From Coq Require Import Bool ZArith Reals Lia Lra.
From Flocq Require Import Core Digits Round Relative.
Require Import Gappa_definitions.
Require Import Gappa_dyadic.
Require Import Gappa_pred_bnd.
Require Import Gappa_round_def.
Require Import Gappa_round_aux.
Require Import Gappa_round.

Global Notation rounding_float rdir p d :=
  (Generic_fmt.round radix2 (FLT_exp d (Zpos p)) rdir) (only parsing).

Global Notation rounding_floatx rdir p :=
  (Generic_fmt.round radix2 (FLX_exp (Zpos p)) rdir) (only parsing).

Definition Fmag (xi : FF) :=
  let l := Fopp2 (lower xi) in
  let u := upper xi in
  if Fle2 l u then u else l.

Lemma Fmag_correct :
  forall x xi,
  BND x xi ->
  (Rabs x <= float2R (Fmag xi))%R.
Proof.
intros x xi [Hx1 Hx2].
apply Rabs_le.
unfold Fmag.
case Fle2_spec ; intros H.
- refine (conj _ Hx2).
  apply Rle_trans with (2 := Hx1).
  rewrite <- (Ropp_involutive (lower xi)).
  apply Ropp_le_contravar.
  now rewrite <- Fopp2_correct.
- split.
  now rewrite Fopp2_correct, Ropp_involutive.
  now apply Rlt_le, Rle_lt_trans with (upper xi).
Qed.

Definition float_ulp (p : positive) (d m e : Z) :=
 match m with
 | Zpos n => FLT_exp d (Zpos p) (e + Zpos (digits n))%Z
 | Zneg n => FLT_exp d (Zpos p) (e + Zpos (digits n))%Z
 | Z0 => d
 end.

Lemma float_ulp_correct :
  forall p d m e,
  bpow radix2 (float_ulp p d m e) = ulp radix2 (FLT_exp d (Zpos p)) (F2R (Float radix2 m e)).
Proof.
intros p d m e.
destruct (Z.eq_dec m 0) as [->|Zm].
{ now rewrite F2R_0, ulp_FLT_0. }
rewrite ulp_neq_0 by now apply F2R_neq_0.
apply f_equal.
unfold float_ulp, cexp.
rewrite mag_F2R by easy.
rewrite <- Zdigits_mag by easy.
rewrite Zplus_comm.
destruct m as [|m|m].
easy.
now rewrite digits2_digits.
now rewrite digits2_digits.
Qed.

Definition floatx_ulp (p : positive) (m e : Z) :=
 match m with
 | Zpos n => FLX_exp (Zpos p) (e + Zpos (digits n))%Z
 | Zneg n => FLX_exp (Zpos p) (e + Zpos (digits n))%Z
 | Z0 => Z0
 end.

Lemma float_absolute_ne_sym :
  forall p d x,
  (Rabs (rounding_float rndNE p d x - x) = Rabs (rounding_float rndNE p d (Rabs x) - Rabs x))%R.
Proof.
intros p d x.
destruct (Rle_or_lt 0 x) as [H|H].
rewrite (Rabs_right _ (Rle_ge _ _ H)).
exact (refl_equal _).
rewrite (Rabs_left _ H).
rewrite round_NE_opp.
unfold Rminus.
rewrite <- Ropp_plus_distr.
now rewrite Rabs_Ropp.
Qed.

Lemma float_absolute_zr_sym :
  forall p d x,
  Rabs (rounding_float rndZR p d x - x) = (Rabs x - rounding_float rndDN p d (Rabs x))%R.
