(****************************************************************************
                                                                             
          IEEE754  :  FexpDiv                                                    
                                                                             
                 Sylvie Boldo                                           
                                                                             
  ******************************************************************************)
Require Export AllFloat.
Section Div.
Variables wi wi1 qi D N qi1 wi2 ai bi eps1 eps2 eps3 ep : R.
Hypothesis Hw : wi = (wi1 - qi * D)%R :>R.
Hypothesis Ha : (Rabs (/ wi1 * (ai - wi1)) <= eps1)%R.
Hypothesis Hb : (Rabs (/ D * (bi - D)) <= eps2)%R.
Hypothesis Hq : (Rabs (/ (/ bi * ai) * (qi - / bi * ai)) <= eps3)%R.
Hypothesis NZwi : wi1 <> 0%R.
Hypothesis NZD : D <> 0%R.
Hypothesis NZbi : bi <> 0%R.
Hypothesis NZai : ai <> 0%R.
Hypothesis PosEps1 : (0 <= eps1)%R.
Hypothesis PosEps2 : (0 <= eps2)%R.
Hypothesis PosEps3 : (0 <= eps3)%R.
Hypothesis LeEps1 : (eps1 < 1)%R.
Hypothesis LeEps2 : (eps2 < 1)%R.
Hypothesis LeEps3 : (eps3 < 1)%R.
Hypothesis Hep : ep = Rmax (Rmax eps1 eps2) eps3 :>R.
 
Theorem InegAbsInf :
 forall x y eps : R,
 x <> 0%R ->
 (Rabs (/ x * (y - x)) <= eps)%R -> (Rabs y <= (1 + eps) * Rabs x)%R.
intros x y eps H H0.
replace ((1 + eps) * Rabs x)%R with (Rabs x + eps * Rabs x)%R;
 [ idtac | ring ].
replace (Rabs y) with (Rabs x + (Rabs y - Rabs x))%R; [ idtac | ring ].
apply Rplus_le_compat_l.
apply Rle_trans with (Rabs (y - x)).
apply Rabs_triang_inv.
apply Rmult_le_reg_l with (/ Rabs x)%R.
replace (/ Rabs x * (eps * Rabs x))%R with eps.
apply Rinv_0_lt_compat; apply Rabs_pos_lt; auto with real.
rewrite (Rmult_comm eps); rewrite <- Rmult_assoc; rewrite Rinv_l; try ring;
 apply Rabs_no_R0; auto with real.
rewrite (Rmult_comm eps); rewrite <- Rmult_assoc; rewrite Rinv_l;
 try apply Rabs_no_R0; auto with real; rewrite Rmult_1_l.
rewrite <- Rabs_Rinv; auto with real; rewrite <- Rabs_mult; auto.
Qed.
 
Theorem InegAbsSup :
 forall x y eps : R,
 x <> 0%R ->
 (Rabs (/ x * (y - x)) <= eps)%R -> ((1 - eps) * Rabs x <= Rabs y)%R.
intros x y eps H H0.
replace ((1 - eps) * Rabs x)%R with (Rabs x + - (eps * Rabs x))%R;
 [ idtac | ring ].
replace (Rabs y) with (Rabs x + - (Rabs x - Rabs y))%R; [ idtac | ring ].
apply Rplus_le_compat_l.
apply Ropp_le_contravar.
apply Rle_trans with (Rabs (y - x)).
rewrite Rabs_minus_sym.
apply Rabs_triang_inv.
apply Rmult_le_reg_l with (/ Rabs x)%R.
apply Rinv_0_lt_compat; apply Rabs_pos_lt; auto with real.
rewrite (Rmult_comm eps); rewrite <- Rmult_assoc; rewrite Rinv_l;
 try apply Rabs_no_R0; auto with real; rewrite Rmult_1_l.
rewrite <- Rabs_Rinv; auto with real; rewrite <- Rabs_mult; auto.
Qed.
 
