(****************************************************************************
                                                                             
          IEEE754  :  DoubleRound                                                   
                                                                             
           Sylvie Boldo                                                      
                                                                             
  ****************************************************************************)
Require Export MinOrMax.
Section MOMR.
Variables b1 b2 : Fbound.
Variable radix : Z.
Variables prec1 prec2 : nat.
 
Coercion Local FtoRradix := FtoR radix.
Hypothesis radixMoreThanOne : (1 < radix)%Z.
Hypothesis prec1GreaterThanOne : 1 < prec1.
Hypothesis prec2GreaterThanOne : 1 < prec2.
Hypothesis p1GivesBound : Zpos (vNum b1) = Zpower_nat radix prec1.
Hypothesis p2GivesBound : Zpos (vNum b2) = Zpower_nat radix prec2.
 
Theorem BoundedBounded :
 forall f : float,
 prec2 <= prec1 ->
 (prec1 - prec2 <= dExp b1 - dExp b2)%Z
  -> Fbounded b2 f -> Fbounded b1 f.
intros f H1 H2 H3.
repeat (split; auto with zarith).
apply Zlt_le_trans with (Zpos (vNum b2)); auto with zarith float.
rewrite p2GivesBound; rewrite p1GivesBound; auto with zarith arith.
apply Zle_trans with (- dExp b2)%Z; auto with zarith float.
Qed.
 
Theorem DblRndStable :
 forall (z : R) (p q : float),
 prec2 <= prec1 ->
 (prec1 - prec2 <= dExp b1 - dExp b2)%Z ->
 Fbounded b1 p ->
 Fbounded b2 q ->
 MinOrMax radix b1 z p -> MinOrMax radix b2 p q -> MinOrMax radix b2 z q.
intros z p q H H' Fp Fq H1 H2.
case (Rle_or_lt q z); intros H3.
left; red in |- *; split; auto; split; auto with real float.
intros f Ff H4.
case H2; intros H7; elim H7; intros H5 H6; elim H6; clear H2 H5 H6;
 intros H5 H6; case H1; intros H10; elim H10; intros H8 H9; 
 elim H9; clear H9 H8 H1; intros H8 H9.
apply H6; auto; apply H9; auto; apply BoundedBounded; auto.
apply H6; auto; apply Rle_trans with z; auto with real.
apply Rle_trans with (FtoRradix p); auto with real; apply H9; auto;
 apply BoundedBounded; auto.
apply Rle_trans with z; auto with real; apply Rle_trans with (FtoRradix p);
 auto with real.
right; red in |- *; split; auto; split; auto with real float.
intros f Ff H4.
case H2; intros H7; elim H7; intros H5 H6; elim H6; clear H2 H5 H6;
 intros H5 H6; case H1; intros H10; elim H10; intros H8 H9; 
 elim H9; clear H9 H8 H1; intros H8 H9.
apply Rle_trans with z; auto with real; apply Rle_trans with (FtoRradix p);
 auto with real.
apply Rle_trans with (FtoRradix p); auto with real; apply H9; auto;
 apply BoundedBounded; auto.
apply H6; auto; apply Rle_trans with z; auto with real.
apply H6; auto; apply H9; auto; apply BoundedBounded; auto.
Qed.
 
Theorem DoubleRound2 :
 forall (z : R) (p q : float),
 prec2 <= prec1 ->
 (prec1 - prec2 = dExp b1 - dExp b2)%Z ->
 Fbounded b1 p ->
 Fbounded b2 q ->
 MinOrMax radix b1 z p ->
 Closest b2 radix p q ->
 (Rabs (z - q) <
  Fulp b2 radix prec2 q * (/ 2%nat + powerRZ radix (Zsucc (prec2 - prec1))))%R.
intros z p q Hp He Fp Fq H1 H2.
replace (z - FtoRradix q)%R with (z - p + (p - q))%R; [ idtac | ring ].
apply Rle_lt_trans with (Rabs (z - p) + Rabs (p - q))%R;
 [ apply Rabs_triang | idtac ].
apply
 Rle_lt_trans
  with (Rabs (z - FtoRradix p) + / 2%nat * Fulp b2 radix prec2 q)%R;
 [ apply Rplus_le_compat_l | idtac ].
apply Rmult_le_reg_l with (INR 2); auto with real arith.
rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real arith.
ring_simplify (1 * Fulp b2 radix prec2 q)%R; unfold FtoRradix in |- *;
 apply ClosestUlp; auto.
ring_simplify
    (Fulp b2 radix prec2 q *
     (/ 2%nat + powerRZ radix (Zsucc (prec2 - prec1))))%R.
rewrite Rplus_comm; rewrite Rmult_comm;apply Rplus_lt_compat_l.
apply Rlt_le_trans with (Fulp b1 radix prec1 p).
unfold FtoRradix in |- *; apply MinOrMax_Rlt; auto with zarith.
cut (Fcanonic radix b1 (Fnormalize radix b1 prec1 p));
 [ intros H3 | apply FnormalizeCanonic; auto with arith ].
case H3; intros H4.
apply
 Rle_trans with (Rabs (FtoR radix p) * powerRZ radix (Zsucc (- prec1)))%R.
apply FulpLe2; auto.
replace (Zsucc (prec2 - prec1)) with (Zsucc (- prec1) + prec2)%Z;
 [ rewrite powerRZ_add; auto with zarith real | unfold Zsucc in |- *; ring ].
apply Rle_trans with ((Fulp b2 radix prec2 q *powerRZ radix prec2)*
   powerRZ radix (Zsucc (- prec1)))%R;[idtac|right; ring].
apply Rmult_le_compat_r; auto with real zarith.
fold FtoRradix in |- *;
 replace (FtoRradix p) with (FtoRradix q + (FtoRradix p - FtoRradix q))%R;
 [ idtac | ring ].
apply
 Rle_trans with (Rabs (FtoRradix q) + Rabs (FtoRradix p - FtoRradix q))%R;
 [ apply Rabs_triang | idtac ].
apply
 Rle_trans
  with
    ((powerRZ radix prec2 - 1) * Fulp b2 radix prec2 q +
     Fulp b2 radix prec2 q)%R; [ apply Rplus_le_compat | right; ring ].
unfold FtoRradix in |- *; apply FulpGe; auto.
unfold FtoRradix in |- *; apply Rlt_le;
 apply RoundedModeUlp with (Closest b2 radix); auto.
apply ClosestRoundedModeP with prec2; auto.
elim H4; intros H5 H6; elim H6; intros H7 H8; clear H6.
unfold Fulp in |- *; rewrite H7.
apply
 Rle_trans with (powerRZ radix (prec2 - prec1) * powerRZ radix (- dExp b2))%R.
rewrite <- powerRZ_add; auto with zarith real.
apply Rle_powerRZ; auto with zarith real.
replace (prec2 - prec1)%Z with (- (prec1 - prec2))%Z;
 [ rewrite He; auto with zarith | ring ].
apply
 Rle_trans
  with
    (powerRZ radix (- (dExp b1 - dExp b2)) *
     powerRZ radix (Fexp (Fnormalize radix b2 prec2 q)))%R;
 [ apply Rmult_le_compat_l | rewrite Rmult_comm;apply Rmult_le_compat_l ]; 
 auto with zarith real.
apply Rle_powerRZ; auto with real zarith float.
Qed.
End MOMR.