Proof.
intros p d x.
destruct (Rle_or_lt 0 x) as [H|H].
- rewrite (Rabs_pos_eq x H).
  rewrite round_ZR_DN by easy.
  assert (H': (Generic_fmt.round radix2 (FLT_exp d (Z.pos p)) Zfloor x <= x)%R).
  2: rewrite Rabs_left1 ; lra.
  apply round_DN_pt.
  now apply FLT_exp_valid.
- rewrite (Rabs_left x H).
  rewrite round_ZR_UP by now apply Rlt_le.
  rewrite round_DN_opp.
  assert (H': (x <= Generic_fmt.round radix2 (FLT_exp d (Z.pos p)) Zceil x)%R).
  2: rewrite Rabs_pos_eq ; lra.
  apply round_UP_pt.
  now apply FLT_exp_valid.
Qed.

Lemma floatx_absolute_ne_sym :
  forall p x,
  (Rabs (rounding_floatx rndNE p x - x) = Rabs (rounding_floatx rndNE p (Rabs x) - Rabs x))%R.
Proof.
intros p x.
destruct (Rle_or_lt 0 x) as [H|H].
rewrite (Rabs_right _ (Rle_ge _ _ H)).
exact (refl_equal _).
rewrite (Rabs_left _ H).
rewrite round_NE_opp.
unfold Rminus.
rewrite <- Ropp_plus_distr.
now rewrite Rabs_Ropp.
Qed.

Local Instance zpos_gt_0 : forall p, Prec_gt_0 (Zpos p).
Proof.
easy.
Qed.

Lemma float_absolute_n_whole :
  forall c p d k x,
  (Rabs x < bpow radix2 k)%R ->
  (Rabs (rounding_float (Znearest c) p d x - x) <= bpow radix2 (FLT_exp d (Zpos p) k - 1))%R.
Proof with auto with typeclass_instances.
intros c p d k x Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, round_0, Rminus_0_r, Rabs_R0...
apply bpow_ge_0.
apply Rle_trans with (/2 * ulp radix2 (FLT_exp d (Zpos p)) x)%R.
apply error_le_half_ulp...
rewrite ulp_neq_0 by easy.
rewrite <- (bpow_plus radix2 (-1)).
apply bpow_le.
unfold Zminus.
rewrite (Zplus_comm _ (-1)).
apply Zplus_le_compat_l.
unfold cexp.
apply monotone_exp...
now apply mag_le_bpow.
Qed.

Lemma float_absolute_whole :
  forall m, Valid_rnd m ->
  forall p d k x,
  (Rabs x < bpow radix2 k)%R ->
  (Rabs (rounding_float m p d x - x) <= bpow radix2 (FLT_exp d (Zpos p) k))%R.
Proof with auto with typeclass_instances.
intros m Hm p d k x Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, round_0, Rminus_0_r, Rabs_R0...
apply bpow_ge_0.
apply Rle_trans with (ulp radix2 (FLT_exp d (Zpos p)) x).
apply error_le_ulp...
rewrite ulp_neq_0 by easy.
apply bpow_le.
unfold cexp.
apply monotone_exp...
now apply mag_le_bpow.
Qed.

Lemma floatx_absolute_n_whole :
  forall c p k x,
  (Rabs x < bpow radix2 k)%R ->
  (Rabs (rounding_floatx (Znearest c) p x - x) <= bpow radix2 (FLX_exp (Zpos p) k - 1))%R.
Proof with auto with typeclass_instances.
intros c p k x Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, round_0, Rminus_0_r, Rabs_R0...
apply bpow_ge_0.
apply Rle_trans with (/2 * ulp radix2 (FLX_exp (Zpos p)) x)%R.
apply error_le_half_ulp...
rewrite ulp_neq_0; trivial.
rewrite <- (bpow_plus radix2 (-1)).
apply bpow_le.
unfold Zminus.
rewrite (Zplus_comm _ (-1)).
apply Zplus_le_compat_l.
unfold cexp.
apply monotone_exp...
now apply mag_le_bpow.
Qed.

Lemma float_absolute_inv_n_whole :
  forall c p d k x,
  (Rabs (rounding_float (Znearest c) p d x) < bpow radix2 k)%R ->
  (Rabs (rounding_float (Znearest c) p d x - x) <= bpow radix2 (FLT_exp d (Zpos p) k - 1))%R.
Proof with auto with typeclass_instances.
intros c p d k x Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, round_0, Rminus_0_r, Rabs_R0...
apply bpow_ge_0.
apply Rle_trans with (/2 * ulp radix2 (FLT_exp d (Zpos p)) x)%R.
apply error_le_half_ulp...
rewrite ulp_neq_0; trivial.
rewrite <- (bpow_plus radix2 (-1)).
apply bpow_le.
unfold Zminus.
rewrite (Zplus_comm _ (-1)).
apply Zplus_le_compat_l.
unfold cexp.
destruct (Zle_or_lt (mag radix2 x) k) as [Hk1|Hk1].
apply monotone_exp...
destruct (Zle_or_lt (mag radix2 x) d) as [Hk2|Hk2].
unfold FLT_exp.
clear -Hk1 Hk2 ; zify ; lia.
elim Rlt_not_le with (1 := Hx) ; clear Hx.
apply Rle_trans with (bpow radix2 (Z.max k d)).
apply bpow_le.
apply Z.le_max_l.
apply abs_round_ge_generic...
apply generic_format_bpow.
unfold FLT_exp.
clear ; zify ; lia.
destruct (mag radix2 x) as (ex,Ex) ; simpl in *.
apply Rle_trans with (2 := proj1 (Ex Hx0)).
apply bpow_le.
clear -Hk1 Hk2 ; zify ; lia.
Qed.

Lemma floatx_absolute_inv_n_whole :
  forall c p k x,
  (Rabs (rounding_floatx (Znearest c) p x) < bpow radix2 k)%R ->
  (Rabs (rounding_floatx (Znearest c) p x - x) <= bpow radix2 (FLX_exp (Zpos p) k - 1))%R.
Proof with auto with typeclass_instances.
intros c p k x Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, round_0, Rminus_0_r, Rabs_R0...
apply bpow_ge_0.
apply Rle_trans with (/2 * ulp radix2 (FLX_exp (Zpos p)) x)%R.
apply error_le_half_ulp...
rewrite ulp_neq_0; trivial.
rewrite <- (bpow_plus radix2 (-1)).
apply bpow_le.
unfold Zminus.
rewrite (Zplus_comm _ (-1)).
apply Zplus_le_compat_l.
unfold cexp.
apply monotone_exp...
destruct (Zle_or_lt (mag radix2 x) k) as [Hk1|Hk1].
exact Hk1.
elim Rlt_not_le with (1 := Hx) ; clear Hx.
apply abs_round_ge_generic...
apply generic_format_bpow.
unfold FLX_exp.
clear ; zify ; lia.
destruct (mag radix2 x) as (ex,Ex) ; simpl in *.
apply Rle_trans with (2 := proj1 (Ex Hx0)).
apply bpow_le.
clear -Hk1 ; lia.
Qed.

Lemma Zmax_inf_l :
 forall m n : Z, (n <= m)%Z -> Z.max m n = m.
intros m n H.
generalize (Z.le_ge _ _ H).
unfold Z.max, Z.ge.
case (m ?= n)%Z ; intros ; try exact (refl_equal _).
elim H0.
exact (refl_equal _).
Qed.

Lemma float_relative_n_whole :
  forall c p d x,
  (bpow radix2 (d + Zpos p - 1) <= Rabs x)%R ->
  (Rabs ((rounding_float (Znearest c) p d x - x) / x) <= bpow radix2 (-Zpos p))%R.
Proof.
intros c p d x Hx.
assert (Hx0: x <> 0%R).
{ intros Hx0.
  apply Rle_not_lt with (1 := Hx).
  rewrite Hx0, Rabs_R0.
  apply bpow_gt_0. }
destruct (relative_error_N_FLT_ex radix2 d (Zpos p) (refl_equal _) c x Hx) as (eps, (Hr1, Hr2)).
rewrite Hr2.
replace ((x * (1 + eps) - x) / x)%R with eps by now field.
revert Hr1.
rewrite <- (bpow_plus radix2 (-1)%Z).
now rewrite (Zplus_comm (- Zpos p)), Zplus_assoc.
Qed.

Lemma float_relative_inv_n_whole :
  forall c p d x,
  (bpow radix2 (d + Zpos p - 1) < Rabs (rounding_float (Znearest c) p d x))%R ->
  (Rabs ((rounding_float (Znearest c) p d x - x) / x) <= bpow radix2 (-Zpos p))%R.
Proof with auto with typeclass_instances.
intros c p d x Hx.
apply float_relative_n_whole.
apply Rnot_lt_le.
contradict Hx.
apply Rle_not_lt.
apply abs_round_le_generic...
apply generic_format_bpow.
unfold FLT_exp.
ring_simplify (d + Zpos p - 1 + 1 - Zpos p)%Z.
rewrite Zmax_idempotent.
clear ; zify ; lia.
now apply Rlt_le.
Qed.

Lemma float_relative_whole :
  forall m, Valid_rnd m ->
  forall p d x,
  (bpow radix2 (d + Zpos p - 1) <= Rabs x)%R ->
  (Rabs ((rounding_float m p d x - x) / x) <= bpow radix2 (-Zpos p + 1))%R.
Proof.
intros m Hm p d x Hx.
assert (Hx0: x <> 0%R).
{ intros Hx0.
  apply Rle_not_lt with (1 := Hx).
  rewrite Hx0, Rabs_R0.
  apply bpow_gt_0. }
destruct (relative_error_FLT_ex radix2 d (Zpos p) (refl_equal _) m x Hx) as [eps [Hr1 Hr2]].
rewrite Hr2.
replace ((x * (1 + eps) - x) / x)%R with eps by now field.
now apply Rlt_le.
Qed.

Lemma float_relative_zr_whole :
  forall p d x,
  (x <> 0)%R ->
  (((rounding_float rndZR p d x - x) / x) <= 0)%R.
Proof with eauto with typeclass_instances.
intros p d x Zx.
destruct (Rle_or_lt 0 x) as [Hx|Hx].
- apply Rmult_le_reg_r with x.
  lra.
  apply Rplus_le_reg_r with x.
  replace (0 * x + x)%R with x by ring.
  replace (_ / x * x + x)%R with (Generic_fmt.round radix2 (FLT_exp d (Z.pos p)) Ztrunc x) by now field.
  rewrite round_ZR_DN by easy.
  apply round_DN_pt...
- apply Rmult_le_reg_r with (-x)%R.
  lra.
  apply Rplus_le_reg_r with (-x)%R.
  replace (0 * -x + -x)%R with (-x)%R by ring.
  replace (_ / x * -x + -x)%R with (- Generic_fmt.round radix2 (FLT_exp d (Z.pos p)) Ztrunc x)%R by now field.
  apply Ropp_le_contravar.
  rewrite round_ZR_UP by now apply Rlt_le.
  apply round_UP_pt...
Qed.

Theorem fix_of_float :
  forall rdir x p k1 k2,
  Zle_bool k2 k1 = true ->
  FIX (rounding_float rdir p k1 x) k2.
Proof.
intros rdir x p k1 k2 H.
generalize (Zle_bool_imp_le _ _ H). clear H. intro H.
unfold FIX.
eexists (Float2 _ _) ; repeat split.
simpl.
unfold cexp.
apply Z.le_trans with (1 := H).
apply Z.le_max_r.
Qed.

Theorem flt_of_float :
  forall rdir {Hrnd : Valid_rnd rdir} x p1 p2 k,
  Zle_bool (Zpos p1) (Zpos p2) = true ->
  FLT (rounding_float rdir p1 k x) p2.
Proof with auto with typeclass_instances.
intros rdir Hrnd x p1 p2 k H.
generalize (Zle_bool_imp_le _ _ H). clear H. intro H.
unfold FLT.
destruct (FLT_format_generic radix2 k (Zpos p1) (Generic_fmt.round radix2 (FLT_exp k (Zpos p1)) rdir x))
  as ((m, e), H1, H2, _).
apply generic_format_round...
rewrite H1.
eexists (Float2 _ _) ; repeat split.
apply Z.lt_le_trans with (1 := H2).
change (Zpower_pos 2 p2) with (Zpower radix2 (Zpos p2)).
now apply Zpower_le.
Qed.

Theorem flt_of_floatx :
  forall rdir {Hrnd : Valid_rnd rdir} x p1 p2,
  Zle_bool (Zpos p1) (Zpos p2) = true ->
  FLT (rounding_floatx rdir p1 x) p2.
Proof with auto with typeclass_instances.
intros rdir Hrnd x p1 p2 H.
generalize (Zle_bool_imp_le _ _ H). clear H. intro H.
unfold FLT.
destruct (FLX_format_generic radix2 (Zpos p1) (Generic_fmt.round radix2 (FLX_exp (Zpos p1)) rdir x))
  as ((m, e), H1, H2).
apply generic_format_round...
rewrite H1.
eexists (Float2 _ _) ; repeat split.
apply Z.lt_le_trans with (1 := H2).
change (Zpower_pos 2 p2) with (Zpower radix2 (Zpos p2)).
now apply Zpower_le.
Qed.

Theorem float_of_fix_flt :
  forall rdir {Hrnd : Valid_rnd rdir},
  forall x : R,
  forall d1 d2 : Z, forall p1 p2 : positive,
  FIX x d1 -> FLT x p1 ->
  Zle_bool d2 d1 && Zle_bool (Zpos p1) (Zpos p2) = true ->
  rounding_float rdir p2 d2 x = x.
Proof with auto with typeclass_instances.
intros rdir Hrnd x d1 d2 p1 p2 (f1,(Hx1,Hx2)) (f2,(Hx3,Hx4)) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Zle_bool_imp_le _ _ H1). clear H1. intro H1.
generalize (Zle_bool_imp_le _ _ H2). clear H2. intro H2.
apply round_generic...
destruct f1 as (m1, e1).
destruct f2 as (m2, e2).
destruct (Z.eq_dec m2 0) as [Hm|Hm].
rewrite <- Hx3.
unfold float2R.
rewrite Hm, F2R_0.
apply generic_format_0.
assert (mag radix2 (F2R (Float radix2 m2 e2)) <= Zpos p2 + e2)%Z.
rewrite mag_F2R with (1 := Hm).
apply Zplus_le_compat_r.
apply Z.le_trans with (2 := H2).
apply bpow_lt_bpow with radix2.
destruct (mag radix2 (IZR m2)) as (n2, Hn).
simpl.
specialize (Hn (IZR_neq _ _ Hm)).
apply Rle_lt_trans with (1 := proj1 Hn).
rewrite <- abs_IZR.
now apply IZR_lt.
destruct (Zle_or_lt e1 e2) as [He|He].
(* *)
rewrite <- Hx3.
apply generic_format_F2R.
intros _ ; simpl.
apply Z.max_lub.
clear -H ; lia.
apply Z.le_trans with (1 := H1).
now apply Z.le_trans with e1.
(* *)
rewrite <- Hx1.
apply generic_format_F2R.
intros _ ; simpl.
apply Z.max_lub.
unfold float2R in Hx1. simpl in Hx1.
rewrite Hx1, <- Hx3.
unfold float2R. simpl.
lia.
now apply Z.le_trans with d1.
Qed.

Theorem floatx_of_flt :
  forall rdir {Hrnd : Valid_rnd rdir},
  forall x : R,
  forall p1 p2 : positive,
  FLT x p1 ->
  Zle_bool (Zpos p1) (Zpos p2) = true ->
  rounding_floatx rdir p2 x = x.
Proof with auto with typeclass_instances.
intros rdir Hrnd x p1 p2 [[m e] [Hx1 Hx2]] Hb.
generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1.
apply round_generic...
rewrite <- Hx1.
apply generic_format_F2R.
unfold cexp.
intros Hm ; simpl.
rewrite mag_F2R with (1 := Hm).
simpl.
unfold FLX_exp.
cut (mag radix2 (IZR m) <= Zpos p1)%Z.
clear -H1 ; lia.
apply bpow_lt_bpow with radix2.
destruct (mag radix2 (IZR m)) as [n Hn].
simpl.
specialize (Hn (IZR_neq _ _ Hm)).
apply Rle_lt_trans with (1 := proj1 Hn).
rewrite <- abs_IZR.
now apply IZR_lt.
Qed.

Local Existing Instance valid_rnd_Gf.

Definition round_helper (rnd : float2 -> float2) (xi zi : FF) :=
 Fle2 (lower zi) (rnd (lower xi)) &&
 Fle2 (rnd (upper xi)) (upper zi).

Theorem float_round :
  forall rdir p d x xi zi,
  BND x xi ->
  round_helper (round (rndG_g rdir) (FLT_exp d (Zpos p))) xi zi = true ->
  BND (rounding_float (rndG_f rdir) p d x) zi.
Proof with auto with typeclass_instances.
intros rdir p d x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). rewrite rndG_conversion. clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite rndG_conversion. clear H2. intro H2.
split.
apply Rle_trans with (1 := H1).
apply round_le...
apply Hx.
apply Rle_trans with (2 := H2).
apply round_le...
apply Hx.
Qed.

Definition float_round_dn := float_round roundDN_cs.
Definition float_round_up := float_round roundUP_cs.
Definition float_round_zr := float_round roundZR_cs.
Definition float_round_ne := float_round roundNE_cs.
Definition float_round_na := float_round roundNA_cs.

Theorem floatx_round :
  forall rdir p x xi zi,
  BND x xi ->
  round_helper (round (rndG_g rdir) (FLX_exp (Zpos p))) xi zi = true ->
  BND (rounding_floatx (rndG_f rdir) p x) zi.
Proof with auto with typeclass_instances.
intros rdir p x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). rewrite rndG_conversion. clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite rndG_conversion. clear H2. intro H2.
split.
apply Rle_trans with (1 := H1).
apply round_le...
apply Hx.
apply Rle_trans with (2 := H2).
apply round_le...
apply Hx.
Qed.