Theorem DivFirstCase :
 ((Rabs wi1 - Rabs (qi * D)) * / Rabs wi1 <=
  1 - (1 - eps3) * (1 - eps1) * / (1 + eps2))%R.
apply Rle_trans with (1 - Rabs (qi * D) * / Rabs wi1)%R.
right.
replace 1%R with (Rabs wi1 * / Rabs wi1)%R;
 [ ring | apply Rinv_r; apply Rabs_no_R0; auto with real ].
unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_contravar.
fold (1 - eps1)%R in |- *; fold (1 - eps3)%R in |- *.
apply
 Rle_trans
  with ((1 - eps3) * (1 - eps1) * Rabs D * / ((1 + eps2) * Rabs D))%R;
 [ right | idtac ].
replace ((1 - eps3) * (1 - eps1) * Rabs D * / ((1 + eps2) * Rabs D))%R with
 ((1 - eps3) * (1 - eps1) * (Rabs D * / Rabs D) * / (1 + eps2))%R;
 [ replace (Rabs D * / Rabs D)%R with 1%R | idtac ].
ring.
apply sym_eq; apply Rinv_r; apply Rabs_no_R0; auto with real.
replace (/ ((1 + eps2) * Rabs D))%R with (/ (1 + eps2) * / Rabs D)%R;
 [ ring | idtac ].
apply sym_eq; apply Rinv_mult_distr;
 [ auto with real | apply Rabs_no_R0; auto ].
apply not_eq_sym; apply Rlt_dichotomy_converse; left; auto with real.
apply Rlt_le_trans with 1%R; auto with real.
pattern 1%R at 1 in |- *; replace 1%R with (1 + 0)%R; auto with real.
apply Rle_trans with ((1 - eps3) * (1 - eps1) * Rabs D * / Rabs bi)%R.
apply Rmult_le_compat_l.
left; apply Rmult_lt_0_compat; auto with real.
apply Rmult_lt_0_compat; auto with real.
apply Rabs_pos_lt; auto with real.
apply Rle_Rinv; auto with real.
apply Rabs_pos_lt; auto with real.
apply InegAbsInf; auto.
apply
 Rle_trans
  with
    ((1 - eps3) * ((1 - eps1) * Rabs wi1) * Rabs D * (/ Rabs wi1 * / Rabs bi))%R;
 [ right | idtac ].
replace
 ((1 - eps3) * ((1 - eps1) * Rabs wi1) * Rabs D * (/ Rabs wi1 * / Rabs bi))%R
 with
 ((1 - eps3) * ((1 - eps1) * / Rabs bi) * Rabs D * (Rabs wi1 * / Rabs wi1))%R;
 [ replace (Rabs wi1 * / Rabs wi1)%R with 1%R; [ ring | idtac ] | ring ].
apply sym_eq; apply Rinv_r; apply Rabs_no_R0; auto with real.
apply
 Rle_trans with ((1 - eps3) * Rabs ai * Rabs D * (/ Rabs wi1 * / Rabs bi))%R.
apply Rmult_le_compat_r.
left; apply Rmult_lt_0_compat; auto with real.
apply Rinv_0_lt_compat; auto with real; apply Rabs_pos_lt; auto with real.
apply Rinv_0_lt_compat; auto with real; apply Rabs_pos_lt; auto with real.
apply Rmult_le_compat_r; auto with real.
apply Rmult_le_compat_l; auto with real.
apply InegAbsSup; auto.
replace ((1 - eps3) * Rabs ai * Rabs D * (/ Rabs wi1 * / Rabs bi))%R with
 (/ Rabs bi * ((1 - eps3) * Rabs ai) * Rabs D * / Rabs wi1)%R;
 [ apply Rmult_le_compat_r | ring ].
left; apply Rinv_0_lt_compat; auto with real; apply Rabs_pos_lt;
 auto with real.
rewrite (Rabs_mult qi D).
apply Rmult_le_compat_r; auto with real.
replace (/ Rabs bi * ((1 - eps3) * Rabs ai))%R with
 ((1 - eps3) * (/ Rabs bi * Rabs ai))%R; [ idtac | ring; ring ].
