(**
Copyright (C) Boldo, Lauter, Muller 2019

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
*)

From Flocq Require Import Core Plus_error Mult_error Sterbenz Operations Pff2Flocq.
Open Scope R_scope.

Definition sign := fun x => 
    if (Rlt_bool 0 x) then 1 else
    if (Req_bool 0 x) then 0 else (-1).

Lemma sign_pos : forall x, 0 < x -> sign x = 1.
Proof.
intros t Ht; unfold sign; rewrite Rlt_bool_true; easy.
Qed.

Lemma sign_0 : sign 0 = 0.
Proof.
unfold sign; rewrite Rlt_bool_false; try auto with real.
rewrite Req_bool_true; easy.
Qed.

Lemma sign_neg : forall x, x < 0 -> sign x = -1.
Proof.
intros t Ht.
unfold sign; rewrite Rlt_bool_false; try auto with real.
rewrite Req_bool_false; try auto with real.
Qed.

Lemma round_N_small : forall (beta : radix) (fexp : Z -> Z)
         (choice : Z -> bool) (x : R) (ex : Z),
       bpow beta (ex - 1) <= Rabs x < bpow beta ex ->
       (ex < fexp ex)%Z ->
       round beta fexp (Znearest choice) x = 0.
Proof with auto with typeclass_instances.
intros beta fexp choice x ex H1 H2.
case (Rle_or_lt 0 x); intros Hx.
apply round_N_small_pos with ex; try easy.
rewrite <- (Rabs_right x); try easy; auto with real.
rewrite <- (Ropp_involutive x), <- Ropp_0.
rewrite round_N_opp; f_equal.
apply round_N_small_pos with ex; try easy.
rewrite <- Rabs_left; easy.
Qed.

Lemma round_N_ge_ge_midp : 
       forall (beta : radix) (fexp : Z -> Z),
       Valid_exp fexp ->
       forall (choice : Z -> bool) (u v : R),
       generic_format beta fexp u ->
       u <= round beta fexp (Znearest choice) v ->
       (u + pred beta fexp u) / 2 <= v.
Proof with auto with typeclass_instances.
intros beta fexp H1 choice u v Hu H2.
assert (K: (u=0 /\ negligible_exp fexp = None) \/ (pred beta fexp u < u)).
case (Req_dec u 0); intros Zu.
case_eq (negligible_exp fexp).
intros n Hn; right.
rewrite Zu, pred_0.
unfold ulp; rewrite Req_bool_true, Hn; try easy.
rewrite <- Ropp_0.
apply Ropp_lt_contravar, bpow_gt_0.
intros _; left; split; easy.
right.
apply pred_lt_id...
(* *)
case K.
intros (K1,K2).
(* . *)
rewrite K1, pred_0.
unfold ulp; rewrite Req_bool_true, K2; try easy.
replace ((0+-0)/2) with 0 by field.
case (Rle_or_lt 0 v); try easy.
intros H3; contradict H2.
rewrite K1; apply Rlt_not_le.
assert (H4: round beta fexp (Znearest choice) v <= 0).
apply round_le_generic...
apply generic_format_0...
now left.
case H4; try easy.
intros H5.
absurd (v=0); try auto with real.
apply eq_0_round_0_negligible_exp with beta fexp (Znearest choice)...
(* . *)
intros K1.
case (Rle_or_lt ((u + pred beta fexp u) / 2) v); try easy.
intros H3.
absurd (u <= round beta fexp (Znearest choice) v); try easy.
apply Rlt_not_le.
apply Rle_lt_trans with (2:=K1).
apply round_N_le_midp...
apply generic_format_pred...
rewrite succ_pred...
apply Rlt_le_trans with (1:=H3).
right; f_equal; ring.
Qed.

Lemma round_N_le_le_midp : 
       forall (beta : radix) (fexp : Z -> Z),
       Valid_exp fexp ->
       forall (choice : Z -> bool) (u v : R),
       generic_format beta fexp u ->
       round beta fexp (Znearest choice) v <= u ->
       v <= (u + succ beta fexp u) / 2.
Proof with auto with typeclass_instances.
intros beta fexp H1 choice u v Hu H2.
apply Ropp_le_cancel.
apply Rle_trans with (((-u)+pred beta fexp (-u))/2).
rewrite pred_opp; right; field.
apply round_N_ge_ge_midp with
   (choice := fun t:Z => negb (choice (- (t + 1))%Z))...
apply generic_format_opp...
rewrite <- (Ropp_involutive (round _ _ _ _)).
rewrite <- round_N_opp, Ropp_involutive.
apply Ropp_le_contravar; easy.
Qed.

Lemma generic_format_FLT_mult_bpow : forall beta emin prec e f,
   Prec_gt_0 prec ->
   (0 <= e)%Z -> 
   generic_format beta (FLT_exp emin prec) f ->
   generic_format beta (FLT_exp emin prec) (f*bpow beta e).
Proof with auto with typeclass_instances.
intros beta emin prec e f Hp He Hf.
destruct (FLT_format_generic _ _ _ _ Hf).
apply generic_format_FLT.
exists (Float beta (Fnum f0) (Fexp f0+e)).
rewrite H; unfold F2R; simpl.
rewrite bpow_plus; ring.
simpl; easy.
simpl; omega.
Qed.

Lemma generic_format_FLT_other: forall beta emin prec e f,
   Prec_gt_0 prec ->
   (exists n:Z, f = IZR n*bpow beta e) ->
   (emin <= e)%Z ->
   (Rabs f < bpow beta (prec+e)) ->
   generic_format beta (FLT_exp emin prec) f.
Proof with auto with typeclass_instances.
intros beta emin prec e f H1 (n,Hn) H2 H3.
apply generic_format_FLT.
exists (Float beta n e).
unfold F2R; simpl; easy.
2: simpl; easy.
simpl; apply lt_IZR.
rewrite IZR_Zpower, abs_IZR.
2: unfold Prec_gt_0 in H1; omega.
apply Rmult_lt_reg_r with (bpow beta e).
apply bpow_gt_0.
rewrite <- bpow_plus.
apply Rle_lt_trans with (2:=H3).
right; rewrite Hn, Rabs_mult.
rewrite (Rabs_right (bpow _ _)); try easy.
apply Rle_ge, bpow_ge_0.
Qed.

Lemma generic_format_FLT_other': forall beta emin prec e x (f:float beta),
   Prec_gt_0 prec ->
   (x= F2R f) ->
   (emin <= e <= Fexp f)%Z ->
   (Rabs x < bpow beta (prec+e)) ->
   generic_format beta (FLT_exp emin prec) x.
Proof with auto with typeclass_instances.
intros beta emin prec e x f H1 H2 (H3,H4) H5.
apply generic_format_FLT_other with e; try easy.
exists (Fnum f*beta^(Fexp f-e))%Z.
rewrite H2; unfold F2R.
rewrite mult_IZR, Rmult_assoc; f_equal.
rewrite IZR_Zpower; try omega.
rewrite <- bpow_plus.
f_equal; ring.
Qed.

Notation Znearest0 := (Znearest (fun x => (Zlt_bool x 0))).

Section About_rnd_NO.

Definition Rnd_N0_pt (F : R -> Prop) (x f : R) :=
  Rnd_N_pt F x f /\
  forall f2 : R, Rnd_N_pt F x f2 -> (Rabs f <= Rabs f2)%R.

Definition Rnd_N0 (F : R -> Prop) (rnd : R -> R) :=
  forall x : R, Rnd_N0_pt F x (rnd x).

Theorem Rnd_N0_NG_pt :
  forall F : R -> Prop,
  F 0 ->
  forall x f,
  Rnd_N0_pt F x f <-> Rnd_NG_pt F (fun x f => Rabs f <= Rabs x) x f.
Proof.
intros F HF x f.
destruct (Rle_or_lt 0 x) as [Hx|Hx].
(* *)
split ; intros (H1, H2).
(* . *)
assert (Hf := Rnd_N_pt_ge_0 F HF x f Hx H1).
split.
exact H1.
destruct (Rnd_N_pt_DN_or_UP _ _ _ H1) as [H3|H3].
(* . . *)
left.
rewrite Rabs_pos_eq with (1 := Hf).
rewrite Rabs_pos_eq with (1 := Hx).
apply H3.
(* . . *)
right.
intros f2 Hxf2.
specialize (H2 _ Hxf2).
destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H4|H4].
apply Rle_antisym.
apply Rle_trans with x.
apply H4.
apply H3.
rewrite Rabs_pos_eq with (1 := Hf) in H2.
rewrite Rabs_pos_eq in H2.
exact H2.
now apply Rnd_N_pt_ge_0 with F x.
eapply Rnd_UP_pt_unique ; eassumption.
(* . *)
split.
exact H1.
intros f2 Hxf2.
destruct H2 as [H2|H2].
assert (Hf := Rnd_N_pt_ge_0 F HF x f Hx H1).
assert (Hf2 := Rnd_N_pt_ge_0 F HF x f2 Hx Hxf2).
rewrite 2!Rabs_pos_eq ; trivial.
rewrite 2!Rabs_pos_eq in H2 ; trivial.
destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H3|H3].
apply H3.
apply H1.
apply H2.
apply Rle_trans with (1 := H2).
apply H3.
rewrite (H2 _ Hxf2).
apply Rle_refl.
(* *)
assert (Hx' := Rlt_le _ _ Hx).
clear Hx. rename Hx' into Hx.
split ; intros (H1, H2).
(* . *)
assert (Hf := Rnd_N_pt_le_0 F HF x f Hx H1).
split.
exact H1.
destruct (Rnd_N_pt_DN_or_UP _ _ _ H1) as [H3|H3].
(* . . *)
right.
intros f2 Hxf2.
specialize (H2 _ Hxf2).
destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H4|H4].
eapply Rnd_DN_pt_unique ; eassumption.
apply Rle_antisym.
2: apply Rle_trans with x.
2: apply H3.
2: apply H4.
rewrite Rabs_left1 with (1 := Hf) in H2.
rewrite Rabs_left1 in H2.
now apply Ropp_le_cancel.
now apply Rnd_N_pt_le_0 with F x.
(* . . *)
left.
rewrite Rabs_left1 with (1 := Hf).
rewrite Rabs_left1 with (1 := Hx).
apply Ropp_le_contravar.
apply H3.
(* . *)
split.
exact H1.
intros f2 Hxf2.
destruct H2 as [H2|H2].
assert (Hf := Rnd_N_pt_le_0 F HF x f Hx H1).
assert (Hf2 := Rnd_N_pt_le_0 F HF x f2 Hx Hxf2).
rewrite 2!Rabs_left1 ; trivial.
rewrite 2!Rabs_left1 in H2 ; trivial.
apply Ropp_le_contravar.
apply Ropp_le_cancel in H2.
destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H3|H3].
2: apply H3.
2: apply H1.
2: apply H2.
apply Rle_trans with (2 := H2).
apply H3.
rewrite (H2 _ Hxf2).
apply Rle_refl.
Qed.

Lemma Rnd_N0_pt_unique_prop :
  forall F : R -> Prop,
  F 0 ->
  Rnd_NG_pt_unique_prop F (fun x f => Rabs f <= Rabs x).
Proof.
intros F HF x d u Hxd1 Hxd2 Hxu1 Hxu2 Hd Hu.
apply Rle_antisym.
apply Rle_trans with x.
apply Hxd1.
apply Hxu1.
destruct (Rle_or_lt 0 x) as [Hx|Hx].
apply Hxd1.
apply Hxu1.
rewrite Rabs_pos_eq with (1 := Hx) in Hu.
rewrite Rabs_pos_eq in Hu.
exact Hu.
apply Rle_trans with (1:=Hx).
apply Hxu1.
(* *)
apply Hxu1.
apply Hxd1.
rewrite Rabs_left with (1 := Hx) in Hd.
rewrite Rabs_left1 in Hd.
now apply Ropp_le_cancel.
apply Rlt_le, Rle_lt_trans with (2:=Hx).
apply Hxd1.
Qed.

Theorem Rnd_N0_pt_unique :
  forall F : R -> Prop,
  F 0 ->
  forall x f1 f2 : R,
  Rnd_N0_pt F x f1 -> Rnd_N0_pt F x f2 ->
  f1 = f2.
Proof.
intros F HF x f1 f2 H1 H2.
apply (Rnd_NG_pt_unique F _ (Rnd_N0_pt_unique_prop F HF) x).
now apply -> Rnd_N0_NG_pt.
now apply -> Rnd_N0_NG_pt.
Qed.

Theorem Rnd_N0_pt_N :
  forall F : R -> Prop,
  F 0 ->
  forall x f : R,
  Rnd_N_pt F x f ->
  (Rabs f <= Rabs x)%R ->
  Rnd_N0_pt F x f.
Proof.
intros F HF x f Rxf Hxf.
split.
apply Rxf.
intros g Rxg.
destruct (Rabs_eq_Rabs (f - x) (g - x)) as [H|H].
apply Rle_antisym.
apply Rxf.
apply Rxg.
apply Rxg.
apply Rxf.
(* *)
replace g with f.
apply Rle_refl.
apply Rplus_eq_reg_r with (1 := H).
(* *)
assert (g = 2 * x - f)%R.
replace (2 * x - f)%R with (x - (f - x))%R by ring.
rewrite H.
ring.
destruct (Rle_lt_dec 0 x) as [Hx|Hx].
(* . *)
revert Hxf.
rewrite Rabs_pos_eq with (1 := Hx).
rewrite 2!Rabs_pos_eq ; try ( apply (Rnd_N_pt_ge_0 F HF x) ; assumption ).
intros Hxf.
rewrite H0.
apply Rplus_le_reg_r with f.
ring_simplify.
apply Rmult_le_compat_l with (2 := Hxf).
now apply IZR_le.
(* . *)
revert Hxf.
apply Rlt_le in Hx.
rewrite Rabs_left1 with (1 := Hx).
rewrite 2!Rabs_left1 ; try ( apply (Rnd_N_pt_le_0 F HF x) ; assumption ).
intros Hxf.
rewrite H0.
apply Ropp_le_contravar.
apply Rplus_le_reg_r with f.
ring_simplify.
apply Rmult_le_compat_l.
now apply IZR_le.
now apply Ropp_le_cancel.
Qed.

Theorem Rnd_N0_unique :
  forall (F : R -> Prop),
  F 0 ->
  forall rnd1 rnd2 : R -> R,
  Rnd_N0 F rnd1 -> Rnd_N0 F rnd2 ->
  forall x, rnd1 x = rnd2 x.
Proof.
intros F HF rnd1 rnd2 H1 H2 x.
now apply Rnd_N0_pt_unique with F x.
Qed.

Theorem Rnd_N0_pt_monotone :
  forall F : R -> Prop,
  F 0 ->
  round_pred_monotone (Rnd_N0_pt F).
Proof.
intros F HF x y f g Hxf Hyg Hxy.
apply (Rnd_NG_pt_monotone F _ (Rnd_N0_pt_unique_prop F HF) x y).
now apply -> Rnd_N0_NG_pt.
now apply -> Rnd_N0_NG_pt.
exact Hxy.
Qed.

Theorem Rnd_N0_pt_refl :
  forall F : R -> Prop,
  forall x : R, F x ->
  Rnd_N0_pt F x x.
Proof.
intros F x Hx.
split.
now apply Rnd_N_pt_refl.
intros f Hxf.
apply Req_le.
apply f_equal.
now apply sym_eq, Rnd_N_pt_idempotent with (1 := Hxf).
Qed.

Theorem Rnd_N0_pt_idempotent :
  forall F : R -> Prop,
  forall x f : R,
  Rnd_N0_pt F x f -> F x ->
  f = x.
Proof.
intros F x f (Hf,_) Hx.
now apply Rnd_N_pt_idempotent with F.
Qed.

Theorem satisfies_any_imp_N0 :
  forall F : R -> Prop,
  F 0 -> satisfies_any F ->
  round_pred (Rnd_N0_pt F).
Proof.
intros F HF0 Hany.
split.
assert (H : round_pred_total (Rnd_NG_pt F (fun a b => (Rabs b <= Rabs a)%R))).
apply satisfies_any_imp_NG.
apply Hany.
intros x d u Hf Hd Hu.
destruct (Rle_lt_dec 0 x) as [Hx|Hx].
right.
rewrite Rabs_pos_eq with (1 := Hx).
rewrite Rabs_pos_eq.
apply Hd.
apply Hd; try easy.
left.
rewrite Rabs_left with (1 := Hx).
rewrite Rabs_left1.
apply Ropp_le_contravar.
apply Hu.
apply Hu; try easy.
now apply Rlt_le.
intros x.
destruct (H x) as (f, Hf).
exists f.
apply <- Rnd_N0_NG_pt.
apply Hf.
apply HF0.
apply Rnd_N0_pt_monotone.
apply HF0.
Qed.

Variable beta : radix.
Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.

Global Instance valid_rnd_N0 : Valid_rnd Znearest0 := valid_rnd_N _.