Definition floatx_round_dn := floatx_round roundDN_cs.
Definition floatx_round_up := floatx_round roundUP_cs.
Definition floatx_round_zr := floatx_round roundZR_cs.
Definition floatx_round_ne := floatx_round roundNE_cs.
Definition floatx_round_na := floatx_round roundNA_cs.

Definition enforce_helper (fexp : Z -> Z) (xi zi : FF) :=
 Fle2 (lower zi) (round roundUP fexp (lower xi)) &&
 Fle2 (round roundDN fexp (upper xi)) (upper zi).

Theorem float_enforce :
  forall rdir {Hrnd : Valid_rnd rdir} p d x xi zi,
  BND (rounding_float rdir p d x) xi ->
  enforce_helper (FLT_exp d (Zpos p)) xi zi = true ->
  BND (rounding_float rdir p d x) zi.
Proof with auto with typeclass_instances.
intros rdir Hrnd p d x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). rewrite (rndG_conversion roundUP_cs). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite (rndG_conversion roundDN_cs). clear H2. intro H2.
revert Hx.
intros (Hx1, Hx2).
split.
apply Rle_trans with (1 := H1).
rewrite <- (round_generic _ _ rndUP _ (generic_format_round radix2 (FLT_exp d (Zpos p)) rdir x)).
apply round_le...
apply Rle_trans with (2 := H2).
rewrite <- (round_generic _ _ rndDN _ (generic_format_round radix2 (FLT_exp d (Zpos p)) rdir x)).
apply round_le...
Qed.

Theorem floatx_enforce :
  forall rdir {Hrnd : Valid_rnd rdir} p x xi zi,
  BND (rounding_floatx rdir p x) xi ->
  enforce_helper (FLX_exp (Zpos p)) xi zi = true ->
  BND (rounding_floatx rdir p x) zi.
Proof with auto with typeclass_instances.
intros rdir Hrnd p x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). rewrite (rndG_conversion roundUP_cs). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite (rndG_conversion roundDN_cs). clear H2. intro H2.
revert Hx.
intros (Hx1, Hx2).
split.
apply Rle_trans with (1 := H1).
rewrite <- (round_generic _ _ rndUP _ (generic_format_round radix2 (FLX_exp (Zpos p)) rdir x)).
apply round_le...
apply Rle_trans with (2 := H2).
rewrite <- (round_generic _ _ rndDN _ (generic_format_round radix2 (FLX_exp (Zpos p)) rdir x)).
apply round_le...
Qed.

Definition float_absolute_n_helper (p : positive) (d : Z) (xi : FF) (zi : FF) :=
 let u := upper xi in
 let e := (float_ulp p d (Fnum u) (Fexp u) - 1)%Z in
 Fle2 (lower zi) (Float2 (-1) e) &&
 Fle2 (Float2 1 e) (upper zi).

Theorem float_absolute_n :
  forall c p d x xi zi,
  ABS x xi ->
  float_absolute_n_helper p d xi zi = true ->
  BND (rounding_float (Znearest c) p d x - x) zi.
Proof with auto with typeclass_instances.
intros c p d x xi zi Hx Hb.
assert (H: (Rabs (rounding_float (Znearest c) p d x - x) <= bpow radix2 (float_ulp p d (Fnum (upper xi)) (Fexp (upper xi)) - 1))%R).
(* *)
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, round_0, Rminus_0_r, Rabs_R0...
apply bpow_ge_0.
replace (bpow radix2 (float_ulp p d (Fnum (upper xi)) (Fexp (upper xi)) - 1)) with (/2 * ulp radix2 (FLT_exp d (Zpos p)) (upper xi))%R.
(* . *)
apply Rle_trans with (/2 * ulp radix2 (FLT_exp d (Zpos p)) x)%R.
apply error_le_half_ulp...
apply Rmult_le_compat_l.
apply Rlt_le.
apply Rinv_0_lt_compat.
now apply IZR_lt.
rewrite <- ulp_abs.
apply ulp_le_pos...
apply Rabs_pos.
apply Hx.
(* . *)
unfold Z.sub.
rewrite bpow_plus, Rmult_comm.
apply Rmult_eq_compat_r.
apply eq_sym, float_ulp_correct.
(* *)
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). clear H2. intro H2.
split.
apply Rle_trans with (1 := H1).
unfold float2R.
rewrite (F2R_Zopp _ 1%Z).
rewrite F2R_bpow.
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply (Rle_trans _ _ _ (Rabs_idem _)).
now rewrite Rabs_Ropp.
apply Rle_trans with (2 := H2).
unfold float2R.
rewrite F2R_bpow.
now apply (Rle_trans _ _ _ (Rabs_idem _)).
Qed.

Definition float_absolute_ne := float_absolute_n (fun x => negb (Z.even x)).
Definition float_absolute_na := float_absolute_n (Zle_bool 0).

Definition float_absolute_zr_helper (p : positive) (d : Z) (xi : FF) (zi : FF) :=
 (if Fneg0 (upper xi) then
   Fneg0 (lower zi)
  else
   let u := upper xi in
   let e := float_ulp p d (Fnum u) (Fexp u) in
   Fle2 (lower zi) (Float2 (-1) e)) &&
 (if Fpos0 (lower xi) then
   Fpos0 (upper zi)
  else
   let l := lower xi in
   let e := float_ulp p d (Fnum l) (Fexp l) in
   Fle2 (Float2 1 e) (upper zi)).

Theorem float_absolute_zr :
  forall p d x xi zi,
  BND x xi ->
  float_absolute_zr_helper p d xi zi = true ->
  BND (rounding_float rndZR p d x - x) zi.
Proof with auto with typeclass_instances.
intros p d x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros [H1 H2].
assert (Hz: (lower zi <= 0 <= upper zi)%R).
{ split.
  - destruct (Fneg0 (upper xi)).
    now apply Fneg0_correct.
    apply Rle_trans with (1 := Fle2_correct _ _ H1).
    now apply F2R_le_0.
  - destruct (Fpos0 (lower xi)).
    now apply Fpos0_correct.
    apply Rle_trans with (2 := Fle2_correct _ _ H2).
    now apply F2R_ge_0. }
destruct (Rle_or_lt 0 x) as [[Sx|Sx]|Sx].
- rewrite round_ZR_DN by now apply Rlt_le.
  split.
  2: {
    apply Rle_trans with (2 := proj2 Hz).
    apply Rle_minus.
    apply round_DN_pt... }
  destruct (Fneg0 (upper xi)) eqn:Hxu.
  { elim Rlt_not_le with (1 := Sx).
    apply Rle_trans with (1 := proj2 Hx).
    now apply Fneg0_correct. }
  apply Rle_trans with (1 := Fle2_correct _ _ H1).
  unfold float2R.
  rewrite (F2R_Zopp _ 1), F2R_bpow.
  simpl.
  rewrite float_ulp_correct.
  apply Ropp_le_cancel.
  rewrite Ropp_involutive.
  apply (Rle_trans _ _ _ (Rabs_idem _)).
  rewrite Rabs_Ropp.
  apply Rle_trans with (ulp radix2 (FLT_exp d (Z.pos p)) x).
  apply error_le_ulp...
  apply ulp_le...
  rewrite (Rabs_pos_eq x) by now apply Rlt_le.
  apply Rle_trans with (1 := proj2 Hx).
  apply Rabs_idem.
- rewrite <- Sx, round_0...
  now rewrite Rminus_0_r.
- rewrite round_ZR_UP by now apply Rlt_le.
  split.
  { apply Rle_trans with (1 := proj1 Hz).
    apply Rle_0_minus.
    apply round_UP_pt... }
  destruct (Fpos0 (lower xi)) eqn:Hxl.
  { elim Rlt_not_le with (1 := Sx).
    apply Rle_trans with (2 := proj1 Hx).
    now apply Fpos0_correct. }
  apply Rle_trans with (2 := Fle2_correct _ _ H2).
  unfold float2R.
  rewrite F2R_bpow.
  simpl.
  rewrite float_ulp_correct.
  apply (Rle_trans _ _ _ (Rabs_idem _)).
  apply Rle_trans with (ulp radix2 (FLT_exp d (Z.pos p)) x).
  apply error_le_ulp...
  apply ulp_le...
  rewrite (Rabs_left x) by easy.
  rewrite Rabs_left1.
  apply Ropp_le_contravar.
  apply Hx.
  apply Rle_trans with (1 := proj1 Hx).
  now apply Rlt_le.
Qed.

Definition float_absolute_up_helper (p : positive) (d : Z) (xi : FF) (zi : FF) :=
 let u := Fmag xi in
 let e := float_ulp p d (Fnum u) (Fexp u) in
 Fneg0 (lower zi) &&
 Fle2 (Float2 1 e) (upper zi).

Theorem float_absolute_up :
  forall p d x xi zi,
  BND x xi ->
  float_absolute_up_helper p d xi zi = true ->
  BND (rounding_float rndUP p d x - x) zi.
Proof with auto with typeclass_instances.
intros p d x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fneg0_correct _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). unfold float2R at 1. simpl. rewrite F2R_bpow. clear H2. intro H2.
apply Fmag_correct in Hx.
split.
{ apply Rle_trans with (1 := H1).
  apply Rle_0_minus.
  apply round_UP_pt... }
apply Rle_trans with (2 := H2).
rewrite float_ulp_correct.
apply Rle_trans with (ulp radix2 (FLT_exp d (Z.pos p)) x).
- rewrite <- (Rabs_pos_eq (Generic_fmt.round _ _ _ x - x)).
  apply error_le_ulp...
  apply Rle_0_minus.
  apply round_UP_pt...
- apply ulp_le...
  rewrite (Rabs_pos_eq (F2R _)).
  apply Hx.
  apply Rle_trans with (2 := Hx).
  apply Rabs_pos.
Qed.

Definition float_absolute_dn_helper (p : positive) (d : Z) (xi : FF) (zi : FF) :=
 let u := Fmag xi in
 let e := float_ulp p d (Fnum u) (Fexp u) in
 Fle2 (lower zi) (Float2 (-1) e) &&
 Fpos0 (upper zi).

Theorem float_absolute_dn :
  forall p d x xi zi,
  BND x xi ->
  float_absolute_dn_helper p d xi zi = true ->
  BND (rounding_float rndDN p d x - x) zi.
Proof with auto with typeclass_instances.
intros p d x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). unfold float2R at 2. simpl. rewrite (F2R_Zopp _ 1), F2R_bpow. clear H1. intro H1.
generalize (Fpos0_correct _ H2). clear H2. intro H2.
apply Fmag_correct in Hx.
assert (H: (Generic_fmt.round radix2 (FLT_exp d (Z.pos p)) Zfloor x - x <= 0)%R).
{ cut (Generic_fmt.round radix2 (FLT_exp d (Z.pos p)) Zfloor x <= x)%R.
  lra.
  apply round_DN_pt... }