replace (/ Rabs bi * Rabs ai)%R with (Rabs (/ bi * ai)).
apply InegAbsSup; auto.
apply Rmult_integral_contrapositive; split; auto; apply Rinv_neq_0_compat;
 auto.
rewrite Rabs_mult; rewrite Rabs_Rinv; auto with real.
Qed.
 
Theorem DivSecondCase :
 ((Rabs (qi * D) - Rabs wi1) * / Rabs wi1 <=
  (1 + eps3) * (1 + eps1) * / (1 - eps2) - 1)%R.
apply Rle_trans with (Rabs (qi * D) * / Rabs wi1 - 1)%R; [ right | idtac ].
rewrite <- (Rinv_l (Rabs wi1)); auto with real; try ring.
apply Rabs_no_R0; auto with real.
replace (Rabs (qi * D) * / Rabs wi1 - 1)%R with
 (-1 + Rabs (qi * D) * / Rabs wi1)%R; [ idtac | ring ].
replace ((1 + eps3) * (1 + eps1) * / (1 - eps2) - 1)%R with
 (-1 + (1 + eps3) * (1 + eps1) * / (1 - eps2))%R; [ idtac | ring ].
apply Rplus_le_compat_l.
rewrite (Rabs_mult qi D).
apply Rle_trans with ((1 + eps3) * Rabs (/ bi * ai) * Rabs D * / Rabs wi1)%R.
apply Rmult_le_compat_r; auto with real.
left; apply Rinv_0_lt_compat; auto with real; apply Rabs_pos_lt;
 auto with real.
apply Rmult_le_compat_r; auto with real.
apply InegAbsInf; auto.
apply Rmult_integral_contrapositive; split; auto; apply Rinv_neq_0_compat;
 auto.
rewrite Rabs_mult.
apply
 Rle_trans
  with
    ((1 + eps3) * (Rabs (/ bi) * ((1 + eps1) * Rabs wi1)) * Rabs D *
     / Rabs wi1)%R.
apply Rmult_le_compat_r; auto with real.
left; apply Rinv_0_lt_compat; auto with real; apply Rabs_pos_lt;
 auto with real.
apply Rmult_le_compat_r; auto with real.
apply Rmult_le_compat_l; auto with real.
apply Rle_trans with (1 + 0)%R; auto with real.
replace (1 + 0)%R with 1%R; auto with real; ring.
apply Rmult_le_compat_l; auto with real.
apply InegAbsInf; auto.
replace
 ((1 + eps3) * (Rabs (/ bi) * ((1 + eps1) * Rabs wi1)) * Rabs D * / Rabs wi1)%R
 with
 ((1 + eps3) * (1 + eps1) * (Rabs (/ bi) * Rabs D * (Rabs wi1 * / Rabs wi1)))%R;
 [ idtac | ring; ring ].
replace (Rabs wi1 * / Rabs wi1)%R with 1%R;
 [ idtac | apply sym_eq; apply Rinv_r; apply Rabs_no_R0; auto with real ].
replace (Rabs (/ bi) * Rabs D * 1)%R with (Rabs (/ bi) * Rabs D)%R;
 [ apply Rmult_le_compat_l; auto with real | ring ].
left; apply Rmult_lt_0_compat; auto with real.
apply Rlt_le_trans with (1 + 0)%R; auto with real.
replace (1 + 0)%R with 1%R; auto with real; ring.
apply Rlt_le_trans with (1 + 0)%R; auto with real.
replace (1 + 0)%R with 1%R; auto with real; ring.
apply Rmult_le_reg_l with (1 - eps2)%R; auto with real.
rewrite Rinv_r; auto with real.
rewrite Rabs_Rinv; auto.
apply Rmult_le_reg_l with (Rabs bi); auto with real.
apply Rabs_pos_lt; auto with real.
apply Rle_trans with ((1 - eps2) * (Rabs D * (Rabs bi * / Rabs bi)))%R;
 [ right; ring | rewrite (Rinv_r (Rabs bi)) ]; auto with real.
