Require Export Div2.
Require Export Even.
Require Export Veltkamp.


Section Generic.
Variable b : Fbound.
Variable radix : Z.
Variable p : nat.

Let FtoRradix := FtoR radix.
Coercion FtoRradix : float >-> R.
Hypothesis radixMoreThanOne : (1 < radix)%Z.

Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne).
Hint Resolve radixMoreThanZERO: zarith.
Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix p.
Hypothesis precisionGreaterThanOne : 1 < p.

Theorem BoundedL: forall (r:R) (x:float) (e:Z),
   (e <=Fexp x)%Z -> (-dExp b <= e)%Z -> (FtoRradix x=r)%R ->
   (Rabs r < powerRZ radix (e+p))%R ->
       (exists x':float, (FtoRradix x'=r) /\ (Fbounded b x') /\ Fexp x'=e).
intros.
exists (Float (Fnum x*Zpower_nat radix (Zabs_nat (Fexp x -e)))%Z e).
split.
rewrite <- H1; unfold FtoRradix, FtoR; simpl.
rewrite mult_IZR; rewrite Zpower_nat_Z_powerRZ.
rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with real zarith.
replace (Zabs_nat (Fexp x - e) + e)%Z with (Fexp x); auto with real.
rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith.
split;[idtac|simpl; auto].
split; simpl; auto.
apply Zlt_Rlt.
rewrite pGivesBound; rewrite <- Rabs_Zabs; rewrite mult_IZR.
repeat rewrite Zpower_nat_Z_powerRZ.
rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith.
rewrite Rabs_mult; rewrite (Rabs_right ( powerRZ radix (Fexp x - e))).
2: apply Rle_ge; auto with real zarith.
apply Rmult_lt_reg_l with (powerRZ radix e); auto with real zarith.
rewrite <- powerRZ_add; auto with real zarith.
apply Rle_lt_trans with (2:=H2); rewrite <- H1.
unfold FtoRradix, FtoR; rewrite Rabs_mult.
rewrite (Rabs_right (powerRZ radix (Fexp x))).
2: apply Rle_ge; auto with real zarith.
right; apply trans_eq with (Rabs (Fnum x)*(powerRZ radix e*powerRZ radix (Fexp x-e)))%R;[ring|idtac].
rewrite <- powerRZ_add; auto with real zarith.
ring_simplify (e+(Fexp x-e))%Z; auto with real.
Qed.


Theorem ClosestZero: forall (r:R) (x:float),
  (Closest b radix r x) -> (r=0)%R -> (FtoRradix x=0)%R.
intros.
cut (0 <= FtoRradix x)%R;[intros |idtac].
cut (FtoRradix x <= 0)%R;[intros; auto with real |idtac].
unfold FtoRradix; apply RleRoundedLessR0 with b p (Closest b radix) r; auto with real.
apply ClosestRoundedModeP with p; auto.
unfold FtoRradix; apply RleRoundedR0 with b p (Closest b radix) r; auto with real.
apply ClosestRoundedModeP with p; auto.
Qed.




Theorem Closestbbext: forall bext:Fbound, forall fext f:float,
    (vNum bext=vNum b) -> (dExp b < dExp bext)%Z ->
    (-dExp b <= Fexp fext)%Z -> 
    (Closest b radix fext f) -> (Closest bext radix fext f).
intros bext fext f K1 K2; intros.
elim H0; intros.
split.
elim H1; intros; split; auto with zarith.
rewrite K1; auto.
intros g Hg.
case (Zle_or_lt (-(dExp b)) (Fexp g)); intros.
apply H2.
elim Hg; split; auto with zarith.
rewrite <- K1; auto.
case (Zle_lt_or_eq (-(dExp b)) (Fexp (Fnormalize radix b p f))).
cut (Fbounded b (Fnormalize radix b p f));[intros T; elim T; auto|idtac].
apply FnormalizeBounded; auto with zarith.
intros; apply Rle_trans with ((Fulp b radix p f)/2)%R.
apply Rmult_le_reg_l with (INR 2); auto with zarith real.
apply Rle_trans with (Fulp b radix p f);[idtac|simpl; right; field; auto with real].
rewrite <- Rabs_Ropp.
replace (- (FtoR radix f - fext))%R with (fext - FtoR radix f)%R;[idtac|ring].
apply ClosestUlp; auto with zarith.
rewrite <- Rabs_Ropp.
replace (- (FtoR radix g - fext))%R with (fext - FtoR radix g)%R;[idtac|ring].
apply Rle_trans with (Rabs fext -Rabs (FtoR radix g))%R;[idtac|apply Rabs_triang_inv].
apply Rle_trans with ((powerRZ radix (p-1+Fexp (Fnormalize radix b p f))
      - powerRZ radix (-1+ Fexp (Fnormalize radix b p f)))
      - powerRZ radix (p-1-dExp b))%R; [idtac|unfold Rminus; apply Rplus_le_compat].
apply Rplus_le_reg_l with  (powerRZ radix (-1 + Fexp (Fnormalize radix b p f))).
ring_simplify ( powerRZ radix (-1 + Fexp (Fnormalize radix b p f)) +
    (powerRZ radix (p - 1 + Fexp (Fnormalize radix b p f)) -
     powerRZ radix (-1 + Fexp (Fnormalize radix b p f)) -
     powerRZ radix (p - 1 - dExp b)))%R.
apply Rle_trans with (powerRZ radix (Fexp (Fnormalize radix b p f))).
unfold Fulp, Rdiv; apply Rle_trans with 
  ((/2+/radix)* powerRZ radix (Fexp (Fnormalize radix b p f)))%R.
rewrite powerRZ_add; auto with real zarith; simpl; right; field.
repeat apply prod_neq_R0; auto with real zarith.
apply Rle_trans with (1 * powerRZ radix (Fexp (Fnormalize radix b p f)))%R;
  [apply Rmult_le_compat_r; auto with real zarith|right; ring].
apply Rmult_le_reg_l with (2*radix)%R; 
  [apply Rmult_lt_0_compat; auto with real zarith|idtac].
apply Rle_trans with (2+radix)%R;
  [right; field; auto with real zarith| ring_simplify (2*radix*1)%R].
apply Rle_trans with (radix+radix)%R;[idtac|right; ring].
replace 2%R with (IZR 2); auto with real zarith.
apply Rle_trans with  (powerRZ radix (p-2+Fexp (Fnormalize radix b p f)));
  [apply Rle_powerRZ; auto with real zarith|idtac].
apply Rle_trans with (1*(powerRZ radix (p - 2 + Fexp (Fnormalize radix b p f))))%R;
   auto with real.
apply Rle_trans with ((radix -1)*(powerRZ radix (p - 2 +  Fexp 
  (Fnormalize radix b p f))))%R;[apply Rmult_le_compat_r; auto with real zarith|idtac].
apply Rplus_le_reg_l with 1%R.
ring_simplify (1+(radix-1))%R; apply Rle_trans with (IZR 2); auto with real zarith.
apply Rle_trans with ( - powerRZ radix (p - 2+ Fexp (Fnormalize radix b p f)) +
    powerRZ radix (p - 1 + Fexp (Fnormalize radix b p f)))%R.
right; unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith.
simpl; field.
ring_simplify (radix*1)%R; repeat apply prod_neq_R0; auto with real zarith.
unfold Rminus; rewrite Rplus_comm; apply Rplus_le_compat_l; apply Ropp_le_contravar; 
   apply Rle_powerRZ; auto with real zarith.
cut (powerRZ radix (p - 1 + Fexp (Fnormalize radix b p f)) +
    - powerRZ radix (-1 + Fexp (Fnormalize radix b p f))=
   (Float (pPred (vNum b)) (-1+Fexp (Fnormalize radix b p f))))%R.
intros W; rewrite W.
2: unfold FtoRradix, FtoR, pPred.
2: apply trans_eq with (Zpred (Zpos (vNum b))*powerRZ radix 
  (-1+Fexp (Fnormalize radix b p f)))%R;[idtac|simpl; auto with real].
2: unfold Zpred, Zminus; rewrite plus_IZR.
2: rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ.
2: repeat rewrite powerRZ_add; auto with real zarith; simpl; field.
2: ring_simplify (radix*1)%R; auto with real zarith.
case (Rle_or_lt  (Float (pPred (vNum b)) (-1 + Fexp (Fnormalize radix b p f)))  
    (Rabs fext)); auto with real; intros V.
absurd ( Rabs f <= Float (pPred (vNum b)) (-1 + Fexp (Fnormalize radix b p f)))%R.
apply Rlt_not_le.
apply Rlt_le_trans with (powerRZ radix (p-1+Fexp (Fnormalize radix b p f))).
rewrite <- W; apply Rlt_le_trans with (powerRZ radix (p - 1 + 
   Fexp (Fnormalize radix b p f))+-0)%R; auto with real zarith.
right; ring.
unfold FtoRradix; rewrite <- FnormalizeCorrect with radix b p f; auto with zarith.
rewrite <- Fabs_correct; auto.
rewrite powerRZ_add; auto with real zarith; unfold FtoRradix, FtoR, Fabs; simpl.
apply Rmult_le_compat_r; auto with real zarith.
apply Rmult_le_reg_l with radix; auto with real zarith.
apply Rle_trans with (powerRZ radix p).
unfold Zminus; rewrite powerRZ_add; auto with real zarith; 
  simpl; right; field ; auto with real.
ring_simplify (radix*1)%R; auto with real zarith.
cut (Fnormal radix b (Fnormalize radix b p f));[intros Nf|idtac].
rewrite <- Zpower_nat_Z_powerRZ; rewrite <- pGivesBound; rewrite <- mult_IZR; 
  elim Nf; intros.
rewrite Zabs_Zmult in H6; rewrite Zabs_eq in H6; auto with zarith real.
cut (Fcanonic radix b (Fnormalize radix b p f));[intros X|apply FnormalizeCanonic; auto with zarith].
case X; auto; intros X'.
elim X'; intros H5 H6; elim H6; intros.
absurd (-dExp b < dExp b)%Z; auto with zarith.
unfold FtoRradix; apply RoundAbsMonotoner with b p (Closest b radix) fext; 
  auto with real zarith.
apply ClosestRoundedModeP with p; auto with zarith.
split.
apply Zle_lt_trans with (pPred (vNum b)); auto with zarith.
simpl; rewrite Zabs_eq; auto with zarith.
apply Zlt_le_weak; apply pPredMoreThanOne with radix p; auto with zarith.
unfold pPred; auto with zarith.
apply Zle_trans with (Zpred (Fexp (Fnormalize radix b p f))); auto with zarith.
unfold Zpred; apply Zle_trans with (-1+Fexp (Fnormalize radix b p f))%Z;auto with zarith.
apply Ropp_le_contravar; rewrite <- Fabs_correct; auto.
unfold FtoR, Fabs; simpl.
apply Rle_trans with ((powerRZ radix p)*(powerRZ radix (-1-dExp b)))%R.
apply Rmult_le_compat; auto with real zarith.
elim Hg; intros; rewrite <- Zpower_nat_Z_powerRZ; 
   rewrite <- pGivesBound;rewrite <- K1; auto with real zarith.
apply Rle_powerRZ; auto with real zarith.
unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith; right; ring.
intros H4.
apply Rle_trans with 0%R; auto with real; right.
rewrite <- FnormalizeCorrect with radix b p f; auto with zarith.
unfold FtoRradix; rewrite <- Fminus_correct; auto.
rewrite <- Fabs_correct; auto.
unfold FtoR.
replace (Fnum (Fabs (Fminus radix (Fnormalize radix b p f) fext))) with 0%Z;
   [simpl; ring|idtac].
apply sym_eq; apply trans_eq with (Zabs (Fnum  (Fminus radix 
   (Fnormalize radix b p f) fext)));[simpl; auto with zarith|idtac].
cut  ( 0 <= Zabs (Fnum (Fminus radix (Fnormalize radix b p f) fext)))%Z;
  auto with real zarith.
cut  (Zabs (Fnum (Fminus radix (Fnormalize radix b p f) fext)) < 1)%Z;
  auto with real zarith.
apply Zlt_Rlt.
apply Rmult_lt_reg_l with (powerRZ radix (-(dExp b))); auto with real zarith.
apply Rle_lt_trans with (Rabs (f-fext))%R.
unfold FtoRradix; rewrite <- FnormalizeCorrect with radix b p f; auto with zarith.
rewrite <- Fminus_correct; auto; rewrite <- Fabs_correct; auto.
unfold FtoR; simpl.
replace (Zmin (Fexp (Fnormalize radix b p f)) (Fexp fext)) with (-(dExp b))%Z;
  [right; ring|idtac].
rewrite Zmin_le1; auto with zarith.
apply Rlt_le_trans with (Fulp b radix p f);
   [idtac|unfold Fulp; simpl; rewrite H4; auto with real zarith].
rewrite <- Rabs_Ropp.
replace (- (f - fext))%R with (fext -f)%R;[idtac|ring].
unfold FtoRradix; apply RoundedModeUlp with (Closest b radix); auto with zarith real.
apply ClosestRoundedModeP with p; auto with zarith.
Qed.






Variable b' : Fbound.