split.
2: now apply Rle_trans with (2 := H2).
apply Rle_trans with (1 := H1).
rewrite float_ulp_correct.
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply Rle_trans with (ulp radix2 (FLT_exp d (Z.pos p)) x).
- rewrite <- Rabs_left1 by easy.
  apply error_le_ulp...
- apply ulp_le...
  rewrite (Rabs_pos_eq (F2R _)).
  apply Hx.
  apply Rle_trans with (2 := Hx).
  apply Rabs_pos.
Qed.

Definition floatx_absolute_n_helper (p : positive) (xi : FF) (zi : FF) :=
 let u := upper xi in
 let e := (floatx_ulp p (Fnum u) (Fexp u) - 1)%Z in
 Fle2 (lower zi) (Float2 (-1) e) &&
 Fle2 (Float2 1 e) (upper zi).

Theorem floatx_absolute_n :
  forall c p x xi zi,
  ABS x xi ->
  floatx_absolute_n_helper p xi zi = true ->
  BND (rounding_floatx (Znearest c) p x - x) zi.
Proof with auto with typeclass_instances.
intros c p x xi zi Hx Hb.
assert (H: (Rabs (rounding_floatx (Znearest c) p x - x) <= bpow radix2 (floatx_ulp p (Fnum (upper xi)) (Fexp (upper xi)) - 1))%R).
(* *)
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, round_0, Rminus_0_r, Rabs_R0...
apply bpow_ge_0.
replace (bpow radix2 (floatx_ulp p (Fnum (upper xi)) (Fexp (upper xi)) - 1)) with (/2 * ulp radix2 (FLX_exp (Zpos p)) (upper xi))%R.
(* . *)
apply Rle_trans with (/2 * ulp radix2 (FLX_exp (Zpos p)) x)%R.
apply error_le_half_ulp...
apply Rmult_le_compat_l.
apply Rlt_le.
apply Rinv_0_lt_compat.
now apply IZR_lt.
rewrite <- ulp_abs.
apply ulp_le_pos...
apply Rabs_pos.
apply Hx.
(* . *)
assert (Hm0: (Fnum (upper xi)) <> Z0).
assert (Hx1 := Rabs_no_R0 _ Hx0).
contradict Hx1.
apply Rle_antisym.
replace 0%R with (float2R (upper xi)).
apply Hx.
clear -Hx1.
destruct (upper xi).
simpl in Hx1.
rewrite Hx1.
apply float2_zero.
apply Rabs_pos.
rewrite ulp_neq_0.
2: now apply F2R_neq_0.
rewrite <- (bpow_plus radix2 (-1)).
unfold Zminus.
rewrite (Zplus_comm _ (-1)).
apply (f_equal (fun e => bpow radix2 (-1 + e))).
clear -Hm0.
destruct (upper xi) as (m, e).
unfold cexp, float2R.
rewrite mag_F2R with (1 := Hm0).
rewrite <- Zdigits_mag with (1 := Hm0).
simpl.
rewrite <- Zdigits_abs.
rewrite Zplus_comm.
destruct m as [|m|m] ; unfold Z.abs.
now elim Hm0.
now rewrite <- digits2_digits.
now rewrite <- digits2_digits.
(* *)
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). clear H2. intro H2.
split.
apply Rle_trans with (1 := H1).
unfold float2R.
rewrite (F2R_Zopp _ 1%Z).
rewrite F2R_bpow.
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply (Rle_trans _ _ _ (Rabs_idem _)).
now rewrite Rabs_Ropp.
apply Rle_trans with (2 := H2).
unfold float2R.
rewrite F2R_bpow.
now apply (Rle_trans _ _ _ (Rabs_idem _)).
Qed.

Definition floatx_absolute_ne := floatx_absolute_n (fun x => negb (Z.even x)).
Definition floatx_absolute_na := floatx_absolute_n (Zle_bool 0).

Theorem float_absolute_inv_n :
  forall c p d x xi zi,
  ABS (rounding_float (Znearest c) p d x) xi ->
  float_absolute_n_helper p d xi zi = true ->
  BND (rounding_float (Znearest c) p d x - x) zi.
Proof with auto with typeclass_instances.
intros c p d x xi zi Hx Hb.
assert (H: (Rabs (rounding_float (Znearest c) p d x - x) <= bpow radix2 (float_ulp p d (Fnum (upper xi)) (Fexp (upper xi)) - 1))%R).
(* *)
replace (float_ulp p d (Fnum (upper xi)) (Fexp (upper xi))) with
  (FLT_exp d (Zpos p) (if Z.eq_dec (Fnum (upper xi)) Z0 then d else (Fexp (upper xi) + Zpos (digits (pos_of_Z (Z.abs (Fnum (upper xi))))))%Z)).
apply float_absolute_inv_n_whole.
apply Rle_lt_trans with (1 := proj2 (proj2 Hx)).
unfold float2R.
case Z.eq_dec ; intros Zx.
rewrite Zx, F2R_0.
apply bpow_gt_0.
rewrite digits2_digits.
rewrite Zpos_pos_of_Z.
rewrite Zdigits_abs, Zplus_comm.
rewrite <- mag_F2R_Zdigits with (1 := Zx).
destruct mag as (ex,Ex) ; simpl.
apply Rle_lt_trans with (1 := RRle_abs _).
apply Ex.
contradict Zx.
apply eq_0_F2R with (1 := Zx).
clear -Zx ; zify ; lia.
unfold float_ulp.
case Z.eq_dec ; intros Zx.
rewrite Zx.
unfold FLT_exp.
clear ; zify ; lia.
revert Zx.
case Fnum ; simpl ; [|easy|easy].
intros H.
now elim H.
(* *)
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). clear H2. intro H2.
split.
apply Rle_trans with (1 := H1).
unfold float2R.
rewrite (F2R_Zopp _ 1%Z).
rewrite F2R_bpow.
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply (Rle_trans _ _ _ (Rabs_idem _)).
now rewrite Rabs_Ropp.
apply Rle_trans with (2 := H2).
unfold float2R.
rewrite F2R_bpow.
now apply (Rle_trans _ _ _ (Rabs_idem _)).
Qed.

Definition float_absolute_inv_ne := float_absolute_inv_n (fun x => negb (Z.even x)).
Definition float_absolute_inv_na := float_absolute_inv_n (Zle_bool 0).

Theorem float_absolute_inv_up :
  forall p d x xi zi,
  BND (rounding_float rndUP p d x) xi ->
  float_absolute_up_helper p d xi zi = true ->
  BND (rounding_float rndUP p d x - x) zi.
Proof with auto with typeclass_instances.
intros p d x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fneg0_correct _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). unfold float2R at 1. simpl. rewrite F2R_bpow. clear H2. intro H2.
apply Fmag_correct in Hx.
split.
{ apply Rle_trans with (1 := H1).
  apply Rle_0_minus.
  apply round_UP_pt... }
apply Rle_trans with (2 := H2).
rewrite float_ulp_correct.
apply Rle_trans with (ulp radix2 (FLT_exp d (Z.pos p)) (Generic_fmt.round radix2 (FLT_exp d (Z.pos p)) Zceil x)).
- rewrite <- (Rabs_pos_eq (Generic_fmt.round _ _ _ x - x)).
  apply error_le_ulp_round...
  apply Rle_0_minus.
  apply round_UP_pt...
- apply ulp_le...
  rewrite (Rabs_pos_eq (F2R _)).
  apply Hx.
  apply Rle_trans with (2 := Hx).
  apply Rabs_pos.
Qed.

Theorem float_absolute_inv_dn :
  forall p d x xi zi,
  BND (rounding_float rndDN p d x) xi ->
  float_absolute_dn_helper p d xi zi = true ->
  BND (rounding_float rndDN p d x - x) zi.
Proof with auto with typeclass_instances.
intros p d x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). unfold float2R at 2. simpl. rewrite (F2R_Zopp _ 1), F2R_bpow. clear H1. intro H1.
generalize (Fpos0_correct _ H2). clear H2. intro H2.
apply Fmag_correct in Hx.
assert (H: (Generic_fmt.round radix2 (FLT_exp d (Z.pos p)) Zfloor x - x <= 0)%R).
{ cut (Generic_fmt.round radix2 (FLT_exp d (Z.pos p)) Zfloor x <= x)%R.
  lra.
  apply round_DN_pt... }
split.
2: now apply Rle_trans with (2 := H2).
apply Rle_trans with (1 := H1).
rewrite float_ulp_correct.
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply Rle_trans with (ulp radix2 (FLT_exp d (Z.pos p)) (Generic_fmt.round radix2 (FLT_exp d (Z.pos p)) Zfloor x)).
- rewrite <- Rabs_left1 by easy.
  apply error_le_ulp_round...
- apply ulp_le...
  rewrite (Rabs_pos_eq (F2R _)).
  apply Hx.
  apply Rle_trans with (2 := Hx).
  apply Rabs_pos.
Qed.

Definition float_absolute_wide_ne_helper (p : positive) (d : Z) (xi : FF) (zi : FF) :=
 let u := upper xi in
 let e := (float_ulp p d (Fnum u) (Fexp u) - 2)%Z in
 Zle_bool d (Fexp u - Zpos p) &&
 Fle2 u (Float2 (Zpos (xI (shift_pos p xH))) e) &&
 Fle2 (lower zi) (Float2 (-1) e) &&
 Fle2 (Float2 1 e) (upper zi).

Theorem float_absolute_wide_ne :
  forall p d x xi zi,
  ABS x xi ->
  float_absolute_wide_ne_helper p d xi zi = true ->
  BND (rounding_float rndNE p d x - x) zi.
Proof with auto with typeclass_instances.
intros p d x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4).
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Zle_bool_imp_le _ _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). unfold float2R. simpl. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H3. intro H3.
generalize (Fle2_correct _ _ H4). unfold float2R. simpl. rewrite F2R_bpow. clear H4. intro H4.
set (e := (float_ulp p d (Fnum (upper xi)) (Fexp (upper xi)) - 2)%Z) in H2, H3, H4.
cut (Rabs (rounding_float rndNE p d x - x) <= bpow radix2 e)%R.
{ split.
  apply Rle_trans with (1 := H3).
  apply Ropp_le_cancel.
  rewrite Ropp_involutive.
  apply Rle_trans with (2 := H).
  rewrite <- Rabs_Ropp.
  apply Rabs_idem.
  apply Rle_trans with (2 := H4).
  apply Rle_trans with (2 := H).
  apply Rabs_idem. }
