intros p q fmax Fp Fq H' H'0 H'1 H'2.
cut (0 <= Fnum p * Fnum q)%Z;
[ intros multPos
| apply Zle_mult_gen; apply (LeR0Fnum radix); auto with arith ].
case (ZquotientProp (Fnum p * Fnum q) (Zpower_nat radix precision));
auto with zarith.
intros r; intros (H'3, (H'4, H'5)).
cut (0 <= Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision))%Z;
[ intros Z2 | apply ZquotientPos; auto with zarith ].
cut (0 <= r)%Z;
[ intros Z3
| replace r with
(Fnum p * Fnum q -
Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision) *
Zpower_nat radix precision)%Z;
[ idtac | pattern (Fnum p * Fnum q)%Z at 1 in |- *; rewrite H'3; ring ];
auto ].
2: apply Zle_Zminus_ZERO; rewrite Zabs_eq in H'4; auto with zarith;
rewrite Zabs_eq in H'4; auto with zarith.
case (Z_eq_dec r 0); intros Z4.
exists (Fzero (Fexp p + Fexp q)); repeat (split; auto with float).
replace (FtoRradix (Fzero (Fexp p + Fexp q))) with 0%R;
[ idtac | unfold Fzero, FtoRradix, FtoR in |- *; simpl in |- *; ring ].
apply Rplus_eq_reg_l with (r := FtoRradix fmax).
replace (fmax + 0)%R with (FtoRradix fmax); [ idtac | ring ].
replace (fmax + (p * q - fmax))%R with (p * q)%R; [ idtac | ring ].
unfold FtoRradix in |- *; rewrite <- (Fmult_correct radix); auto with zarith.
case
(FboundedMbound _ radixMoreThanOne b precision)
with
(z := (precision + (Fexp p + Fexp q))%Z)
(m := Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision));
auto with zarith.
apply Zmult_le_reg_r with (p := Zpower_nat radix precision); auto with zarith.
apply Zlt_gt; auto with zarith.
pattern (Zpower_nat radix precision) at 2 in |- *;
rewrite <- (fun x => Zabs_eq (Zpower_nat radix x)).
rewrite <- Zabs_Zmult.
apply Zle_trans with (1 := H'4); auto with zarith.
rewrite Zabs_Zmult.
apply Zle_trans with (Zpower_nat radix precision * Zabs (Fnum q))%Z.
apply Zle_Zmult_comp_r; auto with zarith.
apply Zlt_le_weak; rewrite <- pGivesBound; case Fp; auto with float.
apply Zle_Zmult_comp_l; auto with zarith.
apply Zlt_le_weak; rewrite <- pGivesBound; case Fq; auto with float.
auto with zarith.
intros x (H'6, H'7).
cut (FtoR radix (Fmult p q) = FtoR radix x).
intros H'8; rewrite H'8.
apply sym_eq; apply (ProjectMax b radix); auto.
rewrite <- H'8; auto.
rewrite Fmult_correct; auto with zarith.
rewrite H'7.
unfold FtoRradix, FtoR in |- *; simpl in |- *.
rewrite powerRZ_add with (n := Z_of_nat precision); auto with real zarith.
pattern (Fnum p * Fnum q)%Z at 1 in |- *; rewrite H'3.
rewrite plus_IZR; rewrite Rmult_IZR.
repeat rewrite Zpower_nat_Z_powerRZ; auto with real zarith.
rewrite Z4; simpl;ring.
cut (ex (fun m : Z => FtoRradix fmax = Float m (Fexp (Fmult p q))));
[ intros Z5 | idtac ].
2: unfold FtoRradix in |- *;
apply
RoundedModeRep
with (b := b) (precision := precision) (P := isMax b radix);
auto.
2: apply MaxRoundedModeP with (precision := precision); auto.
2: rewrite (Fmult_correct radix); auto with zarith.
elim Z5; intros m E; clear Z5.
exists (Fopp (Fminus radix (Float m (Fexp (Fmult p q))) (Fmult p q))).
split.
rewrite E; unfold FtoRradix in |- *; repeat rewrite Fopp_correct;
repeat rewrite Fminus_correct; repeat rewrite Fmult_correct;
auto with zarith; ring.
cut
(Fexp (Fopp (Fminus radix (Float m (Fexp (Fmult p q))) (Fmult p q))) =
(Fexp p + Fexp q)%Z); [ intros Z5 | idtac ].
split; auto.
split; [ idtac | rewrite Z5; auto ].
cut (Fmult p q <= fmax)%R;
[ idtac
| unfold FtoRradix in |- *; rewrite Fmult_correct; auto; case H'2;
auto with real zarith; (intros H1 H2; case H2; auto) ].
cut
(fmax <=
Zsucc (Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision)) *
powerRZ radix (precision + (Fexp p + Fexp q)))%R.
rewrite E; repeat rewrite Zmin_n_n; repeat rewrite <- Zminus_diag_reverse;
repeat rewrite Zpower_nat_O; repeat rewrite Zmult_1_r;
auto.
unfold Fmult, Fminus, Fplus, Fopp in |- *; simpl in |- *.
repeat rewrite Zmin_n_n; repeat rewrite <- Zminus_diag_reverse;
repeat rewrite Zpower_nat_O; repeat rewrite Zmult_1_r;
auto.
intros H1 H2; rewrite Zabs_Zopp; apply Zlt_Zabs_intro.
apply Zlt_le_trans with 0%Z; auto with zarith.
cut (Fnum p * Fnum q <= m)%Z; auto with zarith.
apply le_IZR;
apply (Rle_monotony_contra_exp radix) with (z := (Fexp p + Fexp q)%Z);
auto with zarith.
cut
(m <=
Zsucc (Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision)) *
Zpower_nat radix precision)%Z; [ intros H'9 | idtac ].
apply Zle_lt_trans with (Zpower_nat radix precision - r)%Z;
[ idtac | rewrite pGivesBound; auto with zarith ].
replace r with
(Fnum p * Fnum q -
Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision) *
Zpower_nat radix precision)%Z.
replace
(Zpower_nat radix precision -
(Fnum p * Fnum q -
Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision) *
Zpower_nat radix precision))%Z with
(Zsucc (Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision)) *
Zpower_nat radix precision - Fnum p * Fnum q)%Z;
auto with zarith.
unfold Zsucc in |- *; simpl in |- *; ring.
pattern (Fnum p * Fnum q)%Z at 1 in |- *; rewrite H'3; ring.
apply le_IZR;
apply (Rle_monotony_contra_exp radix) with (z := (Fexp p + Fexp q)%Z);
auto with zarith.
replace
(IZR
(Zsucc (Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision)) *
Zpower_nat radix precision) * powerRZ radix (Fexp p + Fexp q))%R with
(Zsucc (Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision)) *
powerRZ radix (precision + (Fexp p + Fexp q)))%R;
[ auto | idtac ].
rewrite powerRZ_add; auto with real zarith.
repeat rewrite Rmult_IZR; repeat rewrite Zpower_nat_Z_powerRZ; auto with zarith.
ring.
case
(FboundedMbound _ radixMoreThanOne b precision)
with
(z := (precision + (Fexp p + Fexp q))%Z)
(m := Zsucc (Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision)));
auto with arith.
rewrite Zabs_eq; auto with zarith.
apply Zlt_le_succ.
case (Zle_lt_or_eq _ _ multPos); intros Eq1.
cut (0 < Zabs (Fnum p))%Z; [ intros Eq2 | idtac ].
cut (0 < Zabs (Fnum q))%Z; [ intros Eq3 | idtac ].
apply Zlt_mult_simpl_l with (c := Zpower_nat radix precision);
auto with zarith.
rewrite (fun x y z => Zmult_comm x (Zquotient y z)).
apply Zle_lt_trans with (Fnum p * Fnum q)%Z.
rewrite Zabs_eq in H'4; auto with zarith; rewrite Zabs_eq in H'4;
auto with zarith.
rewrite <- (Zabs_eq (Fnum p * Fnum q)); auto with zarith; rewrite Zabs_Zmult.
apply Zlt_trans with (Zabs (Fnum p) * Zpower_nat radix precision)%Z.
cut (Zabs (Fnum q) < Zpower_nat radix precision)%Z;
[ intros Eq4; apply Zmult_gt_0_lt_compat_l
| rewrite <- pGivesBound; case Fq ]; auto with zarith.
cut (Zabs (Fnum p) < Zpower_nat radix precision)%Z;
[ intros Eq4; apply Zmult_gt_0_lt_compat_r
| rewrite <- pGivesBound; case Fp ]; auto with zarith.
case (Zle_lt_or_eq _ _ (Zle_ZERO_Zabs (Fnum q))); auto.
intros Eq3; Contradict Eq1; replace (Fnum q) with 0%Z; auto with zarith.
generalize Eq3; case (Fnum q); simpl in |- *; auto; intros; discriminate.
case (Zle_lt_or_eq _ _ (Zle_ZERO_Zabs (Fnum p))); auto.
intros Eq3; Contradict Eq1; replace (Fnum p) with 0%Z; auto with zarith.
generalize Eq3; case (Fnum p); simpl in |- *; auto; intros; discriminate.
rewrite <- Eq1; replace (Zquotient 0 (Zpower_nat radix precision)) with 0%Z;
auto with zarith.
apply Zle_trans with (1 := H'1); auto with zarith.
intros f1 (Hf1, Hf2); rewrite <- Hf2.
case H'2; intros L1 (L2, L3); apply L3; auto.
rewrite Hf2; unfold Fmult, FtoRradix, FtoR in |- *.
replace
(Fnum p * powerRZ radix (Fexp p) * (Fnum q * powerRZ radix (Fexp q)))%R with
(Fnum p * Fnum q * powerRZ radix (Fexp p + Fexp q))%R.
replace
(Zsucc (Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision)) *
powerRZ radix (precision + (Fexp p + Fexp q)))%R with
((Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision) *
Zpower_nat radix precision + Zpower_nat radix precision)%Z *
powerRZ radix (Fexp p + Fexp q))%R.
apply Rle_monotone_exp; auto with real zarith.
rewrite <- Rmult_IZR; apply Rle_IZR.
pattern (Fnum p * Fnum q)%Z at 1 in |- *; rewrite H'3;
cut (r < Zpower_nat radix precision)%Z; auto with zarith.
rewrite Zabs_eq in H'5; auto with zarith; rewrite Zabs_eq in H'5;
auto with zarith.
unfold Zsucc in |- *; repeat rewrite Rmult_IZR || rewrite plus_IZR;
simpl in |- *.
rewrite (powerRZ_add radix precision); auto with real zarith;
rewrite <- (Zpower_nat_Z_powerRZ radix precision); auto with real zarith;
ring.
rewrite powerRZ_add; auto with real zarith; ring.
unfold Fopp, Fminus, Fmult in |- *; simpl in |- *; auto.
apply Zmin_n_n.
Qed.

(* Specifications: *)
Theorem multExpMin :
forall P,
RoundedModeP b radix P ->
forall p q pq : float,
P (p * q)%R pq ->
exists s : float,
Fbounded b s /\ s = pq :>R /\ (Fexp p + Fexp q <= Fexp s)%Z.