repeat rewrite Rmult_1_r.
apply InegAbsSup; auto.
apply Rabs_no_R0; auto.
Qed.
 
Definition dsd (x y : R) :=
  (0 <= x)%R /\ (0 <= y)%R \/ (x <= 0)%R /\ (y <= 0)%R.
 
Theorem dsdAbs :
 forall x y : R, dsd x y -> Rabs (x - y) = Rabs (Rabs x - Rabs y).
unfold dsd in |- *; intros.
case H; intros H1; elim H1; intros; clear H1 H.
rewrite (Rabs_pos_eq x); auto with real.
rewrite (Rabs_pos_eq y); auto with real.
rewrite (Faux.Rabsolu_left1 x); auto with real.
rewrite (Faux.Rabsolu_left1 y); auto with real.
replace (- x - - y)%R with (- (x - y))%R;
 [ rewrite (Rabs_Ropp (x - y)) | ring ]; auto with real.
Qed.
 
Theorem dsdsym : forall x y : R, dsd x y -> dsd y x.
unfold dsd in |- *; intros; auto.
case H; intros H1; case H1; intros; clear H H1; auto.
Qed.
 
Theorem Inegdsd :
 forall x y eps : R,
 x <> 0%R -> (eps < 1)%R -> (Rabs (/ x * (y - x)) <= eps)%R -> dsd x y.
intros x y eps H H0 H1.
cut (Rabs (/ x * (y - x)) < 1)%R;
 [ intros Z1 | apply Rle_lt_trans with eps; auto with real ].
case (Rle_or_lt x 0); intros Z2; case (Rle_or_lt y 0); intros Z3; auto.
right; auto.
3: left; split; apply Rlt_le; auto with real.
left; split; [ idtac | apply Rlt_le; auto with real ].
Contradict Z1.
apply Rle_not_lt.
rewrite Rabs_mult.
rewrite Rabs_Rinv; auto.
apply Rmult_le_reg_l with (Rabs x); auto with real.
apply Rabs_pos_lt; auto with real.
replace (Rabs x * (/ Rabs x * Rabs (y - x)))%R with
 (Rabs (y - x) * (Rabs x * / Rabs x))%R; [ idtac | ring ].
rewrite Rinv_r.
apply Rmult_le_compat_r; auto with real.
apply Rlt_le; auto with real.
rewrite (Faux.Rabsolu_left1 x); auto.
rewrite (Rabs_pos_eq (y - x)); auto with real.
replace (- x)%R with (0 + - x)%R;
 [ unfold Rminus in |- *; auto with real | ring ].
apply Rle_trans with y; [ apply Rlt_le; auto | unfold Rminus in |- * ].
pattern y at 1 in |- *; replace y with (y + -0)%R;
 [ apply Rplus_le_compat_l; apply Ropp_le_contravar; auto with real | ring ].
apply Rabs_no_R0; auto.
right; split; auto.
Contradict Z1.
apply Rle_not_lt.
rewrite Rabs_mult.
rewrite Rabs_Rinv; auto.
apply Rmult_le_reg_l with (Rabs x); auto with real.
apply Rabs_pos_lt; auto with real.
replace (Rabs x * (/ Rabs x * Rabs (y - x)))%R with
 (Rabs (y - x) * (Rabs x * / Rabs x))%R; [ idtac | ring ].
rewrite Rinv_r.
apply Rmult_le_compat_r; auto with real.
rewrite (Rabs_pos_eq x); auto.
rewrite (Faux.Rabsolu_left1 (y - x)); auto with real.
rewrite Ropp_minus_distr'.
pattern x at 1 in |- *; replace x with (x + -0)%R;
 [ unfold Rminus in |- *; auto with real | ring ].