destruct Hx as [_ [_ Hx]].
clear H3 H4 zi.
destruct (upper xi) as [xum xue].
cbn in e, H2.
destruct xum as [|xum|xum].
3: {
  elim Rlt_not_le with (2 := Hx).
  apply Rlt_le_trans with (Float2 0 xue).
  now apply F2R_lt.
  unfold float2R.
  rewrite F2R_0.
  apply Rabs_pos. }
{ assert (x = 0%R) as ->.
    rewrite float2_zero in Hx.
    apply Rabs_le_inv in Hx.
    apply Rle_antisym with (1 := proj2 Hx).
    now rewrite <- Ropp_0.
  rewrite round_0...
  rewrite Rminus_0_r.
  rewrite Rabs_R0.
  apply bpow_ge_0. }
simpl in e, H1.
assert (H9: (e = xue + Zpos (digits xum) - Zpos p - 2)%Z).
{ unfold e, FLT_exp.
  rewrite Zmax_inf_l.
  easy.
  generalize (Zgt_pos_0 (digits xum)).
  lia. }
destruct (Rle_or_lt (bpow radix2 (xue + Zpos (digits xum) - 1)) (Rabs x)) as [Hx'|Hx'].
2: {
  replace e with (FLT_exp d (Zpos p) (xue + Zpos (digits xum) - 1) - 1)%Z.
  now apply float_absolute_n_whole.
  rewrite H9.
  unfold FLT_exp.
  assert (H3 := Zgt_pos_0 (digits xum)).
  assert (H4 := Zgt_pos_0 p).
  repeat rewrite Zmax_inf_l ; lia. }
rewrite float_absolute_ne_sym.
apply Rle_trans with (Rabs (bpow radix2 (xue + Z.pos (digits xum) - 1) - Rabs x))%R.
apply round_N_pt.
now apply FLT_exp_valid.
apply generic_format_bpow.
unfold FLT_exp.
clear -H1 ; lia.
rewrite Rabs_minus_sym, Rabs_pos_eq by now apply Rle_0_minus.
apply (Rle_trans _ _ _ Hx) in H2.
cut (F2R (Float radix2 (Zpos (xI (shift_pos p 1))) e) = bpow radix2 e + bpow radix2 (xue + Z.pos (digits xum) - 1))%R.
clear -H2 ; lra.
replace (xue + Zpos (digits xum) - 1)%Z with (Zpos p + 1 + e)%Z by (rewrite H9 ; ring).
rewrite bpow_plus.
unfold F2R.
cbn -[Zplus].
rewrite <- (Rmult_1_l (bpow radix2 e)) at 2.
rewrite <- Rmult_plus_distr_r.
apply Rmult_eq_compat_r.
rewrite <- IZR_Zpower by easy.
rewrite <- plus_IZR.
apply f_equal.
rewrite Zpower_exp by easy.
rewrite Zplus_comm.
cbn.
rewrite <- (Zmult_1_r (Z.pow_pos 2 p)).
rewrite <- shift_pos_correct.
now rewrite Zmult_comm.
Qed.

Definition float_absolute_wide_zr_helper (p : positive) (d : Z) (xi : FF) (zi : FF) :=
 let u := upper xi in
 let e := (float_ulp p d (Fnum u) (Fexp u) - 1)%Z in
 Zle_bool d (Fexp u - Zpos p) &&
 Fle2 u (Float2 (Zpos (shift_pos p xH + 1)) e) &&
 Fle2 (lower zi) (Float2 (-1) e) &&
 Fle2 (Float2 1 e) (upper zi).

Theorem float_absolute_wide_zr :
  forall p d x xi zi,
  ABS x xi -> (* should have been BND, so not quite good *)
  float_absolute_wide_zr_helper p d xi zi = true ->
  BND (rounding_float rndZR p d x - x) zi.
Proof with auto with typeclass_instances.
intros p d x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4).
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Zle_bool_imp_le _ _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). unfold float2R. simpl. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H3. intro H3.
generalize (Fle2_correct _ _ H4). unfold float2R. simpl. rewrite F2R_bpow. clear H4. intro H4.
set (e := (float_ulp p d (Fnum (upper xi)) (Fexp (upper xi)) - 1)%Z) in H2, H3, H4.
cut (Rabs (rounding_float rndZR p d x - x) <= bpow radix2 e)%R.
{ split.
  apply Rle_trans with (1 := H3).
  apply Ropp_le_cancel.
  rewrite Ropp_involutive.
  apply Rle_trans with (2 := H).
  rewrite <- Rabs_Ropp.
  apply Rabs_idem.
  apply Rle_trans with (2 := H4).
  apply Rle_trans with (2 := H).
  apply Rabs_idem. }
destruct Hx as [_ [_ Hx]].
clear H3 H4 zi.
destruct (upper xi) as [xum xue].
cbn in e, H2.
destruct xum as [|xum|xum].
3: {
  elim Rlt_not_le with (2 := Hx).
  apply Rlt_le_trans with (Float2 0 xue).
  now apply F2R_lt.
  unfold float2R.
  rewrite F2R_0.
  apply Rabs_pos. }
{ assert (x = 0%R) as ->.
    rewrite float2_zero in Hx.
    apply Rabs_le_inv in Hx.
    apply Rle_antisym with (1 := proj2 Hx).
    now rewrite <- Ropp_0.
  rewrite round_0...
  rewrite Rminus_0_r.
  rewrite Rabs_R0.
  apply bpow_ge_0. }
simpl in e, H1.
assert (H9: (e = xue + Zpos (digits xum) - Zpos p - 1)%Z).
{ unfold e, FLT_exp.
  rewrite Zmax_inf_l.
  easy.
  generalize (Zgt_pos_0 (digits xum)).
  lia. }
destruct (Rle_or_lt (bpow radix2 (xue + Zpos (digits xum) - 1)) (Rabs x)) as [Hx'|Hx'].
2: {
  replace e with (FLT_exp d (Zpos p) (xue + Zpos (digits xum) - 1))%Z.
  apply float_absolute_whole...
  rewrite H9.
  unfold FLT_exp.
  assert (H3 := Zgt_pos_0 (digits xum)).
  assert (H4 := Zgt_pos_0 p).
  repeat rewrite Zmax_inf_l ; lia. }
apply (Rle_trans _ _ _ Hx) in H2.
rewrite float_absolute_zr_sym.
assert (H5: (bpow radix2 (xue + Z.pos (digits xum) - 1) <= Generic_fmt.round radix2 (FLT_exp d (Z.pos p)) Zfloor (Rabs x))%R).
{ apply round_DN_pt...
  apply generic_format_bpow.
  unfold FLT_exp.
  clear -H1 ; lia. }
cut (F2R (Float radix2 (Zpos (shift_pos p 1 + 1)) e) = bpow radix2 e + bpow radix2 (xue + Z.pos (digits xum) - 1))%R.
clear -H2 H5 ; lra.
replace (xue + Zpos (digits xum) - 1)%Z with (Zpos p + e)%Z by (rewrite H9 ; ring).
rewrite bpow_plus.
unfold F2R.
cbn -[Zplus].
rewrite <- (Rmult_1_l (bpow radix2 e)) at 2.
rewrite <- Rmult_plus_distr_r.
apply Rmult_eq_compat_r.
rewrite <- plus_IZR.
apply f_equal.
rewrite <- (Zmult_1_r (Z.pow_pos 2 p)).
rewrite <- shift_pos_correct.
apply eq_sym, Zplus_comm.
Qed.

Lemma floatx_error_wide_n :
  forall c p x M,
  let e := (floatx_ulp p (Fnum M) (Fexp M) - 2)%Z in
  (Rabs x <= M <= float2R (Float2 (Zpos (xI (shift_pos p xH))) e))%R ->
  (Rabs (Generic_fmt.round radix2 (FLX_exp (Zpos p)) (Znearest c) x - x) <= bpow radix2 e)%R.
Proof with auto with typeclass_instances.
intros c p x M e [Hx He].
destruct M as [xum xue].
cbn in e.
destruct xum as [|xum|xum].
3: {
  elim Rlt_not_le with (2 := Hx).
  apply Rlt_le_trans with (Float2 0 xue).
  now apply F2R_lt.
  unfold float2R.
  rewrite F2R_0.
  apply Rabs_pos. }
{ assert (x = 0%R) as ->.
    rewrite float2_zero in Hx.
    apply Rabs_le_inv in Hx.
    apply Rle_antisym with (1 := proj2 Hx).
    now rewrite <- Ropp_0.
  rewrite round_0...
  rewrite Rminus_0_r.
  rewrite Rabs_R0.
  apply bpow_ge_0. }
simpl in e.
destruct (Rle_or_lt (bpow radix2 (xue + Zpos (digits xum) - 1)) (Rabs x)) as [Hx'|Hx'].
2: {
  replace e with (FLX_exp (Zpos p) (xue + Zpos (digits xum) - 1) - 1)%Z by (unfold e, FLX_exp ; ring).
  now apply floatx_absolute_n_whole.
}
apply Rle_trans with (Rabs (bpow radix2 (xue + Z.pos (digits xum) - 1) - Rabs x))%R.
{ set (xe := (_ - 1)%Z).
  clearbody xe. clear.
  revert c x.
  cut (forall c' x',
    (0 <= x')%R -> (Rabs (Generic_fmt.round radix2 (FLX_exp (Z.pos p)) (Znearest c') x' - x') <=
    Rabs (bpow radix2 xe - x'))%R).
  { intros H c x.
    destruct (Rle_or_lt 0 x) as [Hx|Hx].
    - rewrite (Rabs_pos_eq _ Hx).
      now apply H.
    - rewrite <- (Ropp_involutive x).
      rewrite round_N_opp, Rabs_Ropp.
      rewrite (Rabs_pos_eq (- x)) by lra.
      unfold Rminus.
      rewrite <- Ropp_plus_distr, Rabs_Ropp.
      apply H.
      lra. }
  intros c x Hx.
  apply round_N_pt.
  now apply FLX_exp_valid.
  apply generic_format_bpow.
  unfold FLX_exp.
  lia. }
rewrite Rabs_minus_sym, Rabs_pos_eq by now apply Rle_0_minus.
apply (Rle_trans _ _ _ Hx) in He.
cut (float2R (Float2 (Zpos (xI (shift_pos p 1))) e) = bpow radix2 e + bpow radix2 (xue + Z.pos (digits xum) - 1))%R.
clear -He ; lra.
replace (xue + Zpos (digits xum) - 1)%Z with (Zpos p + 1 + e)%Z by (unfold e, FLX_exp ; ring).
rewrite bpow_plus.
unfold float2R, F2R.
cbn -[Zplus].
rewrite <- (Rmult_1_l (bpow radix2 e)) at 2.
rewrite <- Rmult_plus_distr_r.
apply Rmult_eq_compat_r.
rewrite <- IZR_Zpower by easy.
rewrite <- plus_IZR.
apply f_equal.
rewrite Zpower_exp by easy.
rewrite Zplus_comm.
cbn.
rewrite <- (Zmult_1_r (Z.pow_pos 2 p)).
rewrite <- shift_pos_correct.
now rewrite Zmult_comm.
Qed.

Definition floatx_absolute_wide_ne_helper (p : positive) (xi : FF) (zi : FF) :=
 let u := upper xi in
 let e := (floatx_ulp p (Fnum u) (Fexp u) - 2)%Z in
 Fle2 u (Float2 (Zpos (xI (shift_pos p xH))) e) &&
 Fle2 (lower zi) (Float2 (-1) e) &&
 Fle2 (Float2 1 e) (upper zi).

Theorem floatx_absolute_wide_n :
  forall c p x xi zi,
  ABS x xi ->
  floatx_absolute_wide_ne_helper p xi zi = true ->
  BND (rounding_floatx (Znearest c) p x - x) zi.
Proof with auto with typeclass_instances.
intros c p x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4).
generalize (andb_prop _ _ Hb). clear Hb. intros (H2,H3).
generalize (Fle2_correct _ _ H2). clear H2. intro H2.
generalize (Fle2_correct _ _ H3). unfold float2R at 2. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H3. intro H3.
generalize (Fle2_correct _ _ H4). unfold float2R at 1. simpl. rewrite F2R_bpow. clear H4. intro H4.
simple refine (let H := floatx_error_wide_n c p x (upper xi) (conj _ H2) in _).
2: clearbody H.
apply Hx.
clear H2.
set (e := (floatx_ulp p (Fnum (upper xi)) (Fexp (upper xi)) - 2)%Z) in H, H3, H4.
split.
- apply Rle_trans with (1 := H3).
  apply Ropp_le_cancel.
  rewrite Ropp_involutive.
  apply Rle_trans with (2 := H).
  rewrite <- Rabs_Ropp.
  apply Rabs_idem.