Definition Underf_Err (a a' : float) (ra n:R) := 
   (Closest b radix ra a) /\ (Fbounded b' a') /\
   (Rabs (a-a') <= n*powerRZ radix (-(dExp b)))%R /\
   ( ((-dExp b) <= Fexp a')%Z -> (FtoRradix a =a')%R).




Theorem Underf_Err1: forall (a' a:float),
    vNum b=vNum b' -> (dExp b <= dExp b')%Z ->
   (Fbounded b' a') -> (Closest b radix a' a) ->
   (Underf_Err a a' (FtoRradix a') (/2)%R).
intros.
unfold Underf_Err.
split; auto.
split; auto.
case (Zle_or_lt (- dExp b)%Z (Fexp a')); intros.
cut (FtoRradix a'=a);[intros H4|idtac].
rewrite H4; split; auto with real.
ring_simplify (a-a)%R; rewrite Rabs_R0; apply Rlt_le; apply Rmult_lt_0_compat; auto with real zarith.
unfold FtoRradix; apply RoundedModeProjectorIdemEq with b p (Closest b radix); auto.
apply ClosestRoundedModeP with p; auto with zarith.
elim H1; intros; split; auto.
rewrite H; auto.
split.
apply Rmult_le_reg_l with (INR 2); auto with real zarith.
apply Rle_trans with (powerRZ radix (- dExp b));[idtac|simpl; right; field; auto with real].
replace (a-a')%R with (-(a'-a))%R;[rewrite Rabs_Ropp|ring].
apply Rle_trans with (Fulp b radix p a).
unfold FtoRradix; apply ClosestUlp; auto with zarith.
unfold Fulp; apply Rle_powerRZ; auto with real zarith.
apply Zle_trans with (Fexp (firstNormalPos radix b p));[idtac|unfold firstNormalPos; simpl; auto with zarith].
apply Fcanonic_Rle_Zle with radix b p; auto with zarith.
apply FnormalizeCanonic; auto with zarith; elim H2; auto.
left; apply firstNormalPosNormal; auto with zarith.
rewrite (Rabs_right ((FtoR radix (firstNormalPos radix b p)))).
rewrite FnormalizeCorrect; auto with zarith.
apply RoundAbsMonotoner with b p (Closest b radix) (FtoRradix a'); auto.
apply ClosestRoundedModeP with p; auto with zarith.
assert (Fnormal radix b (firstNormalPos radix b p));
 [apply firstNormalPosNormal; auto with zarith| elim H4; auto].
unfold FtoRradix; rewrite <- Fabs_correct; auto.
unfold firstNormalPos, Fabs, FtoR; simpl.
apply Rle_trans with (powerRZ radix p * powerRZ radix (Fexp a'))%R.
apply Rmult_le_compat_r; auto with real zarith.
elim H1; intros; apply Rle_trans with (IZR (Zpos (vNum b'))); auto with real zarith.
rewrite <- H; rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; auto with real zarith.
unfold nNormMin; rewrite Zpower_nat_Z_powerRZ.
repeat rewrite <- powerRZ_add; auto with real zarith.
apply Rle_powerRZ; auto with real zarith.
rewrite inj_pred; auto with zarith; unfold Zpred; auto with zarith.
apply Rle_ge; apply LeFnumZERO; auto.
unfold firstNormalPos, nNormMin; simpl; auto with zarith.
intros ; absurd (Fexp a' < - dExp b)%Z; auto with zarith.
Qed.





Theorem Underf_Err2_aux: forall (r:R) (x1:float),
    vNum b=vNum b' -> (dExp b <= dExp b')%Z ->
    (Fcanonic radix b x1) ->
    (Closest b radix r x1) -> 
    (exists x2:float, (Underf_Err x1 x2 r (3/4)%R) /\ (Closest b' radix r x2)).
intros.
assert (ZH: (0 < 3/4)%R).
apply Rmult_lt_reg_l with 4%R; auto with real.
apply Rmult_lt_0_compat; auto with real.
ring_simplify (4*0)%R; apply Rlt_le_trans with 3%R; auto with real.
apply Rlt_trans with 2%R; auto with real.
right; field; auto with real.
case (Zle_lt_or_eq (-(dExp b))%Z (Fexp x1)).
elim H2; intros I1 I2; elim I1; auto.
intros I.
exists x1; split.
split; auto.
assert (Fbounded b x1);[elim H2; auto|idtac].
split.
split; auto with zarith.
elim H3; intros; rewrite <- H; auto.
split;[idtac|intros; auto with real].
ring_simplify (x1-x1)%R; rewrite Rabs_R0.
apply Rlt_le; apply Rmult_lt_0_compat; auto with real zarith.
split;[elim H2; intros T T'; elim T; intros; split; try rewrite <- H; auto with zarith|idtac].
intros f H3.
case (Zle_or_lt (-(dExp b)) (Fexp f)); intros.
elim H2; intros T1 T2; apply T2.
elim H3; intros; split; try rewrite H; auto with zarith.
fold FtoRradix; replace (f-r)%R with (-((x1-f)-(x1-r)))%R;[rewrite Rabs_Ropp|ring].
apply Rle_trans with (Rabs (x1 - f) - Rabs (x1 - r))%R;[idtac|apply Rabs_triang_inv].
apply Rplus_le_reg_l with (Rabs (x1-r)).
apply Rle_trans with ((INR 2)*(Rabs (x1-r)))%R;[right; simpl; ring|idtac].
apply Rle_trans with (Rabs (x1 - f));[idtac|right; ring].
apply Rle_trans with (Fulp b radix p x1).
replace (x1-r)%R with (-(r-x1))%R;[rewrite Rabs_Ropp|ring].
unfold FtoRradix; apply ClosestUlp; auto with zarith.
rewrite CanonicFulp; auto with zarith.
apply Rle_trans with (powerRZ radix (Fexp x1));[right; unfold FtoR; simpl; ring|idtac].
apply Rle_trans with ((Rabs x1)-Rabs f)%R;[idtac|apply Rabs_triang_inv].
apply Rplus_le_reg_l with (Rabs f).
apply Rle_trans with (Rabs x1);[idtac|right;ring].
apply Rle_trans with (powerRZ radix (p-2+Fexp x1)+powerRZ radix (p-2+Fexp x1))%R.
apply Rplus_le_compat.
apply Rle_trans with (FtoRradix (Float (Zpos (vNum b')) (Fexp f))).
apply Rlt_le; unfold FtoRradix; apply MaxFloat; auto.
unfold FtoRradix, FtoR; rewrite <- H; rewrite pGivesBound;simpl.
rewrite Zpower_nat_Z_powerRZ; rewrite <- powerRZ_add; auto with real zarith.
apply Rle_powerRZ; auto with zarith real.
apply Rle_powerRZ; auto with zarith real.
apply Rle_trans with (2*powerRZ radix (p - 2 + Fexp x1))%R;[right; ring|idtac].
apply Rle_trans with (radix*powerRZ radix (p - 2 + Fexp x1))%R;
  [apply Rmult_le_compat_r; auto with real zarith|idtac].
apply Rle_trans with (IZR 2); auto with real zarith.
unfold FtoRradix; rewrite <- Fabs_correct; auto; unfold FtoR, Fabs; simpl.
rewrite powerRZ_add; auto with real zarith.
rewrite <- Rmult_assoc; apply Rmult_le_compat_r; auto with real zarith.
case H1; intros T.
elim T; intros H5 H6.
apply Rmult_le_reg_l with (IZR radix); auto with real zarith.
apply Rle_trans with  (IZR (Zpos (vNum b))).
right; rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ.
unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl.
ring_simplify (radix*1)%R; field; auto with real zarith.
apply Rle_trans with (IZR(Zabs (radix * Fnum x1))); auto with real zarith.
rewrite Zabs_Zmult; rewrite Zabs_eq; auto with zarith real.
right; rewrite mult_IZR; ring.
elim T; intros T1 T2; elim T2; intros T3 T4.  
absurd  (- dExp b < Fexp x1)%Z; auto with zarith.
intros I.
generalize ClosestTotal; unfold TotalP.
intros T; elim T with b' radix p r; auto.
2: rewrite <- H; auto.
intros x2 H3'; clear T.
case (Zle_or_lt (-(dExp b)) (Fexp x2)); intros.
exists x1; split.
split; auto.
assert (Fbounded b x1);[elim H2; auto|idtac].
split.
elim H4; intros; split; auto with zarith.
rewrite <- H; auto.
split;[idtac|intros; auto with real].
ring_simplify (x1-x1)%R; rewrite Rabs_R0; apply Rlt_le.
apply Rmult_lt_0_compat; auto with real zarith.
split.
elim H2; intros T1 T2; elim T1; intros; split; try rewrite <- H; auto with zarith.
intros f H4.
apply Rle_trans with (Rabs (FtoR radix x2 - r)).
elim H2; intros T1 T2; apply T2.
elim H3'; intros T1' T2'; elim T1'; intros; split; try rewrite H; auto with zarith.
elim H3'; intros T1 T2; apply T2; auto.
exists x2; split; auto.
split; auto.
split;[elim H3'; auto|idtac].
split.
replace (x1-x2)%R with ((-(r-x1))+(r-x2))%R;[idtac|ring].
apply Rle_trans with (1:=Rabs_triang (-(r-x1))%R (r-x2)%R).
rewrite Rabs_Ropp; apply Rmult_le_reg_l with (INR 2); auto with real zarith.
apply Rle_trans with (S 1 * (Rabs (r - x1)) + S 1 *Rabs (r - x2))%R;[right; ring|idtac].
apply Rle_trans with ( powerRZ radix (- dExp b)+ (/2)*powerRZ radix (- dExp b))%R;[idtac|simpl; right; field].
apply Rplus_le_compat.
apply Rle_trans with (Fulp b radix p x1).
unfold FtoRradix; apply ClosestUlp; auto.
rewrite CanonicFulp; auto.
rewrite <- I; unfold FtoR; simpl; right; ring.
apply Rle_trans with (Fulp b' radix p x2).
unfold FtoRradix; apply ClosestUlp; auto.
rewrite <- H; auto.
apply Rle_trans with (powerRZ radix (Fexp x2)).
unfold Fulp; apply Rle_powerRZ; auto with zarith real.
apply FcanonicLeastExp with radix b' p; auto with zarith.
rewrite <- H; auto.
rewrite FnormalizeCorrect; auto with zarith real.
elim H3'; auto.
apply FnormalizeCanonic; auto with zarith.
rewrite <- H; auto.
elim H3'; auto.
apply Rmult_le_reg_l with 2%R; auto with real.
apply Rle_trans with  (powerRZ radix (- dExp b));[idtac|right; field; auto with real].
apply Rle_trans with  (radix * powerRZ radix (Fexp x2))%R;[apply Rmult_le_compat_r; auto with real zarith|idtac].
apply Rle_trans with (IZR 2); auto with real zarith.
apply Rle_trans with (powerRZ radix (Fexp x2+1)).
rewrite powerRZ_add; auto with real zarith; simpl; right; ring.
apply Rle_powerRZ; auto with real zarith.
intros H5; absurd ((Fexp x2 < - dExp b)%Z); auto with zarith.
Qed.


Theorem Underf_Err2: forall (r:R) (x1:float),
    vNum b=vNum b' -> (dExp b <= dExp b')%Z ->
    (Closest b radix r x1) -> 
    (exists x2:float, (Underf_Err x1 x2 r (3/4)%R) /\ (Closest b' radix r x2)).
intros.
elim Underf_Err2_aux with r (Fnormalize radix b p x1); auto with zarith.
unfold Underf_Err; intros x2 tmp; elim tmp; intros T Z; elim T; intros V1 T'; elim T'; 
   intros V2 T''; elim T''; intros V3 V4; clear T T' T'' tmp.
exists x2; split; auto.
split; auto.
split; auto.
split; auto.
replace (x1-x2)%R with (Fnormalize radix b p x1 - x2)%R; auto with real.
unfold FtoRradix; rewrite FnormalizeCorrect; auto.
intros; apply trans_eq with (FtoRradix (Fnormalize radix b p x1)).
unfold FtoRradix; rewrite FnormalizeCorrect; auto.
apply V4; auto.
apply FnormalizeCanonic; auto with zarith; elim H1; auto.
apply ClosestCompatible with (1:=H1); auto.
rewrite <- FnormalizeCorrect with radix b p x1; auto.
apply FnormalizeBounded; auto with zarith; elim H1; auto.
Qed.



Theorem Underf_Err3: forall (x x' y y' z' z:float) (rx ry epsx epsy:R),
    vNum b=vNum b' -> (dExp b <= dExp b')%Z ->
   (Underf_Err x x' rx epsx) -> (Underf_Err y y' ry epsy) ->
   (epsx+epsy <= (powerRZ radix (p-1) -1))%R ->
   (Fbounded b' z') -> (FtoRradix z'=x'-y')%R -> 
   (Fexp z' <= Fexp x')%Z -> (Fexp z' <= Fexp y')%Z -> 
   (Closest b radix (x-y) z) ->
   (Underf_Err z z' (x-y) (epsx+epsy)%R).
intros.
unfold Underf_Err.
split; auto.
split; auto.
unfold Underf_Err in H1; unfold Underf_Err in H2.
case (Zle_or_lt (- dExp b)%Z (Fexp z')); intros.
elim H1; intros V1 T; elim T; intros V2 T'; elim T'; intros V3 V4; clear T T' H1.
elim H2; intros W1 T; elim T; intros W2 T'; elim T'; intros W3 W4; clear T T' H2.
cut (FtoRradix z=z')%R;[intros H9'; rewrite H9'; split; auto|idtac].
ring_simplify (z'-z')%R; rewrite Rabs_R0.
apply Rle_trans with (0* powerRZ radix (- dExp b))%R;[right; ring|apply Rmult_le_compat_r; auto with real zarith].
apply Rle_trans with (0+0)%R; [right; ring|apply Rplus_le_compat; auto with real].
apply Rmult_le_reg_l with (powerRZ radix (- dExp b))%R; auto with real zarith;
    ring_simplify (powerRZ radix (- dExp b) * 0)%R; rewrite Rmult_comm.
apply Rle_trans with (2:=V3); auto with real.
apply Rmult_le_reg_l with (powerRZ radix (- dExp b))%R; auto with real zarith;
    ring_simplify (powerRZ radix (- dExp b) * 0)%R; rewrite Rmult_comm.
apply Rle_trans with (2:=W3); auto with real.
unfold FtoRradix; apply sym_eq.
apply RoundedModeProjectorIdemEq with b p (Closest b radix); auto with zarith.
apply ClosestRoundedModeP with p; auto with zarith.
elim H4; intros; split; auto with zarith.
rewrite H; auto.
fold FtoRradix; rewrite H5.
rewrite <- V4; auto with zarith.
rewrite <- W4; auto with zarith real.
elim H1; intros V1 T; elim T; intros V2 T'; elim T'; intros V3 V4; clear T T' H1.
elim H2; intros W1 T; elim T; intros W2 T'; elim T'; intros W3 W4; clear T T' H2.
split;[idtac|intros; absurd (- dExp b <= Fexp z')%Z; auto with zarith].
replace (z-z')%R with (-((x-y)-z)+((x-x')+-(y-y')))%R;[idtac|rewrite H5; ring].
apply Rle_trans with (1:=Rabs_triang (- (x - y - z))%R ((x - x') + - (y - y'))%R).
apply Rle_trans with ((Rabs (- (x - y - z))) + (Rabs (x - x') +(Rabs (- (y - y')))))%R;
   [apply Rplus_le_compat_l; apply Rabs_triang|idtac].
rewrite Rabs_Ropp; rewrite Rabs_Ropp.
apply Rle_trans with (0 + ( epsx * powerRZ radix (- dExp b)
       + epsy * powerRZ radix (- dExp b)))%R;[idtac|right; ring].
apply Rplus_le_compat;[idtac|apply Rplus_le_compat; auto with real].
cut (FtoRradix (Fnormalize radix b p z)=x-y)%R.
unfold FtoRradix; rewrite FnormalizeCorrect; auto.
fold FtoRradix; intros T; rewrite T; ring_simplify (x - y - (x - y))%R; rewrite Rabs_R0; auto with real.
unfold FtoRradix, Rminus; rewrite <- Fopp_correct; auto.
apply plusExact1 with b p; auto.
elim V1; auto.
apply oppBounded; elim W1; auto.
rewrite Fopp_correct; auto with real.
apply ClosestCompatible with (1:=H8); auto.
rewrite FnormalizeCorrect; auto with real.
apply FnormalizeBounded; auto with zarith; elim H8; auto.
apply Zle_trans with (-(dExp b))%Z.
2: apply Zmin_Zle.
2: elim V1; intros T1 T2; elim T1; auto.
2: elim W1; intros T1 T2; elim T1; auto.
apply Zle_trans with (Fexp (Float (pPred (vNum b)) (-(dExp b))%Z));
   [idtac| simpl; auto with zarith].
apply Fcanonic_Rle_Zle with radix b p; auto with zarith.
apply FnormalizeCanonic; auto with zarith; elim H8; auto. 
apply FcanonicPpred with p; auto with zarith.
rewrite (Rabs_right ((FtoR radix  (Float (pPred (vNum b)) (- dExp b))))).
rewrite FnormalizeCorrect; auto with zarith.
apply RoundAbsMonotoner with b p (Closest b radix) (x-y)%R; auto.
apply ClosestRoundedModeP with p; auto with zarith.
assert (Fcanonic radix b (Float (pPred (vNum b)) (- dExp b)));
 [apply FcanonicPpred with p; auto with zarith | apply FcanonicBound with radix; auto].
replace (x-y)%R with ((x-x')+-(y-y')+z')%R;[idtac|rewrite H5; ring].
apply Rle_trans with (1:=Rabs_triang  (x - x' + - (y - y'))%R z').
apply Rle_trans with ((powerRZ radix (p - 1) - 1)*powerRZ radix (-(dExp b)) + 
       (powerRZ radix p - 1)*powerRZ radix (-(dExp b)-1))%R;[apply Rplus_le_compat|idtac].
apply Rle_trans with (1:=Rabs_triang (x-x')%R (-(y-y'))%R); rewrite Rabs_Ropp.
apply Rle_trans with (epsx * powerRZ radix (- dExp b)+ epsy * powerRZ radix (- dExp b))%R; auto with real.
apply Rle_trans with ((epsx+epsy) * powerRZ radix (- dExp b))%R;[right; ring|idtac].
apply Rmult_le_compat_r; auto with real zarith.
unfold FtoRradix; rewrite <- Fabs_correct; auto.
unfold Fabs, FtoR; simpl.
apply Rmult_le_compat; auto with real zarith.
elim H4; intros.
apply Rle_trans with (IZR (Zpred (Zpos (vNum b')))); auto with real zarith.
unfold Zpred, Zminus; rewrite plus_IZR.
rewrite <- H; rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; auto with real zarith.
apply Rle_powerRZ; auto with real zarith.
apply Rle_trans with  ((powerRZ radix p - 1) * powerRZ radix (- dExp b))%R.
apply Rle_trans with (- powerRZ radix (- dExp b)+powerRZ radix p  
   * powerRZ radix (- dExp b))%R;[idtac|right; ring].
apply Rle_trans with  (- powerRZ radix (- dExp b)+ ((powerRZ radix (p - 1)* powerRZ radix (- dExp b)+
  (powerRZ radix p*powerRZ radix (- dExp b - 1) -  powerRZ radix (- dExp b - 1)))))%R;
   [right; ring|apply Rplus_le_compat_l].
repeat rewrite <- powerRZ_add; auto with real zarith.
replace ((p + (- dExp b - 1)))%Z with (p - 1 + - dExp b)%Z;[idtac|ring].
apply Rle_trans with (powerRZ radix (p - 1 + - dExp b) +
    (powerRZ radix (p - 1 + - dExp b) - 0))%R; auto with real zarith.
apply Rplus_le_compat_l; unfold Rminus; apply Rplus_le_compat_l; auto with real zarith.
apply Rle_trans with (2*(powerRZ radix (p - 1 + - dExp b)))%R;[right; ring|idtac].
apply Rle_trans with (radix*(powerRZ radix (p - 1 + - dExp b)))%R;
 [apply Rmult_le_compat_r; auto with real zarith|idtac].
apply Rle_trans with (IZR 2); auto with real zarith.
unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith; simpl; right; field; auto with real zarith.
unfold FtoR; simpl.
unfold pPred, Zpred, Zminus; rewrite plus_IZR.
rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; simpl; auto with real zarith.
apply Rle_ge; apply LeFnumZERO; auto.
simpl; apply Zlt_le_weak.
apply pPredMoreThanOne with radix p; auto with zarith float.
Qed.


Theorem Underf_Err3_bis: forall (x x' y y' z' z:float) (rx ry epsx epsy:R),
   (4 <= p) ->
    vNum b=vNum b' -> (dExp b <= dExp b')%Z ->
   (Underf_Err x x' rx epsx) -> (Underf_Err y y' ry epsy) ->
   (epsx+epsy <= 7)%R ->
   (Fbounded b' z') -> (FtoRradix z'=x'-y')%R -> 
   (Fexp z' <= Fexp x')%Z -> (Fexp z' <= Fexp y')%Z -> 
   (Closest b radix (x-y) z) ->
   (Underf_Err z z' (x-y) (epsx+epsy)%R).
intros.
apply Underf_Err3 with x' y' rx ry; auto.
apply Rle_trans with (1:=H4).
apply Rle_trans with (8-1)%R;[right; ring|unfold Rminus; apply Rplus_le_compat_r].
apply Rle_trans with (powerRZ radix 3)%R; auto with real zarith.
apply Rle_trans with (powerRZ 2 3)%R; auto with real zarith.
simpl; right; ring.
simpl; auto with real zarith.
assert (2 <= radix)%R;[apply Rle_trans with (IZR 2); auto with real zarith|idtac].
ring_simplify (2*1)%R; ring_simplify (radix*1)%R.
apply Rmult_le_compat; auto with real zarith.
apply Rlt_le; apply Rmult_lt_0_compat; auto with real.
apply Rle_powerRZ; auto with zarith real.
Qed.

End Generic.



Section Sec1.

Variable radix : Z.
Variable b : Fbound.
Variables s t:nat.

Let b' := Bound
    (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (minus t s)))))
    (dExp b).

Let bt := Bound
    (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix s))))
    (dExp b).

Let FtoRradix := FtoR radix.
Coercion FtoRradix : float >-> R.
Hypothesis radixMoreThanOne : (1 < radix)%Z.

Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne).
Hint Resolve radixMoreThanZERO: zarith.

Hypothesis pGivesBound: Zpos (vNum b)=(Zpower_nat radix t).

Hypothesis SLe: (2 <= s)%nat.
Hypothesis SGe: (s <= t-2)%nat.


Hypothesis Hst1: (t-1 <= s+s)%Z.
Hypothesis Hst2: (s+s <= t+1)%Z.


Variables x x1 x2 y y1 y2 r e: float.


Hypotheses Nx: Fnormal radix b x.
Hypotheses Ny: Fnormal radix b y.

Hypothesis K: (-dExp b <= Fexp x +Fexp y)%Z.


Hypotheses rDef: Closest b radix (x*y) r.

Hypotheses eeq: (x*y=r+e)%R.
Hypotheses Xeq: (FtoRradix x=x1+x2)%R.
Hypotheses Yeq: (FtoRradix y=y1+y2)%R.

Hypotheses x2Le: (Rabs x2 <= (powerRZ radix (s+Fexp x)) /2)%R.
Hypotheses y2Le: (Rabs y2 <= (powerRZ radix (s+Fexp y)) /2)%R.
Hypotheses x1Exp: (s+Fexp x <= Fexp x1)%Z.
Hypotheses y1Exp: (s+Fexp y <= Fexp y1)%Z.
Hypotheses x2Exp: (Fexp x <= Fexp x2)%Z.
Hypotheses y2Exp: (Fexp y <= Fexp y2)%Z.



Lemma x2y2Le: (Rabs (x2*y2) <= (powerRZ radix (2*s+Fexp x+Fexp y)) /4)%R.
rewrite Rabs_mult.
apply Rle_trans with ((powerRZ radix (s + Fexp x) / 2)*(powerRZ radix (s + Fexp y) / 2))%R.
apply Rmult_le_compat; auto with real.
replace (2*s)%Z with (s+s)%Z; auto with zarith.
repeat rewrite powerRZ_add; auto with real zarith.
right; field.
Qed.


Lemma x2y1Le: (Rabs (x2*y1) < (powerRZ radix (t+s+Fexp x+Fexp y)) /2 
          + (powerRZ radix (2*s+Fexp x+Fexp y)) /4)%R.
replace (x2*y1)%R with (x2*y+(-(x2*y2)))%R;[idtac|rewrite Yeq; ring].
apply Rle_lt_trans with (1:=Rabs_triang (x2*y)%R (-(x2*y2))%R).
rewrite Rabs_Ropp.
cut ((Rabs (x2 * y) <  powerRZ radix (t + s + Fexp x + Fexp y) / 2))%R;[intros I1|idtac].
generalize x2y2Le; auto with real.
rewrite Rabs_mult.
apply Rlt_le_trans with ((powerRZ radix (s + Fexp x) / 2)*powerRZ radix (t+Fexp y))%R.
cut (Rabs y <powerRZ radix (t + Fexp y))%R; auto with real zarith.
intros I; apply Rle_lt_trans with  (powerRZ radix (s + Fexp x) / 2 *Rabs y)%R; auto with real.
apply Rmult_lt_compat_l; auto with real zarith.
unfold Rdiv; apply Rmult_lt_0_compat; auto with real zarith.
unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith.
unfold FtoR, Fabs; simpl; rewrite powerRZ_add; auto with real zarith.
apply Rmult_lt_compat_r; auto with real zarith.
elim Ny; intros I1 I2; elim I1; intros.
apply Rlt_le_trans with (IZR (Zpos (vNum b))); auto with real zarith.
right; rewrite pGivesBound;rewrite Zpower_nat_Z_powerRZ; auto with real. 
repeat rewrite powerRZ_add; auto with real zarith.
unfold Rdiv; right; ring.
Qed.



Lemma x1y2Le: (Rabs (x1*y2) < (powerRZ radix (t+s+Fexp x+Fexp y)) /2 
          + (powerRZ radix (2*s+Fexp x+Fexp y)) /4)%R.
replace (x1*y2)%R with (x*y2+(-(x2*y2)))%R;[idtac|rewrite Xeq; ring].
apply Rle_lt_trans with (1:=Rabs_triang (x*y2)%R (-(x2*y2))%R).
rewrite Rabs_Ropp.
cut ((Rabs (x * y2) <  powerRZ radix (t + s + Fexp x + Fexp y) / 2))%R;[intros I1|idtac].
generalize x2y2Le; auto with real.
rewrite Rabs_mult.
apply Rlt_le_trans with (powerRZ radix (t+Fexp x)*(powerRZ radix (s + Fexp y) / 2))%R.
cut (Rabs x <powerRZ radix (t + Fexp x))%R; auto with real zarith.
intros I; apply Rle_lt_trans with  (Rabs x*(powerRZ radix (s + Fexp y) / 2))%R; auto with real.
apply Rmult_lt_compat_r; auto with real zarith.
unfold Rdiv; apply Rmult_lt_0_compat; auto with real zarith.
unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith.
unfold FtoR, Fabs; simpl; rewrite powerRZ_add; auto with real zarith.
apply Rmult_lt_compat_r; auto with real zarith.
elim Nx; intros I1 I2; elim I1; intros.
apply Rlt_le_trans with (IZR (Zpos (vNum b))); auto with real zarith.
right; rewrite pGivesBound;rewrite Zpower_nat_Z_powerRZ; auto with real. 
repeat rewrite powerRZ_add; auto with real zarith.
unfold Rdiv; right; ring.
Qed.


Lemma eLe: (Rabs e <= (powerRZ radix (t+Fexp x+Fexp y)) /2)%R.
apply Rmult_le_reg_l with (INR 2); auto with real zarith.
replace (FtoRradix e) with (x*y-r)%R;[idtac|rewrite eeq; ring].
apply Rle_trans with (Fulp b radix t r).
unfold FtoRradix; apply ClosestUlp; auto with zarith.
apply Rle_trans with (powerRZ radix (t + Fexp x + Fexp y));
  [idtac|simpl; right; field; auto with real].
unfold Fulp; apply Rle_powerRZ; auto with real zarith.
apply Zle_trans with (Fexp (Float (pPred (vNum b)) (t+Fexp x+Fexp y)));
  [idtac|simpl; auto with zarith].
apply Fcanonic_Rle_Zle with radix b t; auto with zarith.
apply FnormalizeCanonic; auto with zarith.
elim rDef; auto.
replace (Float (pPred (vNum b)) (t + Fexp x + Fexp y)) with
   (FPred b radix t (Float (nNormMin radix t) (t+1+Fexp x+Fexp y))).
apply FPredCanonic; auto with zarith.
apply FcanonicNnormMin; auto with zarith.
rewrite FPredSimpl2; auto with zarith.
simpl; unfold Zpred; auto with zarith.
replace (t+1+Fexp x +Fexp y+-1)%Z with (t+Fexp x+Fexp y)%Z; auto with zarith.
simpl; auto with zarith.
rewrite FnormalizeCorrect; auto with zarith.
rewrite (Rabs_right (FtoR radix (Float (pPred (vNum b)) (t + Fexp x + Fexp y)))%R).
2: apply Rle_ge; apply LeFnumZERO; simpl; auto with zarith.
2: generalize (pPredMoreThanOne b radix t); auto with zarith.
apply RoundAbsMonotoner with b t (Closest b radix) (x*y)%R; auto with zarith.
apply ClosestRoundedModeP with t; auto with zarith.
replace (Float (pPred (vNum b)) (t + Fexp x + Fexp y)) with
   (FPred b radix t (Float (nNormMin radix t) (t+1+Fexp x+Fexp y))).
apply FBoundedPred; auto with zarith.
elim FnormalNnormMin with radix b t (t + 1 + Fexp x + Fexp y)%Z; auto with zarith.
rewrite FPredSimpl2; auto with zarith.
simpl; unfold Zpred; auto with zarith.
replace (t+1+Fexp x +Fexp y+-1)%Z with (t+Fexp x+Fexp y)%Z; auto with zarith.
simpl; auto with zarith.
rewrite Rabs_mult.
apply Rle_trans with ((FtoRradix (Float (pPred (vNum b)) (Fexp x)))*(powerRZ radix (t+Fexp y)))%R.
apply Rmult_le_compat; auto with real zarith.
unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith.
unfold FtoR, Fabs; simpl.
apply Rmult_le_compat_r; auto with real zarith.
elim Nx; intros I1 I2; elim I1; intros; unfold pPred; auto with real zarith.
unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith.
unfold FtoR, Fabs; simpl.
rewrite powerRZ_add; auto with real zarith.
apply Rmult_le_compat_r; auto with real zarith.
elim Ny; intros I1 I2; elim I1; intros; apply Rle_trans with (IZR (Zpos (vNum b))); auto with real zarith.
rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; auto with real zarith.
unfold FtoRradix, FtoR; simpl; repeat rewrite powerRZ_add; auto with real zarith; right; ring.
Qed.




Lemma rExp: (t - 1 + Fexp x + Fexp y <= Fexp r)%Z.
apply Zle_trans with (Fexp (Float (nNormMin radix t) (t-1+Fexp x+Fexp y)));
  [simpl; auto with zarith|idtac].
apply Zle_trans with (Fexp (Fnormalize radix b t r)).
apply Fcanonic_Rle_Zle with radix b t; auto with zarith.
apply FcanonicNnormMin; auto with zarith.
apply FnormalizeCanonic; auto with zarith.
elim rDef; auto.
rewrite FnormalizeCorrect; auto with zarith.
rewrite (Rabs_right (FtoR radix (Float (nNormMin radix t) (t-1 + Fexp x + Fexp y)))%R).
2: apply Rle_ge; apply LeFnumZERO; simpl; auto with zarith.
2: unfold nNormMin; auto with zarith.
apply RoundAbsMonotonel with b t (Closest b radix) (x*y)%R; auto with zarith.
apply ClosestRoundedModeP with t; auto with zarith.
apply FcanonicBound with radix; auto with zarith.
apply FcanonicNnormMin; auto with zarith.
fold FtoRradix; replace (FtoRradix (Float (nNormMin radix t) (t-1 + Fexp x + Fexp y))) with
  ((Float (nNormMin radix t) (Fexp x))*(Float (nNormMin radix t) (Fexp y)))%R.
rewrite Rabs_mult.
apply Rmult_le_compat.
unfold FtoRradix; apply LeFnumZERO; simpl;  unfold nNormMin; auto with zarith.
unfold FtoRradix; apply LeFnumZERO; simpl;  unfold nNormMin; auto with zarith.
unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith; unfold FtoR; simpl.
apply Rmult_le_compat_r; auto with real zarith; apply Rmult_le_reg_l with (IZR radix); auto with real zarith.
rewrite <- mult_IZR; rewrite <- (PosNormMin radix b t); auto with zarith.
elim Nx; intros I1 I2; rewrite Zabs_Zmult in I2; rewrite Zabs_eq in I2; auto with real zarith.
rewrite <- mult_IZR; auto with real zarith.
unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith; unfold FtoR; simpl.
apply Rmult_le_compat_r; auto with real zarith; apply Rmult_le_reg_l with (IZR radix); auto with real zarith.
rewrite <- mult_IZR; rewrite <- (PosNormMin radix b t); auto with zarith.
elim Ny; intros I1 I2; rewrite Zabs_Zmult in I2; rewrite Zabs_eq in I2; auto with real zarith.
rewrite <- mult_IZR; auto with real zarith.
unfold FtoRradix, FtoR; simpl.
rewrite powerRZ_add; auto with real zarith.
rewrite powerRZ_add; auto with real zarith.
replace (IZR (nNormMin radix t)) with (powerRZ radix (t-1));[ring|idtac].
unfold nNormMin; rewrite Zpower_nat_Z_powerRZ.
rewrite inj_pred; auto with zarith; unfold Zpred; auto with real zarith.
apply FcanonicLeastExp with radix b t; auto with real zarith.
rewrite FnormalizeCorrect; auto with zarith real.
elim rDef; auto.
apply FnormalizeCanonic; auto with zarith; elim rDef; auto.
Qed.


Lemma powerRZSumRle:forall (e1 e2:Z),
  (e2<= e1)%Z ->
  (powerRZ radix e1 + powerRZ radix e2 <= powerRZ radix (e1+1))%R.
intros.
apply Rle_trans with  (powerRZ radix e1 + powerRZ radix e1)%R;
  [apply Rplus_le_compat_l; apply Rle_powerRZ; auto with real zarith|idtac].
apply Rle_trans with (powerRZ radix e1*2)%R;[right; ring|rewrite powerRZ_add; auto with real zarith].
apply Rmult_le_compat_l; auto with real zarith.
simpl; ring_simplify (radix*1)%R; replace 2%R with (IZR 2); auto with real zarith.
Qed.


Lemma Boundedt1: (exists x':float, (FtoRradix x'=r-x1*y1)%R /\ (Fbounded b x') 
                   /\ (Fexp x'=t-1+Fexp x+Fexp y)%Z).
unfold FtoRradix; apply BoundedL with t (Fminus radix r (Fmult x1 y1)); auto with zarith.
unfold Fminus, Fopp, Fplus, Fmult; simpl.
apply Zmin_Zle; auto with zarith.
apply rExp.
rewrite Fminus_correct; auto with zarith; rewrite Fmult_correct; auto with real zarith.
fold FtoRradix.
replace (r-x1*y1)%R with ((-e)+x1*y2+x2*y1+x2*y2)%R.
2: apply trans_eq with (-e+x*y-(x+0)*y+x1*y2+x2*y1+x2*y2)%R;[ring|idtac].
2: rewrite eeq; rewrite Xeq; rewrite Yeq; ring.
apply Rle_lt_trans with ((Rabs e)+(Rabs (x1 * y2)) + (Rabs (x2 * y1)) + (Rabs (x2 * y2)))%R.
apply Rle_trans with (1:= Rabs_triang (-e+ x1 * y2 + x2 * y1) (x2 * y2)%R).
apply Rplus_le_compat_r.
apply Rle_trans with (1:= Rabs_triang (-e+ x1 * y2) (x2 * y1)%R).
apply Rplus_le_compat_r.
apply Rle_trans with (1:= Rabs_triang (-e) (x1 * y2)%R).
rewrite Rabs_Ropp; right; ring.
generalize eLe; generalize x1y2Le; generalize x2y1Le; generalize x2y2Le; intros.
apply Rlt_le_trans with ( (powerRZ radix (t + Fexp x + Fexp y) / 2) +
    (powerRZ radix (t + s + Fexp x + Fexp y) / 2 +powerRZ radix (2 * s + Fexp x + Fexp y) / 4) +
    (powerRZ radix (t + s + Fexp x + Fexp y) / 2 +powerRZ radix (2 * s + Fexp x + Fexp y) / 4) + 
    (powerRZ radix (2 * s + Fexp x + Fexp y) / 4))%R;
  auto with real.
apply Rlt_le_trans with  (powerRZ radix (t + Fexp x + Fexp y) / 2 +
    (powerRZ radix (t + s + Fexp x + Fexp y) / 2 +
     powerRZ radix (2 * s + Fexp x + Fexp y) / 4) +
    (powerRZ radix (t + s + Fexp x + Fexp y) / 2 +
     powerRZ radix (2 * s + Fexp x + Fexp y) / 4) +  Rabs (x2 * y2))%R; auto with real.
apply Rplus_lt_compat_r.
apply Rle_lt_trans with  (powerRZ radix (t + Fexp x + Fexp y) / 2 +
    (powerRZ radix (t + s + Fexp x + Fexp y) / 2 +
     powerRZ radix (2 * s + Fexp x + Fexp y) / 4) +  Rabs (x2 * y1))%R; auto with real.
apply Rle_trans with (powerRZ radix (t + s + Fexp x + Fexp y)+
  powerRZ radix (t + Fexp x + Fexp y) / 2 +3*powerRZ radix (2 * s + Fexp x + Fexp y) / 4)%R;
  [right; field; auto with real|idtac].
assert (0 < 8)%R; auto with real.
apply Rlt_le_trans with 2%R; auto with real.
apply Rle_trans with 4%R; auto with real.
apply Rle_trans with  (powerRZ radix (t + s + Fexp x + Fexp y) +
    powerRZ radix (t + Fexp x + Fexp y) +
    powerRZ radix (2 * s + Fexp x + Fexp y))%R;
  [apply Rplus_le_compat; try apply Rplus_le_compat_l |idtac].
unfold Rdiv; apply Rle_trans with (powerRZ radix (t + Fexp x + Fexp y)*1)%R;[idtac|right; ring].
apply Rmult_le_compat_l; auto with real zarith.
apply Rle_trans with (/1)%R; auto with real.
unfold Rdiv; apply Rle_trans with (powerRZ radix (2*s + Fexp x + Fexp y)*1)%R;[idtac|right; ring].
 apply Rle_trans with (powerRZ radix (2*s + Fexp x + Fexp y)*(3*/4))%R;[right; ring|idtac].
apply Rmult_le_compat_l; auto with real zarith.
assert (0<4)%R.
apply Rlt_le_trans with 2%R; auto with real.
apply Rmult_le_reg_l with (4%R); auto with real.
apply Rle_trans with 3%R;[right; field|idtac]; auto with real.
apply Rle_trans with 4%R; auto with real.
replace 3%R with (INR 3); auto with real zarith.
replace 4%R with (INR 4); auto with real zarith.
simpl; ring.
simpl; ring.
apply Rle_trans with (powerRZ radix (t + s + Fexp x + Fexp y) +
    powerRZ radix (t +1+ Fexp x + Fexp y) +
    powerRZ radix (2 * s + Fexp x + Fexp y))%R.
apply Rplus_le_compat_r; apply Rplus_le_compat_l.
apply Rle_powerRZ; auto with real zarith.
apply Rle_trans with (powerRZ radix (t + s + Fexp x + Fexp y) +
    powerRZ radix (t+1 + Fexp x + Fexp y+1))%R.
rewrite Rplus_assoc; apply Rplus_le_compat_l.
apply powerRZSumRle; auto with zarith.
apply Rle_trans with (powerRZ radix (t + s + Fexp x + Fexp y+1)). 
apply powerRZSumRle; auto with zarith.
apply Rle_powerRZ; auto with real zarith.
Qed.


Lemma Boundedt2: (exists x':float, (FtoRradix x'=r-x1*y1-x1*y2)%R /\ (Fbounded b x') 
                   /\ (Fexp x'=s+Fexp x+Fexp y)%Z).
elim Boundedt1; intros t1 T; elim T; intros H1 T'; elim T'; intros H2 H3; clear T T'.
unfold FtoRradix; apply BoundedL with t (Fminus radix t1 (Fmult x1 y2)); auto with zarith.
unfold Fminus, Fopp, Fplus, Fmult; simpl.
apply Zmin_Zle; auto with zarith.
rewrite Fminus_correct; auto with zarith; rewrite Fmult_correct; auto with real zarith.
fold FtoRradix; rewrite H1; ring.
fold FtoRradix; replace (r-x1*y1-x1*y2)%R with ((-e)+x2*y1+x2*y2)%R.
2: apply trans_eq with (-e+x*y-(x+0)*y+x2*y1+x2*y2)%R;[ring|idtac].
2: rewrite eeq; rewrite Xeq; rewrite Yeq; ring.
apply Rle_lt_trans with ((Rabs e) + (Rabs (x2 * y1)) + (Rabs (x2 * y2)))%R.
apply Rle_trans with (1:= Rabs_triang (-e + x2 * y1) (x2 * y2)%R).
apply Rplus_le_compat_r.
apply Rle_trans with (1:= Rabs_triang (-e) (x2 * y1)%R).
rewrite Rabs_Ropp; right; ring.
generalize eLe; generalize x2y1Le; generalize x2y2Le; intros.
apply Rle_lt_trans with 
  ( (Rabs e + Rabs (x2 * y1)+ (powerRZ radix (2 * s + Fexp x + Fexp y) / 4)))%R; auto with real.
apply Rlt_le_trans with (Rabs e + (powerRZ radix (t + s + Fexp x + Fexp y) / 2 +
        powerRZ radix (2 * s + Fexp x + Fexp y) / 4)+powerRZ radix (2 * s + Fexp x + Fexp y) / 4)%R; auto with real.
apply Rle_trans with (powerRZ radix (t + Fexp x + Fexp y) / 2+ (powerRZ radix (t + s + Fexp x + Fexp y) / 2 +
     powerRZ radix (2 * s + Fexp x + Fexp y) / 4) +
    powerRZ radix (2 * s + Fexp x + Fexp y) / 4)%R; auto with real.
replace  (s + Fexp x + Fexp y + t)%Z with (t+s+Fexp x+Fexp y)%Z;[idtac|ring].
apply Rplus_le_reg_l with (-((powerRZ radix (t + s + Fexp x + Fexp y) / 2)))%R.
apply Rle_trans with (/2* (powerRZ radix (t + Fexp x + Fexp y)+ powerRZ radix (2 * s + Fexp x + Fexp y)))%R;
   [right; field; auto with real|idtac].
apply Rle_trans with (/2* powerRZ radix (t + s + Fexp x + Fexp y))%R;[idtac|right; field; auto with real].
apply Rmult_le_compat_l; auto with real.
apply Rle_trans with  (powerRZ radix (t+1 + Fexp x + Fexp y) +
    powerRZ radix (2 * s + Fexp x + Fexp y))%R; auto with real zarith.
apply Rle_trans with  (powerRZ radix (t+1 + Fexp x + Fexp y+1)).
apply powerRZSumRle; auto with real zarith.
apply Rle_powerRZ; auto with real zarith.
Qed.



Lemma Boundedt3: (exists x':float, (FtoRradix x'=r-x1*y1-x1*y2-x2*y1)%R /\ (Fbounded b x') 
                   /\ (Fexp x'=s+Fexp x+Fexp y)%Z).
elim Boundedt2; intros t2 T; elim T; intros H1 T'; elim T'; intros H2 H3; clear T T'.
unfold FtoRradix; apply BoundedL with t (Fminus radix t2 (Fmult x2 y1)); auto with zarith.
unfold Fminus, Fopp, Fplus, Fmult; simpl.
apply Zmin_Zle; auto with zarith.
rewrite Fminus_correct; auto with zarith; rewrite Fmult_correct; auto with real zarith.
fold FtoRradix; rewrite H1; ring.
fold FtoRradix; replace (r-x1*y1-x1*y2-x2*y1)%R with ((-e)+x2*y2)%R.
2: apply trans_eq with (-e+x*y-(x+0)*y+x2*y2)%R;[ring|idtac].
2: rewrite eeq; rewrite Xeq; rewrite Yeq; ring.
apply Rle_lt_trans with ((Rabs e) + (Rabs (x2 * y2)))%R.
apply Rle_trans with (1:= Rabs_triang (-e) (x2 * y2)%R).
rewrite Rabs_Ropp; right; ring.
generalize eLe; generalize x2y2Le; intros.
apply Rle_lt_trans with 
  (powerRZ radix (t + Fexp x + Fexp y) / 2+powerRZ radix (2 * s + Fexp x + Fexp y) / 4)%R; auto with real.
apply Rlt_le_trans with  (powerRZ radix (t + Fexp x + Fexp y) +
    powerRZ radix (2 * s + Fexp x + Fexp y) / 4)%R.
apply Rplus_lt_compat_r.
apply Rlt_le_trans with (powerRZ radix (t + Fexp x + Fexp y)*1)%R;[idtac|right; ring].
unfold Rdiv; apply Rmult_lt_compat_l; auto with real zarith.
apply Rlt_le_trans with (/1)%R; auto with real.
apply Rle_trans with (powerRZ radix (t+1 + Fexp x + Fexp y) +
    powerRZ radix (2 * s + Fexp x + Fexp y))%R;[apply Rplus_le_compat|idtac].
apply Rle_powerRZ; auto with real zarith.
apply Rle_trans with (powerRZ radix (2*s + Fexp x + Fexp y)*1)%R;[idtac|right; ring].
unfold Rdiv; apply Rmult_le_compat_l; auto with real zarith.
assert (0 < 4)%R;[apply Rlt_le_trans with 2%R; auto with real|idtac].
apply Rmult_le_reg_l with 4%R; auto with real.
apply Rle_trans with 1%R;[right; field|ring_simplify (4*1)%R]; auto with real.
apply Rle_trans with 2%R; auto with real.
apply Rle_trans with (powerRZ radix (t + 1 + Fexp x + Fexp y+1)).
apply powerRZSumRle; auto with zarith.
apply Rle_powerRZ; auto with real zarith.
Qed.


Lemma Boundedt4: (exists x':float, (FtoRradix x'=r-x1*y1-x1*y2-x2*y1-x2*y2)%R /\ (Fbounded b x')).
elim errorBoundedMult with b radix t (Closest b radix) x y r; auto with zarith.
2: apply ClosestRoundedModeP with t; auto with zarith.
2: elim Nx; auto.
2: elim Ny; auto.
intros g T; elim T; intros H1 T'; elim T'; intros; clear T T'.
exists (Fopp g); split.
unfold FtoRradix;rewrite Fopp_correct; rewrite H1; fold FtoRradix.
rewrite Xeq; rewrite Yeq; ring.
apply oppBounded; auto.
Qed.

Lemma Boundedt4_aux: (exists x':float, (FtoRradix x'=r-x1*y1-x1*y2-x2*y1-x2*y2)%R /\ (Fbounded b x')
  /\ (Fexp x'=Fexp x+Fexp y)%Z).
elim errorBoundedMult with b radix t (Closest b radix) x y r; auto with zarith.
2: apply ClosestRoundedModeP with t; auto with zarith.
2: elim Nx; auto.
2: elim Ny; auto.
intros g T; elim T; intros H1 T'; elim T'; intros; clear T T'.
exists (Fopp g); split.
unfold FtoRradix;rewrite Fopp_correct; rewrite H1; fold FtoRradix.
rewrite Xeq; rewrite Yeq; ring.
split;[apply oppBounded; auto|simpl; auto].
Qed.



Hypotheses Fx1: Fbounded b' x1.
Hypotheses Fx2: Fbounded bt x2.
Hypotheses Fy1: Fbounded b' y1.
Hypotheses Fy2: Fbounded bt y2.
Hypothesis Hst3: (t <= s+s)%Z.

Lemma p''GivesBound: Zpos (vNum bt)=(Zpower_nat radix s).
unfold bt in |- *; unfold vNum in |- *.
apply
 trans_eq
  with
    (Z_of_nat
       (nat_of_P
          (P_of_succ_nat
             (pred (Zabs_nat (Zpower_nat radix s)))))).
unfold Z_of_nat in |- *; rewrite nat_of_P_o_P_of_succ_nat_eq_succ;
 auto with zarith.
rewrite nat_of_P_o_P_of_succ_nat_eq_succ; auto with arith zarith.
cut (Zabs (Zpower_nat radix s) = Zpower_nat radix s).
intros H; pattern (Zpower_nat radix s) at 2 in |- *; rewrite <- H.
rewrite Zabs_absolu.
rewrite <- (S_pred (Zabs_nat (Zpower_nat radix s)) 0);
 auto with arith zarith.
apply lt_Zlt_inv; simpl in |- *; auto with zarith arith.
rewrite <- Zabs_absolu; rewrite H; auto with arith zarith.
apply Zabs_eq; auto with arith zarith.
Qed.





Lemma Boundedx1y1_aux: (exists x':float, (FtoRradix x'=x1*y1)%R /\ (Fbounded b x') 
  /\ (Fexp x'=Fexp x1+Fexp y1)%Z ).
exists (Fmult x1 y1).
split;[unfold FtoRradix; rewrite Fmult_correct; auto with real zarith|idtac].
split.
unfold Fmult; split; simpl; auto with zarith.
rewrite Zabs_Zmult.
elim Fx1; elim Fy1; intros.
apply Zlt_le_trans with (Zpos (vNum b')*Zpos (vNum b'))%Z; auto with zarith.
case (Zle_lt_or_eq 0%Z (Zabs (Fnum x1))); auto with zarith.
intros I; apply Zlt_le_trans with  (Zabs (Fnum x1) * Zpos (vNum b'))%Z; auto with zarith.
apply Zmult_lt_compat_l; auto with zarith.
intros I; rewrite <- I; auto with zarith. 
unfold b'; rewrite p'GivesBound; auto with zarith.
rewrite <- Zpower_nat_is_exp.
rewrite pGivesBound; auto with zarith.
simpl; auto.
Qed.

Lemma Boundedx1y1: (exists x':float, (FtoRradix x'=x1*y1)%R /\ (Fbounded b x')).
elim Boundedx1y1_aux; intros f T; elim T ; intros T1 T2; elim T2; intros.
exists f; split; auto.
Qed.

Lemma Boundedx1y2_aux: (exists x':float, (FtoRradix x'=x1*y2)%R /\ (Fbounded b x')
   /\ (Fexp x'=Fexp x1+Fexp y2)%Z ).
exists (Fmult x1 y2).
split;[unfold FtoRradix; rewrite Fmult_correct; auto with real zarith|idtac].
split;[idtac|simpl; auto].
unfold Fmult; split; simpl; auto with zarith.
rewrite Zabs_Zmult.
elim Fx1; elim Fy2; intros.
apply Zlt_le_trans with (Zpos (vNum b')*Zpos (vNum bt))%Z; auto with zarith.
case (Zle_lt_or_eq 0%Z (Zabs (Fnum x1))); auto with zarith.
intros I; apply Zlt_le_trans with  (Zabs (Fnum x1) * Zpos (vNum bt))%Z; auto with zarith.
apply Zmult_lt_compat_l; auto with zarith.
intros I; rewrite <- I; auto with zarith. 
unfold b'; rewrite p'GivesBound; auto with zarith.
rewrite p''GivesBound; auto with zarith.
rewrite <- Zpower_nat_is_exp.
rewrite pGivesBound; auto with zarith.
Qed.

Lemma Boundedx1y2: (exists x':float, (FtoRradix x'=x1*y2)%R /\ (Fbounded b x')).
elim Boundedx1y2_aux; intros f T; elim T ; intros T1 T2; elim T2; intros.
exists f; split; auto.
Qed.


Lemma Boundedx2y1_aux: (exists x':float, (FtoRradix x'=x2*y1)%R /\ (Fbounded b x')
   /\ (Fexp x'=Fexp x2+Fexp y1)%Z ).
exists (Fmult x2 y1).
split;[unfold FtoRradix; rewrite Fmult_correct; auto with real zarith|idtac].
split;[idtac|simpl; auto].
unfold Fmult; split; simpl; auto with zarith.
rewrite Zabs_Zmult.
elim Fx2; elim Fy1; intros.
apply Zlt_le_trans with (Zpos (vNum bt)*Zpos (vNum b'))%Z; auto with zarith.
case (Zle_lt_or_eq 0%Z (Zabs (Fnum x2))); auto with zarith.
intros I; apply Zlt_le_trans with  (Zabs (Fnum x2) * Zpos (vNum b'))%Z; auto with zarith.
apply Zmult_lt_compat_l; auto with zarith.
intros I; rewrite <- I; auto with zarith. 
unfold b'; rewrite p'GivesBound; auto with zarith.
rewrite p''GivesBound; auto with zarith.
rewrite <- Zpower_nat_is_exp.
rewrite pGivesBound; auto with zarith.
Qed.

Lemma Boundedx2y1: (exists x':float, (FtoRradix x'=x2*y1)%R /\ (Fbounded b x')).
elim Boundedx2y1_aux; intros f T; elim T ; intros T1 T2; elim T2; intros.
exists f; split; auto.
Qed.

End Sec1.

Section Algo.

Variable radix : Z.
Variable b : Fbound.
Variables t:nat.

Let FtoRradix := FtoR radix.
Coercion FtoRradix : float >-> R.
Hypothesis radixMoreThanOne : (1 < radix)%Z.

Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne).
Hint Resolve radixMoreThanZERO: zarith.

Hypothesis pGivesBound: Zpos (vNum b)=(Zpower_nat radix t).
Hypotheses pGe: (4 <= t).


Variables x y p q hx tx p' q' hy ty x1y1 x1y2 x2y1 x2y2 r t1 t2 t3 t4:float.


Hypothesis Cx: (Fnormal radix b x).
Hypothesis Cy: (Fnormal radix b y).

Hypothesis Expoxy: (-dExp b <= Fexp x+Fexp y)%Z.

Let s:= t- div2 t.

Hypothesis A1: (Closest b radix (x*((powerRZ radix s)+1))%R p).
Hypothesis A2: (Closest b radix (x-p)%R  q).
Hypothesis A3: (Closest b radix (q+p)%R hx).
Hypothesis A4: (Closest b radix (x-hx)%R tx).

Hypothesis B1: (Closest b radix (y*((powerRZ radix s)+1))%R p').
Hypothesis B2: (Closest b radix (y-p')%R  q').
Hypothesis B3: (Closest b radix (q'+p')%R hy).
Hypothesis B4: (Closest b radix (y-hy)%R ty).


Hypothesis C1: (Closest b radix (hx*hy)%R  x1y1).
Hypothesis C2: (Closest b radix (hx*ty)%R  x1y2).
Hypothesis C3: (Closest b radix (tx*hy)%R  x2y1).
Hypothesis C4: (Closest b radix (tx*ty)%R  x2y2).

Hypothesis D1: (Closest b radix (x*y)%R  r).
Hypothesis D2: (Closest b radix (r-x1y1)%R  t1).
Hypothesis D3: (Closest b radix (t1-x1y2)%R  t2).
Hypothesis D4: (Closest b radix (t2-x2y1)%R  t3).
Hypothesis D5: (Closest b radix (t3-x2y2)%R  t4).



Lemma SLe: (2 <= s)%nat.
unfold s; auto with zarith.
assert (2<= t-div2 t)%Z; auto with zarith.
apply Zmult_le_reg_r with 2%Z; auto with zarith.
replace ((t-div2 t)*2)%Z with (2*t-2*div2 t)%Z; auto with zarith.
replace (2*div2 t)%Z with (Z_of_nat (Div2.double (div2 t))).
case (even_or_odd t); intros I.
rewrite <- even_double; auto with zarith.
apply Zle_trans with (2*t+1-(S ( Div2.double (div2 t))))%Z; auto with zarith.
rewrite <- odd_double; auto with zarith.
replace (Z_of_nat (S ( Div2.double (div2 t)))) with (1+ Div2.double (div2 t))%Z; auto with zarith.
rewrite inj_S; unfold Zsucc; auto with zarith.
unfold Div2.double; rewrite inj_plus; ring.
Qed.


Lemma SGe: (s <= t-2)%nat.
unfold s; auto with zarith.
assert (2<= div2 t)%Z; auto with zarith.
apply Zmult_le_reg_r with 2%Z; auto with zarith.
replace (div2 t*2)%Z with (Z_of_nat (Div2.double (div2 t))).
case (even_or_odd t); intros I.
rewrite <- even_double; auto with zarith.
apply Zle_trans with (-1+(S ( Div2.double (div2 t))))%Z; auto with zarith.
rewrite <- odd_double; auto with zarith.
case (Zle_lt_or_eq 4 t); auto with zarith.
intros I2; absurd (odd t); auto.
intros I3; apply not_even_and_odd with t; auto.
replace t with (4%nat); auto with zarith.
apply even_S; apply odd_S; apply even_S; apply odd_S; apply even_O.
rewrite inj_S; unfold Zsucc; auto with zarith.
unfold Div2.double; rewrite inj_plus; ring.
Qed.

Lemma s2Ge: (t <= s + s)%Z.
unfold s.
assert (2*(div2 t) <= t)%Z; auto with zarith.
case (even_or_odd t); intros I.
apply Zle_trans with  (Div2.double (div2 t)).
unfold Div2.double; rewrite inj_plus; auto with zarith.
rewrite <- even_double; auto with zarith.
apply Zle_trans with (-1+(S ( Div2.double (div2 t))))%Z; auto with zarith.
rewrite inj_S; unfold Zsucc; auto with zarith.
unfold Div2.double; rewrite inj_plus; auto with zarith.
rewrite <- odd_double; auto with zarith.
rewrite inj_minus1; auto with zarith.
Qed.


Lemma s2Le: (s + s <= t + 1)%Z.
unfold s.
rewrite inj_minus1; auto with zarith.
2: generalize (lt_div2 t); auto with zarith.
assert (t<= 2*(div2 t)+1)%Z; auto with zarith.
case (even_or_odd t); intros I.
apply Zle_trans with  ((Div2.double (div2 t)+1))%Z.
2:unfold Div2.double; rewrite inj_plus; auto with zarith.
rewrite <- even_double; auto with zarith.
apply Zle_trans with ((S ( Div2.double (div2 t))))%Z; auto with zarith.
2: rewrite inj_S; unfold Zsucc; auto with zarith.
2: unfold Div2.double; rewrite inj_plus; auto with zarith.
rewrite <- odd_double; auto with zarith.
Qed.




Theorem Dekker_aux: (exists x':float, (FtoRradix x'=tx*ty)%R /\ (Fbounded b x'))
    -> (x*y=r-t4)%R.
intros L1.
generalize SLe; intros Sle; generalize SGe; intros Sge.
generalize s2Le; intros s2le; generalize s2Ge; intros s2ge. 
generalize VeltkampU; intros V.
elim V with radix b s t x p q hx tx; auto.
2: left; auto.
intros MX1 T; elim T; intros MX2 T'; clear T; elim T'; intros T1 T2; clear T'.
elim T1; intros hx' T1'; elim T1'; intros MX3 T1''; elim T1''; intros MX4 MX5; clear T1 T1' T1''.
lapply MX5; auto; clear MX5; intros MX5.
elim T2; intros tx' T1'; elim T1'; intros MX6 T1''; elim T1''; intros MX7 MX8; clear T2 T1' T1''.
elim V with radix b s t y p' q' hy ty; auto.
2: left; auto.
intros MY1 T; elim T; intros MY2 T'; clear T; elim T'; intros T1 T2; clear T'.
elim T1; intros hy' T1'; elim T1'; intros MY3 T1''; elim T1''; intros MY4 MY5; clear T1 T1' T1''.
lapply MY5; auto; clear MY5; intros MY5.
elim T2; intros ty' T1'; elim T1'; intros MY6 T1''; elim T1''; intros MY7 MY8; clear T2 T1' T1'' V.
generalize Boundedt1; intros V.
elim V with radix b s t x hx' tx' y hy' ty' r (Fminus radix (Fmult x y) r); auto with zarith real; clear V.
2:rewrite Fminus_correct; auto with zarith; rewrite Fmult_correct; auto with zarith; ring.
2:rewrite MX6; rewrite MX3; exact MX2.
2:rewrite MY6; rewrite MY3; exact MY2.
2:rewrite MX6; replace (FtoR radix tx) with (FtoR radix x-FtoR radix hx)%R; auto with real.
2:rewrite MX2; ring.
2:rewrite MY6; replace (FtoR radix ty) with (FtoR radix y-FtoR radix hy)%R; auto with real.
2:rewrite MY2; ring.
intros t1' T; elim T; intros M11 T'; elim T'; intros M12 M13; clear T T'.
generalize Boundedt2; intros V.
elim V with radix b s t x hx' tx' y hy' ty' r (Fminus radix (Fmult x y) r); auto with zarith real; clear V.
2:rewrite Fminus_correct; auto with zarith; rewrite Fmult_correct; auto with zarith; ring.
2:rewrite MX6; rewrite MX3; exact MX2.
2:rewrite MY6; rewrite MY3; exact MY2.
2:rewrite MX6; replace (FtoR radix tx) with (FtoR radix x-FtoR radix hx)%R; auto with real.
2:rewrite MX2; ring.
2:rewrite MY6; replace (FtoR radix ty) with (FtoR radix y-FtoR radix hy)%R; auto with real.
2:rewrite MY2; ring.
intros t2' T; elim T; intros M21 T'; elim T'; intros M22 M23; clear T T'.
generalize Boundedt3; intros V.
elim V with radix b s t x hx' tx' y hy' ty' r (Fminus radix (Fmult x y) r); auto with zarith real; clear V.
2:rewrite Fminus_correct; auto with zarith; rewrite Fmult_correct; auto with zarith; ring.
2:rewrite MX6; rewrite MX3; exact MX2.
2:rewrite MY6; rewrite MY3; exact MY2.
2:rewrite MX6; replace (FtoR radix tx) with (FtoR radix x-FtoR radix hx)%R; auto with real.
2:rewrite MX2; ring.
2:rewrite MY6; replace (FtoR radix ty) with (FtoR radix y-FtoR radix hy)%R; auto with real.
2:rewrite MY2; ring.
intros t3' T; elim T; intros M31 T'; elim T'; intros M32 M33; clear T T'.
generalize Boundedt4; intros V.
elim V with radix b s t x hx' tx' y hy' ty' r ; auto with zarith real; clear V.
2:rewrite MX6; rewrite MX3; exact MX2.
2:rewrite MY6; rewrite MY3; exact MY2.
intros t4' T; elim T; intros M41 M42; clear T.
cut (FtoRradix t4=r-x*y)%R; auto with real.
intros V; rewrite V; ring.
apply sym_eq.
apply trans_eq with (FtoRradix t4').
unfold FtoRradix; rewrite M41; rewrite MX2; rewrite MY2.
rewrite MX3; rewrite MX6; rewrite MY3; rewrite MY6; ring.
unfold FtoRradix; apply RoundedModeProjectorIdemEq with b t (Closest b radix); auto with zarith.
apply ClosestRoundedModeP with t; auto with zarith.
replace (FtoR radix t4') with (t3 - x2y2)%R; auto.
replace (FtoRradix t3) with (FtoRradix t3').
replace (FtoRradix x2y2) with (tx*ty)%R.
unfold FtoRradix; rewrite M31; rewrite M41.
rewrite <- MY6; rewrite <- MX6; ring.
elim L1; intros v T; elim T; intros L2 L3.
rewrite <- L2; unfold FtoRradix.
apply RoundedModeProjectorIdemEq with b t (Closest b radix); auto with zarith.
apply ClosestRoundedModeP with t; auto with zarith.
replace (FtoR radix v) with (tx*ty)%R; auto with real.
unfold FtoRradix; apply RoundedModeProjectorIdemEq with b t (Closest b radix); auto with zarith.
apply ClosestRoundedModeP with t; auto with zarith.
replace (FtoR radix t3') with (t2-x2y1)%R; auto with real.
replace (FtoRradix t2) with (FtoRradix t2').
replace (FtoRradix x2y1) with (tx*hy)%R.
unfold FtoRradix; rewrite M21; rewrite M31.
rewrite <- MX6; rewrite <- MY3; ring.
elim Boundedx2y1 with radix b s t x tx' y hy'; auto with zarith.
intros v T; elim T; intros L2 L3.
apply trans_eq with (FtoR radix v).
unfold FtoRradix; rewrite L2; rewrite MX6; rewrite MY3; ring.
unfold FtoRradix; apply RoundedModeProjectorIdemEq with b t (Closest b radix); auto with zarith.
apply ClosestRoundedModeP with t; auto with zarith.
replace (FtoR radix v) with (tx*hy)%R; auto with real.
unfold FtoRradix; rewrite L2; rewrite MX6; rewrite MY3; ring.
unfold FtoRradix; apply RoundedModeProjectorIdemEq with b t (Closest b radix); auto with zarith.
apply ClosestRoundedModeP with t; auto with zarith.
replace (FtoR radix t2') with (t1-x1y2)%R; auto with real.
replace (FtoRradix t1) with (FtoRradix t1').
replace (FtoRradix x1y2) with (hx*ty)%R.
unfold FtoRradix; rewrite M21; rewrite M11.
rewrite <- MX3; rewrite <- MY6; ring.
elim Boundedx1y2 with radix b s t x hx' y ty'; auto with zarith.
intros v T; elim T; intros L2 L3; clear T.
apply trans_eq with (FtoR radix v).
unfold FtoRradix; rewrite L2; rewrite MY6; rewrite MX3; ring.
unfold FtoRradix; apply RoundedModeProjectorIdemEq with b t (Closest b radix); auto with zarith.
apply ClosestRoundedModeP with t; auto with zarith.
replace (FtoR radix v) with (hx*ty)%R; auto with real.
unfold FtoRradix; rewrite L2; rewrite MY6; rewrite MX3; ring.
unfold FtoRradix; apply RoundedModeProjectorIdemEq with b t (Closest b radix); auto with zarith.
apply ClosestRoundedModeP with t; auto with zarith.
replace (FtoR radix t1') with (r-x1y1)%R; auto with real.
replace (FtoRradix x1y1) with (hx*hy)%R.
unfold FtoRradix; rewrite M11; rewrite MY3; rewrite MX3; ring.
elim Boundedx1y1 with radix b s t x hx' y hy'; auto with zarith.
intros v T; elim T; intros L2 L3; clear T.
apply trans_eq with (FtoR radix v).
unfold FtoRradix; rewrite L2; rewrite MY3; rewrite MX3; ring.
unfold FtoRradix; apply RoundedModeProjectorIdemEq with b t (Closest b radix); auto with zarith.
apply ClosestRoundedModeP with t; auto with zarith.
replace (FtoR radix v) with (hx*hy)%R; auto with real.
unfold FtoRradix; rewrite L2; rewrite MY3; rewrite MX3; ring.
Qed.



Theorem Boundedx2y2: (radix=2)%Z \/ (even t) -> 
    (exists x':float, (FtoRradix x'=tx*ty)%R /\ (Fbounded b x') /\ (Fexp x+Fexp y <= Fexp x')%Z).
intros H; case H; clear H; intros H.
generalize SLe; intros Sle; generalize SGe; intros Sge.
elim Veltkamp_tail2 with radix b s t x p q hx tx; auto.
2: elim Cx; auto.
intros x2 T; elim T; intros G1 T'; elim T'; intros G2 T''; elim T''; intros G3 G4; clear T T' T''.
elim Veltkamp_tail2 with radix b s t y p' q' hy ty; auto.
2: elim Cy; auto.
intros y2 T; elim T; intros J1 T'; elim T'; intros J2 T''; elim T''; intros J3 J4; clear T T' T''.
exists (Fmult x2 y2).
split;[unfold FtoRradix; rewrite Fmult_correct; auto with real zarith|idtac].
rewrite G1; rewrite J1; ring.
split.
unfold Fmult; split; simpl; auto with zarith.
rewrite Zabs_Zmult.
elim J3; elim G3; replace  (Zpos
          (vNum
             (Bound
                (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (s - 1)))))
                (dExp b))))%Z with (Zpower_nat radix (s - 1)); intros.
apply Zlt_le_trans with (Zpower_nat radix (s - 1)*Zpower_nat radix (s - 1))%Z; auto with zarith.
case (Zle_lt_or_eq 0%Z (Zabs (Fnum x2))); auto with zarith.
intros I; apply Zlt_le_trans with  (Zabs (Fnum x2) * Zpower_nat radix (s-1))%Z; auto with zarith.
apply Zmult_lt_compat_l; auto with zarith.
intros I; rewrite <- I; auto with zarith. 
rewrite pGivesBound; rewrite <- Zpower_nat_is_exp; auto with zarith.
assert ((s-1+(s-1)) <= t)%Z; auto with zarith.
generalize s2Le; auto with zarith.
apply sym_eq; unfold vNum in |- *.
apply
 trans_eq
  with
    (Z_of_nat
       (nat_of_P
          (P_of_succ_nat
             (pred (Zabs_nat (Zpower_nat radix (s-1))))))).
unfold Z_of_nat in |- *; rewrite nat_of_P_o_P_of_succ_nat_eq_succ;
 auto with zarith.
rewrite nat_of_P_o_P_of_succ_nat_eq_succ; auto with arith zarith.
cut (Zabs (Zpower_nat radix (s-1)) = Zpower_nat radix (s-1)).
intros HA; pattern (Zpower_nat radix (s-1)) at 2 in |- *; rewrite <- HA.
rewrite Zabs_absolu.
rewrite <- (S_pred (Zabs_nat (Zpower_nat radix (s-1))) 0);
 auto with arith zarith.
apply lt_Zlt_inv; simpl in |- *; auto with zarith arith.
rewrite <- Zabs_absolu; rewrite HA; auto with arith zarith.
apply Zabs_eq; auto with arith zarith.
apply Zle_trans with (Fexp (Fnormalize radix b t x)+Fexp (Fnormalize radix b t y))%Z; auto with zarith.
rewrite FcanonicFnormalizeEq; auto with zarith.
rewrite FcanonicFnormalizeEq; auto with zarith.
left; auto.
left; auto.
apply Zle_trans with (Fexp (Fnormalize radix b t x)+Fexp (Fnormalize radix b t y))%Z; simpl; auto with zarith.
rewrite FcanonicFnormalizeEq; auto with zarith.
rewrite FcanonicFnormalizeEq; auto with zarith.
left; auto.
left; auto.
generalize SLe; intros Sle; generalize SGe; intros Sge.
elim Veltkamp_tail with radix b s t x p q hx tx; auto.
2: elim Cx; auto.
intros x2 T; elim T; intros G1 T'; elim T'; intros G2 T''; elim T''; intros G3 G4; clear T T' T''.
elim Veltkamp_tail with radix b s t y p' q' hy ty; auto.
2: elim Cy; auto.
intros y2 T; elim T; intros J1 T'; elim T'; intros J2 T''; elim T''; intros J3 J4; clear T T' T''.
exists (Fmult x2 y2).
split;[unfold FtoRradix; rewrite Fmult_correct; auto with real zarith|idtac].
rewrite G1; rewrite J1; auto with real.
split.
unfold Fmult; split; simpl; auto with zarith.
rewrite Zabs_Zmult.
elim J3; elim G3; replace  (Zpos
          (vNum
             (Bound
                (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (s)))))
                (dExp b))))%Z with (Zpower_nat radix (s)); intros.
apply Zlt_le_trans with (Zpower_nat radix s*Zpower_nat radix s)%Z; auto with zarith.
case (Zle_lt_or_eq 0%Z (Zabs (Fnum x2))); auto with zarith.
intros I; apply Zlt_le_trans with  (Zabs (Fnum x2) * Zpower_nat radix s)%Z; auto with zarith.
apply Zmult_lt_compat_l; auto with zarith.
intros I; rewrite <- I; auto with zarith. 
rewrite <- Zpower_nat_is_exp; rewrite pGivesBound; auto with zarith.
assert (2*s <= t)%Z; auto with zarith.
unfold s.
rewrite inj_minus1; auto with zarith.
assert (t <= 2*(div2 t))%Z; auto with zarith.
apply Zle_trans with  (Div2.double (div2 t)).
2: unfold Div2.double; rewrite inj_plus; auto with zarith.
rewrite <- even_double; auto with zarith.
generalize (lt_div2 t); auto with zarith.
rewrite p''GivesBound; auto.
apply Zle_trans with (Fexp (Fnormalize radix b t x)+Fexp (Fnormalize radix b t y))%Z; auto with zarith.
rewrite FcanonicFnormalizeEq; auto with zarith.
rewrite FcanonicFnormalizeEq; auto with zarith.
left; auto.
left; auto.
apply Zle_trans with (Fexp (Fnormalize radix b t x)+Fexp (Fnormalize radix b t y))%Z; auto with zarith.
rewrite FcanonicFnormalizeEq; auto with zarith.
rewrite FcanonicFnormalizeEq; auto with zarith.
left; auto.
left; auto.
simpl; auto with zarith.
Qed.

Theorem DekkerN: (radix=2)%Z \/ (even t) ->  (x*y=r-t4)%R.
intros H; apply Dekker_aux.
elim Boundedx2y2; auto.
intros f T; exists f; intuition.
Qed.


End Algo.

Section AlgoS1.

Variable radix : Z.
Variable b : Fbound.
Variables t:nat.

Let FtoRradix := FtoR radix.
Coercion FtoRradix : float >-> R.
Hypothesis radixMoreThanOne : (1 < radix)%Z.

Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne).
Hint Resolve radixMoreThanZERO: zarith.

Hypothesis pGivesBound: Zpos (vNum b)=(Zpower_nat radix t).
Hypotheses pGe: (4 <= t).


Variables x y p q hx tx p' q' hy ty x1y1 x1y2 x2y1 x2y2 r t1 t2 t3 t4:float.


Hypothesis Cx: (Fnormal radix b x).
Hypothesis Cy: (Fsubnormal radix b y).

Hypothesis Expoxy: (-dExp b <= Fexp x+Fexp y)%Z.

Let s:= t- div2 t.

Hypothesis A1: (Closest b radix (x*((powerRZ radix s)+1))%R p).
Hypothesis A2: (Closest b radix (x-p)%R  q).
Hypothesis A3: (Closest b radix (q+p)%R hx).
Hypothesis A4: (Closest b radix (x-hx)%R tx).

Hypothesis B1: (Closest b radix (y*((powerRZ radix s)+1))%R p').
Hypothesis B2: (Closest b radix (y-p')%R  q').
Hypothesis B3: (Closest b radix (q'+p')%R hy).
Hypothesis B4: (Closest b radix (y-hy)%R ty).


Hypothesis C1: (Closest b radix (hx*hy)%R  x1y1).
Hypothesis C2: (Closest b radix (hx*ty)%R  x1y2).
Hypothesis C3: (Closest b radix (tx*hy)%R  x2y1).
Hypothesis C4: (Closest b radix (tx*ty)%R  x2y2).

Hypothesis D1: (Closest b radix (x*y)%R  r).
Hypothesis D2: (Closest b radix (r-x1y1)%R  t1).
Hypothesis D3: (Closest b radix (t1-x1y2)%R  t2).
Hypothesis D4: (Closest b radix (t2-x2y1)%R  t3).
Hypothesis D5: (Closest b radix (t3-x2y2)%R  t4).




Theorem DekkerS1: (radix=2)%Z \/ (even t) ->  (x*y=r-t4)%R.
intros H; unfold FtoRradix.
case (Req_dec 0%R y); intros Ny.
cut (FtoRradix r=0)%R;[intros Z1|idtac].
cut (FtoRradix t4=0)%R;[intros Z2|idtac].
fold FtoRradix; rewrite Z1; rewrite Z2; rewrite <- Ny; ring.
cut (FtoRradix hy=0)%R;[intros Z3|idtac].
cut (FtoRradix ty=0)%R;[intros Z4|idtac].
unfold FtoRradix; apply ClosestZero with b t (t3-x2y2)%R; auto with zarith.
cut (FtoRradix t3=0)%R;[intros Z5|idtac].
cut (FtoRradix x2y2=0)%R;[intros Z6|idtac].
rewrite Z5; rewrite Z6; ring.
unfold FtoRradix; apply ClosestZero with b t (tx*ty)%R; auto with zarith.
rewrite Z4; ring.
unfold FtoRradix; apply ClosestZero with b t (t2-x2y1)%R; auto with zarith.
cut (FtoRradix t2=0)%R;[intros Z5|idtac].
cut (FtoRradix x2y1=0)%R;[intros Z6|idtac].
rewrite Z5; rewrite Z6; ring.
unfold FtoRradix; apply ClosestZero with b t (tx*hy)%R; auto with zarith.
rewrite Z3; ring.
unfold FtoRradix; apply ClosestZero with b t (t1-x1y2)%R; auto with zarith.
cut (FtoRradix t1=0)%R;[intros Z5|idtac].
cut (FtoRradix x1y2=0)%R;[intros Z6|idtac].
rewrite Z5; rewrite Z6; ring.
unfold FtoRradix; apply ClosestZero with b t (hx*ty)%R; auto with zarith.
rewrite Z4; ring.
unfold FtoRradix; apply ClosestZero with b t (r-x1y1)%R; auto with zarith.
cut (FtoRradix x1y1=0)%R;[intros Z6|idtac].
rewrite Z1; rewrite Z6; ring.
unfold FtoRradix; apply ClosestZero with b t (hx*hy)%R; auto with zarith.
rewrite Z3; ring.
elim VeltkampU with radix b s t y p' q' hy ty; auto.
intros T1 T; elim T; intros H' T'; clear T1 T T'.
fold FtoRradix in H'; rewrite Z3 in H'; rewrite <- Ny in H'; auto with real.
apply trans_eq with (0+ty)%R; auto with real.
unfold s; apply SLe; auto.
unfold s; apply SGe; auto.
right; auto.
elim Veltkamp with radix b s t y p' q' hy; auto.
intros T1 T; elim T; intros hy' T'; elim T'; intros G1 T''; elim T''; intros ; clear T1 T T' T''.
unfold FtoRradix; rewrite <- G1.
 apply ClosestZero with (Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (t - s)))))
            (dExp b)) (t-s) (FtoR radix y)%R; auto with zarith.
apply p'GivesBound; auto with zarith.
assert  (s <= t - 2)%Z; auto with zarith.
assert  (s <= t - 2)%nat; auto with zarith.
unfold s; apply SGe; auto.
unfold s; apply SLe; auto.
unfold s; apply SGe; auto.
elim Cy; auto.
unfold FtoRradix; apply ClosestZero with b t (x*y)%R; auto with zarith.
rewrite <- Ny; ring.
elim bimplybplusNorm with radix b s t y; auto.
2: unfold s; apply SLe; auto.
2: unfold s; apply SGe; auto.
2: elim Cy; auto.
intros yy T; elim T; intros X1 X2; clear T.
rewrite <- X1.
assert (Fnormal radix (plusExp t b) x).
elim Cx; intros F1 F2; elim F1; intros.
split;[split|idtac]; unfold plusExp; simpl; auto with zarith.
cut (forall (x:N) (y:positive), (x+(Zpos y)=(x +Npos y)%N)%Z).
intros T; simpl; rewrite <- T; auto with zarith.
apply Zle_trans with (-(dExp b))%Z; auto with zarith.
apply Zle_trans with (-(dExp b) + Zneg  (P_of_succ_nat (pred (pred t))))%Z; auto with zarith.
apply Zeq_le; ring_simplify; auto with zarith.
apply Zle_trans with (-(dExp b)+0)%Z; auto with zarith.
intros;unfold Nplus.
case x0; auto with zarith.
assert (- dExp (plusExp t b) <= Fexp x + Fexp yy)%Z.
elim X2; intros F1 F2; elim F1; intros.
assert (0 <= Fexp x)%Z; auto with zarith.
apply Zplus_le_reg_l with (Fexp y).
rewrite (Zplus_comm (Fexp y) (Fexp x)); apply Zle_trans with (2:=Expoxy).
elim Cy; intros F1' F2'; elim F2'; auto with zarith.
assert (Closest (plusExp t b) radix
   (FtoR radix x * (powerRZ radix (t - div2 t)%nat + 1)) p).
cut (FtoR radix x * (powerRZ radix (t - div2 t)%nat + 1) =
    (FtoRradix (Fmult x (Float (Zpower_nat radix (t - div2 t)%nat + 1) 0))))%R.
intros K'; rewrite K'.
unfold FtoRradix; apply Closestbbplus with 2 t; auto with zarith.
unfold Fmult; simpl.
assert (K:Fbounded b x);[elim Cx; auto|elim K; auto with zarith].
fold FtoRradix; rewrite <- K'; auto with real.
unfold FtoRradix; rewrite Fmult_correct; auto.
unfold FtoR; simpl; rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ; simpl;ring.
assert (Closest (plusExp t b) radix (FtoR radix x - FtoR radix p) q).
rewrite <- Fminus_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fminus; simpl; apply Zmin_Zle.
assert (K:Fbounded b x);[elim Cx; auto|elim K; auto with zarith].
assert (K:Fbounded b p);[elim A1; auto|elim K; auto with zarith].
rewrite Fminus_correct; auto.
assert (Closest (plusExp t b) radix (FtoR radix q + FtoR radix p) hx).
rewrite <- Fplus_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fplus; simpl; apply Zmin_Zle.
assert (K:Fbounded b q);[elim A2; auto|elim K; auto with zarith].
assert (K:Fbounded b p);[elim A1; auto|elim K; auto with zarith].
rewrite Fplus_correct; auto.
assert (Closest (plusExp t b) radix (FtoR radix x - FtoR radix hx) tx).
rewrite <- Fminus_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fminus; simpl; apply Zmin_Zle.
assert (K:Fbounded b x);[elim Cx; auto|elim K; auto with zarith].
assert (K:Fbounded b hx);[elim A3; auto|elim K; auto with zarith].
rewrite Fminus_correct; auto.
assert (Closest (plusExp t b) radix (FtoR radix yy * (powerRZ radix (t - div2 t)%nat + 1)) p').
rewrite X1; cut (FtoR radix y * (powerRZ radix (t - div2 t)%nat + 1) =
    (FtoRradix (Fmult y (Float (Zpower_nat radix (t - div2 t)%nat + 1) 0))))%R.
intros K'; rewrite K'.
unfold FtoRradix; apply Closestbbplus with 2 t; auto with zarith.
unfold Fmult; simpl.
assert (K:Fbounded b y);[elim Cy; auto|elim K; auto with zarith].
fold FtoRradix; rewrite <- K'; auto with real.
unfold FtoRradix; rewrite Fmult_correct; auto.
unfold FtoR; simpl; rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ; simpl; ring.
assert (Closest (plusExp t b) radix (FtoR radix yy - FtoR radix p') q').
rewrite X1; rewrite <- Fminus_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fminus; simpl; apply Zmin_Zle.
assert (K:Fbounded b y);[elim Cy; auto|elim K; auto with zarith].
assert (K:Fbounded b p');[elim B1; auto|elim K; auto with zarith].
rewrite Fminus_correct; auto.
assert (Closest (plusExp t b) radix (FtoR radix q' + FtoR radix p') hy).
rewrite <- Fplus_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fplus; simpl; apply Zmin_Zle.
assert (K:Fbounded b q');[elim B2; auto|elim K; auto with zarith].
assert (K:Fbounded b p');[elim B1; auto|elim K; auto with zarith].
rewrite Fplus_correct; auto.
assert (Closest (plusExp t b) radix (FtoR radix yy - FtoR radix hy) ty).
rewrite X1; rewrite <- Fminus_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fminus; simpl; apply Zmin_Zle.
assert (K:Fbounded b y);[elim Cy; auto|elim K; auto with zarith].
assert (K:Fbounded b hy);[elim B3; auto|elim K; auto with zarith].
rewrite Fminus_correct; auto.
generalize VeltkampU; intros V.
elim V with radix b s t x p q hx tx; auto.
2: unfold s; apply SLe; auto.
2: unfold s; apply SGe; auto.
2: left; auto.
intros M1 T; elim T; intros M2 T'; elim T'; intros T1 T2; clear T T'.
elim T1; intros hx' T1'; elim T1'; intros M3 T; elim T; intros M4 T'; clear T1 T1' T.
lapply T'; auto; intros M5; clear T'.
elim T2; intros tx' T1'; elim T1'; intros M6 T; elim T; intros M7 M8; clear T2 T1' T V.
elim Veltkamp_tail with radix b s t y p' q' hy ty; auto.
2: unfold s; apply SLe; auto.
2: unfold s; apply SGe; auto.
2: elim Cy; auto.
intros ty' T1'; elim T1'; intros N5 T; elim T; intros N7 T'; elim T'; intros N8 N9; clear T1' T T'.
rewrite FcanonicFnormalizeEq in N9; auto with zarith;[idtac|right; auto].
assert (Fexp y <= Fexp hy)%Z.
elim Cy; intros T1 T2; elim T2; intros T3 T4; rewrite T3.
elim B3; intros G1 G2; elim G1; auto.
apply DekkerN with (plusExp t b) t p q hx tx p' q' hy ty x1y1 x1y2 x2y1 x2y2 t1 t2 t3; auto.
rewrite <- M3.
rewrite <- Fmult_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fmult; simpl; auto with zarith.
rewrite Fmult_correct; auto with real; rewrite M3; auto.
rewrite <- M3; rewrite <- N5.
rewrite <- Fmult_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fmult; simpl; auto with zarith.
rewrite Fmult_correct; auto with real; rewrite M3; rewrite N5; auto.
rewrite <- M6.
rewrite <- Fmult_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fmult; simpl; auto with zarith.
rewrite Fmult_correct; auto with real; rewrite M6; auto.
rewrite <- M6; rewrite <- N5.
rewrite <- Fmult_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fmult; simpl; auto with zarith.
rewrite Fmult_correct; auto with real; rewrite M6; rewrite N5; auto.
rewrite X1.
rewrite <- Fmult_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
rewrite Fmult_correct; auto with real.
rewrite <- Fminus_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fminus; simpl; apply Zmin_Zle.
assert (K:Fbounded b r);[elim D1; auto|elim K; auto with zarith].
assert (K:Fbounded b x1y1);[elim C1; auto|elim K; auto with zarith].
rewrite Fminus_correct; auto.
rewrite <- Fminus_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fminus; simpl; apply Zmin_Zle.
assert (K:Fbounded b t1);[elim D2; auto|elim K; auto with zarith].
assert (K:Fbounded b x1y2);[elim C2; auto|elim K; auto with zarith].
rewrite Fminus_correct; auto.
rewrite <- Fminus_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fminus; simpl; apply Zmin_Zle.
assert (K:Fbounded b t2);[elim D3; auto|elim K; auto with zarith].
assert (K:Fbounded b x2y1);[elim C3; auto|elim K; auto with zarith].
rewrite Fminus_correct; auto.
rewrite <- Fminus_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fminus; simpl; apply Zmin_Zle.
assert (K:Fbounded b t3);[elim D4; auto|elim K; auto with zarith].
assert (K:Fbounded b x2y2);[elim C4; auto|elim K; auto with zarith].
rewrite Fminus_correct; auto.
Qed.

End AlgoS1.

Section AlgoS2.

Variable radix : Z.
Variable b : Fbound.
Variables t:nat.

Let FtoRradix := FtoR radix.
Coercion FtoRradix : float >-> R.
Hypothesis radixMoreThanOne : (1 < radix)%Z.

Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne).
Hint Resolve radixMoreThanZERO: zarith.

Hypothesis pGivesBound: Zpos (vNum b)=(Zpower_nat radix t).
Hypotheses pGe: (4 <= t).


Variables x y p q hx tx p' q' hy ty x1y1 x1y2 x2y1 x2y2 r t1 t2 t3 t4:float.


Hypothesis Cx: (Fsubnormal radix b x).
Hypothesis Cy: (Fnormal radix b y).

Hypothesis Expoxy: (-dExp b <= Fexp x+Fexp y)%Z.

Let s:= t- div2 t.

Hypothesis A1: (Closest b radix (x*((powerRZ radix s)+1))%R p).
Hypothesis A2: (Closest b radix (x-p)%R  q).
Hypothesis A3: (Closest b radix (q+p)%R hx).
Hypothesis A4: (Closest b radix (x-hx)%R tx).

Hypothesis B1: (Closest b radix (y*((powerRZ radix s)+1))%R p').
Hypothesis B2: (Closest b radix (y-p')%R  q').
Hypothesis B3: (Closest b radix (q'+p')%R hy).
Hypothesis B4: (Closest b radix (y-hy)%R ty).


Hypothesis C1: (Closest b radix (hx*hy)%R  x1y1).
Hypothesis C2: (Closest b radix (hx*ty)%R  x1y2).
Hypothesis C3: (Closest b radix (tx*hy)%R  x2y1).
Hypothesis C4: (Closest b radix (tx*ty)%R  x2y2).

Hypothesis D1: (Closest b radix (x*y)%R  r).
Hypothesis D2: (Closest b radix (r-x1y1)%R  t1).
Hypothesis D3: (Closest b radix (t1-x1y2)%R  t2).
Hypothesis D4: (Closest b radix (t2-x2y1)%R  t3).
Hypothesis D5: (Closest b radix (t3-x2y2)%R  t4).




Theorem DekkerS2: (radix=2)%Z \/ (even t) ->  (x*y=r-t4)%R.
intros H; unfold FtoRradix.
case (Req_dec 0%R x); intros Ny.
cut (FtoRradix r=0)%R;[intros Z1|idtac].
cut (FtoRradix t4=0)%R;[intros Z2|idtac].
fold FtoRradix; rewrite Z1; rewrite Z2; rewrite <- Ny; ring.
cut (FtoRradix hx=0)%R;[intros Z3|idtac].
cut (FtoRradix tx=0)%R;[intros Z4|idtac].
unfold FtoRradix; apply ClosestZero with b t (t3-x2y2)%R; auto with zarith.
cut (FtoRradix t3=0)%R;[intros Z5|idtac].
cut (FtoRradix x2y2=0)%R;[intros Z6|idtac].
rewrite Z5; rewrite Z6; ring.
unfold FtoRradix; apply ClosestZero with b t (tx*ty)%R; auto with zarith.
rewrite Z4; ring.
unfold FtoRradix; apply ClosestZero with b t (t2-x2y1)%R; auto with zarith.
cut (FtoRradix t2=0)%R;[intros Z5|idtac].
cut (FtoRradix x2y1=0)%R;[intros Z6|idtac].
rewrite Z5; rewrite Z6; ring.
unfold FtoRradix; apply ClosestZero with b t (tx*hy)%R; auto with zarith.
rewrite Z4; ring.
unfold FtoRradix; apply ClosestZero with b t (t1-x1y2)%R; auto with zarith.
cut (FtoRradix t1=0)%R;[intros Z5|idtac].
cut (FtoRradix x1y2=0)%R;[intros Z6|idtac].
rewrite Z5; rewrite Z6; ring.
unfold FtoRradix; apply ClosestZero with b t (hx*ty)%R; auto with zarith.
rewrite Z3; ring.
unfold FtoRradix; apply ClosestZero with b t (r-x1y1)%R; auto with zarith.
cut (FtoRradix x1y1=0)%R;[intros Z6|idtac].
rewrite Z1; rewrite Z6; ring.
unfold FtoRradix; apply ClosestZero with b t (hx*hy)%R; auto with zarith.
rewrite Z3; ring.
elim VeltkampU with radix b s t x p q hx tx; auto.
intros T1 T; elim T; intros H' T'; clear T1 T T'.
fold FtoRradix in H'; rewrite Z3 in H'; rewrite <- Ny in H'; auto with real.
apply trans_eq with (0+tx)%R; auto with real.
unfold s; apply SLe; auto.
unfold s; apply SGe; auto.
right; auto.
elim Veltkamp with radix b s t x p q hx; auto.
intros T1 T; elim T; intros hy' T'; elim T'; intros G1 T''; elim T''; intros ; clear T1 T T' T''.
unfold FtoRradix; rewrite <- G1.
 apply ClosestZero with (Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (t - s)))))
            (dExp b)) (t-s) (FtoR radix x)%R; auto with zarith.
apply p'GivesBound; auto with zarith.
assert  (s <= t - 2)%Z; auto with zarith.
assert  (s <= t - 2)%nat; auto with zarith.
unfold s; apply SGe; auto.
unfold s; apply SLe; auto.
unfold s; apply SGe; auto.
elim Cx; auto.
unfold FtoRradix; apply ClosestZero with b t (x*y)%R; auto with zarith.
rewrite <- Ny; ring.
elim bimplybplusNorm with radix b s t x; auto.
2: unfold s; apply SLe; auto.
2: unfold s; apply SGe; auto.
2: elim Cx; auto.
intros xx T; elim T; intros X1 X2; clear T.
rewrite <- X1.
assert (Fnormal radix (plusExp t b) y).
elim Cy; intros F1 F2; elim F1; intros.
split;[split|idtac]; unfold plusExp; simpl; auto with zarith.
cut (forall (x:N) (y:positive), (x+(Zpos y)=(x +Npos y)%N)%Z).
intros T; simpl; rewrite <- T; auto with zarith.
apply Zle_trans with (-(dExp b))%Z; auto with zarith.
apply Zle_trans with (-(dExp b) + Zneg  (P_of_succ_nat (pred (pred t))))%Z; auto with zarith.
apply Zeq_le; ring_simplify; auto with zarith.
apply Zle_trans with (-(dExp b)+0)%Z; auto with zarith.
intros;unfold Nplus.
case x0; auto with zarith.
assert (- dExp (plusExp t b) <= Fexp xx + Fexp y)%Z.
elim X2; intros F1 F2; elim F1; intros.
assert (0 <= Fexp y)%Z; auto with zarith.
apply Zplus_le_reg_l with (Fexp x).
apply Zle_trans with (2:=Expoxy).
elim Cx; intros F1' F2'; elim F2'; auto with zarith.
assert (Closest (plusExp t b) radix
   (FtoR radix y * (powerRZ radix (t - div2 t)%nat + 1)) p').
cut (FtoR radix y * (powerRZ radix (t - div2 t)%nat + 1) =
    (FtoRradix (Fmult y (Float (Zpower_nat radix (t - div2 t)%nat + 1) 0))))%R.
intros K'; rewrite K'.
unfold FtoRradix; apply Closestbbplus with 2 t; auto with zarith.
unfold Fmult; simpl.
assert (K:Fbounded b y);[elim Cy; auto|elim K; auto with zarith].
fold FtoRradix; rewrite <- K'; auto with real.
unfold FtoRradix; rewrite Fmult_correct; auto.
unfold FtoR; simpl; rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ; simpl; ring.
assert (Closest (plusExp t b) radix (FtoR radix y - FtoR radix p') q').
rewrite <- Fminus_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fminus; simpl; apply Zmin_Zle.
assert (K:Fbounded b y);[elim Cy; auto|elim K; auto with zarith].
assert (K:Fbounded b p');[elim B1; auto|elim K; auto with zarith].
rewrite Fminus_correct; auto.
assert (Closest (plusExp t b) radix (FtoR radix q' + FtoR radix p') hy).
rewrite <- Fplus_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fplus; simpl; apply Zmin_Zle.
assert (K:Fbounded b q');[elim B2; auto|elim K; auto with zarith].
assert (K:Fbounded b p');[elim B1; auto|elim K; auto with zarith].
rewrite Fplus_correct; auto.
assert (Closest (plusExp t b) radix (FtoR radix y - FtoR radix hy) ty).
rewrite <- Fminus_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fminus; simpl; apply Zmin_Zle.
assert (K:Fbounded b y);[elim Cy; auto|elim K; auto with zarith].
assert (K:Fbounded b hy);[elim B3; auto|elim K; auto with zarith].
rewrite Fminus_correct; auto.
assert (Closest (plusExp t b) radix (FtoR radix xx * (powerRZ radix (t - div2 t)%nat + 1)) p).
rewrite X1; cut (FtoR radix x * (powerRZ radix (t - div2 t)%nat + 1) =
    (FtoRradix (Fmult x (Float (Zpower_nat radix (t - div2 t)%nat + 1) 0))))%R.
intros K'; rewrite K'.
unfold FtoRradix; apply Closestbbplus with 2 t; auto with zarith.
unfold Fmult; simpl.
assert (K:Fbounded b x);[elim Cx; auto|elim K; auto with zarith].
fold FtoRradix; rewrite <- K'; auto with real.
unfold FtoRradix; rewrite Fmult_correct; auto.
unfold FtoR; simpl; rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ; simpl; ring.
assert (Closest (plusExp t b) radix (FtoR radix xx - FtoR radix p) q).
rewrite X1; rewrite <- Fminus_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fminus; simpl; apply Zmin_Zle.
assert (K:Fbounded b x);[elim Cx; auto|elim K; auto with zarith].
assert (K:Fbounded b p);[elim A1; auto|elim K; auto with zarith].
rewrite Fminus_correct; auto.
assert (Closest (plusExp t b) radix (FtoR radix q + FtoR radix p) hx).
rewrite <- Fplus_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fplus; simpl; apply Zmin_Zle.
assert (K:Fbounded b q);[elim A2; auto|elim K; auto with zarith].
assert (K:Fbounded b p);[elim A1; auto|elim K; auto with zarith].
rewrite Fplus_correct; auto.
assert (Closest (plusExp t b) radix (FtoR radix xx - FtoR radix hx) tx).
rewrite X1; rewrite <- Fminus_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fminus; simpl; apply Zmin_Zle.
assert (K:Fbounded b x);[elim Cx; auto|elim K; auto with zarith].
assert (K:Fbounded b hx);[elim A3; auto|elim K; auto with zarith].
rewrite Fminus_correct; auto.
generalize VeltkampU; intros V.
elim V with radix b s t y p' q' hy ty; auto.
2: unfold s; apply SLe; auto.
2: unfold s; apply SGe; auto.
2: left; auto.
intros M1 T; elim T; intros M2 T'; elim T'; intros T1 T2; clear T T'.
elim T1; intros hy' T1'; elim T1'; intros M3 T; elim T; intros M4 T'; clear T1 T1' T.
lapply T'; auto; intros M5; clear T'.
elim T2; intros ty' T1'; elim T1'; intros M6 T; elim T; intros M7 M8; clear T2 T1' T V.
elim Veltkamp_tail with radix b s t x p q hx tx; auto.
2: unfold s; apply SLe; auto.
2: unfold s; apply SGe; auto.
2: elim Cx; auto.
intros tx' T1'; elim T1'; intros N5 T; elim T; intros N7 T'; elim T'; intros N8 N9; clear T1' T T'.
rewrite FcanonicFnormalizeEq in N9; auto with zarith;[idtac|right; auto].
assert (Fexp x <= Fexp hx)%Z.
elim Cx; intros T1 T2; elim T2; intros T3 T4; rewrite T3.
elim A3; intros G1 G2; elim G1; auto.
apply DekkerN with (plusExp t b) t p q hx tx p' q' hy ty x1y1 x1y2 x2y1 x2y2 t1 t2 t3; auto.
rewrite <- M3.
rewrite <- Fmult_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fmult; simpl; auto with zarith.
rewrite Fmult_correct; auto with real; rewrite M3; auto.
rewrite <- M6.
rewrite <- Fmult_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fmult; simpl; auto with zarith.
rewrite Fmult_correct; auto with real; rewrite M6; auto.
rewrite <- M3; rewrite <- N5.
rewrite <- Fmult_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fmult; simpl; auto with zarith.
rewrite Fmult_correct; auto with real; rewrite M3; rewrite N5; auto.
rewrite <- M6; rewrite <- N5.
rewrite <- Fmult_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fmult; simpl; auto with zarith.
rewrite Fmult_correct; auto with real; rewrite M6; rewrite N5; auto.
rewrite X1.
rewrite <- Fmult_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
rewrite Fmult_correct; auto with real.
rewrite <- Fminus_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fminus; simpl; apply Zmin_Zle.
assert (K:Fbounded b r);[elim D1; auto|elim K; auto with zarith].
assert (K:Fbounded b x1y1);[elim C1; auto|elim K; auto with zarith].
rewrite Fminus_correct; auto.
rewrite <- Fminus_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fminus; simpl; apply Zmin_Zle.
assert (K:Fbounded b t1);[elim D2; auto|elim K; auto with zarith].
assert (K:Fbounded b x1y2);[elim C2; auto|elim K; auto with zarith].
rewrite Fminus_correct; auto.
rewrite <- Fminus_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fminus; simpl; apply Zmin_Zle.
assert (K:Fbounded b t2);[elim D3; auto|elim K; auto with zarith].
assert (K:Fbounded b x2y1);[elim C3; auto|elim K; auto with zarith].
rewrite Fminus_correct; auto.
rewrite <- Fminus_correct; auto.
apply Closestbbplus with 2 t; auto with zarith.
unfold Fminus; simpl; apply Zmin_Zle.
assert (K:Fbounded b t3);[elim D4; auto|elim K; auto with zarith].
assert (K:Fbounded b x2y2);[elim C4; auto|elim K; auto with zarith].
rewrite Fminus_correct; auto.
Qed.

End AlgoS2.


Section Algo1.

Variable radix : Z.
Variable b : Fbound.
Variables t:nat.

Let FtoRradix := FtoR radix.
Coercion FtoRradix : float >-> R.
Hypothesis radixMoreThanOne : (1 < radix)%Z.

Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne).
Hint Resolve radixMoreThanZERO: zarith.

Hypothesis pGivesBound: Zpos (vNum b)=(Zpower_nat radix t).
Hypotheses pGe: (4 <= t).


Variables x y p q hx tx p' q' hy ty x1y1 x1y2 x2y1 x2y2 r t1 t2 t3 t4:float.


Hypothesis Cx: (Fcanonic radix b x).
Hypothesis Cy: (Fcanonic radix b y).

Hypothesis Expoxy: (-dExp b <= Fexp x+Fexp y)%Z.

Let s:= t- div2 t.

Hypothesis A1: (Closest b radix (x*((powerRZ radix s)+1))%R p).
Hypothesis A2: (Closest b radix (x-p)%R  q).
Hypothesis A3: (Closest b radix (q+p)%R hx).
Hypothesis A4: (Closest b radix (x-hx)%R tx).

Hypothesis B1: (Closest b radix (y*((powerRZ radix s)+1))%R p').
Hypothesis B2: (Closest b radix (y-p')%R  q').
Hypothesis B3: (Closest b radix (q'+p')%R hy).
Hypothesis B4: (Closest b radix (y-hy)%R ty).


Hypothesis C1: (Closest b radix (hx*hy)%R  x1y1).
Hypothesis C2: (Closest b radix (hx*ty)%R  x1y2).
Hypothesis C3: (Closest b radix (tx*hy)%R  x2y1).
Hypothesis C4: (Closest b radix (tx*ty)%R  x2y2).

Hypothesis D1: (Closest b radix (x*y)%R  r).
Hypothesis D2: (Closest b radix (r-x1y1)%R  t1).
Hypothesis D3: (Closest b radix (t1-x1y2)%R  t2).
Hypothesis D4: (Closest b radix (t2-x2y1)%R  t3).
Hypothesis D5: (Closest b radix (t3-x2y2)%R  t4).

Hypothesis dExpPos: ~(Z_of_N(dExp b)=0)%Z.


Theorem Dekker1: (radix=2)%Z \/ (even t) ->  (x*y=r-t4)%R.
case Cy; case Cx; intros.
unfold FtoRradix; apply DekkerN  with b t p q hx tx p' q' hy ty x1y1 x1y2 x2y1 x2y2 t1 t2 t3; auto.
unfold FtoRradix; apply DekkerS2 with  b t p q hx tx p' q' hy ty x1y1 x1y2 x2y1 x2y2 t1 t2 t3; auto.
unfold FtoRradix; apply DekkerS1 with  b t p q hx tx p' q' hy ty x1y1 x1y2 x2y1 x2y2 t1 t2 t3; auto.
absurd (- dExp b <= Fexp x + Fexp y)%Z; auto with zarith.
apply Zlt_not_le.
elim H; intros T1 T2; elim T2; intros G1 T; clear T1 T2 T.
elim H0; intros T1 T2; elim T2; intros G2 T; clear T1 T2 T.
rewrite G1; rewrite G2; auto with zarith.
cut (0 < dExp b)%Z; auto with zarith.
generalize dExpPos; unfold Z_of_N; case (dExp b); auto with zarith.
Qed.


End Algo1.
Section Algo2.

Variable radix : Z.
Variable b : Fbound.
Variables t:nat.

Let FtoRradix := FtoR radix.
Coercion FtoRradix : float >-> R.
Hypothesis radixMoreThanOne : (1 < radix)%Z.

Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne).
Hint Resolve radixMoreThanZERO: zarith.

Hypothesis pGivesBound: Zpos (vNum b)=(Zpower_nat radix t).
Hypotheses pGe: (4 <= t).
Let s:= t- div2 t.

Variables x y:float.

Let b' := Bound (vNum b) (Nplus (Ndouble (dExp b)) (Ndouble  (Npos (P_of_succ_nat t)))).


Theorem Veltkampb': forall (f pf qf hf tf:float),
  (dExp b < dExp b')%Z ->
  (Fbounded b f) ->
  Closest b radix (f * (powerRZ radix s + 1)) pf -> Closest b radix (f - pf) qf ->
  Closest b radix (qf + pf) hf -> Closest b radix (f - hf) tf ->
  Closest b' radix (f * (powerRZ radix s + 1)) pf /\ 
  Closest b' radix (f - pf) qf /\ Closest b' radix (qf + pf) hf /\
  Closest b' radix (f - hf) tf.
intros.
split.
assert (f*(powerRZ radix s + 1)= (FtoRradix (Fplus radix (Fmult f (Float 1 s)) f)))%R.
unfold FtoRradix; rewrite Fplus_correct; auto; rewrite Fmult_correct; auto.
unfold FtoR; simpl; ring.
rewrite H5; unfold FtoRradix; apply Closestbbext with b t; auto with zarith.
simpl; rewrite Zmin_le2; auto with zarith float.
fold FtoRradix; rewrite <- H5; auto.
split.
unfold FtoRradix; rewrite <- Fminus_correct; auto.
apply Closestbbext with b t; auto with zarith.
simpl; apply Zmin_Zle; auto with zarith float.
elim H1; auto with zarith float.
rewrite Fminus_correct; auto.
split.
unfold FtoRradix; rewrite <- Fplus_correct; auto.
apply Closestbbext with b t; auto with zarith.
simpl; apply Zmin_Zle; elim H2; elim H1; auto with zarith float.
rewrite Fplus_correct; auto.
unfold FtoRradix; rewrite <- Fminus_correct; auto.
apply Closestbbext with b t; auto with zarith.
simpl; apply Zmin_Zle; elim H3; auto with zarith float.
rewrite Fminus_correct; auto.
Qed.




Variables p q hx tx p' q' hy ty x1y1 x1y2 x2y1 x2y2 r t1 t2 t3 t4:float.


Hypothesis Cx: (Fcanonic radix b x).
Hypothesis Cy: (Fcanonic radix b y).

Hypothesis Expoxy: (Fexp x+Fexp y < -dExp b)%Z.



Hypothesis A1: (Closest b radix (x*((powerRZ radix s)+1))%R p).
Hypothesis A2: (Closest b radix (x-p)%R  q).
Hypothesis A3: (Closest b radix (q+p)%R hx).
Hypothesis A4: (Closest b radix (x-hx)%R tx).

Hypothesis B1: (Closest b radix (y*((powerRZ radix s)+1))%R p').
Hypothesis B2: (Closest b radix (y-p')%R  q').
Hypothesis B3: (Closest b radix (q'+p')%R hy).
Hypothesis B4: (Closest b radix (y-hy)%R ty).


Hypothesis C1: (Closest b radix (hx*hy)%R  x1y1).
Hypothesis C2: (Closest b radix (hx*ty)%R  x1y2).
Hypothesis C3: (Closest b radix (tx*hy)%R  x2y1).
Hypothesis C4: (Closest b radix (tx*ty)%R  x2y2).

Hypothesis D1: (Closest b radix (x*y)%R  r).
Hypothesis D2: (Closest b radix (r-x1y1)%R  t1).
Hypothesis D3: (Closest b radix (t1-x1y2)%R  t2).
Hypothesis D4: (Closest b radix (t2-x2y1)%R  t3).
Hypothesis D5: (Closest b radix (t3-x2y2)%R  t4).


Theorem dExpPrim: (dExp b < dExp b')%Z.
unfold b'; simpl; auto with zarith.
cut (forall (x:N) (y:positive), (x+(Zpos y)=(x +Npos y)%N)%Z).
intros T; simpl; rewrite <- T; auto with zarith.
apply Zle_lt_trans with (Ndouble (dExp b)); auto with zarith.
unfold Ndouble; case (dExp b); auto with zarith.
intros; unfold Z_of_N; auto with zarith.
apply Zle_trans with (2*(Zpos p0))%Z; auto with zarith.
apply Zle_trans with (1*(Zpos p0))%Z; auto with zarith.
apply Zle_lt_trans with (Ndouble (dExp b)+0)%Z; auto with zarith.
intros;unfold Nplus.
case x0; auto with zarith.
Qed.

Theorem dExpPrimEq: (Z_of_N (Ndouble (dExp b) + Npos (xO (P_of_succ_nat t)))
   =2*(dExp b)+2*t+2)%Z.
cut (forall (x:N) (y:positive), (x+(Zpos y)=(x +Npos y)%N)%Z).
intros T; rewrite <- T; auto with zarith.
2:intros;unfold Nplus.
2:case x0; auto with zarith.
replace  (Zpos (xO (P_of_succ_nat t))) with (2*t+2)%Z.
unfold Ndouble; case (dExp b); auto with zarith.
apply trans_eq with (2*(Zpos (P_of_succ_nat t)))%Z; auto with zarith.
replace  (Zpos (P_of_succ_nat t)) with (t+1)%Z; auto with zarith.
apply trans_eq with
    (Z_of_nat
       (nat_of_P
          (P_of_succ_nat t))); auto with zarith.
rewrite nat_of_P_o_P_of_succ_nat_eq_succ; auto with zarith arith.
replace (S t) with (t+1)%nat; auto with zarith arith; rewrite inj_plus; auto with zarith.
unfold Z_of_nat; rewrite nat_of_P_o_P_of_succ_nat_eq_succ;
 auto with zarith.
Qed.


Theorem NormalbPrim: forall (f:float), Fcanonic radix b f -> (FtoRradix f <>0) ->
   (exists f':float, (Fnormal radix b' f') /\ FtoRradix f'=f /\ (-t-dExp b <= Fexp f')%Z).
intros.
exists (Fnormalize radix b' t f).
assert (powerRZ radix (-(dExp b)) <=  (Fabs (Fnormalize radix b' t f)))%R.
unfold FtoRradix; rewrite Fabs_correct; auto.
rewrite FnormalizeCorrect; auto with zarith; rewrite <- Fabs_correct; auto.
unfold FtoRradix, FtoR, Fabs; simpl.
apply Rle_trans with ((IZR 1)*powerRZ radix (- dExp b))%R;[right; simpl; ring|idtac].
apply Rmult_le_compat; auto with real zarith float.
case (Zle_lt_or_eq 0 (Zabs (Fnum f))); auto with zarith real.
intros; absurd (Rabs f =0)%R.
apply Rabs_no_R0; auto.
unfold FtoRradix; rewrite <- Fabs_correct; auto; unfold FtoR, Fabs; simpl; rewrite <- H1; simpl; ring.
assert (Fbounded b f);[apply FcanonicBound with radix; auto with zarith|idtac].
elim H1; intros; apply Rle_powerRZ; auto with zarith real.
assert (Fcanonic radix b'  (Fnormalize radix b' t f)).
apply FnormalizeCanonic; auto with zarith.
assert (Fbounded b f);[apply FcanonicBound with radix; auto with zarith|idtac].
elim H2; generalize dExpPrim; intros; split; auto with zarith.
split.
case H2; auto.
intros; absurd (Fabs f < (firstNormalPos radix b' t))%R.
apply Rle_not_lt.
apply Rle_trans with (powerRZ radix (-(dExp b))).
unfold firstNormalPos, FtoRradix, FtoR; simpl.
unfold nNormMin; rewrite Zpower_nat_Z_powerRZ; rewrite <- powerRZ_add; auto with real zarith.
apply Rle_powerRZ; auto with real zarith.
rewrite dExpPrimEq.
rewrite inj_pred; auto with zarith; unfold Zpred.
ring_simplify (t + -1 + - (2 * dExp b + 2 * t + 2))%Z; auto with zarith.
assert (0 <= dExp b)%Z; auto with zarith.
case (dExp b); auto with zarith.
apply Rle_trans with (1:=H1); unfold FtoRradix; repeat rewrite Fabs_correct; auto.
rewrite FnormalizeCorrect; auto with zarith real.
apply Rle_lt_trans with (Fabs (Fnormalize radix b' t f)).
unfold FtoRradix; repeat rewrite Fabs_correct; auto.
rewrite FnormalizeCorrect; auto with zarith real.
unfold FtoRradix; apply FsubnormalLtFirstNormalPos; auto with zarith.
apply FsubnormFabs; auto.
rewrite Fabs_correct; auto with real zarith.
split;[unfold FtoRradix; rewrite FnormalizeCorrect; auto with zarith|idtac].
apply Zle_trans with (Fexp (Float (nNormMin radix t) (-t-dExp b))); auto with zarith.
apply Fcanonic_Rle_Zle with radix b' t; auto with zarith.
apply FcanonicNnormMin; auto with zarith.
unfold b'; simpl; rewrite dExpPrimEq; auto with zarith.
cut (0 <= dExp b)%Z; auto with zarith; case (dExp b); auto with zarith.
rewrite Rabs_right.
rewrite <- Fabs_correct; auto; fold FtoRradix; apply Rle_trans with (2:=H1).
unfold FtoRradix, FtoR, nNormMin; simpl; rewrite Zpower_nat_Z_powerRZ.
rewrite <- powerRZ_add; auto with real zarith; apply Rle_powerRZ; auto with zarith real.
rewrite inj_pred; auto with zarith; unfold Zpred; auto with zarith.
apply Rle_ge; apply LeFnumZERO; auto with zarith.
unfold nNormMin; simpl; auto with zarith.
Qed.

Theorem Dekker2_aux: 
  (FtoRradix x <>0) -> (FtoRradix y <>0) -> 
  (radix=2)%Z \/ (even t) ->  (Rabs (x*y-(r-t4)) <= (7/2)*powerRZ radix (-(dExp b)))%R.
intros P1 P2.
intros; generalize dExpPrim; intros.
elim (NormalbPrim x); auto.
intros x' T; elim T; intros Nx' T'; elim T'; intros Hx' Ex'; clear T T'.
elim (NormalbPrim y); auto.
intros y' T; elim T; intros Ny' T'; elim T'; intros Hy' Ey'; clear T T'.
assert (MM:(-(dExp b') <= Fexp x'+Fexp y')%Z).
unfold b'; simpl; rewrite dExpPrimEq; auto with zarith float.
generalize Underf_Err2; intros T.
elim T with b radix t b' (x*y)%R r; auto with zarith; clear T.
intros r' T; elim T; intros H1 H2; clear T.
elim Veltkampb' with x p q hx tx; auto.
2: apply FcanonicBound with radix; auto.
intros H4 T; elim T; intros H5 T'; elim T'; intros H6 H7; clear T T'.
elim Veltkampb' with y p' q' hy ty; auto.
2: apply FcanonicBound with radix; auto.
intros H8 T; elim T; intros H9 T'; elim T'; intros H10 H11; clear T T'.
assert (TotalP (Closest b' radix)).
apply ClosestTotal with t; auto with zarith.
unfold TotalP in H3.
elim (H3 (hx * hy)%R); intros x1y1' H12.
elim (H3 (hx * ty)%R); intros x1y2' H13.
elim (H3 (tx * hy)%R); intros x2y1' H14.
elim (H3 (tx * ty)%R); intros x2y2' H15.
elim (H3 (r' - x1y1')%R); intros t1'  H16.
elim (H3 (t1' - x1y2')%R); intros t2' H17.
elim (H3 (t2' - x2y1')%R); intros t3' H18.
elim (H3 (t3' - x2y2')%R); intros t4' H19.
rewrite <- Hx'; rewrite <- Hy'; unfold FtoRradix.
rewrite DekkerN with radix b' t x' y' p q hx tx p' q' hy ty x1y1' x1y2' x2y1' x2y2' r' t1' t2' t3' t4';
  auto with zarith.
2: fold FtoRradix; rewrite Hx'; auto.
2: fold FtoRradix; rewrite Hx'; auto.
2: fold FtoRradix; rewrite Hx'; auto.
2: fold FtoRradix; rewrite Hy'; auto.
2: fold FtoRradix; rewrite Hy'; auto.
2: fold FtoRradix; rewrite Hy'; auto.
2: fold FtoRradix; rewrite Hx'; rewrite Hy'; auto.
fold FtoRradix.
replace (r' - t4' - (r - t4))%R with (-(r-r')+((t4-t4')))%R;[idtac|ring].
apply Rle_trans with (1:=Rabs_triang (-(r-r'))%R ((t4-t4'))%R).
apply Rle_trans with ((3/4)*powerRZ radix (- dExp b) +(11/4)*powerRZ radix (- dExp b))%R;
  [idtac|right; field; apply prod_neq_R0; auto with real; apply prod_neq_R0; auto with real].
apply Rplus_le_compat.
rewrite Rabs_Ropp; auto with real.
elim H1; intros G1 G2; elim G2; intros G3 G4; elim G4; intros G5 G6.
unfold FtoRradix; apply Rle_trans with (1:=G5); right; ring. 
cut (2 <= s);[intros Sle|unfold s; apply SLe; auto].
cut (s <= t-2);[intros Sge|unfold s; apply SGe; auto].
cut (s+s <= t+1)%Z;[intros s2le|unfold s; apply s2Le; auto].
cut (t <=s+s)%Z;[intros s2ge|unfold s; apply s2Ge; auto].
generalize VeltkampU; intros V.
elim V with radix b' s t x' p q hx tx; auto.
2: left; auto.
2: fold FtoRradix; rewrite Hx'; auto.
2: fold FtoRradix; rewrite Hx'; auto.
2: fold FtoRradix; rewrite Hx'; auto.
intros MX1 T; elim T; intros MX2 T'; clear T; elim T'; intros T1 T2; clear T'.
elim T1; intros Chx' T1'; elim T1'; intros MX3 T1''; elim T1''; intros MX4 MX5; clear T1 T1' T1''.
lapply MX5; auto; clear MX5; intros MX5.
elim T2; intros Ctx' T1'; elim T1'; intros MX6 T1''; elim T1''; intros MX7 MX8; clear T2 T1' T1''.
elim V with radix b' s t y' p' q' hy ty; auto.
2: left; auto.
2: fold FtoRradix; rewrite Hy'; auto.
2: fold FtoRradix; rewrite Hy'; auto.
2: fold FtoRradix; rewrite Hy'; auto.
intros MY1 T; elim T; intros MY2 T'; clear T; elim T'; intros T1 T2; clear T'.
elim T1; intros Chy' T1'; elim T1'; intros MY3 T1''; elim T1''; intros MY4 MY5; clear T1 T1' T1''.
lapply MY5; auto; clear MY5; intros MY5.
elim T2; intros Cty' T1'; elim T1'; intros MY6 T1''; elim T1''; intros MY7 MY8; clear T2 T1' T1'' V.
generalize Boundedt1; intros V.
elim V with radix b' s t x' Chx' Ctx' y' Chy' Cty' r' (Fminus radix (Fmult x' y') r'); 
   auto with zarith real; clear V.
2: fold FtoRradix; rewrite Hy';rewrite Hx'; auto.
2:rewrite Fminus_correct; auto with zarith; rewrite Fmult_correct; auto with zarith; ring.
2:rewrite MX6; rewrite MX3; exact MX2.
2:rewrite MY6; rewrite MY3; exact MY2.
2:rewrite MX6; replace (FtoR radix tx) with (FtoR radix x'-FtoR radix hx)%R; auto with real.
2:rewrite MX2; ring.
2:rewrite MY6; replace (FtoR radix ty) with (FtoR radix y'-FtoR radix hy)%R; auto with real.
2:rewrite MY2; ring.
intros Ct1' T; elim T; intros M11 T'; elim T'; intros M12 M13; clear T T'.
generalize Boundedt2; intros V.
elim V with radix b' s t x' Chx' Ctx' y' Chy' Cty' r' (Fminus radix (Fmult x' y') r'); 
   auto with zarith real; clear V.
2: fold FtoRradix; rewrite Hy';rewrite Hx'; auto.
2:rewrite Fminus_correct; auto with zarith; rewrite Fmult_correct; auto with zarith; ring.
2:rewrite MX6; rewrite MX3; exact MX2.
2:rewrite MY6; rewrite MY3; exact MY2.
2:rewrite MX6; replace (FtoR radix tx) with (FtoR radix x'-FtoR radix hx)%R; auto with real.
2:rewrite MX2; ring.
2:rewrite MY6; replace (FtoR radix ty) with (FtoR radix y'-FtoR radix hy)%R; auto with real.
2:rewrite MY2; ring.
intros Ct2' T; elim T; intros M21 T'; elim T'; intros M22 M23; clear T T'.
generalize Boundedt3; intros V.
elim V with radix b' s t x' Chx' Ctx' y' Chy' Cty' r' (Fminus radix (Fmult x' y') r'); 
    auto with zarith real; clear V.
2: fold FtoRradix; rewrite Hy';rewrite Hx'; auto.
2:rewrite Fminus_correct; auto with zarith; rewrite Fmult_correct; auto with zarith; ring.
2:rewrite MX6; rewrite MX3; exact MX2.
2:rewrite MY6; rewrite MY3; exact MY2.
2:rewrite MX6; replace (FtoR radix tx) with (FtoR radix x'-FtoR radix hx)%R; auto with real.
2:rewrite MX2; ring.
2:rewrite MY6; replace (FtoR radix ty) with (FtoR radix y'-FtoR radix hy)%R; auto with real.
2:rewrite MY2; ring.
intros Ct3' T; elim T; intros M31 T'; elim T'; intros M32 M33; clear T T'.
generalize Boundedt4_aux; intros V.
elim V with radix b' s t x' Chx' Ctx' y' Chy' Cty' r' ; auto with zarith real; clear V.
2: fold FtoRradix; rewrite Hy';rewrite Hx'; auto.
2:rewrite MX6; rewrite MX3; exact MX2.
2:rewrite MY6; rewrite MY3; exact MY2.
intros Ct4' T; elim T; intros M41 T'; elim T'; intros M42 M43; clear T T'.
elim Boundedx1y1_aux with radix b' s t x' Chx' y' Chy'; auto with zarith.
intros Cx1y1' T; elim T; intros O1 T'; elim T'; intros O2 O3 ; clear T T'.
elim Boundedx1y2_aux with radix b' s t x' Chx' y' Cty'; auto with zarith.
intros Cx1y2' T; elim T; intros O4 T'; elim T'; intros O5 O6; clear T T'.
elim Boundedx2y1_aux with radix b' s t x' Ctx' y' Chy'; auto with zarith.
intros Cx2y1' T; elim T; intros O7 T'; elim T'; intros O8 O9; clear T T'.
assert (tmp:forall (f:float) (i:nat), (i <= t) ->
       (Fbounded (Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (i)))))
             (dExp b')) f) -> (Fbounded b' f)).
intros f i J1 J2; elim J2; intros J3 J4; split; auto with zarith.
apply Zlt_le_trans with (1:=J3).
apply Zle_trans with (Zpower_nat radix i);[idtac|unfold b'; simpl; rewrite pGivesBound; auto with zarith].
simpl.
apply
 Zle_trans
  with
    (Z_of_nat
       (nat_of_P
          (P_of_succ_nat
             (pred (Zabs_nat (Zpower_nat radix (i))))))).
unfold Z_of_nat in |- *; rewrite nat_of_P_o_P_of_succ_nat_eq_succ;
 auto with zarith.
rewrite nat_of_P_o_P_of_succ_nat_eq_succ; auto with arith zarith.
rewrite <- S_pred with (Zabs_nat (Zpower_nat radix (i))) 0; auto with zarith.
rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith.
cut ( 0 < Zabs_nat (Zpower_nat radix (i)))%Z; auto with zarith.
simpl; rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith.
elim Boundedx2y2 with radix b' t x' y' p q Chx' Ctx' p' q' Chy' Cty'; auto with zarith.
2: fold FtoRradix; rewrite Hx'; auto.
2: fold FtoRradix; rewrite Hx'; auto.
2:apply ClosestCompatible with (1:=H6); auto.
2:apply tmp with (t-s); auto with zarith.
2:apply ClosestCompatible with (1:=H7); auto with real.
2: fold FtoRradix; rewrite Hx'; auto with real.
2:apply tmp with s; auto with zarith.
2: fold FtoRradix; rewrite Hy'; auto.
2: fold FtoRradix; rewrite Hy'; auto.
2:apply ClosestCompatible with (1:=H10); auto.
2:apply tmp with (t-s); auto with zarith.
2:fold FtoRradix; rewrite Hy'; apply ClosestCompatible with (1:=H11); auto with real.
2:apply tmp with s; auto with zarith.
intros Cx2y2' T; elim T; intros O10 T'; elim T'; intros O11 O12; clear T T' tmp.
assert (ZZ:RoundedModeP b' radix (Closest b' radix)).
apply ClosestRoundedModeP with t; auto with zarith.
assert (K1':FtoRradix x1y1'=Cx1y1').
unfold FtoRradix; apply sym_eq; apply RoundedModeProjectorIdemEq with b' t (Closest b' radix); auto with zarith.
rewrite O1; rewrite MY3; rewrite MX3; auto.
assert (K1:FtoRradix Ct1'=t1').
unfold FtoRradix; apply RoundedModeProjectorIdemEq with b' t (Closest b' radix); auto with zarith.
rewrite M11; replace  (FtoR radix Chx' * FtoR radix Chy')%R with (FtoRradix x1y1'); auto.
rewrite <- O1; auto.
assert (K2':FtoRradix x1y2'=Cx1y2').
unfold FtoRradix; apply sym_eq; apply RoundedModeProjectorIdemEq with b' t (Closest b' radix); auto with zarith.
rewrite O4; rewrite MY6; rewrite MX3; auto.
assert (K2:FtoRradix Ct2'=t2').
unfold FtoRradix; apply RoundedModeProjectorIdemEq with b' t (Closest b' radix); auto with zarith.
rewrite M21; rewrite <- M11; fold FtoRradix; rewrite K1.
replace  (Chx' * Cty')%R with (FtoRradix x1y2'); auto.
unfold FtoRradix; rewrite <- O4; auto.
assert (K3':FtoRradix x2y1'=Cx2y1').
unfold FtoRradix; apply sym_eq; apply RoundedModeProjectorIdemEq with b' t (Closest b' radix); auto with zarith.
rewrite O7; rewrite MY3; rewrite MX6; auto.
assert (K3:FtoRradix Ct3'=t3').
unfold FtoRradix; apply RoundedModeProjectorIdemEq with b' t (Closest b' radix); auto with zarith.
rewrite M31; rewrite <- M21; fold FtoRradix; rewrite K2.
replace  (Ctx' * Chy')%R with (FtoRradix x2y1'); auto.
unfold FtoRradix; rewrite <- O7; auto.
assert (K4':FtoRradix x2y2'=Cx2y2').
unfold FtoRradix; apply sym_eq; apply RoundedModeProjectorIdemEq with b' t (Closest b' radix); auto with zarith.
rewrite O10; rewrite MX6; rewrite MY6; auto.
assert (K4:FtoRradix Ct4'=t4').
unfold FtoRradix; apply RoundedModeProjectorIdemEq with b' t (Closest b' radix); auto with zarith.
rewrite M41; rewrite <- M31; fold FtoRradix; rewrite K3.
replace  (Ctx' * Cty')%R with (FtoRradix x2y2'); auto.
unfold FtoRradix; rewrite <- O10; auto.
rewrite <- K4.
cut (Underf_Err b radix b' t4 Ct4' (t3-x2y2)%R (11/4)).
unfold FtoRradix; intros G; elim G; intros G1 G2; elim G2; intros G3 G4; elim G4; auto with real.
replace (11/4)%R with (9/4+/2)%R;
   [idtac|field; apply prod_neq_R0; auto with real; apply prod_neq_R0; auto with real].
unfold FtoRradix; apply Underf_Err3_bis with t Ct3' Cx2y2' (t2-x2y1)%R (tx*ty)%R; auto with zarith.
replace (9/4)%R with (7/4+/2)%R;[idtac|
   field; apply prod_neq_R0; auto with real; apply prod_neq_R0; auto with real].
unfold FtoRradix; apply Underf_Err3_bis with t Ct2' Cx2y1' (t1-x1y2)%R (tx*hy)%R; auto with zarith.
replace (7/4)%R with (5/4+/2)%R;[idtac|
   field; apply prod_neq_R0; auto with real; apply prod_neq_R0; auto with real].
unfold FtoRradix; apply Underf_Err3_bis with t Ct1' Cx1y2' (r-x1y1)%R (hx*ty)%R; auto with zarith.
replace (5/4)%R with ((3/4)+/2)%R;[idtac|
   field; apply prod_neq_R0; auto with real; apply prod_neq_R0; auto with real].
unfold FtoRradix; apply Underf_Err3_bis with t r' Cx1y1' (x*y)%R (hx*hy)%R; auto with zarith.
cut (hx*hy=FtoRradix Cx1y1')%R.
intros P; rewrite P; unfold FtoRradix; apply Underf_Err1 with t; auto with zarith.
fold FtoRradix; rewrite <- P; auto.
rewrite <- K1'; unfold FtoRradix; rewrite <- MX3; rewrite <- MY3; rewrite <- O1; auto.
apply Rmult_le_reg_l with (IZR 4); auto with real zarith; simpl.
apply Rle_trans with (IZR 5);[simpl; right; field; auto with real|idtac].
repeat apply prod_neq_R0; auto with real.
apply Rle_trans with (IZR 28); [auto with real zarith|simpl; right; ring].
rewrite M11; rewrite <- O1; auto with real.
rewrite M13; apply rExp with radix b' s; auto.
fold FtoRradix; rewrite Hx'; rewrite Hy'; auto.
cut (hx*ty=FtoRradix Cx1y2')%R.
intros P; rewrite P; unfold FtoRradix; apply Underf_Err1 with t; auto with zarith.
fold FtoRradix; rewrite <- P; auto.
unfold FtoRradix; rewrite O4; rewrite MX3; rewrite MY6; auto with real.
apply Rmult_le_reg_l with (IZR 4); auto with real zarith; simpl.
apply Rle_trans with (IZR 7);[simpl; right; field; auto with real|idtac].
repeat apply prod_neq_R0; auto with real.
apply Rle_trans with (IZR 28); [auto with real zarith|simpl; right; ring].
rewrite M21; rewrite M11; rewrite O4; ring.
cut (tx*hy=FtoRradix Cx2y1')%R.
intros P; rewrite P; unfold FtoRradix; apply Underf_Err1 with t; auto with zarith.
fold FtoRradix; rewrite <- P; auto.
unfold FtoRradix; rewrite O7; rewrite MX6; rewrite MY3; auto with real.
apply Rmult_le_reg_l with (IZR 4); auto with real zarith; simpl.
apply Rle_trans with (IZR 9);[simpl; right; field; auto with real|idtac].
repeat apply prod_neq_R0; auto with real.
apply Rle_trans with (IZR 28); [auto with real zarith|simpl; right; ring].
rewrite M21; rewrite M31; rewrite O7; ring.
cut (tx*ty=FtoRradix Cx2y2')%R.
intros P; rewrite P; unfold FtoRradix; apply Underf_Err1 with t; auto with zarith.
fold FtoRradix; rewrite <- P; auto.
unfold FtoRradix; rewrite O10; rewrite MX6; rewrite MY6; auto with real.
apply Rmult_le_reg_l with (IZR 4); auto with real zarith; simpl.
apply Rle_trans with (IZR 11);[simpl; right; field; auto with real|idtac].
repeat apply prod_neq_R0; auto with real.
apply Rle_trans with (IZR 28); [auto with real zarith|simpl; right; ring].
rewrite M41; rewrite M31; rewrite O10; ring.
Qed.


Theorem Dekker2: 
  (radix=2)%Z \/ (even t) ->  (Rabs (x*y-(r-t4)) <= (7/2)*powerRZ radix (-(dExp b)))%R.
intros.
case (Req_dec 0%R x); intros Ny.
cut (FtoRradix r=0)%R;[intros Z1|idtac].
cut (FtoRradix t4=0)%R;[intros Z2|idtac].
replace ((x * y - (r - t4)))%R with 0%R.
rewrite Rabs_R0; apply Rlt_le; apply Rmult_lt_0_compat; auto with real zarith.
unfold Rdiv;  apply Rmult_lt_0_compat; auto with real zarith.
apply Rlt_le_trans with (IZR 7);[auto with real zarith|simpl; right; ring].
fold FtoRradix; rewrite Z1; rewrite Z2; rewrite <- Ny; ring.
cut (FtoRradix hx=0)%R;[intros Z3|idtac].
cut (FtoRradix tx=0)%R;[intros Z4|idtac].
unfold FtoRradix; apply ClosestZero with b t (t3-x2y2)%R; auto with zarith.
cut (FtoRradix t3=0)%R;[intros Z5|idtac].
cut (FtoRradix x2y2=0)%R;[intros Z6|idtac].
rewrite Z5; rewrite Z6; ring.
unfold FtoRradix; apply ClosestZero with b t (tx*ty)%R; auto with zarith.
rewrite Z4; ring.
unfold FtoRradix; apply ClosestZero with b t (t2-x2y1)%R; auto with zarith.
cut (FtoRradix t2=0)%R;[intros Z5|idtac].
cut (FtoRradix x2y1=0)%R;[intros Z6|idtac].
rewrite Z5; rewrite Z6; ring.
unfold FtoRradix; apply ClosestZero with b t (tx*hy)%R; auto with zarith.
rewrite Z4; ring.
unfold FtoRradix; apply ClosestZero with b t (t1-x1y2)%R; auto with zarith.
cut (FtoRradix t1=0)%R;[intros Z5|idtac].
cut (FtoRradix x1y2=0)%R;[intros Z6|idtac].
rewrite Z5; rewrite Z6; ring.
unfold FtoRradix; apply ClosestZero with b t (hx*ty)%R; auto with zarith.
rewrite Z3; ring.
unfold FtoRradix; apply ClosestZero with b t (r-x1y1)%R; auto with zarith.
cut (FtoRradix x1y1=0)%R;[intros Z6|idtac].
rewrite Z1; rewrite Z6; ring.
unfold FtoRradix; apply ClosestZero with b t (hx*hy)%R; auto with zarith.
rewrite Z3; ring.
elim VeltkampU with radix b s t x p q hx tx; auto.
intros T1 T; elim T; intros H' T'; clear T1 T T'.
fold FtoRradix in H'; rewrite Z3 in H'; rewrite <- Ny in H'; auto with real.
apply trans_eq with (0+tx)%R; auto with real.
unfold s; apply SLe; auto.
unfold s; apply SGe; auto.
elim Veltkamp with radix b s t x p q hx; auto.
intros T1 T; elim T; intros hy' T'; elim T'; intros G1 T''; elim T''; intros ; clear T1 T T' T''.
unfold FtoRradix; rewrite <- G1.
 apply ClosestZero with (Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (t - s)))))
            (dExp b)) (t-s) (FtoR radix x)%R; auto with zarith.
apply p'GivesBound; auto with zarith.
assert  (s <= t - 2)%Z; auto with zarith.
assert  (s <= t - 2)%nat; auto with zarith.
unfold s; apply SGe; auto.
unfold s; apply SLe; auto.
unfold s; apply SGe; auto.
apply FcanonicBound with radix; auto.
unfold FtoRradix; apply ClosestZero with b t (x*y)%R; auto with zarith.
rewrite <- Ny; ring.
case (Req_dec 0%R y); intros Nx.
cut (FtoRradix r=0)%R;[intros Z1|idtac].
cut (FtoRradix t4=0)%R;[intros Z2|idtac].
replace ((x * y - (r - t4)))%R with 0%R.
rewrite Rabs_R0; apply Rlt_le; apply Rmult_lt_0_compat; auto with real zarith.
unfold Rdiv;  apply Rmult_lt_0_compat; auto with real zarith.
apply Rlt_le_trans with (IZR 7);[auto with real zarith|simpl; right; ring].
fold FtoRradix; rewrite Z1; rewrite Z2; rewrite <- Nx; ring.
cut (FtoRradix hy=0)%R;[intros Z3|idtac].
cut (FtoRradix ty=0)%R;[intros Z4|idtac].
unfold FtoRradix; apply ClosestZero with b t (t3-x2y2)%R; auto with zarith.
cut (FtoRradix t3=0)%R;[intros Z5|idtac].
cut (FtoRradix x2y2=0)%R;[intros Z6|idtac].
rewrite Z5; rewrite Z6; ring.
unfold FtoRradix; apply ClosestZero with b t (tx*ty)%R; auto with zarith.
rewrite Z4; ring.
unfold FtoRradix; apply ClosestZero with b t (t2-x2y1)%R; auto with zarith.
cut (FtoRradix t2=0)%R;[intros Z5|idtac].
cut (FtoRradix x2y1=0)%R;[intros Z6|idtac].
rewrite Z5; rewrite Z6; ring.
unfold FtoRradix; apply ClosestZero with b t (tx*hy)%R; auto with zarith.
rewrite Z3; ring.
unfold FtoRradix; apply ClosestZero with b t (t1-x1y2)%R; auto with zarith.
cut (FtoRradix t1=0)%R;[intros Z5|idtac].
cut (FtoRradix x1y2=0)%R;[intros Z6|idtac].
rewrite Z5; rewrite Z6; ring.
unfold FtoRradix; apply ClosestZero with b t (hx*ty)%R; auto with zarith.
rewrite Z4; ring.
unfold FtoRradix; apply ClosestZero with b t (r-x1y1)%R; auto with zarith.
cut (FtoRradix x1y1=0)%R;[intros Z6|idtac].
rewrite Z1; rewrite Z6; ring.
unfold FtoRradix; apply ClosestZero with b t (hx*hy)%R; auto with zarith.
rewrite Z3; ring.
elim VeltkampU with radix b s t y p' q' hy ty; auto.
intros T1 T; elim T; intros H' T'; clear T1 T T'.
fold FtoRradix in H'; rewrite Z3 in H'; rewrite <- Nx in H'; auto with real.
apply trans_eq with (0+ty)%R; auto with real.
unfold s; apply SLe; auto.
unfold s; apply SGe; auto.
elim Veltkamp with radix b s t y p' q' hy; auto.
intros T1 T; elim T; intros hy' T'; elim T'; intros G1 T''; elim T''; intros ; clear T1 T T' T''.
unfold FtoRradix; rewrite <- G1.
 apply ClosestZero with (Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (t - s)))))
            (dExp b)) (t-s) (FtoR radix y)%R; auto with zarith.
apply p'GivesBound; auto with zarith.
assert  (s <= t - 2)%Z; auto with zarith.
assert  (s <= t - 2)%nat; auto with zarith.
unfold s; apply SGe; auto.
unfold s; apply SLe; auto.
unfold s; apply SGe; auto.
apply FcanonicBound with radix; auto.
unfold FtoRradix; apply ClosestZero with b t (x*y)%R; auto with zarith.
rewrite <- Nx; ring.
apply Dekker2_aux; auto.
Qed.


End Algo2.

Section AlgoT.

Variable radix : Z.
Variable b : Fbound.
Variables t:nat.

Let FtoRradix := FtoR radix.
Coercion FtoRradix : float >-> R.
Hypothesis radixMoreThanOne : (1 < radix)%Z.

Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne).
Hint Resolve radixMoreThanZERO: zarith.

Hypothesis pGivesBound: Zpos (vNum b)=(Zpower_nat radix t).
Hypotheses pGe: (4 <= t).


Variables x y p q hx tx p' q' hy ty x1y1 x1y2 x2y1 x2y2 r t1 t2 t3 t4:float.


Hypothesis Cx: (Fcanonic radix b x).
Hypothesis Cy: (Fcanonic radix b y).


Let s:= t- div2 t.

Hypothesis A1: (Closest b radix (x*((powerRZ radix s)+1))%R p).
Hypothesis A2: (Closest b radix (x-p)%R  q).
Hypothesis A3: (Closest b radix (q+p)%R hx).
Hypothesis A4: (Closest b radix (x-hx)%R tx).

Hypothesis B1: (Closest b radix (y*((powerRZ radix s)+1))%R p').
Hypothesis B2: (Closest b radix (y-p')%R  q').
Hypothesis B3: (Closest b radix (q'+p')%R hy).
Hypothesis B4: (Closest b radix (y-hy)%R ty).


Hypothesis C1: (Closest b radix (hx*hy)%R  x1y1).
Hypothesis C2: (Closest b radix (hx*ty)%R  x1y2).
Hypothesis C3: (Closest b radix (tx*hy)%R  x2y1).
Hypothesis C4: (Closest b radix (tx*ty)%R  x2y2).

Hypothesis D1: (Closest b radix (x*y)%R  r).
Hypothesis D2: (Closest b radix (-r+x1y1)%R  t1).
Hypothesis D3: (Closest b radix (t1+x1y2)%R  t2).
Hypothesis D4: (Closest b radix (t2+x2y1)%R  t3).
Hypothesis D5: (Closest b radix (t3+x2y2)%R  t4).

Hypothesis dExpPos: ~(Z_of_N (dExp b)=0)%Z.


Theorem Dekker: (radix=2)%Z \/ (even t) ->
  ((-dExp b <= Fexp x+Fexp y)%Z ->  (x*y=r+t4)%R) /\
    (Rabs (x*y-(r+t4)) <= (7/2)*powerRZ radix (-(dExp b)))%R.
intros.
case (Zle_or_lt (-dExp b) (Fexp x+Fexp y)); intros.
cut (x * y = r + t4)%R; [intros; split; auto|idtac].
rewrite H1; ring_simplify ( (r + t4) - (r + t4))%R; rewrite Rabs_R0.
apply Rlt_le; apply Rmult_lt_0_compat; auto with real zarith.
unfold Rdiv;  apply Rmult_lt_0_compat; auto with real zarith.
apply Rlt_le_trans with (IZR 7);[auto with real zarith|simpl; right; ring].
apply trans_eq with (r-(Fopp t4))%R;[idtac|unfold FtoRradix; rewrite Fopp_correct; ring].
unfold FtoRradix; apply Dekker1 with b t p q hx tx p' q' hy ty x1y1 x1y2 x2y1 x2y2 
  (Fopp t1) (Fopp t2) (Fopp t3); auto; try rewrite Fopp_correct; fold FtoRradix.
replace (r-x1y1)%R with (-(-r+x1y1))%R;[apply ClosestOpp; auto|ring].
replace (-t1-x1y2)%R with (-(t1+x1y2))%R;[apply ClosestOpp; auto|ring].
replace (-t2-x2y1)%R with (-(t2+x2y1))%R;[apply ClosestOpp; auto|ring].
replace (-t3-x2y2)%R with (-(t3+x2y2))%R;[apply ClosestOpp; auto|ring].
split.
intros; absurd (Fexp x + Fexp y < - dExp b)%Z; auto with zarith.
replace (r+t4)%R with (r-(Fopp t4))%R;[idtac|unfold FtoRradix; rewrite Fopp_correct; ring].
unfold FtoRradix; apply Dekker2 with t p q hx tx p' q' hy ty x1y1 x1y2 x2y1 x2y2 
  (Fopp t1) (Fopp t2) (Fopp t3); auto; try rewrite Fopp_correct; fold FtoRradix.
replace (r-x1y1)%R with (-(-r+x1y1))%R;[apply ClosestOpp; auto|ring].
replace (-t1-x1y2)%R with (-(t1+x1y2))%R;[apply ClosestOpp; auto|ring].
replace (-t2-x2y1)%R with (-(t2+x2y1))%R;[apply ClosestOpp; auto|ring].
replace (-t3-x2y2)%R with (-(t3+x2y2))%R;[apply ClosestOpp; auto|ring].
Qed.



End AlgoT.