apply Rle_trans with y; [ unfold Rminus in |- * | auto ].
pattern y at 2 in |- *; replace y with (y + -0)%R;
 [ apply Rplus_le_compat_l; apply Ropp_le_contravar; auto with real | ring ].
apply Rlt_le; auto.
apply Rabs_no_R0; auto.
Qed.
 
Theorem dsdtrans :
 forall x y z : R, dsd x y -> dsd y z -> y <> 0%R -> dsd x z.
intros x y z H H0 H1.
case H0; intros (H'1, H'2); case H; intros (H'3, H'4); auto.
left; auto.
Contradict H1; apply Rle_antisym; auto.
Contradict H1; apply Rle_antisym; auto.
right; auto.
Qed.
 
Theorem dsdinv : forall x y : R, dsd x y -> y <> 0%R -> dsd x (/ y).
intros x y H H0.
case H; intros (H'1, H'2).
left; split; auto with real.
case H'2; intros H'3.
apply Rlt_le; apply Rinv_0_lt_compat; auto.
case H0; auto.
right; split; auto.
case H'2; intros H'3.
apply Rlt_le; apply Rinv_lt_0_compat; auto.
case H0; auto.
Qed.
 
Theorem dsdmult : forall x y r : R, dsd x y -> dsd (r * x) (r * y).
intros x y r H.
case (Rle_or_lt r 0); intros z1.
case H; intros (H'1, H'2).
right; split; apply Ropp_le_cancel; rewrite Ropp_0;
 rewrite <- Ropp_mult_distr_l_reverse; auto.
replace 0%R with (-0 * 0)%R; [ auto with real | ring ].
replace 0%R with (-0 * 0)%R; [ auto with real | ring ].
left; split.
replace (r * x)%R with (- r * - x)%R; [ idtac | ring ].
replace 0%R with (-0 * -0)%R; [ auto with real | ring ].
replace (r * y)%R with (- r * - y)%R; [ idtac | ring ].
replace 0%R with (-0 * -0)%R; [ auto with real | ring ].
case H; intros (H'1, H'2).
left; split.
replace 0%R with (0 * 0)%R; [ auto with real | ring ].
replace 0%R with (0 * 0)%R; [ auto with real | ring ].
right; split; apply Ropp_le_cancel; rewrite Ropp_0; rewrite Rmult_comm;
 rewrite <- Ropp_mult_distr_l_reverse.
replace 0%R with (-0 * 0)%R; [ auto with real | ring ].
replace 0%R with (-0 * 0)%R; [ auto with real | ring ].
Qed.
 
Theorem dsdwi1qiD : dsd wi1 (qi * D).
case (Req_dec qi 0); intros H.
rewrite H; replace (0 * D)%R with 0%R; [ auto with real | ring ].
case (Rle_or_lt wi1 0); intros H1; auto with real.
right; split; auto with real.
left; split; auto with real; apply Rlt_le; auto.
cut (dsd wi1 ai); [ intros H1 | apply Inegdsd with eps1; auto ].
cut (dsd D bi); [ intros H2 | apply Inegdsd with eps2; auto ].
cut (dsd (/ bi * ai) qi); [ intros H3 | apply Inegdsd with eps3; auto ].
apply dsdtrans with ai; auto.
apply dsdtrans with (qi * bi)%R.
replace ai with (bi * (/ bi * ai))%R.
rewrite (Rmult_comm qi bi); apply dsdmult; auto.
replace (bi * (/ bi * ai))%R with (ai * (bi * / bi))%R;
 [ rewrite (Rinv_r bi); auto; ring | ring ].
apply dsdmult; apply dsdsym; auto.
apply Rmult_integral_contrapositive; auto.
apply Rmult_integral_contrapositive; split; auto.
apply Rinv_neq_0_compat; auto.
Qed.
 
Theorem Maxwiwi1 :
 (Rabs wi * / Rabs wi1 <=
  Rmax (1 - (1 - eps3) * (1 - eps1) * / (1 + eps2))
    ((1 + eps3) * (1 + eps1) * / (1 - eps2) - 1))%R.