- apply Rle_trans with (2 := H4).
  apply Rle_trans with (2 := H).
  apply Rabs_idem.
Qed.

Definition floatx_absolute_wide_ne := floatx_absolute_wide_n (fun x => negb (Z.even x)).
Definition floatx_absolute_wide_na := floatx_absolute_wide_n (Zle_bool 0).

Definition float_relative_n_helper (p : positive) (d : Z) (xi zi : FF) :=
 Fle2 (Float2 1 (d + Zpos p - 1)) (lower xi) &&
 Fle2 (lower zi) (Float2 (-1) (Zneg p)) &&
 Fle2 (Float2 1 (Zneg p)) (upper zi).

Theorem float_relative_n :
  forall c p d x xi zi,
  ABS x xi ->
  float_relative_n_helper p d xi zi = true ->
  REL (rounding_float (Znearest c) p d x) x zi.
Proof.
intros c p d x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). unfold float2R. simpl. rewrite F2R_bpow. clear H1. intro H1.
generalize (Fle2_correct _ _ H2). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). unfold float2R. simpl. rewrite F2R_bpow. clear H3. intro H3.
exists ((rounding_float (Znearest c) p d x - x) / x)%R.
split.
assert (Rabs ((rounding_float (Znearest c) p d x - x) / x) <= bpow radix2 (- Zpos p))%R.
apply float_relative_n_whole.
apply Rle_trans with (1 := H1).
apply Hx.
split.
apply Rle_trans with (1 := H2).
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply Rle_trans with (2 := H).
rewrite <- Rabs_Ropp.
apply Rabs_idem.
apply Rle_trans with (2 := H3).
apply Rle_trans with (2 := H).
apply Rabs_idem.
field.
intros H.
apply Rle_not_lt with (1 := H1).
apply Rle_lt_trans with (1 := proj1 (proj2 Hx)).
rewrite H, Rabs_R0.
apply bpow_gt_0.
Qed.

Definition float_relative_ne := float_relative_n (fun x => negb (Z.even x)).
Definition float_relative_na := float_relative_n (Zle_bool 0).

Definition float_relative_helper (p : positive) (d : Z) (xi zi : FF) :=
 Fle2 (Float2 1 (d + Zpos p - 1)) (lower xi) &&
 Fle2 (lower zi) (Float2 (-1) (Zneg p + 1)) &&
 Fle2 (Float2 1 (Zneg p + 1)) (upper zi).

Theorem float_relative :
  forall m, Valid_rnd m ->
  forall p d x xi zi,
  ABS x xi ->
  float_relative_helper p d xi zi = true ->
  REL (rounding_float m p d x) x zi.
Proof.
intros m Hm p d x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). unfold float2R at 1. simpl. rewrite F2R_bpow. clear H1. intro H1.
generalize (Fle2_correct _ _ H2). unfold float2R at 2. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). unfold float2R at 1. simpl. rewrite F2R_bpow. clear H3. intro H3.
exists ((rounding_float m p d x - x) / x)%R.
split.
2: {
  field.
  intros H.
  apply Rle_not_lt with (1 := H1).
  apply Rle_lt_trans with (1 := proj1 (proj2 Hx)).
  rewrite H, Rabs_R0.
  apply bpow_gt_0. }
assert (Rabs ((rounding_float m p d x - x) / x) <= bpow radix2 (- Zpos p + 1))%R.
{ apply float_relative_whole with (1 := Hm).
  apply Rle_trans with (1 := H1).
  apply Hx. }
split.
- apply Rle_trans with (1 := H2).
  apply Ropp_le_cancel.
  rewrite Ropp_involutive.
  apply Rle_trans with (2 := H).
  rewrite <- Rabs_Ropp.
  apply Rabs_idem.
- apply Rle_trans with (2 := H3).
  apply Rle_trans with (2 := H).
  apply Rabs_idem.
Qed.

Definition float_relative_dn := float_relative Zfloor _.
Definition float_relative_up := float_relative Zceil _.

Definition float_relative_zr_helper (p : positive) (d : Z) (xi zi : FF) :=
 Fle2 (Float2 1 (d + Zpos p - 1)) (lower xi) &&
 Fle2 (lower zi) (Float2 (-1) (Zneg p + 1)) &&
 Fpos0 (upper zi).

Theorem float_relative_zr :
  forall p d x xi zi,
  ABS x xi ->
  float_relative_zr_helper p d xi zi = true ->
  REL (rounding_float rndZR p d x) x zi.
Proof.
intros p d x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). unfold float2R at 1. simpl. rewrite F2R_bpow. clear H1. intro H1.
generalize (Fle2_correct _ _ H2). unfold float2R at 2. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H2. intro H2.
generalize (Fpos0_correct _ H3). clear H3. intro H3.
exists ((rounding_float rndZR p d x - x) / x)%R.
split.
2: {
  field.
  intros H.
  apply Rle_not_lt with (1 := H1).
  apply Rle_lt_trans with (1 := proj1 (proj2 Hx)).
  rewrite H, Rabs_R0.
  apply bpow_gt_0. }
assert (Rabs ((rounding_float rndZR p d x - x) / x) <= bpow radix2 (- Zpos p + 1))%R.
{ apply float_relative_whole.
  apply valid_rnd_ZR.
  apply Rle_trans with (1 := H1).
  apply Hx. }
split.
- apply Rle_trans with (1 := H2).
  apply Ropp_le_cancel.
  rewrite Ropp_involutive.
  apply Rle_trans with (2 := H).
  rewrite <- Rabs_Ropp.
  apply Rabs_idem.
- apply Rle_trans with (2 := H3).
  apply float_relative_zr_whole.
  intros Zx.
  apply Rlt_not_le with (2 := H1).
  apply Rle_lt_trans with (1 := proj1 (proj2 Hx)).
  rewrite Zx, Rabs_R0.
  apply bpow_gt_0.
Qed.

Definition floatx_relative_n_helper (p : positive) (zi : FF) :=
 Fle2 (lower zi) (Float2 (-1) (Zneg p)) &&
 Fle2 (Float2 1 (Zneg p)) (upper zi).

Theorem floatx_relative_n :
  forall c p x zi,
  floatx_relative_n_helper p zi = true ->
  REL (rounding_floatx (Znearest c) p x) x zi.
Proof.
intros c p x zi Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H1. intro H1.
generalize (Fle2_correct _ _ H2). unfold float2R. simpl. rewrite F2R_bpow. clear H2. intro H2.
destruct (relative_error_N_FLX_ex radix2 (Zpos p) (refl_equal _) c x) as (eps, (Hr1, Hr2)).
exists eps.
refine (conj _ Hr2).
rewrite <- (bpow_plus radix2 (-1)%Z) in Hr1.
rewrite (Zplus_comm (- Zpos p)), Zplus_assoc in Hr1.
split.
apply Rle_trans with (1 := H1).
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply Rle_trans with (2 := Hr1).
rewrite <- Rabs_Ropp.
apply Rabs_idem.
apply Rle_trans with (2 := H2).
apply Rle_trans with (2 := Hr1).
apply Rabs_idem.
Qed.

Definition floatx_relative_ne := floatx_relative_n (fun x => negb (Z.even x)).
Definition floatx_relative_na := floatx_relative_n (Zle_bool 0).

Definition floatx_relative_aw_helper (p : positive) (zi : FF) :=
 Fneg0 (lower zi) &&
 Fle2 (Float2 1 (Zneg p + 1)) (upper zi).

Theorem floatx_relative_aw :
  forall p x zi,
  floatx_relative_aw_helper p zi = true ->
  REL (rounding_floatx Zaway p x) x zi.
Proof.
intros p x zi Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fneg0_correct _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). unfold float2R. cbn -[Z.add]. rewrite F2R_bpow. clear H2. intro H2.
destruct (relative_error_FLX_ex radix2 (Zpos p) eq_refl Zaway x) as (eps, (Hr1, Hr2)).
destruct (Req_dec x 0) as [->|Zx].
{ exists 0%R.
  split.
  apply (conj (H1)).
  apply Rle_trans with (2 := H2).
  apply bpow_ge_0.
  now rewrite Hr2, 2!Rmult_0_l. }
exists eps.
refine (conj _ Hr2).
split.
2: {
  apply Rle_trans with (2 := H2).
  apply Rabs_lt_inv in Hr1.
  now apply Rlt_le. }
apply Rle_trans with (1 := H1).
apply Rplus_le_reg_l with 1%R.
rewrite Rplus_0_r.
destruct (Rle_or_lt 0 x) as [[Hx|Hx]|Hx].
2: now elim Zx.
- apply Rmult_le_reg_l with (1 := Hx).
  rewrite Rmult_1_r, <- Hr2.
  rewrite round_AW_UP by now apply Rlt_le.
  apply round_UP_pt.
  now apply FLX_exp_valid.