Theorem round_N0_pt :
  forall x,
  Rnd_N0_pt (generic_format beta fexp) x (round beta fexp Znearest0 x).
Proof.
intros x.
generalize (round_N_pt beta fexp (fun t => Zlt_bool t 0) x).
set (f := round beta fexp (Znearest (fun t => Zlt_bool t 0)) x).
intros Rxf.
destruct (Req_dec (x - round beta fexp Zfloor x) (round beta fexp Zceil x - x)) as [Hm|Hm].
(* *)
apply Rnd_N0_pt_N.
apply generic_format_0.
exact Rxf.
destruct (Rle_or_lt 0 x) as [Hx|Hx].
(* . *)
rewrite Rabs_pos_eq with (1 := Hx).
rewrite Rabs_pos_eq.
unfold f.
rewrite round_N_middle with (1 := Hm).
rewrite Zlt_bool_false.
now apply round_DN_pt.
apply Zfloor_lub.
apply Rmult_le_pos with (1 := Hx).
apply bpow_ge_0.
apply Rnd_N_pt_ge_0 with (2 := Hx) (3 := Rxf).
apply generic_format_0.
(* . *)
rewrite Rabs_left with (1 := Hx).
rewrite Rabs_left1.
apply Ropp_le_contravar.
unfold f.
rewrite round_N_middle with (1 := Hm).
rewrite Zlt_bool_true.
now apply round_UP_pt.
apply lt_IZR.
apply Rle_lt_trans with (scaled_mantissa beta fexp x).
apply Zfloor_lb.
simpl.
rewrite <- (Rmult_0_l (bpow beta (- (cexp beta fexp x)))).
apply Rmult_lt_compat_r with (2 := Hx).
apply bpow_gt_0.
apply Rnd_N_pt_le_0 with (3 := Rxf).
apply generic_format_0.
now apply Rlt_le.
(* *)
split.
apply Rxf.
intros g Rxg.
rewrite Rnd_N_pt_unique with (3 := Hm) (4 := Rxf) (5 := Rxg).
apply Rle_refl.
apply round_DN_pt; easy.
apply round_UP_pt; easy.
Qed.

Lemma round_N0_opp :
  forall x,
  (round beta fexp Znearest0 (- x) = - round beta fexp Znearest0 x)%R.
Proof.
intros x.
rewrite round_N_opp.
apply Ropp_eq_compat.
apply round_ext.
clear x; intro x.
unfold Znearest.
case_eq (Rcompare (x - IZR (Zfloor x)) (/ 2)); intro C;
[|reflexivity|reflexivity].
apply Rcompare_Eq_inv in C.
assert (H : negb (- (Zfloor x + 1) <? 0)%Z = (Zfloor x <? 0)%Z);
  [|now rewrite H].
rewrite negb_Zlt_bool.
case_eq (Zfloor x <? 0)%Z; intro C'.
apply Zlt_is_lt_bool in C'.
apply Zle_bool_true.
omega.
apply Z.ltb_ge in C'.
apply Zle_bool_false.
omega.
Qed.

Lemma round_N_0_eq_N0: forall c x,
  round beta fexp (Znearest c) x = 0 ->
  round beta fexp Znearest0 x = 0.
Proof with auto with typeclass_instances.
intros c x H1.
rewrite <- H1.
apply Rnd_N0_pt_unique with (generic_format beta fexp) x.
apply generic_format_0...
apply round_N0_pt...
apply Rnd_N0_pt_N...
apply generic_format_0...
apply round_N_pt...
rewrite H1, Rabs_R0.
apply Rabs_pos.
Qed.

Lemma round_N_eq_ties: forall c1 c2 x, 
   x - round beta fexp Zfloor x <> round beta fexp Zceil x - x ->
  round beta fexp (Znearest c1) x = round beta fexp (Znearest c2) x.
Proof with auto with typeclass_instances.
intros c1 c2 x.
pose (d:=round beta fexp Zfloor x); pose (u:=round beta fexp Zceil x); fold d; fold u; intros H.
case (Rle_or_lt ((d+u)/2) x); intros L.
2:rewrite 2!round_N_eq_DN...
destruct L as [L|L].
rewrite 2!round_N_eq_UP...
contradict H; rewrite <- L; field.
Qed.

End About_rnd_NO.

Section About_ulpH.

Variable beta : radix.
Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.