rewrite Hw.
rewrite (dsdAbs wi1 (qi * D)); [ idtac | apply dsdwi1qiD ].
case (Rle_or_lt (Rabs wi1 - Rabs (qi * D)) 0); intros Z1.
rewrite (fun x y => Faux.Rabsolu_left1 (x - y)); auto.
replace (- (Rabs wi1 - Rabs (qi * D)))%R with (Rabs (qi * D) - Rabs wi1)%R;
 [ idtac | ring ].
apply Rle_trans with ((1 + eps3) * (1 + eps1) * / (1 - eps2) - 1)%R;
 [ apply DivSecondCase; auto | auto with real ].
apply RmaxLess2.
rewrite (fun x y => Rabs_pos_eq (x - y)); [ idtac | apply Rlt_le; auto ].
apply Rle_trans with (1 - (1 - eps3) * (1 - eps1) * / (1 + eps2))%R;
 [ apply DivFirstCase; auto | auto with real ].
apply RmaxLess1.
Qed.
 
Theorem Rmax_simpl1 : forall p q : R, (p <= q)%R -> Rmax p q = q.
intros p q H; unfold Rmax in |- *.
case (Rle_dec p q); auto.
intros H1; apply Rle_antisym; auto with real.
Qed.
 
Theorem RmaxProp :
 forall (P : R -> Prop) (x y : R), P x -> P y -> P (Rmax x y).
intros.
unfold Rmax in |- *; case (Rle_dec x y); simpl in |- *; auto.
Qed.
 
Theorem FexpEpsilon_aux :
 ((0 <= ep)%R /\ (ep < 1)%R) /\
 (eps1 <= ep)%R /\ (eps2 <= ep)%R /\ (eps3 <= ep)%R.
rewrite Hep.
split.
split; apply RmaxProp; auto; apply RmaxProp; auto.
repeat split.
apply Rle_trans with (Rmax eps1 eps2); apply RmaxLess1.
apply Rle_trans with (Rmax eps1 eps2); [ apply RmaxLess2 | apply RmaxLess1 ].
apply RmaxLess2.
Qed.
 
Theorem FexpDivConv :
 (Rabs wi * / Rabs wi1 <= (ep + (ep + (ep + ep * ep))) * / (1 - ep))%R.
generalize FexpEpsilon_aux; intros ((H1, H2), (H3, (H4, H5))).
apply
 Rle_trans
  with
    (Rmax (1 - (1 - eps3) * (1 - eps1) * / (1 + eps2))
       ((1 + eps3) * (1 + eps1) * / (1 - eps2) - 1));
 [ apply Maxwiwi1 | idtac ].
apply RmaxProp.
cut (0 < 1 + eps2)%R; [ intros Z1 | auto with real ].
pattern 1%R at 1 in |- *; replace 1%R with ((1 + eps2) * / (1 + eps2))%R;
 [ idtac | apply Rinv_r; apply Rlt_dichotomy_converse; auto with real ].
apply Rle_trans with ((1 + eps2 - (1 - eps3) * (1 - eps1)) * / (1 + eps2))%R;
 [ right; ring; ring | idtac ].
replace ((1 - eps3) * (1 - eps1))%R with
 (1 + (- eps3 + (- eps1 + eps3 * eps1)))%R; [ idtac | ring; ring ].
replace (1 + eps2 - (1 + (- eps3 + (- eps1 + eps3 * eps1))))%R with
 (eps2 + (eps3 + (eps1 + - (eps3 * eps1))))%R; [ idtac | ring; ring ].
apply Rle_trans with ((ep + (ep + ep)) * / (1 + eps2))%R.
apply Rmult_le_compat_r.
apply Rlt_le; apply Rinv_0_lt_compat; auto.
apply Rplus_le_compat; auto.
apply Rplus_le_compat; auto.
apply Rle_trans with (ep + - (eps3 * eps1))%R;
 [ apply Rplus_le_compat; auto with real | idtac ].