- apply Rmult_le_reg_l with (-x)%R.
  now apply Ropp_gt_lt_0_contravar.
  rewrite <- 2!Ropp_mult_distr_l, Rmult_1_r, <- Hr2.
  apply Ropp_le_contravar.
  rewrite round_AW_DN by now apply Rlt_le.
  apply round_DN_pt.
  now apply FLX_exp_valid.
Qed.

Definition float_relative_inv_n_helper (p : positive) (d : Z) (xi zi : FF) :=
 Flt2 (Float2 1 (d + Zpos p - 1)) (lower xi) &&
 Fle2 (lower zi) (Float2 (-1) (Zneg p)) &&
 Fle2 (Float2 1 (Zneg p)) (upper zi).

Theorem float_relative_inv_n :
  forall c p d x xi zi,
  ABS (rounding_float (Znearest c) p d x) xi ->
  float_relative_inv_n_helper p d xi zi = true ->
  REL (rounding_float (Znearest c) p d x) x zi.
Proof with auto with typeclass_instances.
intros c p d x xi zi Hx Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Flt2_correct _ _ H1). unfold float2R. simpl. rewrite F2R_bpow. clear H1. intro H1.
generalize (Fle2_correct _ _ H2). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). unfold float2R. simpl. rewrite F2R_bpow. clear H3. intro H3.
exists ((rounding_float (Znearest c) p d x - x) / x)%R.
split.
assert (Rabs ((rounding_float (Znearest c) p d x - x) / x) <= bpow radix2 (- Zpos p))%R.
apply float_relative_inv_n_whole.
apply Rlt_le_trans with (1 := H1).
apply Hx.
split.
apply Rle_trans with (1 := H2).
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply Rle_trans with (2 := H).
rewrite <- Rabs_Ropp.
apply Rabs_idem.
apply Rle_trans with (2 := H3).
apply Rle_trans with (2 := H).
apply Rabs_idem.
field.
intros H.
apply Rlt_not_le with (1 := H1).
apply Rle_trans with (1 := proj1 (proj2 Hx)).
rewrite H, round_0, Rabs_R0...
apply bpow_ge_0.
Qed.

Definition float_relative_inv_ne := float_relative_inv_n (fun x => negb (Z.even x)).
Definition float_relative_inv_na := float_relative_inv_n (Zle_bool 0).

Definition rel_of_fix_float_n_helper (p : positive) (d xn : Z) (zi : FF) :=
 Zle_bool d xn &&
 Fle2 (lower zi) (Float2 (-1) (Zneg p)) &&
 Fle2 (Float2 1 (Zneg p)) (upper zi).

Theorem rel_of_fix_float_n :
  forall c p d xn x zi,
  FIX x xn ->
  rel_of_fix_float_n_helper p d xn zi = true ->
  REL (rounding_float (Znearest c) p d x) x zi.
Proof with auto with typeclass_instances.
intros c p d xn x zi ((mx, ex), (Hx1, Hx2)) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Zle_bool_imp_le _ _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). unfold float2R. simpl. rewrite F2R_bpow. clear H3. intro H3.
destruct (Rle_or_lt (Rabs x) (bpow radix2 (d + Zpos p))) as [He|He].
(* *)
rewrite round_generic...
exists 0%R.
repeat split.
apply Rle_trans with (1 := H2).
rewrite <- Ropp_0.
apply Ropp_le_contravar.
apply bpow_ge_0.
apply Rle_trans with (2 := H3).
apply bpow_ge_0.
now rewrite Rplus_0_r, Rmult_1_r.
apply generic_format_FLT_FIX...
rewrite <- Hx1.
apply generic_format_F2R.
intros _.
now apply Z.le_trans with xn.
(* *)
exists ((rounding_float (Znearest c) p d x - x) / x)%R.
assert (Rabs ((rounding_float (Znearest c) p d x - x) / x) <= bpow radix2 (- Zpos p))%R.
apply float_relative_n_whole.
apply Rlt_le.
apply Rlt_trans with (2 := He).
apply bpow_lt.
pattern (d + Zpos p)%Z at 2 ; rewrite <- Zplus_0_r.
now apply Zplus_lt_compat_l.
repeat split.
apply Rle_trans with (1 := H2).
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply Rle_trans with (2 := H).
rewrite <- Rabs_Ropp.
apply Rabs_idem.
apply Rle_trans with (2 := H3).
apply Rle_trans with (2 := H).
apply Rabs_idem.
field.
intros H0.
apply Rlt_not_le with (1 := He).
rewrite H0, Rabs_R0.
apply bpow_ge_0.
Qed.

Definition rel_of_fix_float_ne := rel_of_fix_float_n (fun x => negb (Z.even x)).
Definition rel_of_fix_float_na := rel_of_fix_float_n (Zle_bool 0).

Definition rel_of_fix_float_zr_helper (p : positive) (d xn : Z) (zi : FF) :=
  Zle_bool d xn &&
  Fle2 (lower zi) (Float2 (-1) (Zneg p + 1)) &&
  Fpos0 (upper zi).

Theorem rel_of_fix_float_zr :
  forall p d xn x zi,
  FIX x xn ->
  rel_of_fix_float_zr_helper p d xn zi = true ->
  REL (rounding_float rndZR p d x) x zi.
Proof with auto with typeclass_instances.
intros p d xn x zi ((mx, ex), (Hx1, Hx2)) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Zle_bool_imp_le _ _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H2. intro H2.
generalize (Fpos0_correct _ H3). clear H3. intro H3.
destruct (Rle_or_lt (Rabs x) (bpow radix2 (d + Zpos p))) as [He|He].
- rewrite round_generic...
  + exists 0%R.
    split. 2: ring.
    refine (conj _ H3).
    apply Rle_trans with (1 := H2).
    rewrite <- Ropp_0.
    apply Ropp_le_contravar.
    apply bpow_ge_0.
  + apply generic_format_FLT_FIX...
    rewrite <- Hx1.
    apply generic_format_F2R.
    intros _.
    now apply Z.le_trans with xn.
- exists ((rounding_float Ztrunc p d x - x) / x)%R.
  assert (Zx: (x <> 0)%R).
  { intros H0.
    apply Rlt_not_le with (1 := He).
    rewrite H0, Rabs_R0.
    apply bpow_ge_0. }
  split. 2: now field.
  split.
  { apply Rle_trans with (1 := H2).
    refine (proj1 (Rabs_le_inv _ _ _)).
    apply float_relative_whole...
    apply Rlt_le, Rlt_trans with (2 := He).
    apply bpow_lt.
    lia. }
  apply Rle_trans with (2 := H3).
  now apply float_relative_zr_whole.
Qed.

Definition rel_of_fix_float_helper (p : positive) (d xn : Z) (zi : FF) :=
  Zle_bool d xn &&
  Fle2 (lower zi) (Float2 (-1) (Zneg p + 1)) &&
  Fle2 (Float2 1 (Zneg p + 1)) (upper zi).

Theorem rel_of_fix_float :
  forall m, Valid_rnd m ->
  forall p d xn x zi,
  FIX x xn ->
  rel_of_fix_float_helper p d xn zi = true ->
  REL (rounding_float m p d x) x zi.
Proof with auto with typeclass_instances.
intros m Hm p d xn x zi ((mx, ex), (Hx1, Hx2)) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Zle_bool_imp_le _ _ H1). clear H1. intro H1.
generalize (Fle2_correct _ _ H2). unfold float2R. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). unfold float2R. simpl. rewrite F2R_bpow. clear H3. intro H3.
destruct (Rle_or_lt (Rabs x) (bpow radix2 (d + Zpos p))) as [He|He].
- rewrite round_generic...
  + exists 0%R.
    split. 2: ring.
    split.
    apply Rle_trans with (1 := H2).
    rewrite <- Ropp_0.
    apply Ropp_le_contravar.
    apply bpow_ge_0.
    apply Rle_trans with (2 := H3).
    apply bpow_ge_0.
  + apply generic_format_FLT_FIX...
    rewrite <- Hx1.
    apply generic_format_F2R.
    intros _.
    now apply Z.le_trans with xn.
- exists ((rounding_float m p d x - x) / x)%R.
  assert (Zx: (x <> 0)%R).
  { intros H0.
    apply Rlt_not_le with (1 := He).
    rewrite H0, Rabs_R0.
    apply bpow_ge_0. }
  split. 2: now field.
  simple refine (_ (float_relative_whole m Hm p d x _)).
  2: {
    apply Rlt_le, Rlt_trans with (2 := He).
    apply bpow_lt.
    lia. }
  intros H.
  apply Rabs_le_inv in H.
  split.
  + now apply Rle_trans with (1 := H2).
  + now apply Rle_trans with (2 := H3).
Qed.

Definition rel_of_fix_float_up := rel_of_fix_float rndUP _.
Definition rel_of_fix_float_dn := rel_of_fix_float rndDN _.

Theorem fix_float_of_fix :
  forall rdir {Hrnd : Valid_rnd rdir} p d xn zn x,
  FIX x xn ->
  Zle_bool zn xn = true ->
  FIX (rounding_float rdir p d x) zn.
Proof with auto with typeclass_instances.
intros rdir Hrnd p d xn zn x Hx Hb.
generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1.
apply FIX_iff_generic.
apply generic_round_generic...
apply FIX_iff_generic.
now apply fix_le with xn.
Qed.

Theorem fix_floatx_of_fix :
  forall rdir {Hrnd : Valid_rnd rdir} p xn zn x,
  FIX x xn ->
  Zle_bool zn xn = true ->
  FIX (rounding_floatx rdir p x) zn.
Proof with auto with typeclass_instances.
intros rdir Hrnd p xn zn x Hx Hb.
generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1.
apply FIX_iff_generic.
apply generic_round_generic...
apply FIX_iff_generic.
now apply fix_le with xn.
Qed.

Theorem flt_float_of_flt :
  forall rdir {Hrnd : Valid_rnd rdir} p d xn zn x,
  FLT x xn ->
  Zle_bool (Zpos xn) (Zpos zn) = true ->
  FLT (rounding_float rdir p d x) zn.
Proof with auto with typeclass_instances.
intros rdir Hrnd p d xn zn x H Hb.
generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1.
apply FLT_iff_generic.
apply generic_round_generic...
apply FLT_iff_generic.
now apply flt_le with xn.
Qed.

Theorem flt_floatx_of_flt :
  forall rdir {Hrnd : Valid_rnd rdir} p xn zn x,
  FLT x xn ->
  Zle_bool (Zpos xn) (Zpos zn) = true ->
  FLT (rounding_floatx rdir p x) zn.
Proof with auto with typeclass_instances.
intros rdir Hrnd p xn zn x H Hb.
generalize (Zle_bool_imp_le _ _ Hb). clear Hb. intro H1.
apply FLT_iff_generic.
apply generic_round_generic...
apply FLT_iff_generic.
now apply flt_le with xn.
Qed.