(** Harrison's ulp *)
Definition ulpH := fun (x:R) =>
      Rabs x - (pred beta fexp (Rabs x)).

Lemma ulpH_pos: forall x,
  0 <= x -> ulpH x = x - pred beta fexp x.
Proof.
intros x Hx; unfold ulpH.
now rewrite Rabs_pos_eq.
Qed.

Lemma ulpH_sym : forall x, 
  ulpH (-x) = ulpH x.
Proof.
intros x; unfold ulpH.
rewrite Rabs_Ropp; easy.
Qed.

Lemma ulpH_gt_0: forall x, x <> 0 -> 0 < ulpH x.
Proof.
intros x Hx; unfold ulpH.
apply Rlt_Rminus.
rewrite pred_eq_pos.
2: apply Rabs_pos.
apply pred_pos_lt_id.
now apply Rabs_no_R0.
Qed.

Lemma round_N_eq_N0_pos: forall c1 x, 
  let a:=round beta fexp (Znearest c1) x in
   0 <= x ->
  2*(a - x) <> ulpH a ->
  a = round beta fexp Znearest0 x.
Proof with auto with typeclass_instances.
intros c1 x a H0 H.
case (generic_format_EM beta fexp x); intros Fx.
unfold a; rewrite 2!round_generic...
pose (d:=round beta fexp Zfloor x); pose (u:=round beta fexp Zceil x).
case (Req_dec (x - d) (u - x)); intros H1.
2: apply round_N_eq_ties...
generalize H; unfold a; rewrite round_N_middle...
fold d; fold u; case (c1 (Zfloor (scaled_mantissa beta fexp x))).
(* *)
intros L; contradict L.
apply trans_eq with (u-d).
apply Rplus_eq_reg_l with (x-u).
apply trans_eq with (x-d); try ring.
rewrite H1; ring.
rewrite ulpH_pos.
2: apply round_ge_generic...
2: apply generic_format_0...
f_equal.
apply sym_eq; apply pred_UP_eq_DN...
(* *)
intros H2; rewrite round_N_middle...
generalize (Z.ltb_spec0 (Zfloor (scaled_mantissa beta fexp x)) 0); case (Z.ltb _ _).
intros L; inversion L as [H3|H3].
contradict H3; apply Zle_not_lt.
apply le_IZR.
apply Rmult_le_reg_r with (bpow beta (cexp beta fexp x)).
apply bpow_gt_0.
rewrite Rmult_0_l.
apply Rle_trans with (round beta fexp Zfloor x).
apply round_ge_generic...
apply generic_format_0...
right; easy.
intros _; easy.
Qed.

Lemma round_N_eq_N0_neg: forall c1 x, 
  let a:=round beta fexp (Znearest c1) x in
   x <= 0 ->
  2*(a - x) <> - ulpH a ->
  a = round beta fexp Znearest0 x.
Proof with auto with typeclass_instances.
intros c1 x a H1 H2; unfold a.
rewrite <- (Ropp_involutive x).
rewrite round_N0_opp.
rewrite round_N_opp.
f_equal.
apply round_N_eq_N0_pos.
auto with real.
rewrite <- (Ropp_involutive (round _ _ _ _)).
rewrite <- round_N_opp, Ropp_involutive; fold a.
rewrite ulpH_sym.
intros H3; contradict H2.
rewrite <- H3; ring.
Qed.

Lemma round_N_eq_N0: forall c1 x a, 
  a=round beta fexp (Znearest c1) x ->
  2*(a - x) <> sign a *ulpH a ->
  a = round beta fexp Znearest0 x.
Proof with auto with typeclass_instances.
intros c1 x a Ha H.
case (Req_dec a 0); intros Za.
rewrite Za; apply sym_eq.
apply round_N_0_eq_N0 with c1...
rewrite <- Ha; easy.
case (Rle_or_lt 0 x); intros Zx.
rewrite Ha; apply round_N_eq_N0_pos...
rewrite sign_pos, Rmult_1_l in H.
rewrite <- Ha; easy.
assert (H1 : 0 <= a).
rewrite Ha; apply round_ge_generic...
apply generic_format_0...
case H1; try easy.
intros K; contradict K; apply sym_not_eq; easy.
rewrite Ha; apply round_N_eq_N0_neg...
now left.
rewrite sign_neg in H.
rewrite <- Ha.
intros K; apply H; rewrite K; ring.
assert (H1 : a <= 0).
rewrite Ha; apply round_le_generic...
apply generic_format_0...
now left.
case H1; try easy.
Qed.

Lemma round_N_eq_N0_middle_pos: forall c1 x, 
  let a:=round beta fexp (Znearest c1) x in
   0 <= x -> a <> 0 ->
  2*(a - x) = ulpH a ->
  a - ulpH a = round beta fexp Znearest0 x.
Proof with auto with typeclass_instances.
intros c1 x a H0 H1 H2.
assert (H3: 0 <= a).
apply round_ge_generic...
apply generic_format_0...
rewrite ulpH_pos; try easy.
apply trans_eq with (pred beta fexp a);[ring|idtac].
assert (x=(a+pred beta fexp a)/2).
apply Rmult_eq_reg_l with (-2).
2: now auto with real.
apply Rplus_eq_reg_l with (2*a).
apply trans_eq with (2*(a-x)).
ring.
rewrite H2, ulpH_pos; try easy.
unfold ulpH; field.
assert (Y0: pred beta fexp a < x < a).
rewrite H; split; apply Rmult_lt_reg_l with 2; try auto with real.
apply Rplus_lt_reg_l with (-pred beta fexp a).
apply Rle_lt_trans with (pred beta fexp a);[right;ring|idtac].
apply Rlt_le_trans with a;[idtac|right;field].
apply pred_lt_id; easy.
apply Rplus_lt_reg_l with (- a).
apply Rle_lt_trans with (pred beta fexp a);[right;field|idtac].
apply Rlt_le_trans with a;[idtac|right;field].
apply pred_lt_id; easy.
assert (Y1: round beta fexp Zfloor x=pred beta fexp a).
apply round_DN_eq...
apply generic_format_pred...
apply generic_format_round...
split; try left; try apply Y0.
rewrite succ_pred...
apply Y0.
apply generic_format_round...
assert (Y2: round beta fexp Zceil x=a).
apply round_UP_eq...
apply generic_format_round...
split; try left; try apply Y0.
(* *)
rewrite round_N_middle...
rewrite Y1.
rewrite Zlt_bool_false; try easy.
apply Zfloor_lub.
unfold scaled_mantissa; apply Rmult_le_pos; try easy.
apply bpow_ge_0.
rewrite Y1, Y2.
apply Rplus_eq_reg_l with (a-x).
apply trans_eq with (2*(a-x));[idtac|ring].
rewrite H2; rewrite ulpH_pos; try easy.
ring.
Qed.

Lemma round_N_eq_N0_middle: forall c1 x a,
  a =round beta fexp (Znearest c1) x ->
  2*(a - x) = sign a * ulpH a ->
  a - sign a * ulpH a = round beta fexp Znearest0 x.
Proof with auto with typeclass_instances.
intros c1 x a Ha H.
case (total_order_T a 0).
intros T; case T; intros Pa; clear T.
(* *)
rewrite <- Ropp_involutive.
rewrite <- round_N0_opp.
apply trans_eq with (-((-a) - ulpH (-a))).
rewrite ulpH_sym.
rewrite sign_neg; try easy.
ring.
f_equal.
assert (V : -a = round beta fexp (Znearest (fun t : Z => negb (c1 (- (t + 1))%Z))) (-x)).
rewrite <- Ropp_involutive.
rewrite <- round_N_opp...
rewrite Ha; f_equal; f_equal; ring.
rewrite V.
apply round_N_eq_N0_middle_pos...
case (Rle_or_lt 0 (-x)); try easy; intros Zx.
contradict Pa; apply Rle_not_lt.
rewrite Ha; apply round_ge_generic...
apply generic_format_0...
left; apply Ropp_lt_cancel; rewrite Ropp_0; easy.
rewrite <- V.
intros K; contradict Pa; apply Rle_not_lt.
rewrite <- (Ropp_involutive a), K.
right; ring.
rewrite <- V.
apply trans_eq with (-(2 * (a - x))).
ring.
rewrite H, sign_neg; try easy.
rewrite ulpH_sym; ring.
(* *)
rewrite Pa, sign_0.
apply trans_eq with 0; try ring.
apply sym_eq, round_N_0_eq_N0 with c1...
rewrite <- Ha; easy.
(* *)
intros Pa.
rewrite sign_pos; try easy.
rewrite Rmult_1_l, Ha.
apply round_N_eq_N0_middle_pos.
case (Rle_or_lt 0 x); try easy; intros Zx.
contradict Pa; apply Rle_not_lt.
rewrite Ha; apply round_le_generic...
apply generic_format_0...
now left.
rewrite <- Ha; apply Rgt_not_eq; easy.
rewrite <- Ha.
rewrite sign_pos, Rmult_1_l in H; try easy.
Qed.

End About_ulpH.

Section About_ulpH_FLT.
Variable beta : radix.
Variable emin prec : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Let emin' := (emin-prec+1)%Z.

(* emin is the IEEE minimal exponent and
   emin' is the Flocq minimal exponent 
  The smallest positive FP is 2^emin-prec+1 = 2^emin'.
  The smallest normal FP is 2^emin=2^emin'+prec-1. *)

(*Goal bpow beta emin = bpow beta (emin'+prec-1).
unfold emin'; f_equal; ring.*)

Lemma ulpH_FLT_small: forall x,
    generic_format beta (FLT_exp emin' prec) x ->
    Rabs x <= bpow beta (emin+1)
    -> ulpH beta (FLT_exp emin' prec) x = bpow beta (emin-prec+1).
Proof with auto with typeclass_instances.
intros x Fx Hx; unfold ulpH.
case (Req_dec 0 x); intros Zx.
rewrite <- Zx, Rabs_R0.
rewrite pred_0, ulp_FLT_small...
unfold emin'; ring.
rewrite Rabs_R0; apply bpow_gt_0.
rewrite <- (pred_plus_ulp beta (FLT_exp emin' prec) (Rabs x)) at 1.
rewrite ulp_FLT_small...
unfold emin'; ring.
rewrite Rabs_pos_eq.
replace (emin'+prec)%Z with (emin+1)%Z by (unfold emin'; ring).
apply Rlt_le_trans with (2:= Hx).
apply pred_lt_id.
apply Rgt_not_eq, Rabs_pos_lt; auto with real.
apply pred_ge_0...
apply Rabs_pos_lt; auto with real.
apply generic_format_abs...
apply Rabs_pos_lt; auto with real.
apply generic_format_abs...
Qed.

Lemma ulpH_FLT_neq_bpow: forall x, 
    generic_format beta (FLT_exp emin' prec) x 
    -> Rabs x <> bpow beta (mag beta x-1)
    -> ulpH beta (FLT_exp emin' prec) x = ulp beta (FLT_exp emin' prec) x.
Proof with auto with typeclass_instances.
intros x Fx Hx.
case (Rle_or_lt (Rabs x) (bpow beta (emin'+prec))); intros Hx2.
rewrite ulpH_FLT_small...
rewrite ulp_FLT_small...
case Hx2; intros Hx3; try easy.
contradict Hx.
rewrite <- mag_abs, Hx3.
rewrite mag_bpow.
f_equal; ring.
apply Rle_trans with (1:=Hx2); right; f_equal.
unfold emin'; ring.
(* *)
assert (T1: 0 < Rabs x).
apply Rlt_trans with (2:=Hx2).
apply bpow_gt_0.
unfold ulpH.
rewrite <- (pred_plus_ulp beta (FLT_exp emin' prec) (Rabs x)) at 1...
2: apply generic_format_abs...
ring_simplify.
case (ulp_succ_pos beta (FLT_exp emin' prec) 
    (pred beta (FLT_exp emin' prec) (Rabs x))).
apply generic_format_pred...
apply generic_format_abs...
apply Rle_lt_trans with
 (pred beta (FLT_exp emin' prec) (bpow beta (emin' + prec))).
rewrite pred_eq_pos; try apply bpow_ge_0.
unfold pred_pos; rewrite mag_bpow.
rewrite Req_bool_true.
apply Rle_0_minus; apply bpow_le.
unfold FLT_exp; rewrite Z.max_l; try omega.
unfold Prec_gt_0 in prec_gt_0_; omega.
f_equal; ring.
apply pred_lt...
apply generic_format_bpow.
unfold FLT_exp; rewrite Z.max_l; try omega.
unfold Prec_gt_0 in prec_gt_0_; omega.
apply generic_format_abs...
rewrite succ_pred...
rewrite ulp_abs; easy.
apply generic_format_abs...
rewrite succ_pred...
intros Y; contradict Hx.
rewrite Y; f_equal.
apply Z.add_reg_l with (1%Z); ring_simplify; apply sym_eq.
apply mag_unique; split.
rewrite Y at 3; right; f_equal; ring.
rewrite Y at 1; apply bpow_lt; omega.
apply generic_format_abs...
Qed.

Lemma ulpH_FLT_bpow: forall x,
     bpow beta emin < Rabs x 
    -> Rabs x = bpow beta (mag beta x-1)
    -> ulpH beta (FLT_exp emin' prec) x = ulp beta (FLT_exp emin' prec) x / IZR beta.
Proof with auto with typeclass_instances.
intros x; pose (e:=(mag beta x - 1)%Z); fold e.
intros H1 H2.
assert (emin < e)%Z.
apply lt_bpow with beta.
rewrite <- H2; easy.
unfold ulpH; rewrite pred_eq_pos...
2: apply Rabs_pos.
unfold pred_pos; rewrite Req_bool_true.
2: rewrite mag_abs; easy.
ring_simplify; unfold Rdiv.
rewrite <- ulp_abs, H2.
rewrite ulp_neq_0.
2: apply Rgt_not_eq; apply bpow_gt_0.
rewrite <- bpow_1, <- bpow_opp, <- bpow_plus.
f_equal; unfold cexp; simpl.
rewrite mag_bpow.
unfold FLT_exp; rewrite Z.max_l; unfold emin'; try omega.
unfold emin'; rewrite Z.max_l; omega.
Qed.

Lemma round_N0_0 : forall x, Rabs x <= bpow radix2 (emin-prec) ->
   round radix2 (FLT_exp emin' prec) Znearest0 x = 0.
Proof with auto with typeclass_instances.
intros x Hx.
case (Req_dec x 0); intros Zx.
rewrite Zx; apply round_0...
destruct Hx.
(* *)
destruct (mag radix2 x) as (e,He).
apply round_N_small with e.
now apply He.
unfold FLT_exp, emin'.
apply Z.lt_le_trans with (2:=Z.le_max_r _ _).
assert (e - 1 < emin-prec)%Z; try omega.
apply lt_bpow with radix2.
apply Rle_lt_trans with (Rabs x); try easy.
now apply He.
assert (Y:round radix2 (FLT_exp emin' prec) Znearest0 (bpow radix2 (emin - prec)) = 0).
assert (H0:(cexp radix2 (FLT_exp emin' prec) (bpow radix2 (emin - prec)) = emin-prec+1)%Z).
unfold cexp, FLT_exp, emin'.
rewrite mag_bpow.
apply Z.max_r.
unfold Prec_gt_0 in prec_gt_0_; omega.
unfold round, scaled_mantissa; rewrite H0.
rewrite <- bpow_plus.
replace (emin - prec + - (emin - prec + 1))%Z with (-1)%Z by ring.
replace (Znearest0 (bpow radix2 (-1))) with 0%Z.
unfold F2R; simpl; ring.
replace (bpow radix2 (-1)) with (/2)%R by easy.
unfold Znearest; replace (Zfloor (/2)) with 0%Z.
rewrite Rcompare_Eq; try easy.
ring.
apply sym_eq, Zfloor_imp.
simpl; split; auto with real.
rewrite <- Rinv_1; apply Rinv_lt; auto with real.
case (Rabs_eq_Rabs x (bpow radix2 (emin-prec))).
rewrite (Rabs_right (bpow _ _)); try easy.
apply Rle_ge, bpow_ge_0.
intros T; rewrite T; easy.
intros T; rewrite T.
rewrite round_N0_opp, Y; ring.
Qed.

Lemma round_N0_mult_bpow : 
   forall x e,
    bpow beta (Z.max emin (emin-e)) <= Rabs x ->
    (round beta (FLT_exp emin' prec) Znearest0 x)*bpow beta e
     = round beta (FLT_exp emin' prec) Znearest0 (x*bpow beta e).
Proof with auto with typeclass_instances.
intros x e H.
case (Req_dec x 0); intros Zx.
rewrite Zx, Rmult_0_l.
rewrite round_0; try ring...
assert (Y1:
  (cexp beta (FLT_exp emin' prec) (x * bpow beta e) =
  cexp beta (FLT_exp emin' prec) x + e)%Z).
unfold cexp, FLT_exp, emin'.
rewrite mag_mult_bpow; try easy.
destruct (mag beta x) as (l,Hl); simpl.
assert (Z.max emin (emin-e) < l)%Z.
apply lt_bpow with beta.
apply Rle_lt_trans with (Rabs x); try easy.
now apply Hl.
generalize (Z.le_max_r emin (emin-e)); 
  generalize (Z.le_max_l emin (emin-e)); intros T1 T2.
rewrite 2!Z.max_l; omega.
(* *)
unfold round, F2R; simpl.
unfold scaled_mantissa; rewrite Rmult_assoc, <- bpow_plus.
rewrite Y1.
f_equal; f_equal; f_equal.
rewrite Rmult_assoc, <- bpow_plus.
f_equal; f_equal; ring.
Qed.

End About_ulpH_FLT.

Section Compute_ulpH_Recomp.

Variable emin prec : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Let emin' := (emin-prec+1)%Z.

Hypothesis emin_neg : (emin < 0)%Z.

Lemma emin'_neg : (emin' <= -prec)%Z.
Proof.
unfold emin'; omega.
Qed.

Local Definition phi := pred radix2 (FLT_exp emin' prec) 1.

Lemma format_phi: generic_format radix2 (FLT_exp emin' prec) phi.
Proof with auto with typeclass_instances.
apply generic_format_pred...
replace 1 with (bpow radix2 0) by easy.
apply generic_format_bpow'...
unfold FLT_exp; apply Z.max_lub...
unfold Prec_gt_0 in prec_gt_0_; omega.
unfold Prec_gt_0 in prec_gt_0_; unfold emin'; omega.
Qed.

Lemma phi_eq : phi = 1 - bpow radix2 (-prec).
Proof with auto with typeclass_instances.
unfold phi; rewrite pred_eq_pos.
2: apply Rle_0_1.
assert (H:(1 = mag radix2 1)%Z).
replace 1 with (bpow radix2 0) by easy.
rewrite mag_bpow; ring.
unfold pred_pos; rewrite Req_bool_true.
rewrite <- H; f_equal; f_equal.
unfold FLT_exp; rewrite Z.max_l.
ring.
unfold Prec_gt_0 in prec_gt_0_; unfold emin'; omega.
rewrite <- H; simpl; easy.
Qed.

Definition ulpH_c := fun choice1 choice2 a =>
    let z:= round radix2 (FLT_exp emin' prec) (Znearest choice1) (phi*a) in
          round radix2 (FLT_exp emin' prec) (Znearest choice2) (a-z).

Lemma ulpH_c_correct_zero: forall c1 c2,
  ulpH_c c1 c2 0 = 0.
Proof with auto with typeclass_instances.
intros choice1 choice2; unfold ulpH_c.
rewrite Rmult_0_r, round_0...
rewrite Rminus_0_r, round_0...
Qed.

(* does not hold for radix <> 2
  For instance, radix=10, p=3, a =101 *)
Lemma ulpH_c_correct_pos: forall c1 c2 a, 0 < a -> 
    generic_format radix2 (FLT_exp emin' prec) a ->
    (bpow radix2 emin < Rabs a) ->
    round radix2 (FLT_exp emin' prec) (Znearest c1) (phi*a) = 
        pred radix2 (FLT_exp emin' prec) a /\
    ulpH_c c1 c2 a = ulpH radix2 (FLT_exp emin' prec) a.
Proof with auto with typeclass_instances.
intros c1 c2 a Za Fa Ha.
case (Req_dec a (bpow radix2 (mag radix2 a-1))); intros H.
(* . a = 2^e *)
pose (ea:=(mag radix2 a - 1)%Z); fold ea in H.
assert (emin < ea)%Z.
apply lt_bpow with radix2.
rewrite <- H, <- (Rabs_right a); try easy.
apply Rle_ge; apply Rlt_le; easy.
rewrite pred_eq_pos; try auto with real.
unfold pred_pos; rewrite Req_bool_true...
fold ea.
unfold emin'; rewrite ulpH_FLT_bpow...
fold emin'; rewrite <- bpow_1; unfold Rdiv; rewrite <- bpow_opp.
rewrite H, ulp_bpow, <- bpow_plus.
unfold FLT_exp at 2 3; rewrite Z.max_l.
2: unfold emin'; omega.
unfold ulpH_c.
rewrite (round_generic _ _ _ (phi*bpow radix2 ea))...
replace (bpow radix2 ea - phi * bpow radix2 ea) with
    (bpow radix2 (ea-prec)).
split.
unfold Zminus; rewrite bpow_plus.
rewrite phi_eq; ring.
rewrite round_generic...
rewrite Z.max_l.
2: unfold emin'; omega.
f_equal; simpl; ring.
apply generic_format_bpow.
unfold FLT_exp; apply Z.max_lub.
unfold Prec_gt_0 in prec_gt_0_; omega.
unfold emin'; omega.
rewrite phi_eq; rewrite Rmult_minus_distr_r.
rewrite <- bpow_plus; ring_simplify.
f_equal; ring.
apply generic_format_FLT.
exists (Float radix2 (radix2^prec-1) (ea-prec)).
rewrite phi_eq; unfold F2R; simpl.
replace (2%Z) with (radix_val radix2) by easy.
rewrite minus_IZR, IZR_Zpower.
2: unfold Prec_gt_0 in prec_gt_0_; omega.
rewrite 2!Rmult_minus_distr_r, 2!Rmult_1_l.
rewrite <- 2!bpow_plus.
f_equal; f_equal; ring.
simpl; rewrite Z.abs_eq; try omega.
unfold Prec_gt_0 in prec_gt_0_.
generalize (Zpower_gt_0 radix2 prec); simpl; omega.
simpl; unfold emin'; omega.
rewrite H at 1; rewrite Rabs_right; try easy.
apply Rle_ge, bpow_ge_0.
(* . a <> 2^e *)
unfold emin'; rewrite ulpH_FLT_neq_bpow...
2: rewrite Rabs_right; try easy.
2: apply Rle_ge, Rlt_le; easy.
fold emin'; unfold ulpH_c.
replace (round radix2 (FLT_exp emin' prec) (Znearest c1) (phi * a))
  with (pred radix2 (FLT_exp emin' prec) a).
split; try easy.
rewrite pred_eq_pos.
2: now left.
unfold pred_pos; rewrite Req_bool_false; try easy.
ring_simplify (a - (a - ulp radix2 (FLT_exp emin' prec) a)).
rewrite round_generic...
apply generic_format_ulp...
assert (T0:pred radix2 (FLT_exp emin' prec) a = 
   a - ulp radix2 (FLT_exp emin' prec) a).
rewrite pred_eq_pos;[idtac|now left].
unfold pred_pos; rewrite Req_bool_false; easy.
assert (T0':ulp radix2 (FLT_exp emin' prec) a = bpow radix2 (mag radix2 a-prec)).
rewrite ulp_neq_0.
2: apply Rgt_not_eq; easy.
f_equal; unfold cexp, FLT_exp.
apply Z.max_l.
assert (emin+1 <= mag radix2 a)%Z; unfold emin'; try omega.
apply mag_ge_bpow; ring_simplify (emin+1-1)%Z; now left.
assert (T1: pred radix2 (FLT_exp emin' prec) a < phi*a).
rewrite T0, T0', phi_eq, Rmult_minus_distr_r, Rmult_1_l.
apply Rplus_lt_compat_l; apply Ropp_lt_contravar.
unfold Zminus; rewrite bpow_plus, Rmult_comm.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
apply Rle_lt_trans with (1:=RRle_abs _).
apply bpow_mag_gt.
assert (T2: phi*a < a).
rewrite <- (Rmult_1_l a) at 2.
apply Rmult_lt_compat_r; try assumption.
rewrite phi_eq; apply Rplus_lt_reg_l with (-1+bpow radix2 (-prec)).
ring_simplify; apply bpow_gt_0.
assert (T3: round radix2 (FLT_exp emin' prec) Zfloor (phi * a) =
    pred radix2 (FLT_exp emin' prec) a).
apply round_DN_eq...
apply generic_format_pred...
rewrite succ_pred...
split; try left; easy.
assert (T4: round radix2 (FLT_exp emin' prec) Zceil (phi * a) = a).
apply round_UP_eq...
split; try left; easy.
apply sym_eq; rewrite <- T3.
apply round_N_eq_DN...
rewrite T3,T4, phi_eq, T0, T0'.
rewrite Rmult_minus_distr_r, Rmult_1_l.
apply Rlt_le_trans with (a-bpow radix2 (mag radix2 a -prec)/2).
2: right; field.
apply Rplus_lt_compat_l, Ropp_lt_contravar.
apply Rle_lt_trans with (bpow radix2 (-prec)*
   (bpow radix2 (mag radix2 a -1))).
unfold Zminus; rewrite 2!bpow_plus.
rewrite 2!bpow_opp, bpow_1.
simpl; unfold Rdiv; right; ring.
apply Rmult_lt_compat_l; try apply bpow_gt_0.
generalize (bpow_mag_le radix2 a); intros T.
rewrite Rabs_right in T;[idtac|apply Rle_ge, Rlt_le; easy].
case T; try easy.
apply Rgt_not_eq; easy.
intros K; contradict K; apply sym_not_eq; easy.
Qed.

Lemma ulpH_c_correct_neg: forall c1 c2 a, a < 0 -> 
    generic_format radix2 (FLT_exp emin' prec) a ->
    (bpow radix2 emin < Rabs a) ->
     round radix2 (FLT_exp emin' prec) (Znearest c1) (phi*a) = 
        succ radix2 (FLT_exp emin' prec) a /\
    ulpH_c c1 c2 a = - ulpH radix2 (FLT_exp emin' prec) a.
Proof with auto with typeclass_instances.
intros c1 c2 a Za Fa Ha.
rewrite <- ulpH_sym.
unfold ulpH_c; replace (phi*a) with (-(phi*(-a))) by ring.
rewrite round_N_opp.
pose (l:=round radix2 (FLT_exp emin' prec)
     (Znearest (fun t : Z => negb (c1 (- (t + 1))%Z)))
     (phi * - a)); fold l.
replace (a--l) with (-((-a)-l)) by ring.
rewrite round_N_opp.
split.
replace a with (--a) by ring.
rewrite succ_opp; f_equal.
apply ulpH_c_correct_pos; try easy.
auto with real.
apply generic_format_opp...
rewrite Rabs_Ropp; easy.
f_equal.
apply ulpH_c_correct_pos.
auto with real.
apply generic_format_opp...
rewrite Rabs_Ropp; easy.
Qed.

Definition Recomp := fun c1 c2 a b =>
   let z:= round radix2 (FLT_exp emin' prec) (Znearest c1) (phi*a) in
    let d:= round radix2 (FLT_exp emin' prec) (Znearest c2) (z-a) in
      if (Req_bool (2*b) d) then (z,-b)
                            else (a,b).

Lemma Recomp_opp : forall c1 c2 a b x y,
  x = fst (Recomp c1 c2 a b) -> y = snd (Recomp c1 c2 a b) ->
  Recomp (fun t : Z => negb (c1 (- (t + 1))%Z))
         (fun t : Z => negb (c2 (- (t + 1))%Z)) (-a) (-b) 
   = (-x,-y).
Proof with auto with typeclass_instances.
intros c1 c2 a b x y Hx Hy.
rewrite Hx, Hy; unfold Recomp.
rewrite <- (Ropp_involutive (round radix2 (FLT_exp emin' prec)
          (Znearest (fun t : Z => negb (c1 (- (t + 1))%Z)))
          (phi * -a))).
rewrite <- round_N_opp.
replace (-(phi*-a)) with (phi*a) by ring.
pose (z:= round radix2 (FLT_exp emin' prec) (Znearest c1) (phi*a)); fold z.
rewrite <- (Ropp_involutive (round radix2 (FLT_exp emin' prec)
          (Znearest (fun t : Z => negb (c2 (- (t + 1))%Z)))
          _ )).
rewrite <- round_N_opp.
replace (-(-z--a)) with (z-a) by ring.
pose (d:=round radix2 (FLT_exp emin' prec) (Znearest c2) (z - a)); fold d.
generalize (Req_bool_spec (2*b) d); case (Req_bool (2*b) d ); intros H; inversion H.
rewrite Req_bool_true; try easy.
rewrite <- H0; ring.
rewrite Req_bool_false; try easy.
intros K; contradict H0.
rewrite <- (Ropp_involutive d), <- K; ring.
Qed.

Lemma Recomp_correct1 : forall c1 c2 a b,
   generic_format radix2 (FLT_exp emin' prec) a ->
    (bpow radix2 emin < Rabs a) ->
    let (x,y) := Recomp c1 c2 a b in
          x+y=a+b.
Proof with auto with typeclass_instances.
intros c1 c2 a b Fa Ha; unfold Recomp.
pose (z:=round radix2 (FLT_exp emin' prec) (Znearest c1) (phi*a)).
pose (d:=round radix2 (FLT_exp emin' prec) (Znearest c2) (z-a)).
fold z; fold d.
generalize (Req_bool_spec (2*b) d); case (Req_bool (2*b) d ); try easy.
intros H; inversion H.
case (total_order_T a 0); intros T.
case T; clear T; intros Za.
(* a < 0 *)
destruct (ulpH_c_correct_neg c1 (fun t : Z =>
             negb (c2 (- (t + 1))%Z)) a) as (Y1,Y2); try assumption.
unfold ulpH_c in Y2; fold z in Y1, Y2.
rewrite <- (Ropp_involutive (round _ _ _ _)) in Y2.
rewrite <- round_N_opp in Y2.
replace (-(a-z)) with (z-a) in Y2 by ring; fold d in Y2.
rewrite Y1; apply Rplus_eq_reg_l with (-b).
apply trans_eq with a; try ring.
apply trans_eq with (succ radix2 (FLT_exp emin' prec) a + - (2*b)); try ring.
rewrite H0, Y2.
unfold ulpH; rewrite Rabs_left; try easy.
rewrite pred_opp; ring.
(* a = 0 *)
contradict Ha; rewrite Za, Rabs_R0.
apply Rle_not_lt, bpow_ge_0.
(* a > 0 *)
destruct (ulpH_c_correct_pos c1 (fun t : Z =>
             negb (c2 (- (t + 1))%Z)) a) as (Y1,Y2); try assumption.
unfold ulpH_c in Y2; fold z in Y1, Y2.
rewrite <- (Ropp_involutive (round _ _ _ _)) in Y2.
rewrite <- round_N_opp in Y2.
replace (-(a-z)) with (z-a) in Y2 by ring; fold d in Y2.
rewrite Y1; apply Rplus_eq_reg_l with (-b).
apply trans_eq with (pred radix2 (FLT_exp emin' prec) a+-(2*b)); try ring.
rewrite H0, Y2.
rewrite ulpH_pos; auto with real.
ring.
Qed.

Lemma Recomp_correct2_pos : forall c1 c2 c3 a b x, 
 (bpow radix2 emin < Rabs a) ->
    0 <= a + b ->
    a = round radix2 (FLT_exp emin' prec) (Znearest c3) (a+b) ->
     x = fst (Recomp c1 c2 a b) ->
          x= round radix2 (FLT_exp emin' prec) Znearest0 (a+b).
Proof with auto with typeclass_instances.
intros c1 c2 c3 a b x Ha1 Hab Ha2 Hx.
assert (Za: 0 <= a).
rewrite Ha2; apply round_ge_generic...
apply generic_format_0...
assert (Za': 0 < a).
case Za; try easy.
intros K; contradict Ha1.
apply Rle_not_lt; rewrite <- K, Rabs_R0.
apply bpow_ge_0.
generalize Hx; unfold Recomp.
pose (z:=round radix2 (FLT_exp emin' prec) (Znearest c1) (phi*a)).
pose (d:=round radix2 (FLT_exp emin' prec) (Znearest c2) (z-a)).
fold z; fold d.
generalize (Req_bool_spec (2*b) d); case (Req_bool (2*b) d ); try easy.
(* middle *)
intros H; inversion H.
intros Hx'; simpl in Hx'; rewrite Hx'.
(* *)
assert (-d = ulpH radix2 (FLT_exp emin' prec) a).
apply trans_eq with (ulpH_c c1 (fun t : Z =>
             negb (c2 (- (t + 1))%Z)) a).
unfold d,z,ulpH_c.
rewrite <- (Ropp_involutive 
  (round _ _ (Znearest (fun t : Z => negb (c2 (- (t + 1))%Z))) _)).
f_equal.
rewrite <- round_N_opp; f_equal; ring.
apply ulpH_c_correct_pos; try easy.
rewrite Ha2.
apply generic_format_round...
assert (Y1: a = round radix2 (FLT_exp emin' prec) Zceil (a+b)).
rewrite Ha2 at 1.
case (round_DN_or_UP radix2 (FLT_exp emin' prec) (Znearest c3) (a+b)); try easy.
intros K.
absurd (0 <= b).
apply Rlt_not_le.
apply Rmult_lt_reg_l with 2%R.
apply Rlt_0_2.
rewrite H0, Rmult_0_r.
rewrite <- (Ropp_involutive d), <- Ropp_0.
apply Ropp_lt_contravar.
rewrite H1.
apply ulpH_gt_0.
apply Rgt_not_eq; easy.
apply Rplus_le_reg_l with a.
rewrite Rplus_0_r.
rewrite Ha2 at 1; rewrite K.
apply round_DN_pt...
assert (Y2: z = pred radix2 (FLT_exp emin' prec) a).
apply ulpH_c_correct_pos; try easy.
rewrite Ha2; apply generic_format_round...
assert (Y3: pred radix2 (FLT_exp emin' prec) a = 
   round radix2 (FLT_exp emin' prec) Zfloor (a + b)).
rewrite Y1 at 1.
apply pred_UP_eq_DN...
intros K; absurd (b = 0).
apply Rlt_not_eq.
apply Rmult_lt_reg_l with 2.
apply Rlt_0_2.
rewrite H0, Rmult_0_r.
rewrite <- (Ropp_involutive d), <- Ropp_0.
apply Ropp_lt_contravar.
rewrite H1.
apply ulpH_gt_0.
apply Rgt_not_eq; easy.
apply Rplus_eq_reg_l with a.
rewrite Rplus_0_r; rewrite Ha2 at 2.
rewrite round_generic...
(* *)
rewrite round_N_middle.
rewrite <- Y3, <- Y2.
rewrite Zlt_bool_false...
apply Zfloor_lub.
apply Rmult_le_pos; try easy.
apply bpow_ge_0.
rewrite <- Y3, <- Y2, <- Y1.
apply Rplus_eq_reg_l with (-b).
apply trans_eq with (-(2*b)); try ring.
rewrite H0, H1.
apply trans_eq with (a-z); try ring.
rewrite Y2, ulpH_pos...
(* non middle *)
intros H; inversion H.
intros Hx'; simpl in Hx'; rewrite Hx'.
rewrite Ha2 at 1.
apply round_N_eq_N0_pos...
rewrite <- Ha2.
replace (2*(a-(a+b))) with (-(2*b)) by ring.
replace (ulpH radix2 (FLT_exp emin' prec) a) with (-d).
intros K; contradict H0.
rewrite <- (Ropp_involutive d), <- K; ring.
apply trans_eq with (ulpH_c c1 (fun t : Z =>
             negb (c2 (- (t + 1))%Z)) a).
unfold d,z,ulpH_c.
rewrite <- (Ropp_involutive 
  (round _ _ (Znearest (fun t : Z => negb (c2 (- (t + 1))%Z))) _)).
f_equal.
rewrite <- round_N_opp; f_equal; ring.
apply ulpH_c_correct_pos; try easy.
rewrite Ha2.
apply generic_format_round...
Qed.

Lemma Recomp_correct2 : forall c1 c2 c3 a b x,
 (bpow radix2 emin < Rabs a) ->
    a = round radix2 (FLT_exp emin' prec) (Znearest c3) (a+b) ->
    x = fst (Recomp c1 c2 a b) ->
    x = round radix2 (FLT_exp emin' prec) Znearest0 (a+b).
Proof with auto with typeclass_instances.
intros c1 c2 c3 a b x H1 H2 H3.
case (Rle_or_lt 0 (a+b)); intros H4.
apply Recomp_correct2_pos with c1 c2 c3...
replace (a+b) with (-(-a+-b)) by ring.
rewrite round_N0_opp.
rewrite <- (Ropp_involutive x); f_equal.
eapply Recomp_correct2_pos.
rewrite Rabs_Ropp...
rewrite <- Ropp_0.
replace (-a+-b) with (-(a+b)) by ring.
apply Ropp_le_contravar; auto with real.
rewrite H2 at 1.
replace (a+b) with (-(-a+-b)) by ring.
rewrite round_N_opp, Ropp_involutive.
easy.
rewrite (Recomp_opp c1 c2 a b x (snd (Recomp c1 c2 a b))); try easy.
Qed.

Lemma Recomp_when_0: forall c1 c2 a b,
   generic_format radix2 (FLT_exp emin' prec) a ->
   b = 0 -> Recomp c1 c2 a b = (a,0).
Proof with auto with typeclass_instances.
intros c1 c2 a b Ha Hb; rewrite Hb; unfold Recomp.
rewrite Rmult_0_r.
pose (z:=(round radix2 (FLT_exp emin' prec) 
     (Znearest c1) (phi * a))); fold z.
pose (d:=round radix2 (FLT_exp emin' prec) (Znearest c2) (z - a)); fold d.
generalize (Req_bool_spec 0 d); case (Req_bool 0 d ); intros H; inversion H...
rewrite Ropp_0.
replace a with z...
apply Rplus_eq_reg_r with (-a).
apply trans_eq with 0; try ring.
apply round_plus_eq_0 with radix2 (FLT_exp emin' prec) (Znearest c2)...
apply generic_format_round...
apply generic_format_opp...
Qed.

Lemma Recomp_all_aux : forall c3 a b,
   a = round radix2 (FLT_exp emin' prec) (Znearest c3) (a+b) ->
   generic_format radix2 (FLT_exp emin' prec) b ->
   (Rabs a <= bpow radix2 emin) -> b = 0.
Proof with auto with typeclass_instances.
intros c3 a b Ha Hb H.
apply Rplus_eq_reg_l with a; rewrite Rplus_0_r.
rewrite Ha at 2.
rewrite round_generic...
apply FLT_format_plus_small...
rewrite Ha; apply generic_format_round...
case (Rle_or_lt (Rabs (a+b)) (bpow radix2 (prec + emin'))); try easy.
intros K.
contradict H; apply Rlt_not_le.
apply Rlt_le_trans with (bpow radix2 (emin'+prec)).
apply bpow_lt; unfold emin'; omega.
rewrite Ha.
apply abs_round_ge_generic...
apply generic_format_bpow'...
unfold FLT_exp; ring_simplify (emin+prec-prec)%Z.
rewrite Z.max_l; try omega.
unfold Prec_gt_0 in prec_gt_0_; omega.
rewrite Zplus_comm; left; assumption.
Qed.

Lemma Recomp_correct1_all : forall c1 c2 c3 a b,
   a = round radix2 (FLT_exp emin' prec) (Znearest c3) (a+b) ->
   generic_format radix2 (FLT_exp emin' prec) b ->
    let (x,y) := Recomp c1 c2 a b in
          x+y=a+b.
Proof with auto with typeclass_instances.
intros c1 c2 c3 a b Ha Hb.
case (Rle_or_lt (Rabs a)  (bpow radix2 emin)); intros H.
assert (Zb:b=0).
apply Recomp_all_aux with c3 a...
rewrite Recomp_when_0...
rewrite Zb; easy.
rewrite Ha; apply generic_format_round...
apply Recomp_correct1...
rewrite Ha; apply generic_format_round...
Qed.

Lemma Recomp_correct2_all : forall c1 c2 c3 a b x,
    a = round radix2 (FLT_exp emin' prec) (Znearest c3) (a+b) ->
    generic_format radix2 (FLT_exp emin' prec) b ->
    x = fst (Recomp c1 c2 a b) ->
    x = round radix2 (FLT_exp emin' prec) Znearest0 (a+b).
Proof with auto with typeclass_instances.
intros c1 c2 c3 a b x Ha Hb Hx.
case (Rle_or_lt (Rabs a)  (bpow radix2 emin)); intros H.
assert (Zb:b=0).
apply Recomp_all_aux with c3 a...
rewrite Hx, Recomp_when_0...
simpl; rewrite Zb, Rplus_0_r.
rewrite round_generic...
rewrite Ha; apply generic_format_round...
rewrite Ha; apply generic_format_round...
apply Recomp_correct2 with c1 c2 c3...
Qed.

End Compute_ulpH_Recomp.

Section Augmented_mult_small_pos.

Variable emin prec : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Let emin' := (emin-prec+1)%Z.

Hypothesis emin_neg : (emin < 0)%Z.
Hypothesis Prec_gt_1 : (1 < prec)%Z.

Variable x y:R.
Hypothesis Fx: generic_format radix2 (FLT_exp emin' prec) x.
Hypothesis Fy: generic_format radix2 (FLT_exp emin' prec) y.

Variable c1 c2 c3: Z->bool.
(* needs even rounding for strict inequalities *)
Let ae := round radix2 (FLT_exp emin' prec) (ZnearestE) (x*y).
Hypothesis Very_small_ae:
   ae <= bpow radix2 (emin+1) - bpow radix2 (emin-prec+1).
Hypothesis Positive_ae: 0 < ae.

Let eta := bpow radix2 emin'.
Let psi := bpow radix2 (emin+1) - bpow radix2 (emin-prec+1).

Lemma eta_succ_0 : eta = succ radix2 (FLT_exp emin' prec) 0.
Proof with auto with typeclass_instances.
rewrite succ_0.
rewrite ulp_FLT_small...
rewrite Rabs_R0; apply bpow_gt_0.
Qed.

Lemma format_eta : generic_format radix2 (FLT_exp emin' prec) eta.
Proof with auto with typeclass_instances.
rewrite eta_succ_0.
apply generic_format_succ...
apply generic_format_0...
Qed.

Lemma ae_ge_eta : eta <= ae.
Proof with auto with typeclass_instances.
rewrite eta_succ_0.
apply succ_le_lt...
apply generic_format_0...
apply generic_format_round...
Qed.

Lemma psi_eq : psi =  pred radix2 (FLT_exp emin' prec) (bpow radix2 (emin+1)).
Proof with auto with typeclass_instances.
rewrite pred_eq_pos.
2: apply bpow_ge_0.
unfold pred_pos; rewrite mag_bpow.
replace (emin+1+1-1)%Z with (emin+1)%Z by ring.
rewrite Req_bool_true; try easy.
unfold psi; f_equal; f_equal.
unfold FLT_exp, emin'.
rewrite Z.max_l; omega.
Qed.

Lemma format_psi : generic_format radix2 (FLT_exp emin' prec) psi.
Proof with auto with typeclass_instances.
rewrite psi_eq.
apply generic_format_pred...
apply generic_format_bpow.
unfold FLT_exp, emin'.
rewrite Z.max_l; omega.
Qed.

Lemma xy_ge:
 bpow radix2 (emin-prec) <= x*y.
Proof with auto with typeclass_instances.
apply Rle_trans with (( eta + pred radix2 (FLT_exp emin' prec) eta) / 2).
rewrite eta_succ_0 at 2.
rewrite pred_succ...
2: apply generic_format_0...
rewrite Rplus_0_r; unfold eta, emin'.
rewrite bpow_plus_1.
simpl; right; field.
apply round_N_ge_ge_midp with (fun x => negb (Z.even x))...
apply format_eta.
fold ae; apply ae_ge_eta.
Qed.

Lemma xy_gt:
 bpow radix2 (emin-prec) < x*y.
Proof with auto with typeclass_instances.
case xy_ge; try easy.
intros K.
assert (H: ae = 0).
2: contradict Positive_ae.
2: apply Rle_not_lt; rewrite H; now right.
unfold ae; rewrite <- K.
replace (bpow radix2 (emin - prec)) with (bpow radix2 (emin'-1)).
2: f_equal; unfold emin'; ring.
assert (J0: cexp radix2 (FLT_exp emin' prec)
              (bpow radix2 (emin' - 1)) = emin').
unfold cexp, FLT_exp.
rewrite mag_bpow.
apply Z.max_r.
unfold Prec_gt_0 in prec_gt_0_; omega.
unfold round; rewrite J0.
unfold scaled_mantissa; rewrite J0, <- bpow_plus.
replace (bpow radix2 (emin' - 1 + - emin')) with (/2).
replace (ZnearestE (/ 2)) with 0%Z.
unfold F2R; simpl; ring.
unfold ZnearestE.
replace (Zfloor (/2)) with 0%Z.
rewrite Rminus_0_r.
rewrite Rcompare_Eq; try easy.
apply sym_eq, Zfloor_imp; simpl.
split; [now auto with real|idtac].
rewrite <- Rinv_1; apply Rinv_lt; auto with real.
apply trans_eq with (bpow radix2 (-1)); try easy.
f_equal; ring.
Qed.

Lemma xy_le:
   x*y <= bpow radix2 (emin+1) - bpow radix2 (emin-prec).
Proof with auto with typeclass_instances.
apply Rle_trans with ((psi+succ radix2 (FLT_exp emin' prec) psi)/2).
apply round_N_le_le_midp with (fun x => negb (Z.even x))...
apply format_psi.
rewrite psi_eq at 2.
rewrite succ_pred...
unfold psi; rewrite (bpow_plus_1 _ (emin-prec)%Z).
simpl; right; field.
apply generic_format_bpow.
unfold FLT_exp, emin'.
rewrite Z.max_l; omega.
Qed.

Lemma xy_lt:
   x*y < bpow radix2 (emin+1) - bpow radix2 (emin-prec).
Proof with auto with typeclass_instances.
case xy_le; try easy.
intros K.
assert (H: ae = bpow radix2 (emin + 1)).
2: contradict Very_small_ae; apply Rlt_not_le.
2: rewrite H, <- Rminus_0_r; apply Rplus_lt_compat_l.
2: apply Ropp_lt_contravar; apply bpow_gt_0.
unfold ae; rewrite K.
pose (t:=bpow radix2 (emin + 1) - bpow radix2 (emin - prec)); fold t.
assert (J0: cexp radix2 (FLT_exp emin' prec) t = (emin+1-prec)%Z).
unfold cexp, FLT_exp.
rewrite mag_unique_pos with radix2 t (emin+1)%Z.
apply Z.max_l.
unfold Prec_gt_0 in prec_gt_0_; unfold emin'; omega.
split.
ring_simplify (emin+1-1)%Z.
apply Rplus_le_reg_l with (-bpow radix2 emin+bpow radix2 (emin-prec)).
apply Rle_trans with (bpow radix2 (emin - prec)).
right; ring.
apply Rle_trans with (bpow radix2 emin).
apply bpow_le.
unfold Prec_gt_0 in prec_gt_0_; omega.
unfold t; rewrite bpow_plus, bpow_1.
simpl; right; ring.
apply Rplus_lt_reg_l with (-bpow radix2 (emin+1)+bpow radix2 (emin-prec)).
unfold t; ring_simplify.
apply bpow_gt_0.
(* . *)
unfold round; rewrite J0.
unfold scaled_mantissa; rewrite J0.
unfold t; rewrite Rmult_minus_distr_r, <- bpow_plus, <- bpow_plus.
ring_simplify (emin + 1 + - (emin + 1 - prec))%Z.
replace (emin - prec + - (emin + 1 - prec))%Z with (-1)%Z by ring.
replace (bpow radix2 (-1)) with (/2) by easy.
unfold F2R; simpl.
replace (IZR (ZnearestE (bpow radix2 prec - / 2))) with (bpow radix2 prec).
rewrite <- bpow_plus.
f_equal; ring.
rewrite <- IZR_Zpower.
2: unfold Prec_gt_0 in prec_gt_0_; omega.
unfold ZnearestE.
replace (Zfloor (IZR (radix2^prec) - /2)) with (radix2^prec-1)%Z.
rewrite Rcompare_Eq.
unfold Zminus; rewrite Z.even_add.
rewrite Z.even_pow; try easy.
simpl.
f_equal.
apply sym_eq, Zceil_imp; simpl.
rewrite minus_IZR; simpl; split.
apply Rplus_lt_compat_l, Ropp_lt_contravar.
rewrite <- Rinv_1.
apply Rinv_lt; auto with real.
apply Rplus_le_reg_l with (/2-IZR (2^prec)); ring_simplify.
auto with real.
rewrite minus_IZR; simpl; field.
apply sym_eq, Zfloor_imp; simpl.
rewrite minus_IZR; simpl; split.
apply Rplus_le_compat_l, Ropp_le_contravar.
rewrite <- Rinv_1.
apply Rinv_le; auto with real.
rewrite plus_IZR, minus_IZR.
apply Rplus_lt_reg_l with (/2-IZR (2^prec)); ring_simplify.
auto with real.
Qed.

Let t1 := round radix2 (FLT_exp emin' prec) 
       (Znearest c1) (x*(y*bpow radix2 (2*prec))).
Let t2 := round radix2 (FLT_exp emin' prec) 
       (Znearest c2) (x*(y*bpow radix2 (2*prec)) - t1).
Let t3 := round radix2 (FLT_exp emin' prec) 
       (Znearest c3) (t1 - ae*bpow radix2 (2*prec)).

Lemma t2_is_exact :
 t2 = x*(y*bpow radix2 (2*prec)) - t1.
Proof with auto with typeclass_instances.
apply round_generic...
rewrite <- Ropp_involutive.
apply generic_format_opp.
replace (-(x * (y * bpow radix2 (2 * prec)) - t1)) with
    (t1 - (x * (y * bpow radix2 (2 * prec)))) by ring.
apply mult_error_FLT...
apply generic_format_FLT_mult_bpow...
unfold Prec_gt_0 in prec_gt_0_ ; omega.
intros K.
rewrite Rabs_right.
rewrite <- Rmult_assoc.
apply Rle_trans with (bpow radix2 (emin - prec)*bpow radix2 (2 * prec)).
rewrite <- bpow_plus.
apply bpow_le.
unfold emin'; omega.
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply xy_ge.
apply Rle_ge; rewrite <- Rmult_assoc.
apply Rmult_le_pos.
apply Rle_trans with (2:=xy_ge).
apply bpow_ge_0.
apply bpow_ge_0.
Qed.

Lemma t3_is_exact :
  t3 = t1 - ae*bpow radix2 (2*prec).
Proof with auto with typeclass_instances.
apply round_generic...
(* *)
pose (e:= cexp radix2 (FLT_exp emin' prec) t1).
eapply generic_format_FLT_other' with (e:=e)...
assert (Y1: generic_format radix2 (FLT_exp emin' prec) t1).
apply generic_format_round...
assert (Y2: generic_format radix2 (FLT_exp emin' prec) ae).
apply generic_format_round...
assert (Y3: bpow radix2 (2 * prec) = F2R (Float radix2 1 (2*prec)%Z)).
unfold F2R; simpl; ring.
rewrite Y2, Y3.
rewrite <- F2R_mult.
rewrite Y1, <- F2R_minus.
easy.
(* *)
split.
apply Z.le_max_r.
fold e.
unfold Fminus; rewrite Fexp_Fplus; simpl.
apply Z.le_trans with 
 (Z.min e ((cexp radix2 (FLT_exp emin' prec) ae)+2*prec))%Z.
2: simpl; auto with zarith.
rewrite Z.min_l; try omega.
apply Z.le_trans with (emin'+2*prec)%Z.
2: apply Zplus_le_compat_r.
2: apply Z.le_max_r.
unfold e, cexp, FLT_exp.
apply Z.max_lub.
2: unfold Prec_gt_0 in prec_gt_0_; omega.
unfold emin'.
assert (mag radix2 t1 <= emin + 2 * prec+1)%Z; try omega.
apply mag_le_bpow.
apply Rgt_not_eq, Rlt_gt.
apply Rlt_le_trans with eta.
apply bpow_gt_0.
apply round_ge_generic...
apply format_eta.
apply Rmult_le_reg_r with (bpow radix2 (-2*prec)).
apply bpow_gt_0.
unfold eta; rewrite <- bpow_plus.
rewrite 2!Rmult_assoc, <- bpow_plus.
ring_simplify (2*prec+-2*prec)%Z; simpl (bpow _ 0); rewrite Rmult_1_r.
apply Rle_trans with (2:=xy_ge).
apply bpow_le.
unfold Prec_gt_0 in prec_gt_0_; unfold emin'; omega.
rewrite Rabs_right.
2: apply Rle_ge, round_ge_generic...
2: apply generic_format_0...
2: rewrite <- Rmult_assoc.
2: apply Rmult_le_pos.
2: apply Rle_trans with (2:=xy_ge).
2: apply bpow_ge_0.
2: apply bpow_ge_0.
apply Rle_lt_trans with
  (pred radix2 (FLT_exp emin' prec) (bpow radix2 (emin + 2*prec+1))).
2: apply pred_lt_id.
2: apply Rgt_not_eq, bpow_gt_0.
assert (Y1: generic_format radix2 (FLT_exp emin' prec) (bpow radix2 (emin + 2 * prec + 1))).
apply generic_format_bpow.
unfold FLT_exp, emin'.
rewrite Z.max_l; unfold Prec_gt_0 in prec_gt_0_; omega.
apply round_N_le_midp...
apply generic_format_pred...
rewrite succ_pred...
rewrite <- Rmult_assoc.
apply Rlt_le_trans with 
  ((bpow radix2 (emin + 1) - bpow radix2 (emin - prec))*
    bpow radix2 (2 * prec)).
apply Rmult_lt_compat_r.
apply bpow_gt_0.
apply xy_lt.
rewrite pred_eq_pos.
2: apply bpow_ge_0.
unfold pred_pos; rewrite Req_bool_true.
2: rewrite mag_bpow; f_equal; ring.
rewrite mag_bpow.
unfold FLT_exp, emin'.
rewrite Z.max_l.
2: unfold Prec_gt_0 in prec_gt_0_; omega.
rewrite Rmult_minus_distr_r, <- 2!bpow_plus.
apply Rle_trans with 
 (bpow radix2 (emin + 2 * prec + 1) + 
    -(bpow radix2 (emin + 2 * prec + 1 + 1 - 1 - prec)/2)).
2: right; field.
replace (emin + 1 + 2 * prec)%Z with (emin + 2 * prec + 1)%Z by ring.
apply Rplus_le_compat_l.
right; f_equal.
unfold Rdiv; replace (/2) with (bpow radix2 (-1)).
rewrite <- bpow_plus.
f_equal; ring.
simpl; easy.
(* *)
replace (t1-ae * bpow radix2 (2 * prec)) with
  ((t1 - (x * (y * bpow radix2 (2 * prec))) +
       bpow radix2 (2 * prec)*-(ae-x*y))) by ring.
apply Rle_lt_trans with (1:=Rabs_triang _ _).
apply Rle_lt_trans with
   (/2*ulp radix2 (FLT_exp emin' prec) t1 +
         bpow radix2 (2 * prec)*(/2*bpow radix2 emin')).
apply Rplus_le_compat.
apply error_le_half_ulp_round...
rewrite Rabs_mult.
rewrite Rabs_right.
2: apply Rle_ge, bpow_ge_0.
apply Rmult_le_compat_l.
apply bpow_ge_0.
rewrite Rabs_Ropp.
apply Rle_trans with (1:=error_le_half_ulp _ _ _ _).
right; f_equal.
apply ulp_FLT_small...
rewrite Rabs_right.
apply Rlt_le_trans with (1:=xy_lt); unfold emin'.
replace (emin-prec+1+prec)%Z with (emin+1)%Z by ring.
apply Rle_trans with (bpow radix2 (emin + 1)+-0)%R;[idtac|right; ring].
apply Rplus_le_compat_l, Ropp_le_contravar.
apply bpow_ge_0.
apply Rle_ge, Rle_trans with (2:=xy_ge), bpow_ge_0.
assert (emin < e)%Z.
assert (emin +prec < mag radix2 t1)%Z.
apply mag_gt_bpow.
apply abs_round_ge_generic...
apply generic_format_bpow...
unfold FLT_exp, emin'.
unfold Prec_gt_0 in prec_gt_0_.
apply Z.max_lub; omega.
rewrite <- Rmult_assoc.
rewrite Rabs_right.
apply Rle_trans with (bpow radix2 (emin-prec)*bpow radix2 (2*prec)).
rewrite <- bpow_plus.
right; f_equal; ring.
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply xy_ge.
apply Rle_ge, Rmult_le_pos.
apply Rle_trans with (2:=xy_ge), bpow_ge_0.
apply bpow_ge_0.
unfold e, cexp, FLT_exp, emin'.
unfold Prec_gt_0 in prec_gt_0_.
rewrite Z.max_l; omega.
apply Rlt_le_trans with 
 (bpow radix2 (prec + e-1)+bpow radix2 (prec + e-1)).
apply Rplus_lt_le_compat.
rewrite ulp_neq_0.
fold e.
replace (/2) with (bpow radix2 (-1)) by easy.
rewrite <- bpow_plus.
apply bpow_lt.
unfold Prec_gt_0 in prec_gt_0_; omega.
apply Rgt_not_eq, Rlt_gt.
apply Rlt_le_trans with (bpow radix2 emin').
apply bpow_gt_0.
apply round_ge_generic...
apply generic_format_bpow.
unfold FLT_exp; rewrite Z.max_r; omega.
rewrite <- Rmult_assoc.
apply Rle_trans with 
 (bpow radix2 (emin - prec)*bpow radix2 (2 * prec)).
rewrite <- bpow_plus; apply bpow_le.
unfold emin'; unfold Prec_gt_0 in prec_gt_0_; omega.
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply xy_ge.
replace (/2) with (bpow radix2 (-1)) by easy.
rewrite <- 2!bpow_plus.
apply bpow_le.
unfold emin'; omega.
apply Rle_trans with (2*bpow radix2 (prec + e - 1)).
right; ring.
replace 2 with (bpow radix2 1) by easy.
rewrite <- bpow_plus.
apply bpow_le; omega.
Qed.

Lemma t3_is_exact_and_exp :
   exists (n:Z), 
  t3 = IZR n * bpow radix2 (cexp radix2 (FLT_exp emin' prec) t1).
Proof with auto with typeclass_instances.
pose (e:= cexp radix2 (FLT_exp emin' prec) t1); fold e.
rewrite t3_is_exact.
assert (Y1: generic_format radix2 (FLT_exp emin' prec) t1).
apply generic_format_round...
assert (Y2: generic_format radix2 (FLT_exp emin' prec) ae).
apply generic_format_round...
assert (Y3: bpow radix2 (2 * prec) = F2R (Float radix2 1 (2*prec)%Z)).
unfold F2R; simpl; ring.
rewrite Y2, Y3.
rewrite <- F2R_mult.
rewrite Y1, <- F2R_minus.
eexists.
unfold F2R; f_equal.
f_equal.
unfold Fminus; rewrite Fexp_Fplus; simpl.
apply trans_eq with 
 (Z.min e ((cexp radix2 (FLT_exp emin' prec) ae)+2*prec))%Z.
simpl; auto with zarith.
rewrite Z.min_l; try omega.
apply Z.le_trans with (emin'+2*prec)%Z.
2: apply Zplus_le_compat_r.
2: apply Z.le_max_r.
unfold e, cexp, FLT_exp.
apply Z.max_lub.
2: unfold Prec_gt_0 in prec_gt_0_; omega.
unfold emin'.
assert (mag radix2 t1 <= emin + 2 * prec+1)%Z; try omega.
apply mag_le_bpow.
apply Rgt_not_eq, Rlt_gt.
apply Rlt_le_trans with eta.
apply bpow_gt_0.
apply round_ge_generic...
apply format_eta.
apply Rmult_le_reg_r with (bpow radix2 (-2*prec)).
apply bpow_gt_0.
unfold eta; rewrite <- bpow_plus.
rewrite 2!Rmult_assoc, <- bpow_plus.
ring_simplify (2*prec+-2*prec)%Z; simpl (bpow _ 0); rewrite Rmult_1_r.
apply Rle_trans with (2:=xy_ge).
apply bpow_le.
unfold Prec_gt_0 in prec_gt_0_; unfold emin'; omega.
rewrite Rabs_right.
2: apply Rle_ge, round_ge_generic...
2: apply generic_format_0...
2: rewrite <- Rmult_assoc.
2: apply Rmult_le_pos.
2: apply Rle_trans with (2:=xy_ge).
2: apply bpow_ge_0.
2: apply bpow_ge_0.
apply Rle_lt_trans with
  (pred radix2 (FLT_exp emin' prec) (bpow radix2 (emin + 2*prec+1))).
2: apply pred_lt_id.
2: apply Rgt_not_eq, bpow_gt_0.
assert (Y4: generic_format radix2 (FLT_exp emin' prec) (bpow radix2 (emin + 2 * prec + 1))).
apply generic_format_bpow.
unfold FLT_exp, emin'.
rewrite Z.max_l; unfold Prec_gt_0 in prec_gt_0_; omega.
apply round_N_le_midp...
apply generic_format_pred...
rewrite succ_pred...
rewrite <- Rmult_assoc.
apply Rlt_le_trans with 
  ((bpow radix2 (emin + 1) - bpow radix2 (emin - prec))*
    bpow radix2 (2 * prec)).
apply Rmult_lt_compat_r.
apply bpow_gt_0.
apply xy_lt.
rewrite pred_eq_pos.
2: apply bpow_ge_0.
unfold pred_pos; rewrite Req_bool_true.
2: rewrite mag_bpow; f_equal; ring.
rewrite mag_bpow.
unfold FLT_exp, emin'.
rewrite Z.max_l.
2: unfold Prec_gt_0 in prec_gt_0_; omega.
rewrite Rmult_minus_distr_r, <- 2!bpow_plus.
apply Rle_trans with 
 (bpow radix2 (emin + 2 * prec + 1) + 
    -(bpow radix2 (emin + 2 * prec + 1 + 1 - 1 - prec)/2)).
2: right; field.
replace (emin + 1 + 2 * prec)%Z with (emin + 2 * prec + 1)%Z by ring.
apply Rplus_le_compat_l.
right; f_equal.
unfold Rdiv; replace (/2) with (bpow radix2 (-1)).
rewrite <- bpow_plus.
f_equal; ring.
simpl; easy.
Qed.

Let z := round radix2 (FLT_exp emin' prec) ZnearestE (t2+t3).
Let z' := -bpow radix2 (emin+prec). (* as ae >=0 in this section *)
Let z'' := round radix2 (FLT_exp emin' prec) ZnearestE (z-t3).
Let z''' := bpow radix2 (emin-prec+1). (* as ae >=0 in this section *)

Lemma format_z''' :  generic_format radix2 (FLT_exp emin' prec) z'''.
Proof with auto with typeclass_instances.
apply generic_format_bpow.
unfold FLT_exp, emin'.
rewrite Z.max_r; omega.
Qed.

Lemma format_z' :  generic_format radix2 (FLT_exp emin' prec) z'.
Proof with auto with typeclass_instances.
apply generic_format_opp.
apply generic_format_bpow.
unfold FLT_exp, emin'.
rewrite Z.max_l; omega.
Qed.

Lemma t3_ge_t2 : t3 = 0 \/ Rabs t2 <= Rabs t3.
Proof with auto with typeclass_instances.
case (Req_dec t3 0); intros H1.
now left.
right.
apply Rle_trans with 
  (/2*ulp radix2 (FLT_exp emin' prec) t1).
rewrite t2_is_exact.
replace (x * (y * bpow radix2 (2 * prec)) - t1) with
   (-(t1-(x * (y * bpow radix2 (2 * prec))))) by ring.
rewrite Rabs_Ropp.
apply error_le_half_ulp_round...
destruct t3_is_exact_and_exp as (n,Hn).
rewrite ulp_neq_0.
rewrite Hn, Rabs_mult.
rewrite (Rabs_right (bpow _ _)).
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply Rle_trans with 1.
left; rewrite <- Rinv_1.
apply Rinv_lt; auto with real.
rewrite <- abs_IZR.
apply IZR_le.
case (Zle_lt_or_eq 0 (Z.abs n)); try omega.
apply Z.abs_nonneg.
intros K; contradict H1.
rewrite Hn; replace n with 0%Z.
ring.
apply sym_eq, Z.abs_0_iff; easy.
apply Rle_ge, bpow_ge_0.
apply Rgt_not_eq, Rlt_gt.
apply Rlt_le_trans with (bpow radix2 emin').
apply bpow_gt_0.
apply round_ge_generic...
apply generic_format_bpow.
unfold FLT_exp; rewrite Z.max_r; omega.
rewrite <- Rmult_assoc.
apply Rle_trans with 
 (bpow radix2 (emin - prec)*bpow radix2 (2 * prec)).
rewrite <- bpow_plus; apply bpow_le.
unfold emin'; unfold Prec_gt_0 in prec_gt_0_; omega.
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply xy_ge.
Qed.

Lemma AM_Full_very_small_aux0:
  ulpH radix2 (FLT_exp emin' prec) ae = -z'*bpow radix2 (-2*prec+1).
Proof with auto with typeclass_instances.
unfold z'; rewrite Ropp_involutive.
unfold emin'; rewrite ulpH_FLT_small...
rewrite <- bpow_plus.
f_equal; ring.
apply generic_format_round...
rewrite Rabs_right.
2: apply Rle_ge; left; apply Positive_ae.
apply Rle_trans with (1:=Very_small_ae).
apply Rplus_le_reg_l with (-bpow radix2 (emin + 1) + bpow radix2 (emin - prec + 1));
  ring_simplify.
apply bpow_ge_0.
Qed.

Lemma AM_Full_very_small_aux1 : 
   t2+t3 = z' <-> (z = z' /\ z'' = t2).
Proof with auto with typeclass_instances.
split.
(* *)
unfold z; rewrite t2_is_exact, t3_is_exact.
replace (x * (y * bpow radix2 (2 * prec)) - t1 +
(t1 - ae * bpow radix2 (2 * prec))) with
(bpow radix2 (2*prec)*(x*y-ae)) by ring.
intros Y.
rewrite Y.
split.
apply round_generic...
apply format_z'.
unfold z'', z; rewrite t3_is_exact, t2_is_exact.
replace (x * (y * bpow radix2 (2 * prec)) - t1 +
(t1 - ae * bpow radix2 (2 * prec))) with
(bpow radix2 (2*prec)*(x*y-ae)) by ring.
rewrite Y.
rewrite round_generic with (x:=z')...
2: apply format_z'.
replace (z' - (t1 - ae * bpow radix2 (2 * prec))) with
   (x * (y * bpow radix2 (2 * prec)) - t1).
2: rewrite <- Y; ring.
apply round_generic...
rewrite <- t2_is_exact.
apply generic_format_round...
(* *)
intros (Y1,Y2).
case t3_ge_t2; intros Y3.
rewrite <- Y1; unfold z; rewrite Y3.
rewrite Rplus_0_r.
rewrite round_generic...
apply generic_format_round...
generalize (Fast2Sum_correct emin' prec 
  (fun x => negb (Z.even x))); intros T.
specialize T with (x:=t3) (y:=t2); generalize T; clear T.
rewrite (Rplus_comm t3 t2); fold z.
replace (t3-z) with (-(z-t3)) by ring.
rewrite round_NE_opp; fold z''.
rewrite Y2; ring_simplify (t2+-t2); rewrite round_0...
rewrite Rplus_0_r, Y1.
intros T; apply sym_eq.
apply T; clear T; try easy.
unfold emin'; omega.
intros t; rewrite Bool.negb_involutive.
rewrite Z.even_opp.
rewrite Z.negb_even.
rewrite <- Z.even_succ; easy.
apply generic_format_round...
apply generic_format_round...
Qed.

Lemma AM_Full_very_small_aux2 : 
   t2+t3 = z' <-> (2 * (ae - x * y) = ulpH radix2 (FLT_exp emin' prec) ae).
Proof with auto with typeclass_instances.
rewrite AM_Full_very_small_aux0.
rewrite t2_is_exact, t3_is_exact.
replace (x * (y * bpow radix2 (2 * prec)) - t1 +
(t1 - ae * bpow radix2 (2 * prec))) with
   ((x*y-ae)*bpow radix2 (2 * prec)) by ring.
split; intros Y.
rewrite <- Y.
rewrite Ropp_mult_distr_l, Rmult_assoc, <- bpow_plus.
ring_simplify (2*prec+(-2*prec+1))%Z.
replace (bpow radix2 1) with 2%R by easy; ring.
rewrite <- (Ropp_involutive z').
apply Rmult_eq_reg_l with (bpow radix2 (-2 * prec + 1)).
2: apply Rgt_not_eq, Rlt_gt, bpow_gt_0.
apply trans_eq with (-( - z' * bpow radix2 (-2 * prec + 1))).
2: ring.
rewrite <- Y.
apply trans_eq with ((x * y - ae) * (bpow radix2 (-2 * prec + 1)*bpow radix2 (2 * prec))).
ring.
rewrite <- bpow_plus.
ring_simplify (-2 * prec + 1 + 2 * prec)%Z.
replace (bpow radix2 1) with 2%R by easy; ring.
Qed.

Lemma AM_Full_very_small_case1_pos :
    z = z' -> z'' = t2 -> ae-z''' = round radix2 (FLT_exp emin' prec) Znearest0 (x*y).
Proof with auto with typeclass_instances.
intros Y1 Y2.
assert (Y3:t2+t3 = z').
apply AM_Full_very_small_aux1; split; easy.
apply AM_Full_very_small_aux2 in Y3.
apply trans_eq with (ae - ulpH radix2 (FLT_exp emin' prec) ae).
f_equal.
unfold z'''; rewrite AM_Full_very_small_aux0; unfold z'.
rewrite Ropp_involutive, <- bpow_plus.
f_equal; ring.
apply round_N_eq_N0_middle_pos...
apply Rle_trans with (2:=xy_ge).
apply bpow_ge_0.
fold ae; apply Rgt_not_eq.
apply Positive_ae.
Qed.

Lemma AM_Full_very_small_case2_pos :
    ~(z = z') \/ ~ (z'' = t2) -> ae = round radix2 (FLT_exp emin' prec) Znearest0 (x*y).
Proof with auto with typeclass_instances.
intros Y1.
assert (Y2:t2+t3 <> z').
case (Req_dec (t2+t3) z'); try easy.
intros Y3; specialize (proj1 AM_Full_very_small_aux1 Y3).
intros (Y4,Y5).
case Y1; easy.
apply round_N_eq_N0_pos...
apply Rle_trans with (2:=xy_ge).
apply bpow_ge_0.
fold ae.
generalize Y2; rewrite t3_is_exact, t2_is_exact.
replace (x * (y * bpow radix2 (2 * prec)) - t1 +
(t1 - ae * bpow radix2 (2 * prec))) with
   ((x*y-ae)*bpow radix2 (2 * prec)) by ring.
rewrite AM_Full_very_small_aux0.
intros J1 J2; apply J1.
rewrite <- (Ropp_involutive z').
apply Rmult_eq_reg_l with (bpow radix2 (-2 * prec + 1)).
2: apply Rgt_not_eq, Rlt_gt, bpow_gt_0.
apply trans_eq with (-( - z' * bpow radix2 (-2 * prec + 1))).
2: ring.
rewrite <- J2.
apply trans_eq with ((x * y - ae) * (bpow radix2 (-2 * prec + 1)*bpow radix2 (2 * prec))).
ring.
rewrite <- bpow_plus.
ring_simplify (-2 * prec + 1 + 2 * prec)%Z.
replace (bpow radix2 1) with 2%R by easy; ring.
Qed.

Lemma AM_Full_very_small_b0_pos : let a0 := round radix2 (FLT_exp emin' prec) Znearest0 (x*y) in
   0 = round radix2 (FLT_exp emin' prec) Znearest0 (x*y-a0).
Proof with auto with typeclass_instances.
intros a0.
apply sym_eq, round_N0_0...
apply Rle_trans with (/2* ulp radix2 (FLT_exp emin' prec) (x*y)).
replace (x*y-a0) with (-(a0-x*y)) by ring; rewrite Rabs_Ropp.
apply error_le_half_ulp...
rewrite ulp_FLT_small...
unfold emin'; replace (/2) with (bpow radix2 (-1)) by easy.
rewrite <- bpow_plus; apply bpow_le; omega.
rewrite Rabs_right.
unfold emin'; apply Rlt_trans with (1:=xy_lt).
replace (emin-prec+1+prec)%Z with (emin+1)%Z by ring.
apply Rplus_lt_reg_l with (-bpow radix2 (emin+1)+bpow radix2 (emin-prec)); ring_simplify.
apply bpow_gt_0.
apply Rle_ge, Rle_trans with (2:=xy_ge).
apply bpow_ge_0.
Qed.

End Augmented_mult_small_pos.

Section Augmented_mult_small.

Variable emin prec : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Let emin' := (emin-prec+1)%Z.

Hypothesis emin_neg : (emin < 0)%Z.
Hypothesis Prec_gt_1 : (1 < prec)%Z.

Variable x y:R.
Hypothesis Fx: generic_format radix2 (FLT_exp emin' prec) x.
Hypothesis Fy: generic_format radix2 (FLT_exp emin' prec) y.

Variable c1 c2 c3: Z->bool.
(* needs even rounding for strict inequalities *)
Let ae := round radix2 (FLT_exp emin' prec) (ZnearestE) (x*y).
Hypothesis Very_small_ae:
   Rabs ae <= bpow radix2 (emin+1) - bpow radix2 (emin-prec+1).
Hypothesis Nonzero_ae: ae <> 0.

Let t1 := round radix2 (FLT_exp emin' prec) 
       (Znearest c1) (x*(y*bpow radix2 (2*prec))).
Let t2 := round radix2 (FLT_exp emin' prec) 
       (Znearest c2) (x*(y*bpow radix2 (2*prec)) - t1).
Let t3 := round radix2 (FLT_exp emin' prec) 
       (Znearest c3) (t1 - ae*bpow radix2 (2*prec)).

Let z := round radix2 (FLT_exp emin' prec) ZnearestE (t2+t3).
Let z' := -sign ae*bpow radix2 (emin+prec).
Let z'' := round radix2 (FLT_exp emin' prec) ZnearestE (z-t3).
Let z''' := sign ae*bpow radix2 (emin-prec+1).

Lemma AM_Full_very_small_case1 :
    z = z' -> z'' = t2 -> ae-z''' = round radix2 (FLT_exp emin' prec) Znearest0 (x*y).
Proof with auto with typeclass_instances.
intros H1 H2.
case (Rle_or_lt 0 ae); intros Zae.
(* pos *)
assert (0 < ae).
case Zae; try easy.
intros K; contradict K; apply sym_not_eq; easy.
assert (H0: sign ae =1).
apply sign_pos; easy.
replace z''' with (bpow radix2 (emin - prec + 1)).
apply AM_Full_very_small_case1_pos with c1 c2 c3; try easy; fold emin'; fold ae.
rewrite <- (Rabs_right ae); try easy.
apply Rle_ge; easy.
apply trans_eq with z; try easy.
rewrite H1; unfold z'.
rewrite H0; ring.
unfold z'''; rewrite H0; ring.
(* neg *)
assert (H0: sign ae =-1).
apply sign_neg; easy.
unfold ae; replace (x*y) with (-((-x)*y)) by ring.
rewrite round_N0_opp.
rewrite round_NE_opp.
apply trans_eq with (-(round radix2 (FLT_exp emin' prec) ZnearestE (- x * y)-bpow radix2 (emin - prec + 1))).
unfold z'''; rewrite H0; ring.
f_equal.
apply AM_Full_very_small_case1_pos with (fun t : Z => negb (c1 (- (t + 1))%Z))  (fun t : Z => negb (c2 (- (t + 1))%Z))  (fun t : Z => negb (c3 (- (t + 1))%Z)); try easy.
apply generic_format_opp...
rewrite <- Ropp_mult_distr_l, round_NE_opp.
rewrite <- Rabs_left; easy.
rewrite <- Ropp_mult_distr_l, round_NE_opp.
apply Ropp_0_gt_lt_contravar; easy.
rewrite <- Ropp_mult_distr_l.
apply trans_eq with (-z).
2: f_equal; rewrite H1; unfold z'.
2: rewrite H0; ring.
rewrite <- (Ropp_involutive (round _ _ _ _)); f_equal; unfold z.
rewrite <- round_NE_opp; f_equal.
rewrite Ropp_plus_distr; f_equal.
rewrite <- round_N_opp; unfold t2; f_equal.
rewrite Ropp_minus_distr.
unfold Rminus; rewrite Rplus_comm; f_equal.
ring.
rewrite <- (Ropp_involutive (round _ _ _ _)); f_equal; unfold t1.
rewrite <- round_N_opp; f_equal.
ring.
rewrite <- round_N_opp; unfold t3; f_equal.
rewrite Ropp_minus_distr.
unfold Rminus; rewrite Rplus_comm; f_equal.
rewrite <- round_N_opp; unfold t1; f_equal.
ring.
rewrite Ropp_mult_distr_l; f_equal.
unfold ae; rewrite <- round_NE_opp.
f_equal; ring.
(* *)
apply sym_eq.
apply trans_eq with (-t2).
rewrite <- (Ropp_involutive (round _ _ _ _)); f_equal; unfold t2.
rewrite <- round_N_opp; f_equal.
unfold Rminus; rewrite Ropp_plus_distr; f_equal.
ring.
f_equal; unfold t1; rewrite <- round_N_opp.
f_equal; ring.
rewrite <- H2.
apply sym_eq; rewrite <- (Ropp_involutive (round _ _ _ _)); f_equal; unfold z''.
rewrite <- round_NE_opp; f_equal.
unfold Rminus; rewrite Ropp_plus_distr; f_equal.
rewrite <- round_NE_opp; unfold z; f_equal.
rewrite Ropp_plus_distr; f_equal.
rewrite <- round_N_opp; unfold t2; f_equal.
unfold Rminus; rewrite Ropp_plus_distr; f_equal.
ring.
rewrite <- round_N_opp; unfold t1; f_equal; f_equal; ring.
rewrite <- round_N_opp; unfold t3; f_equal.
unfold Rminus; rewrite Ropp_plus_distr; f_equal.
rewrite <- round_N_opp; unfold t1; f_equal; ring.
rewrite <- Ropp_mult_distr_l, round_NE_opp.
fold emin'; fold ae; ring.
rewrite <- round_N_opp; unfold t3; f_equal; f_equal.
unfold Rminus; rewrite Ropp_plus_distr; f_equal.
rewrite <- round_N_opp; unfold t1; f_equal; ring.
rewrite <- Ropp_mult_distr_l, round_NE_opp.
fold emin'; fold ae; ring.
Qed.

Lemma AM_Full_very_small_case2 :
    ~(z = z') \/ ~ (z'' = t2) -> ae = round radix2 (FLT_exp emin' prec) Znearest0 (x*y).
Proof with auto with typeclass_instances.
intros H1.
case (Rle_or_lt 0 ae); intros Zae.
(* pos *)
assert (0 < ae).
case Zae; try easy.
intros K; contradict K; apply sym_not_eq; easy.
assert (H0: sign ae =1).
apply sign_pos; easy.
apply AM_Full_very_small_case2_pos with c1 c2 c3; try easy; fold emin'; fold ae.
rewrite <- (Rabs_right ae); try easy.
apply Rle_ge; easy.
fold t1; fold t2; fold t3; fold z; fold z''.
replace (- bpow radix2 (emin + prec)) with z'; try easy.
unfold z'; rewrite H0; ring.
(* neg *)
assert (H0: sign ae =-1).
apply sign_neg; easy.
unfold ae; replace (x*y) with (-((-x)*y)) by ring.
rewrite round_N0_opp.
rewrite round_NE_opp.
f_equal.
apply AM_Full_very_small_case2_pos with (fun t : Z => negb (c1 (- (t + 1))%Z))  (fun t : Z => negb (c2 (- (t + 1))%Z))  (fun t : Z => negb (c3 (- (t + 1))%Z)); try easy.
apply generic_format_opp...
rewrite <- Ropp_mult_distr_l, round_NE_opp.
rewrite <- Rabs_left; easy.
rewrite <- Ropp_mult_distr_l, round_NE_opp.
apply Ropp_0_gt_lt_contravar; easy.
assert ( J1:
  round radix2 (FLT_exp (emin - prec + 1) prec) (Znearest (fun t : Z => negb (c1 (- (t + 1))))) (- x * (y * bpow radix2 (2 * prec)))
  = -t1).
rewrite <- (Ropp_involutive (round _ _ _ _)); f_equal; unfold t1.
rewrite <- round_N_opp; f_equal; ring.
assert (J2: round radix2 (FLT_exp (emin - prec + 1) prec) (Znearest (fun t : Z => negb (c2 (- (t + 1)))))
  (- x * (y * bpow radix2 (2 * prec)) -
   round radix2 (FLT_exp (emin - prec + 1) prec) (Znearest (fun t : Z => negb (c1 (- (t + 1))))) (- x * (y * bpow radix2 (2 * prec))))
 = (-t2)).
rewrite <- (Ropp_involutive (round _ _ _ _)); f_equal; unfold t2.
rewrite <- round_N_opp; f_equal.
unfold Rminus; rewrite Ropp_plus_distr; f_equal.
ring.
rewrite J1; ring.
rewrite J2, J1.
assert (J3: round radix2 (FLT_exp (emin - prec + 1) prec) ZnearestE
  (- t2 +
   round radix2 (FLT_exp (emin - prec + 1) prec) (Znearest (fun t : Z => negb (c3 (- (t + 1)))))
     (- t1 - round radix2 (FLT_exp (emin - prec + 1) prec) ZnearestE (- x * y) * bpow radix2 (2 * prec))) = -z).
rewrite <- (Ropp_involutive (round _ _ _ _)); f_equal; unfold z.
rewrite <- round_NE_opp; f_equal.
unfold Rminus; rewrite Ropp_plus_distr; f_equal.
ring.
rewrite <- round_N_opp; unfold t3; f_equal.
rewrite <- Ropp_mult_distr_l; unfold ae; rewrite round_NE_opp.
unfold emin'; ring.
rewrite J3.
case H1; intros H1'.
left; intros K; apply H1'.
rewrite <- (Ropp_involutive z); rewrite K.
unfold z'; rewrite H0; ring.
right; intros K; apply H1'.
rewrite <- (Ropp_involutive t2); rewrite <- K.
rewrite <- round_NE_opp; unfold z''; f_equal.
unfold Rminus; rewrite Ropp_plus_distr; f_equal.
ring.
rewrite <- round_N_opp.
f_equal; unfold t3; f_equal.
rewrite <- Ropp_mult_distr_l; unfold ae; rewrite round_NE_opp.
unfold emin'; ring.
Qed.

Lemma AM_Full_very_small_b0 : let a0 := round radix2 (FLT_exp emin' prec) Znearest0 (x*y) in
   0 = round radix2 (FLT_exp emin' prec) Znearest0 (x*y-a0).
Proof with auto with typeclass_instances.
intros a0.
case (Rle_or_lt 0 ae); intros Zae.
apply AM_Full_very_small_b0_pos; try easy.
fold emin'; fold ae; rewrite <- (Rabs_right ae); try easy.
apply Rle_ge; easy.
fold emin'; fold ae; case Zae; try easy.
intros K; contradict Nonzero_ae; easy.
replace (x*y-a0) with (-((-x)*y-(-a0))) by ring.
rewrite round_N0_opp.
rewrite <- Ropp_0; f_equal.
unfold a0; rewrite <- round_N0_opp.
rewrite Ropp_mult_distr_l.
apply AM_Full_very_small_b0_pos; try easy.
rewrite <- Ropp_mult_distr_l, round_NE_opp.
fold emin'; fold ae; rewrite <- (Rabs_left ae); try easy.
rewrite <- Ropp_mult_distr_l, round_NE_opp.
fold emin'; fold ae.
apply Ropp_0_gt_lt_contravar; easy.
Qed.

End Augmented_mult_small.

Section Augmented_medium.

Variable emin prec : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Let emin' := (emin-prec+1)%Z.
Hypothesis emin_neg : (emin < 0)%Z.
Hypothesis Prec_gt_1 : (1 < prec)%Z.

Variable x y a' b':R.
Hypothesis Fx: generic_format radix2 (FLT_exp emin' prec) x.
Hypothesis Fy: generic_format radix2 (FLT_exp emin' prec) y.

Variable c1 c2 c3: Z->bool.
Let ae := round radix2 (FLT_exp emin' prec) (ZnearestE) (x*y).
Hypothesis Medium_ae:
   bpow radix2 (emin+1) - bpow radix2 (emin-prec+1) < Rabs ae.
Hypothesis Medium_ae_le:
   Rabs ae <= bpow radix2 (emin+prec).

Lemma Medium_ae_ge : bpow radix2 (emin+1) <= Rabs ae.
Proof with auto with typeclass_instances.
apply Rle_trans with (succ radix2 (FLT_exp emin' prec)
    (bpow radix2 (emin + 1) - bpow radix2 (emin - prec + 1))).
right; rewrite psi_eq.
rewrite succ_pred...
apply generic_format_bpow...
unfold FLT_exp.
rewrite Z.max_l; omega.
apply succ_le_lt...
apply format_psi...
apply generic_format_abs, generic_format_round...
Qed.

Lemma Medium_ge_aux1 :
  bpow radix2 (emin' + prec - 1) <= Rabs (x*y).
Proof with auto with typeclass_instances.
replace (emin'+prec-1)%Z with (emin)%Z.
2: unfold emin'; ring.
case (Rle_or_lt (bpow radix2 emin) (Rabs (x*y))); try easy; intros K.
absurd (bpow radix2 (emin+1) <= Rabs ae).
2: apply Medium_ae_ge.
apply Rlt_not_le.
apply Rle_lt_trans with (bpow radix2 emin).
apply abs_round_le_generic...
apply generic_format_bpow.
unfold FLT_exp, emin'; rewrite Z.max_l; omega.
now left.
apply bpow_lt; omega.
Qed.

Lemma Medium_ge_aux2 :
  bpow radix2 (emin' + 2 * prec - 1) <= Rabs ((bpow radix2 prec*x)*y).
Proof with auto with typeclass_instances.
rewrite Rmult_assoc, Rabs_mult.
rewrite Rabs_right;[idtac|apply Rle_ge, bpow_ge_0].
replace (emin'+2*prec-1)%Z with (prec+(emin'+prec-1))%Z.
2: ring.
rewrite bpow_plus; apply Rmult_le_compat_l.
apply bpow_ge_0.
apply Medium_ge_aux1.
Qed.

Lemma Medium_lt_aux :
  Rabs (x * y) < bpow radix2 (emin + prec + 1).
Proof with auto with typeclass_instances.
case (Rle_or_lt (bpow radix2 (emin + prec + 1)) (Rabs (x * y))); try easy.
intros K.
contradict Medium_ae_le; apply Rlt_not_le.
apply Rlt_le_trans with (bpow radix2 (emin + prec + 1)).
apply bpow_lt; omega.
apply abs_round_ge_generic...
apply generic_format_bpow...
unfold emin', FLT_exp.
rewrite Z.max_l; omega.
Qed.

Hypothesis a'_eq: 
   a' = round radix2 (FLT_exp emin' prec) Znearest0 (bpow radix2 prec*x*y).
Hypothesis b'_eq: b' = bpow radix2 prec*x*y - a'.
Hypothesis Fb' : generic_format radix2 (FLT_exp emin' prec) b'.

Let a0 := round radix2 (FLT_exp emin' prec) (Znearest c1) 
       (bpow radix2 (-prec)*a').

Let beta := round radix2 (FLT_exp emin' prec) (Znearest c2) 
       (bpow radix2 (-prec)*b').

Let z := round radix2 (FLT_exp emin' prec) (Znearest c3) 
           (bpow radix2 prec*beta-b').

Lemma AM_Full_medium_a0_aux :
  a' = bpow radix2 prec*round radix2 (FLT_exp emin' prec) Znearest0 (x*y).
Proof with auto with typeclass_instances.
rewrite a'_eq; apply sym_eq; rewrite Rmult_comm.
unfold emin'; rewrite round_N0_mult_bpow...
f_equal; ring.
apply Rle_trans with (2:=Medium_ge_aux1).
apply bpow_le.
unfold emin'; rewrite Z.max_l; omega.
Qed.

Lemma AM_Full_medium_a0 :
   a0 = round radix2 (FLT_exp emin' prec) Znearest0 (x*y).
Proof with auto with typeclass_instances.
unfold a0; rewrite AM_Full_medium_a0_aux.
rewrite <- Rmult_assoc, <- bpow_plus.
ring_simplify (-prec+prec)%Z; simpl; rewrite Rmult_1_l.
apply round_generic...
apply generic_format_round...
Qed.

Lemma beta_le :
 Rabs beta <= bpow radix2 emin.
Proof with auto with typeclass_instances.
apply abs_round_le_generic...
apply generic_format_bpow.
unfold FLT_exp, emin'.
rewrite Z.max_l; omega.
rewrite Rabs_mult, Rabs_right.
2: apply Rle_ge, bpow_ge_0.
apply Rmult_le_reg_l with (bpow radix2 prec).
apply bpow_gt_0.
rewrite <- Rmult_assoc, <- bpow_plus.
ring_simplify (prec+-prec)%Z; simpl; rewrite Rmult_1_l.
rewrite <- bpow_plus.
rewrite b'_eq.
replace (bpow radix2 prec * x * y - a') with
  (-(a' - (bpow radix2 prec * x * y))) by ring.
rewrite Rabs_Ropp.
assert (Y1: bpow radix2 prec * x * y <> 0).
assert (Y2: Rabs (bpow radix2 prec * x * y) <> 0).
apply Rgt_not_eq, Rlt_gt.
apply Rlt_le_trans with (bpow radix2 (prec+(emin' + prec - 1))).
apply bpow_gt_0.
rewrite Rmult_assoc, Rabs_mult, Rabs_right.
2: apply Rle_ge, bpow_ge_0.
rewrite bpow_plus; apply Rmult_le_compat_l.
apply bpow_ge_0.
apply Medium_ge_aux1.
intros T; apply Y2.
rewrite T; apply Rabs_R0.
apply Rle_trans with
  (/2*ulp radix2 (FLT_exp emin' prec) 
     (bpow radix2 prec * x*y)).
rewrite a'_eq; apply error_le_half_ulp...
rewrite ulp_neq_0...
replace (/2) with (bpow radix2 (-1)) by easy.
rewrite <- bpow_plus.
apply bpow_le.
assert (cexp radix2 (FLT_exp emin' prec) (bpow radix2 prec * x * y)
 <= 1+emin+prec)%Z; try omega.
unfold cexp, FLT_exp, emin'.
apply Z.max_lub; try omega.
rewrite Rmult_assoc, Rmult_comm.
rewrite mag_mult_bpow.
2: intros T; apply Y1.
2: rewrite Rmult_assoc; rewrite T; ring.
ring_simplify (mag radix2 (x*y)+prec-prec)%Z.
destruct (mag radix2 (x * y)) as (e,He).
replace (mag_val _ _ (Build_mag_prop radix2 (x*y) e He)) with e by easy.
assert (e-1 < emin+prec+1)%Z; try omega.
apply lt_bpow with radix2.
apply Rle_lt_trans with (Rabs (x*y)).
apply He.
intros T; apply Y1.
rewrite Rmult_assoc; rewrite T; ring.
apply Medium_lt_aux.
Qed.

Lemma ulp_beta : 
  ulp radix2 (FLT_exp emin' prec) beta = bpow radix2 emin'.
Proof with auto with typeclass_instances.
apply ulp_FLT_small...
unfold emin'.
replace (emin - prec + 1 + prec)%Z with (emin+1)%Z by ring.
apply Rle_lt_trans with (bpow radix2 emin).
2: apply bpow_lt; omega.
apply beta_le.
Qed.

Lemma ulpH_beta : 
  ulpH radix2 (FLT_exp emin' prec) beta = bpow radix2 emin'.
Proof with auto with typeclass_instances.
apply ulpH_FLT_small...
apply generic_format_round...
apply Rle_trans with (1:=beta_le).
apply bpow_le; omega.
Qed.

Lemma z_is_exact : z = bpow radix2 prec*beta-b'.
Proof with auto with typeclass_instances.
unfold z; apply round_generic...
eapply generic_format_FLT_other' with (e:=emin')...
assert (Y1:generic_format radix2 (FLT_exp emin' prec) beta).
apply generic_format_round...
assert (Y2: bpow radix2 prec = F2R (Float radix2 1 prec)).
unfold F2R; simpl; ring.
rewrite Y1, Y2, Fb'.
rewrite <- F2R_mult.
rewrite <- F2R_minus.
easy.
split; try omega.
unfold Fminus; rewrite Fexp_Fplus; simpl.
assert (H: forall t, (emin' <= cexp radix2 (FLT_exp emin' prec) t)%Z).
intros t; unfold FLT_exp, cexp.
apply Z.le_max_r.
apply Z.min_glb.
specialize (H beta); omega.
specialize (H b'); omega.
(* *)
rewrite <- (Rmult_1_l b').
replace 1 with (bpow radix2 prec*bpow radix2 (-prec)).
2: rewrite <- bpow_plus; ring_simplify (prec+-prec)%Z; easy.
rewrite Rmult_assoc, <- Rmult_minus_distr_l.
rewrite Rabs_mult, Rabs_right.
2: apply Rle_ge, bpow_ge_0.
rewrite bpow_plus; apply Rmult_lt_compat_l.
apply bpow_gt_0.
case (Req_dec b' 0); intros Zb'.
unfold beta; rewrite Zb', Rmult_0_r.
rewrite round_0...
rewrite Rminus_0_r, Rabs_R0.
apply bpow_gt_0.
apply Rlt_le_trans with (ulp radix2 (FLT_exp emin' prec) beta).
apply error_lt_ulp_round...
intros K; apply Zb'.
apply Rmult_eq_reg_l with (bpow radix2 (-prec)).
rewrite K; ring.
apply Rgt_not_eq, Rlt_gt, bpow_gt_0.
rewrite ulp_beta; now right.
Qed.

Lemma AM_Full_b0_aux1 : 
  beta = round radix2 (FLT_exp emin' prec) (Znearest c2) (x*y-a0).
Proof with auto with typeclass_instances.
unfold beta; f_equal.
rewrite b'_eq.
rewrite AM_Full_medium_a0_aux.
rewrite <- AM_Full_medium_a0.
rewrite Rmult_minus_distr_l.
rewrite <- 2!Rmult_assoc, <- bpow_plus.
rewrite <- Rmult_assoc, <- bpow_plus.
ring_simplify (-prec+prec)%Z.
simpl; ring.
Qed.

Lemma AM_Full_b0_aux2 : 
   bpow radix2 prec * (beta - (x * y - a0)) = z.
Proof with auto with typeclass_instances.
rewrite z_is_exact, b'_eq.
rewrite AM_Full_medium_a0_aux.
rewrite <- AM_Full_medium_a0.
ring.
Qed.

Lemma AM_Full_b0_case1 :
    z = sign beta *bpow radix2 emin ->
     beta -sign beta*bpow radix2 (emin-prec+1)
         = round radix2 (FLT_exp emin' prec) Znearest0 (x*y-a0).
Proof with auto with typeclass_instances.
intros H1.
fold emin'; rewrite <- ulpH_beta.
apply round_N_eq_N0_middle with c2...
apply AM_Full_b0_aux1.
apply Rmult_eq_reg_r with (bpow radix2 (prec-1)).
apply trans_eq with (bpow radix2 prec * (beta - (x * y - a0))).
unfold Zminus; rewrite bpow_plus.
replace (bpow radix2 (-(1))) with (/2) by easy.
field.
rewrite AM_Full_b0_aux2, H1.
rewrite Rmult_assoc; f_equal.
rewrite ulpH_beta.
rewrite <- bpow_plus; f_equal.
unfold emin'; ring.
apply Rgt_not_eq, bpow_gt_0.
Qed.

Lemma AM_Full_b0_case2 :
    z <> sign beta *bpow radix2 emin ->
      beta = round radix2 (FLT_exp emin' prec) Znearest0 (x*y-a0).
Proof with auto with typeclass_instances.
intros H1.
apply round_N_eq_N0 with c2...
apply AM_Full_b0_aux1.
intros K; apply H1.
apply Rmult_eq_reg_r with (bpow radix2 (1-prec)).
rewrite <- AM_Full_b0_aux2.
apply trans_eq with (2 * (beta - (x * y - a0))).
unfold Zminus; rewrite bpow_plus.
replace (bpow radix2 1) with (2) by easy.
apply trans_eq with ((bpow radix2 prec*bpow radix2 (-prec))
  * (2 * (beta - (x * y - a0)))); try ring.
rewrite <- bpow_plus.
ring_simplify (prec+-prec)%Z.
simpl; ring.
rewrite K.
rewrite Rmult_assoc; f_equal.
rewrite ulpH_beta.
rewrite <- bpow_plus; f_equal.
unfold emin'; ring.
apply Rgt_not_eq, bpow_gt_0.
Qed.

End Augmented_medium.

Section Aug_ops.

Variable emin prec : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Let emin' := (emin-prec+1)%Z.
Hypothesis emin_neg : (emin < 0)%Z.
Hypothesis Prec_gt_1 : (1 < prec)%Z.

Notation round_flt c := (round radix2 (FLT_exp emin' prec) (Znearest c)).
Notation round_flt' r := (round radix2 (FLT_exp emin' prec) r).

Definition Fast2Sum := fun x y =>
   (round_flt' ZnearestE (x+y), round_flt' ZnearestE (y + round_flt' ZnearestE (x - round_flt' ZnearestE (x + y)))).

Definition AA_Simple := fun c1 c2 x y => 
   let (x',y') := if (Rlt_bool (Rabs x) (Rabs y)) then (y,x) else (x,y) in
   let (ae,be) := Fast2Sum x' y' in
     Recomp emin prec c1 c2 ae be.

Definition AM_Full := fun c1 c2 c3 c4 c5 c6 c7 x y =>
  let ae := round_flt' ZnearestE (x*y) in
     if (Rle_bool (Rabs ae) (bpow radix2 (emin+prec))) then
 (* 0 *)   if (Req_bool ae 0) then (0,0) else
           if (Rle_bool (Rabs ae) (bpow radix2 (emin+1) - bpow radix2 (emin-prec+1))) then
 (*very small *)   let t1 := round_flt c1 (x*(y*bpow radix2 (2*prec))) in
                   let t2 := round_flt c2 (x*(y*bpow radix2 (2*prec)) - t1) in
                   let t3 := round_flt c3 (t1 - ae*bpow radix2 (2*prec)) in
                   let z := round_flt' ZnearestE (t2+t3) in
                   if (andb (Req_bool z (-sign(ae)*bpow radix2 (emin+prec))) 
                            (Req_bool (round_flt' ZnearestE (z-t3)) t2)) then
                       (ae-sign(ae)*bpow radix2 (emin-prec+1),0)
                       else (ae,0)
(* medium small*) 
          else let t1 := round_flt c1 (x*(y*bpow radix2 prec)) in
               let t2 := round_flt c2 (x*(y*bpow radix2 prec) - t1) in
               let A' := Recomp emin prec c3 c4 t1 t2 in
               let a0 := round_flt c5 (bpow radix2 (-prec)*fst A') in
               let beta := round_flt c6 (bpow radix2 (-prec)*snd A') in
               let z:= round_flt c7 (bpow radix2 prec*beta-snd A') in
               if (Req_bool z (sign beta*bpow radix2 emin)) then
                    (a0, beta - sign(beta)*bpow radix2 (emin-prec+1))
                     else (a0,beta)
(*big*) else
         let be := round_flt' ZnearestE (x*y-ae) in
           Recomp emin prec c1 c2 ae be.

Lemma Fast2Sum_correct': forall x y, 
   generic_format radix2 (FLT_exp emin' prec) x ->
   generic_format radix2 (FLT_exp emin' prec) y ->
   Rabs y <= Rabs x -> 
   let X := Fast2Sum x y in
     x+y = fst X + snd X /\ fst X = round_flt' ZnearestE (x+y).
Proof with auto with typeclass_instances.
intros x y Fx Fy H; split.
2: easy.
unfold Fast2Sum; simpl.
apply sym_eq, Fast2Sum_correct; try easy.
unfold emin'; omega.
intros t; rewrite Bool.negb_involutive.
rewrite Z.even_opp.
rewrite Z.negb_even.
rewrite <- Z.even_succ; easy.
Qed.

Lemma AA_Simple_correct : forall c1 c2 x y,
   generic_format radix2 (FLT_exp emin' prec) x ->
   generic_format radix2 (FLT_exp emin' prec) y ->
   let (a0,b0) := AA_Simple c1 c2 x y in
       x+y = a0 + b0 /\ a0 = round_flt' Znearest0 (x+y).
Proof with auto with typeclass_instances.
intros c1 c2 x y Fx Fy.
case_eq (AA_Simple c1 c2 x y); intros a0 b0 H0.
case (Rle_or_lt (Rabs y) (Rabs x)); intros H1.
pose (Z:=Fast2Sum x y).
assert ((a0,b0) = Recomp emin prec c1 c2 (fst Z) (snd Z)).
rewrite <- H0; unfold AA_Simple.
rewrite Rlt_bool_false; try easy.
split.
generalize (Fast2Sum_correct' x y Fx Fy H1); intros (T1,T2).
rewrite T1; fold Z.
generalize (Recomp_correct1_all emin prec emin_neg c1 c2 (fun x => negb (Z.even x)) (fst Z) (snd Z)).
destruct (Recomp emin prec c1 c2 (fst Z) (snd Z)) as (k1,k2); intros T.
apply trans_eq with (k1+k2).
rewrite <- T; try easy.
unfold Z; rewrite <- T1; easy.
unfold Z, Fast2Sum; apply generic_format_round...
apply trans_eq with (fst (a0,b0) + snd (a0,b0)); try easy.
rewrite H; easy.
generalize (Fast2Sum_correct' x y Fx Fy H1); intros (T1,T2); rewrite T1.
apply Recomp_correct2_all with c1 c2 (fun x => negb (Z.even x)); try easy.
rewrite <- T1; easy.
unfold Fast2Sum; apply generic_format_round...
apply trans_eq with (fst (a0,b0)); try easy.
rewrite H; easy.
(* *)
pose (Z:=Fast2Sum y x).
assert ((a0,b0) = Recomp emin prec c1 c2 (fst Z) (snd Z)).
rewrite <- H0; unfold AA_Simple.
rewrite Rlt_bool_true; try easy.
assert (H1': Rabs x <= Rabs y) by now left.
split.
generalize (Fast2Sum_correct' y x Fy Fx H1'); intros (T1,T2).
rewrite Rplus_comm, T1; fold Z.
generalize (Recomp_correct1_all emin prec emin_neg c1 c2 (fun x => negb (Z.even x)) (fst Z) (snd Z)).
destruct (Recomp emin prec c1 c2 (fst Z) (snd Z)) as (k1,k2); intros T.
apply trans_eq with (k1+k2).
rewrite <- T; try easy.
unfold Z; rewrite <- T1; easy.
unfold Z, Fast2Sum; apply generic_format_round...
apply trans_eq with (fst (a0,b0) + snd (a0,b0)); try easy.
rewrite H; easy.
generalize (Fast2Sum_correct' y x Fy Fx H1'); intros (T1,T2); rewrite Rplus_comm, T1.
apply Recomp_correct2_all with c1 c2 (fun x => negb (Z.even x)); try easy.
rewrite <- T1; easy.
unfold Fast2Sum; apply generic_format_round...
apply trans_eq with (fst (a0,b0)); try easy.
rewrite H; easy.
Qed.

Lemma AM_Full_correct : forall c1 c2 c3 c4 c5 c6 c7 x y,
   generic_format radix2 (FLT_exp emin' prec) x ->
   generic_format radix2 (FLT_exp emin' prec) y ->
    let (a0,b0) := AM_Full c1 c2 c3 c4 c5 c6 c7 x y in
       a0 = round_flt' Znearest0 (x*y) /\ b0 = round_flt' Znearest0 (x*y-a0).
Proof with auto with typeclass_instances.
intros c1 c2 c3 c4 c5 c6 c7 x y Fx Fy.
unfold AM_Full.
pose (ae:=round_flt' ZnearestE (x * y)); fold ae.
case (Rle_bool_spec (Rabs ae) (bpow radix2 (emin + prec))); intros H1.
case (Req_bool_spec ae 0); intros H2.
(* ae = 0 *)
assert (Rabs (x*y) <= bpow radix2 (emin - prec)).
apply Rabs_le; split.
apply Rle_trans with ((0+pred radix2 (FLT_exp emin' prec) 0)/2).
rewrite pred_0.
rewrite ulp_FLT_small...
unfold emin'; rewrite bpow_plus.
replace (bpow radix2 1) with 2 by easy.
right; field.
rewrite Rabs_R0; apply bpow_gt_0.
apply round_N_ge_ge_midp with (fun x => negb (Z.even x))...
apply generic_format_0...
fold ae; rewrite H2; auto with real.
apply Rle_trans with ((0+succ radix2 (FLT_exp emin' prec) 0)/2).
apply round_N_le_le_midp with (fun x => negb (Z.even x))...
apply generic_format_0...
fold ae; rewrite H2; auto with real.
rewrite succ_0.
rewrite ulp_FLT_small...
unfold emin'; rewrite bpow_plus.
replace (bpow radix2 1) with 2 by easy.
right; field.
rewrite Rabs_R0; apply bpow_gt_0.
split; apply sym_eq.
apply round_N0_0...
rewrite Rminus_0_r.
apply round_N0_0...
case (Rle_bool_spec (Rabs ae) (bpow radix2 (emin + 1) - bpow radix2 (emin - prec + 1))); intros H3.
(* ae very small *)
pose (t1 := round_flt c1 (x*(y*bpow radix2 (2*prec)))); fold t1.
pose (t2 := round_flt c2 (x*(y*bpow radix2 (2*prec)) - t1)); fold t2.
pose (t3 := round_flt c3 (t1 - ae*bpow radix2 (2*prec))); fold t3.
pose (z := round_flt' ZnearestE (t2+t3)); fold z.
case_eq (andb (Req_bool z (- sign ae * bpow radix2 (emin + prec))) (Req_bool ((round_flt' ZnearestE) (z - t3)) t2)); intros H4.
 (* - and middle *)
assert (J: ae - sign ae * bpow radix2 (emin - prec + 1) = (round_flt' Znearest0) (x * y)).
apply AM_Full_very_small_case1 with c1 c2 c3; try easy.
fold emin'; fold t1; fold t2; fold ae; fold t3; fold z.
apply andb_prop in H4; destruct H4 as (H5,H6).
generalize (Req_bool_spec z (- sign ae * bpow radix2 (emin + prec))).
rewrite H5; intros Y; inversion Y; easy.
fold emin'; fold t1; fold t2; fold ae; fold t3; fold z.
apply andb_prop in H4; destruct H4 as (H5,H6).
generalize (Req_bool_spec ((round_flt' ZnearestE) (z - t3)) t2).
rewrite H6; intros Y; inversion Y; easy.
split; try easy.
rewrite J.
apply AM_Full_very_small_b0; try easy.
 (* - not middle *)
assert (J: ae = (round_flt' Znearest0) (x * y)).
apply AM_Full_very_small_case2 with c1 c2 c3; try easy.
fold emin'; fold t1; fold t2; fold ae; fold t3; fold z.
apply Bool.andb_false_elim in H4.
case H4; intros H5.
left.
generalize (Req_bool_spec z (- sign ae * bpow radix2 (emin + prec))).
rewrite H5; intros Y; inversion Y; easy.
right.
generalize (Req_bool_spec ((round_flt' ZnearestE) (z - t3)) t2).
rewrite H5; intros Y; inversion Y; easy.
split; try easy.
rewrite J.
apply AM_Full_very_small_b0; try easy.
(* ae medium small *)
pose (t1 := round_flt c1 (x*(y*bpow radix2 prec))); fold t1.
pose (t2 := round_flt c2 (x*(y*bpow radix2 prec) - t1)); fold t2.
pose (A' := Recomp emin prec c3 c4 t1 t2); fold A'.
pose (a0 := round_flt c5 (bpow radix2 (-prec)*fst A')); fold a0.
pose (beta := round_flt c6 (bpow radix2 (-prec)*snd A')); fold beta.
pose (z:= round_flt c7 (bpow radix2 prec*beta-snd A')); fold z.
assert (V0: bpow radix2 emin < Rabs t1).
apply Rlt_le_trans with (bpow radix2 (emin+1)).
apply bpow_lt; omega.
apply abs_round_ge_generic...
apply generic_format_bpow...
unfold FLT_exp, emin'; rewrite Z.max_l; omega.
apply Rle_trans with (bpow radix2 (emin - prec + 1 + 2 * prec - 1)).
apply bpow_le; omega.
rewrite <- Rmult_assoc, (Rmult_comm _ (bpow _ _)), <- Rmult_assoc.
apply Medium_ge_aux2...
assert (V1 : bpow radix2 prec * x * y = t1+t2).
unfold t2; rewrite round_generic...
ring.
replace  (x * (y * bpow radix2 prec) - t1) with (-(t1 - (x * (y * bpow radix2 prec)))) by ring.
apply generic_format_opp...
apply mult_error_FLT...
apply generic_format_FLT_mult_bpow...
omega.
intros T; rewrite <- Rmult_assoc, (Rmult_comm _ (bpow _ _)), <- Rmult_assoc.
apply Medium_ge_aux2...
assert (V2: fst A' = round radix2 (FLT_exp (emin - prec + 1) prec) Znearest0 (bpow radix2 prec * x * y)).
rewrite V1.
apply Recomp_correct2 with c3 c4 c1...
rewrite <- V1; unfold t1; f_equal; ring.
assert (V3: a0 = round_flt' Znearest0 (x * y)).
apply AM_Full_medium_a0...
assert (V4: snd A' = bpow radix2 prec * x * y - fst A').
rewrite V1.
generalize (Recomp_correct1 emin prec emin_neg c3 c4 t1 t2); fold A'.
case_eq A'; intros y1 y2 Hy; intros T.
rewrite <- T; simpl; try easy; try ring.
apply generic_format_round...
assert (V5: generic_format radix2 (FLT_exp (emin - prec + 1) prec) (snd A')).
unfold A', Recomp; case Req_bool; simpl.
apply generic_format_opp, generic_format_round...
apply generic_format_round...
(* - *)
case (Req_bool_spec _ _); intros H4.
split; try easy.
apply AM_Full_b0_case1 with c7...
split; try easy.
apply AM_Full_b0_case2 with c7...
(* ae big *)
pose (be:=round_flt' ZnearestE (x * y - ae)).
(* - *)
assert (H: be = x*y - ae).
apply round_generic...
replace (x*y-ae) with (-(ae-x*y)) by ring.
apply generic_format_opp.
apply mult_error_FLT...
intros K.
unfold emin'.
replace (emin - prec + 1 + 2 * prec - 1)%Z with (emin+prec)%Z by ring.
case (Rle_or_lt (bpow radix2 (emin +prec)) (Rabs (x * y))); try easy.
intros KK; contradict H1; apply Rle_not_lt.
apply abs_round_le_generic...
apply generic_format_bpow...
unfold FLT_exp, emin'.
rewrite Z.max_l; omega.
now left.
(* - *)
fold be.
case_eq (Recomp emin prec c1 c2 ae be); intros a0 b0 H0.
split.
apply trans_eq with (round radix2 (FLT_exp (emin - prec + 1) prec) Znearest0 (ae + be)).
apply Recomp_correct2 with c1 c2 (fun x => negb (Z.even x)); try easy.
apply Rle_lt_trans with (2:=H1).
apply bpow_le; omega.
replace (ae+be) with (x*y); try easy.
rewrite H; ring.
rewrite H0; easy.
replace (ae+be) with (x*y); try easy.
rewrite H; ring.
generalize (Recomp_correct1 emin prec emin_neg c1 c2 ae be); intros T.
rewrite H0 in T.
replace (x*y-a0) with b0.
apply sym_eq, round_generic...
replace b0 with (snd (a0,b0));[rewrite <- H0|easy].
unfold Recomp; case (Req_bool _ _); simpl.
apply generic_format_opp; apply generic_format_round...
apply generic_format_round...
apply Rplus_eq_reg_l with a0.
rewrite T.
rewrite H; ring.
apply generic_format_round...
apply Rle_lt_trans with (2:=H1).
apply bpow_le; omega.
Qed.

End Aug_ops.