pattern ep at 2 in |- *; replace ep with (ep + -0)%R;
 [ apply Rplus_le_compat; auto with real; apply Ropp_le_contravar;
    auto with real
 | ring ].
replace 0%R with (0 * 0)%R; [ auto with real | ring ].
apply Rle_trans with ((ep + (ep + ep)) * / (1 - ep))%R;
 [ apply Rmult_le_compat_l | idtac ].
replace 0%R with (0 + (0 + 0))%R;
 [ apply Rplus_le_compat; auto; apply Rplus_le_compat; auto | ring ].
apply Rle_Rinv; auto with real.
unfold Rminus in |- *; apply Rplus_le_compat_l; apply Rle_trans with 0%R;
 auto.
rewrite <- Ropp_0; apply Ropp_le_contravar; auto.
apply Rmult_le_compat_r;
 [ apply Rlt_le; apply Rinv_0_lt_compat; auto
 | apply Rplus_le_compat_l; apply Rplus_le_compat_l ]; 
 auto with real.
pattern ep at 1 in |- *; replace ep with (ep + 0 * 0)%R;
 [ auto with real | ring ].
apply Rlt_le_trans with 1%R; [ auto with real | idtac ].
pattern 1%R at 1 in |- *; replace 1%R with (1 + 0)%R;
 [ apply Rplus_le_compat_l; auto | ring ].
pattern 1%R at 4 in |- *; replace 1%R with ((1 - eps2) * / (1 - eps2))%R;
 [ idtac | apply Rinv_r; auto with real ].
apply
 Rle_trans with ((eps3 + (eps1 + (eps2 + eps3 * eps1))) * / (1 - eps2))%R;
 [ right; ring; ring | idtac ].
apply Rle_trans with ((ep + (ep + (ep + ep * ep))) * / (1 - eps2))%R;
 [ apply Rmult_le_compat_r | apply Rmult_le_compat_l ].
apply Rlt_le; apply Rinv_0_lt_compat; auto with real.
repeat apply Rplus_le_compat; auto with real.
repeat (replace 0%R with (0 + 0)%R; [ apply Rplus_le_compat; auto | ring ]).
replace 0%R with (0 * 0)%R; [ auto with real | ring ].
apply Rle_Rinv;
 [ auto with real
 | unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_contravar;
    auto with real ].
Qed.
End Div.
Section Div2.
Variable b : Fbound.
Variable radix : Z.
Variable precision : nat.
 
Coercion Local FtoRradix := FtoR radix.
Hypothesis radixMoreThanOne : (1 < radix)%Z.
Hypothesis precisionGreaterThanOne : 1 < precision.
Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision.
 
Theorem FulpDiv :
 forall x y p : float,
 Fbounded b x ->
 Fbounded b y ->
 Fbounded b p ->
 Closest b radix (x * / y) p ->
 y <> 0%R :>R ->
 Fnormal radix b (Fnormalize radix b precision x) ->
 (Fulp b radix precision x * / Rabs y <= radix * Fulp b radix precision p)%R.
intros x y p H1 H2 H3 H4 H5 H6.
replace (Fulp b radix precision x) with (1 * Fulp b radix precision x)%R;
 [ idtac | ring ].
replace 1%R with
 (powerRZ radix (Zpred precision) * powerRZ radix (Zsucc (- precision)))%R.
2: rewrite <- powerRZ_add; auto with zarith real.
2: replace (Zpred precision + Zsucc (- precision))%Z with 0%Z;
    [ simpl in |- *; ring | unfold Zsucc, Zpred in |- *; ring ].
apply
 Rle_trans
  with
    (powerRZ radix (Zpred precision) * Fulp b radix precision x *
     (powerRZ radix (Zsucc (- precision)) * / Rabs y))%R;
 [ right; ring | idtac ].
apply
 Rle_trans with (Rabs x * (powerRZ radix (Zsucc (- precision)) * / Rabs y))%R.