Lemma Znearest_IZR :
  forall c n, Znearest c (IZR n) = n.
Proof.
intros c n.
destruct (Znearest_DN_or_UP c (IZR n)) as [-> | ->].
apply Zfloor_IZR.
apply Zceil_IZR.
Qed.

Lemma ZnearestE_opp :
  forall x, ZnearestE (- x) = (- ZnearestE x)%Z.
Proof.
intros x.
rewrite Znearest_opp.
apply f_equal.
unfold Znearest.
destruct Rcompare ; try easy.
rewrite negb_involutive.
rewrite Z.even_opp.
rewrite Z.negb_even.
now rewrite <- Z.even_succ.
Qed.

Lemma round_NE_FLX_mult_bpow :
  forall p x y,
  FLT y 1 ->
  Generic_fmt.round radix2 (FLX_exp p) rndNE (y * x) = (y * Generic_fmt.round radix2 (FLX_exp p) rndNE x)%R.
Proof.
intros p x y [[my ey] [Hy1 Hy2]].
unfold Generic_fmt.round, scaled_mantissa, cexp, FLX_exp.
simpl in Hy2.
unfold rndNE.
destruct (Req_dec x 0) as [-> |Zx].
{ rewrite Rmult_0_r, Rmult_0_l.
  rewrite Znearest_IZR, F2R_0.
  apply eq_sym, Rmult_0_r. }
rewrite <- Hy1.
assert (Hy: my = 0%Z \/ my = (-1)%Z \/ my = 1%Z) by lia.
clear -Zx Hy.
unfold float2R.
cbn.
destruct Hy as [-> |[-> | ->]].
- rewrite F2R_0, !Rmult_0_l.
  rewrite Znearest_IZR.
  apply F2R_0.
- unfold F2R. cbn.
  replace (-1 * bpow radix2 ey * x)%R with ((-x) * bpow radix2 ey)%R by ring.
  rewrite mag_mult_bpow.
  rewrite mag_opp.
  replace (mag radix2 x + ey - p)%Z with (mag radix2 x - p + ey)%Z by ring.
  rewrite bpow_plus.
  rewrite <- !Ropp_mult_distr_l.
  rewrite ZnearestE_opp, opp_IZR.
  replace (- (mag radix2 x - p + ey))%Z with (- ey + - (mag radix2 x - p))%Z by ring.
  rewrite bpow_plus.
  rewrite (Rmult_assoc x), <- (Rmult_assoc (bpow radix2 ey)).
  rewrite <- bpow_plus, Z.add_opp_diag_r, Rmult_1_l.
  ring.
  contradict Zx.
  rewrite <- (Ropp_involutive x), Zx.
  apply Ropp_0.
- unfold F2R. cbn.
  rewrite Rmult_1_l.
  rewrite (Rmult_comm (bpow radix2 ey)).
  rewrite mag_mult_bpow by easy.
  replace (mag radix2 x + ey - p)%Z with (mag radix2 x - p + ey)%Z by ring.
  rewrite bpow_plus.
  replace (- (mag radix2 x - p + ey))%Z with (- ey + - (mag radix2 x - p))%Z by ring.
  rewrite bpow_plus.
  rewrite (Rmult_assoc x), <- (Rmult_assoc (bpow radix2 ey)).
  rewrite <- bpow_plus, Z.add_opp_diag_r, Rmult_1_l.
  ring.
Qed.

Definition lin_floatx_error_of_lin_flt_wide_ne_helper (p : positive) (xi : FF) (zi : FF) :=
  let u := Fmag xi in
  let e := (floatx_ulp p (Fnum u) (Fexp u) - 2)%Z in
  Fle2 u (Float2 (Zpos (xI (shift_pos p xH))) e) &&
  Fle2 (lower zi) (Float2 (-1) e) &&
  Fle2 (Float2 1 e) (upper zi).

Theorem lin_floatx_error_of_lin_flt_wide_ne :
  forall p x y xi zi,
  LIN x y xi -> FLT y 1 ->
  lin_floatx_error_of_lin_flt_wide_ne_helper p xi zi = true ->
  LIN (rounding_floatx rndNE p x - x) y zi.
Proof with auto with typeclass_instances.
intros p x' y xi zi [x [Hx1 Hx2]] Hy Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4).
generalize (andb_prop _ _ Hb). clear Hb. intros (H2,H3).
generalize (Fle2_correct _ _ H2). unfold float2R at 2. simpl. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). unfold float2R at 2. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H3. intro H3.
generalize (Fle2_correct _ _ H4). unfold float2R at 1. simpl. rewrite F2R_bpow. clear H4. intro H4.
simple refine (let H := floatx_error_wide_n (fun x => negb (Z.even x)) p x (Fmag xi) (conj _ H2) in _).
2: clearbody H.
now apply Fmag_correct.
clear H2.
set (e := (floatx_ulp p (Fnum (Fmag xi)) (Fexp (Fmag xi)) - 2)%Z) in H, H3, H4.
exists (rounding_floatx rndNE p x - x)%R.
split.
- split.
  + apply Rle_trans with (1 := H3).
    apply Ropp_le_cancel.
    rewrite Ropp_involutive.
    apply Rle_trans with (2 := H).
    rewrite <- Rabs_Ropp.
    apply Rabs_idem.
  + apply Rle_trans with (2 := H4).
    apply Rle_trans with (2 := H).
    apply Rabs_idem.
- rewrite Hx2.
  rewrite round_NE_FLX_mult_bpow with (1 := Hy).
  ring.
Qed.

Theorem lin_floatx_round_of_lin_flt_ne :
  forall p x y xi zi,
  LIN x y xi -> FLT y 1 ->
  round_helper (round roundNE (FLX_exp (Zpos p))) xi zi = true ->
  LIN (rounding_floatx rndNE p x) y zi.
Proof with auto with typeclass_instances.
intros p x' y xi zi [x [Hx1 Hx2]] Hy Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
generalize (Fle2_correct _ _ H1). rewrite rndG_conversion. clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite rndG_conversion. clear H2. intro H2.
exists (rounding_floatx (rndG_f roundNE_cs) p x)%R.
split.
2: {
  rewrite Hx2.
  now apply round_NE_FLX_mult_bpow. }
split.
- apply Rle_trans with (1 := H1).
  apply round_le...
  apply Hx1.
- apply Rle_trans with (2 := H2).
  apply round_le...
  apply Hx1.
Qed.

Definition lin_float_error_of_lin_abs_n_helper (p : positive) (d : Z) (xi yi zi : FF) :=
  Fle2 (Fmult2 (lower yi) (lower zi)) (Float2 (-1) (d-1)) &&
  Fle2 (Float2 1 (d-1)) (Fmult2 (lower yi) (upper zi)) &&
  Fle2 (lower zi) (Fmult2 (upper xi) (Float2 (-1) (Zneg p))) &&
  Fle2 (lower zi) (Fmult2 (lower xi) (Float2 1 (Zneg p))) &&
  Fle2 (Fmult2 (upper xi) (Float2 1 (Zneg p))) (upper zi) &&
  Fle2 (Fmult2 (lower xi) (Float2 (-1) (Zneg p))) (upper zi).

Theorem lin_float_error_of_lin_abs_n :
  forall c p d x y xi yi zi,
  LIN x y xi -> ABS y yi ->
  lin_float_error_of_lin_abs_n_helper p d xi yi zi = true ->
  LIN (rounding_float (Znearest c) p d x - x) y zi.
Proof with auto with typeclass_instances.
intros c p d x' y xi yi zi [x [Hx1 Hx2]] [Hy1 Hy2] Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros [Hb H6].
generalize (andb_prop _ _ Hb). clear Hb. intros [Hb H5].
generalize (andb_prop _ _ Hb). clear Hb. intros [Hb H4].
generalize (andb_prop _ _ Hb). clear Hb. intros [Hb H3].
generalize (andb_prop _ _ Hb). clear Hb. intros [H1 H2].
generalize (Fle2_correct _ _ H1). rewrite Fmult2_correct. unfold float2R at 3. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H1. intro H1.
generalize (Fle2_correct _ _ H2). rewrite Fmult2_correct. unfold float2R at 1. simpl. rewrite F2R_bpow. clear H2. intro H2.
generalize (Fle2_correct _ _ H3). rewrite Fmult2_correct. unfold float2R at 3. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H3. intro H3.
generalize (Fle2_correct _ _ H4). rewrite Fmult2_correct. unfold float2R at 3. simpl. rewrite F2R_bpow. clear H4. intro H4.
generalize (Fle2_correct _ _ H5). rewrite Fmult2_correct. unfold float2R at 2. simpl. rewrite F2R_bpow. clear H5. intro H5.
generalize (Fle2_correct _ _ H6). rewrite Fmult2_correct. unfold float2R at 2. simpl. rewrite (F2R_Zopp _ 1%Z), F2R_bpow. clear H6. intro H6.
destruct Hy1 as [Hy1|Hy1].
2: {
  elim Rle_not_lt with (1 := H1).
  rewrite <- Hy1, Rmult_0_l, <- Ropp_0.
  apply Ropp_lt_contravar, bpow_gt_0. }
destruct (error_N_FLT radix2 d (Z.pos p) eq_refl c x') as (eps&eta&Heps&Heta&Hee&->).
rewrite Hx2.
destruct (Rmult_integral _ _ Hee) as [-> | ->].
- exists (eta / y)%R.
  split.
  apply Gappa_real.IRdiv_aa with (1 := Hy1) (2 := H1) (3 := H2) (5 := proj1 Hy2).
  unfold Zminus. rewrite Zplus_comm.
  now rewrite bpow_plus.
  field.
  intros Hy.
  apply Rlt_not_le with (1 := Hy1).
  apply Rle_trans with (1 := proj1 Hy2).
  rewrite Hy, Rabs_R0.
  apply Rle_refl.
- exists (x * eps)%R.
  split. 2: ring.
  generalize (Rabs_le_inv _ _ Heps).
  replace (/2 * bpow radix2 (- Z.pos p + 1))%R with (bpow radix2 (Z.neg p)).
  2: {
    rewrite bpow_plus, bpow_1.
    simpl Z.opp. set (v := bpow radix2 _).
    simpl. field. }
  clear Heps Hee Heta. intros Heps.
  apply Gappa_real.IRmult_uo with (3 := H3) (4 := H6) (5 := H4) (6 := H5) (7 := Hx1) (8 := Heps).
  rewrite <- Ropp_0.
  apply Ropp_le_contravar, bpow_ge_0.
  apply bpow_ge_0.
Qed.

Definition lin_float_error_of_lin_abs_ne := lin_float_error_of_lin_abs_n (fun x => negb (Z.even x)).
Definition lin_float_error_of_lin_abs_na := lin_float_error_of_lin_abs_n (Zle_bool 0).