apply Rmult_le_compat_r.
replace 0%R with (0 * 0)%R; [ apply Rmult_le_compat | ring ]; auto with real.
apply powerRZ_le; auto with real zarith.
apply Rlt_le; apply Rinv_0_lt_compat; apply Rabs_pos_lt; auto.
apply Rmult_le_reg_l with (powerRZ radix (Zsucc (- precision))).
apply powerRZ_lt; auto with zarith real.
rewrite <- Rmult_assoc.
rewrite <- powerRZ_add; auto with zarith real.
replace (Zsucc (- precision) + Zpred precision)%Z with 0%Z;
 [ simpl in |- * | unfold Zsucc, Zpred in |- *; ring ].
apply Rle_trans with (Fulp b radix precision x);
 [ right; ring | rewrite Rmult_comm ].
unfold FtoRradix in |- *; apply FulpLe2; auto.
rewrite Rmult_comm.
rewrite Rmult_assoc.
apply
 Rle_trans
  with
    (powerRZ radix (Zsucc (- precision)) *
     (Rabs p + / 2%nat * Fulp b radix precision p))%R.
apply Rmult_le_compat_l.
apply powerRZ_le; auto with zarith real.
rewrite <- Rabs_Rinv; auto; rewrite <- Rabs_mult.
apply Rplus_le_reg_l with (- Rabs p)%R.
replace (- Rabs p + Rabs (/ y * x))%R with (Rabs (/ y * x) - Rabs p)%R;
 [ idtac | ring ].
apply Rle_trans with (Rabs (/ y * x - p)); [ apply Rabs_triang_inv | idtac ].
apply Rle_trans with (/ 2%nat * Fulp b radix precision p)%R;
 [ idtac | right; ring ].
apply Rmult_le_reg_l with (INR 2); auto with arith real.
rewrite <- Rmult_assoc.
rewrite Rinv_r; auto with arith real.
apply Rle_trans with (Fulp b radix precision p); [ idtac | right; ring ].
unfold FtoRradix in |- *; apply ClosestUlp; auto.
fold FtoRradix in |- *; rewrite Rmult_comm; auto.
apply
 Rle_trans
  with
    (powerRZ radix (Zsucc (- precision)) *
     ((powerRZ radix precision - 1) * Fulp b radix precision p +
      / 2%nat * Fulp b radix precision p))%R.
apply Rmult_le_compat_l;
 [ apply powerRZ_le
 | apply Rplus_le_compat_r; unfold FtoRradix in |- *; apply FulpGe ];
 auto with zarith real.
apply
 Rle_trans
  with
    (powerRZ radix (Zsucc (- precision)) *
     (powerRZ radix precision - 1 + / 2%nat) * Fulp b radix precision p)%R;
 [ right; ring; ring | idtac ].
apply Rmult_le_compat_r.
unfold Fulp in |- *; apply powerRZ_le; auto with zarith real.
apply
 Rle_trans
  with (powerRZ radix (Zsucc (- precision)) * powerRZ radix precision)%R.
apply Rmult_le_compat_l.
apply powerRZ_le; auto with zarith real.
unfold Rminus in |- *; rewrite Rplus_assoc.
pattern (powerRZ radix precision) at 2 in |- *;
 replace (powerRZ radix precision) with (powerRZ radix precision + 0)%R;
 [ apply Rplus_le_compat_l | ring ].
apply Rplus_le_reg_l with 1%R.
apply Rle_trans with (/ 2%nat)%R; [ right; ring | idtac ].
apply Rle_trans with 1%R; [ idtac | right; ring ].
rewrite <- Rinv_1; apply Rle_Rinv; auto with arith real.
right; rewrite <- powerRZ_add; auto with zarith real.
unfold Zsucc in |- *; simpl in |- *.
replace (- precision + 1 + precision)%Z with 1%Z; [ simpl in |- * | idtac ];
 ring.
Qed.
End Div2.