Float8.4/0000755000423700002640000000000012032777406012051 5ustar sboldotoccataFloat8.4/Makefile0000644000423700002640000001756512032774741013526 0ustar sboldotoccata############################################################################# ## v # The Coq Proof Assistant ## ## "$@" || ( RV=$$?; rm -f "$@"; exit $${RV} ) %.v.beautified: $(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $* # WARNING # # This Makefile has been automagically generated # Edit at your own risks ! # # END OF WARNING Float8.4/Ct2/0000755000423700002640000000000012032777406012501 5ustar sboldotoccataFloat8.4/Ct2/FboundI.v0000644000423700002640000005575212032774524014232 0ustar sboldotoccataRequire Export AllFloat. Section FboundedI_Def. Variable radix : Z. Hypothesis radixMoreThanOne : (1 < radix)%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Record FboundI : Set := BoundI {vNumInf : nat; vNumSup : nat; dExpI : nat}. Definition FboundedI (b : FboundI) (d : float) := ((- vNumInf b <= Fnum d)%Z /\ (Fnum d <= vNumSup b)%Z) /\ (- dExpI b <= Fexp d)%Z. Theorem isBoundedI : forall (b : FboundI) (p : float), {FboundedI b p} + {~ FboundedI b p}. intros b p; case (Z_le_gt_dec (Fnum p) (vNumSup b)); intros H'. case (Z_le_gt_dec (- vNumInf b) (Fnum p)); intros H'0. case (Z_le_gt_dec (- dExpI b) (Fexp p)); intros H'1. left; repeat split; auto. right; red in |- *; intros H'3; absurd (- dExpI b > Fexp p)%Z; elim H'3; auto with zarith. right; red in |- *; intros H'1; absurd (- vNumInf b > Fnum p)%Z; elim H'1; auto with zarith. right; red in |- *; intros H'0; absurd (Fnum p > vNumSup b)%Z; elim H'0; auto with zarith. Qed. Theorem FboundedIFzero : forall b : FboundI, FboundedI b (Fzero (- dExpI b)). intros b; repeat (split; simpl in |- *). replace 0%Z with (- 0%nat)%Z; [ idtac | simpl in |- *; auto ]. apply Zle_Zopp; apply inj_le; auto with arith. replace 0%Z with (Z_of_nat 0); [ idtac | simpl in |- *; auto ]. apply inj_le; auto with arith. auto with zarith. Qed. Definition FnormalI (b : FboundI) (p : float) := FboundedI b p /\ ((vNumSup b < radix * Fnum p)%R \/ (radix * Fnum p < (- vNumInf b)%Z)%R). Theorem FnormalINotZero : forall (b : FboundI) (p : float), FnormalI b p -> ~ is_Fzero p. intros b p H; elim H; intros H1 H2; unfold is_Fzero in |- *. case (Z_zerop (Fnum p)); auto; intros H3. generalize H2; rewrite H3. replace (radix * 0%Z)%R with 0%R; [ idtac | simpl; ring ]. clear H2; intros H2. case H2; intros H4; clear H2. absurd (vNumSup b < 0)%R; auto with arith real. apply Rle_not_lt; auto with zarith real. absurd (0 < (- vNumInf b)%Z)%R; auto. apply Rle_not_lt; replace 0%R with (IZR (- (0))); auto with arith. apply Rle_IZR; apply Zle_Zopp; auto with zarith. Qed. Theorem FnormalIUnique_aux : forall (b : FboundI) (p q : float), FnormalI b p -> FnormalI b q -> p = q :>R -> (Fexp p < Fexp q)%Z -> p = q :>float. intros b p q Hp Hq H H'. absurd (p = q :>R); auto. elim Hq; intros H3 H4; case H4; clear H4; intros H4. apply Rlt_dichotomy_converse; left. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *. apply Rle_lt_trans with (vNumSup b * powerRZ radix (Fexp p))%R. apply Rmult_le_compat_r. apply powerRZ_le; auto with real zarith. rewrite INR_IZR_INZ; apply Rle_IZR; elim Hp; intros V1 V2; elim V1; intros V3 V4; elim V3; auto with zarith. apply Rle_lt_trans with (vNumSup b * powerRZ radix (Fexp q - 1%nat))%R. apply Rmult_le_compat_l. replace 0%R with (INR 0); auto with real arith. apply Rle_powerRZ; auto with real arith zarith. apply Zlt_succ_le. replace (Zsucc (Fexp q - 1%nat)) with (Fexp q); auto with zarith. replace (Z_of_nat 1) with 1%Z; auto with zarith. apply Rmult_lt_reg_l with (IZR radix); auto with real zarith. unfold Zminus in |- *; rewrite powerRZ_add; auto with real zarith. replace (radix * (Fnum q * powerRZ radix (Fexp q)))%R with (radix * Fnum q * powerRZ radix (Fexp q))%R; [ idtac | ring ]. replace (radix * (vNumSup b * (powerRZ radix (Fexp q) * powerRZ radix (- 1%nat))))%R with (vNumSup b * powerRZ radix (Fexp q))%R. apply Rmult_lt_compat_r; auto with real zarith. simpl in |- *; apply trans_eq with (radix * / radix * (vNumSup b * powerRZ radix (Fexp q)))%R. rewrite Rinv_r; auto with real zarith. replace (radix * 1)%R with (IZR radix); ring; ring. apply not_eq_sym; apply Rlt_dichotomy_converse; left. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *. replace (Fnum q * powerRZ radix (Fexp q))%R with (radix * Fnum q * powerRZ radix (Fexp q + - 1%nat))%R. apply Rlt_le_trans with ((- vNumInf b)%Z * powerRZ radix (Fexp q + - 1%nat))%R. apply Rmult_lt_compat_r; auto with real zarith. apply Rle_trans with ((- vNumInf b)%Z * powerRZ radix (Fexp p))%R. rewrite Ropp_Ropp_IZR; rewrite Ropp_mult_distr_l_reverse; rewrite Ropp_mult_distr_l_reverse; apply Ropp_le_contravar. apply Rmult_le_compat_l; auto with real arith zarith. apply Rle_powerRZ; auto with real arith zarith. apply Zlt_succ_le. replace (Zsucc (Fexp q + - 1%nat)) with (Fexp q); auto with zarith. replace (Z_of_nat 1) with 1%Z; auto with zarith. apply Rmult_le_compat_r; auto with real zarith. apply Rle_IZR; unfold FnormalI in Hp; unfold FboundedI in Hp; intuition. rewrite powerRZ_add; auto with real zarith arith. simpl in |- *; replace (radix * 1)%R with (IZR radix); simpl; try ring. field; auto with zarith real. Qed. Theorem FnormalIUnique : forall (b : FboundI) (p q : float), FnormalI b p -> FnormalI b q -> p = q :>R -> p = q :>float. intros b p q Hp Hq H. case (Zle_or_lt (Fexp p) (Fexp q)); intros H1. cut (forall a b : Z, (a <= b)%Z -> a = b \/ (a < b)%Z); [ intros F | idtac ]. 2: intros x y V; omega. lapply (F (Fexp p) (Fexp q)); [ intros H'1 | auto ]. case H'1; intros H2; clear F H'1. apply sameExpEq with radix; auto. apply FnormalIUnique_aux with b; auto. apply sym_eq; apply FnormalIUnique_aux with b; auto. Qed. Definition FsubnormalI (b : FboundI) (p : float) := FboundedI b p /\ Fexp p = (- dExpI b)%Z /\ ((- vNumInf b)%Z <= radix * Fnum p)%R /\ (radix * Fnum p <= vNumSup b)%R. Theorem FsubnormalIUnique : forall (b : FboundI) (p q : float), FsubnormalI b p -> FsubnormalI b q -> p = q :>R -> p = q :>float. intros b p q Hp Hq H. apply sameExpEq with radix; auto with zarith. elim Hp; intros H0 H1; elim H1; clear H1; intros H1 H2. elim Hq; intros H4 H5; elim H5; clear H5; intros H5 H6. auto with zarith. Qed. Theorem NormalIandSubnormalINotEq : forall (b : FboundI) (p q : float), FnormalI b p -> FsubnormalI b q -> p <> q :>R. intros b p q Hp Hq. elim Hp; intros H1 H2; elim Hq; intros H4 H3. elim H3; intros H5 H6; clear H3. elim H6; intros H3 H7; clear H6. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *. rewrite H5. case H2; intros H8. apply not_eq_sym; apply Rlt_dichotomy_converse; left. apply Rlt_le_trans with (Fnum p * powerRZ radix (- dExpI b))%R. apply Rmult_lt_compat_r. apply powerRZ_lt; auto with real zarith. apply Rmult_lt_reg_l with (IZR radix); auto with real zarith. apply Rle_lt_trans with (INR (vNumSup b)); auto. apply Rmult_le_compat_l. apply Rmult_le_reg_l with (IZR radix); auto with real zarith. replace (radix * 0)%R with (INR 0); auto with real arith. apply Rle_trans with (INR (vNumSup b)); auto with real arith. apply Rle_powerRZ; auto with real arith. elim H1; auto. apply Rlt_dichotomy_converse; left. apply Ropp_lt_cancel. rewrite <- Ropp_mult_distr_l_reverse. rewrite <- Ropp_mult_distr_l_reverse. apply Rlt_le_trans with (- Fnum p * powerRZ radix (- dExpI b))%R. apply Rmult_lt_compat_r. apply powerRZ_lt; auto with real zarith. apply Ropp_lt_gt_contravar. apply Rmult_lt_reg_l with (IZR radix); auto with real zarith. apply Rlt_le_trans with (IZR (- vNumInf b)); auto with real arith. apply Rmult_le_compat_l. replace 0%R with (-0)%R; auto with real; apply Ropp_le_contravar. apply Rmult_le_reg_l with (IZR radix); auto with real zarith. replace (radix * 0)%R with 0%R; auto with real. apply Rle_trans with (IZR (- vNumInf b)); auto with real arith. replace 0%R with (IZR 0); auto with real arith zarith. apply Rle_powerRZ; auto with real arith. elim H1; auto. Qed. Definition FcanonicI (b : FboundI) (a : float) := FnormalI b a \/ FsubnormalI b a. Theorem FcanonicIUnique : forall (b : FboundI) (p q : float), FcanonicI b p -> FcanonicI b q -> p = q :>R -> p = q :>float. intros b p q Hp Hq H; case Hp; case Hq; intros H1 H2. apply FnormalIUnique with b; auto. Contradict H; apply NormalIandSubnormalINotEq with b; auto. Contradict H; apply not_eq_sym; apply NormalIandSubnormalINotEq with b; auto. apply FsubnormalIUnique with b; auto. Qed. Theorem Zpower_nat_S : forall n : nat, Zpower_nat radix (S n) = (radix * Zpower_nat radix n)%Z. intros n; replace (S n) with (1 + n); auto with arith. Qed. Fixpoint FNIAux (v N q : nat) {struct q} : nat := match q with | O => 0 | S q' => match (Zpower_nat radix q' * v ?= radix * N)%Z with | Datatypes.Lt => q' | Datatypes.Eq => q' | _ => FNIAux v N q' end end. Definition FNI (q N : nat) := pred (FNIAux q N (S (S N))). Theorem FNIAuxLess : forall v N q : nat, 0 < v -> v <= N -> (Zpower_nat radix (FNIAux v N q) * v <= radix * N)%Z. intros v N q; elim q. intros H1 H2; apply Zle_trans with (Z_of_nat v); simpl in |- *. apply Zeq_le; case v; auto with arith zarith. apply Zle_trans with (Z_of_nat N); auto with arith zarith. pattern (Z_of_nat N) at 1 in |- *; replace (Z_of_nat N) with (1 * N)%Z; auto with arith zarith. intros q1 H H1 H2. simpl in |- *; generalize (Zcompare_correct (Zpower_nat radix q1 * v) (radix * N)); case (Zpower_nat radix q1 * v ?= radix * N)%Z; auto with arith zarith. Qed. Theorem FNILess : forall q N : nat, 0 < q -> q <= N -> (Zpower_nat radix (FNI q N) * q <= N)%Z. intros q N H1 H2; unfold FNI in |- *. apply Zmult_le_reg_r with radix; auto with zarith. generalize (refl_equal (FNIAux q N (S (S N)))); pattern (FNIAux q N (S (S N))) at -1 in |- *; case (FNIAux q N (S (S N))). intros H3; replace (Zpower_nat radix (pred 0) * q)%Z with (Z_of_nat q); auto with arith zarith. intros n H3; simpl in |- *. rewrite (Zmult_comm (Z_of_nat N) radix). replace (Zpower_nat radix n * q * radix)%Z with (Zpower_nat radix (FNIAux q N (S (S N))) * q)%Z; [ apply FNIAuxLess; auto | idtac ]. rewrite H3; rewrite Zpower_nat_S; ring. Qed. Theorem FNIAuxMore : forall v N q : nat, FNIAux v N q < pred q -> (N < Zpower_nat radix (FNIAux v N q) * v)%Z. intros v N q; elim q; simpl in |- *. intros H; inversion H. intros q1 H'. generalize (Zcompare_correct (Zpower_nat radix q1 * v) (radix * N)); case (Zpower_nat radix q1 * v ?= radix * N)%Z; auto with arith zarith. intros H1 H2. case (le_lt_or_eq (FNIAux v N q1) (pred q1)); auto with zarith arith. intros H3; rewrite H3. apply Zgt_lt; apply Zmult_gt_reg_r with radix; auto with zarith; apply Zlt_gt. apply Zlt_le_trans with (Zpower_nat radix q1 * v)%Z; auto with zarith. rewrite Zmult_comm; auto. replace (Zpower_nat radix (pred q1) * v * radix)%Z with (radix * Zpower_nat radix (pred q1) * v)%Z; [ rewrite <- Zpower_nat_S | ring ]. apply Zmult_le_compat_r; auto with zarith. Qed. Theorem Zlt_Zpower_nat : forall n : nat, (n < Zpower_nat radix n)%Z. intros n; induction n as [| n Hrecn]. simpl in |- *; auto with zarith. rewrite Zpower_nat_S. apply Zlt_le_trans with (1 + Zpower_nat radix n)%Z. replace (Z_of_nat (S n)) with (1 + n)%Z; auto with arith zarith. replace 1%Z with (Z_of_nat 1); auto with arith zarith. rewrite <- inj_plus; auto with arith zarith. apply Zle_trans with (Zpower_nat radix n + Zpower_nat radix n)%Z; auto with zarith. apply Zle_trans with (2 * Zpower_nat radix n)%Z; auto with zarith. Qed. Theorem FNIMore : forall N q : nat, 0 < q -> q <= N -> (N < radix * (Zpower_nat radix (FNI q N) * q))%Z. intros N q; case q. intros H; inversion H. intros q' H H'; unfold FNI in |- *. apply Zlt_le_trans with (Zpower_nat radix (FNIAux (S q') N (S (S N))) * S q')%Z. apply FNIAuxMore; auto with arith zarith. generalize (refl_equal (FNIAux (S q') N (S (S N)))); pattern (FNIAux (S q') N (S (S N))) at -1 in |- *; case (FNIAux (S q') N (S (S N))). simpl in |- *; auto with arith. intros n0 H2; replace (pred (S (S N))) with (S N); auto with arith. rewrite <- H2. apply Zpower_nat_anti_monotone_lt with radix; auto with arith zarith. apply Zgt_lt; apply Zmult_gt_reg_r with (Z_of_nat (S q')); auto with zarith arith; apply Zlt_gt. apply Zlt_le_trans with (Z_of_nat 1); auto with zarith arith. apply Zle_lt_trans with (radix * N)%Z. apply FNIAuxLess; auto with zarith arith. apply Zle_lt_trans with (radix * N * S q')%Z; auto with zarith arith. pattern (radix * N)%Z at 1 in |- *; replace (radix * N)%Z with (radix * N * 1%nat)%Z; auto with arith zarith. replace (Z_of_nat 1) with 1%Z; auto with zarith. apply Zmult_gt_0_lt_compat_r; auto with zarith arith. apply Zlt_gt; auto with arith zarith. rewrite Zpower_nat_S; apply Zmult_gt_0_lt_compat_l; auto with zarith. apply Zlt_Zpower_nat. rewrite Zmult_assoc; apply Zmult_le_compat_r; auto with zarith. generalize (refl_equal (FNIAux (S q') N (S (S N)))); pattern (FNIAux (S q') N (S (S N))) at -1 in |- *; case (FNIAux (S q') N (S (S N))). intros H1; simpl in |- *; auto with zarith arith. intros H1; rewrite <- Zpower_nat_S; auto with zarith arith. Qed. Definition FnormalizeI (b : FboundI) (p : float) := match (0 ?= Fnum p)%Z with | Datatypes.Eq => Float 0 (- dExpI b) | Datatypes.Lt => Fshift radix (min (FNI (Zabs_nat (Fnum p)) (vNumSup b)) (Zabs_nat (Fexp p + dExpI b))) p | Datatypes.Gt => Fshift radix (min (FNI (Zabs_nat (Fnum p)) (vNumInf b)) (Zabs_nat (Fexp p + dExpI b))) p end. Theorem FnormalizeICorrect : forall (b : FboundI) (p : float), FnormalizeI b p = p :>R. intros b p; unfold FnormalizeI in |- *. generalize (Zcompare_correct 0 (Fnum p)); case (0 ?= Fnum p)%Z; intros H. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *. rewrite <- H; simpl; ring. unfold FtoRradix in |- *; apply FshiftCorrect; auto. unfold FtoRradix in |- *; apply FshiftCorrect; auto. Qed. Theorem FnormalizeIBounded : forall (b : FboundI) (p : float), FboundedI b p -> FboundedI b (FnormalizeI b p). intros b p H; unfold FnormalizeI in |- *. generalize (Zcompare_correct 0 (Fnum p)); case (0 ?= Fnum p)%Z; intros H1. replace (Float 0 (- dExpI b)) with (Fzero (- dExpI b)); [ apply FboundedIFzero | unfold Fzero in |- *; auto ]. unfold Fshift in |- *. repeat split; simpl in |- *. apply Zle_trans with 0%Z; auto with zarith arith. apply Zle_trans with (Fnum p * Zpower_nat radix (FNI (Zabs_nat (Fnum p)) (vNumSup b)))%Z; auto with zarith arith. pattern (Fnum p) at 1 in |- *; replace (Fnum p) with (Zabs (Fnum p)); [ rewrite Zabs_absolu; rewrite Zmult_comm | apply Zabs_eq; auto with zarith ]. apply FNILess; auto with arith zarith. apply lt_Zlt_inv; rewrite <- Zabs_absolu; simpl in |- *; rewrite Zabs_eq; auto with zarith. apply ZleLe; rewrite <- Zabs_absolu; simpl in |- *; rewrite Zabs_eq; auto with zarith; elim H; intuition. apply Zplus_le_reg_l with (dExpI b + min (FNI (Zabs_nat (Fnum p)) (vNumSup b)) (Zabs_nat (Fexp p + dExpI b)))%Z. apply Zle_trans with (Z_of_nat (min (FNI (Zabs_nat (Fnum p)) (vNumSup b)) (Zabs_nat (Fexp p + dExpI b)))); [ apply Zeq_le; ring | idtac ]. apply Zle_trans with (dExpI b + Fexp p)%Z; [ idtac | apply Zeq_le; ring ]. apply Zle_trans with (Z_of_nat (Zabs_nat (Fexp p + dExpI b))); auto with zarith arith. case (Zle_or_lt 0 (Fexp p + dExpI b)); intros H2. rewrite inj_abs; auto with zarith arith. rewrite <- absolu_Zopp; rewrite inj_abs; auto with zarith arith. apply Zplus_le_reg_l with (- dExpI b + Fexp p)%Z. apply Zle_trans with (- dExpI b + - dExpI b)%Z; [ apply Zeq_le; ring | idtac ]. apply Zle_trans with (Fexp p + Fexp p)%Z; [ idtac | apply Zeq_le; ring ]. repeat rewrite Zred_factor1. apply Zle_Zmult_comp_r; auto with zarith arith; elim H; intuition. unfold Fshift in |- *. repeat split; simpl in |- *. 2: apply Zle_trans with 0%Z; auto with zarith arith. 2: cut (forall x y : Z, (x <= 0)%Z -> (0 <= y)%Z -> (x * y <= 0)%Z); [ intros F; apply F | intros x y H3 H2 ]; auto with zarith. 2: rewrite <- (Zopp_involutive (x * y)); rewrite <- (Zopp_involutive 0). 2: apply Zle_Zopp; simpl in |- *; rewrite <- Zopp_mult_distr_l_reverse; auto with zarith. pattern (Fnum p) at 1 in |- *; replace (Fnum p) with (- Zabs_nat (Fnum p))%Z; auto with zarith. rewrite Zopp_mult_distr_l_reverse; apply Zle_Zopp. apply Zle_trans with (Zabs_nat (Fnum p) * Zpower_nat radix (FNI (Zabs_nat (Fnum p)) (vNumInf b)))%Z. apply Zle_Zmult_comp_l; auto with zarith arith. rewrite Zmult_comm; apply FNILess. rewrite <- absolu_Zopp; auto with zarith arith. apply lt_Zlt_inv; rewrite <- Zabs_absolu; simpl in |- *; rewrite Zabs_eq; auto with zarith. rewrite <- absolu_Zopp; apply ZleLe. rewrite <- (Zopp_involutive (Z_of_nat (vNumInf b))). rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. apply Zle_Zopp; elim H; intuition. rewrite <- absolu_Zopp; rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. apply Zplus_le_reg_l with (dExpI b + min (FNI (Zabs_nat (Fnum p)) (vNumInf b)) (Zabs_nat (Fexp p + dExpI b)))%Z. apply Zle_trans with (Z_of_nat (min (FNI (Zabs_nat (Fnum p)) (vNumInf b)) (Zabs_nat (Fexp p + dExpI b)))); [ apply Zeq_le; ring | idtac ]. apply Zle_trans with (dExpI b + Fexp p)%Z; [ idtac | apply Zeq_le; ring ]. apply Zle_trans with (Z_of_nat (Zabs_nat (Fexp p + dExpI b))); auto with zarith arith. case (Zle_or_lt 0 (Fexp p + dExpI b)); intros H2. rewrite inj_abs; auto with zarith arith. rewrite <- absolu_Zopp; rewrite inj_abs; auto with zarith arith. apply Zplus_le_reg_l with (- dExpI b + Fexp p)%Z. apply Zle_trans with (- dExpI b + - dExpI b)%Z; [ apply Zeq_le; ring | idtac ]. apply Zle_trans with (Fexp p + Fexp p)%Z; [ idtac | apply Zeq_le; ring ]. repeat rewrite Zred_factor1. apply Zle_Zmult_comp_r; auto with zarith arith; elim H; intuition. Qed. Theorem FcanonicIBoundedI : forall (b : FboundI) (p : float), FcanonicI b p -> FboundedI b p. intros b p H. case H; intros H1; elim H1; auto. Qed. Theorem FnormalizeIFcanonicI : forall (b : FboundI) (p : float), FboundedI b p -> FcanonicI b (FnormalizeI b p). intros b p H; unfold FnormalizeI in |- *. generalize (Zcompare_correct 0 (Fnum p)); case (0 ?= Fnum p)%Z; intros H1. unfold FcanonicI in |- *; right. repeat split; simpl in |- *; auto with zarith. replace (radix * 0)%R with (IZR 0); auto with zarith real. replace (radix * 0)%R with (INR 0); auto with zarith real arith. case (min_or (FNI (Zabs_nat (Fnum p)) (vNumSup b)) (Zabs_nat (Fexp p + dExpI b))); intros H2; elim H2; clear H2; intros H2 H3; rewrite H2. unfold FcanonicI in |- *; left; split. rewrite <- H2. replace (Fshift radix (min (FNI (Zabs_nat (Fnum p)) (vNumSup b)) (Zabs_nat (Fexp p + dExpI b))) p) with (FnormalizeI b p). apply FnormalizeIBounded; auto. unfold FnormalizeI in |- *; rewrite H1; simpl in |- *; auto. left; unfold Fshift in |- *; simpl in |- *. pattern (Fnum p) at 1 in |- *; rewrite <- (Zabs_eq (Fnum p)); auto with zarith; rewrite Zabs_absolu. rewrite <- Rmult_IZR; rewrite INR_IZR_INZ; apply Rlt_IZR. rewrite (Zmult_comm (Zabs_nat (Fnum p)) (Zpower_nat radix (FNI (Zabs_nat (Fnum p)) (vNumSup b)))) . apply FNIMore. apply lt_Zlt_inv; simpl in |- *; rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. apply ZleLe; rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith; elim H; intuition. cut (Zabs_nat (Fexp p + dExpI b) = (Fexp p + dExpI b)%Z :>Z); [ intros H4 | auto with zarith ]. case (Rle_or_lt (radix * (Fnum p * Zpower_nat radix (Zabs_nat (Fexp p + dExpI b)))%Z) (vNumSup b)); intros H5. unfold FcanonicI in |- *; right; split. replace (Fshift radix (Zabs_nat (Fexp p + dExpI b)) p) with (FnormalizeI b p). apply FnormalizeIBounded; auto. unfold FnormalizeI in |- *; rewrite H1; simpl in |- *; rewrite H2; auto. split. unfold Fshift in |- *; simpl in |- *; rewrite H4; ring. unfold Fshift in |- *; simpl in |- *. split; auto. apply Rle_trans with 0%R; auto with real arith zarith. replace 0%R with (IZR 0); auto with real zarith. rewrite Rmult_IZR; auto with real arith zarith. apply Rlt_le; apply Rmult_lt_0_compat; auto with real arith zarith. apply Rmult_lt_0_compat; auto with real arith zarith. unfold FcanonicI in |- *; left; split. replace (Fshift radix (Zabs_nat (Fexp p + dExpI b)) p) with (FnormalizeI b p). apply FnormalizeIBounded; auto. unfold FnormalizeI in |- *; rewrite H1; simpl in |- *; rewrite H2; auto. unfold Fshift in |- *; simpl in |- *; auto. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. apply Zplus_le_reg_l with (- dExpI b)%Z. apply Zle_trans with (- dExpI b)%Z; [ apply Zeq_le; ring | idtac ]. apply Zle_trans with (Fexp p); [ idtac | apply Zeq_le; ring ]. elim H; intuition. cut (0 < - Fnum p)%Z; [ intros Y | auto with zarith ]. case (min_or (FNI (Zabs_nat (Fnum p)) (vNumInf b)) (Zabs_nat (Fexp p + dExpI b))); intros H2; elim H2; clear H2; intros H2 H3; rewrite H2. unfold FcanonicI in |- *; left; split. rewrite <- H2. replace (Fshift radix (min (FNI (Zabs_nat (Fnum p)) (vNumInf b)) (Zabs_nat (Fexp p + dExpI b))) p) with (FnormalizeI b p). apply FnormalizeIBounded; auto. unfold FnormalizeI in |- *; rewrite H2; auto with zarith. replace (0 ?= Fnum p)%Z with Datatypes.Gt; auto with zarith. generalize (Zcompare_correct 0 (Fnum p)); case (0 ?= Fnum p)%Z; auto with zarith. intros H4; absurd (0%Z = Fnum p :>Z); auto with zarith. intros H4; absurd (0 < Fnum p)%Z; auto with zarith. right; unfold Fshift in |- *; simpl in |- *. pattern (Fnum p) at 1 in |- *; rewrite <- (Zopp_involutive (Fnum p)); rewrite <- (Zabs_eq (- Fnum p)); auto with zarith. rewrite Zopp_mult_distr_l_reverse; rewrite <- Rmult_IZR; rewrite Zmult_comm; rewrite Zopp_mult_distr_l_reverse. apply Rlt_IZR; apply Zlt_Zopp. rewrite Zabs_absolu; rewrite absolu_Zopp. rewrite Zmult_comm; rewrite (Zmult_comm (Zabs_nat (Fnum p)) (Zpower_nat radix (FNI (Zabs_nat (Fnum p)) (vNumInf b)))) . apply FNIMore; auto with zarith. rewrite <- absolu_Zopp; apply lt_Zlt_inv; simpl in |- *; rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. rewrite <- absolu_Zopp; apply ZleLe; rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith; elim H; intuition. cut (Zabs_nat (Fexp p + dExpI b) = (Fexp p + dExpI b)%Z :>Z); [ intros H4 | auto with zarith ]. case (Rle_or_lt (- vNumInf b)%Z (radix * (Fnum p * Zpower_nat radix (Zabs_nat (Fexp p + dExpI b)))%Z)); intros H5. unfold FcanonicI in |- *; right; split. replace (Fshift radix (Zabs_nat (Fexp p + dExpI b)) p) with (FnormalizeI b p). apply FnormalizeIBounded; auto. unfold FnormalizeI in |- *. replace (0 ?= Fnum p)%Z with Datatypes.Gt; auto with zarith. rewrite H2; auto. generalize (Zcompare_correct 0 (Fnum p)); case (0 ?= Fnum p)%Z; auto with zarith. intros H6; absurd (0%Z = Fnum p :>Z); auto with zarith. intros H6; absurd (0 < Fnum p)%Z; auto with zarith. split. unfold Fshift in |- *; simpl in |- *; rewrite H4; ring. unfold Fshift in |- *; simpl in |- *. split; auto. apply Rle_trans with 0%R; auto with real arith zarith. apply Ropp_le_cancel. rewrite Rmult_comm; rewrite <- Ropp_mult_distr_l_reverse; rewrite Rmult_comm. replace (-0)%R with 0%R; auto with real. apply Rlt_le; apply Rmult_lt_0_compat; auto with real zarith. rewrite <- Ropp_Ropp_IZR; rewrite Zmult_comm. rewrite Zopp_mult_distr_r; rewrite Zmult_comm; auto with zarith real. unfold FcanonicI in |- *; left; split. replace (Fshift radix (Zabs_nat (Fexp p + dExpI b)) p) with (FnormalizeI b p). apply FnormalizeIBounded; auto. unfold FnormalizeI in |- *. replace (0 ?= Fnum p)%Z with Datatypes.Gt; auto with zarith. rewrite H2; auto. generalize (Zcompare_correct 0 (Fnum p)); case (0 ?= Fnum p)%Z; auto with zarith. intros H6; absurd (0%Z = Fnum p :>Z); auto with zarith. intros H6; absurd (0 < Fnum p)%Z; auto with zarith. unfold Fshift in |- *; simpl in |- *; auto. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. apply Zplus_le_reg_l with (- dExpI b)%Z. apply Zle_trans with (- dExpI b)%Z; [ apply Zeq_le; ring | idtac ]. apply Zle_trans with (Fexp p); [ idtac | apply Zeq_le; ring ]. elim H; intuition. Qed. End FboundedI_Def.Float8.4/Ct2/FnormI.v0000644000423700002640000017410212032774524014065 0ustar sboldotoccataRequire Export FboundI. Section FboundedI_Def. Variable radix : Z. Hypothesis radixMoreThanOne : (1 < radix)%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Theorem LexicoPosCanI : forall (b : FboundI) (x y : float), FcanonicI radix b x -> FboundedI b y -> (0 <= x)%R -> (x <= y)%R -> (Fexp x <= Fexp y)%Z. intros b x y H1 H2 H3 H4. case H1; intros H5. case (Zle_or_lt (Fexp x) (Fexp y)); auto; intros H6. absurd (x <= y)%R; auto; apply Rlt_not_le. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *. apply Rle_lt_trans with (vNumSup b * powerRZ radix (Fexp y))%R. apply Rmult_le_compat_r; [ apply powerRZ_le; auto with real zarith | rewrite INR_IZR_INZ; apply Rle_IZR; elim H2; intuition ]. apply Rlt_le_trans with (radix * Fnum x * powerRZ radix (Fexp y))%R. apply Rmult_lt_compat_r; [ apply powerRZ_lt; auto with real zarith | idtac ]. elim H5; intros H9 H7; case H7; auto; intros H8. absurd (radix * Fnum x < (- vNumInf b)%Z)%R; auto. apply Rle_not_lt. apply Rle_trans with (IZR 0); auto with zarith real. replace (IZR 0) with (radix * 0%Z)%R; auto with real zarith. apply Rmult_le_compat_l; [ idtac | apply Rle_IZR; apply LeR0Fnum with radix ]; auto with real zarith arith. apply Rle_trans with (Fnum x * (radix * powerRZ radix (Fexp y)))%R; [ right; ring | idtac ]. apply Rmult_le_compat_l; [ replace 0%R with (IZR 0); auto with real zarith; apply Rle_IZR; apply LeR0Fnum with radix; auto with arith | idtac ]. rewrite <- powerRZ_Zs; auto with real zarith. apply Rle_powerRZ; auto with real arith zarith. elim H5; intros H6 H7; elim H7; intros H8 H9. rewrite H8; elim H2; intuition. Qed. Theorem LexicoNegCanI : forall (b : FboundI) (x y : float), FcanonicI radix b x -> FboundedI b y -> (x <= 0)%R -> (y <= x)%R -> (Fexp x <= Fexp y)%Z. intros b x y H1 H2 H3 H4. case H1; intros H5. case (Zle_or_lt (Fexp x) (Fexp y)); auto; intros H6. absurd (y <= x)%R; auto; apply Rlt_not_le. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *. rewrite (Zsucc_pred (Fexp x)); rewrite powerRZ_Zs; auto with real zarith. apply Rlt_le_trans with ((- vNumInf b)%Z * powerRZ radix (Zpred (Fexp x)))%R. rewrite <- Rmult_assoc; apply Rmult_lt_compat_r; auto with real zarith. elim H5; intros H9 H7; case H7; intros H8; clear H7. absurd (vNumSup b < radix * Fnum x)%R; auto; apply Rle_not_lt. apply Rle_trans with (IZR 0); auto with zarith real. replace (IZR 0) with (radix * 0%Z)%R; auto with real zarith. apply Rmult_le_compat_l; [ idtac | apply Rle_IZR; apply R0LeFnum with radix ]; auto with real zarith arith. rewrite Rmult_comm; auto with zarith real. apply Rle_trans with ((- vNumInf b)%Z * powerRZ radix (Fexp y))%R; [ idtac | apply Rmult_le_compat_r ]; auto with zarith real. rewrite Ropp_Ropp_IZR; repeat rewrite Ropp_mult_distr_l_reverse; apply Ropp_le_contravar. apply Rmult_le_compat_l; [ idtac | apply Rle_powerRZ ]; auto with real arith zarith. elim H2; intuition. elim H5; intros H6 H7; elim H7; intros H8 H9. rewrite H8; elim H2; intuition. Qed. Theorem LexicoCanI : forall (b : FboundI) (x y : float), Zabs_nat (vNumInf b - vNumSup b) <= 1 -> FcanonicI radix b x -> FboundedI b y -> (Rabs x < Rabs y)%R -> (Fexp x <= Fexp y)%Z. intros b x y H1 H2 H3 H4. case H2; intros H5. case (Zle_or_lt (Fexp x) (Fexp y)); auto; intros H6. absurd (Rabs x < Rabs y)%R; auto. apply Rle_not_lt. unfold FtoRradix in |- *; repeat rewrite <- Fabs_correct; auto with real zarith. unfold FtoR in |- *; simpl in |- *. elim H5; intros H8 H7; case H7; auto; intros H9. cut (0 < Fnum x)%Z; [ intros H10 | idtac ]. apply Rle_trans with (Zsucc (vNumSup b) * powerRZ radix (Fexp y))%R. apply Rmult_le_compat_r; [ apply powerRZ_le; auto with real zarith | apply Rle_IZR ]. case (Zle_or_lt 0 (Fnum y)); intros H11. rewrite Zabs_eq; auto with zarith. apply Zle_trans with (Z_of_nat (vNumSup b)); [ elim H3; intuition | auto with zarith ]. rewrite Zabs_absolu; rewrite <- absolu_Zopp; auto with zarith. rewrite inj_abs; auto with zarith. apply Zle_trans with (Z_of_nat (vNumInf b)); auto with zarith. rewrite <- (Zopp_involutive (Z_of_nat (vNumInf b))); apply Zle_Zopp; elim H3; intuition. replace (Zsucc (vNumSup b)) with (1%nat + vNumSup b)%Z. apply le_IZR; rewrite plus_IZR. apply Rplus_le_reg_l with (- vNumSup b)%R. apply Rle_trans with (vNumInf b - vNumSup b)%R; [ right; rewrite <- INR_IZR_INZ; ring | idtac ]. apply Rle_trans with (INR 1); [ idtac | right; repeat rewrite <- INR_IZR_INZ; ring ]. rewrite <- (Rabs_right (vNumSup b)); auto with real arith. rewrite <- (Rabs_right (vNumInf b)); auto with real arith. apply Rle_trans with (Rabs (vNumInf b - vNumSup b)); [ apply Rabs_triang_inv | idtac ]. repeat rewrite INR_IZR_INZ; rewrite Z_R_minus. rewrite Faux.Rabsolu_Zabs; rewrite Zabs_absolu; auto with arith zarith real. unfold Zsucc in |- *; auto with arith zarith. apply Rle_trans with (radix * Fnum x * powerRZ radix (Fexp y))%R. apply Rmult_le_compat_r; [ apply powerRZ_le; auto with real zarith | idtac ]. repeat rewrite INR_IZR_INZ; rewrite <- Rmult_IZR; apply Rle_IZR. apply Zlt_le_succ; apply lt_IZR; rewrite Rmult_IZR; repeat rewrite <- INR_IZR_INZ; auto with arith zarith real. apply Rle_trans with (Fnum x * (radix * powerRZ radix (Fexp y)))%R; [ right; ring | idtac ]. rewrite Zabs_eq; auto with zarith. apply Rmult_le_compat_l; [ replace 0%R with (IZR 0); auto with real zarith | idtac ]. rewrite <- powerRZ_Zs; auto with real zarith. apply Rle_powerRZ; auto with real arith zarith. apply lt_IZR; simpl in |- *. apply Rmult_lt_reg_l with (IZR radix); auto with real zarith. apply Rle_lt_trans with 0%R; [ right; ring | idtac ]. apply Rle_lt_trans with (INR (vNumSup b)); auto with arith real. cut (Fnum x < 0)%Z; [ intros H10 | idtac ]. apply Rle_trans with (Zsucc (vNumInf b) * powerRZ radix (Fexp y))%R. apply Rmult_le_compat_r; [ apply powerRZ_le; auto with real zarith | apply Rle_IZR ]. case (Zle_or_lt 0 (Fnum y)); intros H11. rewrite Zabs_eq; auto with zarith. apply Zle_trans with (Z_of_nat (vNumSup b)); [ elim H3; intuition | auto with zarith ]. replace (Zsucc (vNumInf b)) with (1%nat + vNumInf b)%Z. apply le_IZR; rewrite plus_IZR. apply Rplus_le_reg_l with (- vNumInf b)%R. apply Rle_trans with (vNumSup b - vNumInf b)%R; [ right; rewrite <- INR_IZR_INZ; ring | idtac ]. apply Rle_trans with (INR 1); [ idtac | right; repeat rewrite <- INR_IZR_INZ; ring ]. rewrite <- (Rabs_right (vNumSup b)); auto with real arith. rewrite <- (Rabs_right (vNumInf b)); auto with real arith. apply Rle_trans with (Rabs (vNumSup b - vNumInf b)); [ apply Rabs_triang_inv | idtac ]. rewrite <- Rabs_Ropp. replace (- (vNumSup b - vNumInf b))%R with (vNumInf b - vNumSup b)%R; [ idtac | ring ]. repeat rewrite INR_IZR_INZ; rewrite Z_R_minus. rewrite Faux.Rabsolu_Zabs; rewrite Zabs_absolu; auto with arith zarith real. unfold Zsucc in |- *; auto with arith zarith. rewrite Zabs_absolu; rewrite <- absolu_Zopp. rewrite inj_abs; auto with zarith. apply Zle_trans with (Z_of_nat (vNumInf b)); auto with zarith. rewrite <- (Zopp_involutive (Z_of_nat (vNumInf b))); apply Zle_Zopp; elim H3; intuition. apply Rle_trans with (radix * (- Fnum x)%Z * powerRZ radix (Fexp y))%R. apply Rmult_le_compat_r; [ apply powerRZ_le; auto with real zarith | idtac ]. repeat rewrite INR_IZR_INZ; rewrite <- Rmult_IZR; apply Rle_IZR. apply Zlt_le_succ; apply lt_IZR; rewrite Rmult_IZR; repeat rewrite <- INR_IZR_INZ; auto with arith zarith real. apply Ropp_lt_cancel; rewrite Ropp_Ropp_IZR. apply Rle_lt_trans with (radix * Fnum x)%R; [ right; ring | auto with zarith real ]. rewrite (INR_IZR_INZ (vNumInf b)); rewrite <- Ropp_Ropp_IZR; auto with zarith real. apply Rle_trans with ((- Fnum x)%Z * (radix * powerRZ radix (Fexp y)))%R; [ right; ring | idtac ]. rewrite <- (Zabs_eq (- Fnum x)); auto with zarith. replace (Zabs (- Fnum x)) with (Zabs (Fnum x)); auto with zarith. apply Rmult_le_compat_l; [ replace 0%R with (IZR 0); auto with real zarith | idtac ]. rewrite <- powerRZ_Zs; auto with real zarith. apply Rle_powerRZ; auto with real arith zarith. auto with zarith. repeat rewrite Zabs_absolu; auto with arith zarith. rewrite absolu_Zopp; auto with zarith arith. apply lt_IZR; simpl in |- *. apply Rmult_lt_reg_l with (IZR radix); auto with real zarith. apply Rlt_le_trans with 0%R; [ idtac | right; ring ]. apply Rlt_le_trans with (IZR (- vNumInf b)); auto with arith real. replace 0%R with (IZR (- 0%nat)); auto with real arith zarith. elim H5; intros H6 H7; elim H7; intros H8 H9. rewrite H8; elim H3; intuition. Qed. Theorem ReductRangeI : forall (b b' : FboundI) (p : nat), vNumInf b = vNumInf b' -> dExpI b = dExpI b' -> Z_of_nat (vNumSup b) = (vNumSup b' + 1)%Z -> Z_of_nat (vNumSup b) = (radix * p)%Z -> forall x : float, FboundedI b x -> exists y : float, FboundedI b' y /\ x = y :>R. intros b b' p Hi He Hs1 Hs2 x Fx. elim Fx; intros H2 H3; elim H2; clear H2; intros H2 H4. case (Zle_or_lt (Fnum x) (Zpred (vNumSup b))); intros H1. exists x; split; auto with real. repeat (split; auto with zarith arith). cut (Fnum x = vNumSup b); [ intros H5 | idtac ]. exists (Float p (Zsucc (Fexp x))); split. repeat (split; simpl in |- *; auto with zarith arith). cut (1 <= p)%Z; [ intros H6 | idtac ]. apply Zle_trans with (p + 0)%Z; auto with zarith arith. apply Zle_trans with (p + (p - 1))%Z; auto with zarith arith. apply Zle_trans with (2 * p - 1)%Z; auto with zarith arith. apply Zle_trans with (radix * p - 1)%Z; auto with zarith arith. unfold Zminus in |- *; apply Zplus_le_compat_r. apply Zmult_le_compat_r; auto with zarith arith. CaseEq p; auto with zarith arith; intros H6. absurd (Z_of_nat (vNumSup b) = 0%Z); auto with zarith arith. rewrite Hs2; rewrite H6; ring. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *; rewrite powerRZ_Zs; auto with zarith real. rewrite H5; rewrite Hs2; ring_simplify; rewrite mult_IZR; ring. apply Zle_antisym; auto with zarith. Qed. Theorem ReductRangeIInv : forall b b' : FboundI, vNumInf b = vNumInf b' -> dExpI b = dExpI b' -> Z_of_nat (vNumSup b) = (vNumSup b' + 1)%Z -> (forall x : float, FboundedI b x -> exists y : float, FboundedI b' y /\ FtoRradix x = y) -> exists p : Z, Z_of_nat (vNumSup b) = (radix * p)%Z. intros b b' Hi He Hs H1. elim (H1 (Float (vNumSup b) 0)); [ intros y E; elim E; intros H'1 H'2; clear E | idtac ]. 2: repeat split; simpl in |- *; auto with zarith. cut (INR (vNumSup b) = FtoRradix y); [ intros H'3 | rewrite <- H'2; unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite <- INR_IZR_INZ; ring ]. cut (0 <= Zpred (Fexp y))%Z; [ intros H3 | idtac ]. exists (Fnum y * Zpower_nat radix (Zabs_nat (Zpred (Fexp y))))%Z. cut (forall a b : Z, IZR a = IZR b -> a = b); [ intros H4; apply H4 | idtac ]. repeat rewrite Rmult_IZR; repeat rewrite <- INR_IZR_INZ. rewrite Zpower_nat_powerRZ_absolu; auto with zarith arith; rewrite H'3. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *; unfold Zpred in |- *. apply trans_eq with (Fnum y * (radix * powerRZ radix (Fexp y + -1)))%R. pattern (IZR radix) at 2 in |- *; replace (IZR radix) with (powerRZ radix 1); [ rewrite <- powerRZ_add | simpl in |- * ]; auto with real zarith. replace (1 + (Fexp y + -1))%Z with (Fexp y); ring. repeat rewrite <- INR_IZR_INZ; ring. intros u v Hw; apply Zplus_reg_l with (- v)%Z. replace (- v + v)%Z with 0%Z; [ apply IZR_zero_r | ring ]. rewrite plus_IZR; rewrite Ropp_Ropp_IZR; auto with real. rewrite Hw; ring. apply Zlt_succ_le; rewrite <- Zsucc_pred. case (Zle_or_lt (Fexp y) 0); intros H3; auto. absurd (vNumSup b <= vNumSup b - 1)%Z; auto with arith zarith. apply le_IZR; rewrite <- INR_IZR_INZ; rewrite H'3. rewrite Hs; ring_simplify (vNumSup b' + 1 - 1)%Z; unfold FtoRradix, FtoR in |- *; simpl in |- *. apply Rle_trans with (Fnum y * powerRZ radix 0)%R. apply Rmult_le_compat_l; [ idtac | apply Rle_powerRZ; auto with real arith zarith ]. replace 0%R with (IZR 0); auto with real; apply Rle_IZR. apply LeR0Fnum with radix; auto; fold FtoRradix in |- *; rewrite <- H'3; auto with zarith real. simpl in |- *; ring_simplify; elim H'1; intros H4 H5; elim H4; auto with zarith real. Qed. End FboundedI_Def. Section FroundI. Variable radix : Z. Hypothesis radixMoreThanOne : (1 < radix)%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Variable b : FboundI. Hypothesis vNumSupGreaterThanOne : (1 <= vNumSup b)%Z. Hypothesis vNumInfGreaterThanOne : (1 <= vNumInf b)%Z. Definition isMinI (r : R) (min : float) := FboundedI b min /\ (min <= r)%R /\ (forall f : float, FboundedI b f -> (f <= r)%R -> (f <= min)%R). Definition isMaxI (r : R) (max : float) := FboundedI b max /\ (r <= max)%R /\ (forall f : float, FboundedI b f -> (r <= f)%R -> (max <= f)%R). Definition ProjectorPI (P : R -> float -> Prop) := forall p q : float, FboundedI b p -> P p q -> p = q :>R. Definition MonotonePI (P : R -> float -> Prop) := forall (p q : R) (p' q' : float), (p < q)%R -> P p p' -> P q q' -> (p' <= q')%R. Definition TotalPI (P : R -> float -> Prop) := forall r : R, exists p : float, P r p. Definition CompatiblePI (P : R -> float -> Prop) := forall (r1 r2 : R) (p q : float), P r1 p -> r1 = r2 -> p = q :>R -> FboundedI b q -> P r2 q. Definition MinOrMaxPI (P : R -> float -> Prop) := forall (r : R) (p : float), P r p -> isMinI r p \/ isMaxI r p. Definition RoundedModePI (P : R -> float -> Prop) := TotalPI P /\ CompatiblePI P /\ MinOrMaxPI P /\ MonotonePI P. Theorem ProjectMinI : ProjectorPI isMinI. red in |- *. intros p q H' H'0; apply Rle_antisym. elim H'0; intros H'1 H'2; elim H'2; intros H'3 H'4; apply H'4; clear H'2; auto with real. elim H'0; intros H'1 H'2; elim H'2; auto with real. Qed. Theorem ProjectMaxI : ProjectorPI isMaxI. red in |- *. intros p q H' H'0; apply Rle_antisym. elim H'0; intros H'1 H'2; elim H'2; auto with real. elim H'0; intros H'1 H'2; elim H'2; intros H'3 H'4; apply H'4; clear H'2; auto with real. Qed. Theorem RoundedProjectorI : forall P, RoundedModePI P -> ProjectorPI P. intros P H'; red in |- *; simpl in |- *. intros p q H'0 H'1. red in H'. elim H'; intros H'2 H'3; elim H'3; intros H'4 H'5; elim H'5; intros H'6 H'7; case (H'6 p q); clear H'5 H'3 H'; auto. intros H'; apply (ProjectMinI p); auto. intros H'; apply (ProjectMaxI p); auto. Qed. Theorem RoundedModeProjectorIdemI : forall P (p : float), RoundedModePI P -> FboundedI b p -> P p p. intros P p H' H. elim H'; intros H'0 H'1; elim H'1; intros H'2 H'3; elim H'3; intros H'4 H'5; clear H'3 H'1. case (H'0 p). intros x H'6. apply (H'2 p p x); auto. apply sym_eq; apply (RoundedProjectorI P H'); auto. Qed. Theorem OppositeIUnique_1 : forall (x y z : float) P, RoundedModePI P -> FboundedI b x -> FboundedI b y -> (- x < y)%R -> P (x + y)%R z -> (powerRZ radix (- dExpI b) <= z)%R. intros x y z P HP Fx Fy H1 H2. cut (powerRZ radix (- dExpI b) = Float 1 (- dExpI b)); [ intros V; rewrite V | unfold FtoRradix, FtoR in |- *; simpl in |- *; ring ]. cut (powerRZ radix (- dExpI b) <= x + y)%R; [ intros H'; case H'; clear H'; intros H' | idtac ]. red in HP; elim HP; intros HP1 tmp; elim tmp; intros HP2 tmp2; elim tmp2; intros HP3 HP4; clear tmp tmp2. apply HP4 with (powerRZ radix (- dExpI b)) (x + y)%R; auto. rewrite V; apply RoundedModeProjectorIdemI; auto. repeat (split; simpl in |- *; auto with zarith). cut (ProjectorPI P); [ intros HP' | apply RoundedProjectorI; auto ]. right; apply HP'; auto. repeat (split; simpl in |- *; auto with zarith). rewrite <- V; rewrite H'; auto. unfold FtoRradix in |- *; rewrite <- Fplus_correct; auto with zarith. apply Rle_trans with (1%Z * powerRZ radix (- dExpI b))%R; [ right; simpl; ring | idtac ]. unfold FtoR in |- *; simpl in |- *. apply Rle_trans with (1 * powerRZ radix (Zmin (Fexp x) (Fexp y)))%R. apply Rmult_le_compat_l; auto with real; apply Rle_powerRZ; auto with zarith real. apply Zmin_Zle; [ elim Fx | elim Fy ]; auto. apply Rmult_le_compat_r; auto with real zarith. cut (forall k : Z, (0 < k)%Z -> (1 <= k)%R); auto with real zarith; intros V'; apply V'. replace (Fnum x * Zpower_nat radix (Zabs_nat (Fexp x - Zmin (Fexp x) (Fexp y))) + Fnum y * Zpower_nat radix (Zabs_nat (Fexp y - Zmin (Fexp x) (Fexp y))))%Z with (Fnum (Fplus radix x y)); [ apply LtR0Fnum with radix | simpl in |- * ]; auto. rewrite Fplus_correct; auto with zarith real; apply Rplus_lt_reg_r with (- FtoR radix x)%R. ring_simplify; auto. Qed. Theorem OppositeIUnique_2 : forall (x y z : float) P, RoundedModePI P -> FboundedI b x -> FboundedI b y -> (y < - x)%R -> P (x + y)%R z -> (powerRZ radix (- dExpI b) <= - z)%R. intros x y z P HP Fx Fy H1 H2. apply Ropp_le_cancel; rewrite Ropp_involutive. cut ((- powerRZ radix (- dExpI b))%R = Float (-1) (- dExpI b)); [ intros V; rewrite V | unfold FtoRradix, FtoR in |- *; simpl in |- *; ring ]. cut (x + y <= - powerRZ radix (- dExpI b))%R; [ intros H'; case H'; clear H'; intros H' | idtac ]. red in HP; elim HP; intros HP1 tmp; elim tmp; intros HP2 tmp2; elim tmp2; intros HP3 HP4; clear tmp tmp2. apply HP4 with (x + y)%R (- powerRZ radix (- dExpI b))%R; auto. rewrite V; apply RoundedModeProjectorIdemI; auto. repeat (split; simpl in |- *; auto with zarith). cut (ProjectorPI P); [ intros HP' | apply RoundedProjectorI; auto ]. right; apply sym_eq; apply HP'; auto. repeat (split; simpl in |- *; auto with zarith). rewrite <- V; rewrite <- H'; auto. unfold FtoRradix in |- *; rewrite <- Fplus_correct; auto with zarith. apply Rle_trans with ((-1)%Z * powerRZ radix (- dExpI b))%R; [ idtac | right; auto with real zarith ]. unfold FtoR in |- *; simpl in |- *. apply Rle_trans with (-1 * powerRZ radix (Zmin (Fexp x) (Fexp y)))%R. apply Rmult_le_compat_r; auto with real zarith. apply Ropp_le_cancel; rewrite Ropp_involutive. cut (forall k : Z, (0 < - k)%Z -> (1 <= - k)%R); auto with real zarith. intros V'; apply V'. replace (- (Fnum x * Zpower_nat radix (Zabs_nat (Fexp x - Zmin (Fexp x) (Fexp y))) + Fnum y * Zpower_nat radix (Zabs_nat (Fexp y - Zmin (Fexp x) (Fexp y)))))%Z with (Fnum (Fopp (Fplus radix x y))); [ apply LtR0Fnum with radix | simpl in |- * ]; auto. rewrite Fopp_correct; rewrite Fplus_correct; auto with zarith real; apply Rplus_lt_reg_r with (FtoR radix y). ring_simplify; auto. intros k; replace (- k)%R with (IZR (- k)); auto with zarith real; apply Ropp_Ropp_IZR. apply Ropp_le_cancel; ring_simplify. apply Rle_powerRZ; auto with zarith real; apply Zmin_Zle; [ elim Fx | elim Fy ]; auto. Qed. Theorem OppositeIUnique : forall (x y z : float) P, RoundedModePI P -> FboundedI b x -> FboundedI b y -> (- x)%R <> y -> P (x + y)%R z -> (powerRZ radix (- dExpI b) <= Rabs z)%R. intros x y z P HP Fx Fy H1 H2. case (Rle_or_lt (- x) y); intros H3; [ case H3; intros H4 | idtac ]. apply Rle_trans with (FtoRradix z); [ idtac | apply RRle_abs ]. apply OppositeIUnique_1 with x y P; auto. absurd ((- FtoRradix x)%R = FtoRradix y); auto with real. rewrite <- Rabs_Ropp; apply Rle_trans with (- FtoRradix z)%R; [ idtac | apply RRle_abs ]. apply OppositeIUnique_2 with x y P; auto. Qed. End FroundI. Section FpropI. Variable radix : Z. Hypothesis radixMoreThanOne : (1 < radix)%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Variable b : FboundI. Theorem SterbenzIAux1 : forall x y : float, FboundedI b x -> FboundedI b y -> (y <= x)%R -> (x <= 2%nat * y)%R -> FboundedI b (Fminus radix x y). intros x y H' H'0 H'1 H'2. cut (0 <= Fminus radix x y)%R; [ intros Rle1 | idtac ]. cut (Fminus radix x y <= y)%R; [ intros Rle2 | idtac ]. case (Zle_or_lt (Fexp x) (Fexp y)); intros Zle1. repeat split. apply Zle_trans with 0%Z; auto with zarith. apply (LeR0Fnum radix); auto. apply Zle_trans with (Fnum x). apply Rle_Fexp_eq_Zle with (radix := radix); auto with arith. apply Rle_trans with (2 := H'1); auto. unfold Fminus in |- *; simpl in |- *; apply Zmin_le1; auto. elim H'; intuition. unfold Fminus in |- *; simpl in |- *; rewrite Zmin_le1; auto. elim H'; intuition. repeat split. apply Zle_trans with 0%Z; auto with zarith. apply (LeR0Fnum radix); auto. apply Zle_trans with (Fnum y). apply Rle_Fexp_eq_Zle with (radix := radix); auto with arith. unfold Fminus in |- *; simpl in |- *; apply Zmin_le2; auto with zarith. elim H'0; intuition. unfold Fminus in |- *; simpl in |- *; rewrite Zmin_le2; auto with zarith. elim H'0; intuition. rewrite (Fminus_correct radix); auto with zarith; fold FtoRradix in |- *. apply Rplus_le_reg_l with (r := FtoRradix y); auto with real. replace (y + (x - y))%R with (FtoRradix x); [ idtac | ring ]. replace (y + y)%R with (2%nat * y)%R; [ auto | simpl in |- *; ring ]. rewrite (Fminus_correct radix); auto with zarith; fold FtoRradix in |- *. apply Rplus_le_reg_l with (r := FtoRradix y); auto with real. replace (y + (x - y))%R with (FtoRradix x); [ auto with real | ring ]. replace (y + 0)%R with (FtoRradix y); [ auto | simpl in |- *; ring ]. Qed. Theorem SterbenzOppI : forall x y : float, (forall u : float, FboundedI b u -> exists v : float, FtoRradix v = (- u)%R /\ FboundedI b v) -> FboundedI b x -> FboundedI b y -> (/ 2%nat * y <= x)%R -> (x <= 2%nat * y)%R -> exists z : float, FtoRradix z = (x - y)%R /\ FboundedI b z. intros x y H1 Fx Fy H2 H3. case (Rle_or_lt y x); intros H4. exists (Fminus radix x y); split; auto with float real. unfold FtoRradix in |- *; rewrite Fminus_correct; auto with zarith. apply SterbenzIAux1; auto. cut (ex (fun v : float => FtoRradix v = (- FtoRradix (Fminus radix y x))%R /\ FboundedI b v)); [ intros H5; elim H5; intros v H6 | apply H1 ]. elim H6; clear H5 H6; intros H5 H6; exists v; split; auto. rewrite H5; unfold FtoRradix in |- *; rewrite Fminus_correct; auto with zarith real. apply SterbenzIAux1; auto with real. apply Rmult_le_reg_l with (/ 2%nat)%R; auto with real arith. apply Rle_trans with (1 := H2); right; field; auto with real arith. Qed. Theorem FoppBoundedI : forall (b : FboundI) (x : float) (m : nat), Z_of_nat (vNumSup b) = (radix * m - 1%nat)%Z -> Z_of_nat (vNumInf b) = (radix * m)%Z -> FboundedI b x -> exists y : float, FtoRradix y = (- x)%R /\ FboundedI b y. intros b0 x p H1 H2 Hx. cut (1 <= p); [ intros Hp | idtac ]. case (Zle_or_lt (- vNumInf b0) (Fnum x)); intros H3. 2: absurd (Fnum x < Fnum x)%Z; auto with zarith. 2: elim Hx; intuition; auto with zarith. cut (forall a b : Z, (a <= b)%Z -> a = b \/ (a < b)%Z); [ intros F | idtac ]. 2: intros a c V; omega. lapply (F (- vNumInf b0)%Z (Fnum x)); [ intros H'1 | auto ]. case H'1; intros H'2; clear H'1 F. exists (Float p (Zsucc (Fexp x))). repeat split. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *. rewrite <- H'2; rewrite H2; rewrite Ropp_Ropp_IZR. ring_simplify; unfold Zsucc in |- *; repeat rewrite <- INR_IZR_INZ. rewrite powerRZ_add; auto with zarith real; simpl in |- *. rewrite Rmult_IZR; repeat rewrite <- INR_IZR_INZ; ring. simpl in |- *; apply Zle_trans with 0%Z; auto with arith zarith. simpl in |- *; rewrite H1. apply Zle_trans with (p + p - 1%nat)%Z. apply Zplus_le_reg_l with (- p + 1%nat)%Z. replace (- p + 1%nat + p)%Z with (Z_of_nat 1); [ idtac | ring ]. replace (- p + 1%nat + (p + p - 1%nat))%Z with (Z_of_nat p); [ idtac | ring ]; auto with arith zarith. replace (p + p)%Z with (2%nat * p)%Z; unfold Zminus in |- *; auto with arith zarith. apply Zplus_le_compat_r; apply Zle_Zmult_comp_r; auto with arith zarith. replace (Z_of_nat 2) with 2%Z; auto with arith zarith. replace (Z_of_nat 2) with 2%Z; auto with arith zarith. simpl in |- *; apply Zle_trans with (Fexp x); auto with zarith; elim Hx; intuition. exists (Fopp x). repeat split; auto with real float arith zarith. unfold FtoRradix in |- *; apply Fopp_correct; auto. simpl in |- *; apply Zle_Zopp. apply Zle_trans with (Z_of_nat (vNumSup b0)); auto with zarith. elim Hx; intuition. simpl in |- *; rewrite <- (Zopp_involutive (vNumSup b0)); apply Zle_Zopp. apply Zlt_succ_le. replace (- vNumSup b0)%Z with (Zsucc (- vNumInf b0)). apply Zsucc_lt_compat; auto. rewrite H2; rewrite H1; rewrite <- Zopp_Zpred_Zs; auto with zarith. simpl in |- *; elim Hx; intuition. CaseEq p; auto with arith zarith. intros Hp; generalize H1; rewrite Hp; simpl in |- *. replace (radix * 0 - 1)%Z with (-1)%Z; [ auto with arith zarith | ring ]. Qed. Theorem FoppBoundedI2 : forall (b0 : FboundI) (x : float) (p : nat), Z_of_nat (vNumInf b0) = (radix * p - 1%nat)%Z -> Z_of_nat (vNumSup b0) = (radix * p)%Z -> FboundedI b0 x -> exists y : float, FtoRradix y = (- x)%R /\ FboundedI b0 y. intros b0 x p H1 H2 H3. elim FoppBoundedI with (BoundI (vNumSup b0) (vNumInf b0) (dExpI b0)) (Fopp x) p; auto. intros u tmp; elim tmp; intros H4 H5; clear tmp; exists (Fopp u); split. unfold FtoRradix in |- *; rewrite Fopp_correct; fold FtoRradix in |- *; rewrite H4; unfold FtoRradix in |- *; rewrite Fopp_correct; ring. elim H5; simpl in |- *; intros tmp H6; elim tmp; intros H7 H8; clear tmp; split; auto with zarith. unfold Fopp in |- *; simpl in |- *; split; auto with zarith. elim H3; simpl in |- *; intros tmp H6; elim tmp; intros H7 H8; clear tmp; split; auto with zarith. unfold Fopp in |- *; simpl in |- *; split; auto with zarith. Qed. Theorem FoppBoundedIInv_aux : forall n : Z, (vNumSup b + 1%nat <= - n)%Z -> (- n <= vNumInf b)%Z -> (forall x : float, FboundedI b x -> exists y : float, FtoRradix y = (- x)%R /\ FboundedI b y) -> exists p : Z, n = (radix * p)%Z. intros n H1 H2 H. elim (H (Float n 0)); [ intros y E; elim E; intros H'1 H'2; clear E | idtac ]. 2: repeat split; simpl in |- *; auto with zarith. cut (0 <= Zpred (Fexp y))%Z; [ intros H3 | idtac ]. exists (- (Fnum y * Zpower_nat radix (Zabs_nat (Zpred (Fexp y)))))%Z. cut (forall a b : Z, IZR a = IZR b -> a = b); [ intros H4; apply H4 | idtac ]. rewrite Rmult_IZR; rewrite Ropp_Ropp_IZR; rewrite Rmult_IZR. repeat rewrite <- INR_IZR_INZ. rewrite Zpower_nat_powerRZ_absolu; auto with zarith arith. replace (IZR n) with (- y)%R. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *; unfold Zpred in |- *. apply trans_eq with (- (Fnum y * (radix * powerRZ radix (Fexp y + -1))))%R. pattern (IZR radix) at 2 in |- *; replace (IZR radix) with (powerRZ radix 1); [ rewrite <- powerRZ_add | simpl in |- * ]; auto with real zarith. replace (1 + (Fexp y + -1))%Z with (Fexp y); ring. repeat rewrite <- INR_IZR_INZ; ring. replace (IZR n) with (FtoRradix (Float n 0)); auto with real float. rewrite H'1; rewrite Ropp_involutive; auto with real. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *; ring. intros u v Hw; apply Zplus_reg_l with (- v)%Z. replace (- v + v)%Z with 0%Z; [ apply IZR_zero_r | ring ]. rewrite plus_IZR; rewrite Ropp_Ropp_IZR; auto with real. rewrite Hw; ring. apply Zlt_succ_le; rewrite <- Zsucc_pred. case (Zle_or_lt (Fexp y) 0); intros H3; auto. absurd (vNumSup b + 1%nat <= vNumSup b)%Z. rewrite <- inj_plus; auto with arith zarith. apply Zle_trans with (- n)%Z; auto. apply le_IZR; rewrite Ropp_Ropp_IZR. replace (IZR n) with (FtoRradix (Float n 0)); [ idtac | unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *; ring ]. rewrite <- H'1; unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *. apply Rle_trans with (IZR (Fnum y)); [ idtac | elim H'2; intuition; auto with real ]. apply Rle_trans with (Fnum y * powerRZ radix 0)%R; [ idtac | simpl in |- *; right; ring ]. apply Rmult_le_compat_l; [ idtac | apply Rle_powerRZ; auto; apply Rlt_le; auto with real arith ]. replace 0%R with (IZR 0); auto with real; apply Rle_IZR. apply LeR0Fnum with radix; auto; fold FtoRradix in |- *. replace (FtoRradix y) with (IZR (- n)); auto with arith zarith. replace 0%R with (IZR 0); auto with arith zarith real. rewrite Ropp_Ropp_IZR. replace (IZR n) with (FtoRradix (Float n 0)); [ auto | unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *; ring ]. Qed. Theorem FoppBoundedIExp : forall (x : float) (p : nat), Z_of_nat (vNumSup b) = (radix * p - 1%nat)%Z -> Z_of_nat (vNumInf b) = (radix * p)%Z -> FboundedI b x -> exists y : float, FtoRradix y = (- x)%R /\ FboundedI b y /\ (Fexp y = Fexp x \/ Fexp y = Zsucc (Fexp x)). intros x p H1 H2 Hx. cut (1 <= p); [ intros Hp | idtac ]. case (Zle_or_lt (- vNumInf b) (Fnum x)); intros H3. 2: absurd (Fnum x < Fnum x)%Z; auto with zarith. 2: elim Hx; intuition; auto with zarith. cut (forall a b : Z, (a <= b)%Z -> a = b \/ (a < b)%Z); [ intros F | idtac ]. 2: intros a c V; omega. lapply (F (- vNumInf b)%Z (Fnum x)); [ intros H'1 | auto ]. case H'1; intros H'2; clear H'1 F. exists (Float p (Zsucc (Fexp x))). repeat split. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *. rewrite <- H'2; rewrite H2; rewrite Ropp_Ropp_IZR. ring_simplify; unfold Zsucc in |- *; repeat rewrite <- INR_IZR_INZ. rewrite powerRZ_add; auto with zarith real; simpl in |- *. rewrite Rmult_IZR; repeat rewrite <- INR_IZR_INZ; ring. simpl in |- *; apply Zle_trans with 0%Z; auto with arith zarith. simpl in |- *; rewrite H1. apply Zle_trans with (p + p - 1%nat)%Z. apply Zplus_le_reg_l with (- p + 1%nat)%Z. replace (- p + 1%nat + p)%Z with (Z_of_nat 1); [ idtac | ring ]. replace (- p + 1%nat + (p + p - 1%nat))%Z with (Z_of_nat p); [ idtac | ring ]; auto with arith zarith. replace (p + p)%Z with (2%nat * p)%Z; unfold Zminus in |- *; auto with arith zarith. apply Zplus_le_compat_r; apply Zle_Zmult_comp_r; auto with arith zarith. replace (Z_of_nat 2) with 2%Z; auto with arith zarith. replace (Z_of_nat 2) with 2%Z; auto with arith zarith. simpl in |- *; apply Zle_trans with (Fexp x); auto with zarith; elim Hx; intuition. simpl in |- *; auto with zarith. exists (Fopp x). repeat split; auto with real float arith zarith. unfold FtoRradix in |- *; apply Fopp_correct; auto. simpl in |- *; apply Zle_Zopp. apply Zle_trans with (Z_of_nat (vNumSup b)); auto with zarith. elim Hx; intuition. simpl in |- *; rewrite <- (Zopp_involutive (vNumSup b)); apply Zle_Zopp. apply Zlt_succ_le. replace (- vNumSup b)%Z with (Zsucc (- vNumInf b)). apply Zsucc_lt_compat; auto. rewrite H2; rewrite H1; rewrite <- Zopp_Zpred_Zs; auto with zarith. simpl in |- *; elim Hx; intuition. CaseEq p; auto with arith zarith. intros Hp; generalize H1; rewrite Hp; simpl in |- *. replace (radix * 0 - 1)%Z with (-1)%Z; [ auto with arith zarith | ring ]. Qed. Theorem nat_div_one : forall n m : nat, m * n = 1 -> m = 1. intros n m; case m; case n; simpl in |- *; auto with arith. intros n'; rewrite mult_comm; simpl in |- *; intros; discriminate. intros n' n''; case n''; simpl in |- *; auto with arith. intros n0; replace (S (n' + S (n' + n0 * S n'))) with (S (S (n' + (n' + n0 * S n')))); auto with arith. intros; discriminate. Qed. Theorem Z_div_one : forall (n : nat) (z : Z), (z * Z_of_nat n)%Z = Z_of_nat 1 -> n = 1. intros n z H. cut (0 < n); [ intros L1 | idtac ]. apply (nat_div_one (Zabs_nat z)). apply inject_nat_eq; rewrite inj_mult; rewrite inj_abs. rewrite Zmult_comm; auto with arith. apply le_IZR; apply Rmult_le_reg_l with (IZR (Z_of_nat n)); repeat rewrite <- Rmult_IZR; auto with real arith zarith. replace (n * 0)%Z with (Z_of_nat 0); auto with zarith arith. rewrite Zmult_comm; apply Rle_IZR; rewrite H; auto with zarith arith. replace (Z_of_nat 0) with 0%Z; auto with zarith arith. generalize H; case n; simpl in |- *; auto with zarith arith. Qed. Theorem FoppBoundedIInv : (vNumSup b < vNumInf b)%Z -> (forall x : float, FboundedI b x -> exists y : float, FtoRradix y = (- x)%R /\ FboundedI b y) -> (exists m : Z, Z_of_nat (vNumInf b) = (radix * m)%Z) /\ Z_of_nat (vNumInf b) = (vNumSup b + 1%nat)%Z. intros H1 H2. generalize FoppBoundedIInv_aux; intros H3. elim (H3 (- (vNumSup b + 1%nat))%Z); [ intros p E | idtac | idtac | idtac ]; auto with zarith. 2: rewrite Zopp_involutive; auto with zarith arith. 2: replace (vNumSup b + 1%nat)%Z with (Zsucc (vNumSup b)); auto with zarith arith. case (Zle_or_lt (vNumInf b) (vNumSup b + 1%nat)); intros H4. cut (Z_of_nat (vNumInf b) = (vNumSup b + 1%nat)%Z); [ intros H5 | idtac ]. 2: apply Zeq_Zs; auto with zarith arith. 2: replace (vNumSup b + 1%nat)%Z with (Zsucc (vNumSup b)); auto with zarith arith. repeat split; auto with zarith. exists (- p)%Z; rewrite H5. replace (radix * - p)%Z with (- (radix * p))%Z; [ rewrite <- E | idtac ]; ring. elim (H3 (- (vNumSup b + 2%nat))%Z); [ intros p0 E0 | idtac | idtac | idtac ]; auto with zarith. 2: rewrite Zopp_involutive; apply Zplus_le_compat_l; auto with zarith arith. 2: rewrite Zopp_involutive; replace (vNumSup b + 2%nat)%Z with (Zsucc (vNumSup b + 1%nat)); [ apply Zlt_le_succ | idtac ]; auto with zarith arith. 2: replace (vNumSup b + 2%nat)%Z with (vNumSup b + (1%nat + 1%nat))%Z; auto with zarith arith. 2: replace (vNumSup b + (1%nat + 1%nat))%Z with (vNumSup b + 1%nat + 1%nat)%Z; auto with zarith arith. absurd (Z_of_nat 1 = Zabs_nat radix); auto with arith zarith. apply Zlt_not_eq; auto with arith zarith. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with arith zarith. cut (forall n : nat, (exists p : Z, Z_of_nat 1 = (p * n)%Z) -> Z_of_nat 1 = n); [ intros H5 | idtac ]. apply H5; auto; exists (p - p0)%Z. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with arith zarith. apply trans_eq with (radix*p-radix*p0)%Z; try ring. rewrite <- E0; rewrite <- E; ring. intros n V; elim V; intros r W. apply sym_eq; apply inj_eq; apply Z_div_one with r; auto with arith. Qed. Theorem SterbenzIAux2A : forall (x y : float) (n : nat), Zabs_nat (vNumInf b - vNumSup b) <= n -> FboundedI b x -> FboundedI b y -> (Fexp y <= Fexp x)%Z -> (y <= x)%R -> (x <= 2%nat * y - n * powerRZ radix (Fexp y))%R -> (Fminus radix y x <= 0)%R -> (- vNumInf b <= - vNumSup b + n)%Z -> FboundedI b (Fminus radix y x). intros x y n H H' H'0 Zle2 H'1 H'2 Rle1 Zle1. repeat split. apply Zle_trans with (- vNumSup b + n)%Z; auto with zarith. apply Zle_trans with (- Fnum y + n)%Z; auto with zarith. apply Zplus_le_compat_r; apply Zle_Zopp; unfold FboundedI in H'0; intuition. replace (- Fnum y + n)%Z with (Fnum (Fplus radix (Fopp y) (Float n (Fexp y)))). apply Rle_Fexp_eq_Zle with (radix := radix); auto with arith. rewrite Fminus_correct; auto with zarith; rewrite Fplus_correct; auto with zarith; rewrite Fopp_correct. apply Rplus_le_reg_l with (x + - (- FtoR radix y + FtoR radix (Float n (Fexp y))))%R. replace (x + - (- FtoR radix y + FtoR radix (Float n (Fexp y))) + (- FtoR radix y + FtoR radix (Float n (Fexp y))))%R with ( FtoRradix x); [ idtac | ring ]. replace (x + - (- FtoR radix y + FtoR radix (Float n (Fexp y))) + (FtoR radix y - FtoR radix x))%R with (2%nat * y - Float n (Fexp y))%R. replace (FtoRradix (Float n (Fexp y))) with (n * powerRZ radix (Fexp y))%R; auto. unfold FtoRradix, FtoR; simpl; rewrite <- INR_IZR_INZ; auto with real. replace (2%nat * y)%R with (y + y)%R; unfold FtoRradix in |- *; [ ring; ring | simpl in |- *; ring ]. unfold Fminus in |- *; simpl in |- *; repeat rewrite Zmin_le1; auto with zarith. unfold Fplus in |- *; simpl in |- *. repeat rewrite Zmin_le1; auto with zarith; simpl in |- *. replace (Zabs_nat (Fexp y - Fexp y)) with 0; auto with zarith. unfold Zpower_nat in |- *; simpl in |- *; ring. replace (Fexp y - Fexp y)%Z with 0%Z; auto with arith zarith. apply Zle_trans with 0%Z; auto with zarith. rewrite <- (Zopp_involutive (Fnum (Fminus radix y x))). replace 0%Z with (- (0))%Z; auto with zarith; apply Zle_Zopp. replace (- Fnum (Fminus radix y x))%Z with (Fnum (Fopp (Fminus radix y x))); [ idtac | unfold Fopp in |- *; simpl in |- * ]. apply (LeR0Fnum radix); auto. rewrite Fopp_correct. replace 0%R with (-0)%R; auto with real; apply Ropp_le_ge_contravar. ring. unfold Fminus in |- *; simpl in |- *. rewrite Zmin_le1; auto with zarith. elim H'0; intuition. Qed. Theorem SterbenzIAux2B : forall (x y : float) (n : nat), Zabs_nat (vNumInf b - vNumSup b) <= n -> FboundedI b x -> FboundedI b y -> (Fexp x <= Fexp y)%Z -> (y <= 0)%R -> (y <= x)%R -> (x <= 2%nat * y - n * powerRZ radix (Fexp x))%R -> (Fminus radix y x <= 0)%R -> (- vNumInf b <= - vNumSup b + n)%Z -> FboundedI b (Fminus radix y x). intros x y n H H' H'0 Zle2 H'1 H'2 Rle1 Zle1 G. repeat split. apply Zle_trans with (- vNumSup b + n)%Z; auto with zarith. apply Zle_trans with (- Fnum y + n)%Z; auto with zarith. apply Zplus_le_compat_r; apply Zle_Zopp; unfold FboundedI in H'0; intuition. apply Zle_trans with (- Fnum y * Zpower_nat radix (Zabs_nat (Fexp y - Fexp x)) + n)%Z. apply Zplus_le_compat_r. pattern (- Fnum y)%Z at 1 in |- *; replace (- Fnum y)%Z with (- Fnum y * Zpower_nat radix 0)%Z. 2: unfold Zpower_nat in |- *; simpl in |- *; auto with arith zarith. apply Zle_Zmult_comp_l. replace (- Fnum y)%Z with (Fnum (Fopp y)); auto with float. apply LeR0Fnum with radix; auto with float real. rewrite Fopp_correct; auto with float real. apply le_IZR. rewrite Zpower_nat_powerRZ_absolu; auto with zarith. rewrite Zpower_nat_Z_powerRZ; auto with zarith real. apply Rle_powerRZ; auto with real zarith. apply le_IZR; rewrite plus_IZR; rewrite Rmult_IZR; rewrite Ropp_Ropp_IZR. rewrite Zpower_nat_powerRZ_absolu; auto with zarith. apply Rle_monotony_contra_exp with radix (Fexp x); auto. apply Rle_trans with (- Fnum y * (powerRZ radix (Fexp y - Fexp x) * powerRZ radix (Fexp x)) + powerRZ radix (Fexp x) * n)%R; [ right; repeat rewrite <- INR_IZR_INZ; ring | idtac ]. rewrite <- powerRZ_add; auto with real zarith. replace (Fexp y - Fexp x + Fexp x)%Z with (Fexp y); [ idtac | ring ]. replace (- Fnum y * powerRZ radix (Fexp y))%R with (- y)%R; [ idtac | unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *; ring ]. replace (Fnum (Fminus radix y x) * powerRZ radix (Fexp x))%R with (y - x)%R. apply Rplus_le_reg_l with (y + x + - (n * powerRZ radix (Fexp x)))%R. apply Rle_trans with (FtoRradix x); [ right; ring | idtac ]. apply Rle_trans with (y + y - n * powerRZ radix (Fexp x))%R; [ idtac | right; ring ]. replace (y + y)%R with (2%nat * y)%R; [ auto | simpl in |- *; ring ]. unfold FtoRradix in |- *; rewrite <- Fminus_correct; auto with zarith. unfold FtoR in |- *; replace (Fexp (Fminus radix y x)) with (Fexp x); auto with real. unfold Fminus in |- *; simpl in |- *; auto with zarith. rewrite Zmin_le2; auto with zarith. apply Zle_trans with 0%Z; auto with zarith. rewrite <- (Zopp_involutive (Fnum (Fminus radix y x))). replace 0%Z with (- (0))%Z; auto with zarith; apply Zle_Zopp. replace (- Fnum (Fminus radix y x))%Z with (Fnum (Fopp (Fminus radix y x))); [ idtac | unfold Fopp in |- *; simpl in |- * ]. apply (LeR0Fnum radix); auto. rewrite Fopp_correct. replace 0%R with (-0)%R; auto with real; apply Ropp_le_ge_contravar. ring. unfold Fminus in |- *; simpl in |- *. rewrite Zmin_le2; auto with zarith; unfold FboundedI in H'; intuition. Qed. Theorem SterbenzIAux2 : forall (x y : float) (n : nat), Zabs_nat (vNumInf b - vNumSup b) <= n -> FboundedI b x -> FcanonicI radix b y -> FboundedI b y -> (y <= x)%R -> (x <= 2%nat * y - n * powerRZ radix (Zmin (Fexp y) (Fexp x)))%R -> FboundedI b (Fminus radix y x). intros x y n H H' Hcan H'0 H'1 H'2. cut (Fminus radix y x <= 0)%R; [ intros Rle1 | idtac ]. 2: rewrite (Fminus_correct radix); auto with zarith; fold FtoRradix in |- *. 2: apply Rplus_le_reg_l with (r := FtoRradix x); auto. 2: replace (x + (y - x))%R with (FtoRradix y); [ idtac | ring ]. 2: replace (x + 0)%R with (FtoRradix x); [ auto | simpl in |- *; ring ]. cut (- vNumInf b <= - vNumSup b + n)%Z; [ intros Zle1 | idtac ]. 2: replace (- vNumSup b + n)%Z with (- (vNumSup b + - n))%Z; [ apply Zle_Zopp | ring ]. 2: apply le_IZR; rewrite plus_IZR; rewrite Ropp_Ropp_IZR. 2: apply Rplus_le_reg_l with (n + - vNumInf b)%R. 2: apply Rle_trans with (vNumSup b - vNumInf b)%R; [ right; repeat rewrite <- INR_IZR_INZ; ring | idtac ]. 2: apply Rle_trans with (INR n); [ idtac | right; rewrite <- INR_IZR_INZ; ring ]. 2: rewrite <- (Rabs_right (vNumSup b)); auto with real arith. 2: rewrite <- (Rabs_right (vNumInf b)); auto with real arith. 2: apply Rle_trans with (Rabs (vNumSup b - vNumInf b)); [ apply Rabs_triang_inv | idtac ]. 2: rewrite <- Rabs_Ropp. 2: replace (- (vNumSup b - vNumInf b))%R with (vNumInf b - vNumSup b)%R; [ idtac | ring ]. 2: repeat rewrite INR_IZR_INZ; rewrite Z_R_minus. 2: rewrite Faux.Rabsolu_Zabs; rewrite Zabs_absolu; auto with arith zarith real. case (Zle_or_lt (Fexp y) (Fexp x)); intros Zle3. apply SterbenzIAux2A with n; auto. rewrite <- (Zmin_le1 (Fexp y) (Fexp x)); auto with zarith. case (Rle_or_lt 0 y); intros Rle2. absurd (Fexp x < Fexp y)%Z; auto. apply Zle_not_lt. apply LexicoPosCanI with radix b; auto. apply SterbenzIAux2B with n; auto with zarith real float arith. rewrite <- (Zmin_le2 (Fexp y) (Fexp x)); auto with zarith. Qed. Theorem SterbenzI : forall (x y : float) (n : nat), Zabs_nat (vNumInf b - vNumSup b) <= n -> FboundedI b x -> FcanonicI radix b x -> FboundedI b y -> (/ 2%nat * y + / 2%nat * (n * powerRZ radix (Zmin (Fexp x) (Fexp y))) <= x)%R -> (x <= 2%nat * y)%R -> FboundedI b (Fminus radix x y). intros x y n Hn H H' H'0 H'1 H'2. case (Rle_or_lt x y); intros Le2; auto. apply SterbenzIAux2 with n; auto with real. apply Rplus_le_reg_l with (n * powerRZ radix (Zmin (Fexp x) (Fexp y)))%R. rewrite Rplus_comm. apply Rle_trans with (2%nat * x)%R; [ idtac | right; ring ]. apply Rmult_le_reg_l with (r := (/ 2%nat)%R); [ apply Rinv_0_lt_compat; auto with real | idtac ]. rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real; ring_simplify (1 * FtoRradix x)%R. apply Rle_trans with (2 := H'1); right; ring. apply SterbenzIAux1; auto with real. Qed. End FpropI. Section SterbenzApproxIAux. Variable radix : Z. Hypothesis radixMoreThanOne : (1 < radix)%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Variables (b1 : FboundI) (b2 : FboundI). Theorem SterbenzApproxI_aux1 : forall (rho : R) (x y : float), (0 < rho)%R -> IZR (Zsucc (vNumSup b1)) = (rho * Zsucc (vNumSup b2))%R -> (- dExpI b2 <= - dExpI b1)%Z -> FboundedI b1 x -> FboundedI b1 y -> (0 <= y)%R -> (y <= x)%R -> (x <= (1 + / rho) * y)%R -> FboundedI b2 (Fminus radix x (FnormalizeI radix b1 y)). intros rho x y H1 H2 H'' H3 H4 H5 H6 H7. cut (0 <= Fminus radix x (FnormalizeI radix b1 y))%R; [ intros Rle1 | idtac ]. 2: rewrite (Fminus_correct radix); auto with zarith; fold FtoRradix in |- *. 2: unfold FtoRradix in |- *; rewrite FnormalizeICorrect; auto. 2: apply Rplus_le_reg_l with (r := FtoR radix y); auto. 2: fold FtoRradix in |- *; ring_simplify; auto with real. cut (Fexp (Fminus radix x (FnormalizeI radix b1 y)) = Fexp (FnormalizeI radix b1 y)); [ intros He | idtac ]. 2: unfold Fminus in |- *; simpl in |- *; apply Zmin_le2. 2: apply LexicoPosCanI with radix b1; auto with zarith; [ apply FnormalizeIFcanonicI; auto | idtac | idtac ]; rewrite FnormalizeICorrect; auto. split; [ split | idtac ]. apply Zle_trans with 0%Z; auto with zarith; apply LeR0Fnum with radix; auto. apply Zgt_succ_le; apply Zlt_gt; apply Zlt_Rlt. apply Rle_lt_trans with ((x - y) * powerRZ radix (- Fexp (FnormalizeI radix b1 y)))%R. right; apply trans_eq with (Fminus radix x (FnormalizeI radix b1 y) * powerRZ radix (- Fexp (Fminus radix x (FnormalizeI radix b1 y))))%R. unfold FtoRradix, FtoR in |- *; rewrite Rmult_assoc. rewrite <- powerRZ_add; auto with zarith real. ring_simplify (Fexp (Fminus radix x (FnormalizeI radix b1 y)) + - Fexp (Fminus radix x (FnormalizeI radix b1 y)))%Z; simpl in |- *; ring. unfold FtoRradix in |- *; rewrite Fminus_correct; auto with zarith. rewrite <- FnormalizeICorrect with radix b1 y; auto. rewrite He; ring. apply Rle_lt_trans with (/ rho * FtoRradix y * powerRZ radix (- Fexp (FnormalizeI radix b1 y)))%R. apply Rmult_le_compat_r; auto with real zarith. apply Rplus_le_reg_l with (FtoRradix y); auto. ring_simplify (FtoRradix y + (FtoRradix x - FtoRradix y))%R. apply Rle_trans with (1 := H7); right; ring. apply Rle_lt_trans with (/ rho * Fnum (FnormalizeI radix b1 y))%R. unfold FtoRradix in |- *; rewrite <- FnormalizeICorrect with radix b1 y; auto. right; unfold FtoR in |- *. apply trans_eq with (/ rho * (powerRZ radix (- Fexp (FnormalizeI radix b1 y)) * powerRZ radix (Fexp (FnormalizeI radix b1 y))) * Fnum (FnormalizeI radix b1 y))%R. ring. rewrite <- powerRZ_add; auto with zarith real. ring_simplify (- Fexp (FnormalizeI radix b1 y) + Fexp (FnormalizeI radix b1 y))%Z; simpl in |- *; ring. apply Rlt_le_trans with (/ rho * Zsucc (vNumSup b1))%R. apply Rmult_lt_compat_l; auto with real. cut (FboundedI b1 (FnormalizeI radix b1 y)); [ intros H8 | apply FnormalizeIBounded; auto ]. apply Rlt_IZR. elim H8; intros H' H'1; elim H'; auto with zarith real. right; rewrite H2; rewrite <- Rmult_assoc; rewrite Rinv_l; [ ring | auto with zarith real ]. apply Zle_trans with (- dExpI b1)%Z; auto with zarith; rewrite He. cut (FboundedI b1 (FnormalizeI radix b1 y)); [ intros H8 | apply FnormalizeIBounded; auto ]. elim H8; auto with zarith real. Qed. Theorem SterbenzApproxI_1 : forall (rho : R) (x y : float), (0 < rho)%R -> IZR (Zsucc (vNumSup b1)) = (rho * Zsucc (vNumSup b2))%R -> (- dExpI b2 <= - dExpI b1)%Z -> (forall x : float, FboundedI b2 x -> exists y : float, y = (- x)%R :>R /\ FboundedI b2 y) -> FboundedI b1 x -> FboundedI b1 y -> (/ (1 + / rho) * y <= x)%R -> (x <= (1 + / rho) * y)%R -> exists u : float, u = (x - y)%R :>R /\ FboundedI b2 u. intros rho x y Hrho Hv1 Hv2 Hv4 F1x F1y H1 H2. cut (0 < 1 + / rho)%R; [ intros H' | idtac ]. 2: apply Rlt_trans with (1 + 0)%R; [ ring_simplify (1 + 0)%R | apply Rplus_lt_compat_l ]; auto with real. case (Rle_or_lt y x); intros H3. case (Rcase_abs (FtoRradix y)); intros H4. absurd (0 <= / rho * FtoRradix y)%R. apply Rlt_not_le; replace 0%R with (/ rho * 0)%R; [ idtac | ring ]. apply Rmult_lt_compat_l; auto with real; apply Rinv_0_lt_compat; apply Rlt_le_trans with 1%R; auto with real. apply Rplus_le_reg_l with (FtoRradix y); ring_simplify (FtoRradix y + 0)%R. apply Rle_trans with (1 := H3); apply Rle_trans with (1 := H2); right; ring. exists (Fminus radix x (FnormalizeI radix b1 y)); split. unfold FtoRradix in |- *; rewrite Fminus_correct; auto with zarith. rewrite FnormalizeICorrect; auto with zarith. apply SterbenzApproxI_aux1 with rho; auto with real float. case (Rcase_abs (FtoRradix y)); intros H4. absurd (0 <= / rho * FtoRradix y)%R. apply Rlt_not_le; replace 0%R with (/ rho * 0)%R; [ idtac | ring ]. apply Rmult_lt_compat_l; auto with real. apply Rplus_le_reg_l with (FtoRradix y); ring_simplify (FtoRradix y + 0)%R. apply Rmult_le_reg_l with (/ (1 + / rho))%R; auto with real. apply Rle_trans with (1 := H1); apply Rle_trans with (FtoRradix y); auto with real. right; apply trans_eq with (FtoRradix y * ((1 + / rho) * / (1 + / rho)))%R; [ idtac | ring; ring ]. rewrite Rinv_r; auto with real. replace (FtoRradix x - FtoRradix y)%R with (- Fminus radix y (FnormalizeI radix b1 x))%R. 2: unfold FtoRradix in |- *; rewrite Fminus_correct; auto with zarith. 2: rewrite FnormalizeICorrect; auto with zarith; ring. apply Hv4. apply SterbenzApproxI_aux1 with rho; auto with real float. apply Rle_trans with (2 := H1); apply Rmult_le_pos; auto with real. apply Rmult_le_reg_l with (/ (1 + / rho))%R; auto with real. apply Rle_trans with (1 := H1). rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real. Qed. Theorem SterbenzApproxI_aux2 : forall (rho : R) (x y : float), (0 < rho)%R -> IZR (Zsucc (vNumSup b1)) = (rho * Zsucc (vNumInf b2))%R -> (- dExpI b2 <= - dExpI b1)%Z -> FboundedI b1 x -> FboundedI b1 y -> (0 <= y)%R -> (y <= x)%R -> (x <= (1 + / rho) * y)%R -> FboundedI b2 (Fminus radix (FnormalizeI radix b1 y) x). intros rho x y H1 H2 H'' H3 H4 H5 H6 H7. cut (Fminus radix (FnormalizeI radix b1 y) x <= 0)%R; [ intros Rle1 | idtac ]. 2: rewrite (Fminus_correct radix); auto with zarith; fold FtoRradix in |- *. 2: unfold FtoRradix in |- *; rewrite FnormalizeICorrect; auto. 2: apply Rplus_le_reg_l with (r := FtoR radix x); auto. 2: fold FtoRradix in |- *; ring_simplify; auto with real. cut (Fexp (Fminus radix (FnormalizeI radix b1 y) x) = Fexp (FnormalizeI radix b1 y)); [ intros He | idtac ]. 2: unfold Fminus in |- *; simpl in |- *; apply Zmin_le1. 2: apply LexicoPosCanI with radix b1; auto with zarith float real. 2: apply FnormalizeIFcanonicI; auto. 2: rewrite FnormalizeICorrect; auto. 2: rewrite FnormalizeICorrect; auto. split; [ split | idtac ]. 2: apply Zle_trans with 0%Z; auto with zarith; apply R0LeFnum with radix; auto. 2: apply Zle_trans with (- dExpI b1)%Z; auto with zarith; rewrite He. 2: cut (FboundedI b1 (FnormalizeI radix b1 y)); [ intros H8 | apply FnormalizeIBounded; auto ]. 2: elim H8; auto with zarith real. apply Zle_Zopp_Inv; rewrite Zopp_involutive. apply Zgt_succ_le; apply Zlt_gt; apply Zlt_Rlt. apply Rle_lt_trans with ((x - y) * powerRZ radix (- Fexp (FnormalizeI radix b1 y)))%R. right; apply trans_eq with (Fminus radix x (FnormalizeI radix b1 y) * powerRZ radix (- Fexp (Fminus radix x (FnormalizeI radix b1 y))))%R. unfold FtoRradix, FtoR in |- *; rewrite Rmult_assoc. rewrite <- powerRZ_add; auto with zarith real. apply trans_eq with (IZR (Fnum (Fopp (Fminus radix (FnormalizeI radix b1 y) x)))); [ unfold Fopp in |- *; simpl in |- *; auto | rewrite Fopp_Fminus ]. ring_simplify (Fexp (Fminus radix x (FnormalizeI radix b1 y)) + - Fexp (Fminus radix x (FnormalizeI radix b1 y)))%Z; simpl in |- *; ring. unfold FtoRradix in |- *; rewrite Fminus_correct; auto with zarith. rewrite <- FnormalizeICorrect with radix b1 y; auto. replace (Fexp (Fminus radix x (FnormalizeI radix b1 y))) with (Fexp (Fminus radix (FnormalizeI radix b1 y) x)). rewrite He; ring. unfold Fminus in |- *; simpl in |- *; auto with zarith; apply Zmin_sym. apply Rle_lt_trans with (/ rho * FtoRradix y * powerRZ radix (- Fexp (FnormalizeI radix b1 y)))%R. apply Rmult_le_compat_r; auto with real zarith. apply Rplus_le_reg_l with (FtoRradix y); auto. ring_simplify (FtoRradix y + (FtoRradix x - FtoRradix y))%R. apply Rle_trans with (1 := H7); right; ring. apply Rle_lt_trans with (/ rho * Fnum (FnormalizeI radix b1 y))%R. unfold FtoRradix in |- *; rewrite <- FnormalizeICorrect with radix b1 y; auto. right; unfold FtoR in |- *. apply trans_eq with (/ rho * (powerRZ radix (- Fexp (FnormalizeI radix b1 y)) * powerRZ radix (Fexp (FnormalizeI radix b1 y))) * Fnum (FnormalizeI radix b1 y))%R. ring. rewrite <- powerRZ_add; auto with zarith real. ring_simplify (- Fexp (FnormalizeI radix b1 y) + Fexp (FnormalizeI radix b1 y))%Z; simpl in |- *; ring. apply Rlt_le_trans with (/ rho * Zsucc (vNumSup b1))%R. apply Rmult_lt_compat_l; auto with real. cut (FboundedI b1 (FnormalizeI radix b1 y)); [ intros H8 | apply FnormalizeIBounded; auto ]. apply Rlt_IZR. elim H8; intros H' H'1; elim H'; auto with zarith real. right; rewrite H2; rewrite <- Rmult_assoc; rewrite Rinv_l; [ ring | auto with zarith real ]. Qed. Theorem SterbenzApproxI_2 : forall (rho : R) (x y : float), (0 < rho)%R -> IZR (Zsucc (vNumSup b1)) = (rho * Zsucc (vNumInf b2))%R -> (- dExpI b2 <= - dExpI b1)%Z -> (forall x : float, FboundedI b2 x -> exists y : float, y = (- x)%R :>R /\ FboundedI b2 y) -> FboundedI b1 x -> FboundedI b1 y -> (/ (1 + / rho) * y <= x)%R -> (x <= (1 + / rho) * y)%R -> exists u : float, u = (x - y)%R :>R /\ FboundedI b2 u. intros rho x y Hrho Hv1 Hv2 Hv4 F1x F1y H1 H2. cut (0 < 1 + / rho)%R; [ intros H' | idtac ]. 2: apply Rlt_trans with (1 + 0)%R; [ ring_simplify (1 + 0)%R | apply Rplus_lt_compat_l ]; auto with real. case (Rle_or_lt y x); intros H3. case (Rcase_abs (FtoRradix y)); intros H4. absurd (0 <= / rho * FtoRradix y)%R. apply Rlt_not_le; replace 0%R with (/ rho * 0)%R; [ idtac | ring ]. apply Rmult_lt_compat_l; auto with real; apply Rinv_0_lt_compat; apply Rlt_le_trans with 1%R; auto with real. apply Rplus_le_reg_l with (FtoRradix y); ring_simplify (FtoRradix y + 0)%R. apply Rle_trans with (1 := H3); apply Rle_trans with (1 := H2); right; ring. replace (FtoRradix x - FtoRradix y)%R with (- Fminus radix (FnormalizeI radix b1 y) x)%R. 2: unfold FtoRradix in |- *; rewrite Fminus_correct; auto with zarith. 2: rewrite FnormalizeICorrect; auto with zarith; ring. apply Hv4. apply SterbenzApproxI_aux2 with rho; auto with real float. case (Rcase_abs (FtoRradix y)); intros H4. absurd (0 <= / rho * FtoRradix y)%R. apply Rlt_not_le; replace 0%R with (/ rho * 0)%R; [ idtac | ring ]. apply Rmult_lt_compat_l; auto with real. apply Rplus_le_reg_l with (FtoRradix y); ring_simplify (FtoRradix y + 0)%R. apply Rmult_le_reg_l with (/ (1 + / rho))%R; auto with real. apply Rle_trans with (1 := H1); apply Rle_trans with (FtoRradix y); auto with real. right; apply trans_eq with (FtoRradix y * ((1 + / rho) * / (1 + / rho)))%R; [ idtac | ring; ring ]. rewrite Rinv_r; auto with real. exists (Fminus radix (FnormalizeI radix b1 x) y); split. unfold FtoRradix in |- *; rewrite Fminus_correct; auto with zarith. rewrite FnormalizeICorrect; auto with zarith. apply SterbenzApproxI_aux2 with rho; auto with real float. apply Rle_trans with (2 := H1); apply Rmult_le_pos; auto with real. apply Rmult_le_reg_l with (/ (1 + / rho))%R; auto with real. apply Rle_trans with (1 := H1). rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real. Qed. End SterbenzApproxIAux. Section SterbenzApproxI. Variable radix : Z. Hypothesis radixMoreThanOne : (1 < radix)%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Variables (b1 : FboundI) (b2 : FboundI). Theorem SterbenzApproxI_3 : forall (rho : R) (x y : float), (0 < rho)%R -> IZR (Zsucc (vNumInf b1)) = (rho * Zsucc (vNumInf b2))%R -> (- dExpI b2 <= - dExpI b1)%Z -> (forall x : float, FboundedI b2 x -> exists y : float, y = (- x)%R :>R /\ FboundedI b2 y) -> FboundedI b1 x -> FboundedI b1 y -> (x <= / (1 + / rho) * y)%R -> ((1 + / rho) * y <= x)%R -> exists u : float, u = (x - y)%R :>R /\ FboundedI b2 u. intros rho x y Hrho Hv1 Hv2 Hv3 Hx Hy Hxy1 Hxy2. cut (forall (b : FboundI) (z : float), FboundedI b z -> FboundedI (BoundI (vNumSup b) (vNumInf b) (dExpI b)) (Fopp z)); [ intros V | intros b z Hz ]. 2: elim Hz; intros Hz1 Hz2; elim Hz1; intros Hz3 Hz4; split; auto with zarith. 2: split; unfold Fopp in |- *; simpl in |- *; auto with zarith. cut (forall (b : FboundI) (z : float), FboundedI (BoundI (vNumSup b) (vNumInf b) (dExpI b)) z -> FboundedI b (Fopp z)); [ intros V' | intros b z Hz ]. 2: elim Hz; simpl in |- *; intros Hz1 Hz2; elim Hz1; intros Hz3 Hz4; split; auto with zarith. 2: split; unfold Fopp in |- *; simpl in |- *; auto with zarith. generalize SterbenzApproxI_1; intros H'. elim H' with radix (BoundI (vNumSup b1) (vNumInf b1) (dExpI b1)) (BoundI (vNumSup b2) (vNumInf b2) (dExpI b2)) rho (Fopp x) (Fopp y); auto with zarith real float; clear H'. 2: intros u Hu; elim Hv3 with (Fopp u); auto. 2: intros v Hv; elim Hv; intros Hv1' Hv2'; clear Hv; exists (Fopp v); split; auto. 2: rewrite Fopp_correct; fold FtoRradix in |- *; rewrite Hv1'; unfold FtoRradix in |- *; rewrite Fopp_correct; ring. 2: unfold FtoRradix in |- *; repeat rewrite Fopp_correct; fold FtoRradix in |- *; auto with real. 2: apply Ropp_le_cancel; rewrite Ropp_involutive; apply Rle_trans with (1 := Hxy1); right; ring. 2: repeat rewrite Fopp_correct; fold FtoRradix in |- *; auto with real. 2: apply Ropp_le_cancel; rewrite Ropp_involutive; apply Rle_trans with (2 := Hxy2); right; ring. intros u Hu; elim Hu; intros Hu1 Hu2; clear Hu. exists (Fopp u); split; auto. unfold FtoRradix in |- *; rewrite Fopp_correct; rewrite Hu1; repeat rewrite Fopp_correct; ring. Qed. Theorem SterbenzApproxI_4 : forall (rho : R) (x y : float), (0 < rho)%R -> IZR (Zsucc (vNumInf b1)) = (rho * Zsucc (vNumSup b2))%R -> (- dExpI b2 <= - dExpI b1)%Z -> (forall x : float, FboundedI b2 x -> exists y : float, y = (- x)%R :>R /\ FboundedI b2 y) -> FboundedI b1 x -> FboundedI b1 y -> (x <= / (1 + / rho) * y)%R -> ((1 + / rho) * y <= x)%R -> exists u : float, u = (x - y)%R :>R /\ FboundedI b2 u. intros rho x y Hrho Hv1 Hv2 Hv3 Hx Hy Hxy1 Hxy2. cut (forall (b : FboundI) (z : float), FboundedI b z -> FboundedI (BoundI (vNumSup b) (vNumInf b) (dExpI b)) (Fopp z)); [ intros V | intros b z Hz ]. 2: elim Hz; intros Hz1 Hz2; elim Hz1; intros Hz3 Hz4; split; auto with zarith. 2: split; unfold Fopp in |- *; simpl in |- *; auto with zarith. cut (forall (b : FboundI) (z : float), FboundedI (BoundI (vNumSup b) (vNumInf b) (dExpI b)) z -> FboundedI b (Fopp z)); [ intros V' | intros b z Hz ]. 2: elim Hz; simpl in |- *; intros Hz1 Hz2; elim Hz1; intros Hz3 Hz4; split; auto with zarith. 2: split; unfold Fopp in |- *; simpl in |- *; auto with zarith. generalize SterbenzApproxI_2; intros H'. elim H' with radix (BoundI (vNumSup b1) (vNumInf b1) (dExpI b1)) (BoundI (vNumSup b2) (vNumInf b2) (dExpI b2)) rho (Fopp x) (Fopp y); auto with zarith real float; clear H'. 2: intros u Hu; elim Hv3 with (Fopp u); auto. 2: intros v Hv; elim Hv; intros Hv1' Hv2'; clear Hv; exists (Fopp v); split; auto. 2: rewrite Fopp_correct; fold FtoRradix in |- *; rewrite Hv1'; unfold FtoRradix in |- *; rewrite Fopp_correct; ring. 2: unfold FtoRradix in |- *; repeat rewrite Fopp_correct; fold FtoRradix in |- *; auto with real. 2: apply Ropp_le_cancel; rewrite Ropp_involutive; apply Rle_trans with (1 := Hxy1); right; ring. 2: repeat rewrite Fopp_correct; fold FtoRradix in |- *; auto with real. 2: apply Ropp_le_cancel; rewrite Ropp_involutive; apply Rle_trans with (2 := Hxy2); right; ring. intros u Hu; elim Hu; intros Hu1 Hu2; clear Hu. exists (Fopp u); split; auto. unfold FtoRradix in |- *; rewrite Fopp_correct; rewrite Hu1; repeat rewrite Fopp_correct; ring. Qed. Theorem SterbenzApproxI_pos : forall (rho : R) (x y : float), (0 < rho)%R -> rho = Rmin (Rmin (Zsucc (vNumInf b1) / Zsucc (vNumInf b2)) (Zsucc (vNumSup b1) / Zsucc (vNumSup b2))) (Rmin (Zsucc (vNumInf b1) / Zsucc (vNumSup b2)) (Zsucc (vNumSup b1) / Zsucc (vNumInf b2))) -> (- dExpI b2 <= - dExpI b1)%Z -> (forall x : float, FboundedI b2 x -> exists y : float, y = (- x)%R :>R /\ FboundedI b2 y) -> (forall x : float, FboundedI b1 x -> exists y : float, y = (- x)%R :>R /\ FboundedI b1 y) -> FboundedI b1 x -> FboundedI b1 y -> (/ (1 + / rho) * y <= x)%R -> (x <= (1 + / rho) * y)%R -> exists u : float, u = (x - y)%R :>R /\ FboundedI b2 u. intros rho x y Hrho Hv1 Hv2 Hv3 Hv0 Hx Hy Hxy1 Hxy2. cut (forall u v : R, Rmin u v = u \/ Rmin u v = v); [ intros V | idtac ]. 2: intros u v; unfold Rmin in |- *; case (Rle_dec u v); auto. case (V (Rmin (Zsucc (vNumInf b1) / Zsucc (vNumInf b2)) (Zsucc (vNumSup b1) / Zsucc (vNumSup b2))) (Rmin (Zsucc (vNumInf b1) / Zsucc (vNumSup b2)) (Zsucc (vNumSup b1) / Zsucc (vNumInf b2)))); intros V1. case (V (Zsucc (vNumInf b1) / Zsucc (vNumInf b2))%R (Zsucc (vNumSup b1) / Zsucc (vNumSup b2))%R); intros V2. cut (rho = (Zsucc (vNumInf b1) / Zsucc (vNumInf b2))%R); [ intros Hv4; clear V2 V1 V Hv1 | rewrite Hv1; rewrite V1; auto with real ]. elim (Hv0 x); auto; intros Mx tmp; elim tmp; intros Mx1 Mx2; clear tmp. elim (Hv0 y); auto; intros My tmp; elim tmp; intros My1 My2; clear tmp. elim SterbenzApproxI_3 with rho Mx My; auto with real zarith. 2: rewrite Hv4; unfold Rdiv in |- *; rewrite Rmult_assoc; rewrite Rinv_l; auto with real zarith. 2: rewrite Mx1; rewrite My1; apply Ropp_le_cancel; rewrite Ropp_involutive; auto with real. 2: apply Rle_trans with (2 := Hxy1); right; ring. 2: rewrite Mx1; rewrite My1; apply Ropp_le_cancel; rewrite Ropp_involutive; auto with real. 2: apply Rle_trans with (1 := Hxy2); right; ring. intros v tmp; elim tmp; intros Hv1' Hv2'; clear tmp. replace (x - y)%R with (- (Mx - My))%R; [ rewrite <- Hv1'; auto with real | rewrite Mx1; rewrite My1; ring ]. cut (rho = (Zsucc (vNumSup b1) / Zsucc (vNumSup b2))%R); [ intros Hv4; clear V2 V1 V Hv1 | rewrite Hv1; rewrite V1; auto with real ]. unfold FtoRradix in |- *; apply SterbenzApproxI_1 with b1 rho; auto with real zarith. rewrite Hv4; unfold Rdiv in |- *; rewrite Rmult_assoc; rewrite Rinv_l; auto with real arith zarith. case (V (Zsucc (vNumInf b1) / Zsucc (vNumSup b2))%R (Zsucc (vNumSup b1) / Zsucc (vNumInf b2))%R); intros V2. cut (rho = (Zsucc (vNumInf b1) / Zsucc (vNumSup b2))%R); [ intros Hv4; clear V2 V1 V Hv1 | rewrite Hv1; rewrite V1; auto with real ]. elim (Hv0 x); auto; intros Mx tmp; elim tmp; intros Mx1 Mx2; clear tmp. elim (Hv0 y); auto; intros My tmp; elim tmp; intros My1 My2; clear tmp. elim SterbenzApproxI_4 with rho Mx My; auto with real zarith. 2: rewrite Hv4; unfold Rdiv in |- *; rewrite Rmult_assoc; rewrite Rinv_l; auto with real zarith. 2: rewrite Mx1; rewrite My1; apply Ropp_le_cancel; rewrite Ropp_involutive; auto with real. 2: apply Rle_trans with (2 := Hxy1); right; ring. 2: rewrite Mx1; rewrite My1; apply Ropp_le_cancel; rewrite Ropp_involutive; auto with real. 2: apply Rle_trans with (1 := Hxy2); right; ring. intros v tmp; elim tmp; intros Hv1' Hv2'; clear tmp. replace (x - y)%R with (- (Mx - My))%R; [ rewrite <- Hv1'; auto with real | rewrite Mx1; rewrite My1; ring ]. cut (rho = (Zsucc (vNumSup b1) / Zsucc (vNumInf b2))%R); [ intros Hv4; clear V2 V1 V Hv1 | rewrite Hv1; rewrite V1; auto with real ]. unfold FtoRradix in |- *; apply SterbenzApproxI_2 with b1 rho; auto with real zarith. rewrite Hv4; unfold Rdiv in |- *; rewrite Rmult_assoc; rewrite Rinv_l; auto with real zarith. Qed. Theorem SterbenzApproxI : forall (rho : R) (x y : float), (0 < rho)%R -> rho = Rmin (Rmin (Zsucc (vNumInf b1) / Zsucc (vNumInf b2)) (Zsucc (vNumSup b1) / Zsucc (vNumSup b2))) (Rmin (Zsucc (vNumInf b1) / Zsucc (vNumSup b2)) (Zsucc (vNumSup b1) / Zsucc (vNumInf b2))) -> (- dExpI b2 <= - dExpI b1)%Z -> (forall x : float, FboundedI b2 x -> exists y : float, y = (- x)%R :>R /\ FboundedI b2 y) -> (forall x : float, FboundedI b1 x -> exists y : float, y = (- x)%R :>R /\ FboundedI b1 y) -> FboundedI b1 x -> FboundedI b1 y -> (0 <= x * y)%R -> (/ (1 + / rho) * Rabs y <= Rabs x)%R -> (Rabs x <= (1 + / rho) * Rabs y)%R -> exists u : float, u = (x - y)%R :>R /\ FboundedI b2 u. intros rho x y Hrho Hrho2 Hv0 Hv2 Hv1 Hx Hy H1 H2 H3. case (Rle_or_lt 0 y); intros H'0. cut (0 <= x)%R; [ intros H'1 | idtac ]. apply SterbenzApproxI_pos with rho; auto; rewrite <- (Rabs_right y); auto with real; rewrite <- (Rabs_right x); auto with real. case H'0; intros H'. apply Rmult_le_reg_l with (FtoRradix y); auto with real. ring_simplify; rewrite Rmult_comm; auto with real. case (Req_dec 0 x); auto with real; intros H''. absurd (0 < 0)%R; auto with real. apply Rlt_le_trans with (Rabs (FtoRradix x)); auto with real. apply Rabs_pos_lt; auto with real. apply Rle_trans with (1 := H3); rewrite <- H'; rewrite Rabs_R0; right; ring. cut (x <= 0)%R; [ intros H'1 | idtac ]. elim (Hv1 x); auto; intros Mx tmp; elim tmp; intros Mx1 Mx2; clear tmp. elim (Hv1 y); auto; intros My tmp; elim tmp; intros My1 My2; clear tmp. elim SterbenzApproxI_pos with rho Mx My; auto. intros u tmp; elim tmp; intros Hu1 Hu2; clear tmp. replace (FtoRradix x - FtoRradix y)%R with (- u)%R; [ idtac | rewrite Hu1; rewrite Mx1; rewrite My1; ring ]. apply Hv2; auto. rewrite Mx1; rewrite My1; rewrite <- Faux.Rabsolu_left1; auto with real; rewrite <- Faux.Rabsolu_left1; auto with real. rewrite Mx1; rewrite My1; rewrite <- Faux.Rabsolu_left1; auto with real; rewrite <- Faux.Rabsolu_left1; auto with real. apply Rmult_le_reg_l with (- y)%R; auto with real. ring_simplify;apply Rle_trans with (-(x*y))%R; auto with real. right; ring. Qed. End SterbenzApproxI.Float8.4/AllFloat.v0000644000423700002640000000006212032774524013732 0ustar sboldotoccataRequire Export RND. Require Export Closest2Plus. Float8.4/Closest.v0000644000423700002640000005513512032774524013663 0ustar sboldotoccata(**************************************************************************** IEEE754 : Closest Laurent Thery ***************************************************************************** Properties about the closest rounding mode *) Require Export Fround. Section Fclosest. Variable b : Fbound. Variable radix : Z. Variable precision : nat. Coercion Local FtoRradix := FtoR radix. Hypothesis radixMoreThanOne : (1 < radix)%Z. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Definition Closest (r : R) (p : float) := Fbounded b p /\ (forall f : float, Fbounded b f -> (Rabs (p - r) <= Rabs (f - r))%R). Theorem ClosestTotal : TotalP Closest. red in |- *; intros r. case MinEx with (r := r) (3 := pGivesBound); auto with arith. intros min H'. case MaxEx with (r := r) (3 := pGivesBound); auto with arith. intros max H'0. cut (min <= r)%R; [ intros Rl1 | apply isMin_inv1 with (1 := H') ]. cut (r <= max)%R; [ intros Rl2 | apply isMax_inv1 with (1 := H'0) ]. case (Rle_or_lt (Rabs (min - r)) (Rabs (max - r))); intros H'1. exists min; split. case H'; auto. intros f H'2. case (Rle_or_lt f r); intros H'3. repeat rewrite Faux.Rabsolu_left1. apply Ropp_le_contravar; auto. apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. elim H'; auto. intros H'4 H'5; elim H'5; intros H'6 H'7; apply H'7; clear H'5; auto. apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. apply Rle_trans with (1 := H'1). repeat rewrite Rabs_right. apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. elim H'0; auto. intros H'4 H'5; elim H'5; intros H'6 H'7; apply H'7; clear H'5; auto. apply Rlt_le; auto. apply Rle_ge; apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r. apply Rlt_le; auto. repeat rewrite Rplus_minus; auto. apply Rle_ge; apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. exists max; split. case H'0; auto. intros f H'2. case (Rle_or_lt f r); intros H'3. apply Rle_trans with (1 := Rlt_le _ _ H'1). repeat rewrite Faux.Rabsolu_left1. apply Ropp_le_contravar; auto. apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. elim H'; auto. intros H'4 H'5; elim H'5; intros H'6 H'7; apply H'7; clear H'5; auto. apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. repeat rewrite Rabs_right; auto with real. apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. elim H'0; auto. intros H'4 H'5; elim H'5; intros H'6 H'7; apply H'7; clear H'5; auto. apply Rlt_le; auto. apply Rle_ge; apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. apply Rlt_le; auto. apply Rle_ge; apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. Qed. Theorem ClosestCompatible : CompatibleP b radix Closest. red in |- *; simpl in |- *. intros r1 r2 p q H'; case H'. intros H'0 H'1 H'2 H'3 H'4. split; auto. intros f H'5. unfold FtoRradix in |- *; rewrite <- H'3; rewrite <- H'2; auto. Qed. Theorem ClosestMin : forall (r : R) (min max : float), isMin b radix r min -> isMax b radix r max -> (2%nat * r <= min + max)%R -> Closest r min. intros r min max H' H'0 H'1; split. case H'; auto. intros f H'2. case (Rle_or_lt f r); intros H'3. repeat rewrite Faux.Rabsolu_left1. apply Ropp_le_contravar. apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. case H'; auto. intros H'4 H'5; elim H'5; intros H'6 H'7; apply H'7; clear H'5; auto. apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. apply isMin_inv1 with (1 := H'); auto. rewrite (Faux.Rabsolu_left1 (min - r)). rewrite (Rabs_right (f - r)). apply Rle_trans with (max - r)%R. cut (forall x y : R, (- y + x)%R = (- (y - x))%R); [ intros Eq0; repeat rewrite Eq0; clear Eq0 | intros; ring ]. cut (forall x y : R, (- (x - y))%R = (y - x)%R); [ intros Eq0; repeat rewrite Eq0; clear Eq0 | intros; unfold Rminus in |- *; ring ]. apply Rplus_le_reg_l with (r := FtoR radix min). repeat rewrite Rplus_minus; auto. apply Rplus_le_reg_l with (r := r). replace (r + (FtoR radix min + (max - r)))%R with (min + max)%R. replace (r + r)%R with (2%nat * r)%R; auto. simpl in |- *; ring. simpl in |- *; fold FtoRradix; ring. apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. case H'0; auto. intros H'4 H'5; elim H'5; intros H'6 H'7; apply H'7; clear H'5; auto. apply Rlt_le; auto. apply Rle_ge; apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. apply Rlt_le; auto. apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. apply isMin_inv1 with (1 := H'); auto. Qed. Theorem ClosestMax : forall (r : R) (min max : float), isMin b radix r min -> isMax b radix r max -> (min + max <= 2%nat * r)%R -> Closest r max. intros r min max H' H'0 H'1; split. case H'0; auto. intros f H'2. case (Rle_or_lt f r); intros H'3. rewrite (Rabs_right (max - r)). rewrite (Faux.Rabsolu_left1 (f - r)). apply Rle_trans with (r - min)%R. apply Rplus_le_reg_l with (r := FtoRradix min). repeat rewrite Rplus_minus; auto. apply Rplus_le_reg_l with (r := r). replace (r + (min + (max - r)))%R with (min + max)%R. replace (r + r)%R with (2%nat * r)%R; auto. simpl in |- *; ring. simpl in |- *; ring. replace (r - min)%R with (- (min - r))%R. apply Ropp_le_contravar. apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. case H'; auto. intros H'4 H'5; elim H'5; intros H'6 H'7; apply H'7; clear H'5; auto. simpl in |- *; ring. apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. apply Rle_ge; apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. apply isMax_inv1 with (1 := H'0); auto. repeat rewrite Rabs_right. apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. case H'0; auto. intros H'4 H'5; elim H'5; intros H'6 H'7; apply H'7; clear H'5; auto. apply Rlt_le; auto. apply Rle_ge; apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. apply Rlt_le; auto. apply Rle_ge; apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. apply isMax_inv1 with (1 := H'0); auto. Qed. Theorem ClosestMinOrMax : MinOrMaxP b radix Closest. red in |- *. intros r p H'. case (Rle_or_lt p r); intros H'1. left; split; auto. case H'; auto. split; auto. intros f H'0 H'2. apply Rplus_le_reg_l with (r := (- r)%R). cut (forall x y : R, (- y + x)%R = (- (y - x))%R); [ intros Eq0; repeat rewrite Eq0; clear Eq0 | intros; ring ]. apply Ropp_le_contravar. rewrite <- (Rabs_right (r - FtoR radix p)). rewrite <- (Rabs_right (r - FtoR radix f)). cut (forall x y : R, Rabs (x - y) = Rabs (y - x)); [ intros Eq0; repeat rewrite (Eq0 r); clear Eq0 | intros x y; rewrite <- (Rabs_Ropp (x - y)); rewrite Ropp_minus_distr ]; auto. elim H'; auto. apply Rle_ge; apply Rplus_le_reg_l with (r := FtoR radix f). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. apply Rle_ge; apply Rplus_le_reg_l with (r := FtoR radix p). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. right; split; auto. case H'; auto. split; auto. apply Rlt_le; auto. intros f H'0 H'2. apply Rplus_le_reg_l with (r := (- r)%R). cut (forall x y : R, (- y + x)%R = (- (y - x))%R); [ intros Eq0; repeat rewrite Eq0; clear Eq0 | intros; ring ]. rewrite <- (Faux.Rabsolu_left1 (r - FtoR radix p)). rewrite <- (Faux.Rabsolu_left1 (r - FtoR radix f)). cut (forall x y : R, Rabs (x - y) = Rabs (y - x)); [ intros Eq0; repeat rewrite (Eq0 r); clear Eq0 | intros x y; rewrite <- (Rabs_Ropp (x - y)); rewrite Ropp_minus_distr ]; auto. elim H'; auto. apply Rplus_le_reg_l with (r := FtoR radix f). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. apply Rplus_le_reg_l with (r := FtoR radix p). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. apply Rlt_le; auto. Qed. Theorem ClosestMinEq : forall (r : R) (min max p : float), isMin b radix r min -> isMax b radix r max -> (2%nat * r < min + max)%R -> Closest r p -> p = min :>R. intros r min max p H' H'0 H'1 H'2. case (ClosestMinOrMax r p); auto; intros H'3. unfold FtoRradix in |- *; apply MinEq with (1 := H'3); auto. absurd (Rabs (max - r) <= Rabs (min - r))%R. apply Rgt_not_le. rewrite (Faux.Rabsolu_left1 (min - r)). rewrite Rabs_right. replace (- (min - r))%R with (r - min)%R; [ idtac | ring ]. red in |- *; apply Rplus_lt_reg_r with (r := FtoRradix min). repeat rewrite Rplus_minus; auto. apply Rplus_lt_reg_r with (r := r). replace (r + r)%R with (2%nat * r)%R; [ idtac | simpl in |- *; ring ]. replace (r + (min + (max - r)))%R with (min + max)%R; [ idtac | ring ]; auto. apply Rle_ge; apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. apply isMax_inv1 with (1 := H'0); auto. apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. apply isMin_inv1 with (1 := H'); auto. cut (Closest r max). intros H'4; case H'4. intros H'5 H'6; apply H'6; auto. case H'; auto. apply ClosestCompatible with (1 := H'2); auto. apply MaxEq with (1 := H'3); auto. case H'0; auto. Qed. Theorem ClosestMaxEq : forall (r : R) (min max p : float), isMin b radix r min -> isMax b radix r max -> (min + max < 2%nat * r)%R -> Closest r p -> p = max :>R. intros r min max p H' H'0 H'1 H'2. case (ClosestMinOrMax r p); auto; intros H'3. 2: unfold FtoRradix in |- *; apply MaxEq with (1 := H'3); auto. absurd (Rabs (min - r) <= Rabs (max - r))%R. apply Rgt_not_le. rewrite (Faux.Rabsolu_left1 (min - r)). rewrite Rabs_right. replace (- (min - r))%R with (r - min)%R; [ idtac | ring ]. red in |- *; apply Rplus_lt_reg_r with (r := FtoRradix min). repeat rewrite Rplus_minus; auto. apply Rplus_lt_reg_r with (r := r). replace (r + r)%R with (2%nat * r)%R; [ idtac | simpl in |- *; ring ]. replace (r + (min + (max - r)))%R with (min + max)%R; [ idtac | ring ]; auto. apply Rle_ge; apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. apply isMax_inv1 with (1 := H'0); auto. apply Rplus_le_reg_l with (r := r). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. apply isMin_inv1 with (1 := H'); auto. cut (Closest r min). intros H'4; case H'4. intros H'5 H'6; apply H'6; auto. case H'0; auto. apply ClosestCompatible with (1 := H'2); auto. apply MinEq with (1 := H'3); auto. case H'; auto. Qed. Theorem ClosestMonotone : MonotoneP radix Closest. red in |- *; simpl in |- *. intros p q p' q' H' H'0 H'1. change (p' <= q')%R in |- *. case (Rle_or_lt p p'); intros Rl0. case (Rle_or_lt p q'); intros Rl1. apply Rplus_le_reg_l with (r := (- p)%R). cut (forall x y : R, (- y + x)%R = (- (y - x))%R); [ intros Eq0; repeat rewrite Eq0; clear Eq0 | intros; ring ]. rewrite <- (Faux.Rabsolu_left1 (p - p')). rewrite <- (Faux.Rabsolu_left1 (p - q')). cut (forall x y : R, Rabs (x - y) = Rabs (y - x)); [ intros Eq0; repeat rewrite (Eq0 p); clear Eq0 | intros x y; rewrite <- (Rabs_Ropp (x - y)); rewrite Ropp_minus_distr ]; auto. elim H'0; auto. intros H'2 H'3; apply H'3; auto. case H'1; auto. apply Rplus_le_reg_l with (r := FtoR radix q'). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. apply Rplus_le_reg_l with (r := FtoR radix p'). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. case (Rle_or_lt p' q); intros Rl2. apply Rplus_le_reg_l with (r := (- q)%R). cut (forall x y : R, (- y + x)%R = (- (y - x))%R); [ intros Eq0; repeat rewrite Eq0; clear Eq0 | intros; ring ]. rewrite <- (Rabs_right (q - p')). 2: apply Rle_ge; apply Rplus_le_reg_l with (r := FtoR radix p'). 2: repeat rewrite Rplus_minus; auto. 2: rewrite Rplus_0_r; auto. rewrite <- (Rabs_right (q - q')). 2: apply Rle_ge; apply Rplus_le_reg_l with (r := FtoR radix q'). 2: repeat rewrite Rplus_minus; auto. 2: rewrite Rplus_0_r; auto. 2: apply Rle_trans with (1 := Rlt_le _ _ Rl1); apply Rlt_le; auto. cut (forall x y : R, Rabs (x - y) = Rabs (y - x)); [ intros Eq0; repeat rewrite (Eq0 q); clear Eq0 | intros x y; rewrite <- (Rabs_Ropp (x - y)); rewrite Ropp_minus_distr ]; auto. apply Ropp_le_contravar. elim H'1; auto. intros H'2 H'3; apply H'3; auto. case H'0; auto. case (Rle_or_lt (p - q') (p' - q)); intros Rl3. absurd (Rabs (p' - p) <= Rabs (q' - p))%R. apply Rgt_not_le. rewrite (Faux.Rabsolu_left1 (q' - p)). 2: apply Rplus_le_reg_l with (r := p). 2: repeat rewrite Rplus_minus; auto. 2: rewrite Rplus_0_r; apply Rlt_le; auto. rewrite (Rabs_right (p' - p)). 2: apply Rle_ge; apply Rplus_le_reg_l with (r := p). 2: rewrite Rplus_0_r; auto. cut (forall x y : R, (- (y - x))%R = (x - y)%R); [ intros Eq0; repeat rewrite Eq0; clear Eq0 | intros; ring ]. red in |- *; apply Rle_lt_trans with (1 := Rl3). replace (p' - p)%R with (p' - q + (q - p))%R. pattern (p' - q)%R at 1 in |- *; replace (p' - q)%R with (p' - q + 0)%R. apply Rplus_lt_compat_l; auto. apply Rplus_lt_reg_r with (r := p). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. rewrite Rplus_0_r; auto. ring. replace (p + (p' - p))%R with (FtoRradix p'); auto; ring. case H'0; intros H'2 H'3; apply H'3; auto. case H'1; auto. absurd (Rabs (q' - q) <= Rabs (p' - q))%R. apply Rgt_not_le. rewrite (Faux.Rabsolu_left1 (q' - q)). 2: apply Rplus_le_reg_l with (r := q). 2: repeat rewrite Rplus_minus; auto. 2: rewrite Rplus_0_r; apply Rlt_le; auto. 2: apply Rlt_trans with (1 := Rl1); auto. rewrite (Rabs_right (p' - q)). 2: apply Rle_ge; apply Rplus_le_reg_l with (r := q). 2: rewrite Rplus_0_r; apply Rlt_le; auto. cut (forall x y : R, (- (y - x))%R = (x - y)%R); [ intros Eq0; repeat rewrite Eq0; clear Eq0 | intros; ring ]. red in |- *; apply Rlt_trans with (1 := Rl3). replace (q - q')%R with (p - q' + (q - p))%R. pattern (p - q')%R at 1 in |- *; replace (p - q')%R with (p - q' + 0)%R. apply Rplus_lt_compat_l; auto. apply Rplus_lt_reg_r with (r := p). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. rewrite Rplus_0_r; auto. ring. replace (q + (p' - q))%R with (FtoRradix p'); auto; ring. case H'1; intros H'2 H'3; apply H'3; auto. case H'0; auto. case (Rle_or_lt p q'); intros Rl1. apply Rle_trans with p; auto. apply Rlt_le; auto. apply Rplus_le_reg_l with (r := (- q)%R). cut (forall x y : R, (- y + x)%R = (- (y - x))%R); [ intros Eq0; repeat rewrite Eq0; clear Eq0 | intros; ring ]. rewrite <- (Rabs_right (q - p')). rewrite <- (Rabs_right (q - q')). apply Ropp_le_contravar. cut (forall x y : R, Rabs (x - y) = Rabs (y - x)); [ intros Eq0; repeat rewrite (Eq0 q); clear Eq0 | intros x y; rewrite <- (Rabs_Ropp (x - y)); rewrite Ropp_minus_distr ]; auto. elim H'1; auto. intros H'2 H'3; apply H'3; auto. case H'0; auto. apply Rle_ge; apply Rplus_le_reg_l with (r := FtoR radix q'). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. apply Rlt_le; apply Rlt_trans with (1 := Rl1); auto. apply Rle_ge; apply Rplus_le_reg_l with (r := FtoR radix p'). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; auto. apply Rlt_le; apply Rlt_trans with (1 := Rl0); auto. Qed. Theorem ClosestRoundedModeP : RoundedModeP b radix Closest. split; try exact ClosestTotal. split; try exact ClosestCompatible. split; try exact ClosestMinOrMax. try exact ClosestMonotone. Qed. Definition EvenClosest (r : R) (p : float) := Closest r p /\ (FNeven b radix precision p \/ (forall q : float, Closest r q -> q = p :>R)). Theorem EvenClosestTotal : TotalP EvenClosest. red in |- *; intros r. case MinEx with (r := r) (3 := pGivesBound); auto with arith. intros min H'. case MaxEx with (r := r) (3 := pGivesBound); auto with arith. intros max H'0. cut (min <= r)%R; [ intros Rl1 | apply isMin_inv1 with (1 := H'); auto ]. cut (r <= max)%R; [ intros Rl2 | apply isMax_inv1 with (1 := H'0) ]. case (Rle_or_lt (r - min) (max - r)); intros H'1. case H'1; intros H'2; auto. exists min; split. apply ClosestMin with (max := max); auto. replace (2%nat * r)%R with (r + r)%R; [ idtac | simpl in |- *; ring ]. apply Rminus_le; auto. replace (r + r - (min + max))%R with (r - min - (max - r))%R; [ idtac | simpl in |- *; ring ]. apply Rle_minus; auto. right; intros q H'3. apply ClosestMinEq with (r := r) (max := max); auto. replace (2%nat * r)%R with (r + r)%R; [ idtac | simpl in |- *; ring ]. apply Rminus_lt; auto. replace (r + r - (min + max))%R with (r - min - (max - r))%R; [ idtac | simpl in |- *; ring ]. apply Rlt_minus; auto. case (FNevenOrFNodd b radix precision min); intros Ev0. exists min; split; auto. apply ClosestMin with (max := max); auto. replace (2%nat * r)%R with (r + r)%R; [ idtac | simpl in |- *; ring ]. apply Rminus_le; auto. replace (r + r - (min + max))%R with (r - min - (max - r))%R; [ idtac | simpl in |- *; ring ]. apply Rle_minus; auto. exists max; split; auto. apply ClosestMax with (min := min); auto. replace (2%nat * r)%R with (r + r)%R; [ idtac | simpl in |- *; ring ]. apply Rminus_le; auto. replace (min + max - (r + r))%R with (max - r - (r - min))%R; [ idtac | simpl in |- *; ring ]. apply Rle_minus; auto. rewrite H'2; auto with real. case (Req_dec min max); intros H'5. right; intros q H'3. case (ClosestMinOrMax _ _ H'3); intros isM0. rewrite <- H'5. apply MinEq with (1 := isM0); auto. apply MaxEq with (1 := isM0); auto. left. apply FNevenEq with (f1 := FNSucc b radix precision min); auto. apply FcanonicBound with (radix := radix). apply FNSuccCanonic; auto with arith. case H'; auto. case H'0; auto. apply MaxEq with (b := b) (r := r); auto. apply MinMax; auto with arith. Contradict H'5; auto. fold FtoRradix in H'5; rewrite H'5 in H'2. replace (FtoRradix max) with (min + (max - min))%R; [ rewrite <- H'2 | idtac ]; ring. apply FNoddSuc; auto. case H'; auto. exists max; split; auto. apply ClosestMax with (min := min); auto. replace (2%nat * r)%R with (r + r)%R; [ idtac | simpl in |- *; ring ]. apply Rminus_le; auto. replace (min + max - (r + r))%R with (max - r - (r - min))%R; [ idtac | simpl in |- *; ring ]. apply Rle_minus; auto with real. right; intros q H'2. apply ClosestMaxEq with (r := r) (min := min); auto. replace (2%nat * r)%R with (r + r)%R; [ idtac | simpl in |- *; ring ]. apply Rminus_lt; auto. replace (min + max - (r + r))%R with (max - r - (r - min))%R; [ idtac | simpl in |- *; ring ]. apply Rlt_minus; auto. Qed. Theorem EvenClosestCompatible : CompatibleP b radix EvenClosest. red in |- *; simpl in |- *. intros r1 r2 p q H' H'0 H'1 H'2; red in |- *. inversion H'. split. apply (ClosestCompatible r1 r2 p q); auto. case H0; intros H1. left. apply FNevenEq with (f1 := p); auto. case H; auto. right; intros q0 H'3. unfold FtoRradix in |- *; rewrite <- H'1; auto. apply H1; auto. apply (ClosestCompatible r2 r1 q0 q0); auto. case H'3; auto. Qed. Theorem EvenClosestMinOrMax : MinOrMaxP b radix EvenClosest. red in |- *; intros r p H'; case (ClosestMinOrMax r p); auto. case H'; auto. Qed. Theorem EvenClosestMonotone : MonotoneP radix EvenClosest. red in |- *; simpl in |- *; intros p q p' q' H' H'0 H'1. apply (ClosestMonotone p q); auto; case H'0; case H'1; auto. Qed. Theorem EvenClosestRoundedModeP : RoundedModeP b radix EvenClosest. red in |- *; split. exact EvenClosestTotal. split. exact EvenClosestCompatible. split. exact EvenClosestMinOrMax. exact EvenClosestMonotone. Qed. Theorem EvenClosestUniqueP : UniqueP radix EvenClosest. red in |- *; simpl in |- *. intros r p q H' H'0. inversion H'; inversion H'0; case H0; case H2; auto. intros H'1 H'2; case (EvenClosestMinOrMax r p); case (EvenClosestMinOrMax r q); auto. intros H'3 H'4; apply (MinUniqueP b radix r); auto. intros H'3 H'4; case (Req_dec p q); auto; intros H'5. Contradict H'1; auto. apply FnOddNEven; auto. apply FNoddEq with (f1 := FNSucc b radix precision p); auto. apply FcanonicBound with (radix := radix); auto. apply FNSuccCanonic; auto with arith. case H'4; auto. case H'3; auto. apply (MaxUniqueP b radix r); auto. apply MinMax; auto with arith. Contradict H'5; auto. apply (RoundedProjector b radix _ (MaxRoundedModeP _ _ _ radixMoreThanOne precisionGreaterThanOne pGivesBound)); auto. case H'4; auto. rewrite <- H'5; auto. apply FNevenSuc; auto. case H'4; auto. intros H'3 H'4; case (Req_dec p q); auto; intros H'5. Contradict H'2; auto. apply FnOddNEven; auto. apply FNoddEq with (f1 := FNSucc b radix precision q); auto. apply FcanonicBound with (radix := radix); auto. apply FNSuccCanonic; auto with arith. case H'3; auto. case H'4; auto. apply (MaxUniqueP b radix r); auto. apply MinMax; auto with arith. Contradict H'5; auto. apply sym_eq; apply (RoundedProjector b radix _ (MaxRoundedModeP _ _ _ radixMoreThanOne precisionGreaterThanOne pGivesBound)); auto. case H'3; auto. rewrite <- H'5; auto. apply FNevenSuc; auto. case H'3; auto. intros H'3 H'4; apply (MaxUniqueP b radix r); auto. intros H'1 H'2; apply sym_eq; auto. Qed. Theorem ClosestSymmetric : SymmetricP Closest. red in |- *; intros r p H'; case H'; clear H'. intros H' H'0; split. apply oppBounded; auto. intros f H'1. replace (Rabs (Fopp p - - r)) with (Rabs (p - r)). replace (Rabs (f - - r)) with (Rabs (Fopp f - r)). apply H'0; auto. apply oppBounded; auto. unfold FtoRradix in |- *; rewrite Fopp_correct. pattern r at 1 in |- *; replace r with (- - r)%R; [ idtac | ring ]. replace (- FtoR radix f - - - r)%R with (- (FtoR radix f - - r))%R; [ idtac | ring ]. apply Rabs_Ropp; auto. unfold FtoRradix in |- *; rewrite Fopp_correct. replace (- FtoR radix p - - r)%R with (- (FtoR radix p - r))%R; [ idtac | ring ]. apply sym_eq; apply Rabs_Ropp. Qed. Theorem EvenClosestSymmetric : SymmetricP EvenClosest. red in |- *; intros r p H'; case H'; clear H'. intros H' H'0; case H'0; clear H'0; intros H'0. split; auto. apply (ClosestSymmetric r p); auto. left. apply FNevenFop; auto. split; auto. apply (ClosestSymmetric r p); auto. right. intros q H'1. cut (Fopp q = p :>R). intros H'2; unfold FtoRradix in |- *; rewrite Fopp_correct. unfold FtoRradix in H'2; rewrite <- H'2. rewrite Fopp_correct; ring. apply H'0; auto. replace r with (- - r)%R; [ idtac | ring ]. apply (ClosestSymmetric (- r)%R q); auto. Qed. End Fclosest. Hint Resolve ClosestTotal ClosestCompatible ClosestMin ClosestMax ClosestMinOrMax ClosestMonotone ClosestRoundedModeP EvenClosestTotal EvenClosestCompatible EvenClosestMinOrMax EvenClosestMonotone EvenClosestRoundedModeP FnOddNEven EvenClosestUniqueP ClosestSymmetric EvenClosestSymmetric: float.Float8.4/Closest2Plus.v0000644000423700002640000002374212032774524014610 0ustar sboldotoccata(**************************************************************************** IEEE754 : Closest2Plus Laurent Thery ******************************************************************************) Require Export ClosestPlus. Require Export Closest2Prop. Section F2. Variable b : Fbound. Variable precision : nat. Let radix := 2%Z. Coercion Local FtoRradix := FtoR radix. Theorem TwoMoreThanOne : (1 < radix)%Z. red in |- *; simpl in |- *; auto. Qed. Hint Resolve TwoMoreThanOne. Hypothesis precisionNotZero : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Theorem plusUpperBound : forall P, RoundedModeP b 2%nat P -> forall p q pq : float, P (p + q)%R pq -> Fbounded b p -> Fbounded b q -> (Rabs pq <= radix * Rmax (Rabs p) (Rabs q))%R. intros P H' p q pq H'0 H'1 H'2. rewrite <- (Rabs_right radix); auto with real zarith. rewrite <- RmaxRmult; auto with real. repeat rewrite <- Rabs_mult. case (Rle_or_lt p q); intros Rltp. apply RmaxAbs; auto. apply (RoundedModeMultLess b radix) with (P := P) (r := (p + q)%R); auto. replace (radix * FtoR radix p)%R with (p + p)%R; [ auto with real | simpl in |- *; fold FtoRradix; ring ]. unfold FtoRradix in |- *; apply (RoundedModeMult b radix) with (P := P) (r := (p + q)%R); auto. replace (radix * FtoR radix q)%R with (q + q)%R; [ auto with real | simpl in |- *; fold FtoRradix; ring ]. rewrite RmaxSym. apply RmaxAbs; auto. apply (RoundedModeMultLess b radix) with (P := P) (r := (p + q)%R); auto. replace (radix * FtoR radix q)%R with (q + q)%R; [ auto with real | simpl in |- *; fold FtoRradix; ring ]. unfold FtoRradix in |- *; apply (RoundedModeMult b radix) with (P := P) (r := (p + q)%R); auto. replace (radix * FtoR radix p)%R with (p + p)%R; [ auto with real zarith | simpl in |- *; fold FtoRradix; ring ]. apply Rle_ge; auto with real zarith. Qed. Theorem plusErrorBound2 : forall p q r : float, Fbounded b p -> Fbounded b q -> Closest b radix (p + q) r -> ~ is_Fzero r -> (Rabs (r - (p + q)) < radix * / pPred (vNum b) * Rmax (Rabs p) (Rabs q))%R. intros p q r H' H'0 H'1 H'2. apply Rlt_le_trans with (Rabs (FtoR radix r) * / radix * (radix * / pPred (vNum b)))%R; auto. unfold FtoRradix in |- *; apply plusErrorBound1 with (precision := precision); auto with arith. replace (Rabs (FtoR radix r) * / radix * (radix * / pPred (vNum b)))%R with (radix * / pPred (vNum b) * (Rabs r * / radix))%R; [ idtac | fold FtoRradix; ring ]. apply Rmult_le_compat_l; auto. replace 0%R with (radix * 0)%R; [ apply Rmult_le_compat_l | ring ]. cut (0 <= radix)%Z; auto with real zarith. apply Rlt_le; apply Rinv_0_lt_compat; cut (0 < pPred (vNum b))%Z; auto with real zarith. unfold pPred in |- *; apply Zlt_succ_pred; simpl in |- *. apply vNumbMoreThanOne with (radix := radix) (precision := precision); auto with real arith. apply Rmult_le_reg_l with (r := IZR radix); auto with real. rewrite (Rmult_comm (Rabs r)); rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real zarith; rewrite Rmult_1_l. apply plusUpperBound with (P := Closest b radix); auto. apply ClosestRoundedModeP with (precision := precision); auto. Qed. Theorem plusClosestLowerBoundAux1 : forall p q pq : float, (Rabs q <= p)%R -> Closest b radix (p + q) pq -> Fbounded b p -> Fbounded b q -> pq <> (p + q)%R :>R -> (/ radix * p <= pq)%R. intros p q pq H' H'0 H'1 H'2 H'3. cut (0 <= p)%R; [ intros Rl0; Casec Rl0; intros H0 | apply Rle_trans with (2 := H'); auto with real ]. apply (FmultRadixInv b radix precision) with (5 := H'0); auto. case (Rle_or_lt 0 q); intros Rl0. apply Rlt_le_trans with (FtoRradix p); auto. apply Rlt_RinvDouble; auto. pattern (FtoRradix p) at 1 in |- *; replace (FtoRradix p) with (p + 0)%R; auto with real. apply Rmult_lt_reg_l with (r := IZR radix); auto with real. rewrite <- Rmult_assoc; rewrite Rinv_r. rewrite Rmult_plus_distr_l. rewrite Rmult_1_l. apply Rplus_lt_reg_r with (r := (- (radix * p))%R). replace (- (radix * p) + FtoR radix p)%R with (- p)%R; [ idtac | simpl in |- *; unfold FtoRradix in |- *; ring; auto; ring ]. replace (- (radix * p) + (radix * p + radix * q))%R with (radix * q)%R; [ idtac | simpl in |- *; ring ]. rewrite <- (Ropp_involutive (radix * q)); apply Ropp_lt_contravar. replace (- (radix * q))%R with (radix * - q)%R; [ idtac | ring ]. case (Rle_or_lt (FtoRradix p) (radix * - q)); auto. intros H'4; Contradict H'3. rewrite <- (Fplus_correct radix); auto. unfold FtoRradix in |- *; apply sym_eq; apply ClosestIdem with (b := b); auto. replace (Fplus radix p q) with (Fminus radix p (Fopp q)). rewrite <- Fopp_Fminus. apply oppBounded; auto. apply Sterbenz; auto. apply oppBounded; auto. apply Rmult_le_reg_l with (r := IZR radix); auto with real. rewrite <- Rmult_assoc; rewrite Rinv_r. rewrite Rmult_1_l; rewrite Fopp_correct; auto. replace 0%R with (INR 0); auto with real arith. apply Rle_trans with (FtoR 2%nat p); auto with real. rewrite Fopp_correct; auto. rewrite <- Faux.Rabsolu_left1; auto. apply Rlt_le; auto. unfold Fminus in |- *; rewrite Fopp_Fopp; auto. apply (ClosestCompatible b radix (p + q)%R (FtoR radix (Fplus radix p q)) pq pq); auto. apply sym_eq; unfold FtoRradix in |- *; apply Fplus_correct; auto. apply RoundedModeBounded with (radix := radix) (P := Closest b radix) (r := (p + q)%R); auto. apply ClosestRoundedModeP with (precision := precision); auto. replace 0%R with (INR 0); auto with real arith. rewrite <- H0; rewrite Rmult_0_r. replace (FtoRradix pq) with (FtoRradix p); auto. rewrite <- H0; auto with real. unfold FtoRradix in |- *; apply ClosestIdem with (b := b); auto. apply (ClosestCompatible b radix (p + q)%R (FtoR radix p) pq pq); auto. replace (FtoR 2%nat p) with (FtoRradix p); auto. fold FtoRradix; rewrite <- H0; replace (FtoRradix q) with 0%R; try ring. generalize H'; unfold Rabs in |- *; case (Rcase_abs q); auto. intros H'4 H'5; Contradict H'5; rewrite <- H0; auto with real. apply Rlt_not_le; auto with real. intros H'4 H'5; apply Rle_antisym; auto with real. rewrite H0; auto. apply RoundedModeBounded with (radix := radix) (P := Closest b radix) (r := (p + q)%R); auto. apply ClosestRoundedModeP with (precision := precision); auto. Qed. Theorem plusClosestLowerBoundAux2 : forall p q pq : float, Closest b radix (p + q) pq -> Fbounded b p -> Fbounded b q -> pq <> (p + q)%R :>R -> (Rabs p <= Rabs q)%R -> (/ radix * Rabs q <= Rabs pq)%R. intros p q pq H' H'0 H'1 H'2 H'3. cut (Fbounded b pq); [ intros Fb0 | apply RoundedModeBounded with (radix := radix) (P := Closest b radix) (r := (p + q)%R); auto; apply ClosestRoundedModeP with (precision := precision) ]; auto. case (Rle_or_lt 0 q); intros Rl2; [ idtac | cut (q <= 0)%R; [ intros Rl2' | apply Rlt_le; auto ] ]. repeat rewrite Rabs_right; auto with real. apply plusClosestLowerBoundAux1 with (q := p); auto. rewrite <- (Rabs_right q); auto with real. apply (ClosestCompatible b radix (p + q)%R (q + p)%R pq pq); auto; try ring. rewrite Rplus_comm; auto with real. apply Rle_ge; unfold FtoRradix in |- *; apply RleRoundedR0 with (b := b) (precision := precision) (P := Closest b radix) (r := (p + q)%R); auto. apply ClosestRoundedModeP with (precision := precision); auto. case (Rle_or_lt 0 p); intros Rl3; [ idtac | cut (p <= 0)%R; [ intros Rl3' | apply Rlt_le; auto ] ]; auto with real. replace 0%R with (0 + 0)%R; auto with real. apply Rplus_le_reg_l with (r := (- p)%R). replace (- p + 0)%R with (- p)%R; [ idtac | ring ]. replace (- p + (p + q))%R with (FtoRradix q); [ idtac | ring ]. rewrite <- (Faux.Rabsolu_left1 (FtoRradix p)); auto with real. rewrite <- (Rabs_right (FtoRradix q)); auto with real. repeat rewrite Faux.Rabsolu_left1; auto with real. unfold FtoRradix in |- *; repeat rewrite <- (Fopp_correct 2%nat); auto. apply plusClosestLowerBoundAux1 with (q := Fopp p); auto. unfold FtoRradix in |- *; repeat rewrite Fopp_correct; rewrite Rabs_Ropp; rewrite <- Faux.Rabsolu_left1; auto with real. apply (ClosestCompatible b radix (- (p + q))%R (Fopp q + Fopp p)%R ( Fopp pq) (Fopp pq)); auto. apply ClosestOpp; auto. unfold FtoRradix in |- *; repeat rewrite Fopp_correct; ring. apply oppBounded; auto. apply oppBounded; auto. apply oppBounded; auto. unfold FtoRradix in |- *; repeat rewrite Fopp_correct; Contradict H'2. unfold FtoRradix in |- *; rewrite <- (Ropp_involutive (FtoR radix pq)); rewrite H'2; ring. unfold FtoRradix in |- *; apply RleRoundedLessR0 with (b := b) (precision := precision) (P := Closest b radix) (r := (p + q)%R); auto. apply ClosestRoundedModeP with (precision := precision); auto. case (Rle_or_lt 0 p); intros Rl3; [ idtac | cut (p <= 0)%R; [ intros Rl3' | apply Rlt_le; auto ] ]; auto with real. apply Rplus_le_reg_l with (r := (- q)%R). replace (- q + 0)%R with (- q)%R; [ idtac | ring ]. replace (- q + (p + q))%R with (FtoRradix p); [ idtac | ring ]. rewrite <- (Rabs_right (FtoRradix p)); auto with real. rewrite <- (Rabs_left (FtoRradix q)); auto with real. replace 0%R with (0 + 0)%R; auto with real. Qed. Theorem plusClosestLowerBound : forall p q pq : float, Closest b radix (p + q) pq -> Fbounded b p -> Fbounded b q -> pq <> (p + q)%R :>R -> (/ radix * Rmax (Rabs p) (Rabs q) <= Rabs pq)%R. intros p q pq H' H'0 H'1 H'2. cut (Fbounded b pq); [ intros Fb0 | apply RoundedModeBounded with (radix := radix) (P := Closest b radix) (r := (p + q)%R); auto; apply ClosestRoundedModeP with (precision := precision) ]; auto. unfold Rmax in |- *. case (Rle_dec (Rabs p) (Rabs q)); intros Rl1. apply plusClosestLowerBoundAux2 with (p := p); auto. apply plusClosestLowerBoundAux2 with (p := q); auto. apply (ClosestCompatible b radix (p + q)%R (q + p)%R pq pq); auto; try ring. rewrite Rplus_comm; auto. case (Rle_or_lt (Rabs q) (Rabs p)); auto; intros H'3; Contradict Rl1; apply Rlt_le; auto. Qed. End F2.Float8.4/Closest2Prop.v0000644000423700002640000000473112032774524014602 0ustar sboldotoccata(**************************************************************************** IEEE754 : Closest2Prop Laurent Thery ******************************************************************************) Require Export ClosestProp. Section F2. Variable b : Fbound. Variable precision : nat. Let radix := 2%Z. Coercion Local FtoRradix := FtoR radix. Theorem TwoMoreThanOne : (1 < radix)%Z. unfold radix in |- *; red in |- *; simpl in |- *; auto. Qed. Hint Resolve TwoMoreThanOne. Hypothesis precisionNotZero : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Theorem FevenNormMin : Even (nNormMin 2%nat precision). unfold nNormMin in |- *. generalize precisionNotZero; case precision. intros H'2; Contradict H'2; auto with zarith. intros n; case n. intros H'2; Contradict H'2; auto with zarith. intros n0 H'2; replace (pred (S (S n0))) with (S n0). simpl in |- *; apply EvenExp; auto. exists 1%Z; ring. simpl in |- *; auto. Qed. Theorem EvenFNSuccFNSuccMid : forall p : float, Fbounded b p -> FNeven b radix precision p -> Fminus radix (FNSucc b radix precision (FNSucc b radix precision p)) (FNSucc b radix precision p) = Fminus radix (FNSucc b radix precision p) p :>R. intros p H' H'0. unfold FtoRradix in |- *; apply FNSuccFNSuccMid; auto. red in |- *; intros H'1; absurd (FNodd b radix precision (FNSucc b radix precision p)); auto. unfold FNodd in |- *. rewrite FcanonicFnormalizeEq; auto with float arith. unfold Fodd in |- *. rewrite H'1. apply EvenNOdd; auto with float arith. apply FevenNormMin; auto with float arith. apply FNevenSuc; auto. red in |- *; intros H'1; absurd (FNodd b radix precision (FNSucc b radix precision p)); auto with float arith. unfold FNodd in |- *. rewrite FcanonicFnormalizeEq; auto with float arith. unfold Fodd in |- *. rewrite H'1. apply EvenNOdd. apply EvenOpp; apply FevenNormMin. Qed. Theorem AScal2 : forall p : float, Float (Fnum p) (Fexp p + 1%nat) = (radix * p)%R :>R. intros p. unfold FtoRradix in |- *; rewrite FvalScale; auto. replace (powerRZ radix 1%nat) with (INR 2); [ idtac | simpl in |- *; ring ]; auto. Qed. End F2. Hint Resolve FevenNormMin: float.Float8.4/ClosestMult.v0000644000423700002640000003430312032774524014517 0ustar sboldotoccata(**************************************************************************** IEEE754 : ClosestMult Laurent Thery, Sylvie Boldo ******************************************************************************) Require Export FroundMult. Require Export ClosestProp. Section FRoundP. Variable b : Fbound. Variable radix : Z. Variable precision : nat. Coercion Local FtoRradix := FtoR radix. Hypothesis radixMoreThanOne : (1 < radix)%Z. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Theorem closestLessMultPos : forall (p : float) (r : R), Closest b radix r p -> (0 <= r)%R -> (p <= 2%nat * r)%R. intros p r H' H'0. case ClosestMinOrMax with (1 := H'); intros H'3. apply Rle_trans with r; auto with real. apply isMin_inv1 with (1 := H'3). case (MinEx b radix precision) with (r := r); auto with arith. intros min Hmin. apply Rle_trans with (min + p)%R; auto with real. apply Rplus_le_reg_l with (r := (- p)%R). replace (- p + p)%R with 0%R; [ idtac | ring ]. replace (- p + (min + p))%R with (FtoRradix min); [ apply (RleMinR0 b radix precision) with (r := r); auto | ring ]. apply Rplus_le_reg_l with (r := (- r)%R). apply Rplus_le_reg_l with (r := (- min)%R). replace (- min + (- r + (min + p)))%R with (Rabs (p - r)). replace (- min + (- r + 2%nat * r))%R with (Rabs (min - r)). case H'. intros H'1 H'2; apply H'2; auto. case Hmin; auto. rewrite Faux.Rabsolu_left1; simpl in |- *. ring; auto. apply Rle_minus; apply isMin_inv1 with (1 := Hmin). rewrite Rabs_right; simpl in |- *. ring; auto. apply Rle_ge; apply Rplus_le_reg_l with (r := r). replace (r + 0)%R with r; [ idtac | ring ]. replace (r + (p - r))%R with (FtoRradix p); [ apply isMax_inv1 with (1 := H'3) | ring ]. Qed. Theorem closestLessMultNeg : forall (p : float) (r : R), Closest b radix r p -> (r <= 0)%R -> (2%nat * r <= p)%R. intros p r H' H'0. replace (2%nat * r)%R with (- (2%nat * - r))%R; [ idtac | ring ]. replace (FtoRradix p) with (- - p)%R; [ unfold FtoRradix in |- *; rewrite <- Fopp_correct | ring ]. apply Ropp_le_contravar. apply closestLessMultPos; auto. apply ClosestOpp; auto. replace 0%R with (-0)%R; [ auto with real | ring ]. Qed. Theorem closestLessMultAbs : forall (p : float) (r : R), Closest b radix r p -> (Rabs p <= 2%nat * Rabs r)%R. intros p r H'; case (Rle_or_lt 0 r); intros H'1. repeat rewrite Rabs_right; auto with real. apply closestLessMultPos; auto. apply Rle_ge; apply (RleRoundedR0 b radix precision) with (P := Closest b radix) (r := r); auto. apply ClosestRoundedModeP with (precision := precision); auto. repeat rewrite Faux.Rabsolu_left1; auto. replace (2%nat * - r)%R with (- (2%nat * r))%R; [ apply Ropp_le_contravar | ring ]. apply closestLessMultNeg; auto. apply Rlt_le; auto. apply Rlt_le; auto. apply (RleRoundedLessR0 b radix precision) with (P := Closest b radix) (r := r); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply Rlt_le; auto. Qed. Theorem errorBoundedMultClosest_aux : forall p q pq : float, Fbounded b p -> Fbounded b q -> Closest b radix (p * q) pq -> (- dExp b <= Fexp p + Fexp q)%Z -> (p * q - pq)%R <> 0%R :>R -> ex (fun r : float => ex (fun s : float => Fcanonic radix b r /\ Fbounded b r /\ Fbounded b s /\ r = pq :>R /\ s = (p * q - r)%R :>R /\ Fexp s = (Fexp p + Fexp q)%Z :>Z /\ (Fexp s <= Fexp r)%Z /\ (Fexp r <= precision + (Fexp p + Fexp q))%Z)). intros p q pq Hp Hq H1 H2 H3. cut (RoundedModeP b radix (Closest b radix)); [ intros H4 | apply ClosestRoundedModeP with precision; auto ]. lapply (errorBoundedMultExp b radix precision); [ intros H'2; lapply H'2; [ intros H'3; lapply H'3; [ intros H'4; lapply (H'4 (Closest b radix)); [ intros H'7; elim (H'7 p q pq); [ intros r E; elim E; intros s E0; elim E0; intros H'15 H'16; elim H'16; intros H'17 H'18; elim H'18; intros H'19 H'20; elim H'20; intros H'21 H'22; elim H'22; intros H'23 H'24; elim H'24; intros H'25 H'26; clear H'24 H'22 H'20 H'18 H'16 E0 E H'3 H'2 | clear H'3 H'2 | clear H'3 H'2 | clear H'3 H'2 | clear H'3 H'2 ] | clear H'3 H'2 ] | clear H'3 H'2 ] | clear H'2 ] | idtac]; auto. exists (Fnormalize radix b precision r); exists s. cut (Fbounded b (Fnormalize radix b precision r)); [ intros H5 | apply FnormalizeBounded; auto with arith ]. split; [ apply FnormalizeCanonic; auto with arith | idtac ]. repeat (split; auto). unfold FtoRradix in |- *; rewrite <- H'19; unfold FtoRradix in |- *; apply FnormalizeCorrect; auto. unfold FtoRradix in |- *; rewrite FnormalizeCorrect; auto with arith. apply Zlt_le_weak. apply RoundedModeErrorExpStrict with b radix precision (Closest b radix) (p * q)%R; auto with arith. generalize ClosestCompatible; unfold CompatibleP in |- *; intros H6. generalize (H6 b radix (FtoRradix p * FtoRradix q)%R (FtoRradix p * FtoRradix q)%R pq); intros H9; apply H9; auto. rewrite FnormalizeCorrect; auto with real arith. rewrite FnormalizeCorrect; auto with real arith. rewrite H'21; rewrite H'19; auto. apply Zle_trans with (Fexp r); auto. apply FcanonicLeastExp with radix b precision; auto with arith. rewrite FnormalizeCorrect; auto with real arith. apply FnormalizeCanonic; auto with arith. Qed. Theorem errorBoundedMultClosest : forall p q pq : float, Fbounded b p -> Fbounded b q -> Closest b radix (p * q) pq -> (- dExp b <= Fexp p + Fexp q)%Z -> (- dExp b <= Fexp (Fnormalize radix b precision pq) - precision)%Z -> ex (fun r : float => ex (fun s : float => Fcanonic radix b r /\ Fbounded b r /\ Fbounded b s /\ r = pq :>R /\ s = (p * q - r)%R :>R /\ Fexp s = (Fexp r - precision)%Z :>Z)). intros. cut (RoundedModeP b radix (Closest b radix)); [ intros G1 | apply ClosestRoundedModeP with precision; auto ]. case (Req_dec (p * q - pq) 0); intros U. exists (Fnormalize radix b precision pq); exists (Fzero (Fexp (Fnormalize radix b precision pq) - precision)). cut (Fbounded b pq); [ intros G2 | apply RoundedModeBounded with radix (Closest b radix) (p * q)%R; auto ]. cut (Fcanonic radix b (Fnormalize radix b precision pq)); [ intros G3 | apply FnormalizeCanonic; auto with arith ]. cut (Fbounded b (Fnormalize radix b precision pq)); [ intros G4 | apply FnormalizeBounded; auto with arith ]. cut (Fnormalize radix b precision pq = pq :>R); [ intros G5 | unfold FtoRradix in |- *; apply FnormalizeCorrect; auto with arith ]. repeat (split; auto). rewrite G5; unfold FtoRradix in |- *; rewrite FzeroisReallyZero; auto with real. lapply (errorBoundedMultClosest_aux p q pq); auto; intros H5. lapply H5; auto; intros H6; clear H5. lapply H6; auto; intros H5; clear H6. lapply H5; auto; intros H6; clear H5. lapply H6; auto; intros H5; clear H6. elim H5; intros r H6; clear H5. elim H6; intros s H5; clear H6. elim H5; intros H7 H6; clear H5. elim H6; intros H8 H9; clear H6. elim H9; intros H6 H10; clear H9. elim H10; intros H9 H11; clear H10. elim H11; intros H10 H12; clear H11. elim H12; intros H11 H13; clear H12. elim H13; intros H12 H14; clear H13. cut (ex (fun m : Z => s = Float m (Fexp r - precision) :>R /\ (Zabs m <= pPred (vNum b))%Z)). intros H13; elim H13; intros m H15; elim H15; intros H16 H17; clear H15 H13. exists r; exists (Float m (Fexp r - precision)). split; auto. split; auto. split. 2: repeat (split; auto). 2: rewrite <- H16; auto. split; simpl in |- *. generalize H17; unfold pPred in |- *; apply Zle_Zpred_inv. replace r with (Fnormalize radix b precision pq); auto with zarith. apply FcanonicUnique with radix b precision; auto with zarith. apply FnormalizeCanonic; auto with zarith; elim H1; auto. rewrite FnormalizeCorrect; auto with real zarith. cut (radix <> 0%Z :>Z); [ intros V | auto with arith real zarith ]. cut (0 < radix)%Z; [ intros V2 | auto with arith real zarith ]. rewrite H10; unfold FtoRradix in |- *; rewrite <- Fmult_correct; auto. rewrite <- Fminus_correct; fold FtoRradix in |- *; auto. unfold Fmult in |- *; unfold Fminus in |- *; unfold Fopp in |- *; unfold Fplus in |- *; simpl in |- *. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *. rewrite Zmin_le1; auto with zarith. replace (Fnum p * Fnum q * Zpower_nat radix (Zabs_nat (Fexp p + Fexp q - (Fexp p + Fexp q))))%Z with (Fnum p * Fnum q)%Z. 2: replace (Fexp p + Fexp q - (Fexp p + Fexp q))%Z with 0%Z; auto with zarith arith; simpl in |- *. 2: rewrite Zpower_nat_O. 2: replace (Z_of_nat 1) with 1%Z; auto with zarith. exists ((Fnum p * Fnum q + - Fnum r * Zpower_nat radix (Zabs_nat (Fexp r - (Fexp p + Fexp q)))) * Zpower_nat radix (Zabs_nat (Fexp p + Fexp q + (precision - Fexp r))))%Z; split. rewrite plus_IZR. repeat rewrite Rmult_IZR. rewrite plus_IZR. repeat rewrite Rmult_IZR. rewrite (Zpower_nat_powerRZ_absolu radix (Fexp r - (Fexp p + Fexp q))). 2: auto with zarith arith. rewrite (Zpower_nat_powerRZ_absolu radix (Fexp p + Fexp q + (precision - Fexp r))) . 2: auto with zarith arith. cut (radix <> 0%R :>R); [ intros W | auto with real arith zarith ]. unfold Zminus in |- *. repeat rewrite powerRZ_add; try rewrite <- INR_IZR_INZ; auto. apply trans_eq with ((Fnum p * Fnum q + (- Fnum r)%Z * (powerRZ radix (Fexp r) * powerRZ radix (- (Fexp p + Fexp q)))) * (powerRZ radix (Fexp p) * powerRZ radix (Fexp q)))%R. ring; ring. apply trans_eq with ((Fnum p * Fnum q + (- Fnum r)%Z * (powerRZ radix (Fexp r) * powerRZ radix (- (Fexp p + Fexp q)))) * (powerRZ radix (Fexp p) * powerRZ radix (Fexp q) * (powerRZ radix precision * powerRZ radix (- precision))) * (powerRZ radix (Fexp r) * powerRZ radix (- Fexp r)))%R. 2: ring; ring. replace (powerRZ radix precision * powerRZ radix (- precision))%R with 1%R. replace (powerRZ radix (Fexp r) * powerRZ radix (- Fexp r))%R with 1%R; try ring. rewrite <- powerRZ_add; try rewrite <- INR_IZR_INZ; auto. rewrite Zplus_opp_r; simpl in |- *; auto. rewrite <- powerRZ_add; try rewrite <- INR_IZR_INZ; auto. rewrite Zplus_opp_r; simpl in |- *; auto. apply le_IZR; rewrite <- Faux.Rabsolu_Zabs. rewrite Rmult_IZR; rewrite plus_IZR. repeat rewrite Rmult_IZR. rewrite (Zpower_nat_powerRZ_absolu radix (Fexp p + Fexp q + (precision - Fexp r))) . 2: auto with zarith arith. rewrite (Zpower_nat_powerRZ_absolu radix (Fexp r - (Fexp p + Fexp q))). 2: auto with zarith arith. rewrite powerRZ_add; try rewrite <- INR_IZR_INZ; auto with real arith. replace ((Fnum p * Fnum q + (- Fnum r)%Z * powerRZ radix (Fexp r - (Fexp p + Fexp q))) * (powerRZ radix (Fexp p + Fexp q) * powerRZ radix (precision - Fexp r)))%R with ((Fnum p * Fnum q + (- Fnum r)%Z * powerRZ radix (Fexp r - (Fexp p + Fexp q))) * powerRZ radix (Fexp p + Fexp q) * powerRZ radix (precision - Fexp r))%R; [ idtac | ring; ring ]. rewrite Rabs_mult. rewrite (Rabs_right (powerRZ radix (precision - Fexp r))). 2: apply Rle_ge; apply powerRZ_le; auto with real zarith. apply Rmult_le_reg_l with (powerRZ radix (Fexp r - precision)). apply powerRZ_lt; auto with real arith. rewrite Rmult_comm; rewrite Rmult_assoc; rewrite <- powerRZ_add. 2: auto with zarith arith real. replace (precision - Fexp r + (Fexp r - precision))%Z with 0%Z; [ simpl in |- * | ring ]. apply Rle_trans with (Rabs ((Fnum p * Fnum q + (- Fnum r)%Z * powerRZ radix (Fexp r - (Fexp p + Fexp q))) * powerRZ radix (Fexp p + Fexp q))); [ right; ring | idtac ]. replace ((Fnum p * Fnum q + (- Fnum r)%Z * powerRZ radix (Fexp r - (Fexp p + Fexp q))) * powerRZ radix (Fexp p + Fexp q))%R with (p * q - r)%R. 2: unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *; unfold Rminus in |- *. 2: unfold Zminus in |- *; repeat rewrite Ropp_Ropp_IZR. 2: repeat rewrite powerRZ_add; auto with real arith. 2: apply trans_eq with (Fnum p * Fnum q * (powerRZ radix (Fexp p) * powerRZ radix (Fexp q)) + - Fnum r * (powerRZ radix (Fexp r) * (powerRZ radix (- (Fexp p + Fexp q)) * (powerRZ radix (Fexp p) * powerRZ radix (Fexp q)))))%R; [ idtac | ring ]. 2: replace (powerRZ radix (- (Fexp p + Fexp q)) * (powerRZ radix (Fexp p) * powerRZ radix (Fexp q)))%R with 1%R; try ring. 2: repeat rewrite <- powerRZ_add; auto with real arith. 2: replace (- (Fexp p + Fexp q) + (Fexp p + Fexp q))%Z with 0%Z; simpl in |- *; simpl; ring. apply Rle_trans with (powerRZ radix (Fexp r) * / 2%nat)%R. rewrite <- H10; replace (powerRZ radix (Fexp r)) with (FtoRradix (Float 1%nat (Fexp r))); unfold FtoRradix in |- *; [ idtac | unfold FtoR in |- *; simpl in |- *; ring ]. apply ClosestErrorBound with b precision (p * q)%R; auto. apply (ClosestCompatible b radix (p * q)%R (p * q)%R pq); auto. unfold Zminus in |- *; rewrite powerRZ_add; auto with real arith. rewrite Rmult_assoc; apply Rmult_le_compat_l. apply powerRZ_le; auto with real arith. unfold pPred, Zpred in |- *; rewrite pGivesBound. rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ. replace (powerRZ radix (- precision) * (powerRZ radix precision + (-1)%Z))%R with (1 + - powerRZ radix (- precision))%R. apply Rle_trans with (1 + - powerRZ radix (- 1%nat))%R. simpl in |- *. replace (radix * 1)%R with (IZR radix); [ idtac | ring ]. replace (/ 2)%R with (1 + - / 2)%R. apply Rplus_le_compat_l; apply Ropp_le_contravar. apply Rle_Rinv; auto with real arith zarith. replace 2%R with (IZR (Zsucc 1)); auto with real arith zarith. cut (2%R <> 0%R :>R); [ intros | idtac ]. 2: replace 2%R with (INR 2); auto with real arith zarith. apply Rmult_eq_reg_l with 2%R; auto. rewrite Rmult_plus_distr_l. rewrite (Rmult_comm 2 (- / 2)). rewrite Ropp_mult_distr_l_reverse. rewrite (Rmult_comm (/ 2) 2). rewrite Rinv_r; auto with real; ring. apply Rplus_le_compat_l; apply Ropp_le_contravar. apply Rle_powerRZ; auto with real arith zarith. rewrite Rmult_plus_distr_l. rewrite <- powerRZ_add; auto with real arith. replace (- precision + precision)%Z with 0%Z; simpl in |- *; ring. Qed. End FRoundP. Float8.4/ClosestPlus.v0000644000423700002640000006546512032774524014536 0ustar sboldotoccata(**************************************************************************** IEEE754 : ClosestPlus Laurent Thery, Sylvie Boldo ******************************************************************************) Require Export FroundPlus. Require Export ClosestProp. Section ClosestP. Variable b : Fbound. Variable radix : Z. Variable precision : nat. Coercion Local FtoRradix := FtoR radix. Hypothesis radixMoreThanOne : (1 < radix)%Z. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Theorem errorBoundedPlusLe : forall p q pq : float, Fbounded b p -> Fbounded b q -> (Fexp p <= Fexp q)%Z -> Closest b radix (p + q) pq -> exists error : float, error = Rabs (p + q - pq) :>R /\ Fbounded b error /\ Fexp error = Zmin (Fexp p) (Fexp q). intros p q pq H' H'0 H'1 H'2. cut (ex (fun m : Z => pq = Float m (Fexp (Fplus radix p q)) :>R)). 2: unfold FtoRradix in |- *; apply RoundedModeRep with (b := b) (precision := precision) (P := Closest b radix); auto. 2: apply ClosestRoundedModeP with (precision := precision); auto. 2: rewrite (Fplus_correct radix); auto with arith. intros H'3; elim H'3; intros m E; clear H'3. exists (Fabs (Fminus radix q (Fminus radix (Float m (Fexp (Fplus radix p q))) p))). cut (forall A B : Prop, A -> (A -> B) -> A /\ B); [ intros tmp; apply tmp; clear tmp | auto ]. unfold FtoRradix in |- *; rewrite Fabs_correct; auto with arith. cut (forall p q : R, p = q -> Rabs p = Rabs q); [ intros tmp; apply tmp; clear tmp | intros p' q' H; rewrite H; auto ]. unfold FtoRradix in |- *; repeat rewrite Fminus_correct; auto with arith. unfold FtoRradix in E; rewrite E; auto. ring. intros H'4. cut (Rabs (pq - (p + q)) <= Rabs (q - (p + q)))%R. 2: elim H'2; auto. replace (q - (p + q))%R with (- FtoRradix p)%R. 2: ring. rewrite Rabs_Ropp. unfold FtoRradix in |- *; rewrite <- Fabs_correct; auto with arith. rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr. unfold FtoRradix in H'4; rewrite <- H'4. simpl in |- *. rewrite Zmin_le1; auto. generalize H'1 H'; case p; case q; unfold Fabs, Fminus, Fopp, Fplus in |- *; simpl in |- *; clear H'1 H'. intros Fnum1 Fexp1 Fnum2 Fexp2 H'5 H'6. repeat rewrite Zmin_n_n; auto. repeat rewrite (Zmin_le2 _ _ H'5); auto with zarith. replace (Zabs_nat (Fexp2 - Fexp2)) with 0. rewrite Zpower_nat_O. cut (forall z : Z, (z * 1%nat)%Z = z); [ intros tmp; repeat rewrite tmp; clear tmp | auto with zarith ]. unfold FtoRradix, FtoR in |- *; simpl in |- *. intros H'. repeat split; simpl in |- *. rewrite (fun x => Zabs_eq (Zabs x)); auto with zarith. apply Zle_lt_trans with (Zabs Fnum2); auto. apply le_IZR. apply (Rle_monotony_contra_exp radix) with (z := Fexp2); auto. case H'6; auto. case H'6; auto. intros; simpl in |- *; ring. replace (Fexp2 - Fexp2)%Z with 0%Z; simpl in |- *; auto with zarith. Qed. Theorem errorBoundedPlusAbs : forall p q pq : float, Fbounded b p -> Fbounded b q -> Closest b radix (p + q) pq -> exists error : float, error = Rabs (p + q - pq) :>R /\ Fbounded b error /\ Fexp error = Zmin (Fexp p) (Fexp q). intros p q pq H' H'0 H'1. case (Zle_or_lt (Fexp p) (Fexp q)); intros H'2. apply errorBoundedPlusLe; auto. replace (p + q)%R with (q + p)%R; [ idtac | ring ]. replace (Zmin (Fexp p) (Fexp q)) with (Zmin (Fexp q) (Fexp p)); [ idtac | apply Zmin_sym ]. apply errorBoundedPlusLe; auto. auto with zarith. apply (ClosestCompatible b radix (p + q)%R (q + p)%R pq); auto. ring. case H'1; auto. Qed. Theorem errorBoundedPlus : forall p q pq : float, (Fbounded b p) -> (Fbounded b q) -> (Closest b radix (p + q) pq) -> exists error : float, error = (p + q - pq)%R :>R /\ (Fbounded b error) /\ (Fexp error) = (Zmin (Fexp p) (Fexp q)). intros p q pq H' H'0 H'1. case (errorBoundedPlusAbs p q pq); auto. intros x H'2; elim H'2; intros H'3 H'4; elim H'4; intros H'5 H'6; clear H'4 H'2. generalize H'3; clear H'3. unfold Rabs in |- *; case (Rcase_abs (p + q - pq)). intros H'2 H'3; exists (Fopp x); split; auto. unfold FtoRradix in |- *; rewrite Fopp_correct; auto. unfold FtoRradix in H'3; rewrite H'3; ring. split. apply oppBounded; auto. rewrite <- H'6; auto. intros H'2 H'3; exists x; split; auto. Qed. Theorem plusExact1 : forall p q r : float, Fbounded b p -> Fbounded b q -> Closest b radix (p + q) r -> (Fexp r <= Zmin (Fexp p) (Fexp q))%Z -> r = (p + q)%R :>R. intros p q r H' H'0 H'1 H'2. cut (2%nat * Rabs (FtoR radix (Fplus radix p q) - FtoR radix r) <= Float 1%nat (Fexp r))%R; [ rewrite Fplus_correct; auto with zarith; intros Rl1 | idtac ]. case errorBoundedPlus with (p := p) (q := q) (pq := r); auto. intros x H'3; elim H'3; intros H'4 H'5; elim H'5; intros H'6 H'7; clear H'5 H'3. unfold FtoRradix in H'4; rewrite <- H'4 in Rl1. 2: apply Rle_trans with (Fulp b radix precision r); auto. 2: apply (ClosestUlp b radix precision); auto. 2: rewrite Fplus_correct; auto with zarith. 2: unfold FtoRradix in |- *; apply FulpLe; auto. 2: apply RoundedModeBounded with (radix := radix) (P := Closest b radix) (r := (p + q)%R); auto. 2: apply ClosestRoundedModeP with (precision := precision); auto. cut (x = 0%R :>R); [ unfold FtoRradix in |- *; intros Eq1 | idtac ]. replace (FtoR radix r) with (FtoR radix r + 0)%R; [ idtac | ring ]. rewrite <- Eq1. rewrite H'4; ring. apply (is_Fzero_rep1 radix). case (Z_zerop (Fnum x)); simpl in |- *; auto. intros H'3; Contradict Rl1. apply Rgt_not_le. red in |- *; apply Rle_lt_trans with (Rabs (FtoR radix x)). unfold FtoRradix, FtoR in |- *; simpl in |- *; auto. rewrite Rabs_mult. apply Rmult_le_compat; auto with real arith. generalize H'3; case (Fnum x); simpl in |- *; auto with real zarith. intros H'5; case H'5; auto. intros p0 H'5; rewrite Rabs_right; auto with real arith. replace 1%R with (INR 1); auto with real arith. intros p0 H'5; rewrite Faux.Rabsolu_left1; auto. rewrite Ropp_involutive. replace 1%R with (INR 1); auto with real arith. replace 0%R with (- 0%nat)%R; auto with real; apply Ropp_le_ge_contravar; auto with real arith. rewrite Rabs_right; auto with real arith. apply Rle_powerRZ; auto with real arith. auto with zarith. apply Rle_ge; cut (1 < radix)%Z; auto with float real zarith. cut (forall r : R, (2%nat * r)%R = (r + r)%R); [ intros tmp; rewrite tmp; clear tmp | intros f; simpl in |- *; ring ]. pattern (Rabs (FtoR radix x)) at 1 in |- *; replace (Rabs (FtoR radix x)) with (Rabs (FtoR radix x) + 0)%R; [ idtac | ring ]. apply Rplus_lt_compat_l; auto. case (Rabs_pos (FtoR radix x)); auto. rewrite <- Fabs_correct; auto with arith. intros H'5; Contradict H'3. cut (Fnum (Fabs x) = 0%Z). unfold Fabs in |- *; simpl in |- *; case (Fnum x); simpl in |- *; auto; intros; discriminate. change (is_Fzero (Fabs x)) in |- *. apply (is_Fzero_rep2 radix); auto with arith. Qed. Theorem plusExact1bis : forall p q r : float, Fbounded b p -> Fbounded b q -> Closest b radix (p + q) r -> r <> (p + q)%R :>R -> (Zmin (Fexp p) (Fexp q) < Fexp r)%Z. intros p0 q0 r0 H' H'0 H'1 H'2; case (Zle_or_lt (Fexp r0) (Zmin (Fexp p0) (Fexp q0))); auto. intros H'3; Contradict H'2. apply plusExact1; auto. Qed. Theorem plusExact2Aux : forall p q r : float, (0 <= p)%R -> Fcanonic radix b p -> Fbounded b q -> Closest b radix (p + q) r -> (Fexp r < Zpred (Fexp p))%Z -> r = (p + q)%R :>R. intros p q r H' H'0 H'1 H'2 H'3. apply plusExact1; auto. apply FcanonicBound with (1 := H'0); auto. case (Zle_or_lt (Fexp p) (Fexp q)); intros Zl1. rewrite Zmin_le1; auto with zarith. apply Zle_trans with (Zpred (Fexp p)); auto with zarith. unfold Zpred in |- *; auto with zarith. rewrite Zmin_le2; auto with zarith. case (Zlt_next _ _ Zl1); intros Zl2. rewrite Zl2 in H'3. replace (Fexp q) with (Zpred (Zsucc (Fexp q))); auto with zarith; unfold Zpred, Zsucc in |- *; ring. case H'0; clear H'0; intros H'0. absurd (r < Float (nNormMin radix precision) (Zpred (Fexp p)))%R. apply Rle_not_lt; auto. unfold FtoRradix in |- *; apply (ClosestMonotone b radix (Float (nNormMin radix precision) (Zpred (Fexp p))) ( p + q)%R); auto; auto. cut (Float (nNormMin radix precision) (Fexp p) <= p)%R; [ intros Eq1 | idtac ]. case (Rle_or_lt 0 q); intros Rl1. apply Rlt_le_trans with (FtoRradix p). apply Rlt_le_trans with (FtoRradix (Float (nNormMin radix precision) (Fexp p))); auto. unfold FtoRradix, FtoR in |- *; simpl in |- *; auto. apply Rmult_lt_compat_l; auto with real arith. replace 0%R with (IZR 0%nat); auto with real; auto with real float arith. apply Rlt_IZR; apply nNormPos; auto with zarith. unfold Zpred in |- *; auto with real float zarith arith. pattern (FtoRradix p) at 1 in |- *; replace (FtoRradix p) with (p + 0)%R; auto with real. apply Rplus_lt_reg_r with (r := (- q)%R); auto. replace (- q + (p + q))%R with (FtoRradix p); [ idtac | ring ]. apply Rlt_le_trans with (FtoRradix (Float (nNormMin radix precision) (Fexp p))); auto. apply Rlt_le_trans with (2%nat * Float (nNormMin radix precision) (Zpred (Fexp p)))%R; auto. cut (forall r : R, (2%nat * r)%R = (r + r)%R); [ intros tmp; rewrite tmp; clear tmp | intros; simpl in |- *; ring ]. rewrite (Rplus_comm (- q)). apply Rplus_lt_compat_l. rewrite <- Faux.Rabsolu_left1; auto. rewrite <- (Fabs_correct radix); auto with arith. unfold FtoRradix in |- *; apply maxMaxBis with (b := b); auto with zarith. apply Rlt_le; auto. apply Rle_trans with (radix * Float (nNormMin radix precision) (Zpred (Fexp p)))%R. apply Rmult_le_compat_r; auto. apply (LeFnumZERO radix); simpl in |- *; auto with arith. apply Zlt_le_weak; apply nNormPos; auto with zarith. rewrite INR_IZR_INZ; apply Rle_IZR; simpl in |- *; cut (1 < radix)%Z; auto with real zarith. pattern (Fexp p) at 2 in |- *; replace (Fexp p) with (Zsucc (Zpred (Fexp p))); [ idtac | unfold Zsucc, Zpred in |- *; ring ]. unfold FtoRradix, FtoR in |- *; simpl in |- *. rewrite powerRZ_Zs; auto with real zarith. repeat rewrite <- Rmult_assoc. rewrite (Rmult_comm radix); auto with real. unfold FtoRradix, FtoR in |- *; simpl in |- *; auto. apply Rmult_le_compat_r; auto with real zarith. apply Rle_IZR. rewrite <- (Zabs_eq (Fnum p)); auto with zarith. apply pNormal_absolu_min with (b := b); auto with arith. unfold FtoRradix, FtoR in |- *; simpl in |- *; auto. apply (LeR0Fnum radix); auto with arith. apply (RoundedModeProjectorIdem b radix (Closest b radix)); auto. apply ClosestRoundedModeP with (precision := precision); auto. repeat split; simpl in |- *. rewrite Zabs_eq; auto with zarith. apply ZltNormMinVnum; auto with arith. apply Zlt_le_weak; apply nNormPos; auto with zarith. apply Zle_trans with (Fexp q); auto with float zarith. case (Rle_or_lt 0 r); intros Rl1. rewrite <- (Rabs_right r); auto with real. rewrite <- (Fabs_correct radix); auto with arith. unfold FtoRradix in |- *; apply maxMaxBis with (b := b); auto with zarith. apply RoundedModeBounded with (radix := radix) (P := Closest b radix) (r := (p + q)%R); auto. apply ClosestRoundedModeP with (precision := precision); auto with real. apply Rlt_le_trans with 0%R; auto. apply (LeFnumZERO radix); simpl in |- *; auto with arith. apply Zlt_le_weak; apply nNormPos; auto with zarith. absurd (- dExp b <= Fexp q)%Z; auto with float. apply Zlt_not_le. case H'0; intros Z1 (Z2, Z3); rewrite <- Z2; auto with zarith. Qed. Theorem plusExact2 : forall p q r : float, Fcanonic radix b p -> Fbounded b q -> Closest b radix (p + q) r -> (Fexp r < Zpred (Fexp p))%Z -> r = (p + q)%R :>R. intros p q r H' H'0 H'1 H'2. case (Rle_or_lt 0 p); intros Rl1. apply plusExact2Aux; auto. replace (p + q)%R with (- (Fopp p + Fopp q))%R. rewrite <- (plusExact2Aux (Fopp p) (Fopp q) (Fopp r)); auto. unfold FtoRradix in |- *; rewrite Fopp_correct; ring. unfold FtoRradix in |- *; rewrite Fopp_correct. apply Rlt_le; replace 0%R with (-0)%R; auto with real. apply FcanonicFopp; auto with arith. apply oppBounded; auto. replace (Fopp p + Fopp q)%R with (- (p + q))%R. apply ClosestOpp; auto. unfold FtoRradix in |- *; repeat rewrite Fopp_correct; ring. unfold FtoRradix in |- *; repeat rewrite Fopp_correct; ring. Qed. Theorem plusExactR0 : forall p q r : float, Fbounded b p -> Fbounded b q -> Closest b radix (p + q) r -> r = 0%R :>R -> r = (p + q)%R :>R. intros p q r H' H'0 H'1 H'2. cut (r = FtoRradix (Fzero (- dExp b)) :>R); [ intros Eq1; rewrite Eq1 | rewrite H'2; apply sym_eq; unfold FtoRradix in |- *; apply FzeroisZero ]. apply plusExact1; auto. apply (ClosestCompatible b radix (p + q)%R (p + q)%R r); auto. apply FboundedFzero; auto. simpl in |- *; auto. unfold Zmin in |- *; case (Fexp p ?= Fexp q)%Z; auto with float. Qed. Theorem plusErrorBound1 : forall p q r : float, Fbounded b p -> Fbounded b q -> Closest b radix (p + q) r -> ~ is_Fzero r -> (Rabs (r - (p + q)) < Rabs r * / 2%nat * (radix * / pPred (vNum b)))%R. intros p q r H' H'0 H'1 H'2. cut (Fcanonic radix b (Fnormalize radix b precision r)); [ intros tmp; Casec tmp; intros Fs | idtac ]. 3: apply FnormalizeCanonic; auto with arith. 3: apply RoundedModeBounded with (radix := radix) (P := Closest b radix) (r := (p + q)%R); auto. 3: apply ClosestRoundedModeP with (precision := precision); auto. 2: rewrite <- (plusExact1 p q (Fnormalize radix b precision r)); auto. 2: unfold FtoRradix in |- *; rewrite FnormalizeCorrect; auto with arith. 2: replace (FtoR radix r - FtoR radix r)%R with 0%R; [ idtac | ring ]. 2: rewrite Rabs_R0. 2: replace 0%R with (0 * (radix * / pPred (vNum b)))%R; [ apply Rmult_lt_compat_r | ring ]. 2: replace 0%R with (0 * / pPred (vNum b))%R; [ apply Rmult_lt_compat_r | ring ]. 2: apply Rinv_0_lt_compat; replace 0%R with (IZR 0); auto with real zarith. 2: apply Rlt_IZR; unfold pPred in |- *; apply Zlt_succ_pred; simpl in |- *. 2: apply vNumbMoreThanOne with (radix := radix) (precision := precision); auto with real zarith. 2: cut (1 < radix)%Z; auto with real zarith. 2: replace 0%R with (0 * / 2%nat)%R; [ apply Rmult_lt_compat_r | ring ]; auto with real. 2: case (Rabs_pos (FtoR radix r)); auto. 2: intros H'3; Contradict H'2. 2: apply is_Fzero_rep2 with (radix := radix); auto with real arith. 2: generalize H'3; fold FtoRradix in |- *; unfold Rabs in |- *; case (Rcase_abs r); auto. 2: intros r0 H'2; replace 0%R with (-0)%R; [ rewrite H'2 | idtac ]; ring. 2: apply (ClosestCompatible b radix (p + q)%R (p + q)%R r); auto. 2: apply sym_eq; apply FnormalizeCorrect; auto. 2: apply FnormalizeBounded; auto with arith. 2: apply RoundedModeBounded with (radix := radix) (P := Closest b radix) (r := (p + q)%R); auto. 2: apply ClosestRoundedModeP with (precision := precision); auto. 2: replace (Fexp (Fnormalize radix b precision r)) with (- dExp b)%Z. 2: unfold Zmin in |- *; case (Fexp p ?= Fexp q)%Z; auto with float. 2: apply sym_equal; case Fs; intros H1 H2; case H2; auto. apply Rle_lt_trans with (/ 2%nat * Fulp b radix precision r)%R. apply Rmult_le_reg_l with (r := INR 2); auto with real. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real; rewrite Rmult_1_l. unfold FtoRradix in |- *; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; rewrite <- (Fplus_correct radix); auto with zarith. apply ClosestUlp; auto. rewrite Fplus_correct; auto with arith. replace (Rabs r * / 2%nat * (radix * / pPred (vNum b)))%R with (/ 2%nat * (Rabs r * (radix * / pPred (vNum b))))%R; [ apply Rmult_lt_compat_l; auto with real | ring ]. replace (Fulp b radix precision r) with (Float (pPred (vNum b)) (Zpred (Fexp (Fnormalize radix b precision r))) * (radix * / pPred (vNum b)))%R. apply Rmult_lt_compat_r. replace 0%R with (radix * 0)%R; [ apply Rmult_lt_compat_l | ring ]; auto with real arith. apply Rinv_0_lt_compat; replace 0%R with (IZR 0%nat); auto with real arith; apply Rlt_IZR. unfold pPred in |- *; apply Zlt_succ_pred; apply (vNumbMoreThanOne radix) with (precision := precision); auto with zarith. unfold FtoRradix in |- *; rewrite <- (FnormalizeCorrect _ radixMoreThanOne b precision r). rewrite <- (Fabs_correct radix); auto with arith. apply FnormalBoundAbs; auto with zarith. unfold Fulp, FtoRradix, FtoR in |- *; simpl in |- *. apply trans_eq with (pPred (vNum b) * / pPred (vNum b) * (radix * powerRZ radix (Zpred (Fexp (Fnormalize radix b precision r)))))%R; [ ring | idtac ]; auto. rewrite Rinv_r; auto with real arith. rewrite <- powerRZ_Zs; auto with real. cut (forall r : Z, Zsucc (Zpred r) = r); [ intros Er; rewrite Er | intros r'; unfold Zsucc, Zpred in |- * ]; ring. apply Rlt_dichotomy_converse; right; red in |- *. replace 0%R with (IZR 0); cut (1 < radix)%Z; auto with real zarith. apply Rlt_dichotomy_converse; right; red in |- *. replace 0%R with (IZR 0); auto with real zarith. unfold pPred in |- *; apply Rlt_IZR; apply Zlt_succ_pred; simpl in |- *. apply vNumbMoreThanOne with (radix := radix) (precision := precision); auto with real arith. Qed. Theorem plusErrorBound1bis : forall p q r : float, Fbounded b p -> Fbounded b q -> Closest b radix (p + q) r -> ~ is_Fzero r -> (Rabs (r - (p + q)) <= Rabs r * / 2%nat * (radix * / Zpos (vNum b)))%R. intros p q r H' H'0 H'1 H'2. cut (Fcanonic radix b (Fnormalize radix b precision r)); [ intros tmp; Casec tmp; intros Fs | idtac ]. 3: apply FnormalizeCanonic; auto with arith. 3: apply RoundedModeBounded with (radix := radix) (P := Closest b radix) (r := (p + q)%R); auto. 3: apply ClosestRoundedModeP with (precision := precision); auto. 2: rewrite <- (plusExact1 p q (Fnormalize radix b precision r)); auto. 2: unfold FtoRradix in |- *; rewrite FnormalizeCorrect; auto. 2: replace (FtoR radix r - FtoR radix r)%R with 0%R; [ idtac | ring ]. 2: rewrite Rabs_R0. 2: replace 0%R with (0 * (radix * / Zpos (vNum b)))%R; [ apply Rmult_le_compat_r | ring ]; auto with real zarith. 2: replace 0%R with (0 * / Zpos (vNum b))%R; [ apply Rmult_le_compat_r | ring ]; auto with real zarith. 2: replace 0%R with (0 * / 2%nat)%R; [ apply Rmult_le_compat_r | ring ]; auto with real zarith. 2: apply (ClosestCompatible b radix (p + q)%R (p + q)%R r); auto. 2: apply sym_eq; apply FnormalizeCorrect; auto. 2: apply FnormalizeBounded; auto with arith. 2: apply RoundedModeBounded with (radix := radix) (P := Closest b radix) (r := (p + q)%R); auto. 2: apply ClosestRoundedModeP with (precision := precision); auto. 2: replace (Fexp (Fnormalize radix b precision r)) with (- dExp b)%Z. 2: unfold Zmin in |- *; case (Fexp p ?= Fexp q)%Z; intuition. 2: case Fs; intros H1 (H2, H3); auto. apply Rle_trans with (/ 2%nat * Fulp b radix precision r)%R. replace (Rabs (FtoRradix r - (FtoRradix p + FtoRradix q))) with (/ 2%nat * (2%nat * Rabs (FtoRradix r - (FtoRradix p + FtoRradix q))))%R; [ idtac | rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real ]. apply Rmult_le_compat_l; auto with real. replace (FtoRradix r - (FtoRradix p + FtoRradix q))%R with (- (FtoRradix p + FtoRradix q - FtoRradix r))%R; [ rewrite Rabs_Ropp | ring ]. apply (ClosestUlp b radix); auto. replace (Rabs r * / 2%nat * (radix * / Zpos (vNum b)))%R with (/ 2%nat * (Rabs r * (radix * / Zpos (vNum b))))%R; [ apply Rmult_le_compat_l; auto with real | ring ]. replace (Fulp b radix precision r) with (Zpos (vNum b) * FtoR radix (Float 1%nat (Zpred (Fexp (Fnormalize radix b precision r)))) * (radix * / Zpos (vNum b)))%R. apply Rmult_le_compat_r. replace 0%R with (radix * 0)%R; [ apply Rmult_le_compat_l | ring ]; apply Rlt_le; auto with real arith. apply Rinv_0_lt_compat; replace 0%R with (INR 0); auto with float real arith. rewrite INR_IZR_INZ; apply Rlt_IZR; simpl in |- *; apply Zlt_1_O; apply Zlt_le_weak; apply (vNumbMoreThanOne radix) with (precision := precision); auto with zarith. unfold FtoRradix in |- *; rewrite <- (FnormalizeCorrect _ radixMoreThanOne b precision r). rewrite <- (Fabs_correct radix); auto with arith. apply FnormalBoundAbs2 with precision; auto with arith. unfold Fulp, FtoRradix, FtoR in |- *; simpl in |- *. apply trans_eq with (nat_of_P (vNum b) * / nat_of_P (vNum b) * (radix * powerRZ radix (Zpred (Fexp (Fnormalize radix b precision r)))))%R; [ ring | idtac ]; auto. rewrite Rinv_r; auto with real arith. rewrite <- powerRZ_Zs; auto with real zarith. rewrite <- Zsucc_pred; ring. Qed. Theorem plusErrorBound1withZero : forall p q r : float, Fbounded b p -> Fbounded b q -> Closest b radix (p + q) r -> (Rabs (r - (p + q)) <= Rabs r * / 2%nat * (radix * / pPred (vNum b)))%R. intros p q r H H0 H1. case (Req_dec r 0); intros Hr. replace (Rabs (r - (p + q))) with (Rabs r * / 2%nat * 0)%R. apply Rmult_le_compat_l. replace 0%R with (Rabs r * 0)%R; [ apply Rmult_le_compat_l | ring ]; auto with real arith. replace 0%R with (radix * 0)%R; [ apply Rmult_le_compat_l | ring ]; auto with real arith. apply Rlt_le; apply Rinv_0_lt_compat; auto with real arith. replace 0%R with (IZR 0%nat); auto with real zarith; apply Rlt_IZR. apply Zle_lt_trans with (nNormMin radix precision). apply Zlt_le_weak; apply nNormPos; auto with real zarith. apply nNormMimLtvNum; auto with real zarith. rewrite <- plusExactR0 with (3 := H1); auto with real zarith. rewrite Hr; repeat rewrite Rabs_R0 || (rewrite Rminus_diag_eq; auto); ring. apply Rlt_le; apply plusErrorBound1; auto. Contradict Hr; unfold FtoRradix in |- *; apply is_Fzero_rep1; auto. Qed. Theorem pPredMoreThanOne : (0 < pPred (vNum b))%Z. unfold pPred in |- *; apply Zlt_succ_pred; simpl in |- *. apply (vNumbMoreThanOne radix) with (precision := precision); auto with zarith. Qed. Theorem pPredMoreThanRadix : (radix < pPred (vNum b))%Z. apply Zle_lt_trans with (nNormMin radix precision). pattern radix at 1 in |- *; rewrite <- (Zpower_nat_1 radix); unfold nNormMin in |- *; auto with zarith. apply nNormMimLtvNum; auto with zarith. Qed. Theorem RoundBound : forall x y p : float, Fbounded b x -> Fbounded b y -> Fbounded b p -> Closest b radix (x + y) p -> (radix < 2%nat * pPred (vNum b))%Z -> (Rabs p <= Rabs (x + y) * (2%nat * pPred (vNum b) * / (2%nat * pPred (vNum b) - radix)))%R. intros x y p H H0 H1 H2 H3. cut (0 < 2%nat * pPred (vNum b))%Z; [ intros NZ1 | apply Zlt_trans with radix; auto with zarith ]. cut (0 < 2%nat * pPred (vNum b))%R; [ intros NZ1' | rewrite INR_IZR_INZ; rewrite <- Rmult_IZR; auto with real zarith ]. cut (radix < 2%nat * pPred (vNum b))%R; [ intros NZ2 | rewrite INR_IZR_INZ; rewrite <- Rmult_IZR; auto with real zarith ]. replace (Rabs p) with (Rabs p * ((2%nat * pPred (vNum b) - radix) * / (2%nat * pPred (vNum b))) * (2%nat * pPred (vNum b) * / (2%nat * pPred (vNum b) - radix)))%R. 2: replace (Rabs p * ((2%nat * pPred (vNum b) - radix) * / (2%nat * pPred (vNum b))) * (2%nat * pPred (vNum b) * / (2%nat * pPred (vNum b) - radix)))%R with (Rabs p * ((2%nat * pPred (vNum b) - radix) * / (2%nat * pPred (vNum b) - radix)) * (2%nat * pPred (vNum b) * / (2%nat * pPred (vNum b))))%R; [ idtac | ring ]. 2: repeat rewrite Rinv_r; auto with real zarith; try ring. apply Rmult_le_compat_r. replace 0%R with (2%nat * pPred (vNum b) * 0)%R; [ apply Rmult_le_compat_l | ring ]; auto with real zarith. replace ((2%nat * pPred (vNum b) - radix) * / (2%nat * pPred (vNum b)))%R with (1 - radix * / (2%nat * pPred (vNum b)))%R. 2: unfold Rminus in |- *; rewrite Rmult_plus_distr_r; rewrite Rinv_r; auto with real. replace (Rabs p * (1 - radix * / (2%nat * pPred (vNum b))))%R with (Rabs p - Rabs p * (radix * / (2%nat * pPred (vNum b))))%R; [ idtac | ring; ring ]. apply Rplus_le_reg_l with (Rabs p * (radix * / (2%nat * pPred (vNum b))))%R. replace (Rabs (FtoRradix p) * (radix * / (2%nat * pPred (vNum b))) + (Rabs (FtoRradix p) - Rabs (FtoRradix p) * (radix * / (2%nat * pPred (vNum b)))))%R with (Rabs p); [ idtac | ring ]. apply Rle_trans with (Rabs (p - (x + y)) + Rabs (x + y))%R. pattern (FtoRradix p) at 1 in |- *; replace (FtoRradix p) with (p - (x + y) + (x + y))%R; [ apply Rabs_triang | ring ]. rewrite (Rplus_comm (Rabs (p - (x + y))) (Rabs (x + y))); rewrite (Rplus_comm (Rabs p * (radix * / (2%nat * pPred (vNum b)))) (Rabs (x + y))) ; apply Rplus_le_compat_l. replace (Rabs p * (radix * / (2%nat * pPred (vNum b))))%R with (Rabs p * / 2%nat * (radix * / pPred (vNum b)))%R; [ apply plusErrorBound1withZero | idtac ]; auto. rewrite (Rinv_mult_distr 2%nat (pPred (vNum b))); auto with real zarith. ring. apply NEq_IZRO; auto with real zarith. generalize pPredMoreThanOne; auto with zarith. Qed. Theorem plusExactExp : forall p q pq : float, Fbounded b p -> Fbounded b q -> Closest b radix (p + q) pq -> ex (fun r : float => ex (fun s : float => Fbounded b r /\ Fbounded b s /\ s = pq :>R /\ r = (p + q - s)%R :>R /\ Fexp r = Zmin (Fexp p) (Fexp q) :>Z /\ (Fexp r <= Fexp s)%Z /\ (Fexp s <= Zsucc (Zmax (Fexp p) (Fexp q)))%Z)). intros p q pq H H0 H1. case (plusExpBound b radix precision) with (P := Closest b radix) (5 := H1); auto with zarith. apply (ClosestRoundedModeP b radix precision); auto with zarith. intros r (H2, (H3, (H4, H5))); fold FtoRradix in H3. case (Req_dec (p + q - pq) 0); intros Hr. cut (Fbounded b (Fzero (Zmin (Fexp p) (Fexp q)))); [ intros Fbs | idtac ]. exists (Fzero (Zmin (Fexp p) (Fexp q))); exists r; repeat (split; auto). rewrite (FzeroisReallyZero radix); rewrite <- Hr; rewrite <- H3; auto. case (Zmin_or (Fexp p) (Fexp q)); intros Hz; rewrite Hz; apply FboundedZeroSameExp; auto. case (errorBoundedPlus p q pq); auto. intros error (H6, (H7, H8)). exists error; exists r; repeat (split; auto). rewrite H3; auto. rewrite H8; auto. Qed. Theorem plusExactExpCanonic : forall c d p q : float, Fbounded b c -> Fbounded b d -> Fbounded b p -> Fbounded b q -> Closest b radix (c + d) p -> q = (c + d - p)%R :>R -> q <> 0%R :>R -> ex (fun r : float => ex (fun s : float => Fcanonic radix b s /\ Fbounded b r /\ s = p :>R /\ r = (c + d - s)%R :>R /\ Fexp r = Zmin (Fexp c) (Fexp d) :>Z /\ (Fexp r < Fexp s)%Z /\ (Fexp s <= Zsucc (Zmax (Fexp c) (Fexp d)))%Z)). intros c d p q H H0 H1 H2 H3 H4 H5. case (plusExactExp c d p); auto. intros r (s, (H6, (H7, (H8, (H9, (H10, (H11, H12))))))). exists r; exists (Fnormalize radix b precision s). repeat (split; auto with float). apply FnormalizeCanonic; auto with arith. rewrite <- H8; apply (FnormalizeCorrect radix); auto with zarith. rewrite (FnormalizeCorrect radix); auto with zarith. apply ClosestErrorExpStrict with (radix := radix) (b := b) (precision := precision) (x := (c + d)%R); auto with float. apply FnormalizeBounded; auto with arith. apply (ClosestCompatible b radix (c + d)%R (c + d)%R p); auto. rewrite (FnormalizeCorrect radix); auto with zarith. apply FnormalizeBounded; auto with arith. rewrite (FnormalizeCorrect radix); auto with zarith. fold FtoRradix in |- *; rewrite H9; rewrite H8; rewrite <- H4; auto. apply Zle_trans with (Fexp s); auto. apply FcanonicLeastExp with radix b precision; auto with arith. apply sym_eq; apply FnormalizeCorrect; auto with real. apply FnormalizeCanonic; auto with arith. Qed. End ClosestP. Float8.4/ClosestProp.v0000644000423700002640000006667212032774524014534 0ustar sboldotoccata(**************************************************************************** IEEE754 : ClosestProp Laurent Thery, Sylvie Boldo ******************************************************************************) Require Export FroundProp. Require Export Closest. Section Fclosestp2. Variable b : Fbound. Variable radix : Z. Variable precision : 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 precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Theorem ClosestOpp : forall (p : float) (r : R), Closest b radix r p -> Closest b radix (- r) (Fopp p). intros p r H'; split. apply oppBounded; auto. case H'; auto. intros f H'0. rewrite Fopp_correct. replace (- FtoR radix p - - r)%R with (- (FtoR radix p - r))%R; [ idtac | ring ]. replace (FtoR radix f - - r)%R with (- (- FtoR radix f - r))%R; [ idtac | ring ]. rewrite <- Fopp_correct. repeat rewrite Rabs_Ropp. case H'; auto with float. Qed. Theorem ClosestFabs : forall (p : float) (r : R), Closest b radix r p -> Closest b radix (Rabs r) (Fabs p). intros p r H'; case (Rle_or_lt 0 r); intros Rl0. rewrite Rabs_right; auto with real. replace (Fabs p) with p; auto. unfold Fabs in |- *; apply floatEq; simpl in |- *; auto. cut (0 <= Fnum p)%Z. case (Fnum p); simpl in |- *; auto; intros p' H0. absurd ((0 <= Zneg p')%Z); trivial. apply Zlt_not_le; red in |- *; simpl in |- *; auto with zarith. apply LeR0Fnum with (radix := radix); auto. apply RleRoundedR0 with (b := b) (precision := precision) (P := Closest b radix) (r := r); auto. apply ClosestRoundedModeP with (precision := precision); auto with real. rewrite Faux.Rabsolu_left1; auto. replace (Fabs p) with (Fopp p). apply ClosestOpp; auto. unfold Fabs in |- *; apply floatEq; simpl in |- *; auto. cut (Fnum p <= 0)%Z. case (Fnum p); simpl in |- *; auto; intros p' H0. absurd (Zpos p' <= 0)%Z; trivial. apply Zlt_not_le; red in |- *; simpl in |- *; auto with zarith. apply R0LeFnum with (radix := radix); auto. apply RleRoundedLessR0 with (b := b) (precision := precision) (P := Closest b radix) (r := r); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply Rlt_le; auto. apply Rlt_le; auto. Qed. Theorem ClosestUlp : forall (p : R) (q : float), Closest b radix p q -> (2%nat * Rabs (p - q) <= Fulp b radix precision q)%R. intros p q H'. case (Req_dec p q); intros Eqpq. rewrite Eqpq. replace (Rabs (q - q)) with 0%R; [ rewrite Rmult_0_r | replace (q - q)%R with 0%R; try ring; rewrite Rabs_right; auto with real ]. unfold Fulp in |- *; apply Rlt_le; auto with real arith. replace (2%nat * Rabs (p - q))%R with (Rabs (p - q) + Rabs (p - q))%R; [ idtac | simpl in |- *; ring ]. case ClosestMinOrMax with (1 := H'); intros H'1. apply Rle_trans with (Rabs (p - q) + Rabs (FNSucc b radix precision q - p))%R. apply Rplus_le_compat_l. rewrite <- (Rabs_Ropp (p - q)). rewrite Ropp_minus_distr. elim H'; auto. intros H'0 H'2; apply H'2; auto. apply FcanonicBound with (radix := radix); auto with float arith. rewrite Rabs_right. rewrite Rabs_right. replace (p - q + (FNSucc b radix precision q - p))%R with (FNSucc b radix precision q - q)%R; [ idtac | ring ]. unfold FtoRradix in |- *; apply FulpSuc; auto. case H'1; auto. apply Rge_minus; apply Rle_ge; auto with real float. case MinMax with (3 := pGivesBound) (r := p) (p := q); auto with arith. intros H'0 H'2; elim H'2; intros H'3 H'4; apply H'3; clear H'2; auto. apply Rge_minus; apply Rle_ge; auto with real float. apply isMin_inv1 with (1 := H'1). apply Rle_trans with (Rabs (p - q) + Rabs (p - FNPred b radix precision q))%R. apply Rplus_le_compat_l. rewrite <- (Rabs_Ropp (p - q)); rewrite <- (Rabs_Ropp (p - FNPred b radix precision q)). repeat rewrite Ropp_minus_distr. elim H'; auto. intros H'0 H'2; apply H'2; auto. apply FcanonicBound with (radix := radix); auto with float arith. rewrite <- (Rabs_Ropp (p - q)); rewrite Ropp_minus_distr. rewrite Rabs_right. rewrite Rabs_right. replace (q - p + (p - FNPred b radix precision q))%R with (q - FNPred b radix precision q)%R; [ idtac | ring ]. unfold FtoRradix in |- *; apply FulpPred; auto. case H'1; auto. apply Rge_minus; apply Rle_ge; auto with real float. case MaxMin with (3 := pGivesBound) (r := p) (p := q); auto with arith. intros H'0 H'2; elim H'2; intros H'3 H'4; apply H'3; clear H'2; auto. apply Rge_minus; apply Rle_ge; auto with real float. apply isMax_inv1 with (1 := H'1). Qed. Theorem ClosestExp : forall (p : R) (q : float), Closest b radix p q -> (2%nat * Rabs (p - q) <= powerRZ radix (Fexp q))%R. intros p q H'. apply Rle_trans with (Fulp b radix precision q). apply (ClosestUlp p q); auto. replace (powerRZ radix (Fexp q)) with (FtoRradix (Float 1%nat (Fexp q))). apply (FulpLe b radix); auto. apply RoundedModeBounded with (radix := radix) (P := Closest b radix) (r := p); auto. apply ClosestRoundedModeP with (precision := precision); auto. unfold FtoRradix, FtoR in |- *; simpl in |- *. ring. Qed. Theorem ClosestErrorExpStrict : forall (p q : float) (x : R), Fbounded b p -> Fbounded b q -> Closest b radix x p -> q = (x - p)%R :>R -> q <> 0%R :>R -> (Fexp q < Fexp p)%Z. intros. case (Zle_or_lt (Fexp p) (Fexp q)); auto; intros Z1. absurd (powerRZ radix (Fexp p) <= powerRZ radix (Fexp q))%R. 2: apply Rle_powerRZ; auto with real arith. apply Rgt_not_le. red in |- *; apply Rlt_le_trans with (2%nat * powerRZ radix (Fexp q))%R. apply Rltdouble; auto with real arith. apply Rle_trans with (2%nat * Fabs q)%R. apply Rmult_le_compat_l; auto with real arith. replace 0%R with (INR 0); auto with real arith. replace (powerRZ radix (Fexp q)) with (FtoRradix (Float 1%nat (Fexp q))); auto. apply (Fop.RleFexpFabs radix); auto with real zarith. unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. rewrite (Fabs_correct radix); auto with arith. replace (FtoR radix q) with (x - p)%R; auto. apply ClosestExp; auto. Qed. Theorem ClosestIdem : forall p q : float, Fbounded b p -> Closest b radix p q -> p = q :>R. intros p q H' H'0. case (Rabs_pos (q - p)); intros H1. Contradict H1; apply Rle_not_lt. replace 0%R with (Rabs (p - p)); [ case H'0; auto | idtac ]. replace (p - p)%R with 0%R; [ apply Rabs_R0; auto | ring ]. apply Rplus_eq_reg_l with (r := (- p)%R). apply trans_eq with 0%R; [ ring | idtac ]. apply trans_eq with (q - p)%R; [ idtac | ring ]. generalize H1; unfold Rabs in |- *; case (Rcase_abs (q - p)); auto. intros r H0; replace 0%R with (-0)%R; [ rewrite H0 | idtac ]; ring. Qed. Theorem ClosestM1 : forall (r1 r2 : R) (min max p q : float), isMin b radix r1 min -> isMax b radix r1 max -> (min + max < 2%nat * r2)%R -> Closest b radix r1 p -> Closest b radix r2 q -> (p <= q)%R. intros r1 r2 min max p q H' H'0 H'1 H'2 H'3. case (Rle_or_lt r2 max); intros H'4. 2: apply (ClosestMonotone b radix) with (p := r1) (q := r2); auto. 2: apply Rle_lt_trans with (FtoRradix max); auto. 2: apply isMax_inv1 with (1 := H'0). case H'4; clear H'4; intros H'4. 2: replace (FtoRradix q) with (FtoRradix max). 2: case ClosestMinOrMax with (1 := H'2); intros H'5. 2: replace (FtoRradix p) with (FtoRradix min). 2: apply Rle_trans with r1. 2: apply isMin_inv1 with (1 := H'). 2: apply isMax_inv1 with (1 := H'0). 2: apply MinEq with (1 := H'); auto. 2: replace (FtoRradix p) with (FtoRradix max); auto with real. 2: apply MaxEq with (1 := H'0); auto. 2: apply ClosestIdem; auto. 2: case H'0; auto. 2: rewrite <- H'4; auto. cut (min < r2)%R. 2: apply Rmult_lt_reg_l with (r := INR 2); auto with real. 2: replace (2%nat * min)%R with (min + min)%R; [ idtac | simpl in |- *; ring ]. 2: apply Rle_lt_trans with (2 := H'1). 2: apply Rplus_le_compat_l; auto with real. 2: apply Rle_trans with r1. 2: apply isMin_inv1 with (1 := H'). 2: apply isMax_inv1 with (1 := H'0). intros H'5. replace (FtoRradix q) with (FtoRradix max). case ClosestMinOrMax with (1 := H'2); intros H'6. replace (FtoRradix p) with (FtoRradix min). apply Rle_trans with r1. apply isMin_inv1 with (1 := H'). apply isMax_inv1 with (1 := H'0). apply MinEq with (1 := H'); auto. replace (FtoRradix p) with (FtoRradix max); auto with real. apply MaxEq with (1 := H'0); auto. apply sym_eq. apply (ClosestMaxEq b radix) with (r := r2) (min := min); auto. apply isMinComp with (2 := H'0); auto. apply isMaxComp with (1 := H'); auto. Qed. Theorem FmultRadixInv : forall (x z : float) (y : R), Fbounded b x -> Closest b radix y z -> (/ 2%nat * x < y)%R -> (/ 2%nat * x <= z)%R. intros x z y H' H'0 H'1. case MinEx with (r := (/ 2%nat * x)%R) (3 := pGivesBound); auto with arith. intros min isMin. case MaxEx with (r := (/ 2%nat * x)%R) (3 := pGivesBound); auto with arith. intros max isMax. case (Rle_or_lt y max); intros Rl1. case Rl1; clear Rl1; intros Rl1. replace (FtoRradix z) with (FtoRradix max). apply isMax_inv1 with (1 := isMax). apply sym_eq. unfold FtoRradix in |- *; apply ClosestMaxEq with (b := b) (r := y) (min := min); auto. apply isMinComp with (r1 := (/ 2%nat * x)%R) (max := max); auto. apply Rle_lt_trans with (2 := H'1); auto. apply isMin_inv1 with (1 := isMin). apply isMaxComp with (r1 := (/ 2%nat * x)%R) (min := min); auto. apply Rle_lt_trans with (2 := H'1); auto. apply isMin_inv1 with (1 := isMin). replace (FtoR radix min + FtoR radix max)%R with (FtoRradix x). apply Rmult_lt_reg_l with (r := (/ 2%nat)%R); auto with real. rewrite <- Rmult_assoc; rewrite Rinv_l; try rewrite Rmult_1_l; auto with real. unfold FtoRradix in |- *; apply (div2IsBetween b radix precision); auto. cut (Closest b radix max z); [ intros C0 | idtac ]. replace (FtoRradix z) with (FtoRradix max); auto. rewrite <- Rl1; auto. apply Rlt_le; auto. apply ClosestIdem; auto. case isMax; auto. apply (ClosestCompatible b radix y max z z); auto. case H'0; auto. apply Rle_trans with (FtoRradix max); auto. apply isMax_inv1 with (1 := isMax). apply (ClosestMonotone b radix (FtoRradix max) y); auto. apply (RoundedModeProjectorIdem b radix (Closest b radix)); auto. apply ClosestRoundedModeP with (precision := precision); auto. case isMax; auto. Qed. Theorem ClosestErrorBound : forall (p q : float) (x : R), Fbounded b p -> Closest b radix x p -> q = (x - p)%R :>R -> (Rabs q <= Float 1%nat (Fexp p) * / 2%nat)%R. intros p q x H H0 H1. apply Rle_trans with (Fulp b radix precision p * / 2%nat)%R. rewrite H1. replace (Rabs (x - p)) with (2%nat * Rabs (x - p) * / 2%nat)%R; [ idtac | field; auto with real ]. apply Rmult_le_compat_r; auto with real. apply ClosestUlp; auto. apply Rmult_le_compat_r. apply Rlt_le. apply Rinv_0_lt_compat; auto with real. unfold FtoRradix in |- *; apply FulpLe; auto. Qed. Theorem ClosestErrorExp : forall (p q : float) (x : R), Fbounded b p -> Fbounded b q -> Closest b radix x p -> q = (x - p)%R :>R -> exists error : float, Fbounded b error /\ error = q :>R /\ (Fexp error <= Zmax (Fexp p - precision) (- dExp b))%Z. intros p q x H H0 H1 H2; exists (Fnormalize radix b precision q). cut (Fcanonic radix b (Fnormalize radix b precision q)); [ intros C1 | apply FnormalizeCanonic; auto with arith ]. split. apply FcanonicBound with (radix := radix); auto. split. apply (FnormalizeCorrect radix); auto. case C1; intros C2. apply Zle_trans with (Fexp p - precision)%Z; auto with zarith. apply Zplus_le_reg_l with (Z_of_nat precision). replace (precision + (Fexp p - precision))%Z with (Fexp p); [ idtac | ring ]. replace (precision + Fexp (Fnormalize radix b precision q))%Z with (Zsucc (Zpred precision + Fexp (Fnormalize radix b precision q))); [ idtac | unfold Zpred, Zsucc in |- *; ring ]. apply Zlt_le_succ. apply Zlt_powerRZ with (IZR radix); auto with real zarith. rewrite powerRZ_add; auto with real zarith. apply Rle_lt_trans with (Zabs (Fnum (Fnormalize radix b precision q)) * powerRZ radix (Fexp (Fnormalize radix b precision q)))%R. apply Rmult_le_compat_r; auto with real zarith. replace (Zpred precision) with (Z_of_nat (pred (digit radix (Fnum (Fnormalize radix b precision q))))). rewrite <- Zpower_nat_Z_powerRZ. apply Rle_IZR; apply digitLess; auto with real zarith. change (~ is_Fzero (Fnormalize radix b precision q)) in |- *; apply (FnormalNotZero radix b); auto with float. change (Z_of_nat (pred (Fdigit radix (Fnormalize radix b precision q))) = Zpred precision) in |- *. rewrite FnormalPrecision with (precision := precision) (4 := C2); auto with zarith arith. apply inj_pred; auto with arith. change (Fabs (Fnormalize radix b precision q) < powerRZ radix (Fexp p))%R in |- *. rewrite (Fabs_correct radix); auto; rewrite (FnormalizeCorrect radix); auto. apply Rle_lt_trans with (Float 1%nat (Fexp p) * / 2%nat)%R. apply ClosestErrorBound with (x := x); auto. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *. pattern (powerRZ radix (Fexp p)) at 2 in |- *; replace (powerRZ radix (Fexp p)) with (powerRZ radix (Fexp p) * 1)%R; [ idtac | ring ]. replace (1 * powerRZ radix (Fexp p))%R with (powerRZ radix (Fexp p)); [ apply Rmult_lt_compat_l | ring ]. apply powerRZ_lt; auto with arith real. pattern 1%R at 3 in |- *; replace 1%R with (/ 1)%R. apply Rinv_1_lt_contravar; auto with real. replace 2%R with (INR 2); auto with real arith. apply Zle_trans with (- dExp b)%Z; auto with float zarith. case C2. intros H3 (H4, H5); rewrite H4; auto with zarith. Qed. Theorem ClosestErrorBoundNormal_aux : forall (x : R) (p : float), Closest b radix x p -> Fnormal radix b (Fnormalize radix b precision p) -> (Rabs (x - p) <= Rabs p * (/ 2%nat * (radix * / Zpos (vNum b))))%R. intros x p H H'. apply Rle_trans with (/ 2%nat * Fulp b radix precision p)%R. replace (Rabs (x - FtoRradix p)) with (/ 2%nat * (2%nat * Rabs (x - FtoRradix p)))%R. apply Rmult_le_compat_l; auto with real. apply ClosestUlp; auto. rewrite <- Rmult_assoc; rewrite Rinv_l; simpl in |- *; auto with real. apply Rle_trans with (/ 2%nat * (Rabs p * (radix * / Zpos (vNum b))))%R; [ apply Rmult_le_compat_l | right; ring; ring ]. apply Rlt_le; apply Rinv_0_lt_compat; auto with real arith. unfold Fulp in |- *. replace (Fexp (Fnormalize radix b precision p)) with (Fexp (Fnormalize radix b precision p) + precision + - precision)%Z; [ idtac | ring ]. rewrite powerRZ_add; auto with real zarith. apply Rle_trans with (Rabs p * radix * powerRZ radix (- precision))%R; [ apply Rmult_le_compat_r | right ]; auto with real zarith. 2: rewrite pGivesBound; simpl in |- *. 2: rewrite powerRZ_Zopp; auto with real zarith; rewrite Zpower_nat_Z_powerRZ; auto with real zarith; ring. replace (FtoRradix p) with (FtoRradix (Fnormalize radix b precision p)); [ idtac | apply (FnormalizeCorrect radix) ]; auto. rewrite <- (Fabs_correct radix); unfold FtoR in |- *; simpl in |- *; auto with arith. rewrite powerRZ_add; auto with real zarith. replace (Zabs (Fnum (Fnormalize radix b precision p)) * powerRZ radix (Fexp (Fnormalize radix b precision p)) * radix)%R with (powerRZ radix (Fexp (Fnormalize radix b precision p)) * (Zabs (Fnum (Fnormalize radix b precision p)) * radix))%R; [ idtac | ring ]. apply Rmult_le_compat_l; auto with arith real. rewrite <- Zpower_nat_Z_powerRZ; auto with real zarith. rewrite <- Rmult_IZR; apply Rle_IZR. rewrite <- pGivesBound; pattern radix at 2 in |- *; rewrite <- (Zabs_eq radix); auto with zarith. rewrite <- Zabs_Zmult. rewrite Zmult_comm; elim H'; auto. Qed. Theorem ClosestErrorBound2 : forall (x : R) (p : float), Closest b radix x p -> (Rabs (x - p) <= Rmax (Rabs p * (/ 2%nat * (radix * / Zpos (vNum b)))) (/ 2%nat * powerRZ radix (- dExp b)))%R. intros x p H. cut (Fcanonic radix b (Fnormalize radix b precision p)); [ intros tmp; Casec tmp; intros Fs | idtac ]. 3: apply FnormalizeCanonic; auto with arith. 3: apply RoundedModeBounded with (radix := radix) (P := Closest b radix) (r := x); auto. 3: apply ClosestRoundedModeP with (precision := precision); auto. apply Rle_trans with (Rabs p * (/ 2%nat * (radix * / Zpos (vNum b))))%R; [ idtac | apply RmaxLess1 ]. apply ClosestErrorBoundNormal_aux; auto. apply Rle_trans with (/ 2%nat * Fulp b radix precision p)%R. replace (Rabs (x - FtoRradix p)) with (/ 2%nat * (2%nat * Rabs (x - FtoRradix p)))%R. apply Rmult_le_compat_l; auto with real. apply ClosestUlp; auto. rewrite <- Rmult_assoc; rewrite Rinv_l; simpl in |- *; auto with real. elim Fs; intros H1 H2; elim H2; intros; clear H2. unfold Fulp in |- *; rewrite H0; apply RmaxLess2. Qed. Theorem ClosestErrorBoundNormal : forall (x : R) (p : float), Closest b radix x p -> Fnormal radix b (Fnormalize radix b precision p) -> (Rabs (x - p) <= Rabs p * (/ 2%nat * powerRZ radix (Zsucc (- precision))))%R. intros x p H H1. apply Rle_trans with (Rabs (FtoRradix p) * (/ 2%nat * (radix * / Zpos (vNum b))))%R; [ apply ClosestErrorBoundNormal_aux; auto | right ]. replace (powerRZ radix (Zsucc (- precision))) with (radix * / Zpos (vNum b))%R; auto with real. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ. rewrite Rinv_powerRZ; auto with real zarith. rewrite powerRZ_Zs; auto with real zarith. Qed. Theorem ClosestPropHigham25 : forall (x : R) (p : float), Closest b radix x p -> exists delta : R, (exists nu : R, (x / (1 + delta) + nu)%R = FtoRradix p /\ (Rabs delta <= / 2%nat * powerRZ radix (Zsucc (- precision)))%R /\ (Rabs nu <= / 2%nat * powerRZ radix (- dExp b))%R /\ (delta * nu)%R = 0%R /\ (Fnormal radix b (Fnormalize radix b precision p) -> nu = 0%R) /\ (Fsubnormal radix b (Fnormalize radix b precision p) -> delta = 0%R)). intros x p H. cut (Fcanonic radix b (Fnormalize radix b precision p)); [ intros tmp; Casec tmp; intros Fs | idtac ]. 3: apply FnormalizeCanonic; auto with arith. 3: apply RoundedModeBounded with (radix := radix) (P := Closest b radix) (r := x); auto. 3: apply ClosestRoundedModeP with (precision := precision); auto. cut (~ is_Fzero (Fnormalize radix b precision p)); [ unfold is_Fzero in |- *; intros tmp | apply FnormalNotZero with radix b; auto ]. cut (FtoRradix p <> 0%R); [ intros H1; clear tmp | unfold FtoRradix in |- * ]. 2: rewrite <- FnormalizeCorrect with radix b precision p; auto; unfold FtoR in |- *; simpl in |- *. 2: apply Rmult_integral_contrapositive; split; auto with real zarith. exists ((x - p) / p)%R; exists 0%R. split; [ case (Req_dec x 0); intros H2 | idtac ]. repeat rewrite H2; unfold Rdiv in |- *. ring_simplify. rewrite <- FzeroisZero with radix b; unfold FtoRradix in |- *. cut (ProjectorP b radix (Closest b radix)); [ unfold ProjectorP in |- *; intros H3 | apply RoundedProjector; auto with float ]. apply H3; auto with float zarith. replace (FtoR radix (Fzero (- dExp b))) with x; auto with real. rewrite H2; unfold Fzero, FtoR in |- *; simpl in |- *; ring. apply ClosestRoundedModeP with precision; auto with zarith. apply sym_eq; apply trans_eq with (x / (1 + (x - p) / p))%R; [ idtac | ring ]. replace (1 + (x - FtoRradix p) / FtoRradix p)%R with (x / p)%R; unfold Rdiv in |- *. rewrite Rinv_mult_distr; auto with real; rewrite Rinv_involutive; auto; rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real. ring_simplify; rewrite Rinv_l; auto with real; ring. split. apply Rmult_le_reg_l with (Rabs p); [ apply Rabs_pos_lt; auto | idtac ]. apply Rle_trans with (Rabs (x - FtoRradix p)); [ right | apply ClosestErrorBoundNormal; auto ]. unfold Rdiv in |- *; rewrite Rabs_mult; rewrite Rabs_Rinv; auto. rewrite Rmult_comm; rewrite Rmult_assoc; rewrite Rinv_l; auto with real. apply Rabs_no_R0; exact H1. split; [ rewrite Rabs_R0; apply Rmult_le_pos; auto with real zarith | idtac ]. split; [ ring | idtac ]. split; [ auto with real | intros H2 ]. absurd (Fnormal radix b (Fnormalize radix b precision p) /\ Fsubnormal radix b (Fnormalize radix b precision p)). apply NormalNotSubNormal; auto. split; auto. exists 0%R; exists (p - x)%R. split; [ unfold Rdiv in |- *; ring_simplify (1 + 0)%R; rewrite Rinv_1; ring | idtac ]. split; [ rewrite Rabs_R0; apply Rmult_le_pos; auto with real zarith | idtac ]. split. apply Rle_trans with (/ 2%nat * Fulp b radix precision p)%R. rewrite <- Rabs_Ropp; replace (- (FtoRradix p - x))%R with (x - FtoRradix p)%R; [ idtac | ring ]. replace (Rabs (x - FtoRradix p)) with (/ 2%nat * (2%nat * Rabs (x - FtoRradix p)))%R. apply Rmult_le_compat_l; auto with real; apply ClosestUlp; auto. rewrite <- Rmult_assoc; rewrite Rinv_l; simpl in |- *; auto with real. elim Fs; intros H1 H2; elim H2; intros; clear H2. unfold Fulp in |- *; rewrite H0; auto with real. split; [ ring | idtac ]. split; [ intros H2 | auto with real ]. absurd (Fnormal radix b (Fnormalize radix b precision p) /\ Fsubnormal radix b (Fnormalize radix b precision p)). apply NormalNotSubNormal; auto. split; auto. Qed. Theorem FpredUlpPos : forall x : float, Fcanonic radix b x -> (0 < x)%R -> (FPred b radix precision x + Fulp b radix precision (FPred b radix precision x))%R = x. intros x Hx H. apply sym_eq; apply Rplus_eq_reg_l with (- FtoRradix (FPred b radix precision x))%R. apply trans_eq with (Fulp b radix precision (FPred b radix precision x)); [ idtac | ring ]. apply trans_eq with (FtoRradix x - FtoRradix (FPred b radix precision x))%R; [ ring | idtac ]. unfold FtoRradix in |- *; rewrite <- Fminus_correct; auto with zarith; fold FtoRradix in |- *. pattern x at 1 in |- *; replace x with (FSucc b radix precision (FPred b radix precision x)); [ idtac | apply FSucPred; auto with zarith arith ]. unfold FtoRradix in |- *; apply FSuccUlpPos; auto with zarith arith. apply FPredCanonic; auto with zarith arith. apply R0RltRlePred; auto with zarith arith real. Qed. Theorem FulpFPredLe : forall f : float, Fbounded b f -> Fcanonic radix b f -> (Fulp b radix precision f <= radix * Fulp b radix precision (FPred b radix precision f))%R. intros f Hf1 Hf2; unfold Fulp in |- *. replace (Fnormalize radix b precision f) with f; [ idtac | apply FcanonicUnique with (radix := radix) (b := b) (precision := precision); auto with float arith zarith ]. 2: apply sym_eq; apply FnormalizeCorrect; auto with arith zarith. replace (Fnormalize radix b precision (FPred b radix precision f)) with (FPred b radix precision f); [ idtac | apply FcanonicUnique with (radix := radix) (b := b) (precision := precision); auto with float arith zarith ]. 2: apply sym_eq; apply FnormalizeCorrect; auto with arith zarith. pattern (IZR radix) at 2 in |- *; replace (IZR radix) with (powerRZ radix 1); [ idtac | simpl in |- *; auto with arith zarith real ]. rewrite <- powerRZ_add; auto with zarith real. apply Rle_powerRZ; auto with zarith real. replace (1 + Fexp (FPred b radix precision f))%Z with (Zsucc (Fexp (FPred b radix precision f))); auto with zarith. unfold FPred in |- *. generalize (Z_eq_bool_correct (Fnum f) (- pPred (vNum b))); case (Z_eq_bool (Fnum f) (- pPred (vNum b))); intros H1; [ simpl in |- *; auto with zarith | idtac ]. generalize (Z_eq_bool_correct (Fnum f) (nNormMin radix precision)); case (Z_eq_bool (Fnum f) (nNormMin radix precision)); intros H2; [ idtac | simpl in |- *; auto with zarith ]. generalize (Z_eq_bool_correct (Fexp f) (- dExp b)); case (Z_eq_bool (Fexp f) (- dExp b)); intros H3; simpl in |- *; auto with zarith. Qed. Theorem ClosestErrorBoundNormal2_aux : forall (x : R) (p : float), Closest b radix x p -> Fnormal radix b p -> Fnormal radix b (Fnormalize radix b precision (FPred b radix precision p)) -> (0 < x)%R -> (x < p)%R -> (Rabs (x - p) <= Rabs x * (/ 2%nat * powerRZ radix (Zsucc (- precision))))%R. intros x p H1 H2 H0 H3 H4. cut (Fcanonic radix b p); [ intros H5 | left; auto ]. cut (Fbounded b p); [ intros H6 | elim H2; auto ]. cut (0 < p)%R; [ intros H7 | apply Rlt_trans with x; auto ]. cut (FPred b radix precision p < x)%R; [ intros H' | idtac ]. apply Rle_trans with (/ 2%nat * Fulp b radix precision (FPred b radix precision p))%R. case (Rle_or_lt (Rabs (x - FtoRradix p)) (/ 2%nat * Fulp b radix precision (FPred b radix precision p))); auto; intros H8. absurd (Rabs (p - x) <= Rabs (FPred b radix precision p - x))%R. 2: generalize H1; unfold Closest in |- *; intros H9; elim H9; intros tmp H10. 2: clear tmp; apply H10; auto with float zarith arith. apply Rlt_not_le; rewrite Rabs_left; auto with real. apply Rle_lt_trans with (p - FPred b radix precision p + (x - p))%R; [ right; ring | idtac ]. pattern (FtoRradix p) at 1 in |- *; rewrite <- FpredUlpPos with p; auto with real. apply Rle_lt_trans with (Fulp b radix precision (FPred b radix precision p) + (x - p))%R; [ right; ring | idtac ]. apply Rle_lt_trans with (Fulp b radix precision (FPred b radix precision p) + - (/ 2%nat * Fulp b radix precision (FPred b radix precision p)))%R; [ apply Rplus_le_compat_l | idtac ]. apply Ropp_le_cancel; rewrite Ropp_involutive; rewrite <- Rabs_left; auto with real. apply Rle_lt_trans with (/ 2%nat * Fulp b radix precision (FPred b radix precision p))%R. right; apply trans_eq with ((1 + - / 2%nat) * Fulp b radix precision (FPred b radix precision p))%R; [ ring | idtac ]. replace (1 + - / 2%nat)%R with (/ 2%nat)%R; [ ring | simpl; field; auto with arith real; simpl in |- *; ring ]. rewrite <- Rabs_Ropp; replace (- (FtoRradix p - x))%R with (x - p)%R; auto; ring. apply Rle_trans with (/ 2%nat * (Rabs x * powerRZ radix (Zsucc (- precision))))%R; [ apply Rmult_le_compat_l; auto with real arith | right; ring ]. apply Rle_trans with (Rabs (FPred b radix precision p) * powerRZ radix (Zsucc (- precision)))%R. unfold Fulp in |- *; replace (Fexp (Fnormalize radix b precision (FPred b radix precision p))) with (Fexp (Fnormalize radix b precision (FPred b radix precision p)) + precision + - precision)%Z; [ idtac | ring ]. rewrite powerRZ_add; auto with real zarith. apply Rle_trans with (Rabs (FPred b radix precision p) * radix * powerRZ radix (- precision))%R; [ apply Rmult_le_compat_r | right ]; auto with real zarith. 2: rewrite powerRZ_Zs; auto with real zarith; ring. replace (FtoRradix (FPred b radix precision p)) with (FtoRradix (Fnormalize radix b precision (FPred b radix precision p))); [ idtac | apply (FnormalizeCorrect radix) ]; auto. rewrite <- (Fabs_correct radix); unfold FtoR in |- *; simpl in |- *; auto with arith. rewrite powerRZ_add; auto with real zarith. apply Rle_trans with (powerRZ radix (Fexp (Fnormalize radix b precision (FPred b radix precision p))) * (Zabs (Fnum (Fnormalize radix b precision (FPred b radix precision p))) * radix))%R; [ idtac | right; ring ]. apply Rmult_le_compat_l; auto with arith real. rewrite <- Zpower_nat_Z_powerRZ; auto with real zarith; rewrite <- Rmult_IZR. apply Rle_IZR; rewrite <- pGivesBound; pattern radix at 3 in |- *; rewrite <- (Zabs_eq radix); auto with zarith; rewrite <- Zabs_Zmult; rewrite Zmult_comm; elim H0; auto. apply Rmult_le_compat_r; auto with real zarith. repeat rewrite Rabs_right; auto with real; apply Rle_ge; auto with real. unfold FtoRradix in |- *; apply R0RltRlePred; auto with real arith. case (Rle_or_lt 0 (FtoRradix (FPred b radix precision p) - x)); intros H9. absurd (Rabs (p - x) <= Rabs (FPred b radix precision p - x))%R. apply Rlt_not_le; repeat rewrite Rabs_right; try apply Rle_ge; auto with real. unfold Rminus in |- *; apply Rplus_lt_compat_r; auto with real float zarith. unfold FtoRradix in |- *; apply FPredLt; auto with real float zarith. generalize H1; unfold Closest in |- *; intros H'; elim H'; intros tmp H10. clear tmp; apply H10; auto with float zarith arith. apply Rplus_lt_reg_r with (- x)%R; auto with real. ring_simplify (- x + x)%R; apply Rle_lt_trans with (2 := H9); right; ring. Qed. End Fclosestp2. Hint Resolve ClosestOpp ClosestFabs ClosestUlp: float.Float8.4/Digit.v0000644000423700002640000003166412032774524013310 0ustar sboldotoccata(**************************************************************************** IEEE754 : Digit Laurent Thery ***************************************************************************** Gives the number of digits necessary to write a number in a given base *) Require Export ZArithRing. Require Export Omega. Require Export Faux. Section Pdigit. (* n is the base *) Variable n : Z. (* and it is greater or equal to 2 *) Hypothesis nMoreThan1 : (1 < n)%Z. Let nMoreThanOne := Zlt_1_O _ (Zlt_le_weak _ _ nMoreThan1). Hint Resolve nMoreThanOne: zarith. Theorem Zpower_nat_less : forall q : nat, (0 < Zpower_nat n q)%Z. intros q; elim q; simpl in |- *. rewrite Zpower_nat_O; simpl in |- *; auto with zarith. intros n0 H; replace (S n0) with (1 + n0); [ rewrite Zpower_nat_is_exp | auto with zarith ]. rewrite Zpower_nat_1; auto with zarith. Qed. Hint Resolve Zpower_nat_less: zarith. Theorem Zpower_nat_monotone_S : forall p : nat, (Zpower_nat n p < Zpower_nat n (S p))%Z. intros p; rewrite <- (Zmult_1_l (Zpower_nat n p)); replace (S p) with (1 + p); [ rewrite Zpower_nat_is_exp | auto with zarith ]. rewrite Zpower_nat_1; auto with zarith. apply Zmult_gt_0_lt_compat_r; auto with zarith. apply Zlt_gt; auto with zarith. Qed. Theorem Zpower_nat_monotone_lt : forall p q : nat, p < q -> (Zpower_nat n p < Zpower_nat n q)%Z. intros p q H'; elim H'; simpl in |- *; auto. apply Zpower_nat_monotone_S. intros m H H0; apply Zlt_trans with (1 := H0). apply Zpower_nat_monotone_S. Qed. Hint Resolve Zpower_nat_monotone_lt: zarith. Theorem Zpower_nat_anti_monotone_lt : forall p q : nat, (Zpower_nat n p < Zpower_nat n q)%Z -> p < q. intros p q H'. case (le_or_lt q p); auto; (intros H'1; generalize H'; case H'1). intros H'0; Contradict H'0; auto with zarith. intros m H'0 H'2; Contradict H'2; auto with zarith. Qed. Theorem Zpower_nat_monotone_le : forall p q : nat, p <= q -> (Zpower_nat n p <= Zpower_nat n q)%Z. intros p q H'; case (le_lt_or_eq _ _ H'); auto with zarith. intros H1; rewrite H1; auto with zarith. Qed. Theorem Zpower_nat_anti_monotone_le : forall p q : nat, (Zpower_nat n p <= Zpower_nat n q)%Z -> p <= q. intros p q H'; case (le_or_lt p q); intros H'0; auto with arith. absurd ((Zpower_nat n p <= Zpower_nat n q)%Z); auto with zarith. Qed. Theorem Zpower_nat_anti_eq : forall p q : nat, Zpower_nat n p = Zpower_nat n q -> p = q. intros p q H'; apply le_antisym; apply Zpower_nat_anti_monotone_le; rewrite H'; auto with zarith. Qed. (* To compute the number of digits structurally, we suppose that we know already an upper bound q. So we start from q down to 0 to find the bigger exponent r such that n^(r-1) < v *) Fixpoint digitAux (v r : Z) (q : positive) {struct q} : nat := match q with | xH => 0 | xI q' => match (n * r)%Z with | r' => match (r ?= v)%Z with | Datatypes.Gt => 0 | _ => S (digitAux v r' q') end end | xO q' => match (n * r)%Z with | r' => match (r ?= v)%Z with | Datatypes.Gt => 0 | _ => S (digitAux v r' q') end end end. (* As we know that log_n q < log_2 q we can define our function digit*) Definition digit (q : Z) := match q with | Z0 => 0 | Zpos q' => digitAux (Zabs q) 1 (xO q') | Zneg q' => digitAux (Zabs q) 1 (xO q') end. Hint Unfold digit. Theorem digitAux1 : forall p r, (Zpower_nat n (S p) * r)%Z = (Zpower_nat n p * (n * r))%Z. intros p r; replace (S p) with (1 + p); [ rewrite Zpower_nat_is_exp | auto with arith ]. rewrite Zpower_nat_1; ring. Qed. Theorem Zcompare_correct : forall p q : Z, match (p ?= q)%Z with | Datatypes.Gt => (q < p)%Z | Datatypes.Lt => (p < q)%Z | Datatypes.Eq => p = q end. intros p q; unfold Zlt in |- *; generalize (Zcompare_EGAL p q); (CaseEq (p ?= q)%Z; simpl in |- *; auto). intros H H0; case (Zcompare_Gt_Lt_antisym p q); auto. Qed. Theorem digitAuxLess : forall (v r : Z) (q : positive), match digitAux v r q with | S r' => (Zpower_nat n r' * r <= v)%Z | O => True end. intros v r q; generalize r; elim q; clear r q; simpl in |- *; auto. intros q' Rec r; generalize (Zcompare_correct r v); case (r ?= v)%Z; auto. intros H1; generalize (Rec (n * r)%Z); case (digitAux v (n * r) q'). intros; rewrite H1; rewrite Zpower_nat_O; auto with zarith. intros r'; rewrite digitAux1; auto. intros H1; generalize (Rec (n * r)%Z); case (digitAux v (n * r) q'). intros; rewrite Zpower_nat_O; auto with zarith. apply Zle_trans with (m := r); auto with zarith. intros r'; rewrite digitAux1; auto. intros q' Rec r; generalize (Zcompare_correct r v); case (r ?= v)%Z; auto. intros H1; generalize (Rec (n * r)%Z); case (digitAux v (n * r) q'). intros; rewrite H1; rewrite Zpower_nat_O; auto with zarith. intros r'; rewrite digitAux1; auto. intros H1; generalize (Rec (n * r)%Z); case (digitAux v (n * r) q'). intros; rewrite Zpower_nat_O; auto with zarith. apply Zle_trans with (m := r); auto with zarith. intros r'; rewrite digitAux1; auto. Qed. (* digit is correct (first part) *) Theorem digitLess : forall q : Z, q <> 0%Z -> (Zpower_nat n (pred (digit q)) <= Zabs q)%Z. intros q; case q. intros H; Contradict H; auto with zarith. intros p H; unfold digit in |- *; generalize (digitAuxLess (Zabs (Zpos p)) 1 (xO p)); case (digitAux (Zabs (Zpos p)) 1 (xO p)); simpl in |- *; auto with zarith. intros p H; unfold digit in |- *; generalize (digitAuxLess (Zabs (Zneg p)) 1 (xO p)); case (digitAux (Zabs (Zneg p)) 1 (xO p)); simpl in |- *; auto with zarith. Qed. Hint Resolve digitLess: zarith. Hint Resolve Zmult_gt_0_lt_compat_r Zmult_gt_0_lt_compat_l: zarith. Fixpoint pos_length (p : positive) : nat := match p with | xH => 0 | xO p' => S (pos_length p') | xI p' => S (pos_length p') end. Theorem digitAuxMore : forall (v r : Z) (q : positive), (0 < r)%Z -> (v < Zpower_nat n (pos_length q) * r)%Z -> (v < Zpower_nat n (digitAux v r q) * r)%Z. intros v r q; generalize r; elim q; clear r q; simpl in |- *. intros p Rec r Hr; generalize (Zcompare_correct r v); case (r ?= v)%Z; auto. intros H1 H2; rewrite <- H1. apply Zle_lt_trans with (Zpower_nat n 0 * r)%Z; auto with zarith arith. rewrite Zpower_nat_O; rewrite Zmult_1_l; auto with zarith. intros H1 H2; rewrite digitAux1. apply Rec. apply Zlt_mult_ZERO; auto with zarith. rewrite <- digitAux1; auto. rewrite Zpower_nat_O; rewrite Zmult_1_l; auto with zarith. intros p Rec r Hr; generalize (Zcompare_correct r v); case (r ?= v)%Z; auto. intros H1 H2; rewrite <- H1. apply Zle_lt_trans with (Zpower_nat n 0 * r)%Z; auto with zarith arith. rewrite Zpower_nat_O; rewrite Zmult_1_l; auto with zarith. intros H1 H2; rewrite digitAux1. apply Rec. apply Zlt_mult_ZERO; auto with zarith. rewrite <- digitAux1; auto. rewrite Zpower_nat_O; rewrite Zmult_1_l; auto with zarith. auto. Qed. Theorem pos_length_pow : forall p : positive, (Zpos p < Zpower_nat n (S (pos_length p)))%Z. intros p; elim p; simpl in |- *; auto. intros p0 H; rewrite Zpos_xI. apply Zlt_le_trans with (Z_of_nat 2 * Zpower_nat n (S (pos_length p0)))%Z. replace (Z_of_nat 2) with (1 + 1)%Z; [ idtac | simpl in |- *; auto ]. replace 2%Z with (1 + 1)%Z; [ auto with zarith | simpl in |- *; auto ]. replace (S (S (pos_length p0))) with (1 + S (pos_length p0)); [ rewrite Zpower_nat_is_exp | auto with arith ]. rewrite Zpower_nat_1; auto with zarith. cut (Z_of_nat 2 <= n)%Z; [ auto with zarith | idtac ]. replace (Z_of_nat 2) with (Zsucc 1); [ auto with zarith | simpl in |- *; auto ]. intros p0 H; rewrite Zpos_xO. apply Zlt_le_trans with (Z_of_nat 2 * Zpower_nat n (S (pos_length p0)))%Z. replace (Z_of_nat 2) with (1 + 1)%Z; [ idtac | simpl in |- *; auto ]. replace 2%Z with (1 + 1)%Z; [ auto with zarith | simpl in |- *; auto ]. replace (S (S (pos_length p0))) with (1 + S (pos_length p0)); [ rewrite Zpower_nat_is_exp | auto with arith ]. rewrite Zpower_nat_1; auto with zarith. cut (Z_of_nat 2 <= n)%Z; [ auto with zarith | idtac ]. replace (Z_of_nat 2) with (Zsucc 1); [ auto with zarith | simpl in |- *; auto ]. rewrite Zpower_nat_1; auto. Qed. (* digit is correct (second part) *) Theorem digitMore : forall q : Z, (Zabs q < Zpower_nat n (digit q))%Z. intros q; case q. simpl in |- *; rewrite Zpower_nat_O; simpl in |- *; auto with zarith. intros q'; rewrite <- (Zmult_1_r (Zpower_nat n (digit (Zpos q')))). unfold digit in |- *; apply digitAuxMore; auto with zarith. rewrite Zmult_1_r. simpl in |- *; apply pos_length_pow. intros q'; rewrite <- (Zmult_1_r (Zpower_nat n (digit (Zneg q')))). unfold digit in |- *; apply digitAuxMore; auto with zarith. rewrite Zmult_1_r. simpl in |- *; apply pos_length_pow. Qed. Hint Resolve digitMore: zarith. (* if we find an r such that n^(r-1) =< q < n^r then r is the number of digits *) Theorem digitInv : forall (q : Z) (r : nat), (Zpower_nat n (pred r) <= Zabs q)%Z -> (Zabs q < Zpower_nat n r)%Z -> digit q = r. intros q r H' H'0; case (le_or_lt (digit q) r). intros H'1; case (le_lt_or_eq _ _ H'1); auto; intros H'2. absurd (Zabs q < Zpower_nat n (digit q))%Z; auto with zarith. apply Zle_not_lt; auto with zarith. apply Zle_trans with (m := Zpower_nat n (pred r)); auto with zarith. apply Zpower_nat_monotone_le. generalize H'2; case r; auto with arith. intros H'1. absurd (Zpower_nat n (pred (digit q)) <= Zabs q)%Z; auto with zarith. apply Zlt_not_le; auto with zarith. apply Zlt_le_trans with (m := Zpower_nat n r); auto. apply Zpower_nat_monotone_le. generalize H'1; case (digit q); auto with arith. apply digitLess; auto with zarith. generalize H'1; case q; unfold digit in |- *; intros tmp; intros; red in |- *; intros; try discriminate; Contradict tmp; auto with arith. Qed. Theorem digitO : digit 0 = 0. unfold digit in |- *; simpl in |- *; auto with arith. Qed. Theorem digit1 : digit 1 = 1. unfold digit in |- *; simpl in |- *; auto. Qed. (* digit is monotone *) Theorem digit_monotone : forall p q : Z, (Zabs p <= Zabs q)%Z -> digit p <= digit q. intros p q H; case (le_or_lt (digit p) (digit q)); auto; intros H1. absurd ((Zabs p <= Zabs q)%Z); trivial. apply Zlt_not_le. cut (p <> 0%Z); [ intros H2 | idtac ]. apply Zlt_le_trans with (2 := digitLess p H2). cut (digit q <= pred (digit p)); [ intros H3 | idtac ]. apply Zlt_le_trans with (2 := Zpower_nat_monotone_le _ _ H3); auto with zarith. generalize H1; case (digit p); simpl in |- *; auto with arith. generalize H1; case p; simpl in |- *; intros tmp; intros; red in |- *; intros; try discriminate; Contradict tmp; auto with arith. Qed. Hint Resolve digit_monotone: arith. (* if the number is not null so is the number of digits *) Theorem digitNotZero : forall q : Z, q <> 0%Z -> 0 < digit q. intros q H'. apply lt_le_trans with (m := digit 1); auto with zarith. apply digit_monotone. generalize H'; case q; simpl in |- *; auto with zarith; intros q'; case q'; simpl in |- *; auto with zarith arith; intros; red in |- *; simpl in |- *; red in |- *; intros; discriminate. Qed. Hint Resolve Zlt_gt: zarith. Theorem digitAdd : forall (q : Z) (r : nat), q <> 0%Z -> digit (q * Zpower_nat n r) = digit q + r. intros q r H0. apply digitInv. replace (pred (digit q + r)) with (pred (digit q) + r). rewrite Zpower_nat_is_exp; rewrite Zabs_Zmult; rewrite (fun x => Zabs_eq (Zpower_nat n x)); auto with zarith arith. generalize (digitNotZero _ H0); case (digit q); auto with arith. intros H'; Contradict H'; auto with arith. rewrite Zpower_nat_is_exp; rewrite Zabs_Zmult; rewrite (fun x => Zabs_eq (Zpower_nat n x)); auto with zarith arith. Qed. Theorem digit_minus1 : forall p : nat, digit (Zpower_nat n p - 1) = p. intros p; case p; auto. intros n0; apply digitInv; auto. rewrite Zabs_eq. cut (Zpower_nat n (pred (S n0)) < Zpower_nat n (S n0))%Z; auto with zarith. cut (0 < Zpower_nat n (S n0))%Z; auto with zarith. rewrite Zabs_eq; auto with zarith. Qed. Theorem digit_bound : forall (x y z : Z) (n : nat), (Zabs x <= Zabs y)%Z -> (Zabs y <= Zabs z)%Z -> digit x = n -> digit z = n -> digit y = n. intros x y z n0 H' H'0 H'1 H'2; apply le_antisym. rewrite <- H'2; auto with arith. rewrite <- H'1; auto with arith. Qed. Theorem digit_abs : forall p : Z, digit (Zabs p) = digit p. intros p; case p; simpl in |- *; auto. Qed. (* Strict comparison on the number of digits gives comparison on the numbers *) Theorem digit_anti_monotone_lt : (1 < n)%Z -> forall p q : Z, digit p < digit q -> (Zabs p < Zabs q)%Z. intros H' p q H'0. case (Zle_or_lt (Zabs q) (Zabs p)); auto; intros H'1. Contradict H'0. case (Zle_lt_or_eq _ _ H'1); intros H'2. apply le_not_lt; auto with arith. rewrite <- (digit_abs p); rewrite <- (digit_abs q); rewrite H'2; auto with arith. Qed. End Pdigit. Hint Resolve Zpower_nat_less: zarith. Hint Resolve Zpower_nat_monotone_lt: zarith. Hint Resolve Zpower_nat_monotone_le: zarith. Hint Unfold digit. Hint Resolve digitLess: zarith. Hint Resolve digitMore: zarith. Hint Resolve digit_monotone: arith.Float8.4/FPred.v0000644000423700002640000004564412032774525013254 0ustar sboldotoccata(**************************************************************************** IEEE754 : FPred Laurent Thery ******************************************************************************) Require Export FSucc. Section pred. Variable b : Fbound. Variable radix : Z. Variable precision : nat. Coercion Local FtoRradix := FtoR radix. Hypothesis radixMoreThanOne : (1 < radix)%Z. Hypothesis precisionNotZero : precision <> 0. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Definition FPred (x : float) := match Z_eq_bool (Fnum x) (- pPred (vNum b)) with | true => Float (- nNormMin radix precision) (Zsucc (Fexp x)) | false => match Z_eq_bool (Fnum x) (nNormMin radix precision) with | true => match Z_eq_bool (Fexp x) (- dExp b) with | true => Float (Zpred (Fnum x)) (Fexp x) | false => Float (pPred (vNum b)) (Zpred (Fexp x)) end | false => Float (Zpred (Fnum x)) (Fexp x) end end. Theorem FPredSimpl1 : forall x : float, Fnum x = (- pPred (vNum b))%Z -> FPred x = Float (- nNormMin radix precision) (Zsucc (Fexp x)). intros x H'; unfold FPred in |- *. generalize (Z_eq_bool_correct (Fnum x) (- pPred (vNum b))); case (Z_eq_bool (Fnum x) (- pPred (vNum b))); auto. intros H'0; Contradict H'0; auto. Qed. Theorem FPredSimpl2 : forall x : float, Fnum x = nNormMin radix precision -> Fexp x <> (- dExp b)%Z -> FPred x = Float (pPred (vNum b)) (Zpred (Fexp x)). intros x H' H'0; unfold FPred in |- *. generalize (Z_eq_bool_correct (Fnum x) (- pPred (vNum b))); case (Z_eq_bool (Fnum x) (- pPred (vNum b))); auto. intros H'1; absurd (0%nat < Fnum x)%Z; auto with zarith arith. apply Zle_not_lt; rewrite H'1; replace (Z_of_nat 0) with (- (0))%Z; [ apply Zle_Zopp | simpl in |- *; auto ]. unfold pPred in |- *; apply Zle_Zpred; red in |- *; simpl in |- *; auto. rewrite H'. apply nNormPos; auto with zarith. intros H'1; generalize (Z_eq_bool_correct (Fnum x) (nNormMin radix precision)); case (Z_eq_bool (Fnum x) (nNormMin radix precision)). intros H'2; generalize (Z_eq_bool_correct (Fexp x) (- dExp b)); case (Z_eq_bool (Fexp x) (- dExp b)); auto. intros H'3; Contradict H'0; auto. intros H'2; Contradict H'2; auto. Qed. Theorem FPredSimpl3 : FPred (Float (nNormMin radix precision) (- dExp b)) = Float (Zpred (nNormMin radix precision)) (- dExp b). unfold FPred in |- *; simpl in |- *. generalize (Z_eq_bool_correct (nNormMin radix precision) (- pPred (vNum b))); case (Z_eq_bool (nNormMin radix precision) (- pPred (vNum b))); auto. intros H'0; absurd (0 < pPred (vNum b))%Z; auto with zarith arith. rewrite <- (Zopp_involutive (pPred (vNum b))); rewrite <- H'0. apply Zle_not_lt; replace 0%Z with (- (0))%Z; [ apply Zle_Zopp | simpl in |- *; auto ]. apply Zlt_le_weak; apply nNormPos; auto with float zarith. unfold pPred in |- *; apply Zlt_succ_pred; simpl in |- *; auto with float zarith. simpl in |- *; apply vNumbMoreThanOne with (3 := pGivesBound); auto. intros H'; generalize (Z_eq_bool_correct (nNormMin radix precision) (nNormMin radix precision)); case (Z_eq_bool (nNormMin radix precision) (nNormMin radix precision)). intros H'0; generalize (Z_eq_bool_correct (- dExp b) (- dExp b)); case (Z_eq_bool (- dExp b) (- dExp b)); auto. intros H'1; Contradict H'1; auto. intros H'1; Contradict H'1; auto. Qed. Theorem FPredSimpl4 : forall x : float, Fnum x <> (- pPred (vNum b))%Z -> Fnum x <> nNormMin radix precision -> FPred x = Float (Zpred (Fnum x)) (Fexp x). intros x H' H'0; unfold FPred in |- *. generalize (Z_eq_bool_correct (Fnum x) (- pPred (vNum b))); case (Z_eq_bool (Fnum x) (- pPred (vNum b))); auto. intros H'1; Contradict H'; auto. intros H'1; generalize (Z_eq_bool_correct (Fnum x) (nNormMin radix precision)); case (Z_eq_bool (Fnum x) (nNormMin radix precision)); auto. intros H'2; Contradict H'0; auto. Qed. Theorem FPredFopFSucc : forall x : float, FPred x = Fopp (FSucc b radix precision (Fopp x)). intros x. generalize (Z_eq_bool_correct (Fnum x) (- pPred (vNum b))); case (Z_eq_bool (Fnum x) (- pPred (vNum b))); intros H'1. rewrite FPredSimpl1; auto; rewrite FSuccSimpl1; auto. unfold Fopp in |- *; simpl in |- *; rewrite H'1; auto with zarith. generalize (Z_eq_bool_correct (Fnum x) (nNormMin radix precision)); case (Z_eq_bool (Fnum x) (nNormMin radix precision)); intros H'2. generalize (Z_eq_bool_correct (Fexp x) (- dExp b)); case (Z_eq_bool (Fexp x) (- dExp b)); intros H'3. replace x with (Float (Fnum x) (Fexp x)). rewrite H'2; rewrite H'3; rewrite FPredSimpl3; unfold Fopp in |- *; simpl in |- *; rewrite FSuccSimpl3; simpl in |- *; auto. rewrite <- Zopp_Zpred_Zs; rewrite Zopp_involutive; auto. case x; simpl in |- *; auto. rewrite FPredSimpl2; auto; rewrite FSuccSimpl2; unfold Fopp in |- *; simpl in |- *; try rewrite Zopp_involutive; auto. rewrite H'2; auto. rewrite FPredSimpl4; auto; rewrite FSuccSimpl4; auto. unfold Fopp in |- *; simpl in |- *; rewrite <- Zopp_Zpred_Zs; rewrite Zopp_involutive; auto. unfold Fopp in |- *; simpl in |- *; Contradict H'1; rewrite <- H'1; rewrite Zopp_involutive; auto. unfold Fopp in |- *; simpl in |- *; Contradict H'2; auto with zarith. Qed. Theorem FPredDiff1 : forall x : float, Fnum x <> nNormMin radix precision -> Fminus radix x (FPred x) = Float 1%nat (Fexp x) :>R. intros x H'; rewrite (FPredFopFSucc x). pattern x at 1 in |- *; rewrite <- (Fopp_Fopp x). rewrite <- Fopp_Fminus_dist. rewrite Fopp_Fminus. unfold FtoRradix in |- *; rewrite FSuccDiff1; auto. replace (Fnum (Fopp x)) with (- Fnum x)%Z. Contradict H'; rewrite <- (Zopp_involutive (Fnum x)); rewrite H'; auto with zarith. case x; simpl in |- *; auto. Qed. Theorem FPredDiff2 : forall x : float, Fnum x = nNormMin radix precision -> Fexp x = (- dExp b)%Z -> Fminus radix x (FPred x) = Float 1%nat (Fexp x) :>R. intros x H' H'0; rewrite (FPredFopFSucc x). pattern x at 1 in |- *; rewrite <- (Fopp_Fopp x). rewrite <- Fopp_Fminus_dist. rewrite Fopp_Fminus. unfold FtoRradix in |- *; rewrite FSuccDiff2; auto. rewrite <- H'; case x; auto. Qed. Theorem FPredDiff3 : forall x : float, Fnum x = nNormMin radix precision -> Fexp x <> (- dExp b)%Z -> Fminus radix x (FPred x) = Float 1%nat (Zpred (Fexp x)) :>R. intros x H' H'0; rewrite (FPredFopFSucc x). pattern x at 1 in |- *; rewrite <- (Fopp_Fopp x). rewrite <- Fopp_Fminus_dist. rewrite Fopp_Fminus. unfold FtoRradix in |- *; rewrite FSuccDiff3; auto. rewrite <- H'; case x; auto. Qed. Theorem FBoundedPred : forall f : float, Fbounded b f -> Fbounded b (FPred f). intros f H'; rewrite (FPredFopFSucc f); auto with float. Qed. Theorem FPredCanonic : forall a : float, Fcanonic radix b a -> Fcanonic radix b (FPred a). intros a H'. rewrite FPredFopFSucc; auto with float. Qed. Theorem FPredLt : forall a : float, (FPred a < a)%R. intros a; rewrite FPredFopFSucc. pattern a at 2 in |- *; rewrite <- (Fopp_Fopp a). unfold FtoRradix in |- *; repeat rewrite Fopp_correct. apply Ropp_lt_contravar. rewrite <- Fopp_correct; auto with float. Qed. Theorem R0RltRlePred : forall x : float, (0 < x)%R -> (0 <= FPred x)%R. intros x H'; rewrite FPredFopFSucc. unfold FtoRradix in |- *; repeat rewrite Fopp_correct. replace 0%R with (-0)%R; auto with real. apply Ropp_le_contravar. apply R0RltRleSucc; auto. unfold FtoRradix in |- *; repeat rewrite Fopp_correct. replace 0%R with (-0)%R; auto with real. Qed. Theorem FPredProp : forall x y : float, Fcanonic radix b x -> Fcanonic radix b y -> (x < y)%R -> (x <= FPred y)%R. intros x y H' H'0 H'1; rewrite FPredFopFSucc. rewrite <- (Fopp_Fopp x). unfold FtoRradix in |- *; rewrite Fopp_correct with (x := Fopp x). rewrite Fopp_correct with (x := FSucc b radix precision (Fopp y)); auto with float real. apply Ropp_le_contravar. apply FSuccProp; auto with float. repeat rewrite Fopp_correct; auto with real. Qed. Theorem FPredZleEq : forall p q : float, (FPred p < q)%R -> (q <= p)%R -> (Fexp p <= Fexp q)%Z -> p = q :>R. intros p q H' H'0 H'1. rewrite <- (Ropp_involutive p); rewrite <- (Ropp_involutive q); apply Ropp_eq_compat. unfold FtoRradix in |- *; repeat rewrite <- Fopp_correct. apply FSuccZleEq with (b := b) (precision := precision); auto. repeat rewrite Fopp_correct; auto with real. apply Ropp_lt_cancel. repeat rewrite <- Fopp_correct; rewrite <- FPredFopFSucc; rewrite Fopp_Fopp; auto. Qed. Definition FNPred (x : float) := FPred (Fnormalize radix b precision x). Theorem FNPredFopFNSucc : forall x : float, FNPred x = Fopp (FNSucc b radix precision (Fopp x)). intros x; unfold FNPred, FNSucc in |- *; auto. rewrite Fnormalize_Fopp; auto. apply FPredFopFSucc; auto. Qed. Theorem FNPredCanonic : forall a : float, Fbounded b a -> Fcanonic radix b (FNPred a). intros a H'; unfold FNPred in |- *. apply FPredCanonic; auto with float. Qed. Theorem FNPredLt : forall a : float, (FNPred a < a)%R. intros a; unfold FNPred in |- *. unfold FtoRradix in |- *; rewrite <- (FnormalizeCorrect _ radixMoreThanOne b precision a). apply FPredLt; auto. Qed. Theorem FNPredProp : forall x y : float, Fbounded b x -> Fbounded b y -> (x < y)%R -> (x <= FNPred y)%R. intros x y H' H'0 H'1; unfold FNPred in |- *. replace (FtoRradix x) with (FtoRradix (Fnormalize radix b precision x)). apply FPredProp; auto with float. unfold FtoRradix in |- *; repeat rewrite FnormalizeCorrect; auto. unfold FtoRradix in |- *; repeat rewrite FnormalizeCorrect; auto. Qed. Theorem FPredSuc : forall x : float, Fcanonic radix b x -> FPred (FSucc b radix precision x) = x. intros x H; unfold FPred, FSucc in |- *. cut (Fbounded b x); [ intros Fb0 | apply FcanonicBound with (1 := H) ]. generalize (Z_eq_bool_correct (Fnum x) (pPred (vNum b))); case (Z_eq_bool (Fnum x) (pPred (vNum b))); simpl in |- *. generalize (Z_eq_bool_correct (nNormMin radix precision) (- pPred (vNum b))); case (Z_eq_bool (nNormMin radix precision) (- pPred (vNum b))); simpl in |- *. intros H'; Contradict H'; apply sym_not_equal; apply Zlt_not_eq; auto. apply Zlt_le_trans with (- 0%nat)%Z. apply Zlt_Zopp; unfold pPred in |- *; apply Zlt_succ_pred; simpl in |- *; apply vNumbMoreThanOne with (3 := pGivesBound); auto. simpl in |- *; apply Zlt_le_weak; apply nNormPos; auto. generalize (Z_eq_bool_correct (nNormMin radix precision) (nNormMin radix precision)); case (Z_eq_bool (nNormMin radix precision) (nNormMin radix precision)); simpl in |- *. generalize (Z_eq_bool_correct (Zsucc (Fexp x)) (- dExp b)); case (Z_eq_bool (Zsucc (Fexp x)) (- dExp b)); simpl in |- *. intros H' H'0 H'1 H'2; absurd (- dExp b <= Fexp x)%Z; auto with float. rewrite <- H'; auto with float zarith. replace (Zpred (Zsucc (Fexp x))) with (Fexp x); [ idtac | unfold Zsucc, Zpred in |- *; ring ]; auto. intros H' H'0 H'1 H'2; rewrite <- H'2; auto. apply floatEq; auto. intros H'; case H'; auto. generalize (Z_eq_bool_correct (Fnum x) (- nNormMin radix precision)); case (Z_eq_bool (Fnum x) (- nNormMin radix precision)); simpl in |- *. generalize (Z_eq_bool_correct (Fexp x) (- dExp b)); case (Z_eq_bool (Fexp x) (- dExp b)); simpl in |- *. generalize (Z_eq_bool_correct (Zsucc (Fnum x)) (- pPred (vNum b))); case (Z_eq_bool (Zsucc (Fnum x)) (- pPred (vNum b))); simpl in |- *. intros H0 H1 H2; absurd (Zsucc (Fnum x) <= Fnum x)%Z; auto with zarith. rewrite H0; rewrite H2; (apply Zle_Zopp; auto with float arith). unfold pPred in |- *; apply Zle_Zpred; apply ZltNormMinVnum; auto with zarith. generalize (Z_eq_bool_correct (Zsucc (Fnum x)) (nNormMin radix precision)); case (Z_eq_bool (Zsucc (Fnum x)) (nNormMin radix precision)); simpl in |- *. intros H' H'0 H'1 H'2; Contradict H'2. rewrite <- H'; auto with zarith. replace (Zpred (Zsucc (Fnum x))) with (Fnum x); [ idtac | unfold Zsucc, Zpred in |- *; ring ]; auto. intros H' H'0 H'1 H'2 H'3; apply floatEq; auto. generalize (Z_eq_bool_correct (- pPred (vNum b)) (- pPred (vNum b))); case (Z_eq_bool (- pPred (vNum b)) (- pPred (vNum b))); auto. intros H' H'0 H'1 H'2; rewrite <- H'1. replace (Zsucc (Zpred (Fexp x))) with (Fexp x); [ idtac | unfold Zsucc, Zpred in |- *; ring ]; auto. apply floatEq; auto. intros H'; case H'; auto. generalize (Z_eq_bool_correct (Zsucc (Fnum x)) (- pPred (vNum b))); case (Z_eq_bool (Zsucc (Fnum x)) (- pPred (vNum b))); simpl in |- *. intros H'; absurd (- pPred (vNum b) <= Fnum x)%Z; auto with float. rewrite <- H'; auto with zarith. apply Zle_Zabs_inv1; auto with float. unfold pPred in |- *; apply Zle_Zpred; auto with float. generalize (Z_eq_bool_correct (Zsucc (Fnum x)) (nNormMin radix precision)); case (Z_eq_bool (Zsucc (Fnum x)) (nNormMin radix precision)); simpl in |- *. generalize (Z_eq_bool_correct (Fexp x) (- dExp b)); case (Z_eq_bool (Fexp x) (- dExp b)); simpl in |- *. intros H' H'0 H'1 H'2 H'3. replace (Zpred (Zsucc (Fnum x))) with (Fnum x); [ idtac | unfold Zsucc, Zpred in |- *; ring ]; auto. apply floatEq; auto. intros H' H'0 H'1 H'2 H'3; case H. intros H'4; absurd (nNormMin radix precision <= Zabs (Fnum x))%Z. replace (Fnum x) with (Zpred (Zsucc (Fnum x))); [ idtac | unfold Zsucc, Zpred in |- *; ring ]; auto. rewrite H'0. apply Zlt_not_le; rewrite Zabs_eq; auto with zarith. apply Zle_Zpred; apply nNormPos; auto with float zarith. apply pNormal_absolu_min with (b := b); auto. intros H'4; Contradict H'; apply FsubnormalFexp with (1 := H'4). intros H' H'0 H'1 H'2; apply floatEq; simpl in |- *; auto. unfold Zpred, Zsucc in |- *; ring. Qed. Theorem FSucPred : forall x : float, Fcanonic radix b x -> FSucc b radix precision (FPred x) = x. intros x H; unfold FPred, FSucc in |- *. cut (Fbounded b x); [ intros Fb0 | apply FcanonicBound with (1 := H) ]. generalize (Z_eq_bool_correct (Fnum x) (- pPred (vNum b))); case (Z_eq_bool (Fnum x) (- pPred (vNum b))); simpl in |- *. generalize (Z_eq_bool_correct (- nNormMin radix precision) (pPred (vNum b))); case (Z_eq_bool (- nNormMin radix precision) (pPred (vNum b))); simpl in |- *. intros H'; Contradict H'; apply Zlt_not_eq; auto. rewrite <- (Zopp_involutive (pPred (vNum b))); apply Zlt_Zopp. apply Zlt_le_trans with (- 0%nat)%Z. apply Zlt_Zopp; unfold pPred in |- *; apply Zlt_succ_pred; simpl in |- *. apply (vNumbMoreThanOne radix) with (precision := precision); auto. simpl in |- *; apply Zlt_le_weak; apply nNormPos; auto with zarith arith. generalize (Z_eq_bool_correct (- nNormMin radix precision) (- nNormMin radix precision)); case (Z_eq_bool (- nNormMin radix precision) (- nNormMin radix precision)); simpl in |- *. generalize (Z_eq_bool_correct (Zsucc (Fexp x)) (- dExp b)); case (Z_eq_bool (Zsucc (Fexp x)) (- dExp b)); simpl in |- *. intros H' H'0 H'1 H'2; absurd (- dExp b <= Fexp x)%Z; auto with float. rewrite <- H'; auto with zarith. intros H' H'0 H'1 H'2; rewrite <- H'2; apply floatEq; simpl in |- *; auto; unfold Zsucc, Zpred in |- *; ring. intros H'; case H'; auto. generalize (Z_eq_bool_correct (Fnum x) (nNormMin radix precision)); case (Z_eq_bool (Fnum x) (nNormMin radix precision)); simpl in |- *. generalize (Z_eq_bool_correct (Fexp x) (- dExp b)); case (Z_eq_bool (Fexp x) (- dExp b)); simpl in |- *. generalize (Z_eq_bool_correct (Zpred (Fnum x)) (pPred (vNum b))); case (Z_eq_bool (Zpred (Fnum x)) (pPred (vNum b))); simpl in |- *. intros H' H'0 H'1 H'2; absurd (nNormMin radix precision <= pPred (vNum b))%Z; auto with float. rewrite <- H'; rewrite H'1; auto with zarith. rewrite <- H'1; auto with float. apply Zle_Zabs_inv2; auto with float zarith. unfold pPred in |- *; apply Zle_Zpred; auto with float. generalize (Z_eq_bool_correct (Zpred (Fnum x)) (- nNormMin radix precision)); case (Z_eq_bool (Zpred (Fnum x)) (- nNormMin radix precision)); simpl in |- *. intros H' H'0 H'1 H'2 H'3; absurd (Zpred (nNormMin radix precision) = (- nNormMin radix precision)%Z); auto with zarith. intros H' H'0 H'1 H'2 H'3; apply floatEq; simpl in |- *; auto; unfold Zpred, Zsucc in |- *; ring. generalize (Z_eq_bool_correct (pPred (vNum b)) (pPred (vNum b))); case (Z_eq_bool (pPred (vNum b)) (pPred (vNum b))); auto. intros H' H'0 H'1 H'2; rewrite <- H'1; apply floatEq; simpl in |- *; auto; unfold Zpred, Zsucc in |- *; ring. intros H'; case H'; auto. generalize (Z_eq_bool_correct (Zpred (Fnum x)) (pPred (vNum b))); case (Z_eq_bool (Zpred (Fnum x)) (pPred (vNum b))); simpl in |- *. intros H'; absurd (Fnum x <= pPred (vNum b))%Z; auto with float. rewrite <- H'. apply Zlt_not_le; apply Zlt_pred; auto. apply Zle_Zabs_inv2; unfold pPred in |- *; apply Zle_Zpred; auto with float. generalize (Z_eq_bool_correct (Zpred (Fnum x)) (- nNormMin radix precision)); case (Z_eq_bool (Zpred (Fnum x)) (- nNormMin radix precision)); simpl in |- *. generalize (Z_eq_bool_correct (Fexp x) (- dExp b)); case (Z_eq_bool (Fexp x) (- dExp b)); simpl in |- *. intros H' H'0 H'1 H'2 H'3; apply floatEq; simpl in |- *; auto; unfold Zsucc, Zpred in |- *; ring. intros H' H'0 H'1 H'2 H'3; case H; intros C0. absurd (nNormMin radix precision <= Zabs (Fnum x))%Z; auto with float. replace (Fnum x) with (Zsucc (Zpred (Fnum x))); [ idtac | unfold Zsucc, Zpred in |- *; ring ]. rewrite H'0. rewrite <- Zopp_Zpred_Zs; rewrite Zabs_Zopp. rewrite Zabs_eq; auto with zarith. apply Zle_Zpred; simpl in |- *; apply nNormPos; auto with float zarith. apply pNormal_absolu_min with (b := b); auto. Contradict H'; apply FsubnormalFexp with (1 := C0). intros H' H'0 H'1 H'2; apply floatEq; simpl in |- *; auto. unfold Zpred, Zsucc in |- *; ring. Qed. Theorem FNPredSuc : forall x : float, Fbounded b x -> FNPred (FNSucc b radix precision x) = x :>R. intros x H'; unfold FNPred in |- *; rewrite FcanonicFnormalizeEq; auto. unfold FNSucc in |- *; rewrite FPredSuc; auto. unfold FtoRradix in |- *; apply FnormalizeCorrect; auto. apply FnormalizeCanonic; auto. apply FNSuccCanonic; auto. Qed. Theorem FNPredSucEq : forall x : float, Fcanonic radix b x -> FNPred (FNSucc b radix precision x) = x. intros x H'. apply FcanonicUnique with (precision := precision) (5 := H'); auto. apply FNPredCanonic; auto with float. apply FcanonicBound with (radix := radix); auto. apply FNSuccCanonic; auto. apply FcanonicBound with (radix := radix); auto. apply FNPredSuc; auto. apply FcanonicBound with (radix := radix); auto. Qed. Theorem FNSucPred : forall x : float, Fbounded b x -> FNSucc b radix precision (FNPred x) = x :>R. intros x H'; unfold FNSucc in |- *; rewrite FcanonicFnormalizeEq; auto. unfold FNPred in |- *; rewrite FSucPred; auto. unfold FtoRradix in |- *; apply FnormalizeCorrect; auto. apply FnormalizeCanonic; auto. apply FNPredCanonic; auto. Qed. Theorem FNSucPredEq : forall x : float, Fcanonic radix b x -> FNSucc b radix precision (FNPred x) = x. intros x H'. apply FcanonicUnique with (5 := H') (precision := precision); auto. apply FNSuccCanonic; auto. apply FcanonicBound with (radix := radix); auto. apply FNPredCanonic; auto. apply FcanonicBound with (radix := radix); auto. apply FNSucPred; auto. apply FcanonicBound with (radix := radix); auto. Qed. End pred. Hint Resolve FBoundedPred FPredCanonic FPredLt R0RltRleSucc FPredProp FNPredCanonic FNPredLt FNPredProp: float.Float8.4/FSucc.v0000644000423700002640000011604312032774525013247 0ustar sboldotoccata(**************************************************************************** IEEE754 : FSucc Laurent Thery ******************************************************************************) Require Export List. Require Export Fnorm. Section suc. Variable b : Fbound. Variable radix : Z. Variable precision : nat. Coercion Local FtoRradix := FtoR radix. Hypothesis radixMoreThanOne : (1 < radix)%Z. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Hypothesis precisionNotZero : precision <> 0. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Definition FSucc (x : float) := match Z_eq_bool (Fnum x) (pPred (vNum b)) with | true => Float (nNormMin radix precision) (Zsucc (Fexp x)) | false => match Z_eq_bool (Fnum x) (- nNormMin radix precision) with | true => match Z_eq_bool (Fexp x) (- dExp b) with | true => Float (Zsucc (Fnum x)) (Fexp x) | false => Float (- pPred (vNum b)) (Zpred (Fexp x)) end | false => Float (Zsucc (Fnum x)) (Fexp x) end end. Theorem FSuccSimpl1 : forall x : float, Fnum x = pPred (vNum b) -> FSucc x = Float (nNormMin radix precision) (Zsucc (Fexp x)). intros x H'; unfold FSucc in |- *. generalize (Z_eq_bool_correct (Fnum x) (pPred (vNum b))); case (Z_eq_bool (Fnum x) (pPred (vNum b))); auto. intros H'0; Contradict H'0; auto. Qed. Theorem FSuccSimpl2 : forall x : float, Fnum x = (- nNormMin radix precision)%Z -> Fexp x <> (- dExp b)%Z -> FSucc x = Float (- pPred (vNum b)) (Zpred (Fexp x)). intros x H' H'0; unfold FSucc in |- *. generalize (Z_eq_bool_correct (Fnum x) (pPred (vNum b))); case (Z_eq_bool (Fnum x) (pPred (vNum b))); auto. intros H'1; absurd (0%nat <= pPred (vNum b))%Z; auto with zarith arith. rewrite <- H'1; rewrite H'. unfold nNormMin in |- *; simpl in |- *; auto with zarith. replace 0%Z with (- (0))%Z; auto with zarith. unfold pPred in |- *; apply Zle_Zpred; auto with zarith. intros H'1; generalize (Z_eq_bool_correct (Fnum x) (- nNormMin radix precision)); case (Z_eq_bool (Fnum x) (- nNormMin radix precision)). intros H'2; generalize (Z_eq_bool_correct (Fexp x) (- dExp b)); case (Z_eq_bool (Fexp x) (- dExp b)); auto. intros H'3; Contradict H'0; auto. intros H'2; Contradict H'2; auto. Qed. Theorem FSuccSimpl3 : FSucc (Float (- nNormMin radix precision) (- dExp b)) = Float (Zsucc (- nNormMin radix precision)) (- dExp b). unfold FSucc in |- *; simpl in |- *. generalize (Z_eq_bool_correct (- nNormMin radix precision) (pPred (vNum b))); case (Z_eq_bool (- nNormMin radix precision) (pPred (vNum b))); auto. intros H'1; absurd (0%nat <= pPred (vNum b))%Z; auto with zarith arith. rewrite <- H'1. unfold nNormMin in |- *; simpl in |- *; auto with zarith. replace 0%Z with (- (0))%Z; auto with zarith. unfold pPred in |- *; apply Zle_Zpred; auto with zarith. intros H'; generalize (Z_eq_bool_correct (- nNormMin radix precision) (- nNormMin radix precision)); case (Z_eq_bool (- nNormMin radix precision) (- nNormMin radix precision)). intros H'0; generalize (Z_eq_bool_correct (- dExp b) (- dExp b)); case (Z_eq_bool (- dExp b) (- dExp b)); auto. intros H'1; Contradict H'1; auto. intros H'1; Contradict H'1; auto. Qed. Theorem FSuccSimpl4 : forall x : float, Fnum x <> pPred (vNum b) -> Fnum x <> (- nNormMin radix precision)%Z -> FSucc x = Float (Zsucc (Fnum x)) (Fexp x). intros x H' H'0; unfold FSucc in |- *. generalize (Z_eq_bool_correct (Fnum x) (pPred (vNum b))); case (Z_eq_bool (Fnum x) (pPred (vNum b))); auto. intros H'1; Contradict H'; auto. intros H'1; generalize (Z_eq_bool_correct (Fnum x) (- nNormMin radix precision)); case (Z_eq_bool (Fnum x) (- nNormMin radix precision)); auto. intros H'2; Contradict H'0; auto. Qed. Theorem FSuccDiff1 : forall x : float, Fnum x <> (- nNormMin radix precision)%Z -> Fminus radix (FSucc x) x = Float 1%nat (Fexp x) :>R. intros x H'. generalize (Z_eq_bool_correct (Fnum x) (pPred (vNum b))); case (Z_eq_bool (Fnum x) (pPred (vNum b))); intros H'1. rewrite FSuccSimpl1; auto. unfold FtoRradix, FtoR, Fminus, Fopp, Fplus in |- *; simpl in |- *; auto. repeat rewrite Zmin_le2; auto with zarith. rewrite <- Zminus_succ_l; repeat rewrite <- Zminus_diag_reverse. rewrite absolu_Zs; auto with zarith; simpl in |- *. rewrite Zpower_nat_O; rewrite Zpower_nat_1. rewrite H'1; unfold pPred in |- *; rewrite pGivesBound; unfold nNormMin in |- *. replace (Zpower_nat radix (pred precision) * radix)%Z with (Zpower_nat radix precision). rewrite plus_IZR; rewrite Rmult_IZR; rewrite Ropp_Ropp_IZR; simpl in |- *. unfold Zpred in |- *; unfold Zminus in |- *; rewrite plus_IZR; simpl in |- *; ring; ring. pattern precision at 1 in |- *; replace precision with (pred precision + 1). rewrite Zpower_nat_is_exp; rewrite Zpower_nat_1; auto. generalize precisionNotZero; case precision; simpl in |- *; auto with zarith arith. rewrite FSuccSimpl4; auto. unfold FtoRradix, FtoR, Fminus, Fopp, Fplus in |- *; simpl in |- *; auto. repeat rewrite Zmin_n_n; repeat rewrite <- Zminus_diag_reverse; simpl in |- *. rewrite Zpower_nat_O; repeat rewrite Zmult_1_r. replace (Zsucc (Fnum x) + - Fnum x)%Z with (Z_of_nat 1). simpl in |- *; auto. simpl in |- *; unfold Zsucc in |- *; ring. Qed. Theorem FSuccDiff2 : forall x : float, Fnum x = (- nNormMin radix precision)%Z -> Fexp x = (- dExp b)%Z -> Fminus radix (FSucc x) x = Float 1%nat (Fexp x) :>R. intros x H' H'0; replace x with (Float (Fnum x) (Fexp x)). rewrite H'; rewrite H'0; rewrite FSuccSimpl3; auto. unfold FtoRradix, FtoR, Fminus, Fopp, Fplus in |- *; simpl in |- *; auto. repeat rewrite Zmin_n_n; repeat rewrite <- Zminus_diag_reverse; auto with zarith. simpl in |- *; rewrite Zpower_nat_O; repeat rewrite Zmult_1_r. rewrite Zplus_succ_l; rewrite Zplus_opp_r; simpl in |- *; auto. case x; simpl in |- *; auto. Qed. Theorem FSuccDiff3 : forall x : float, Fnum x = (- nNormMin radix precision)%Z -> Fexp x <> (- dExp b)%Z -> Fminus radix (FSucc x) x = Float 1%nat (Zpred (Fexp x)) :>R. intros x H' H'1; rewrite FSuccSimpl2; auto. unfold FtoRradix, FtoR, Fminus, Fopp, Fplus in |- *; simpl in |- *; auto. repeat rewrite Zmin_le1; auto with zarith. rewrite <- Zminus_diag_reverse; rewrite <- Zminus_n_predm; repeat rewrite <- Zminus_diag_reverse. rewrite absolu_Zs; auto with zarith; simpl in |- *. rewrite Zpower_nat_O; rewrite Zpower_nat_1. rewrite H'; unfold pPred in |- *; rewrite pGivesBound; unfold nNormMin in |- *. rewrite Zopp_involutive; rewrite Zmult_1_r. replace (Zpower_nat radix (pred precision) * radix)%Z with (Zpower_nat radix precision). unfold Zpred in |- *; simpl in |- *; repeat rewrite plus_IZR || rewrite Ropp_Ropp_IZR. simpl in |- *; ring. pattern precision at 1 in |- *; replace precision with (pred precision + 1). rewrite Zpower_nat_is_exp; rewrite Zpower_nat_1; auto. generalize precisionNotZero; case precision; simpl in |- *; auto with zarith arith. Qed. Theorem ZltNormMinVnum : (nNormMin radix precision < Zpos (vNum b))%Z. unfold nNormMin in |- *; rewrite pGivesBound; auto with zarith. Qed. Hint Resolve ZltNormMinVnum: float. Theorem FSuccNormPos : forall a : float, (0 <= a)%R -> Fnormal radix b a -> Fnormal radix b (FSucc a). intros a H' H'0; unfold FSucc in |- *. cut (Fbounded b a); [ intros B0 | apply FnormalBounded with (1 := H'0); auto ]. generalize (Z_eq_bool_correct (Fnum a) (pPred (vNum b))); case (Z_eq_bool (Fnum a) (pPred (vNum b))); auto. intros H'3; repeat split; simpl in |- *; auto. rewrite Zabs_eq; auto with float zarith. unfold nNormMin in |- *; auto with zarith. apply Zle_trans with (m := Fexp a); auto with float zarith arith. rewrite pGivesBound; rewrite Zabs_eq; auto with zarith. pattern precision at 1 in |- *; replace precision with (1 + pred precision). rewrite Zpower_nat_is_exp; rewrite Zpower_nat_1; unfold nNormMin in |- *; auto with zarith. generalize precisionNotZero; case precision; auto with zarith. apply Zle_mult_gen; simpl in |- *; auto with zarith. apply Zle_trans with 1%Z; auto with zarith. unfold nNormMin in |- *; auto with zarith. intros H'3; generalize (Z_eq_bool_correct (Fnum a) (- nNormMin radix precision)); case (Z_eq_bool (Fnum a) (- nNormMin radix precision)). intros H'4; absurd (0 <= Fnum a)%Z; auto. 2: apply LeR0Fnum with (radix := radix); auto with zarith. rewrite H'4; auto. apply Zlt_not_le. replace 0%Z with (- 0%nat)%Z; unfold nNormMin in |- *; auto with zarith. intros H'4; repeat split; simpl in |- *; auto with float zarith arith. apply Zle_lt_trans with (Zsucc (Zabs (Fnum a))); auto with float zarith. case (Zlt_next (Zabs (Fnum a)) (Zpos (vNum b))); auto with float zarith arith. intros H1; Contradict H'3. unfold pPred in |- *; rewrite H1; rewrite Zabs_eq; auto with zarith. apply LeR0Fnum with (radix := radix); auto with zarith. apply Zle_trans with (Zabs (radix * Fnum a)); auto with float zarith. case H'0; auto. repeat rewrite Zabs_Zmult. cut (0 <= Fnum a)%Z; [ intros Z1 | apply LeR0Fnum with (radix := radix) ]; auto. rewrite (Zabs_eq (Fnum a)); auto. rewrite (Zabs_eq (Zsucc (Fnum a))); auto with zarith. Qed. Theorem FSuccSubnormNotNearNormMin : forall a : float, Fsubnormal radix b a -> Fnum a <> Zpred (nNormMin radix precision) -> Fsubnormal radix b (FSucc a). intros a H' H'0. cut (Fbounded b a); [ intros B0 | apply FsubnormalFbounded with (1 := H'); auto ]. unfold FSucc in |- *. generalize (Z_eq_bool_correct (Fnum a) (pPred (vNum b))); case (Z_eq_bool (Fnum a) (pPred (vNum b))); auto. intros H'2; absurd (Fdigit radix a < precision); auto with float. 2: apply FsubnormalDigit with (b := b); auto. unfold Fdigit in |- *; rewrite H'2. unfold pPred in |- *; rewrite (digitPredVNumiSPrecision radix) with (b := b) (precision := precision); auto with arith. intros H'3; generalize (Z_eq_bool_correct (Fnum a) (- nNormMin radix precision)); case (Z_eq_bool (Fnum a) (- nNormMin radix precision)). intros H'2; absurd (Fdigit radix a < precision); auto with float. unfold Fdigit in |- *; rewrite H'2. replace (digit radix (- nNormMin radix precision)) with (digit radix (nNormMin radix precision)). rewrite digitnNormMin; auto with arith. case (nNormMin radix precision); simpl in |- *; auto. apply FsubnormalDigit with (b := b); auto. intros H'4; repeat split; simpl in |- *; auto with float zarith arith. apply Zle_lt_trans with (m := Zsucc (Zabs (Fnum a))); auto with float zarith arith. apply Zlt_le_trans with (m := Zsucc (nNormMin radix precision)); auto with float zarith arith. apply Zsucc_lt_compat; apply pSubnormal_absolu_min with (3 := pGivesBound); auto with float zarith arith. case H'; intros H1 (H2, H3); auto with float. rewrite Zabs_Zmult. rewrite (Zabs_eq radix); auto with zarith. apply Zlt_le_trans with (m := (radix * nNormMin radix precision)%Z); auto with float zarith arith. apply Zmult_gt_0_lt_compat_l; try apply Zlt_gt; auto with zarith. apply Zlt_Zabs_Zpred; auto with float zarith arith. apply pSubnormal_absolu_min with (3 := pGivesBound); auto. pattern radix at 1 in |- *; rewrite <- (Zpower_nat_1 radix); unfold nNormMin in |- *; rewrite <- Zpower_nat_is_exp. rewrite pGivesBound. generalize precisionNotZero; case precision; simpl in |- *; auto with zarith. Qed. Theorem FSuccSubnormNearNormMin : forall a : float, Fsubnormal radix b a -> Fnum a = Zpred (nNormMin radix precision) -> Fnormal radix b (FSucc a). intros a H' H'0. cut (Fbounded b a); [ intros Fb0 | apply FsubnormalFbounded with (1 := H') ]. unfold FSucc in |- *. generalize (Z_eq_bool_correct (Fnum a) (pPred (vNum b))); case (Z_eq_bool (Fnum a) (pPred (vNum b))); auto. intros H'1; absurd (nNormMin radix precision < Zpos (vNum b))%Z; auto with float. apply Zle_not_lt. apply Zle_n_Zpred; unfold pPred in H'1; rewrite <- H'1; rewrite H'0; auto with zarith. intros H'3; generalize (Z_eq_bool_correct (Fnum a) (- nNormMin radix precision)); case (Z_eq_bool (Fnum a) (- nNormMin radix precision)). intros H'1; absurd (- nNormMin radix precision < Zpred (nNormMin radix precision))%Z. rewrite <- H'1; rewrite <- H'0; auto with zarith. unfold nNormMin in |- *; apply Zlt_le_trans with (m := (- (0))%Z); auto with zarith. intros H'4; repeat split; simpl in |- *; auto with float zarith arith. rewrite H'0. rewrite <- Zsucc_pred. rewrite Zabs_eq; auto with float zarith. unfold nNormMin in |- *; auto with zarith. rewrite H'0. rewrite <- Zsucc_pred. pattern radix at 1 in |- *; rewrite <- (Zpower_nat_1 radix); unfold nNormMin in |- *; rewrite <- Zpower_nat_is_exp. rewrite pGivesBound. generalize precisionNotZero; case precision; simpl in |- *; auto with zarith. Qed. Theorem FBoundedSuc : forall f : float, Fbounded b f -> Fbounded b (FSucc f). intros f H'; unfold FSucc in |- *. generalize (Z_eq_bool_correct (Fnum f) (pPred (vNum b))); case (Z_eq_bool (Fnum f) (pPred (vNum b))); intros H'1. repeat split; simpl in |- *; auto with zarith arith. rewrite Zabs_eq; auto with float zarith. unfold nNormMin in |- *; auto with zarith. apply Zle_trans with (Fexp f); auto with float zarith. generalize (Z_eq_bool_correct (Fnum f) (- nNormMin radix precision)); case (Z_eq_bool (Fnum f) (- nNormMin radix precision)); intros H'2. generalize (Z_eq_bool_correct (Fexp f) (- dExp b)); case (Z_eq_bool (Fexp f) (- dExp b)); intros H'3. repeat split; simpl in |- *; auto with float zarith arith. apply Zlt_Zabs_Zpred; auto with float zarith arith. repeat split; simpl in |- *; auto with float zarith arith. rewrite Zabs_Zopp. rewrite Zabs_eq; unfold pPred in |- *; auto with zarith. case (Zle_next (- dExp b) (Fexp f)); auto with float zarith arith. repeat split; simpl in |- *; auto with float zarith arith. apply Zlt_Zabs_Zpred; auto with float zarith arith. Qed. Theorem FSuccSubnormal : forall a : float, Fsubnormal radix b a -> Fcanonic radix b (FSucc a). intros a H'. generalize (Z_eq_bool_correct (Fnum a) (Zpred (nNormMin radix precision))); case (Z_eq_bool (Fnum a) (Zpred (nNormMin radix precision))); intros H'1. left; apply FSuccSubnormNearNormMin; auto. right; apply FSuccSubnormNotNearNormMin; auto. Qed. Theorem FSuccPosNotMax : forall a : float, (0 <= a)%R -> Fcanonic radix b a -> Fcanonic radix b (FSucc a). intros a H' H'0; case H'0; intros H'2. left; apply FSuccNormPos; auto. apply FSuccSubnormal; auto. Qed. Theorem FSuccNormNegNotNormMin : forall a : float, (a <= 0)%R -> Fnormal radix b a -> a <> Float (- nNormMin radix precision) (- dExp b) -> Fnormal radix b (FSucc a). intros a H' H'0 H'1; cut (Fbounded b a); [ intros Fb0 | apply FnormalBounded with (1 := H'0) ]. cut (Fnum a <= 0)%Z; [ intros Z0 | apply R0LeFnum with (radix := radix) ]; auto with zarith. case (Zle_lt_or_eq _ _ Z0); intros Z1. 2: absurd (is_Fzero a); auto with float. 2: apply FnormalNotZero with (1 := H'0); auto. unfold FSucc in |- *. generalize (Z_eq_bool_correct (Fnum a) (pPred (vNum b))); case (Z_eq_bool (Fnum a) (pPred (vNum b))); auto. intros H'2; absurd (0 < Fnum a)%Z; auto with zarith arith. rewrite H'2; unfold pPred in |- *; apply Zlt_succ_pred; simpl in |- *; apply (vNumbMoreThanOne radix) with (precision := precision); auto with zarith arith. intros H'3; generalize (Z_eq_bool_correct (Fnum a) (- nNormMin radix precision)); case (Z_eq_bool (Fnum a) (- nNormMin radix precision)); auto. intros H'2; generalize (Z_eq_bool_correct (Fexp a) (- dExp b)); case (Z_eq_bool (Fexp a) (- dExp b)). intros H'4; Contradict H'1; auto. apply floatEq; auto. intros H'4; repeat split; simpl in |- *; auto with zarith. rewrite Zabs_Zopp. unfold pPred in |- *; rewrite Zabs_eq; auto with zarith. case (Zle_next (- dExp b) (Fexp a)); auto with float zarith. rewrite <- Zopp_mult_distr_r; rewrite Zabs_Zopp. rewrite Zabs_Zmult. repeat rewrite Zabs_eq; auto with float zarith. pattern (Zpos (vNum b)) at 1 in |- *; rewrite (PosNormMin radix) with (precision := precision); auto with zarith. apply Zle_Zmult_comp_l; auto with zarith. unfold pPred in |- *; apply Zle_Zpred; auto with float zarith. unfold pPred in |- *; apply Zle_Zpred; auto with float zarith. intros H'2; repeat split; simpl in |- *; auto with float zarith arith. apply Zlt_trans with (Zabs (Fnum a)); auto with float zarith. repeat rewrite Zabs_eq_opp; auto with float zarith. rewrite Zabs_Zmult. rewrite (Zabs_eq radix); [ idtac | apply Zle_trans with 1%Z; auto with zarith ]. repeat rewrite Zabs_eq_opp; auto with float zarith. pattern (Zpos (vNum b)) at 1 in |- *; rewrite (PosNormMin radix) with (precision := precision); auto with zarith. apply Zle_Zmult_comp_l; auto with zarith. replace (- Zsucc (Fnum a))%Z with (Zpred (- Fnum a)). auto with float zarith. unfold pPred in |- *; apply Zle_Zpred. case (Zle_lt_or_eq (nNormMin radix precision) (- Fnum a)); auto. rewrite <- Zabs_eq_opp; auto with float zarith. apply pNormal_absolu_min with (b := b); auto. intros H'4; Contradict H'2; rewrite H'4; ring. apply Zpred_Zopp_Zs; auto. Qed. Theorem FSuccNormNegNormMin : Fsubnormal radix b (FSucc (Float (- nNormMin radix precision) (- dExp b))). unfold FSucc in |- *; simpl in |- *. generalize (Z_eq_bool_correct (- nNormMin radix precision) (pPred (vNum b))); case (Z_eq_bool (- nNormMin radix precision) (pPred (vNum b))); intros H'; auto. absurd (0%nat < pPred (vNum b))%Z; auto. rewrite <- H'; auto with float zarith. replace (Z_of_nat 0) with (- (0))%Z; [ idtac | simpl in |- *; auto ]. apply Zle_not_lt; apply Zle_Zopp; auto with float zarith. apply Zlt_le_weak; auto with float zarith. apply nNormPos; auto with float zarith. unfold pPred in |- *; apply Zlt_succ_pred; simpl in |- *; auto with float zarith. apply (vNumbMoreThanOne radix) with (precision := precision); auto with float zarith. generalize (Z_eq_bool_correct (- nNormMin radix precision) (- nNormMin radix precision)); case (Z_eq_bool (- nNormMin radix precision) (- nNormMin radix precision)); intros H'0. 2: Contradict H'0; auto. generalize (Z_eq_bool_correct (- dExp b) (- dExp b)); case (Z_eq_bool (- dExp b) (- dExp b)); intros H'1. 2: Contradict H'1; auto. repeat split; simpl in |- *; auto with zarith. apply Zle_lt_trans with (m := nNormMin radix precision); auto with float zarith. rewrite <- Zopp_Zpred_Zs; rewrite Zabs_Zopp; rewrite Zabs_eq; auto with float zarith. apply Zle_Zpred; simpl in |- *; auto with float zarith. apply nNormPos; auto with float zarith. rewrite Zabs_Zmult; rewrite (Zabs_eq radix); auto with zarith. rewrite (PosNormMin radix) with (precision := precision); auto with zarith. apply Zmult_gt_0_lt_compat_l; auto with float zarith. rewrite <- Zopp_Zpred_Zs; rewrite Zabs_Zopp. rewrite Zabs_eq; auto with zarith. apply Zle_Zpred; simpl in |- *; auto with float zarith. apply nNormPos; auto with float zarith. Qed. Theorem FSuccNegCanonic : forall a : float, (a <= 0)%R -> Fcanonic radix b a -> Fcanonic radix b (FSucc a). intros a H' H'0; case H'0; intros H'1. case (floatDec a (Float (- nNormMin radix precision) (- dExp b))); intros H'2. rewrite H'2; right; apply FSuccNormNegNormMin; auto. left; apply FSuccNormNegNotNormMin; auto. apply FSuccSubnormal; auto. Qed. Theorem FSuccCanonic : forall a : float, Fcanonic radix b a -> Fcanonic radix b (FSucc a). intros a H'. case (Rle_or_lt 0 a); intros H'3. apply FSuccPosNotMax; auto. apply FSuccNegCanonic; auto with real. Qed. Theorem FSuccLt : forall a : float, (a < FSucc a)%R. intros a; unfold FSucc in |- *. generalize (Z_eq_bool_correct (Fnum a) (pPred (vNum b))); case (Z_eq_bool (Fnum a) (pPred (vNum b))); auto. intros H'; unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite H'. unfold pPred in |- *; rewrite (PosNormMin radix) with (precision := precision); auto with zarith; unfold nNormMin in |- *. rewrite powerRZ_Zs; auto with real zarith. repeat rewrite <- Rmult_assoc. apply Rlt_monotony_exp; auto with zarith. rewrite Zmult_comm. rewrite <- Rmult_IZR. apply Rlt_IZR; auto with zarith. intros H'; generalize (Z_eq_bool_correct (Fnum a) (- nNormMin radix precision)); case (Z_eq_bool (Fnum a) (- nNormMin radix precision)). intros H'0; generalize (Z_eq_bool_correct (Fexp a) (- dExp b)); case (Z_eq_bool (Fexp a) (- dExp b)). intros H'1; unfold FtoRradix, FtoR in |- *; simpl in |- *. apply Rlt_monotony_exp; auto with real zarith. intros H'1; unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite H'0. pattern (Fexp a) at 1 in |- *; replace (Fexp a) with (Zsucc (Zpred (Fexp a))). rewrite powerRZ_Zs; auto with real zarith. repeat rewrite <- Rmult_assoc. apply Rlt_monotony_exp; auto with real zarith. rewrite <- Rmult_IZR. apply Rlt_IZR; auto with zarith. rewrite <- Zopp_mult_distr_l. apply Zlt_Zopp. rewrite Zmult_comm. unfold pPred in |- *; rewrite (PosNormMin radix) with (precision := precision); auto with zarith. apply sym_equal; apply Zsucc_pred. intros H'1; unfold FtoRradix, FtoR in |- *; simpl in |- *; auto with real zarith. Qed. Theorem FSuccPropPos : forall x y : float, (0 <= x)%R -> Fcanonic radix b x -> Fcanonic radix b y -> (x < y)%R -> (FSucc x <= y)%R. intros x y H' H'0 H'1 H'2. cut (Fbounded b x); [ intros Fb0 | apply FcanonicBound with (1 := H'0) ]. cut (Fbounded b y); [ intros Fb1 | apply FcanonicBound with (1 := H'1) ]. case FcanonicLtPos with (p := x) (q := y) (3 := pGivesBound); auto. case (Z_eq_dec (Fnum x) (pPred (vNum b))); intros H'4. rewrite FSuccSimpl1; auto. intros H'5; case (Zlt_next _ _ H'5); intros H'6. replace y with (Float (Fnum y) (Fexp y)). rewrite H'6. generalize Fle_Zle; unfold Fle, FtoRradix in |- *; intros H'7; apply H'7; clear H'7; auto with arith. rewrite <- (Zabs_eq (Fnum y)); auto with float zarith. apply pNormal_absolu_min with (b := b); auto. case H'1; auto with float. intros H'7; Contradict H'5; apply Zle_not_lt. replace (Fexp y) with (- dExp b)%Z; auto with float. case H'7; intros H'8 (H'9, H'10); auto. apply LeR0Fnum with (radix := radix); auto with zarith. apply Rle_trans with (r2 := FtoR radix x); auto with real. case y; auto. apply Rlt_le; auto. unfold FtoRradix in |- *; apply FcanonicPosFexpRlt with (3 := pGivesBound); auto. apply LeFnumZERO with (radix := radix); auto with zarith. simpl in |- *; auto with zarith. apply Zlt_le_weak; apply nNormPos. auto with zarith. apply Rle_trans with (r2 := FtoR radix x); auto with real. rewrite <- FSuccSimpl1; auto. apply FSuccCanonic; auto. intros H'5; apply Rlt_le. unfold FtoRradix in |- *; apply FcanonicPosFexpRlt with (3 := pGivesBound); auto. apply Rle_trans with (r2 := FtoR radix x); auto. apply Rlt_le; auto. apply FSuccLt; auto. apply Rle_trans with (r2 := FtoR radix x); auto with real. apply FSuccCanonic; auto. rewrite FSuccSimpl4; auto. apply sym_not_equal; apply Zlt_not_eq. apply Zlt_le_trans with (m := 0%Z); auto with zarith. replace 0%Z with (- 0%nat)%Z; auto with zarith. apply Zlt_Zopp. apply nNormPos; auto. apply LeR0Fnum with (radix := radix); auto with zarith. intros H'4; elim H'4; intros H'5 H'6; clear H'4. generalize (Z_eq_bool_correct (Fnum x) (Zpos (vNum b))); case (Z_eq_bool (Fnum x) (Zpos (vNum b))); intros H'4. Contradict H'6; auto. apply Zle_not_lt; apply Zlt_le_weak. rewrite H'4; auto with float zarith. rewrite <- (Zabs_eq (Fnum y)); auto with float zarith. apply LeR0Fnum with (radix := radix); auto with zarith. apply Rle_trans with (FtoRradix x); auto with real. case (Zlt_next _ _ H'6); intros H'7. rewrite FSuccSimpl4; auto. rewrite <- H'7; rewrite H'5; unfold FtoRradix, FtoR in |- *; simpl in |- *; auto with real. apply Zlt_not_eq. unfold pPred in |- *; apply Zlt_succ_pred; rewrite <- H'7; auto with float. rewrite <- (Zabs_eq (Fnum y)); auto with float zarith. apply LeR0Fnum with (radix := radix); auto with zarith. apply Rle_trans with (FtoRradix x); auto with real. apply Zlt_not_eq_rev. apply Zlt_le_trans with (m := 0%Z); auto with zarith. replace 0%Z with (- 0%nat)%Z; auto with zarith. apply Zlt_Zopp. apply nNormPos; auto. apply LeR0Fnum with (radix := radix); auto with zarith. rewrite FSuccSimpl4; auto. replace y with (Float (Fnum y) (Fexp y)). rewrite H'5. unfold FtoRradix, FtoR in |- *; simpl in |- *; auto with real float. case y; simpl in |- *; auto. Contradict H'7; auto. apply Zle_not_lt; apply Zlt_le_weak. rewrite H'7; auto with float zarith. unfold pPred in |- *; rewrite <- Zsucc_pred. rewrite <- (Zabs_eq (Fnum y)); auto with float zarith. apply LeR0Fnum with (radix := radix); auto with zarith. apply Rle_trans with (FtoRradix x); auto with real. apply Zlt_not_eq_rev. apply Zlt_le_trans with (m := 0%Z); auto with zarith. replace 0%Z with (- 0%nat)%Z; auto with zarith. apply Zlt_Zopp. apply nNormPos; auto. apply LeR0Fnum with (radix := radix); auto with zarith. Qed. Theorem R0RltRleSucc : forall x : float, (x < 0)%R -> (FSucc x <= 0)%R. intros a H'; unfold FSucc in |- *. generalize (Z_eq_bool_correct (Fnum a) (pPred (vNum b))); case (Z_eq_bool (Fnum a) (pPred (vNum b))); auto. intros H'0; absurd (Fnum a < 0)%Z; auto. rewrite H'0; auto with zarith arith. apply Zle_not_lt; unfold pPred in |- *; apply Zle_Zpred; auto with float. apply Zlt_trans with 1%Z; auto with zarith; apply (vNumbMoreThanOne radix) with (precision := precision); auto with zarith. apply R0LtFnum with (radix := radix); auto with zarith. generalize (Z_eq_bool_correct (Fnum a) (- nNormMin radix precision)); case (Z_eq_bool (Fnum a) (- nNormMin radix precision)); intros H'1. generalize (Z_eq_bool_correct (Fexp a) (- dExp b)); case (Z_eq_bool (Fexp a) (- dExp b)); intros H'2. intros H'0. apply LeZEROFnum with (radix := radix); simpl in |- *; auto with zarith. apply Zlt_le_succ. apply R0LtFnum with (radix := radix); auto with zarith. intros H'0. apply LeZEROFnum with (radix := radix); simpl in |- *; auto with zarith. replace 0%Z with (- (0))%Z; [ apply Zle_Zopp | simpl in |- *; auto ]. unfold pPred in |- *; apply Zle_Zpred; apply Zlt_trans with 1%Z; auto with zarith; apply (vNumbMoreThanOne radix) with (precision := precision); auto with zarith. intros H'0. apply LeZEROFnum with (radix := radix); simpl in |- *; auto with zarith. apply Zlt_le_succ. apply R0LtFnum with (radix := radix); auto with zarith. Qed. Theorem FSuccPropNeg : forall x y : float, (x < 0)%R -> Fcanonic radix b x -> Fcanonic radix b y -> (x < y)%R -> (FSucc x <= y)%R. intros x y H' H'0 H'1 H'2. cut (Fbounded b x); [ intros Fb0 | apply FcanonicBound with (1 := H'0) ]. cut (Fbounded b y); [ intros Fb1 | apply FcanonicBound with (1 := H'1) ]. case (Rle_or_lt 0 y); intros Rle0. apply Rle_trans with (r2 := 0%R); auto. apply R0RltRleSucc; auto. cut (Fnum x <> pPred (vNum b)); [ intros N0 | idtac ]; auto with zarith. generalize (Z_eq_bool_correct (Fnum x) (- nNormMin radix precision)); case (Z_eq_bool (Fnum x) (- nNormMin radix precision)); intros H'4. generalize (Z_eq_bool_correct (Fexp x) (- dExp b)); case (Z_eq_bool (Fexp x) (- dExp b)); intros H'5. replace x with (Float (Fnum x) (Fexp x)). rewrite H'4; rewrite H'5; rewrite FSuccSimpl3; auto. case FcanonicLtNeg with (p := x) (q := y) (3 := pGivesBound); auto with real. intros H'6; Contradict H'6; rewrite H'5; apply Zle_not_lt; auto with float. intros H'6; elim H'6; intros H'7 H'8; clear H'6; replace y with (Float (Fnum y) (Fexp y)). rewrite <- H'7; rewrite H'5. generalize Fle_Zle; unfold Fle, FtoRradix in |- *; intros H'9; apply H'9; clear H'9; auto with arith. rewrite <- H'4; auto with zarith. case y; auto. case x; auto. rewrite FSuccSimpl2; auto. case FcanonicLtNeg with (p := x) (q := y) (3 := pGivesBound); auto with real. intros H'6; replace y with (Float (Fnum y) (Fexp y)). case (Zlt_next _ _ H'6); intros H'7. rewrite H'7. rewrite <- Zpred_succ. unfold FtoRradix, FtoR in |- *; simpl in |- *. apply Rle_monotone_exp; auto with zarith. rewrite <- (Zopp_involutive (Fnum y)); apply Rle_IZR; apply Zle_Zopp. unfold pPred in |- *; apply Zle_Zpred; rewrite <- Zabs_eq_opp; auto with float zarith. apply Zlt_le_weak; apply R0LtFnum with (radix := radix); auto with zarith. apply Rlt_le; auto with real. unfold FtoRradix in |- *; apply FcanonicNegFexpRlt with (3 := pGivesBound); auto. apply Rlt_le; auto. rewrite <- FSuccSimpl2; auto. apply R0RltRleSucc; auto. rewrite <- FSuccSimpl2; auto. apply FSuccCanonic; auto. simpl in |- *; auto. apply Zsucc_lt_reg; auto. rewrite <- Zsucc_pred; auto with zarith. case y; auto. intros H'6; elim H'6; intros H'7 H'8; clear H'6; apply Rlt_le. Contradict H'8; rewrite H'4. apply Zle_not_lt. replace (Fnum y) with (- Zabs (Fnum y))%Z. apply Zle_Zopp. apply pNormal_absolu_min with (3 := pGivesBound); auto. case H'1; auto. intros H'6; Contradict H'5; rewrite H'7; auto with float. apply FsubnormalFexp with (1 := H'6). rewrite Zabs_eq_opp. ring. apply R0LeFnum with (radix := radix); auto with zarith. apply Rlt_le; auto. rewrite FSuccSimpl4; auto. case FcanonicLtNeg with (p := x) (q := y) (3 := pGivesBound); auto. apply Rlt_le; auto with real. intros H'5; apply Rlt_le; auto. unfold FtoRradix in |- *; apply FcanonicNegFexpRlt with (3 := pGivesBound); auto. apply Rlt_le; auto. rewrite <- FSuccSimpl4; auto. apply R0RltRleSucc; auto. rewrite <- FSuccSimpl4; auto. apply FSuccCanonic; auto. intros H'5; elim H'5; intros H'6 H'7; clear H'5. replace y with (Float (Fnum y) (Fexp y)). rewrite H'6. generalize Fle_Zle; unfold Fle, FtoRradix in |- *; intros H'8; apply H'8; clear H'8; auto with zarith arith. case y; auto. apply Zlt_not_eq. apply Zlt_trans with 0%Z; auto with zarith. apply R0LtFnum with (radix := radix); auto with zarith. unfold pPred in |- *; apply Zlt_succ_pred. replace (Zsucc 0) with (Z_of_nat 1); [ apply (vNumbMoreThanOne radix) with (precision := precision) | simpl in |- * ]; auto with zarith. Qed. Theorem FSuccProp : forall x y : float, Fcanonic radix b x -> Fcanonic radix b y -> (x < y)%R -> (FSucc x <= y)%R. intros x y H' H'0 H'1; case (Rle_or_lt 0 x); intros H'2. apply FSuccPropPos; auto. apply FSuccPropNeg; auto. Qed. Theorem FSuccZleEq : forall p q : float, (p <= q)%R -> (q < FSucc p)%R -> (Fexp p <= Fexp q)%Z -> p = q :>R. intros p q H'. generalize (Z_eq_bool_correct (Fnum p) (pPred (vNum b))); case (Z_eq_bool (Fnum p) (pPred (vNum b))); intros H'0. rewrite FSuccSimpl1; simpl in |- *; auto with arith. intros H'1 H'2. replace p with (Fshift radix (Zabs_nat (Fexp q - Fexp p)) q). unfold FtoRradix in |- *; rewrite FshiftCorrect; auto with real. cut (Fexp (Fshift radix (Zabs_nat (Fexp q - Fexp p)) q) = Fexp p); [ intros Eq0 | idtac ]. apply floatEq; auto. apply sym_equal; apply Zeq_Zs; auto. apply Rle_Fexp_eq_Zle with (radix := radix); auto with arith. rewrite FshiftCorrect; auto. replace (Zsucc (Fnum p)) with (Fnum (Fshift radix 1 (FSucc p))); auto. apply Rlt_Fexp_eq_Zlt with (radix := radix); auto with arith. repeat rewrite FshiftCorrect; auto. rewrite FSuccSimpl1; simpl in |- *; auto with arith. unfold Fshift in |- *; simpl in |- *. rewrite FSuccSimpl1; simpl in |- *; auto with arith. rewrite inj_abs; auto with zarith. unfold Fshift in |- *; simpl in |- *. rewrite FSuccSimpl1; simpl in |- *; auto with arith. rewrite Zpower_nat_1. rewrite H'0. unfold pPred in |- *; rewrite <- Zsucc_pred. rewrite (PosNormMin radix) with (precision := precision); auto with zarith; apply Zmult_comm. unfold Fshift in |- *; simpl in |- *. rewrite inj_abs; auto with zarith. generalize (Z_eq_bool_correct (Fnum p) (- nNormMin radix precision)); case (Z_eq_bool (Fnum p) (- nNormMin radix precision)); intros H'1. generalize (Z_eq_bool_correct (Fexp p) (- dExp b)); case (Z_eq_bool (Fexp p) (- dExp b)); intros H'2. pattern p at 1 in |- *; replace p with (Float (Fnum p) (Fexp p)). rewrite H'1; rewrite H'2. rewrite FSuccSimpl3; auto with arith. intros H'3 H'4. replace p with (Fshift radix (Zabs_nat (Fexp q - Fexp p)) q). unfold FtoRradix in |- *; rewrite FshiftCorrect; auto with real. cut (Fexp (Fshift radix (Zabs_nat (Fexp q - Fexp p)) q) = Fexp p); [ intros Eq0 | idtac ]. apply floatEq; auto. apply sym_equal; apply Zeq_Zs; auto. apply Rle_Fexp_eq_Zle with (radix := radix); auto with arith. rewrite FshiftCorrect; auto. replace (Zsucc (Fnum p)) with (Fnum (FSucc p)); auto. pattern p at 2 in |- *; replace p with (Float (Fnum p) (Fexp p)). rewrite H'1; rewrite H'2. rewrite FSuccSimpl3; auto with arith. rewrite <- H'2. apply Rlt_Fexp_eq_Zlt with (radix := radix); auto with arith. rewrite FshiftCorrect; auto. rewrite H'2; auto. case p; simpl in |- *; auto. pattern p at 1 in |- *; replace p with (Float (Fnum p) (Fexp p)). rewrite H'1; rewrite H'2. rewrite FSuccSimpl3; auto with arith. case p; simpl in |- *; auto. unfold Fshift in |- *; simpl in |- *. rewrite inj_abs; auto with zarith. case p; simpl in |- *; auto. rewrite FSuccSimpl2; auto with arith. intros H'3 H'4. unfold FtoRradix in |- *; rewrite <- FshiftCorrect with (n := 1) (x := p); auto. replace (Fshift radix 1 p) with (Fshift radix (S (Zabs_nat (Fexp q - Fexp p))) q). repeat rewrite FshiftCorrect; auto with real. cut (Fexp (Fshift radix (S (Zabs_nat (Fexp q - Fexp p))) q) = Fexp (Fshift radix 1 p)); [ intros Eq0 | idtac ]. apply floatEq; auto. apply sym_equal; apply Zeq_Zs; auto. apply Rle_Fexp_eq_Zle with (radix := radix); auto with arith. repeat rewrite FshiftCorrect; auto. replace (Zsucc (Fnum (Fshift radix 1 p))) with (Fnum (FSucc p)); auto. apply Rlt_Fexp_eq_Zlt with (radix := radix); auto with arith. repeat rewrite FshiftCorrect; auto. rewrite FSuccSimpl2; auto with arith. rewrite FSuccSimpl2; auto with arith. rewrite FSuccSimpl2; auto with arith. unfold Fshift in |- *; simpl in |- *. rewrite Zpower_nat_1; auto. unfold pPred in |- *; rewrite (PosNormMin radix) with (precision := precision); auto with zarith; rewrite H'1. rewrite Zopp_mult_distr_l_reverse. rewrite (Zmult_comm radix). apply Zopp_Zpred_Zs. unfold Fshift in |- *; simpl in |- *. replace (Zpos (P_of_succ_nat (Zabs_nat (Fexp q - Fexp p)))) with (Zsucc (Fexp q - Fexp p)). unfold Zsucc, Zpred in |- *; ring. rewrite <- (inj_abs (Fexp q - Fexp p)); auto with zarith. rewrite <- inj_S; simpl in |- *; auto. rewrite inj_abs; auto with zarith. rewrite FSuccSimpl4; auto. intros H'2 H'3. replace p with (Fshift radix (Zabs_nat (Fexp q - Fexp p)) q). unfold FtoRradix in |- *; rewrite FshiftCorrect; auto with real. cut (Fexp (Fshift radix (Zabs_nat (Fexp q - Fexp p)) q) = Fexp p); [ intros Eq0 | idtac ]. apply floatEq; auto. apply sym_equal; apply Zeq_Zs; auto. apply Rle_Fexp_eq_Zle with (radix := radix); auto with arith. rewrite FshiftCorrect; auto. replace (Zsucc (Fnum p)) with (Fnum (FSucc p)); auto. rewrite FSuccSimpl4; auto. apply Rlt_Fexp_eq_Zlt with (radix := radix); auto with arith. repeat rewrite FshiftCorrect; auto. rewrite FSuccSimpl4; auto. unfold Fshift in |- *; simpl in |- *. rewrite inj_abs; auto with zarith. Qed. Definition FNSucc x := FSucc (Fnormalize radix b precision x). Theorem FNSuccCanonic : forall a : float, Fbounded b a -> Fcanonic radix b (FNSucc a). intros a H'; unfold FNSucc in |- *. apply FSuccCanonic; auto with float. Qed. Theorem FNSuccLt : forall a : float, (a < FNSucc a)%R. intros a; unfold FNSucc in |- *. unfold FtoRradix in |- *; rewrite <- (FnormalizeCorrect _ radixMoreThanOne b precision a). apply FSuccLt; auto. Qed. Theorem FNSuccProp : forall x y : float, Fbounded b x -> Fbounded b y -> (x < y)%R -> (FNSucc x <= y)%R. intros x y H' H'0 H'1; unfold FNSucc in |- *. replace (FtoRradix y) with (FtoRradix (Fnormalize radix b precision y)). apply FSuccProp; auto with float. unfold FtoRradix in |- *; repeat rewrite FnormalizeCorrect; auto. unfold FtoRradix in |- *; repeat rewrite FnormalizeCorrect; auto. Qed. Theorem FNSuccEq : forall p q : float, Fbounded b p -> Fbounded b q -> p = q :>R -> FNSucc p = FNSucc q. intros p q H' H'0 H'1; unfold FNSucc in |- *. replace (Fnormalize radix b precision p) with (Fnormalize radix b precision q); auto. apply FcanonicUnique with (radix := radix) (b := b) (precision := precision); auto with float. repeat rewrite FnormalizeCorrect; auto. Qed. End suc. Hint Resolve FSuccNormPos FBoundedSuc FSuccSubnormal FSuccNegCanonic FSuccCanonic FSuccLt FSuccPropPos R0RltRleSucc FSuccPropNeg FSuccProp FNSuccCanonic FNSuccLt: float. Section suc1. Variable b : Fbound. Variable radix : Z. Variable precision : nat. Coercion Local FtoRradix := FtoR radix. Hypothesis radixMoreThanOne : (1 < radix)%Z. Hypothesis precisionNotZero : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Theorem nNormMimLtvNum : (nNormMin radix precision < pPred (vNum b))%Z. unfold pPred in |- *; rewrite PosNormMin with (radix := radix) (precision := precision); auto with zarith. apply Zlt_le_trans with (Zpred (2 * nNormMin radix precision)). replace (Zpred (2 * nNormMin radix precision)) with (Zpred (nNormMin radix precision) + nNormMin radix precision)%Z; [ idtac | unfold Zpred in |- *; ring ]. pattern (nNormMin radix precision) at 1 in |- *; replace (nNormMin radix precision) with (0 + nNormMin radix precision)%Z; [ idtac | ring ]. apply Zplus_lt_compat_r; auto. apply Zlt_succ_pred. replace (Zsucc 0) with (Z_of_nat 1); [ idtac | simpl in |- *; auto ]. rewrite <- (Zpower_nat_O radix); unfold nNormMin in |- *. generalize precisionNotZero; case precision; simpl in |- *; auto with zarith. unfold Zpred in |- *; apply Zplus_le_compat_r. apply Zle_Zmult_comp_r; auto with float zarith. apply Zlt_le_weak; auto with zarith. apply nNormPos; auto with zarith. Qed. Theorem FSucFSucMid : forall p : float, Fnum (FSucc b radix precision p) <> nNormMin radix precision -> Fnum (FSucc b radix precision p) <> (- nNormMin radix precision)%Z -> Fminus radix (FSucc b radix precision (FSucc b radix precision p)) (FSucc b radix precision p) = Fminus radix (FSucc b radix precision p) p :>R. intros p. generalize (Z_eq_bool_correct (Fnum p) (- nNormMin radix precision)); case (Z_eq_bool (Fnum p) (- nNormMin radix precision)); intros H'1. generalize (Z_eq_bool_correct (Fexp p) (- dExp b)); case (Z_eq_bool (Fexp p) (- dExp b)); intros H'2. rewrite FSuccDiff2 with (2 := H'1); auto with arith. replace p with (Float (Fnum p) (Fexp p)). repeat (rewrite H'1; rewrite H'2). rewrite FSuccSimpl3; auto with arith. rewrite FSuccDiff1 with (2 := pGivesBound); auto with arith. simpl in |- *; auto with zarith. apply floatEq; auto. unfold FtoRradix in |- *; rewrite FSuccDiff3 with (x := p) (3 := pGivesBound); auto with arith. rewrite FSuccSimpl2; auto with arith. rewrite FSuccDiff1; simpl in |- *; auto with arith. apply Zlt_not_eq; auto. apply Zlt_Zopp; auto. apply nNormMimLtvNum; auto. unfold FtoRradix in |- *; rewrite FSuccDiff1 with (x := p); simpl in |- *; auto with arith. generalize (Z_eq_bool_correct (Fnum p) (pPred (vNum b))); case (Z_eq_bool (Fnum p) (pPred (vNum b))); intros H'2. rewrite FSuccSimpl1; simpl in |- *; auto with arith. intros H'; case H'; auto. rewrite FSuccSimpl4; simpl in |- *; auto with arith. intros H' H'0. rewrite FSuccDiff1; simpl in |- *; auto with arith. Qed. Theorem FNSuccFNSuccMid : forall p : float, Fbounded b p -> Fnum (FNSucc b radix precision p) <> nNormMin radix precision -> Fnum (FNSucc b radix precision p) <> (- nNormMin radix precision)%Z -> Fminus radix (FNSucc b radix precision (FNSucc b radix precision p)) (FNSucc b radix precision p) = Fminus radix (FNSucc b radix precision p) p :>R. intros p Fb; unfold FNSucc in |- *. intros H' H'0. rewrite FcanonicFnormalizeEq with (p := FSucc b radix precision (Fnormalize radix b precision p)); auto with float arith. rewrite FSucFSucMid; auto. unfold FtoRradix in |- *; repeat rewrite Fminus_correct; auto with float arith. rewrite FnormalizeCorrect; auto. apply Zlt_trans with 1%Z; auto with zarith. apply Zlt_trans with 1%Z; auto with zarith. Qed. End suc1. Hint Resolve nNormMimLtvNum: float. Float8.4/Faux.v0000644000423700002640000010406512032774525013150 0ustar sboldotoccata(**************************************************************************** IEEE754 : Faux Laurent Thery ***************************************************************************** Auxillary properties about natural numbers, relative numbers and reals *) Require Export Min. Require Export Arith. Require Export Reals. Require Export Zpower. Require Export ZArith. Require Export Zcomplements. Require Export sTactic. Hint Resolve R1_neq_R0: real. (*Missing rule for nat *) Theorem minus_minus : forall a b : nat, a <= b -> b - (b - a) = a. intros a b H'. apply sym_equal. apply plus_minus; auto. rewrite plus_comm; apply le_plus_minus; auto. Qed. Theorem lte_comp_mult : forall p q r t : nat, p <= q -> r <= t -> p * r <= q * t. intros p q r t H'; elim H'; simpl in |- *; auto with arith. elim p; simpl in |- *; auto with arith. intros n H m H0 H1 H2; apply plus_le_compat; auto with arith. apply le_trans with (m := r + n * r); auto with arith. Qed. Hint Resolve lte_comp_mult: arith. Theorem le_refl_eq : forall n m : nat, n = m -> n <= m. intros n m H'; rewrite H'; auto. Qed. Theorem lt_le_pred : forall n m : nat, n < m -> n <= pred m. intros n m H'; inversion H'; simpl in |- *; auto. apply le_trans with (S n); auto. Qed. Theorem lt_comp_mult_l : forall p q r : nat, 0 < p -> q < r -> p * q < p * r. intros p; elim p; simpl in |- *. auto with arith. intros n0; case n0. simpl in |- *; auto with arith. intros n1 H' q r H'0 H'1. apply lt_trans with (m := q + S n1 * r); auto with arith. Qed. Hint Resolve lt_comp_mult_l: arith. Theorem lt_comp_mult_r : forall p q r : nat, 0 < p -> q < r -> q * p < r * p. intros; repeat rewrite (fun x : nat => mult_comm x p); auto with arith. Qed. Hint Resolve lt_comp_mult_r: arith. Theorem lt_comp_mult : forall p q r s : nat, p < q -> r < s -> p * r < q * s. intros p q r s; case q. intros H'; inversion H'. intros q'; case p. intros H' H'0; simpl in |- *; apply le_lt_trans with (m := r); auto with arith. intros p' H' H'0; apply le_lt_trans with (m := S q' * r); auto with arith. Qed. Hint Resolve lt_comp_mult: arith. Theorem mult_eq_inv : forall n m p : nat, 0 < n -> n * m = n * p -> m = p. intros n m p H' H'0. apply le_antisym; auto. case (le_or_lt m p); intros H'1; auto with arith. absurd (n * p < n * m); auto with arith. rewrite H'0; auto with arith. case (le_or_lt p m); intros H'1; auto with arith. absurd (n * m < n * p); auto with arith. rewrite H'0; auto with arith. Qed. Definition natEq : forall n m : nat, {n = m} + {n <> m}. intros n; elim n. intros m; case m; auto with arith. intros n0 H' m; case m; auto with arith. Defined. Theorem notEqLt : forall n : nat, 0 < n -> n <> 0. intros n H'; Contradict H'; auto. rewrite H'; auto with arith. Qed. Hint Resolve notEqLt: arith. Theorem lt_next : forall n m : nat, n < m -> m = S n \/ S n < m. intros n m H'; elim H'; auto with arith. Qed. Theorem le_next : forall n m : nat, n <= m -> m = n \/ S n <= m. intros n m H'; case (le_lt_or_eq _ _ H'); auto with arith. Qed. Theorem min_or : forall n m : nat, min n m = n /\ n <= m \/ min n m = m /\ m < n. intros n; elim n; simpl in |- *; auto with arith. intros n' Rec m; case m; simpl in |- *; auto with arith. intros m'; elim (Rec m'); intros H'0; case H'0; clear H'0; intros H'0 H'1; rewrite H'0; auto with arith. Qed. Theorem minus_inv_lt_aux : forall n m : nat, n - m = 0 -> n - S m = 0. intros n; elim n; simpl in |- *; auto with arith. intros n0 H' m; case m; auto with arith. intros H'0; discriminate. Qed. Theorem minus_inv_lt : forall n m : nat, m <= n -> m - n = 0. intros n m H'; elim H'; simpl in |- *; auto with arith. intros m0 H'0 H'1; apply minus_inv_lt_aux; auto. Qed. Theorem minus_le : forall m n p q : nat, m <= n -> p <= q -> m - q <= n - p. intros m n p q H' H'0. case (le_or_lt m q); intros H'1. rewrite minus_inv_lt with (1 := H'1); auto with arith. apply (fun p n m : nat => plus_le_reg_l n m p) with (p := q). rewrite le_plus_minus_r; auto with arith. rewrite (le_plus_minus p q); auto. rewrite (plus_comm p). rewrite plus_assoc_reverse. rewrite le_plus_minus_r; auto with arith. apply le_trans with (1 := H'); auto with arith. apply le_trans with (1 := H'0); auto with arith. apply le_trans with (2 := H'); auto with arith. Qed. Theorem lt_minus_inv : forall n m p : nat, n <= p -> m < n -> p - n < p - m. intros n m p H'; generalize m; clear m; elim H'. intros m H'0; rewrite <- minus_n_n; elim H'0. rewrite <- minus_Sn_m; auto with arith. intros m0 H'1 H'2; rewrite <- minus_Sn_m; auto with arith. intros m H'0 H'1 m0 H'2; repeat rewrite <- minus_Sn_m; auto with arith. apply le_trans with n; auto with arith. Qed. Theorem lt_mult_anti_compatibility : forall n n1 n2 : nat, 0 < n -> n * n1 < n * n2 -> n1 < n2. intros n n1 n2 H' H'0; case (le_or_lt n2 n1); auto. intros H'1; Contradict H'0; auto. apply le_not_lt; auto with arith. Qed. Theorem le_mult_anti_compatibility : forall n n1 n2 : nat, 0 < n -> n * n1 <= n * n2 -> n1 <= n2. intros n n1 n2 H' H'0; case (le_or_lt n1 n2); auto. intros H'1; Contradict H'0; auto. apply lt_not_le; auto with arith. Qed. Theorem min_n_0 : forall n : nat, min n 0 = 0. intros n; case n; simpl in |- *; auto. Qed. (*Simplification rules missing in R *) Hint Resolve Rabs_pos: real. Theorem Rlt_Rminus_ZERO : forall r1 r2 : R, (r2 < r1)%R -> (0 < r1 - r2)%R. intros r1 r2 H; replace 0%R with (r1 - r1)%R; unfold Rminus in |- *; auto with real. Qed. Hint Resolve Rlt_Rminus_ZERO: real. Theorem Rabsolu_left1 : forall a : R, (a <= 0)%R -> Rabs a = (- a)%R. intros a H; case H; intros H1. apply Rabs_left; auto. rewrite H1; simpl in |- *; rewrite Rabs_right; auto with real. Qed. Theorem RmaxLess1 : forall r1 r2 : R, (r1 <= Rmax r1 r2)%R. intros r1 r2; unfold Rmax in |- *; case (Rle_dec r1 r2); auto with real. Qed. Theorem RmaxLess2 : forall r1 r2 : R, (r2 <= Rmax r1 r2)%R. intros r1 r2; unfold Rmax in |- *; case (Rle_dec r1 r2); auto with real; intros; apply Ropp_le_cancel; auto with real. Qed. Theorem RmaxSym : forall p q : R, Rmax p q = Rmax q p. intros p q; unfold Rmax in |- *. case (Rle_dec p q); case (Rle_dec q p); auto; intros H1 H2; apply Rle_antisym; auto. case (Rle_or_lt p q); auto; intros H'0; Contradict H1; apply Rlt_le; auto. case (Rle_or_lt q p); auto; intros H'0; Contradict H2; apply Rlt_le; auto. Qed. Theorem RmaxAbs : forall p q r : R, (p <= q)%R -> (q <= r)%R -> (Rabs q <= Rmax (Rabs p) (Rabs r))%R. intros p q r H' H'0; case (Rle_or_lt 0 p); intros H'1. repeat rewrite Rabs_right; auto with real. apply Rle_trans with r; auto with real. apply RmaxLess2; auto. apply Rge_trans with p; auto with real; apply Rge_trans with q; auto with real. apply Rge_trans with p; auto with real. rewrite (Rabs_left p); auto. case (Rle_or_lt 0 q); intros H'2. repeat rewrite Rabs_right; auto with real. apply Rle_trans with r; auto. apply RmaxLess2; auto. apply Rge_trans with q; auto with real. rewrite (Rabs_left q); auto. case (Rle_or_lt 0 r); intros H'3. repeat rewrite Rabs_right; auto with real. apply Rle_trans with (- p)%R; auto with real. apply RmaxLess1; auto. rewrite (Rabs_left r); auto. apply Rle_trans with (- p)%R; auto with real. apply RmaxLess1; auto. Qed. Theorem Rabsolu_Zabs : forall z : Z, Rabs (IZR z) = IZR (Zabs z). intros z; case z; simpl in |- *; auto with real. apply Rabs_right; auto with real. intros p0; apply Rabs_right; auto with real zarith. intros p0; rewrite Rabs_Ropp. apply Rabs_right; auto with real zarith. Qed. Theorem RmaxRmult : forall p q r : R, (0 <= r)%R -> Rmax (r * p) (r * q) = (r * Rmax p q)%R. intros p q r H; unfold Rmax in |- *. case (Rle_dec p q); case (Rle_dec (r * p) (r * q)); auto; intros H1 H2; auto. case H; intros E1. case H1; auto with real. rewrite <- E1; repeat rewrite Rmult_0_l; auto. case H; intros E1. case H2; auto with real. apply Rmult_le_reg_l with (r := r); auto. rewrite <- E1; repeat rewrite Rmult_0_l; auto. Qed. Theorem Rle_R0_Ropp : forall p : R, (p <= 0)%R -> (0 <= - p)%R. intros p H; rewrite <- Ropp_0; auto with real. Qed. Theorem Rlt_R0_Ropp : forall p : R, (p < 0)%R -> (0 < - p)%R. intros p H; rewrite <- Ropp_0; auto with real. Qed. Hint Resolve Rle_R0_Ropp Rlt_R0_Ropp: real. (* Properties of Z *) Theorem convert_not_O : forall p : positive, nat_of_P p <> 0. intros p; elim p. intros p0 H'; unfold nat_of_P in |- *; simpl in |- *; rewrite ZL6. generalize H'; case (nat_of_P p0); auto. intros p0 H'; unfold nat_of_P in |- *; simpl in |- *; rewrite ZL6. generalize H'; case (nat_of_P p0); simpl in |- *; auto. unfold nat_of_P in |- *; simpl in |- *; auto with arith. Qed. Hint Resolve convert_not_O: zarith arith. Hint Resolve Zlt_le_weak Zle_not_gt Zgt_irrefl Zlt_irrefl Zle_not_lt Zlt_not_le Zlt_asym inj_lt inj_le: zarith. Theorem inj_abs : forall x : Z, (0 <= x)%Z -> Z_of_nat (Zabs_nat x) = x. intros x; elim x; auto. unfold Zabs_nat in |- *. intros p. pattern p at 1 3 in |- *; rewrite <- (pred_o_P_of_succ_nat_o_nat_of_P_eq_id p). generalize (convert_not_O p); case (nat_of_P p); simpl in |- *; auto with arith. intros H'; case H'; auto. intros n H' H'0; rewrite Ppred_succ; auto. intros p H'; Contradict H'; auto. Qed. Theorem inject_nat_convert : forall (p : Z) (q : positive), p = Zpos q -> Z_of_nat (nat_of_P q) = p. intros p q H'; rewrite H'. CaseEq (nat_of_P q); simpl in |- *. elim q; unfold nat_of_P in |- *; simpl in |- *; intros; try discriminate. absurd (0%Z = Zpos p0); auto. red in |- *; intros H'0; try discriminate. apply H; auto. change (nat_of_P p0 = 0) in |- *. generalize H0; rewrite ZL6; case (nat_of_P p0); simpl in |- *; auto; intros; try discriminate. intros n; rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ. intros H'0; apply f_equal with (f := Zpos). apply nat_of_P_inj; auto. Qed. Hint Resolve inj_le inj_lt: zarith. Theorem ZleLe : forall x y : nat, (Z_of_nat x <= Z_of_nat y)%Z -> x <= y. intros x y H'. case (le_or_lt x y); auto with arith. intros H'0; Contradict H'0; auto with zarith. Qed. Theorem inject_nat_eq : forall x y : nat, Z_of_nat x = Z_of_nat y -> x = y. intros x y H'; apply le_antisym. apply ZleLe; auto. idtac; rewrite H'; auto with zarith. apply ZleLe; auto. idtac; rewrite H'; auto with zarith. Qed. Theorem Zcompare_EGAL : forall p q : Z, (p ?= q)%Z = Datatypes.Eq -> p = q. intros p q; case p; case q; simpl in |- *; auto with arith; try (intros; discriminate); intros q1 p1. intros H1; rewrite (Pcompare_Eq_eq p1 q1); auto. generalize (Pcompare_Eq_eq p1 q1). rewrite Pos.compare_cont_spec. case (Pos.compare p1 q1); simpl in |- *; intros H H1; try discriminate; rewrite H; auto. Qed. Theorem Zlt_Zopp : forall x y : Z, (x < y)%Z -> (- y < - x)%Z. intros x y H; omega. Qed. Hint Resolve Zlt_Zopp: zarith. Theorem Zle_Zopp : forall x y : Z, (x <= y)%Z -> (- y <= - x)%Z. intros x y H'; case (Zle_lt_or_eq _ _ H'); auto with zarith. Qed. Hint Resolve Zle_Zopp: zarith. Theorem absolu_INR : forall n : nat, Zabs_nat (Z_of_nat n) = n. intros n; case n; simpl in |- *; auto with arith. intros n0; rewrite nat_of_P_o_P_of_succ_nat_eq_succ; auto with arith. Qed. Theorem absolu_Zopp : forall p : Z, Zabs_nat (- p) = Zabs_nat p. intros p; case p; simpl in |- *; auto. Qed. Theorem Zabs_absolu : forall z : Z, Zabs z = Z_of_nat (Zabs_nat z). intros z; case z; simpl in |- *; auto; intros p; apply sym_equal; apply inject_nat_convert; auto. Qed. Theorem absolu_comp_mult : forall p q : Z, Zabs_nat (p * q) = Zabs_nat p * Zabs_nat q. intros p q; case p; case q; simpl in |- *; auto; intros p0 p1; apply ((fun (x y : positive) (_ : positive -> positive) => nat_of_P_mult_morphism x y) p1 p0 (fun x => x)). Qed. Theorem Zmin_sym : forall m n : Z, Zmin n m = Zmin m n. intros m n; apply Z.min_comm. Qed. Theorem Zpower_nat_O : forall z : Z, Zpower_nat z 0 = Z_of_nat 1. intros z; unfold Zpower_nat in |- *; simpl in |- *; auto. Qed. Theorem Zpower_nat_1 : forall z : Z, Zpower_nat z 1 = z. intros z; unfold Zpower_nat in |- *; simpl in |- *; rewrite Zmult_1_r; auto. Qed. Theorem Zmin_le1 : forall z1 z2 : Z, (z1 <= z2)%Z -> Zmin z1 z2 = z1. intros z1 z2; unfold Zle, Zmin in |- *; case (z1 ?= z2)%Z; auto; intros H; Contradict H; auto. Qed. Theorem Zmin_le2 : forall z1 z2 : Z, (z2 <= z1)%Z -> Zmin z1 z2 = z2. intros z1 z2 H; rewrite Zmin_sym; apply Zmin_le1; auto. Qed. Theorem Zmin_Zle : forall z1 z2 z3 : Z, (z1 <= z2)%Z -> (z1 <= z3)%Z -> (z1 <= Zmin z2 z3)%Z. intros z1 z2 z3 H' H'0; unfold Zmin in |- *. case (z2 ?= z3)%Z; auto. Qed. Theorem Zminus_n_predm : forall n m : Z, Zsucc (n - m) = (n - Zpred m)%Z. intros n m. unfold Zpred in |- *; unfold Zsucc in |- *; ring. Qed. Theorem Zopp_Zpred_Zs : forall z : Z, (- Zpred z)%Z = Zsucc (- z). intros z; unfold Zpred, Zsucc in |- *; ring. Qed. Theorem Zle_mult_gen : forall x y : Z, (0 <= x)%Z -> (0 <= y)%Z -> (0 <= x * y)%Z. intros x y H' H'0; case (Zle_lt_or_eq _ _ H'). intros H'1; rewrite Zmult_comm; apply Zmult_gt_0_le_0_compat; auto; apply Zlt_gt; auto. intros H'1; rewrite <- H'1; simpl in |- *; auto with zarith. Qed. Hint Resolve Zle_mult_gen: zarith. Definition Zmax : forall x_ x_ : Z, Z := fun n m : Z => match (n ?= m)%Z with | Datatypes.Eq => m | Datatypes.Lt => m | Datatypes.Gt => n end. Theorem ZmaxLe1 : forall z1 z2 : Z, (z1 <= Zmax z1 z2)%Z. intros z1 z2; unfold Zmax in |- *; CaseEq (z1 ?= z2)%Z; simpl in |- *; auto with zarith. unfold Zle in |- *; intros H; rewrite H; red in |- *; intros; discriminate. Qed. Theorem ZmaxSym : forall z1 z2 : Z, Zmax z1 z2 = Zmax z2 z1. intros z1 z2; unfold Zmax in |- *; CaseEq (z1 ?= z2)%Z; CaseEq (z2 ?= z1)%Z; intros H1 H2; try case (Zcompare_EGAL _ _ H1); auto; try case (Zcompare_EGAL _ _ H2); auto; Contradict H1. case (Zcompare.Zcompare_Gt_Lt_antisym z2 z1); auto. intros H' H'0; rewrite H'0; auto; red in |- *; intros; discriminate. case (Zcompare.Zcompare_Gt_Lt_antisym z1 z2); auto. intros H'; rewrite H'; auto; intros; red in |- *; intros; discriminate. Qed. Theorem Zmax_le2 : forall z1 z2 : Z, (z1 <= z2)%Z -> Zmax z1 z2 = z2. intros z1 z2; unfold Zle, Zmax in |- *; case (z1 ?= z2)%Z; auto. intros H'; case H'; auto. Qed. Theorem Zmax_le1 : forall z1 z2 : Z, (z2 <= z1)%Z -> Zmax z1 z2 = z1. intros z1 z2 H'; rewrite ZmaxSym; apply Zmax_le2; auto. Qed. Theorem ZmaxLe2 : forall z1 z2 : Z, (z2 <= Zmax z1 z2)%Z. intros z1 z2; rewrite ZmaxSym; apply ZmaxLe1. Qed. Hint Resolve ZmaxLe1 ZmaxLe2: zarith. Theorem Zeq_Zs : forall p q : Z, (p <= q)%Z -> (q < Zsucc p)%Z -> p = q. intros p q H' H'0; apply Zle_antisym; auto. apply Zlt_succ_le; auto. Qed. Theorem Zmin_Zmax : forall z1 z2 : Z, (Zmin z1 z2 <= Zmax z1 z2)%Z. intros z1 z2; case (Zle_or_lt z1 z2); unfold Zle, Zlt, Zmin, Zmax in |- *; CaseEq (z1 ?= z2)%Z; auto; intros H1 H2; try rewrite H1; try rewrite H2; red in |- *; intros; discriminate. Qed. Theorem Zabs_Zmult : forall z1 z2 : Z, Zabs (z1 * z2) = (Zabs z1 * Zabs z2)%Z. intros z1 z2; case z1; case z2; simpl in |- *; auto with zarith. Qed. Theorem Zle_Zmult_comp_r : forall x y z : Z, (0 <= z)%Z -> (x <= y)%Z -> (x * z <= y * z)%Z. intros x y z H' H'0; case (Zle_lt_or_eq _ _ H'); intros Zlt1. apply Zmult_gt_0_le_compat_r; auto. apply Zlt_gt; auto. rewrite <- Zlt1; repeat rewrite <- Zmult_0_r_reverse; auto with zarith. Qed. Theorem Zle_Zmult_comp_l : forall x y z : Z, (0 <= z)%Z -> (x <= y)%Z -> (z * x <= z * y)%Z. intros x y z H' H'0; repeat rewrite (Zmult_comm z); apply Zle_Zmult_comp_r; auto. Qed. Theorem NotZmultZero : forall z1 z2 : Z, z1 <> 0%Z -> z2 <> 0%Z -> (z1 * z2)%Z <> 0%Z. intros z1 z2; case z1; case z2; simpl in |- *; intros; auto; try discriminate. Qed. Hint Resolve NotZmultZero: zarith. (* Conversions from R <-> Z <-> N *) Theorem IZR_zero : forall p : Z, p = 0%Z -> IZR p = 0%R. intros p H'; rewrite H'; auto. Qed. Hint Resolve not_O_INR: real. Theorem IZR_zero_r : forall p : Z, IZR p = 0%R -> p = 0%Z. intros p; case p; simpl in |- *; auto. intros p1 H'; Contradict H'; auto with real zarith. intros p1 H'; absurd (INR (nat_of_P p1) = 0%R); auto with real zarith. rewrite <- (Ropp_involutive (INR (nat_of_P p1))). rewrite H'; auto with real. Qed. Theorem INR_lt_nm : forall n m : nat, n < m -> (INR n < INR m)%R. intros n m H'; elim H'; auto. replace (INR n) with (INR n + 0)%R; auto with real; rewrite S_INR; auto with real. intros m0 H'0 H'1. replace (INR n) with (INR n + 0)%R; auto with real; rewrite S_INR; auto with real. Qed. Hint Resolve INR_lt_nm: real. Theorem Rlt_INR1 : forall n : nat, 1 < n -> (1 < INR n)%R. replace 1%R with (INR 1); auto with real. Qed. Hint Resolve Rlt_INR1: real. Theorem NEq_INR : forall n m : nat, n <> m -> INR n <> INR m. intros n m H'; (case (le_or_lt n m); intros H'1). case (le_lt_or_eq _ _ H'1); intros H'2. apply Rlt_dichotomy_converse; auto with real. Contradict H'; auto. apply Compare.not_eq_sym; apply Rlt_dichotomy_converse; auto with real. Qed. Hint Resolve NEq_INR: real. Theorem NEq_INRO : forall n : nat, n <> 0 -> INR n <> 0%R. replace 0%R with (INR 0); auto with real. Qed. Hint Resolve NEq_INRO: real. Theorem NEq_INR1 : forall n : nat, n <> 1 -> INR n <> 1%R. replace 1%R with (INR 1); auto with real. Qed. Hint Resolve NEq_INR1: real. Theorem not_O_lt : forall n : nat, n <> 0 -> 0 < n. intros n; elim n; simpl in |- *; auto with arith. Qed. Hint Resolve not_O_lt: arith. Theorem NEq_IZRO : forall n : Z, n <> 0%Z -> IZR n <> 0%R. intros n H; Contradict H. apply IZR_zero_r; auto. Qed. Hint Resolve NEq_IZRO: real. Theorem Rlt_IZR : forall p q : Z, (p < q)%Z -> (IZR p < IZR q)%R. intros p q H; case (Rle_or_lt (IZR q) (IZR p)); auto. intros H1; Contradict H; apply Zle_not_lt. apply le_IZR; auto. Qed. Hint Resolve Rlt_IZR: real. Theorem Rle_IZR : forall x y : Z, (x <= y)%Z -> (IZR x <= IZR y)%R. intros x y H'. case (Zle_lt_or_eq _ _ H'); clear H'; intros H'. apply Rlt_le; auto with real. rewrite <- H'; auto with real. Qed. Hint Resolve Rle_IZR: real. Theorem Rlt_IZRO : forall p : Z, (0 < p)%Z -> (0 < IZR p)%R. intros p H; replace 0%R with (IZR 0); auto with real. Qed. Hint Resolve Rlt_IZRO: real. Theorem Rle_IZRO : forall x y : Z, (0 <= y)%Z -> (0 <= IZR y)%R. intros; replace 0%R with (IZR 0); auto with real. Qed. Hint Resolve Rle_IZRO: real. Theorem Rlt_IZR1 : forall p q : Z, (1 < q)%Z -> (1 < IZR q)%R. intros; replace 1%R with (IZR 1); auto with real. Qed. Hint Resolve Rlt_IZR1: real. Theorem Rle_IZR1 : forall x y : Z, (1 <= y)%Z -> (1 <= IZR y)%R. intros; replace 1%R with (IZR 1); auto with real. Qed. Hint Resolve Rle_IZR1: real. Theorem lt_Rlt : forall n m : nat, (INR n < INR m)%R -> n < m. intros n m H'; case (le_or_lt m n); auto; intros H0; Contradict H'; auto with real. case (le_lt_or_eq _ _ H0); intros H1; auto with real. rewrite H1; apply Rlt_irrefl. Qed. Theorem INR_inv : forall n m : nat, INR n = INR m -> n = m. intros n; elim n; auto; try rewrite S_INR. intros m; case m; auto. intros m' H1; Contradict H1; auto. rewrite S_INR. apply Rlt_dichotomy_converse; left. apply Rle_lt_0_plus_1. apply pos_INR. intros n' H' m; case m. intros H'0; Contradict H'0; auto. rewrite S_INR. apply Rlt_dichotomy_converse; right. red in |- *; apply Rle_lt_0_plus_1. apply pos_INR. intros m' H'0. rewrite (H' m'); auto. repeat rewrite S_INR in H'0. apply Rplus_eq_reg_l with (r := 1%R); repeat rewrite (Rplus_comm 1); auto with real. Qed. Theorem Rle_INR : forall x y : nat, x <= y -> (INR x <= INR y)%R. intros x y H; repeat rewrite INR_IZR_INZ. apply Rle_IZR; auto with zarith. Qed. Hint Resolve Rle_INR: real. Theorem le_Rle : forall n m : nat, (INR n <= INR m)%R -> n <= m. intros n m H'; case H'; auto. intros H'0; apply lt_le_weak; apply lt_Rlt; auto. intros H'0; rewrite <- (INR_inv _ _ H'0); auto with arith. Qed. Theorem Rmult_IZR : forall z t : Z, IZR (z * t) = (IZR z * IZR t)%R. intros z t; case z; case t; simpl in |- *; auto with real. intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real. intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real. rewrite Rmult_comm. rewrite Ropp_mult_distr_l_reverse; auto with real. apply Ropp_eq_compat; rewrite mult_comm; auto with real. intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real. rewrite Ropp_mult_distr_l_reverse; auto with real. intros t1 z1; rewrite nat_of_P_mult_morphism; auto with real. rewrite Rmult_opp_opp; auto with real. Qed. Theorem absolu_Zs : forall z : Z, (0 <= z)%Z -> Zabs_nat (Zsucc z) = S (Zabs_nat z). intros z; case z. 3: intros p H'; Contradict H'; auto with zarith. replace (Zsucc 0) with (Z_of_nat 1). intros H'; rewrite absolu_INR; simpl in |- *; auto. simpl in |- *; auto. intros p H'; rewrite <- Zpos_succ_morphism; simpl in |- *; auto with zarith. unfold nat_of_P in |- *; rewrite Pmult_nat_succ_morphism; auto. Qed. Hint Resolve Zlt_le_succ: zarith. Theorem Zlt_next : forall n m : Z, (n < m)%Z -> m = Zsucc n \/ (Zsucc n < m)%Z. intros n m H'; case (Zle_lt_or_eq (Zsucc n) m); auto with zarith. Qed. Theorem Zle_next : forall n m : Z, (n <= m)%Z -> m = n \/ (Zsucc n <= m)%Z. intros n m H'; case (Zle_lt_or_eq _ _ H'); auto with zarith. Qed. Theorem Zlt_Zopp_Inv : forall p q : Z, (- p < - q)%Z -> (q < p)%Z. intros x y H'; case (Zle_or_lt x y); auto with zarith. Qed. Theorem Zle_Zopp_Inv : forall p q : Z, (- p <= - q)%Z -> (q <= p)%Z. intros p q H'; case (Zle_lt_or_eq _ _ H'); auto with zarith. Qed. Theorem absolu_Zs_neg : forall z : Z, (z < 0)%Z -> S (Zabs_nat (Zsucc z)) = Zabs_nat z. intros z H'; apply inject_nat_eq. rewrite inj_S. repeat rewrite <- (absolu_Zopp (Zsucc z)). repeat rewrite <- (absolu_Zopp z). repeat rewrite inj_abs; replace 0%Z with (- (0))%Z; auto with zarith. Qed. Theorem Zlt_absolu : forall (x : Z) (n : nat), Zabs_nat x < n -> (x < Z_of_nat n)%Z. intros x n; case x; simpl in |- *; auto with zarith. replace 0%Z with (Z_of_nat 0); auto with zarith. intros p; rewrite <- (inject_nat_convert (Zpos p) p); auto with zarith. case n; simpl in |- *; intros; red in |- *; simpl in |- *; auto. Qed. Theorem inj_pred : forall n : nat, n <> 0 -> Z_of_nat (pred n) = Zpred (Z_of_nat n). intros n; case n; auto. intros H'; Contradict H'; auto. intros n0 H'; rewrite inj_S; rewrite <- Zpred_succ; auto. Qed. Theorem Zle_abs : forall p : Z, (p <= Z_of_nat (Zabs_nat p))%Z. intros p; case p; simpl in |- *; auto with zarith; intros q; rewrite inject_nat_convert with (p := Zpos q); auto with zarith. unfold Zle in |- *; red in |- *; intros H'2; discriminate. Qed. Hint Resolve Zle_abs: zarith. Theorem ZleAbs : forall (z : Z) (n : nat), (- Z_of_nat n <= z)%Z -> (z <= Z_of_nat n)%Z -> Zabs_nat z <= n. intros z n H' H'0; case (le_or_lt (Zabs_nat z) n); auto; intros lt. case (Zle_or_lt 0 z); intros Zle0. absurd ((z <= Z_of_nat n)%Z); auto. apply Zlt_not_le; auto. rewrite <- (inj_abs z); auto with zarith. absurd ((- Z_of_nat n <= z)%Z); trivial. apply Zlt_not_le; auto. replace z with (- Z_of_nat (Zabs_nat z))%Z. apply Zlt_Zopp; auto with zarith. rewrite <- absolu_Zopp. rewrite inj_abs; auto with zarith. Qed. Theorem lt_Zlt_inv : forall n m : nat, (Z_of_nat n < Z_of_nat m)%Z -> n < m. intros n m H'; case (le_or_lt n m); auto. intros H'0. case (le_lt_or_eq _ _ H'0); auto with zarith. intros H'1. Contradict H'. apply Zle_not_lt; auto with zarith. Qed. Theorem NconvertO : forall p : positive, nat_of_P p <> 0. intros p; elim p; unfold nat_of_P in |- *; simpl in |- *. intros p0 H'; red in |- *; intros H'0; discriminate. intros p0; rewrite ZL6; unfold nat_of_P in |- *. case (Pmult_nat p0 1); simpl in |- *; auto. red in |- *; intros H'; discriminate. Qed. Hint Resolve NconvertO: zarith. Theorem absolu_lt_nz : forall z : Z, z <> 0%Z -> 0 < Zabs_nat z. intros z; case z; simpl in |- *; auto; try (intros H'; case H'; auto; fail); intros p; generalize (NconvertO p); auto with arith. Qed. Theorem Rlt2 : (0 < INR 2)%R. replace 0%R with (INR 0); auto with real arith. Qed. Hint Resolve Rlt2: real. Theorem RlIt2 : (0 < / INR 2)%R. apply Rmult_lt_reg_l with (r := INR 2); auto with real. Qed. Hint Resolve RlIt2: real. Theorem Rledouble : forall r : R, (0 <= r)%R -> (r <= INR 2 * r)%R. intros r H'. replace (INR 2 * r)%R with (r + r)%R; [ idtac | simpl in |- *; ring ]. pattern r at 1 in |- *; replace r with (r + 0)%R; [ idtac | ring ]. apply Rplus_le_compat_l; auto. Qed. Theorem Rltdouble : forall r : R, (0 < r)%R -> (r < INR 2 * r)%R. intros r H'. pattern r at 1 in |- *; replace r with (r + 0)%R; try ring. replace (INR 2 * r)%R with (r + r)%R; simpl in |- *; try ring; auto with real. Qed. Theorem Rlt_RinvDouble : forall r : R, (0 < r)%R -> (/ INR 2 * r < r)%R. intros r H'. apply Rmult_lt_reg_l with (r := INR 2); auto with real. rewrite <- Rmult_assoc; rewrite Rinv_r. apply Rmult_lt_compat_r; replace 1%R with (INR 1); auto with real arith. replace 0%R with (INR 0); auto with real arith. Qed. Hint Resolve Rledouble: real. Theorem Rle_Rinv : forall x y : R, (0 < x)%R -> (x <= y)%R -> (/ y <= / x)%R. intros x y H H1; case H1; intros H2. left; apply Rinv_lt_contravar; auto. apply Rmult_lt_0_compat; auto. apply Rlt_trans with (2 := H2); auto. rewrite H2; auto with real. Qed. Theorem Int_part_INR : forall n : nat, Int_part (INR n) = Z_of_nat n. intros n; unfold Int_part in |- *. cut (up (INR n) = (Z_of_nat n + Z_of_nat 1)%Z). intros H'; rewrite H'; simpl in |- *; ring. apply sym_equal; apply tech_up; auto. replace (Z_of_nat n + Z_of_nat 1)%Z with (Z_of_nat (S n)). repeat rewrite <- INR_IZR_INZ. apply INR_lt_nm; auto. rewrite Zplus_comm; rewrite <- inj_plus; simpl in |- *; auto. rewrite plus_IZR; simpl in |- *; auto with real. repeat rewrite <- INR_IZR_INZ; auto with real. Qed. Theorem Int_part_IZR : forall z : Z, Int_part (IZR z) = z. intros z; unfold Int_part in |- *. cut (up (IZR z) = (z + 1)%Z). intros Z1; rewrite Z1; rewrite Zplus_comm; apply Zminus_plus; auto with zarith. apply sym_equal; apply tech_up; simpl in |- *; auto with real zarith. replace (IZR z) with (IZR z + IZR 0)%R; try rewrite plus_IZR; auto with real zarith. Qed. Theorem Zlt_Rlt : forall z1 z2 : Z, (IZR z1 < IZR z2)%R -> (z1 < z2)%Z. intros z1 z2 H; case (Zle_or_lt z2 z1); auto. intros H1; Contradict H; auto with real zarith. apply Rle_not_lt; auto with real zarith. Qed. Theorem Zle_Rle : forall z1 z2 : Z, (IZR z1 <= IZR z2)%R -> (z1 <= z2)%Z. intros z1 z2 H; case (Zle_or_lt z1 z2); auto. intros H1; Contradict H; auto with real zarith. apply Rlt_not_le; auto with real zarith. Qed. Theorem IZR_inv : forall z1 z2 : Z, IZR z1 = IZR z2 :>R -> z1 = z2. intros z1 z2 H; apply Zle_antisym; apply Zle_Rle; rewrite H; auto with real. Qed. Theorem Zabs_eq_opp : forall x, (x <= 0)%Z -> Zabs x = (- x)%Z. intros x; case x; simpl in |- *; auto. intros p H; Contradict H; auto with zarith. Qed. Theorem Zabs_Zs : forall z : Z, (Zabs (Zsucc z) <= Zsucc (Zabs z))%Z. intros z; case z; auto. simpl in |- *; auto with zarith. repeat rewrite Zabs_eq; auto with zarith. intros p; rewrite Zabs_eq_opp; auto with zarith. 2: unfold Zsucc in |- *; replace 0%Z with (-1 + 1)%Z; auto with zarith. 2: case p; simpl in |- *; intros; red in |- *; simpl in |- *; intros; red in |- *; intros; discriminate. replace (- Zsucc (Zneg p))%Z with (Zpos p - 1)%Z. replace (Zsucc (Zabs (Zneg p))) with (Zpos p + 1)%Z; auto with zarith. unfold Zsucc in |- *; rewrite Zopp_plus_distr. auto with zarith. Qed. Hint Resolve Zabs_Zs: zarith. Theorem Zle_Zpred : forall x y : Z, (x < y)%Z -> (x <= Zpred y)%Z. intros x y H; apply Zlt_succ_le. rewrite <- Zsucc_pred; auto. Qed. Hint Resolve Zle_Zpred: zarith. Theorem Zabs_Zopp : forall z : Z, Zabs (- z) = Zabs z. intros z; case z; simpl in |- *; auto. Qed. Theorem Zle_Zabs : forall z : Z, (z <= Zabs z)%Z. intros z; case z; simpl in |- *; red in |- *; simpl in |- *; auto; try (red in |- *; intros; discriminate; fail). intros p; elim p; simpl in |- *; auto; try (red in |- *; intros; discriminate; fail). Qed. Hint Resolve Zle_Zabs: zarith. Theorem Zlt_mult_simpl_l : forall a b c : Z, (0 < c)%Z -> (c * a < c * b)%Z -> (a < b)%Z. intros a b0 c H H0; apply Zgt_lt. apply Zmult_gt_reg_r with (p := c); try apply Zlt_gt; auto with zarith. repeat rewrite (fun x => Zmult_comm x c); auto with zarith. Qed. (* An equality function on Z that return a bool *) Fixpoint pos_eq_bool (a b : positive) {struct b} : bool := match a, b with | xH, xH => true | xI a', xI b' => pos_eq_bool a' b' | xO a', xO b' => pos_eq_bool a' b' | _, _ => false end. Theorem pos_eq_bool_correct : forall p q : positive, match pos_eq_bool p q with | true => p = q | false => p <> q end. intros p q; generalize p; elim q; simpl in |- *; auto; clear p q. intros p Rec q; case q; simpl in |- *; try (intros; red in |- *; intros; discriminate; fail). intros q'; generalize (Rec q'); case (pos_eq_bool q' p); simpl in |- *; auto. intros H1; rewrite H1; auto. intros H1; Contradict H1; injection H1; auto. intros p Rec q; case q; simpl in |- *; try (intros; red in |- *; intros; discriminate; fail). intros q'; generalize (Rec q'); case (pos_eq_bool q' p); simpl in |- *; auto. intros H1; rewrite H1; auto. intros H1; Contradict H1; injection H1; auto. intros q; case q; simpl in |- *; try (intros; red in |- *; intros; discriminate; fail); auto. Qed. Theorem Z_O_1 : (0 < 1)%Z. red in |- *; simpl in |- *; auto; intros; red in |- *; intros; discriminate. Qed. Hint Resolve Z_O_1: zarith. Definition Z_eq_bool a b := match a, b with | Z0, Z0 => true | Zpos a', Zpos b' => pos_eq_bool a' b' | Zneg a', Zneg b' => pos_eq_bool a' b' | _, _ => false end. Theorem Z_eq_bool_correct : forall p q : Z, match Z_eq_bool p q with | true => p = q | false => p <> q end. intros p q; case p; case q; simpl in |- *; auto; try (intros; red in |- *; intros; discriminate; fail). intros p' q'; generalize (pos_eq_bool_correct q' p'); case (pos_eq_bool q' p'); simpl in |- *; auto. intros H1; rewrite H1; auto. intros H1; Contradict H1; injection H1; auto. intros p' q'; generalize (pos_eq_bool_correct q' p'); case (pos_eq_bool q' p'); simpl in |- *; auto. intros H1; rewrite H1; auto. intros H1; Contradict H1; injection H1; auto. Qed. Theorem Zlt_mult_ZERO : forall x y : Z, (0 < x)%Z -> (0 < y)%Z -> (0 < x * y)%Z. intros x y; case x; case y; unfold Zlt in |- *; simpl in |- *; auto. Qed. Hint Resolve Zlt_mult_ZERO: zarith. Theorem Zlt_Zminus_ZERO : forall z1 z2 : Z, (z2 < z1)%Z -> (0 < z1 - z2)%Z. intros z1 z2; rewrite (Zminus_diag_reverse z2); auto with zarith. Qed. Theorem Zle_Zminus_ZERO : forall z1 z2 : Z, (z2 <= z1)%Z -> (0 <= z1 - z2)%Z. intros z1 z2; rewrite (Zminus_diag_reverse z2); auto with zarith. Qed. Hint Resolve Zle_Zminus_ZERO Zlt_Zminus_ZERO: zarith. Theorem Zle_Zpred_Zpred : forall z1 z2 : Z, (z1 <= z2)%Z -> (Zpred z1 <= Zpred z2)%Z. intros z1 z2 H; apply Zsucc_le_reg. repeat rewrite <- Zsucc_pred; auto. Qed. Hint Resolve Zle_Zpred_Zpred: zarith. Theorem Zle_ZERO_Zabs : forall z : Z, (0 <= Zabs z)%Z. intros z; case z; simpl in |- *; auto with zarith. Qed. Hint Resolve Zle_ZERO_Zabs: zarith. Theorem Zlt_Zabs_inv1 : forall z1 z2 : Z, (Zabs z1 < z2)%Z -> (- z2 < z1)%Z. intros z1 z2 H; case (Zle_or_lt 0 z1); intros H1. apply Zlt_le_trans with (- (0))%Z; auto with zarith. apply Zlt_Zopp; apply Zle_lt_trans with (2 := H); auto with zarith. rewrite <- (Zopp_involutive z1); rewrite <- (Zabs_eq_opp z1); auto with zarith. Qed. Theorem Zlt_Zabs_inv2 : forall z1 z2 : Z, (Zabs z1 < Zabs z2)%Z -> (z1 < Zabs z2)%Z. intros z1 z2; case z1; case z2; simpl in |- *; auto with zarith. Qed. Theorem Zle_Zabs_inv1 : forall z1 z2 : Z, (Zabs z1 <= z2)%Z -> (- z2 <= z1)%Z. intros z1 z2 H; case (Zle_or_lt 0 z1); intros H1. apply Zle_trans with (- (0))%Z; auto with zarith. apply Zle_Zopp; apply Zle_trans with (2 := H); auto with zarith. rewrite <- (Zopp_involutive z1); rewrite <- (Zabs_eq_opp z1); auto with zarith. Qed. Theorem Zle_Zabs_inv2 : forall z1 z2 : Z, (Zabs z1 <= z2)%Z -> (z1 <= z2)%Z. intros z1 z2 H; case (Zle_or_lt 0 z1); intros H1. rewrite <- (Zabs_eq z1); auto. apply Zle_trans with (Zabs z1); auto with zarith. Qed. Theorem Zlt_Zabs_Zpred : forall z1 z2 : Z, (Zabs z1 < z2)%Z -> z1 <> Zpred z2 -> (Zabs (Zsucc z1) < z2)%Z. intros z1 z2 H H0; case (Zle_or_lt 0 z1); intros H1. rewrite Zabs_eq; auto with zarith. rewrite Zabs_eq in H; auto with zarith. apply Zlt_trans with (2 := H). repeat rewrite Zabs_eq_opp; auto with zarith. Qed. Theorem Zle_n_Zpred : forall z1 z2 : Z, (Zpred z1 <= Zpred z2)%Z -> (z1 <= z2)%Z. intros z1 z2 H; rewrite (Zsucc_pred z1); rewrite (Zsucc_pred z2); auto with zarith. Qed. Theorem Zpred_Zopp_Zs : forall z : Z, Zpred (- z) = (- Zsucc z)%Z. intros z; unfold Zpred, Zsucc in |- *; ring. Qed. Theorem Zlt_1_O : forall z : Z, (1 <= z)%Z -> (0 < z)%Z. intros z H; apply Zsucc_lt_reg; simpl in |- *; auto with zarith. Qed. Hint Resolve Zlt_succ Zsucc_lt_compat Zle_lt_succ: zarith. Theorem Zlt_not_eq : forall p q : Z, (p < q)%Z -> p <> q. intros p q H; Contradict H; rewrite H; auto with zarith. Qed. Theorem Zlt_not_eq_rev : forall p q : Z, (q < p)%Z -> p <> q. intros p q H; Contradict H; rewrite H; auto with zarith. Qed. Hint Resolve Zlt_not_eq Zlt_not_eq_rev: zarith. Theorem Zle_Zpred_Zlt : forall z1 z2 : Z, (z1 <= z2)%Z -> (Zpred z1 < z2)%Z. intros z1 z2 H; apply Zsucc_lt_reg; rewrite <- Zsucc_pred; auto with zarith. Qed. Hint Resolve Zle_Zpred_Zlt: zarith. Theorem Zle_Zpred_inv : forall z1 z2 : Z, (z1 <= Zpred z2)%Z -> (z1 < z2)%Z. intros z1 z2 H; rewrite (Zsucc_pred z2); auto with zarith. Qed. Theorem Zabs_intro : forall (P : Z -> Prop) (z : Z), P (- z)%Z -> P z -> P (Zabs z). intros P z; case z; simpl in |- *; auto. Qed. Theorem Zpred_Zle_Zabs_intro : forall z1 z2 : Z, (- Zpred z2 <= z1)%Z -> (z1 <= Zpred z2)%Z -> (Zabs z1 < z2)%Z. intros z1 z2 H H0; apply Zle_Zpred_inv. apply Zabs_intro with (P := fun x => (x <= Zpred z2)%Z); auto with zarith. Qed. Theorem Zlt_ZERO_Zle_ONE : forall z : Z, (0 < z)%Z -> (1 <= z)%Z. intros z H; replace 1%Z with (Zsucc 0); auto with zarith; simpl in |- *; auto. Qed. Hint Resolve Zlt_ZERO_Zle_ONE: zarith. Theorem ptonat_def1 : forall p q, 1 < Pmult_nat p (S (S q)). intros p; elim p; simpl in |- *; auto with arith. Qed. Hint Resolve ptonat_def1: arith. Theorem lt_S_le : forall p q, p < q -> S p <= q. intros p q; unfold lt in |- *; simpl in |- *; auto. Qed. Hint Resolve lt_S_le: arith. Theorem Zlt_Zabs_intro : forall z1 z2 : Z, (- z2 < z1)%Z -> (z1 < z2)%Z -> (Zabs z1 < z2)%Z. intros z1 z2; case z1; case z2; simpl in |- *; auto with zarith. intros p p0 H H0; change (- Zneg p0 < - Zneg p)%Z in |- *; auto with zarith. Qed. Float8.4/Fbound.v0000644000423700002640000002735512032774525013470 0ustar sboldotoccata(**************************************************************************** IEEE754 : Fbound Laurent Thery ******************************************************************************) Require Export Fop. Section Fbounded_Def. Variable radix : Z. Hypothesis radixMoreThanOne : (1 < radix)%Z. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Coercion Local FtoRradix := FtoR radix. Coercion Z_of_N: N >-> Z. Record Fbound : Set := Bound {vNum : positive; dExp : N}. Definition Fbounded (b : Fbound) (d : float) := (Zabs (Fnum d) < Zpos (vNum b))%Z /\ (- dExp b <= Fexp d)%Z. Theorem FboundedNum : forall (b : Fbound) (p : float), Fbounded b p -> (Zabs (Fnum p) < Zpos (vNum b))%Z. intros b p H; case H; intros H1 H2; case H1; auto. Qed. Theorem FboundedExp : forall (b : Fbound) (p : float), Fbounded b p -> (- dExp b <= Fexp p)%Z. intros b p H; case H; auto. Qed. Hint Resolve FboundedNum FboundedExp: float. Theorem isBounded : forall (b : Fbound) (p : float), {Fbounded b p} + {~ Fbounded b p}. intros b p; case (Z_le_gt_dec (Zpos (vNum b)) (Zabs (Fnum p))); intros H'. right; red in |- *; intros H'3. absurd ((Zpos (vNum b) <= Zabs (Fnum p))%Z); auto with zarith float. case (Z_le_gt_dec (- dExp b) (Fexp p)); intros H'1. left; repeat split; auto with zarith. right; red in |- *; intros H'3; Contradict H'1; auto with float zarith. Qed. Theorem FzeroisZero : forall b : Fbound, Fzero (- dExp b) = 0%R :>R. intros b; unfold FtoRradix, FtoR in |- *; simpl in |- *; auto with real. Qed. Theorem FboundedFzero : forall b : Fbound, Fbounded b (Fzero (- dExp b)). intros b; repeat (split; simpl in |- *). replace 0%Z with (- 0%nat)%Z; [ idtac | simpl in |- *; auto ]. apply Zeq_le; auto with arith. Qed. Hint Unfold Fbounded. Theorem FboundedZeroSameExp : forall (b : Fbound) (p : float), Fbounded b p -> Fbounded b (Fzero (Fexp p)). intros b p H'; (repeat split; simpl in |- *; auto with float zarith). Qed. Theorem FBoundedScale : forall (b : Fbound) (p : float) (n : nat), Fbounded b p -> Fbounded b (Float (Fnum p) (Fexp p + n)). intros b p n H'; repeat split; simpl in |- *; auto with float. apply Zle_trans with (Fexp p); auto with float. pattern (Fexp p) at 1 in |- *; (replace (Fexp p) with (Fexp p + 0%nat)%Z; [ idtac | simpl in |- *; ring ]). apply Zplus_le_compat_l. apply inj_le; auto with arith. Qed. Theorem FvalScale : forall (b : Fbound) (p : float) (n : nat), Float (Fnum p) (Fexp p + n) = (powerRZ radix n * p)%R :>R. intros b p n; unfold FtoRradix, FtoR in |- *; simpl in |- *. rewrite powerRZ_add; auto with real zarith. ring. Qed. Theorem oppBounded : forall (b : Fbound) (x : float), Fbounded b x -> Fbounded b (Fopp x). intros b x H'; repeat split; simpl in |- *; auto with float zarith. replace (Zabs (- Fnum x)) with (Zabs (Fnum x)); auto with float. case (Fnum x); simpl in |- *; auto. Qed. Theorem oppBoundedInv : forall (b : Fbound) (x : float), Fbounded b (Fopp x) -> Fbounded b x. intros b x H'; rewrite <- (Fopp_Fopp x). apply oppBounded; auto. Qed. Theorem FopRepAux : forall (b : Fbound) (z : Z) (p : R), ex (fun r : float => r = (- p)%R :>R /\ Fbounded b r /\ Fexp r = z) -> ex (fun r : float => r = p :>R /\ Fbounded b r /\ Fexp r = z). intros b z p H'; elim H'; intros r E; elim E; intros H'0 H'1; elim H'1; intros H'2 H'3; clear H'1 E H'. exists (Fopp r); split; auto. rewrite <- (Ropp_involutive p). rewrite <- H'0; auto. unfold FtoRradix in |- *; apply Fopp_correct; auto. split. apply oppBounded; auto. simpl in |- *; auto. Qed. Theorem absFBounded : forall (b : Fbound) (f : float), Fbounded b f -> Fbounded b (Fabs f). intros b f H'; repeat split; simpl in |- *; auto with float. replace (Zabs (Zabs (Fnum f))) with (Zabs (Fnum f)); auto with float. case (Fnum f); auto. Qed. Theorem FboundedEqExpPos : forall (b : Fbound) (p q : float), Fbounded b p -> p = q :>R -> (Fexp p <= Fexp q)%R -> (0 <= q)%R -> Fbounded b q. intros b p q H' H'0 H'1 H'2. cut (0 <= Fnum p)%Z; [ intros Z1 | apply (LeR0Fnum radix); auto with real arith; fold FtoRradix in |- *; rewrite H'0; auto ]. cut (0 <= Fnum q)%Z; [ intros Z2 | apply (LeR0Fnum radix); auto with real arith ]. split. apply Zle_lt_trans with (Zabs (Fnum p)); [ idtac | auto with float ]. repeat rewrite Zabs_eq; auto. apply Zle_trans with (Fnum (Fshift radix (Zabs_nat (Fexp q - Fexp p)) q)); auto. unfold Fshift in |- *; simpl in |- *; auto. pattern (Fnum q) at 1 in |- *; replace (Fnum q) with (Fnum q * 1)%Z; auto with zarith. apply (Rle_Fexp_eq_Zle radix); auto with real zarith. rewrite FshiftCorrect; auto with real zarith. unfold Fshift in |- *; simpl in |- *; rewrite inj_abs; try ring. apply Zle_Zminus_ZERO; apply le_IZR; auto with real arith. apply Zle_trans with (Fexp p). case H'; auto. apply le_IZR; auto with real arith. Qed. Theorem FboundedEqExp : forall (b : Fbound) (p q : float), Fbounded b p -> p = q :>R -> (Fexp p <= Fexp q)%R -> Fbounded b q. intros b p q H' H'0 H'1; split. apply Zle_lt_trans with (Zabs (Fnum p)); [ idtac | auto with float ]. apply Zle_trans with (Zabs (Fnum (Fshift radix (Zabs_nat (Fexp q - Fexp p)) q))); auto. unfold Fshift in |- *; simpl in |- *; auto. rewrite Zabs_Zmult. pattern (Zabs (Fnum q)) at 1 in |- *; replace (Zabs (Fnum q)) with (Zabs (Fnum q) * 1%nat)%Z; [ apply Zle_Zmult_comp_l | auto with zarith ]; auto with zarith. rewrite Zabs_eq; simpl in |- *; auto with zarith. simpl in |- *; ring. cut (Fexp p <= Fexp q)%Z; [ intros E2 | idtac ]. apply le_IZR; auto. apply (Rle_monotony_contra_exp radix) with (z := Fexp p); auto with real arith. pattern (Fexp p) at 2 in |- *; replace (Fexp p) with (Fexp (Fshift radix (Zabs_nat (Fexp q - Fexp p)) q)); auto. rewrite <- (fun x => Rabs_pos_eq (powerRZ radix x)); auto with real zarith. rewrite <- Faux.Rabsolu_Zabs. rewrite <- Rabs_mult. change (Rabs (FtoRradix (Fshift radix (Zabs_nat (Fexp q - Fexp p)) q)) <= Zabs (Fnum p) * powerRZ radix (Fexp p))%R in |- *. unfold FtoRradix in |- *; rewrite FshiftCorrect; auto. fold FtoRradix in |- *; rewrite <- H'0. rewrite <- (Fabs_correct radix); auto with real zarith. unfold Fshift in |- *; simpl in |- *. rewrite inj_abs; [ ring | auto with zarith ]. cut (Fexp p <= Fexp q)%Z; [ intros E2 | apply le_IZR ]; auto. apply Zle_trans with (Fexp p); [ idtac | apply le_IZR ]; auto with float. Qed. Theorem eqExpLess : forall (b : Fbound) (p q : float), Fbounded b p -> p = q :>R -> exists r : float, Fbounded b r /\ r = q :>R /\ (Fexp q <= Fexp r)%R. intros b p q H' H'0. case (Rle_or_lt (Fexp q) (Fexp p)); intros H'1. exists p; repeat (split; auto). exists q; split; [ idtac | split ]; auto with real. apply FboundedEqExp with (p := p); auto. apply Rlt_le; auto. Qed. Theorem FboundedShiftLess : forall (b : Fbound) (f : float) (n m : nat), m <= n -> Fbounded b (Fshift radix n f) -> Fbounded b (Fshift radix m f). intros b f n m H' H'0; split; auto. simpl in |- *; auto. apply Zle_lt_trans with (Zabs (Fnum (Fshift radix n f))). simpl in |- *; replace m with (m + 0); auto with arith. replace n with (m + (n - m)); auto with arith. repeat rewrite Zpower_nat_is_exp. repeat rewrite Zabs_Zmult; auto. apply Zle_Zmult_comp_l; auto with zarith. apply Zle_Zmult_comp_l; auto with zarith. repeat rewrite Zabs_eq; auto with zarith. case H'0; auto. apply Zle_trans with (Fexp (Fshift radix n f)); auto with float. simpl in |- *; unfold Zminus in |- *; auto with zarith. Qed. Theorem eqExpMax : forall (b : Fbound) (p q : float), Fbounded b p -> Fbounded b q -> (Fabs p <= q)%R -> exists r : float, Fbounded b r /\ r = p :>R /\ (Fexp r <= Fexp q)%Z. intros b p q H' H'0 H'1; case (Zle_or_lt (Fexp p) (Fexp q)); intros Rl0. exists p; auto. cut ((Fexp p - Zabs_nat (Fexp p - Fexp q))%Z = Fexp q); [ intros Eq1 | idtac ]. exists (Fshift radix (Zabs_nat (Fexp p - Fexp q)) p); split; split; auto. apply Zle_lt_trans with (Fnum q); auto with float. replace (Zabs (Fnum (Fshift radix (Zabs_nat (Fexp p - Fexp q)) p))) with (Fnum (Fabs (Fshift radix (Zabs_nat (Fexp p - Fexp q)) p))); auto. apply (Rle_Fexp_eq_Zle radix); auto with arith. rewrite Fabs_correct; auto with arith; rewrite FshiftCorrect; auto with arith; rewrite <- (Fabs_correct radix); auto with float arith. rewrite <- (Zabs_eq (Fnum q)); auto with float zarith. apply (LeR0Fnum radix); auto. apply Rle_trans with (2 := H'1); auto with real. rewrite (Fabs_correct radix); auto with real zarith. unfold Fshift in |- *; simpl in |- *; rewrite Eq1; auto with float. unfold FtoRradix in |- *; apply FshiftCorrect; auto. unfold Fshift in |- *; simpl in |- *. rewrite Eq1; auto with zarith. rewrite inj_abs; auto with zarith; ring. Qed. Theorem Zle_monotony_contra_abs_pow : forall x y z n : Z, (0 < z)%Z -> (Rabs (x * powerRZ z n) <= Rabs (y * powerRZ z n))%R -> (Zabs x <= Zabs y)%Z. intros x y z n Hz O1. apply le_IZR; auto. apply Rmult_le_reg_l with (r := powerRZ z n); auto with real zarith. repeat rewrite (Rmult_comm (powerRZ z n)); auto. repeat rewrite <- Faux.Rabsolu_Zabs. replace (powerRZ z n) with (Rabs (powerRZ z n)). repeat rewrite <- Rabs_mult; auto. apply Rabs_pos_eq; auto with real zarith. Qed. Theorem LessExpBound : forall (b : Fbound) (p q : float), Fbounded b p -> Fbounded b q -> (Fexp q <= Fexp p)%Z -> (0 <= p)%R -> (p <= q)%R -> exists m : Z, Float m (Fexp q) = p :>R /\ Fbounded b (Float m (Fexp q)). intros b p q H' H'0 H'1 H'2 H'3; exists (Fnum p * Zpower_nat radix (Zabs_nat (Fexp p - Fexp q)))%Z. cut (Float (Fnum p * Zpower_nat radix (Zabs_nat (Fexp p - Fexp q))) (Fexp q) = p :>R); [ intros Eq1 | idtac ]. split; auto. repeat split; simpl in |- *; auto with float. apply Zle_lt_trans with (Zabs (Fnum q)); auto with float. apply Zle_monotony_contra_abs_pow with (z := radix) (n := Fexp q); auto with real arith. unfold FtoRradix, FtoR in Eq1; simpl in Eq1; rewrite Eq1; auto with real. change (Rabs p <= Rabs q)%R in |- *. repeat rewrite Rabs_pos_eq; auto with real. apply Rle_trans with (1 := H'2); auto. pattern (Fexp q) at 2 in |- *; replace (Fexp q) with (Fexp p - Zabs_nat (Fexp p - Fexp q))%Z. change (Fshift radix (Zabs_nat (Fexp p - Fexp q)) p = p :>R) in |- *. unfold FtoRradix in |- *; apply FshiftCorrect; auto. rewrite inj_abs; auto with zarith; ring. Qed. Theorem maxFbounded : forall (b : Fbound) (z : Z), (- dExp b <= z)%Z -> Fbounded b (Float (Zpred (Zpos (vNum b))) z). intros b z H; split; auto. change (Zabs (Zpred (Zpos (vNum b))) < Zpos (vNum b))%Z in |- *. rewrite Zabs_eq; auto with zarith. Qed. Theorem maxMax : forall (b : Fbound) (p : float) (z : Z), Fbounded b p -> (Fexp p <= z)%Z -> (Fabs p < Float (Zpos (vNum b)) z)%R. intros b p z H' H'0; unfold FtoRradix in |- *; rewrite <- (FshiftCorrect _ radixMoreThanOne (Zabs_nat (z - Fexp p)) (Float (Zpos (vNum b)) z)); unfold Fshift in |- *. change (FtoR radix (Fabs p) < FtoR radix (Float (Zpos (vNum b) * Zpower_nat radix (Zabs_nat (z - Fexp p))) (z - Zabs_nat (z - Fexp p))))%R in |- *. replace (z - Zabs_nat (z - Fexp p))%Z with (Fexp p). unfold Fabs, FtoR in |- *. change (Zabs (Fnum p) * powerRZ radix (Fexp p) < (Zpos (vNum b) * Zpower_nat radix (Zabs_nat (z - Fexp p)))%Z * powerRZ radix (Fexp p))%R in |- *. apply Rmult_lt_compat_r; auto with real zarith. apply Rlt_le_trans with (IZR (Zpos (vNum b))); auto with real float zarith. pattern (Zpos (vNum b)) at 1 in |- *; replace (Zpos (vNum b)) with (Zpos (vNum b) * 1)%Z; auto with real float zarith; ring. rewrite inj_abs; auto with zarith; ring. Qed. End Fbounded_Def. Hint Resolve FboundedFzero oppBounded absFBounded maxFbounded FboundedNum FboundedExp: float.Float8.4/Fcomp.v0000644000423700002640000002346212032774525013312 0ustar sboldotoccata(**************************************************************************** IEEE754 : Fcomp Laurent Thery ******************************************************************************) Require Export Float. Section comparisons. Variable radix : Z. Hypothesis radixMoreThanOne : (1 < radix)%Z. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Definition Fdiff (x y : float) := (Fnum x * Zpower_nat radix (Zabs_nat (Fexp x - Zmin (Fexp x) (Fexp y))) - Fnum y * Zpower_nat radix (Zabs_nat (Fexp y - Zmin (Fexp x) (Fexp y))))%Z. Coercion Local FtoRradix := FtoR radix. Theorem Fdiff_correct : forall x y : float, (Fdiff x y * powerRZ radix (Zmin (Fexp x) (Fexp y)))%R = (x - y)%R. intros x y; unfold Fdiff in |- *. rewrite <- Z_R_minus. rewrite Rmult_comm; rewrite Rmult_minus_distr_l. repeat rewrite Rmult_IZR. repeat rewrite Zpower_nat_Z_powerRZ; auto. rewrite (Rmult_comm (Fnum x)); rewrite (Rmult_comm (Fnum y)). repeat rewrite <- Rmult_assoc. repeat rewrite <- powerRZ_add; auto with real zarith. repeat rewrite inj_abs; auto with arith. repeat rewrite Zplus_minus; auto. rewrite (fun t : R => Rmult_comm t (Fnum x)); rewrite (fun t : R => Rmult_comm t (Fnum y)); auto. apply Zplus_le_reg_l with (p := Zmin (Fexp x) (Fexp y)); auto with arith. rewrite Zplus_minus; rewrite Zplus_0_r; apply Zle_min_r; auto. apply Zplus_le_reg_l with (p := Zmin (Fexp x) (Fexp y)); auto with arith. rewrite Zplus_minus; rewrite Zplus_0_r; apply Zle_min_l; auto. Qed. (* Definition of comparison functions*) Definition Feq (x y : float) := x = y :>R. Definition Fle (x y : float) := (x <= y)%R. Definition Flt (x y : float) := (x < y)%R. Definition Fge (x y : float) := (x >= y)%R. Definition Fgt (x y : float) := (x > y)%R. Definition Fcompare (x y : float) := (Fdiff x y ?= 0)%Z. Definition Feq_bool (x y : float) := match Fcompare x y with | Eq => true | _ => false end. Theorem Feq_bool_correct_t : forall x y : float, Feq_bool x y = true -> Feq x y. intros x y H'; red in |- *. apply Rplus_eq_reg_l with (r := (- y)%R). repeat rewrite (Rplus_comm (- y)). rewrite Rplus_opp_r. change ((x - y)%R = 0%R) in |- *. rewrite <- Fdiff_correct. apply Rmult_eq_0_compat_r; auto. cut (Fdiff x y = 0%Z); [ intros H; rewrite H | idtac ]; auto with real. apply Zcompare_EGAL. generalize H'; unfold Feq_bool, Fcompare in |- *. case (Fdiff x y ?= 0)%Z;auto; intros; discriminate. Qed. Theorem Feq_bool_correct_r : forall x y : float, Feq x y -> Feq_bool x y = true. intros x y H'; cut ((x - y)%R = 0%R). rewrite <- Fdiff_correct; intros H'1; case Rmult_integral with (1 := H'1). intros H'0; unfold Feq_bool, Fcompare in |- *. rewrite eq_IZR_R0 with (1 := H'0); auto. intros H'0; Contradict H'0. case (Zmin (Fexp x) (Fexp y)); simpl in |- *; auto with real zarith. apply Rplus_eq_reg_l with (r := FtoR radix y); auto with real. Qed. Theorem Feq_bool_correct_f : forall x y : float, Feq_bool x y = false -> ~ Feq x y. intros x y H'; Contradict H'. rewrite Feq_bool_correct_r; auto with arith. red in |- *; intros H'0; discriminate. Qed. Definition Flt_bool (x y : float) := match Fcompare x y with | Lt => true | _ => false end. Theorem Flt_bool_correct_t : forall x y : float, Flt_bool x y = true -> Flt x y. intros x y H'; red in |- *. apply Rplus_lt_reg_r with (r := (- y)%R). repeat rewrite (Rplus_comm (- y)). rewrite Rplus_opp_r. change (x - y < 0)%R in |- *. rewrite <- Fdiff_correct. replace 0%R with (powerRZ radix (Zmin (Fexp x) (Fexp y)) * 0)%R; auto with real arith. rewrite (Rmult_comm (Fdiff x y)). apply Rmult_lt_compat_l; auto with real zarith. replace 0%R with (IZR 0); auto with real arith. apply Rlt_IZR; red in |- *. generalize H'; unfold Flt_bool, Fcompare in |- *. case (Fdiff x y ?= 0)%Z; auto; intros; try discriminate. Qed. Theorem Flt_bool_correct_r : forall x y : float, Flt x y -> Flt_bool x y = true. intros x y H'. cut (0 < y - x)%R; auto with arith. 2: apply Rplus_lt_reg_r with (r := FtoRradix x); rewrite Rplus_0_r; rewrite Rplus_minus; auto with real. intros H'0. cut (Fdiff x y < 0)%R; auto with arith. intros H'1. cut (Fdiff x y < 0)%Z; auto with zarith. intros H'2; generalize (Zlt_compare _ _ H'2); unfold Flt_bool, Fcompare, Zcompare in |- *; case (Fdiff x y); auto with arith; intros; contradiction. apply lt_IZR; auto with arith. apply (Rlt_monotony_contra_exp radix) with (z := Zmin (Fexp x) (Fexp y)); auto with arith real; rewrite Rmult_0_l. rewrite Fdiff_correct; auto with real. Qed. Theorem Flt_bool_correct_f : forall x y : float, Flt_bool x y = false -> Fle y x. intros x y H'. case (Rtotal_order (FtoRradix y) (FtoRradix x)); auto with real. intros H'0; red in |- *; apply Rlt_le; auto with real. intros H'0; elim H'0; clear H'0; intros H'1. red in |- *; rewrite H'1; auto with real. Contradict H'; rewrite Flt_bool_correct_r; auto with real. red in |- *; intros H'; discriminate. Qed. Definition Fle_bool (x y : float) := match Fcompare x y with | Lt => true | Eq => true | _ => false end. Theorem Fle_bool_correct_t : forall x y : float, Fle_bool x y = true -> Fle x y. intros x y H'. cut (Feq x y \/ Flt x y). intros H; case H; intros H1; auto with real. red in |- *; apply Req_le; auto with real. red in |- *; apply Rlt_le; auto with real. generalize H' (Feq_bool_correct_t x y) (Flt_bool_correct_t x y). unfold Fle_bool, Feq_bool, Flt_bool in |- *; case (Fcompare x y); auto. Qed. Theorem Fle_bool_correct_r : forall x y : float, Fle x y -> Fle_bool x y = true. intros x y H'. cut (Feq x y \/ Flt x y). intros H; case H; intros H1; auto with real. generalize (Feq_bool_correct_r x y). unfold Fle_bool, Feq_bool, Flt_bool in |- *; case (Fcompare x y); auto. generalize (Flt_bool_correct_r x y); unfold Fle_bool, Feq_bool, Flt_bool in |- *; case (Fcompare x y); auto with arith. case H'; auto with arith. Qed. Theorem Fle_bool_correct_f : forall x y : float, Fle_bool x y = false -> Flt y x. intros x y H'. case (Rtotal_order (FtoRradix y) (FtoRradix x)); auto with real. intros H'0; elim H'0; clear H'0; intros H'1. Contradict H'. rewrite Fle_bool_correct_r; auto with real. red in |- *; intros H'; discriminate. red in |- *; rewrite H'1; auto with real. Contradict H'. rewrite Fle_bool_correct_r; auto with real. red in |- *; intros H'; discriminate. red in |- *; auto with real. Qed. Lemma Fle_Zle : forall n1 n2 d : Z, (n1 <= n2)%Z -> Fle (Float n1 d) (Float n2 d). intros; unfold Fle, FtoRradix, FtoR in |- *; simpl in |- *; auto. case Zle_lt_or_eq with (1 := H); intros H1. apply Rlt_le; auto with real. rewrite <- H1; auto with real. Qed. Lemma Flt_Zlt : forall n1 n2 d : Z, (n1 < n2)%Z -> Flt (Float n1 d) (Float n2 d). intros; unfold Flt, FtoRradix, FtoR in |- *; simpl in |- *; auto with real. Qed. Lemma Fle_Fge : forall x y : float, Fle x y -> Fge y x. unfold Fle, Fge in |- *; intros x y H'; auto with real. Qed. Lemma Fge_Zge : forall n1 n2 d : Z, (n1 >= n2)%Z -> Fge (Float n1 d) (Float n2 d). intros n1 n2 d H'; apply Fle_Fge; auto. apply Fle_Zle; auto. apply Zge_le; auto. Qed. Lemma Flt_Fgt : forall x y : float, Flt x y -> Fgt y x. unfold Flt, Fgt in |- *; intros x y H'; auto. Qed. Lemma Fgt_Zgt : forall n1 n2 d : Z, (n1 > n2)%Z -> Fgt (Float n1 d) (Float n2 d). intros n1 n2 d H'; apply Flt_Fgt; auto. apply Flt_Zlt; auto. apply Zgt_lt; auto. Qed. (* Arithmetic properties on F : Fle is reflexive, transitive, antisymmetric *) Lemma Fle_refl : forall x y : float, Feq x y -> Fle x y. unfold Feq in |- *; unfold Fle in |- *; intros. rewrite H; auto with real. Qed. Lemma Fle_trans : forall x y z : float, Fle x y -> Fle y z -> Fle x z. unfold Fle in |- *; intros. apply Rle_trans with (r2 := FtoR radix y); auto. Qed. Theorem Rlt_Fexp_eq_Zlt : forall x y : float, (x < y)%R -> Fexp x = Fexp y -> (Fnum x < Fnum y)%Z. intros x y H' H'0. apply lt_IZR. apply (Rlt_monotony_contra_exp radix) with (z := Fexp x); auto with real arith. pattern (Fexp x) at 2 in |- *; rewrite H'0; auto. Qed. Theorem Rle_Fexp_eq_Zle : forall x y : float, (x <= y)%R -> Fexp x = Fexp y -> (Fnum x <= Fnum y)%Z. intros x y H' H'0. apply le_IZR. apply (Rle_monotony_contra_exp radix) with (z := Fexp x); auto with real arith. pattern (Fexp x) at 2 in |- *; rewrite H'0; auto. Qed. Theorem LtR0Fnum : forall p : float, (0 < p)%R -> (0 < Fnum p)%Z. intros p H'. apply lt_IZR. apply (Rlt_monotony_contra_exp radix) with (z := Fexp p); auto with real arith. simpl in |- *; rewrite Rmult_0_l; auto. Qed. Theorem LeR0Fnum : forall p : float, (0 <= p)%R -> (0 <= Fnum p)%Z. intros p H'. apply le_IZR. apply (Rle_monotony_contra_exp radix) with (z := Fexp p); auto with real arith. simpl in |- *; rewrite Rmult_0_l; auto. Qed. Theorem LeFnumZERO : forall x : float, (0 <= Fnum x)%Z -> (0 <= x)%R. intros x H'; unfold FtoRradix, FtoR in |- *. replace 0%R with (0%Z * 0%Z)%R; auto 6 with real zarith. Qed. Theorem R0LtFnum : forall p : float, (p < 0)%R -> (Fnum p < 0)%Z. intros p H'. apply lt_IZR. apply (Rlt_monotony_contra_exp radix) with (z := Fexp p); auto with real arith. simpl in |- *; rewrite Rmult_0_l; auto. Qed. Theorem R0LeFnum : forall p : float, (p <= 0)%R -> (Fnum p <= 0)%Z. intros p H'. apply le_IZR. apply (Rle_monotony_contra_exp radix) with (z := Fexp p); auto with real arith. simpl in |- *; rewrite Rmult_0_l; auto. Qed. Theorem LeZEROFnum : forall x : float, (Fnum x <= 0)%Z -> (x <= 0)%R. intros x H'; unfold FtoRradix, FtoR in |- *. apply Ropp_le_cancel; rewrite Ropp_0; rewrite <- Ropp_mult_distr_l_reverse. replace 0%R with (- 0%Z * 0)%R; auto 6 with real zarith. Qed. End comparisons. Hint Resolve LeFnumZERO LeZEROFnum: float.Float8.4/Finduct.v0000644000423700002640000002225012032774525013634 0ustar sboldotoccata(**************************************************************************** IEEE754 : Finduct Laurent Thery ***************************************************************************** Define an induction principle on float*) Require Export FPred. Section finduct. Variable b : Fbound. Variable radix : Z. Variable precision : nat. Coercion Local FtoRradix := FtoR radix. Hypothesis radixMoreThanOne : (1 < radix)%Z. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Hypothesis precisionNotZero : precision <> 0. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Definition Fweight (p : float) := (Fnum p + Fexp p * Zpower_nat radix precision)%Z. Theorem FweightLt : forall p q : float, Fcanonic radix b p -> Fcanonic radix b q -> (0 <= p)%R -> (p < q)%R -> (Fweight p < Fweight q)%Z. intros p q H' H'0 H'1 H'2. cut (Fbounded b p); [ intros Fb1 | apply FcanonicBound with (1 := H') ]; auto. cut (Fbounded b q); [ intros Fb2 | apply FcanonicBound with (1 := H'0) ]; auto. case (FcanonicLtPos _ radixMoreThanOne b precision) with (p := p) (q := q); auto with arith; intros Zl1. unfold Fweight in |- *; simpl in |- *. replace (Fexp q) with (Fexp q - Fexp p + Fexp p)%Z; [ idtac | ring ]. rewrite Zmult_plus_distr_l. rewrite Zplus_assoc. repeat rewrite (fun x y z : Z => Zplus_comm x (y * z)). apply Zplus_lt_compat_l. apply Zlt_le_trans with (Zpower_nat radix precision); auto with zarith. apply Zle_lt_trans with (Zpred (Zpower_nat radix precision)); auto with zarith. apply Zle_Zabs_inv2; auto with float zarith. apply Zle_Zpred; auto with float zarith. rewrite <- pGivesBound; auto with float. apply Zle_trans with ((Fexp q - Fexp p) * Zpower_nat radix precision)%Z; auto with zarith. pattern (Zpower_nat radix precision) at 1 in |- *; replace (Zpower_nat radix precision) with (Zsucc 0 * Zpower_nat radix precision)%Z; auto. apply Zle_Zmult_comp_r; auto with zarith. unfold Zsucc in |- *; ring. cut (0 <= Fnum q)%Z; auto with zarith. apply (LeR0Fnum radix); auto. apply Rle_trans with (FtoRradix p); auto; apply Rlt_le; auto. elim Zl1; intros H'3 H'4; clear Zl1. unfold Fweight in |- *; simpl in |- *. rewrite <- H'3. repeat rewrite (fun x y z : Z => Zplus_comm x (y * z)). apply Zplus_lt_compat_l; auto. Qed. Theorem FweightEq : forall p q : float, Fcanonic radix b p -> Fcanonic radix b q -> p = q :>R -> Fweight p = Fweight q. intros p q H' H'0 H'1. rewrite (FcanonicUnique _ radixMoreThanOne b precision) with (p := p) (q := q); auto with arith. Qed. Theorem FweightZle : forall p q : float, Fcanonic radix b p -> Fcanonic radix b q -> (0 <= p)%R -> (p <= q)%R -> (Fweight p <= Fweight q)%Z. intros p q H' H'0 H'1 H'2; Casec H'2; intros H'2. apply Zlt_le_weak. apply FweightLt; auto. rewrite (FweightEq p q); auto with zarith. Qed. Theorem FinductPosAux : forall (P : float -> Prop) (p : float), (0 <= p)%R -> Fcanonic radix b p -> P p -> (forall q : float, Fcanonic radix b q -> (p <= q)%R -> P q -> P (FSucc b radix precision q)) -> forall x : Z, (0 <= x)%Z -> forall q : float, x = (Fweight q - Fweight p)%Z -> Fcanonic radix b q -> (p <= q)%R -> P q. intros P p H' H'0 H'1 H'2 x H'3; pattern x in |- *. apply Z_lt_induction; auto. intros x0 H'4 q H'5 H'6 H'7. Casec H'7; intros H'7. cut (p <= FPred b radix precision q)%R; [ intros Rl1 | idtac ]. cut (P (FPred b radix precision q)); [ intros P1 | idtac ]. rewrite <- (FSucPred b radix precision) with (x := q); auto with arith. apply H'2; auto with float arith. apply H'4 with (y := (Fweight (FPred b radix precision q) - Fweight p)%Z); auto. split. cut (Fweight p <= Fweight (FPred b radix precision q))%Z; auto with zarith. apply FweightZle; auto. apply FPredCanonic; auto with arith. rewrite H'5. cut (Fweight (FPred b radix precision q) < Fweight q)%Z; [ auto with zarith | idtac ]. apply FweightLt; auto with float. apply (R0RltRlePred b radix precision); auto. apply Rle_lt_trans with (FtoRradix p); auto. apply (FPredLt b radix precision); auto. apply (FPredCanonic b radix precision); auto with arith. apply (FPredProp b radix precision); auto with arith. rewrite <- (FcanonicUnique _ radixMoreThanOne b precision) with (p := p) (q := q); auto with arith. Qed. Theorem FinductPos : forall (P : float -> Prop) (p : float), (0 <= p)%R -> Fcanonic radix b p -> P p -> (forall q : float, Fcanonic radix b q -> (p <= q)%R -> P q -> P (FSucc b radix precision q)) -> forall q : float, Fcanonic radix b q -> (p <= q)%R -> P q. intros P p H' H'0 H'1 H'2 q H'3 H'4. apply FinductPosAux with (p := p) (x := (Fweight q - Fweight p)%Z); auto. cut (Fweight p <= Fweight q)%Z; [ auto with zarith | idtac ]. apply FweightZle; auto with float. Qed. Theorem FinductNegAux : forall (P : float -> Prop) (p : float), (0 <= p)%R -> Fcanonic radix b p -> P p -> (forall q : float, Fcanonic radix b q -> (0 < q)%R -> (q <= p)%R -> P q -> P (FPred b radix precision q)) -> forall x : Z, (0 <= x)%Z -> forall q : float, x = (Fweight p - Fweight q)%Z -> Fcanonic radix b q -> (0 <= q)%R -> (q <= p)%R -> P q. intros P p H' H'0 H'1 H'2 x H'3; pattern x in |- *. apply Z_lt_induction; auto. intros x0 H'4 q H'5 H'6 H'7 H'8. Casec H'8; intros H'8. cut (FSucc b radix precision q <= p)%R; [ intros Rle1 | idtac ]. cut (P (FSucc b radix precision q)); [ intros P1 | idtac ]. rewrite <- (FPredSuc b radix precision) with (x := q); auto with arith. apply H'2; auto with float arith. apply Rle_lt_trans with (FtoRradix q); auto. apply (FSuccLt b radix); auto with arith. apply H'4 with (y := (Fweight p - Fweight (FSucc b radix precision q))%Z); auto. split. cut (Fweight (FSucc b radix precision q) <= Fweight p)%Z; auto with zarith. apply FweightZle; auto. apply FSuccCanonic; auto with arith. apply Rle_trans with (FtoRradix q); auto; apply Rlt_le. apply (FSuccLt b radix); auto with arith. rewrite H'5. cut (Fweight q < Fweight (FSucc b radix precision q))%Z; [ auto with zarith | idtac ]. apply FweightLt; auto with float. apply (FSuccLt b radix); auto with arith. apply FSuccCanonic; auto with arith. apply Rle_trans with (FtoRradix q); auto; apply Rlt_le. apply (FSuccLt b radix); auto with arith. apply (FSuccProp b radix); auto with arith. rewrite <- (FcanonicUnique _ radixMoreThanOne b precision) with (p := p) (q := q); auto with arith. Qed. Theorem FinductNeg : forall (P : float -> Prop) (p : float), (0 <= p)%R -> Fcanonic radix b p -> P p -> (forall q : float, Fcanonic radix b q -> (0 < q)%R -> (q <= p)%R -> P q -> P (FPred b radix precision q)) -> forall q : float, Fcanonic radix b q -> (0 <= q)%R -> (q <= p)%R -> P q. intros P p H' H'0 H'1 H'2 q H'3 H'4 H'5. apply FinductNegAux with (p := p) (x := (Fweight p - Fweight q)%Z); auto. cut (Fweight q <= Fweight p)%Z; [ auto with zarith | idtac ]. apply FweightZle; auto with float. Qed. Theorem radixRangeBoundExp : forall p q : float, Fcanonic radix b p -> Fcanonic radix b q -> (0 <= p)%R -> (p < q)%R -> (q < radix * p)%R -> Fexp p = Fexp q \/ Zsucc (Fexp p) = Fexp q. intros p q H' H'0 H'1 H'2 H'3. case (FcanonicLtPos _ radixMoreThanOne b precision) with (p := p) (q := q); auto with arith. 2: intros H'4; elim H'4; intros H'5 H'6; clear H'4; auto. intros H'4; right. Casec H'; intros H'. case (FcanonicLtPos _ radixMoreThanOne b precision) with (p := q) (q := Float (Fnum p) (Zsucc (Fexp p))); auto with arith. left. case H'; intros H1 H2; red in H1. repeat split; simpl in |- *; auto with float. apply Zle_trans with (Fexp p); auto with float zarith. apply Rle_trans with (FtoRradix p); auto; apply Rlt_le; auto. unfold FtoR in |- *; simpl in |- *. rewrite powerRZ_Zs; auto with real zarith; auto. rewrite <- Rmult_assoc; rewrite (fun (x : R) (y : Z) => Rmult_comm x y); rewrite Rmult_assoc; auto. simpl in |- *; intros; apply Zle_antisym; auto with zarith. simpl in |- *; auto. intros H'5; elim H'5; intros H'6 H'7; auto. case (FcanonicLtPos _ radixMoreThanOne b precision) with (p := q) (q := Float (nNormMin radix precision) (Zsucc (Fexp p))); auto with arith. left; repeat split; simpl in |- *. rewrite Zabs_eq; auto with zarith. apply ZltNormMinVnum; auto with zarith. unfold nNormMin in |- *; auto with zarith. apply Zle_trans with (Fexp p); auto with float zarith. case H'; auto with float. rewrite <- (PosNormMin radix b precision); auto with zarith. apply Rle_trans with (1 := H'1); auto with real. apply Rlt_trans with (1 := H'3). unfold FtoR in |- *; simpl in |- *. rewrite powerRZ_Zs; auto with real zarith; auto. rewrite <- Rmult_assoc; rewrite (fun (x : R) (y : Z) => Rmult_comm x y); rewrite Rmult_assoc; auto. apply Rmult_lt_compat_l; auto with real arith. case H'. intros H'5 H'6; elim H'6; intros H'7 H'8; rewrite H'7; clear H'6. change (p < firstNormalPos radix b precision)%R in |- *. apply (FsubnormalLtFirstNormalPos radix); auto with arith. simpl in |- *; intros; apply Zle_antisym; auto with zarith. intros H'5; elim H'5; intros H'6 H'7; rewrite H'6; clear H'5; auto. Qed. End finduct.Float8.4/Float.v0000644000423700002640000002616312032774525013314 0ustar sboldotoccata(**************************************************************************** IEEE754 : Float Laurent Thery ***************************************************************************** ****************************************************** Module Float.v Inspired by the Diadic of Patrick Loiseleur *******************************************************) Require Export Omega. Require Export Compare. Require Export Rpow. Section definitions. Variable radix : Z. Hypothesis radixMoreThanOne : (1 < radix)%Z. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. (* The type float represents the set of numbers who can be written: x = n*b^p with n and p in Z. (pdic numbers) n = Fnum and p = Fexp *) Record float : Set := Float {Fnum : Z; Fexp : Z}. Theorem floatEq : forall p q : float, Fnum p = Fnum q -> Fexp p = Fexp q -> p = q. intros p q; case p; case q; simpl in |- *; intros; apply (f_equal2 (A1:=Z) (A2:=Z)); auto. Qed. Theorem floatDec : forall x y : float, {x = y} + {x <> y}. intros x y; case x; case y; intros Fnum2 Fexp2 Fnum1 Fexp1. case (Z_eq_dec Fnum1 Fnum2); intros H1. case (Z_eq_dec Fexp1 Fexp2); intros H2. left; apply floatEq; auto. right; red in |- *; intros H'; Contradict H2; inversion H'; auto. right; red in |- *; intros H'; Contradict H1; inversion H'; auto. Qed. Definition Fzero (x : Z) := Float 0 x. Definition is_Fzero (x : float) := Fnum x = 0%Z. Theorem is_FzeroP : forall x : float, is_Fzero x \/ ~ is_Fzero x. unfold is_Fzero in |- *; intro; CaseEq (Fnum x); intros; (right; discriminate) || (left; auto). Qed. Coercion IZR : Z >-> R. Coercion INR : nat >-> R. Coercion Z_of_nat : nat >-> Z. Definition FtoR (x : float) := (Fnum x * powerRZ (IZR radix) (Fexp x))%R. Coercion Local FtoR1 := FtoR. Theorem FzeroisReallyZero : forall z : Z, Fzero z = 0%R :>R. intros z; unfold FtoR1, FtoR in |- *; simpl in |- *; auto with real. Qed. Theorem is_Fzero_rep1 : forall x : float, is_Fzero x -> x = 0%R :>R. intros x H; unfold FtoR1, FtoR in |- *. red in H; rewrite H; simpl in |- *; auto with real. Qed. Theorem LtFnumZERO : forall x : float, (0 < Fnum x)%Z -> (0 < x)%R. intros x; case x; unfold FtoR1, FtoR in |- *; simpl in |- *. intros Fnum1 Fexp1 H'; replace 0%R with (Fnum1 * 0)%R; [ apply Rmult_lt_compat_l | ring ]; auto with real zarith. Qed. Theorem is_Fzero_rep2 : forall x : float, x = 0%R :>R -> is_Fzero x. intros x H'. case (Rmult_integral _ _ H'); simpl in |- *; auto. case x; simpl in |- *. intros Fnum1 Fexp1 H'0; red in |- *; simpl in |- *; auto with real zarith. apply eq_IZR_R0; auto. intros H'0; Contradict H'0; apply powerRZ_NOR; auto with real zarith. Qed. Theorem NisFzeroComp : forall x y : float, ~ is_Fzero x -> x = y :>R -> ~ is_Fzero y. intros x y H' H'0; Contradict H'. apply is_Fzero_rep2; auto. rewrite H'0. apply is_Fzero_rep1; auto. Qed. (* Some inegalities that will be helpful *) Theorem Rlt_monotony_exp : forall (x y : R) (z : Z), (x < y)%R -> (x * powerRZ radix z < y * powerRZ radix z)%R. intros x y z H'; apply Rmult_lt_compat_r; auto with real zarith. Qed. Theorem Rle_monotone_exp : forall (x y : R) (z : Z), (x <= y)%R -> (x * powerRZ radix z <= y * powerRZ radix z)%R. intros x y z H'; apply Rmult_le_compat_r; auto with real zarith. Qed. Theorem Rlt_monotony_contra_exp : forall (x y : R) (z : Z), (x * powerRZ radix z < y * powerRZ radix z)%R -> (x < y)%R. intros x y z H'; apply Rmult_lt_reg_l with (r := powerRZ radix z); auto with real zarith. repeat rewrite (Rmult_comm (powerRZ radix z)); auto. Qed. Theorem Rle_monotony_contra_exp : forall (x y : R) (z : Z), (x * powerRZ radix z <= y * powerRZ radix z)%R -> (x <= y)%R. intros x y z H'; apply Rmult_le_reg_l with (r := powerRZ radix z); auto with real zarith. repeat rewrite (Rmult_comm (powerRZ radix z)); auto. Qed. Theorem FtoREqInv1 : forall p q : float, ~ is_Fzero p -> p = q :>R -> Fnum p = Fnum q -> p = q. intros p q H' H'0 H'1. apply floatEq; auto. unfold FtoR1, FtoR in H'0. apply Rpow_eq_inv with (r := IZR radix); auto 6 with real zarith. apply Rlt_dichotomy_converse; right; red in |- *. unfold Rabs in |- *; case (Rcase_abs radix). intros H'2; Contradict H'2; apply Rle_not_lt; apply Ropp_le_cancel; auto with real. intros H'2; replace 1%R with (IZR 1); auto with real zarith. apply Rmult_eq_reg_l with (r := IZR (Fnum p)); auto with real. pattern (Fnum p) at 2 in |- *; rewrite H'1; auto. Qed. Theorem FtoREqInv2 : forall p q : float, p = q :>R -> Fexp p = Fexp q -> p = q. intros p q H' H'0. apply floatEq; auto. apply eq_IZR; auto. apply Rmult_eq_reg_l with (r := powerRZ radix (Fexp p)); auto with real zarith. repeat rewrite (Rmult_comm (powerRZ radix (Fexp p))); pattern (Fexp p) at 2 in |- *; rewrite H'0; auto with real zarith. Qed. Theorem Rlt_Float_Zlt : forall p q r : Z, (Float p r < Float q r)%R -> (p < q)%Z. intros p q r H'. apply lt_IZR. apply Rlt_monotony_contra_exp with (z := r); auto with real. Qed. Theorem Rle_Float_Zle : forall p q r : Z, (Float p r <= Float q r)%R -> (p <= q)%Z. intros p q r H'. apply le_IZR. apply Rle_monotony_contra_exp with (z := r); auto with real. Qed. (* Properties for floats with 1 as mantissa *) Theorem oneExp_le : forall x y : Z, (x <= y)%Z -> (Float 1%nat x <= Float 1%nat y)%R. intros x y H'; unfold FtoR1, FtoR in |- *; simpl in |- *. repeat rewrite Rmult_1_l; auto with real zarith. apply Rle_powerRZ; try replace 1%R with (IZR 1); auto with real zarith zarith. Qed. Theorem oneExp_lt : forall x y : Z, (x < y)%Z -> (Float 1%nat x < Float 1%nat y)%R. intros x y H'; unfold FtoR1, FtoR in |- *; simpl in |- *. repeat rewrite Rmult_1_l; auto with real zarith. Qed. Theorem oneExp_Zlt : forall x y : Z, (Float 1%nat x < Float 1%nat y)%R -> (x < y)%Z. intros x y H'; case (Zle_or_lt y x); auto; intros ZH; Contradict H'. apply Rle_not_lt; apply oneExp_le; auto. Qed. Theorem oneExp_Zle : forall x y : Z, (Float 1%nat x <= Float 1%nat y)%R -> (x <= y)%Z. intros x y H'; case (Zle_or_lt x y); auto; intros ZH; Contradict H'. apply Rgt_not_le; red in |- *; apply oneExp_lt; auto. Qed. Definition Fdigit (p : float) := digit radix (Fnum p). Definition Fshift (n : nat) (x : float) := Float (Fnum x * Zpower_nat radix n) (Fexp x - n). Theorem sameExpEq : forall p q : float, p = q :>R -> Fexp p = Fexp q -> p = q. intros p q; case p; case q; unfold FtoR1, FtoR in |- *; simpl in |- *. intros Fnum1 Fexp1 Fnum2 Fexp2 H' H'0; rewrite H'0; rewrite H'0 in H'. cut (Fnum1 = Fnum2). intros H'1; rewrite <- H'1; auto. apply eq_IZR; auto. apply Rmult_eq_reg_l with (r := powerRZ radix Fexp1); repeat rewrite (Rmult_comm (powerRZ radix Fexp1)); auto. apply Rlt_dichotomy_converse; right; auto with real. red in |- *; auto with real. Qed. Theorem FshiftFdigit : forall (n : nat) (x : float), ~ is_Fzero x -> Fdigit (Fshift n x) = Fdigit x + n. intros n x; case x; unfold Fshift, Fdigit, is_Fzero in |- *; simpl in |- *. intros p1 p2 H; apply digitAdd; auto. Qed. Theorem FshiftCorrect : forall (n : nat) (x : float), Fshift n x = x :>R. intros n x; unfold FtoR1, FtoR in |- *; simpl in |- *. rewrite Rmult_IZR. rewrite Zpower_nat_Z_powerRZ; auto. repeat rewrite Rmult_assoc. rewrite <- powerRZ_add; auto with real zarith. rewrite Zplus_minus; auto. Qed. Theorem FshiftCorrectInv : forall x y : float, x = y :>R -> (Fexp x <= Fexp y)%Z -> Fshift (Zabs_nat (Fexp y - Fexp x)) y = x. intros x y H' H'0; try apply sameExpEq; auto. apply trans_eq with (y := FtoR y); auto. apply FshiftCorrect. generalize H' H'0; case x; case y; simpl in |- *; clear H' H'0 x y. intros Fnum1 Fexp1 Fnum2 Fexp2 H' H'0; rewrite inj_abs; auto with zarith. Qed. Theorem FshiftO : forall x : float, Fshift 0 x = x. intros x; unfold Fshift in |- *; apply floatEq; simpl in |- *. replace (Zpower_nat radix 0) with 1%Z; auto with zarith. simpl in |- *; auto with zarith. Qed. Theorem FshiftCorrectSym : forall x y : float, x = y :>R -> exists n : nat, (exists m : nat, Fshift n x = Fshift m y). intros x y H'. case (Z_le_gt_dec (Fexp x) (Fexp y)); intros H'1. exists 0; exists (Zabs_nat (Fexp y - Fexp x)). rewrite FshiftO. apply sym_equal. apply FshiftCorrectInv; auto. exists (Zabs_nat (Fexp x - Fexp y)); exists 0. rewrite FshiftO. apply FshiftCorrectInv; auto with zarith. Qed. Theorem FshiftAdd : forall (n m : nat) (p : float), Fshift (n + m) p = Fshift n (Fshift m p). intros n m p; case p; unfold Fshift in |- *; simpl in |- *. intros Fnum1 Fexp1; apply floatEq; simpl in |- *; auto with zarith. rewrite Zpower_nat_is_exp; auto with zarith. rewrite (Zmult_comm (Zpower_nat radix n)); auto with zarith. rewrite <- (Zminus_plus_simpl_r (Fexp1 - m) n m). replace (Fexp1 - m + m)%Z with Fexp1; auto with zarith. replace (Z_of_nat (n + m)) with (n + m)%Z; auto with zarith arith. rewrite <- inj_plus; auto. Qed. Theorem ReqGivesEqwithSameExp : forall p q : float, exists r : float, (exists s : float, p = r :>R /\ q = s :>R /\ Fexp r = Fexp s). intros p q; exists (Fshift (Zabs_nat (Fexp p - Zmin (Fexp p) (Fexp q))) p); exists (Fshift (Zabs_nat (Fexp q - Zmin (Fexp p) (Fexp q))) q); repeat split; auto with real. rewrite FshiftCorrect; auto. rewrite FshiftCorrect; auto. simpl in |- *. replace (Z_of_nat (Zabs_nat (Fexp p - Zmin (Fexp p) (Fexp q)))) with (Fexp p - Zmin (Fexp p) (Fexp q))%Z. replace (Z_of_nat (Zabs_nat (Fexp q - Zmin (Fexp p) (Fexp q)))) with (Fexp q - Zmin (Fexp p) (Fexp q))%Z. case (Zmin_or (Fexp p) (Fexp q)); intros H'; rewrite H'; auto with zarith. rewrite inj_abs; auto. apply Zplus_le_reg_l with (p := Zmin (Fexp p) (Fexp q)); auto with zarith. generalize (Zle_min_r (Fexp p) (Fexp q)); auto with zarith. rewrite inj_abs; auto. apply Zplus_le_reg_l with (p := Zmin (Fexp p) (Fexp q)); auto with zarith. Qed. Theorem FdigitEq : forall x y : float, ~ is_Fzero x -> x = y :>R -> Fdigit x = Fdigit y -> x = y. intros x y H' H'0 H'1. cut (~ is_Fzero y); [ intros NZy | idtac ]. 2: red in |- *; intros H'2; case H'. 2: apply is_Fzero_rep2; rewrite H'0; apply is_Fzero_rep1; auto. case (Zle_or_lt (Fexp x) (Fexp y)); intros Eq1. case (Zle_lt_or_eq _ _ Eq1); clear Eq1; intros Eq1. absurd (Fdigit (Fshift (Zabs_nat (Fexp y - Fexp x)) y) = Fdigit y + Zabs_nat (Fexp y - Fexp x)). rewrite FshiftCorrectInv; auto. rewrite <- H'1. red in |- *; intros H'2. absurd (0%Z = (Fexp y - Fexp x)%Z); auto with zarith arith. rewrite <- (inj_abs (Fexp y - Fexp x)); auto with zarith. apply Zlt_le_weak; auto. apply FshiftFdigit; auto. apply sameExpEq; auto. absurd (Fdigit (Fshift (Zabs_nat (Fexp x - Fexp y)) x) = Fdigit x + Zabs_nat (Fexp x - Fexp y)). rewrite FshiftCorrectInv; auto. rewrite <- H'1. red in |- *; intros H'2. absurd (0%Z = (Fexp x - Fexp y)%Z); auto with zarith arith. rewrite <- (inj_abs (Fexp x - Fexp y)); auto with zarith. apply Zlt_le_weak; auto. apply FshiftFdigit; auto. Qed. End definitions. Hint Resolve Rlt_monotony_exp Rle_monotone_exp: real. Hint Resolve Zlt_not_eq Zlt_not_eq_rev: zarith.Float8.4/Fmin.v0000644000423700002640000005466712032774525013152 0ustar sboldotoccata(**************************************************************************** IEEE754 : Fmin Laurent Thery ******************************************************************************) Require Export Zenum. Require Export FPred. Section FMinMax. Variable b : Fbound. Variable radix : Z. Variable precision : 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 precisionNotZero : precision <> 0. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. (* a function that returns a boundd greater than a given nat *) Definition boundNat (n : nat) := Float 1%nat (digit radix n). Theorem boundNatCorrect : forall n : nat, (n < boundNat n)%R. intros n; unfold FtoRradix, FtoR, boundNat in |- *; simpl in |- *. rewrite Rmult_1_l. rewrite <- Zpower_nat_Z_powerRZ; auto with real zarith. rewrite INR_IZR_INZ; auto with real zarith. apply Rle_lt_trans with (Zabs n); [rewrite (Zabs_eq (Z_of_nat n))|idtac];auto with real zarith. Qed. Theorem boundBoundNat : forall n : nat, Fbounded b (boundNat n). intros n; repeat split; unfold boundNat in |- *; simpl in |- *; auto with zarith. apply vNumbMoreThanOne with (radix := radix) (precision := precision); auto with zarith. apply Zle_trans with 0%Z;[case (dExp b)|idtac]; auto with zarith. Qed. (* A function that returns a bounded greater than a given r *) Definition boundR (r : R) := boundNat (Zabs_nat (up (Rabs r))). Theorem boundRCorrect1 : forall r : R, (r < boundR r)%R. intros r; case (Rle_or_lt r 0); intros H'. apply Rle_lt_trans with (1 := H'). unfold boundR, boundNat, FtoRradix, FtoR in |- *; simpl in |- *; auto with real. rewrite Rmult_1_l; auto with real zarith. apply Rlt_trans with (2 := boundNatCorrect (Zabs_nat (up (Rabs r)))). replace (Rabs r) with r; auto with real. apply Rlt_le_trans with (r2 := IZR (up r)); auto with real zarith. case (archimed r); auto. rewrite INR_IZR_INZ; auto with real zarith. unfold Rabs in |- *; case (Rcase_abs r); auto with real. intros H'0; Contradict H'0; auto with real. Qed. Theorem boundRrOpp : forall r : R, boundR r = boundR (- r). intros R; unfold boundR in |- *. rewrite Rabs_Ropp; auto. Qed. Theorem boundRCorrect2 : forall r : R, (Fopp (boundR r) < r)%R. intros r; case (Rle_or_lt r 0); intros H'. rewrite boundRrOpp. pattern r at 2 in |- *; rewrite <- (Ropp_involutive r). unfold FtoRradix in |- *; rewrite Fopp_correct. apply Ropp_lt_contravar; apply boundRCorrect1; auto. apply Rle_lt_trans with 0%R; auto. replace 0%R with (-0)%R; auto with real. unfold FtoRradix in |- *; rewrite Fopp_correct. apply Ropp_le_contravar. unfold boundR, boundNat, FtoRradix, FtoR in |- *; simpl in |- *; auto with real zarith. rewrite Rmult_1_l; apply Rlt_le; auto with real zarith arith. Qed. (* A function that returns a list containing all the bounded smaller than a given real *) Definition mBFloat (p : R) := map (fun p : Z * Z => Float (fst p) (snd p)) (mProd Z Z (Z * Z) (mZlist (- pPred (vNum b)) (pPred (vNum b))) (mZlist (- dExp b) (Fexp (boundR p)))). Theorem mBFadic_correct1 : forall (r : R) (q : float), ~ is_Fzero q -> (Fopp (boundR r) < q)%R -> (q < boundR r)%R -> Fbounded b q -> In q (mBFloat r). intros r q. case (Zle_or_lt (Fexp (boundR r)) (Fexp q)); intros H'. intros H'0 H'1 H'2 H'3; case H'0. apply is_Fzero_rep2 with (radix := radix); auto. rewrite <- FshiftCorrect with (n := Zabs_nat (Fexp q - Fexp (boundR r))) (x := q); auto with arith. apply is_Fzero_rep1 with (radix := radix). unfold is_Fzero in |- *. cut (forall p : Z, (- 1%nat < p)%Z -> (p < 1%nat)%Z -> p = 0%Z); [ intros tmp; apply tmp | idtac ]. replace (- 1%nat)%Z with (Fnum (Fopp (boundR r))). apply Rlt_Fexp_eq_Zlt with (radix := radix); auto with real zarith. rewrite FshiftCorrect; auto. unfold Fshift in |- *; simpl in |- *. rewrite (fun x y => inj_abs (x - y)); auto with zarith. simpl in |- *; auto. replace (Z_of_nat 1) with (Fnum (boundR r)). apply Rlt_Fexp_eq_Zlt with (radix := radix); auto with zarith. rewrite FshiftCorrect; auto. unfold Fshift in |- *; simpl in |- *. rewrite inj_abs; auto with zarith. generalize H'; simpl in |- *; auto with zarith. simpl in |- *; auto. intros p0; case p0; simpl in |- *; auto with zarith. intros H'0 H'1 H'2 H'3; unfold mBFloat in |- *. replace q with ((fun p : Z * Z => Float (fst p) (snd p)) (Fnum q, Fexp q)). apply in_map with (f := fun p : Z * Z => Float (fst p) (snd p)); auto. apply mProd_correct; auto. apply mZlist_correct; auto with float. apply Zle_Zabs_inv1; auto with float. unfold pPred in |- *; apply Zle_Zpred; auto with float. apply Zle_Zabs_inv2; auto with float. unfold pPred in |- *; apply Zle_Zpred; auto with float. apply mZlist_correct; auto with float. auto with zarith. case q; simpl in |- *; auto with zarith. Qed. Theorem mBFadic_correct2 : forall r : R, In (boundR r) (mBFloat r). intros r; unfold mBFloat in |- *. replace (boundR r) with ((fun p : Z * Z => Float (fst p) (snd p)) (Fnum (boundR r), Fexp (boundR r))). apply in_map with (f := fun p : Z * Z => Float (fst p) (snd p)); auto. apply mProd_correct; auto. apply mZlist_correct; auto. unfold boundR, boundNat in |- *; simpl in |- *; auto with zarith. apply Zle_trans with (- (0))%Z; auto with zarith. apply Zle_Zopp; unfold pPred in |- *; apply Zle_Zpred; simpl in |- *. apply Zlt_trans with 1%Z; auto with zarith. apply vNumbMoreThanOne with (3 := pGivesBound); auto. unfold boundR, boundNat in |- *; simpl in |- *; auto with zarith. unfold pPred in |- *; apply Zle_Zpred; simpl in |- *. unfold boundR, boundNat in |- *; simpl in |- *; auto with zarith. apply vNumbMoreThanOne with (3 := pGivesBound); auto. apply mZlist_correct; auto. unfold boundR, boundNat in |- *; simpl in |- *; auto with zarith. apply Zle_trans with 0%Z; auto with zarith arith. case (dExp b); auto with zarith. case (boundR r); simpl in |- *; auto with zarith. case (boundR r); simpl in |- *; auto with zarith. Qed. Theorem mBFadic_correct3 : forall r : R, In (Fopp (boundR r)) (mBFloat r). intros r; unfold mBFloat in |- *. replace (Fopp (boundR r)) with ((fun p : Z * Z => Float (fst p) (snd p)) (Fnum (Fopp (boundR r)), Fexp (Fopp (boundR r)))). apply in_map with (f := fun p : Z * Z => Float (fst p) (snd p)); auto. apply mProd_correct; auto. apply mZlist_correct; auto. unfold boundR, boundNat in |- *; simpl in |- *; auto with zarith. replace (-1)%Z with (- Z_of_nat 1)%Z; auto with zarith. apply Zle_Zopp. unfold pPred in |- *; apply Zle_Zpred; simpl in |- *. apply (vNumbMoreThanOne radix) with (precision := precision); auto with zarith. unfold pPred in |- *; apply Zle_Zpred; simpl in |- *. red in |- *; simpl in |- *; auto. apply mZlist_correct; auto. unfold boundR, boundNat in |- *; simpl in |- *; auto with zarith. apply Zle_trans with 0%Z; auto with zarith. case (dExp b); auto with zarith. case (boundR r); simpl in |- *; auto with zarith. case (boundR r); simpl in |- *; auto with zarith. Qed. Theorem mBFadic_correct4 : forall r : R, In (Float 0%nat (- dExp b)) (mBFloat r). intros p; unfold mBFloat in |- *. replace (Float 0%nat (- dExp b)) with ((fun p : Z * Z => Float (fst p) (snd p)) (Fnum (Float 0%nat (- dExp b)), Fexp (Float 0%nat (- dExp b)))). apply in_map with (f := fun p : Z * Z => Float (fst p) (snd p)); auto. apply mProd_correct; auto. apply mZlist_correct; auto. simpl in |- *; auto with zarith. replace 0%Z with (- (0))%Z; [ idtac | simpl in |- *; auto ]. apply Zle_Zopp; unfold pPred in |- *; apply Zle_Zpred. red in |- *; simpl in |- *; auto with zarith. simpl in |- *; auto with zarith. unfold pPred in |- *; apply Zle_Zpred. red in |- *; simpl in |- *; auto with zarith. apply mZlist_correct; auto. simpl in |- *; auto with zarith. unfold boundR, boundNat in |- *; simpl in |- *; auto with zarith. apply Zle_trans with 0%Z; auto with zarith. case (dExp b); auto with zarith. simpl in |- *; auto with zarith. Qed. Theorem mBPadic_Fbounded : forall (p : float) (r : R), In p (mBFloat r) -> Fbounded b p. intros p r H'; red in |- *; repeat (split; auto). apply Zpred_Zle_Zabs_intro. apply mZlist_correct_rev1 with (q := Zpred (Zpos (vNum b))); auto with real. apply mProd_correct_rev1 with (l2 := mZlist (- dExp b) (Fexp (boundR r))) (C := (Z * Z)%type) (b := Fexp p); auto. apply in_map_inv with (f := fun p : Z * Z => Float (fst p) (snd p)); auto. intros a1 b1; case a1; case b1; simpl in |- *. intros z z0 z1 z2 H'0; inversion H'0; auto. generalize H'; case p; auto. apply mZlist_correct_rev2 with (p := (- Zpred (Zpos (vNum b)))%Z); auto. apply mProd_correct_rev1 with (l2 := mZlist (- dExp b) (Fexp (boundR r))) (C := (Z * Z)%type) (b := Fexp p); auto. apply in_map_inv with (f := fun p : Z * Z => Float (fst p) (snd p)); auto. intros a1 b1; case a1; case b1; simpl in |- *. intros z z0 z1 z2 H'0; inversion H'0; auto. generalize H'; case p; auto. apply mZlist_correct_rev1 with (q := Fexp (boundR r)); auto. apply mProd_correct_rev2 with (l1 := mZlist (- pPred (vNum b)) (pPred (vNum b))) (C := (Z * Z)%type) (a := Fnum p); auto. apply in_map_inv with (f := fun p : Z * Z => Float (fst p) (snd p)); auto. intros a1 b1; case a1; case b1; simpl in |- *. intros z z0 z1 z2 H'0; inversion H'0; auto. generalize H'; case p; auto. Qed. (* Some general properties of rounded predicate : -Projector A bounded is rounded to something equal to itself - Monotone : the rounded predicate is monotone *) Definition ProjectorP (P : R -> float -> Prop) := forall p q : float, Fbounded b p -> P p q -> p = q :>R. Definition MonotoneP (P : R -> float -> Prop) := forall (p q : R) (p' q' : float), (p < q)%R -> P p p' -> P q q' -> (p' <= q')%R. (* What it is to be a minimum*) Definition isMin (r : R) (min : float) := Fbounded b min /\ (min <= r)%R /\ (forall f : float, Fbounded b f -> (f <= r)%R -> (f <= min)%R). (* Min is a projector *) Theorem isMin_inv1 : forall (p : float) (r : R), isMin r p -> (p <= r)%R. intros p r H; case H; intros H1 H2; case H2; auto. Qed. Theorem ProjectMin : ProjectorP isMin. red in |- *. intros p q H' H'0; apply Rle_antisym. elim H'0; intros H'1 H'2; elim H'2; intros H'3 H'4; apply H'4; clear H'2; auto with real. apply isMin_inv1 with (1 := H'0); auto. Qed. (* It is monotone *) Theorem MonotoneMin : MonotoneP isMin. red in |- *. intros p q p' q' H' H'0 H'1. elim H'1; intros H'2 H'3; elim H'3; intros H'4 H'5; apply H'5; clear H'3 H'1; auto. case H'0; auto. apply Rle_trans with p; auto. apply isMin_inv1 with (1 := H'0); auto. apply Rlt_le; auto. Qed. (* What it is to be a maximum *) Definition isMax (r : R) (max : float) := Fbounded b max /\ (r <= max)%R /\ (forall f : float, Fbounded b f -> (r <= f)%R -> (max <= f)%R). (* It is a projector *) Theorem isMax_inv1 : forall (p : float) (r : R), isMax r p -> (r <= p)%R. intros p r H; case H; intros H1 H2; case H2; auto. Qed. Theorem ProjectMax : ProjectorP isMax. red in |- *. intros p q H' H'0; apply Rle_antisym. apply isMax_inv1 with (1 := H'0); auto. elim H'0; intros H'1 H'2; elim H'2; intros H'3 H'4; apply H'4; clear H'2; auto with real. Qed. (* It is monotone *) Theorem MonotoneMax : MonotoneP isMax. red in |- *. intros p q p' q' H' H'0 H'1. elim H'0; intros H'2 H'3; elim H'3; intros H'4 H'5; apply H'5; clear H'3 H'0. case H'1; auto. apply Rle_trans with q; auto. apply Rlt_le; auto. apply isMax_inv1 with (1 := H'1); auto. Qed. (* Minimun is defined upto equality *) Theorem MinEq : forall (p q : float) (r : R), isMin r p -> isMin r q -> p = q :>R. intros p q r H' H'0; apply Rle_antisym. elim H'0; intros H'1 H'2; elim H'2; intros H'3 H'4; apply H'4; clear H'2 H'0; auto. case H'; auto. apply isMin_inv1 with (1 := H'); auto. elim H'; intros H'1 H'2; elim H'2; intros H'3 H'4; apply H'4; clear H'2 H'; auto. case H'0; auto. apply isMin_inv1 with (1 := H'0); auto. Qed. (* Maximum is defined upto equality *) Theorem MaxEq : forall (p q : float) (r : R), isMax r p -> isMax r q -> p = q :>R. intros p q r H' H'0; apply Rle_antisym. elim H'; intros H'1 H'2; elim H'2; intros H'3 H'4; apply H'4; clear H'2 H'; auto. case H'0; auto. apply isMax_inv1 with (1 := H'0); auto. elim H'0; intros H'1 H'2; elim H'2; intros H'3 H'4; apply H'4; clear H'2 H'0; auto. case H'; auto. apply isMax_inv1 with (1 := H'); auto. Qed. (* Min and Max are related *) Theorem MinOppMax : forall (p : float) (r : R), isMin r p -> isMax (- r) (Fopp p). intros p r H'; split. apply oppBounded; case H'; auto. split. unfold FtoRradix in |- *; rewrite Fopp_correct. apply Ropp_le_contravar; apply isMin_inv1 with (1 := H'); auto. intros f H'0 H'1. rewrite <- (Fopp_Fopp f). unfold FtoRradix in |- *; rewrite Fopp_correct; rewrite Fopp_correct. apply Ropp_le_contravar. elim H'. intros H'2 H'3; elim H'3; intros H'4 H'5; apply H'5; clear H'3. apply oppBounded; case H'; auto. rewrite <- (Ropp_involutive r). unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real. Qed. (* Max and Min are related *) Theorem MaxOppMin : forall (p : float) (r : R), isMax r p -> isMin (- r) (Fopp p). intros p r H'; split. apply oppBounded; case H'; auto. split. unfold FtoRradix in |- *; rewrite Fopp_correct. apply Ropp_le_contravar; apply isMax_inv1 with (1 := H'); auto. intros f H'0 H'1. rewrite <- (Fopp_Fopp f). unfold FtoRradix in |- *; repeat rewrite Fopp_correct. apply Ropp_le_contravar. rewrite <- (Fopp_correct radix f). elim H'. intros H'2 H'3; elim H'3; intros H'4 H'5; apply H'5; clear H'3. apply oppBounded; auto. rewrite <- (Ropp_involutive r). unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real. Qed. (* If I have a strict min I can get a max using FNSucc *) Theorem MinMax : forall (p : float) (r : R), isMin r p -> r <> p :>R -> isMax r (FNSucc b radix precision p). intros p r H' H'0. split. apply FcanonicBound with (radix := radix); auto with float. apply FNSuccCanonic; auto. inversion H'; auto. split. case (Rle_or_lt (FNSucc b radix precision p) r); intros H'2; auto. absurd (FNSucc b radix precision p <= p)%R. apply Rlt_not_le. unfold FtoRradix in |- *; apply FNSuccLt; auto. inversion H'; auto. elim H0; intros H'1 H'3; apply H'3; auto. apply FcanonicBound with (radix := radix); auto with float. apply Rlt_le; auto. intros f H'2 H'3. replace (FtoRradix f) with (FtoRradix (Fnormalize radix b precision f)). unfold FtoRradix in |- *; apply FNSuccProp; auto. inversion H'; auto. apply FcanonicBound with (radix := radix); auto with float. apply Rlt_le_trans with r; auto. case (Rle_or_lt r p); auto. intros H'4; Contradict H'0. apply Rle_antisym; auto; apply isMin_inv1 with (1 := H'); auto. rewrite FnormalizeCorrect; auto. unfold FtoRradix in |- *; apply FnormalizeCorrect; auto. Qed. (* Find a minimun in a given list if it exists *) Theorem MinExList : forall (r : R) (L : list float), (forall f : float, In f L -> (r < f)%R) \/ (exists min : float, In min L /\ (min <= r)%R /\ (forall f : float, In f L -> (f <= r)%R -> (f <= min)%R)). intros r L; elim L; simpl in |- *; auto. left; intros f H'; elim H'. intros a l H'. elim H'; [ intros H'0; clear H' | intros H'0; elim H'0; intros min E; elim E; intros H'1 H'2; elim H'2; intros H'3 H'4; try exact H'4; clear H'2 E H'0 H' ]. case (Rle_or_lt a r); intros H'1. right; exists a; repeat split; auto. intros f H'; elim H'; [ intros H'2; rewrite <- H'2; clear H' | intros H'2; clear H' ]; auto with real. intros H'; Contradict H'; auto with real. apply Rlt_not_le; auto with real. left; intros f H'; elim H'; [ intros H'2; rewrite <- H'2; clear H' | intros H'2; clear H' ]; auto. case (Rle_or_lt a min); intros H'5. right; exists min; repeat split; auto. intros f H'; elim H'; [ intros H'0; rewrite <- H'0; clear H' | intros H'0; clear H' ]; auto. case (Rle_or_lt a r); intros H'6. right; exists a; repeat split; auto. intros f H'; elim H'; [ intros H'0; rewrite <- H'0; clear H' | intros H'0; clear H' ]; auto with real. intros H'; apply Rle_trans with (FtoRradix min); auto with real. right; exists min; split; auto; split; auto. intros f H'; elim H'; [ intros H'0; elim H'0; clear H' | intros H'0; clear H' ]; auto. intros H'; Contradict H'6; auto with real. apply Rle_not_lt; auto. Qed. Theorem MinEx : forall r : R, exists min : float, isMin r min. intros r. case (MinExList r (mBFloat r)). intros H'0; absurd (Fopp (boundR r) <= r)%R; auto. apply Rlt_not_le. apply H'0. apply mBFadic_correct3; auto. (* A minimum always exists *) apply Rlt_le. apply boundRCorrect2; auto. intros H'0; elim H'0; intros min E; elim E; intros H'1 H'2; elim H'2; intros H'3 H'4; clear H'2 E H'0. exists min; split; auto. apply mBPadic_Fbounded with (r := r); auto. split; auto. intros f H'0 H'2. case (Req_dec f 0); intros H'6. replace (FtoRradix f) with (FtoRradix (Float 0%nat (- dExp b))). apply H'4; auto. apply mBFadic_correct4; auto. replace (FtoRradix (Float 0%nat (- dExp b))) with (FtoRradix f); auto. rewrite H'6. unfold FtoRradix, FtoR in |- *; simpl in |- *; auto with real. rewrite H'6. unfold FtoRradix, FtoR in |- *; simpl in |- *; auto with real. case (Rle_or_lt f (Fopp (boundR r))); intros H'5. apply Rle_trans with (FtoRradix (Fopp (boundR r))); auto. apply H'4; auto. apply mBFadic_correct3; auto. apply Rlt_le. apply boundRCorrect2; auto. case (Rle_or_lt (boundR r) f); intros H'7. Contradict H'2; apply Rlt_not_le. apply Rlt_le_trans with (FtoRradix (boundR r)); auto. apply boundRCorrect1; auto. apply H'4; auto. apply mBFadic_correct1; auto. Contradict H'6; unfold FtoRradix in |- *; apply is_Fzero_rep1; auto. Qed. Theorem MaxEx : forall r : R, exists max : float, isMax r max. intros r; case (MinEx r). intros x H'. case (Req_dec x r); intros H'1. exists x. rewrite <- H'1. red in |- *; split; [ case H' | split ]; auto with real. (* A maximum always exists *) exists (FNSucc b radix precision x). apply MinMax; auto. Qed. Theorem MinBinade : forall (r : R) (p : float), Fbounded b p -> (p <= r)%R -> (r < FNSucc b radix precision p)%R -> isMin r p. intros r p H' H'0 H'1. split; auto. split; auto. intros f H'2 H'3. case (Rle_or_lt f p); auto; intros H'5. Contradict H'3. (* If we are between a bound and its successor, it is our minimum *) apply Rlt_not_le. apply Rlt_le_trans with (1 := H'1); auto with real. replace (FtoRradix f) with (FtoRradix (Fnormalize radix b precision f)). unfold FtoRradix in |- *; apply FNSuccProp; auto; try apply FnormalizeCanonic; auto. unfold FtoRradix in |- *; repeat rewrite FnormalizeCorrect; auto with real. apply FcanonicBound with (radix := radix); auto. apply FnormalizeCanonic; auto. unfold FtoRradix in |- *; rewrite FnormalizeCorrect; auto with real. unfold FtoRradix in |- *; rewrite FnormalizeCorrect; auto with real. Qed. Theorem FminRep : forall p q : float, isMin p q -> exists m : Z, q = Float m (Fexp p) :>R. intros p q H'. replace (FtoRradix q) with (FtoRradix (Fnormalize radix b precision q)). 2: unfold FtoRradix in |- *; apply FnormalizeCorrect; auto. case (Zle_or_lt (Fexp (Fnormalize radix b precision q)) (Fexp p)); intros H'1. exists (Fnum p). unfold FtoRradix in |- *; apply FSuccZleEq with (3 := pGivesBound); auto. (* A min of a float is always represnetable with the same exposant *) replace (Float (Fnum p) (Fexp p)) with p; [ idtac | case p ]; auto. replace (FtoR radix (Fnormalize radix b precision q)) with (FtoR radix q); [ idtac | rewrite FnormalizeCorrect ]; auto. apply isMin_inv1 with (1 := H'); auto. replace (FSucc b radix precision (Fnormalize radix b precision q)) with (FNSucc b radix precision q); [ idtac | case p ]; auto. replace (Float (Fnum p) (Fexp p)) with p; [ idtac | case p ]; auto. case (Req_dec p q); intros Eq0. unfold FtoRradix in Eq0; rewrite Eq0. apply FNSuccLt; auto. case (MinMax q p); auto. intros H'2 H'3; elim H'3; intros H'4 H'5; clear H'3. case H'4; auto. intros H'0; absurd (p <= q)%R; rewrite H'0; auto. apply Rlt_not_le; auto. unfold FtoRradix in |- *; apply FNSuccLt; auto. inversion H'. elim H0; intros H'3 H'6; apply H'6; clear H0; auto. rewrite <- H'0; auto with real. exists (Fnum (Fshift radix (Zabs_nat (Fexp (Fnormalize radix b precision q) - Fexp p)) (Fnormalize radix b precision q))). pattern (Fexp p) at 2 in |- *; replace (Fexp p) with (Fexp (Fshift radix (Zabs_nat (Fexp (Fnormalize radix b precision q) - Fexp p)) (Fnormalize radix b precision q))). unfold FtoRradix in |- *; rewrite <- FshiftCorrect with (n := Zabs_nat (Fexp (Fnormalize radix b precision q) - Fexp p)) (x := Fnormalize radix b precision q). case (Fshift radix (Zabs_nat (Fexp (Fnormalize radix b precision q) - Fexp p)) (Fnormalize radix b precision q)); auto. auto with arith. simpl in |- *; rewrite inj_abs; auto with zarith. Qed. Theorem MaxBinade : forall (r : R) (p : float), Fbounded b p -> (r <= p)%R -> (FNPred b radix precision p < r)%R -> isMax r p. intros r p H' H'0 H'1. rewrite <- (Ropp_involutive r). rewrite <- (Fopp_Fopp p). apply MinOppMax. apply MinBinade; auto with real float. unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real. (* Same for max *) rewrite <- (Fopp_Fopp (FNSucc b radix precision (Fopp p))). rewrite <- FNPredFopFNSucc; auto. unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real arith. Qed. Theorem MaxMin : forall (p : float) (r : R), isMax r p -> r <> p :>R -> isMin r (FNPred b radix precision p). intros p r H' H'0. rewrite <- (Fopp_Fopp (FNPred b radix precision p)). rewrite <- (Ropp_involutive r). apply MaxOppMin. rewrite FNPredFopFNSucc; auto. rewrite Fopp_Fopp; auto. (* Taking the pred of a max we get a min *) apply MinMax; auto. apply MaxOppMin; auto. Contradict H'0. rewrite <- (Ropp_involutive r); rewrite H'0; auto; unfold FtoRradix in |- *; rewrite Fopp_correct; auto; apply Ropp_involutive. Qed. Theorem FmaxRep : forall p q : float, isMax p q -> exists m : Z, q = Float m (Fexp p) :>R. intros p q H'; case (FminRep (Fopp p) (Fopp q)). unfold FtoRradix in |- *; rewrite Fopp_correct. apply MaxOppMin; auto. intros x H'0. exists (- x)%Z. rewrite <- (Ropp_involutive (FtoRradix q)). (* The max of a float can be represented with the same exposant *) unfold FtoRradix in |- *; rewrite <- Fopp_correct. unfold FtoRradix in H'0; rewrite H'0. unfold FtoR in |- *; simpl in |- *; auto with real. rewrite Ropp_Ropp_IZR; rewrite Ropp_mult_distr_l_reverse; auto. Qed. End FMinMax. Hint Resolve ProjectMax MonotoneMax MinOppMax MaxOppMin MinMax MinBinade MaxBinade MaxMin: float. Float8.4/Fnorm.v0000644000423700002640000010641012032774525013322 0ustar sboldotoccata(**************************************************************************** IEEE754 : Fnorm Laurent Thery & Sylvie Boldo ******************************************************************************) Require Export Fbound. Section Fnormalized_Def. Variable radix : Z. Hypothesis radixMoreThanOne : (1 < radix)%Z. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Variable b : Fbound. Definition Fnormal (p : float) := Fbounded b p /\ (Zpos (vNum b) <= Zabs (radix * Fnum p))%Z. Theorem FnormalBounded : forall p : float, Fnormal p -> Fbounded b p. intros p H; case H; auto. Qed. Theorem FnormalBound : forall p : float, Fnormal p -> (Zpos (vNum b) <= Zabs (radix * Fnum p))%Z. intros p H; case H; auto. Qed. Hint Resolve FnormalBounded FnormalBound: float. Theorem FnormalNotZero : forall p : float, Fnormal p -> ~ is_Fzero p. unfold is_Fzero in |- *; intros p H; red in |- *; intros H1. case H; rewrite H1. replace (Zabs (radix * 0)) with 0%Z; auto with zarith. rewrite Zmult_comm; simpl in |- *; auto. Qed. Theorem FnormalFop : forall p : float, Fnormal p -> Fnormal (Fopp p). intros p H; split; auto with float. replace (Zabs (radix * Fnum (Fopp p))) with (Zabs (radix * Fnum p)); auto with float. case p; simpl in |- *; auto with zarith. intros Fnum1 Fexp1; rewrite <- Zopp_mult_distr_r; apply sym_equal; apply Zabs_Zopp. Qed. Theorem FnormalFabs : forall p : float, Fnormal p -> Fnormal (Fabs p). intros p; case p; intros a e H; split; auto with float. simpl in |- *; case H; intros H1 H2; simpl in |- *; auto. rewrite <- (Zabs_eq radix); auto with zarith. rewrite <- Zabs_Zmult. rewrite (fun x => Zabs_eq (Zabs x)); auto with float zarith. Qed. Definition pPred x := Zpred (Zpos x). Theorem maxMax1 : forall (p : float) (z : Z), Fbounded b p -> (Fexp p <= z)%Z -> (Fabs p <= Float (pPred (vNum b)) z)%R. intros p z H H0; unfold FtoRradix in |- *. rewrite <- (FshiftCorrect _ radixMoreThanOne (Zabs_nat (z - Fexp p)) (Float (pPred (vNum b)) z)). unfold FtoR, Fabs in |- *; simpl in |- *; auto with zarith. rewrite Rmult_IZR; rewrite Zpower_nat_Z_powerRZ; auto with zarith. repeat rewrite inj_abs; auto with zarith. replace (z - (z - Fexp p))%Z with (Fexp p); [ idtac | ring ]. rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with real zarith. replace (z - Fexp p + Fexp p)%Z with z; [ idtac | ring ]. apply Rle_trans with (pPred (vNum b) * powerRZ radix (Fexp p))%R. apply Rle_monotone_exp; auto with zarith; repeat rewrite Rmult_IZR; apply Rle_IZR; unfold pPred in |- *; apply Zle_Zpred; auto with float real zarith. apply Rmult_le_compat_l; auto with real zarith. replace 0%R with (IZR 0); auto with real; apply Rle_IZR; unfold pPred in |- *; apply Zle_Zpred; auto with float zarith. apply Rle_powerRZ; auto with float real zarith. Qed. Theorem FnormalBoundAbs : forall p : float, Fnormal p -> (Float (pPred (vNum b)) (Zpred (Fexp p)) < Fabs p)%R. intros p H'; unfold FtoRradix, FtoR in |- *; simpl in |- *. pattern (Fexp p) at 2 in |- *; replace (Fexp p) with (Zsucc (Zpred (Fexp p))); [ rewrite powerRZ_Zs; auto with real zarith | unfold Zsucc, Zpred in |- *; ring ]. repeat rewrite <- Rmult_assoc. apply Rmult_lt_compat_r; auto with real arith. rewrite <- Rmult_IZR; apply Rlt_IZR. unfold pPred in |- *; cut (Zpos (vNum b) <= Zabs (Fnum p) * radix)%Z; auto with zarith. rewrite <- (Zabs_eq radix); auto with float zarith; rewrite <- Zabs_Zmult; rewrite Zmult_comm; auto with float real zarith. Qed. Definition Fsubnormal (p : float) := Fbounded b p /\ Fexp p = (- dExp b)%Z /\ (Zabs (radix * Fnum p) < Zpos (vNum b))%Z. Theorem FsubnormalFbounded : forall p : float, Fsubnormal p -> Fbounded b p. intros p H; case H; auto. Qed. Theorem FsubnormalFexp : forall p : float, Fsubnormal p -> Fexp p = (- dExp b)%Z. intros p H; case H; auto. intros H1 H2; case H2; auto. Qed. Theorem FsubnormalBound : forall p : float, Fsubnormal p -> (Zabs (radix * Fnum p) < Zpos (vNum b))%Z. intros p H; case H; auto. intros H1 H2; case H2; auto. Qed. Hint Resolve FsubnormalFbounded FsubnormalBound FsubnormalFexp: float. Theorem FsubnormFopp : forall p : float, Fsubnormal p -> Fsubnormal (Fopp p). intros p H'; repeat split; simpl in |- *; auto with zarith float. rewrite Zabs_Zopp; auto with float. rewrite <- Zopp_mult_distr_r; rewrite Zabs_Zopp; auto with float. Qed. Theorem FsubnormFabs : forall p : float, Fsubnormal p -> Fsubnormal (Fabs p). intros p; case p; intros a e H; split; auto with float. simpl in |- *; split; auto with float. case H; intros H1 (H2, H3); auto. rewrite <- (Zabs_eq radix); auto with zarith. rewrite <- Zabs_Zmult. rewrite (fun x => Zabs_eq (Zabs x)); auto with float zarith. case H; intros H1 (H2, H3); auto. Qed. Theorem FsubnormalUnique : forall p q : float, Fsubnormal p -> Fsubnormal q -> p = q :>R -> p = q. intros p q H' H'0 H'1. apply FtoREqInv2 with (radix := radix); auto. generalize H' H'0; unfold Fsubnormal in |- *; auto with zarith. Qed. Theorem FsubnormalLt : forall p q : float, Fsubnormal p -> Fsubnormal q -> (p < q)%R -> (Fnum p < Fnum q)%Z. intros p q H' H'0 H'1. apply Rlt_Fexp_eq_Zlt with (radix := radix); auto with zarith. apply trans_equal with (- dExp b)%Z. case H'; auto. intros H1 H2; case H2; auto. apply sym_equal; case H'0; auto. intros H1 H2; case H2; auto. Qed. Theorem LtFsubnormal : forall p q : float, Fsubnormal p -> Fsubnormal q -> (Fnum p < Fnum q)%Z -> (p < q)%R. intros p q H' H'0 H'1. case (Rtotal_order p q); auto; intros Test; case Test; clear Test; intros Test; Contradict H'1. unfold FtoRradix in Test; rewrite sameExpEq with (2 := Test); auto. auto with zarith. apply trans_equal with (- dExp b)%Z. case H'; auto. intros H1 H2; case H2; auto. apply sym_equal; case H'0. intros H1 H2; case H2; auto. apply Zle_not_lt. apply Zlt_le_weak. apply FsubnormalLt; auto. Qed. Definition Fcanonic (a : float) := Fnormal a \/ Fsubnormal a. Theorem FcanonicBound : forall p : float, Fcanonic p -> Fbounded b p. intros p H; case H; auto with float. Qed. Hint Resolve FcanonicBound: float. Theorem pUCanonic_absolu : forall p : float, Fcanonic p -> (Zabs (Fnum p) < Zpos (vNum b))%Z. auto with float. Qed. Theorem FcanonicFopp : forall p : float, Fcanonic p -> Fcanonic (Fopp p). intros p H'; case H'; intros H'1. left; apply FnormalFop; auto. right; apply FsubnormFopp; auto. Qed. Theorem FcanonicFabs : forall p : float, Fcanonic p -> Fcanonic (Fabs p). intros p H'; case H'; clear H'; auto with float. intros H; left; auto with float. apply FnormalFabs; auto. intros H; right; auto with float. apply FsubnormFabs; auto. Qed. Theorem NormalNotSubNormal : forall p : float, ~ (Fnormal p /\ Fsubnormal p). intros p; red in |- *; intros H; elim H; intros H0 H1; clear H. absurd (Zabs (radix * Fnum p) < Zpos (vNum b))%Z; auto with float zarith. Qed. Theorem MaxFloat : forall x : float, Fbounded b x -> (Rabs x < Float (Zpos (vNum b)) (Fexp x))%R. intros. replace (Rabs x) with (FtoR radix (Fabs x)). unfold FtoRradix in |- *. apply maxMax with (b := b); auto with *. unfold FtoRradix in |- *. apply Fabs_correct; auto with *. Qed. (* What depends of the precision *) Variable precision : nat. Hypothesis precisionNotZero : precision <> 0. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Theorem FboundNext : forall p : float, Fbounded b p -> exists q : float, Fbounded b q /\ q = Float (Zsucc (Fnum p)) (Fexp p) :>R. intros p H'. case (Zle_lt_or_eq (Zsucc (Fnum p)) (Zpos (vNum b))); auto with float. case (Zle_or_lt 0 (Fnum p)); intros H1. rewrite <- (Zabs_eq (Fnum p)); auto with float zarith. apply Zle_trans with 0%Z; auto with zarith. intros H'0; exists (Float (Zsucc (Fnum p)) (Fexp p)); split; auto with float. repeat split; simpl in |- *; auto with float. case (Zle_or_lt 0 (Fnum p)); intros H1; auto with zarith. rewrite Zabs_eq; auto with zarith. apply Zlt_trans with (Zabs (Fnum p)); auto with float zarith. repeat rewrite Zabs_eq_opp; auto with zarith. intros H'0; exists (Float (Zpower_nat radix (pred precision)) (Zsucc (Fexp p))); split; auto. repeat split; simpl in |- *; auto with zarith arith float. rewrite pGivesBound. rewrite Zabs_eq; auto with zarith. rewrite H'0; rewrite pGivesBound. pattern precision at 2 in |- *; replace precision with (1 + pred precision). rewrite Zpower_nat_is_exp. rewrite Zpower_nat_1. unfold FtoRradix, FtoR in |- *; simpl in |- *. rewrite powerRZ_Zs; auto with real zarith. rewrite Rmult_IZR; ring. generalize precisionNotZero; case precision; simpl in |- *; auto with arith. intros H'1; case H'1; auto. Qed. Theorem digitPredVNumiSPrecision : digit radix (Zpred (Zpos (vNum b))) = precision. apply digitInv; auto. rewrite pGivesBound. rewrite Zabs_eq; auto with zarith. rewrite Zabs_eq; auto with zarith. Qed. Theorem digitVNumiSPrecision : digit radix (Zpos (vNum b)) = S precision. apply digitInv; auto. rewrite pGivesBound. rewrite Zabs_eq; auto with zarith. rewrite Zabs_eq; auto with zarith. rewrite pGivesBound; auto with zarith. Qed. Theorem vNumPrecision : forall n : Z, digit radix n <= precision -> (Zabs n < Zpos (vNum b))%Z. intros n H'. rewrite <- (Zabs_eq (Zpos (vNum b))); auto with zarith. apply digit_anti_monotone_lt with (n := radix); auto. rewrite digitVNumiSPrecision; auto with arith. Qed. Theorem pGivesDigit : forall p : float, Fbounded b p -> Fdigit radix p <= precision. intros p H; unfold Fdigit in |- *. rewrite <- digitPredVNumiSPrecision. apply digit_monotone; auto with zarith. rewrite (fun x => Zabs_eq (Zpred x)); auto with float zarith. Qed. Theorem digitGivesBoundedNum : forall p : float, Fdigit radix p <= precision -> (Zabs (Fnum p) < Zpos (vNum b))%Z. intros p H; apply vNumPrecision; auto. Qed. Theorem FboundedOne : forall z : Z, (- dExp b <= z)%Z -> Fbounded b (Float 1%nat z). intros z H'; repeat (split; simpl in |- *; auto with zarith). rewrite pGivesBound; auto. apply Zlt_le_trans with (Zpower_nat radix 1); auto with zarith. rewrite Zpower_nat_1; auto with zarith. Qed. Theorem FboundedMboundPos : forall z m : Z, (0 <= m)%Z -> (m <= Zpower_nat radix precision)%Z -> (- dExp b <= z)%Z -> exists c : float, Fbounded b c /\ c = (m * powerRZ radix z)%R :>R. intros z m H' H'0 H'1; case (Zle_lt_or_eq _ _ H'0); intros H'2. exists (Float m z); split; auto with zarith. repeat split; simpl in |- *; auto with zarith. rewrite Zabs_eq; auto; rewrite pGivesBound; auto. case (FboundNext (Float (Zpred (Zpos (vNum b))) z)); auto with float. intros f' (H1, H2); exists f'; split; auto. rewrite H2; rewrite pGivesBound. unfold FtoRradix, FtoR in |- *; simpl in |- *; auto. rewrite <- Zsucc_pred; rewrite <- H'2; auto; ring. Qed. Theorem FboundedMbound : forall z m : Z, (Zabs m <= Zpower_nat radix precision)%Z -> (- dExp b <= z)%Z -> exists c : float, Fbounded b c /\ c = (m * powerRZ radix z)%R :>R. intros z m H H0. case (Zle_or_lt 0 m); intros H1. case (FboundedMboundPos z (Zabs m)); auto; try rewrite Zabs_eq; auto. intros f (H2, H3); exists f; split; auto. case (FboundedMboundPos z (Zabs m)); auto; try rewrite Zabs_eq_opp; auto with zarith. intros f (H2, H3); exists (Fopp f); split; auto with float. rewrite (Fopp_correct radix); auto with arith; fold FtoRradix in |- *; rewrite H3. rewrite Ropp_Ropp_IZR; ring. Qed. Theorem FnormalPrecision : forall p : float, Fnormal p -> Fdigit radix p = precision. intros p H; apply le_antisym; auto with float. apply pGivesDigit; auto with float. apply le_S_n. rewrite <- digitVNumiSPrecision. unfold Fdigit in |- *. replace (S (digit radix (Fnum p))) with (digit radix (Fnum p) + 1). rewrite <- digitAdd; auto with zarith. apply digit_monotone; auto with float. rewrite (fun x => Zabs_eq (Zpos x)); auto with float zarith. rewrite Zmult_comm; rewrite Zpower_nat_1; auto with float zarith. red in |- *; intros H1; case H. intros H0 H2; Contradict H2; rewrite H1. replace (Zabs (radix * 0)) with 0%Z; auto with zarith. rewrite Zmult_comm; simpl in |- *; auto. rewrite plus_comm; simpl in |- *; auto. Qed. Hint Resolve FnormalPrecision: float. Theorem FnormalUnique : forall p q : float, Fnormal p -> Fnormal q -> p = q :>R -> p = q. intros p q H' H'0 H'1. apply (FdigitEq radix); auto. apply FnormalNotZero; auto. apply trans_equal with (y := precision); auto with float. apply sym_equal; auto with float. Qed. Theorem FnormalLtPos : forall p q : float, Fnormal p -> Fnormal q -> (0 <= p)%R -> (p < q)%R -> (Fexp p < Fexp q)%Z \/ Fexp p = Fexp q /\ (Fnum p < Fnum q)%Z. intros p q H' H'0 H'1 H'2. case (Zle_or_lt (Fexp q) (Fexp p)); auto. intros H'3; right. case (Zle_lt_or_eq _ _ H'3); intros H'4. 2: split; auto. 2: apply Rlt_Fexp_eq_Zlt with (radix := radix); auto with zarith. absurd (Fnum (Fshift radix (Zabs_nat (Fexp p - Fexp q)) p) < Fnum q)%Z; auto. 2: apply Rlt_Fexp_eq_Zlt with (radix := radix); auto with zarith. 2: unfold FtoRradix in |- *; rewrite FshiftCorrect; auto. 2: unfold Fshift in |- *; simpl in |- *; auto with zarith. 2: replace (Z_of_nat (Zabs_nat (Fexp p - Fexp q))) with (Fexp p - Fexp q)%Z; auto with zarith. 2: cut (0 < Fexp p - Fexp q)%Z; auto with zarith. 2: case (Fexp p - Fexp q)%Z; simpl in |- *; auto with zarith. 2: intros p0; rewrite (inject_nat_convert (Zpos p0)); auto with arith. 2: intros p0 H'5; discriminate. red in |- *; intros H'5. absurd (Fdigit radix (Fshift radix (Zabs_nat (Fexp p - Fexp q)) p) <= Fdigit radix q); auto with arith. rewrite FshiftFdigit; auto with arith. replace (Fdigit radix p) with precision. replace (Fdigit radix q) with precision; auto with zarith. cut (0 < Fexp p - Fexp q)%Z; auto with zarith. case (Fexp p - Fexp q)%Z; simpl in |- *; auto with zarith. intros p0 H'6; generalize (convert_not_O p0); auto with zarith. intros p0 H'6; discriminate. apply sym_equal; auto with float. apply sym_equal; auto with float. apply FnormalNotZero; auto with arith. unfold Fdigit in |- *; apply digit_monotone; auto with arith. repeat rewrite Zabs_eq; auto with zarith. apply LeR0Fnum with (radix := radix); auto with zarith. apply Rle_trans with (r2 := FtoRradix p); auto with real. apply LeR0Fnum with (radix := radix); auto with zarith. unfold FtoRradix in |- *; rewrite FshiftCorrect; auto. Qed. Theorem FnormalLtNeg : forall p q : float, Fnormal p -> Fnormal q -> (q <= 0)%R -> (p < q)%R -> (Fexp q < Fexp p)%Z \/ Fexp p = Fexp q /\ (Fnum p < Fnum q)%Z. intros p q H' H'0 H'1 H'2. cut ((Fexp (Fopp q) < Fexp (Fopp p))%Z \/ Fexp (Fopp q) = Fexp (Fopp p) /\ (Fnum (Fopp q) < Fnum (Fopp p))%Z). simpl in |- *. intros H'3; elim H'3; clear H'3; intros H'3; [ idtac | elim H'3; clear H'3; intros H'3 H'4 ]; auto; right; split; auto with zarith. apply FnormalLtPos; try apply FnormalFop; auto; unfold FtoRradix in |- *; repeat rewrite Fopp_correct; replace 0%R with (-0)%R; auto with real. Qed. Definition nNormMin := Zpower_nat radix (pred precision). Theorem nNormPos : (0 < nNormMin)%Z. unfold nNormMin in |- *; auto with zarith. Qed. Theorem digitnNormMin : digit radix nNormMin = precision. unfold nNormMin, Fdigit in |- *; simpl in |- *; apply digitInv; auto with zarith arith. rewrite Zabs_eq; auto with zarith. Qed. Theorem nNrMMimLevNum : (nNormMin <= Zpos (vNum b))%Z. rewrite pGivesBound. unfold nNormMin in |- *; simpl in |- *; auto with zarith arith. Qed. Hint Resolve nNrMMimLevNum: arith. Definition firstNormalPos := Float nNormMin (- dExp b). Theorem firstNormalPosNormal : Fnormal firstNormalPos. repeat split; unfold firstNormalPos in |- *; simpl in |- *; auto with zarith. rewrite pGivesBound. rewrite Zabs_eq; auto with zarith. unfold nNormMin in |- *; simpl in |- *; auto with zarith arith. apply Zlt_le_weak; auto with zarith. apply nNormPos. rewrite pGivesBound. replace precision with (pred precision + 1). rewrite Zpower_nat_is_exp; auto with zarith. rewrite Zpower_nat_1; auto with zarith. rewrite (fun x => Zmult_comm x radix); unfold nNormMin in |- *; auto with zarith. unfold nNormMin in |- *; auto with zarith. Qed. Theorem pNormal_absolu_min : forall p : float, Fnormal p -> (nNormMin <= Zabs (Fnum p))%Z. intros p H; apply Zmult_le_reg_r with (p := radix); auto with zarith. unfold nNormMin in |- *. pattern radix at 2 in |- *; rewrite <- (Zpower_nat_1 radix). rewrite <- Zpower_nat_is_exp; auto with zarith. replace (pred precision + 1) with precision. rewrite <- pGivesBound; auto with float. rewrite <- (Zabs_eq radix); auto with zarith. rewrite <- Zabs_Zmult; rewrite Zmult_comm; auto with float. generalize precisionNotZero; case precision; simpl in |- *; try (intros tmp; Contradict tmp; auto; fail); intros; rewrite plus_comm; simpl in |- *; auto. Qed. Theorem maxMaxBis : forall (p : float) (z : Z), Fbounded b p -> (Fexp p < z)%Z -> (Fabs p < Float nNormMin z)%R. intros p z H' H'0; apply Rlt_le_trans with (FtoR radix (Float (Zpos (vNum b)) (Zpred z))). unfold FtoRradix in |- *; apply maxMax; auto with zarith; unfold Zpred in |- *; auto with zarith. unfold FtoRradix, FtoR, nNormMin in |- *; simpl in |- *. pattern z at 2 in |- *; replace z with (Zsucc (Zpred z)); [ rewrite powerRZ_Zs; auto with real zarith | unfold Zsucc, Zpred in |- *; ring ]. rewrite <- Rmult_assoc. apply Rmult_le_compat_r; auto with real arith. pattern radix at 2 in |- *; rewrite <- (Zpower_nat_1 radix). rewrite <- Rmult_IZR. rewrite <- Zpower_nat_is_exp. replace (pred precision + 1) with precision. replace (INR (nat_of_P (vNum b))) with (IZR (Zpos (vNum b))). rewrite pGivesBound; auto with real. simpl in |- *; auto. generalize precisionNotZero; case precision; simpl in |- *; auto with arith. intros H'1; Contradict H'1; auto. intros; rewrite plus_comm; simpl in |- *; auto. Qed. Theorem FnormalLtFirstNormalPos : forall p : float, Fnormal p -> (0 <= p)%R -> (firstNormalPos <= p)%R. intros p H' H'0. case (Rle_or_lt firstNormalPos p); intros Lt0; auto with real. case (FnormalLtPos p firstNormalPos); auto. apply firstNormalPosNormal. intros H'1; Contradict H'1; unfold firstNormalPos in |- *; simpl in |- *. apply Zle_not_lt; auto with float. intros H'1; elim H'1; intros H'2 H'3; Contradict H'3. unfold firstNormalPos in |- *; simpl in |- *. apply Zle_not_lt. rewrite <- (Zabs_eq (Fnum p)); auto with float zarith. apply pNormal_absolu_min; auto. apply LeR0Fnum with (radix := radix); auto with arith. Qed. Theorem FnormalLtFirstNormalNeg : forall p : float, Fnormal p -> (p <= 0)%R -> (p <= Fopp firstNormalPos)%R. intros p H' H'0. rewrite <- (Ropp_involutive p); unfold FtoRradix in |- *; repeat rewrite Fopp_correct. apply Ropp_le_contravar; rewrite <- Fopp_correct. apply FnormalLtFirstNormalPos. apply FnormalFop; auto. replace 0%R with (-0)%R; unfold FtoRradix in |- *; try rewrite Fopp_correct; auto with real. Qed. Theorem FsubnormalDigit : forall p : float, Fsubnormal p -> Fdigit radix p < precision. intros p H; unfold Fdigit in |- *. case (Z_eq_dec (Fnum p) 0); intros Z1. rewrite Z1; simpl in |- *; auto with arith. apply lt_S_n; apply le_lt_n_Sm. rewrite <- digitPredVNumiSPrecision. replace (S (digit radix (Fnum p))) with (digit radix (Fnum p) + 1). rewrite <- digitAdd; auto with zarith. apply digit_monotone; auto with float. rewrite (fun x => Zabs_eq (Zpred x)); auto with float zarith. rewrite Zmult_comm; rewrite Zpower_nat_1; auto with float zarith. rewrite plus_comm; simpl in |- *; auto. Qed. Hint Resolve FsubnormalDigit: float. Theorem pSubnormal_absolu_min : forall p : float, Fsubnormal p -> (Zabs (Fnum p) < nNormMin)%Z. intros p H'; apply Zlt_mult_simpl_l with (c := radix); auto with zarith. replace (radix * Zabs (Fnum p))%Z with (Zabs (radix * Fnum p)). replace (radix * nNormMin)%Z with (Zpos (vNum b)); auto with float. rewrite pGivesBound. replace precision with (1 + pred precision). rewrite Zpower_nat_is_exp; auto with zarith; rewrite Zpower_nat_1; auto. generalize precisionNotZero; case precision; simpl in |- *; auto. intros H; Contradict H; auto. rewrite Zabs_Zmult; rewrite (Zabs_eq radix); auto with zarith. Qed. Theorem FsubnormalLtFirstNormalPos : forall p : float, Fsubnormal p -> (0 <= p)%R -> (p < firstNormalPos)%R. intros p H' H'0; unfold FtoRradix, FtoR, firstNormalPos in |- *; simpl in |- *. replace (Fexp p) with (- dExp b)%Z. 2: apply sym_equal; case H'; intros H1 H2; case H2; auto. apply Rmult_lt_compat_r; auto with real arith. apply Rlt_IZR. rewrite <- (Zabs_eq (Fnum p)). 2: apply LeR0Fnum with (radix := radix); auto with zarith. apply pSubnormal_absolu_min; auto. Qed. Theorem FsubnormalnormalLtPos : forall p q : float, Fsubnormal p -> Fnormal q -> (0 <= p)%R -> (0 <= q)%R -> (p < q)%R. intros p q H' H'0 H'1 H'2. apply Rlt_le_trans with (r2 := FtoRradix firstNormalPos). apply FsubnormalLtFirstNormalPos; auto. apply FnormalLtFirstNormalPos; auto. Qed. Theorem FsubnormalnormalLtNeg : forall p q : float, Fsubnormal p -> Fnormal q -> (p <= 0)%R -> (q <= 0)%R -> (q < p)%R. intros p q H' H'0 H'1 H'2. rewrite <- (Ropp_involutive p); rewrite <- (Ropp_involutive q). apply Ropp_gt_lt_contravar; red in |- *. unfold FtoRradix in |- *; repeat rewrite <- Fopp_correct. apply FsubnormalnormalLtPos; auto. apply FsubnormFopp; auto. apply FnormalFop; auto. unfold FtoRradix in |- *; rewrite Fopp_correct; replace 0%R with (-0)%R; auto with real. unfold FtoRradix in |- *; rewrite Fopp_correct; replace 0%R with (-0)%R; auto with real. Qed. Definition Fnormalize (p : float) := match Z_zerop (Fnum p) with | left _ => Float 0 (- dExp b) | right _ => Fshift radix (min (precision - Fdigit radix p) (Zabs_nat (dExp b + Fexp p))) p end. Theorem FnormalizeCorrect : forall p : float, Fnormalize p = p :>R. intros p; unfold Fnormalize in |- *. case (Z_zerop (Fnum p)). case p; intros Fnum1 Fexp1 H'; unfold FtoRradix, FtoR in |- *; rewrite H'; simpl in |- *; auto with real. apply trans_eq with 0%R; auto with real. intros H'; unfold FtoRradix in |- *; apply FshiftCorrect; auto. Qed. Theorem Fnormalize_Fopp : forall p : float, Fnormalize (Fopp p) = Fopp (Fnormalize p). intros p; case p; unfold Fnormalize in |- *; simpl in |- *. intros Fnum1 Fexp1; case (Z_zerop Fnum1); intros H'. rewrite H'; simpl in |- *; auto. case (Z_zerop (- Fnum1)); intros H'0; simpl in |- *; auto. case H'; replace Fnum1 with (- - Fnum1)%Z; auto with zarith. unfold Fopp, Fshift, Fdigit in |- *; simpl in |- *. replace (digit radix (- Fnum1)) with (digit radix Fnum1). apply floatEq; simpl in |- *; auto with zarith. ring. case Fnum1; simpl in |- *; auto. Qed. Theorem FnormalizeBounded : forall p : float, Fbounded b p -> Fbounded b (Fnormalize p). intros p H'; red in |- *; split. unfold Fnormalize in |- *; case (Z_zerop (Fnum p)); auto. intros H'0; simpl in |- *; auto with zarith. intros H'0. apply digitGivesBoundedNum; auto. rewrite FshiftFdigit; auto. apply le_trans with (m := Fdigit radix p + (precision - Fdigit radix p)); auto with arith. rewrite <- le_plus_minus; auto. apply pGivesDigit; auto. unfold Fnormalize in |- *; case (Z_zerop (Fnum p)); auto. simpl in |- *; auto with zarith. generalize H'; case p; unfold Fbounded, Fnormal, Fdigit in |- *; simpl in |- *. intros Fnum1 Fexp1 H'0 H'1. apply Zle_trans with (m := (Fexp1 - Zabs_nat (dExp b + Fexp1))%Z). rewrite inj_abs; auto with zarith. unfold Zminus in |- *; apply Zplus_le_compat_l; auto. apply Zle_Zopp; auto. apply inj_le; auto with arith. Qed. Theorem FnormalizeCanonic : forall p : float, Fbounded b p -> Fcanonic (Fnormalize p). intros p H'. generalize (FnormalizeBounded p H'). unfold Fnormalize in |- *; case (Z_zerop (Fnum p)); auto. intros H'0; right; repeat split; simpl in |- *; auto with zarith. rewrite Zmult_comm; simpl in |- *; red in |- *; simpl in |- *; auto. intros H'1. case (min_or (precision - Fdigit radix p) (Zabs_nat (dExp b + Fexp p))); intros Min; case Min; clear Min; intros MinR MinL. intros H'2; left; split; auto. rewrite MinR; unfold Fshift in |- *; simpl in |- *. apply Zle_trans with (Zabs (radix * (Zpower_nat radix (pred (Fdigit radix p)) * Zpower_nat radix (precision - Fdigit radix p)))). pattern radix at 1 in |- *; rewrite <- (Zpower_nat_1 radix). repeat rewrite <- Zpower_nat_is_exp; auto with zarith. replace (1 + (pred (Fdigit radix p) + (precision - Fdigit radix p))) with precision; auto. rewrite pGivesBound; auto with real. rewrite Zabs_eq; auto with zarith. cut (Fdigit radix p <= precision); auto with float. unfold Fdigit in |- *. generalize (digitNotZero _ radixMoreThanOne _ H'1); case (digit radix (Fnum p)); simpl in |- *; auto. intros tmp; Contradict tmp; auto with arith. intros n H H0; change (precision = S n + (precision - S n)) in |- *. apply le_plus_minus; auto. apply pGivesDigit; auto. repeat rewrite Zabs_Zmult. apply Zle_Zmult_comp_l. apply Zle_ZERO_Zabs. apply Zle_Zmult_comp_r. apply Zle_ZERO_Zabs. rewrite (fun x => Zabs_eq (Zpower_nat radix x)); auto with zarith. unfold Fdigit in |- *; apply digitLess; auto. intros H'0; right; split; auto; split. rewrite MinR; clear MinR; auto. cut (- dExp b <= Fexp p)%Z; [ idtac | auto with float ]. case p; simpl in |- *. intros Fnum1 Fexp1 H'2; rewrite inj_abs; auto with zarith. rewrite MinR. rewrite <- (fun x => Zabs_eq (Zpos x)). unfold Fshift in |- *; simpl in |- *. apply Zlt_le_trans with (Zabs (radix * (Zpower_nat radix (Fdigit radix p) * Zpower_nat radix (Zabs_nat (dExp b + Fexp p))))). repeat rewrite Zabs_Zmult. apply Zmult_gt_0_lt_compat_l. apply Zlt_gt; rewrite Zabs_eq; auto with zarith. apply Zmult_gt_0_lt_compat_r. apply Zlt_gt; rewrite Zabs_eq; auto with zarith. rewrite (fun x => Zabs_eq (Zpower_nat radix x)); auto with zarith. unfold Fdigit in |- *; apply digitMore; auto. pattern radix at 1 in |- *; rewrite <- (Zpower_nat_1 radix). repeat rewrite <- Zpower_nat_is_exp; auto with zarith. apply Zle_trans with (Zabs (Zpower_nat radix precision)). repeat rewrite Zabs_eq; auto with zarith. rewrite pGivesBound. rewrite (fun x => Zabs_eq (Zpower_nat radix x)); auto with zarith. red in |- *; simpl in |- *; red in |- *; intros; discriminate. Qed. Theorem NormalAndSubNormalNotEq : forall p q : float, Fnormal p -> Fsubnormal q -> p <> q :>R. intros p q H' H'0; red in |- *; intros H'1. case (Rtotal_order 0 p); intros H'2. absurd (q < p)%R. rewrite <- H'1; auto with real. apply FsubnormalnormalLtPos; auto with real. rewrite <- H'1; auto with real. absurd (p < q)%R. rewrite <- H'1; auto with real. apply FsubnormalnormalLtNeg; auto with real. rewrite <- H'1; auto with real. elim H'2; intros H'3; try rewrite <- H'3; auto with real. elim H'2; intros H'3; try rewrite <- H'3; auto with real. Qed. Theorem FcanonicUnique : forall p q : float, Fcanonic p -> Fcanonic q -> p = q :>R -> p = q. intros p q H' H'0 H'1; case H'; case H'0; intros H'2 H'3. apply FnormalUnique; auto. Contradict H'1; apply NormalAndSubNormalNotEq; auto. absurd (q = p :>R); auto; apply NormalAndSubNormalNotEq; auto. apply FsubnormalUnique; auto. Qed. Theorem FcanonicLeastExp : forall x y : float, x = y :>R -> Fbounded b x -> Fcanonic y -> (Fexp y <= Fexp x)%Z. intros x y H H0 H1. cut (Fcanonic (Fnormalize x)); [ intros | apply FnormalizeCanonic; auto ]. replace y with (Fnormalize x); [ simpl in |- * | apply FcanonicUnique; auto with real ]. unfold Fnormalize in |- *. case (Z_zerop (Fnum x)); simpl in |- *; intros Z1; auto with float. apply Zplus_le_reg_l with (- Fexp x)%Z. replace (- Fexp x + Fexp x)%Z with (- (0))%Z; try ring. replace (- Fexp x + (Fexp x - min (precision - Fdigit radix x) (Zabs_nat (dExp b + Fexp x))))%Z with (- min (precision - Fdigit radix x) (Zabs_nat (dExp b + Fexp x)))%Z; try ring. apply Zle_Zopp; auto with arith zarith. rewrite <- H. apply FnormalizeCorrect. Qed. Theorem FcanonicLtPos : forall p q : float, Fcanonic p -> Fcanonic q -> (0 <= p)%R -> (p < q)%R -> (Fexp p < Fexp q)%Z \/ Fexp p = Fexp q /\ (Fnum p < Fnum q)%Z. intros p q H' H'0 H'1 H'2; case H'; case H'0. intros H'3 H'4; apply FnormalLtPos; auto. intros H'3 H'4; absurd (p < q)%R; auto. apply Rlt_asym. apply FsubnormalnormalLtPos; auto. apply Rle_trans with (r2 := FtoRradix p); auto with real. intros H'3 H'4; case (Z_eq_dec (Fexp q) (- dExp b)); intros H'5. right; split. rewrite H'5; case H'4; intros H1 H2; case H2; auto. apply Rlt_Fexp_eq_Zlt with (radix := radix); auto with zarith. rewrite H'5; case H'4; intros H1 H2; case H2; auto. left. replace (Fexp p) with (- dExp b)%Z; [ idtac | apply sym_equal; auto with float ]. case (Zle_lt_or_eq (- dExp b) (Fexp q)); auto with float zarith. intros H'3 H'4; right; split. apply trans_equal with (- dExp b)%Z; auto with float. apply sym_equal; auto with float. apply FsubnormalLt; auto. Qed. Theorem FcanonicLePos : forall p q : float, Fcanonic p -> Fcanonic q -> (0 <= p)%R -> (p <= q)%R -> (Fexp p < Fexp q)%Z \/ Fexp p = Fexp q /\ (Fnum p <= Fnum q)%Z. intros p q H' H'0 H'1 H'2. case H'2; intros H'3. case FcanonicLtPos with (p := p) (q := q); auto with zarith arith. rewrite FcanonicUnique with (p := p) (q := q); auto with zarith arith. Qed. Theorem Fcanonic_Rle_Zle : forall x y : float, Fcanonic x -> Fcanonic y -> (Rabs x <= Rabs y)%R -> (Fexp x <= Fexp y)%Z. intros x y H H0 H1. cut (forall z : float, Fexp z = Fexp (Fabs z) :>Z); [ intros E | intros; unfold Fabs in |- *; simpl in |- *; auto with zarith ]. rewrite (E x); rewrite (E y). cut (Fcanonic (Fabs x)); [ intros D | apply FcanonicFabs; auto ]. cut (Fcanonic (Fabs y)); [ intros G | apply FcanonicFabs; auto ]. case H1; intros Z2. case (FcanonicLtPos (Fabs x) (Fabs y)); auto with zarith. rewrite (Fabs_correct radix); auto with real zarith. repeat rewrite (Fabs_correct radix); auto with real zarith. rewrite (FcanonicUnique (Fabs x) (Fabs y)); auto with float zarith. repeat rewrite (Fabs_correct radix); auto with real zarith. Qed. Theorem FcanonicLtNeg : forall p q : float, Fcanonic p -> Fcanonic q -> (q <= 0)%R -> (p < q)%R -> (Fexp q < Fexp p)%Z \/ Fexp p = Fexp q /\ (Fnum p < Fnum q)%Z. intros p q H' H'0 H'1 H'2. cut ((Fexp (Fopp q) < Fexp (Fopp p))%Z \/ Fexp (Fopp q) = Fexp (Fopp p) /\ (Fnum (Fopp q) < Fnum (Fopp p))%Z). simpl in |- *. intros H'3; elim H'3; clear H'3; intros H'3; [ idtac | elim H'3; clear H'3; intros H'3 H'4 ]; auto; right; split; auto with zarith. apply FcanonicLtPos; try apply FcanonicFopp; auto; unfold FtoRradix in |- *; repeat rewrite Fopp_correct; replace 0%R with (-0)%R; auto with real. Qed. Theorem FcanonicFnormalizeEq : forall p : float, Fcanonic p -> Fnormalize p = p. intros p H'. apply FcanonicUnique; auto. apply FnormalizeCanonic; auto. apply FcanonicBound with (1 := H'); auto. apply FnormalizeCorrect; auto. Qed. Theorem FcanonicPosFexpRlt : forall x y : float, (0 <= x)%R -> (0 <= y)%R -> Fcanonic x -> Fcanonic y -> (Fexp x < Fexp y)%Z -> (x < y)%R. intros x y H' H'0 H'1 H'2 H'3. case (Rle_or_lt y x); auto. intros H'4; case H'4; clear H'4; intros H'4. case FcanonicLtPos with (p := y) (q := x); auto. intros H'5; Contradict H'3; auto with zarith. intros H'5; elim H'5; intros H'6 H'7; clear H'5; Contradict H'3; rewrite H'6; auto with zarith. Contradict H'3. rewrite FcanonicUnique with (p := x) (q := y); auto with zarith. Qed. Theorem FcanonicNegFexpRlt : forall x y : float, (x <= 0)%R -> (y <= 0)%R -> Fcanonic x -> Fcanonic y -> (Fexp x < Fexp y)%Z -> (y < x)%R. intros x y H' H'0 H'1 H'2 H'3. case (Rle_or_lt x y); auto. intros H'4; case H'4; clear H'4; intros H'4. case FcanonicLtNeg with (p := x) (q := y); auto. intros H'5; Contradict H'3; auto with zarith. intros H'5; elim H'5; intros H'6 H'7; clear H'5; Contradict H'3; rewrite H'6; auto with zarith. Contradict H'3. rewrite FcanonicUnique with (p := x) (q := y); auto with zarith. Qed. Theorem FnormalBoundAbs2 : forall p : float, Fnormal p -> (Zpos (vNum b) * Float 1%nat (Zpred (Fexp p)) <= Fabs p)%R. intros p H'; unfold FtoRradix, FtoR in |- *; simpl in |- *. replace (1 * powerRZ radix (Zpred (Fexp p)))%R with (powerRZ radix (Zpred (Fexp p))); [ idtac | ring ]. pattern (Fexp p) at 2 in |- *; replace (Fexp p) with (Zsucc (Zpred (Fexp p))); [ rewrite powerRZ_Zs; auto with real zarith | unfold Zsucc, Zpred in |- *; ring ]. repeat rewrite <- Rmult_assoc. apply Rmult_le_compat_r; auto with real arith. repeat rewrite INR_IZR_INZ; rewrite (fun x => inject_nat_convert (Zpos x) x); auto. rewrite <- Rmult_IZR; apply Rle_IZR. rewrite <- (Zabs_eq radix); auto with zarith. rewrite <- Zabs_Zmult; rewrite Zmult_comm; auto with float. Qed. Theorem vNumbMoreThanOne : (1 < Zpos (vNum b))%Z. replace 1%Z with (Z_of_nat 1); [ idtac | simpl in |- *; auto ]. rewrite <- (Zpower_nat_O radix); rewrite pGivesBound; auto with zarith. Qed. Theorem PosNormMin : Zpos (vNum b) = (radix * nNormMin)%Z. pattern radix at 1 in |- *; rewrite <- (Zpower_nat_1 radix); unfold nNormMin in |- *. rewrite pGivesBound; rewrite <- Zpower_nat_is_exp. generalize precisionNotZero; case precision; auto with zarith. Qed. Theorem FnormalPpred : forall x : Z, (- dExp b <= x)%Z -> Fnormal (Float (pPred (vNum b)) x). intros x H; (cut (0 <= pPred (vNum b))%Z; [ intros Z1 | unfold pPred in |- *; auto with zarith ]). repeat split; simpl in |- *; auto with zarith. rewrite (Zabs_eq (pPred (vNum b))). unfold pPred in |- *; auto with zarith. unfold pPred in |- *; rewrite pGivesBound; auto with zarith. rewrite Zabs_Zmult; repeat rewrite Zabs_eq; auto with zarith. apply Zle_trans with ((1 + 1) * pPred (vNum b))%Z; auto with zarith. replace ((1 + 1) * pPred (vNum b))%Z with (pPred (vNum b) + pPred (vNum b))%Z; auto with zarith. replace (Zpos (vNum b)) with (1 + Zpred (Zpos (vNum b)))%Z; unfold pPred in |- *; auto with zarith. apply Zplus_le_compat_r; apply Zle_Zpred. apply vNumbMoreThanOne. Qed. Theorem FcanonicPpred : forall x : Z, (- dExp b <= x)%Z -> Fcanonic (Float (pPred (vNum b)) x). intros x H; left; apply FnormalPpred; auto. Qed. Theorem FnormalNnormMin : forall x : Z, (- dExp b <= x)%Z -> Fnormal (Float nNormMin x). intros x H; (cut (0 < nNormMin)%Z; [ intros Z1 | apply nNormPos ]). repeat split; simpl in |- *; auto with zarith. rewrite Zabs_eq; auto with zarith. rewrite PosNormMin. pattern nNormMin at 1 in |- *; replace nNormMin with (1 * nNormMin)%Z; auto with zarith. apply Zmult_gt_0_lt_compat_r; auto with zarith. rewrite PosNormMin; auto with zarith. Qed. Theorem FcanonicNnormMin : forall x : Z, (- dExp b <= x)%Z -> Fcanonic (Float nNormMin x). intros x H; left; apply FnormalNnormMin; auto. Qed. Theorem boundedNorMinGivesExp : forall (x : Z) (p : float), Fbounded b p -> (- dExp b <= x)%Z -> (Float nNormMin x <= p)%R -> (p <= Float (pPred (vNum b)) x)%R -> Fexp (Fnormalize p) = x. intros x p H' H'0 H'1 H'2. cut (0 <= p)%R; [ intros Rle1 | idtac ]. case (FcanonicLePos (Float nNormMin x) (Fnormalize p)); try rewrite FnormalizeCorrect; simpl in |- *; auto with float zarith. apply FcanonicNnormMin; auto. apply FnormalizeCanonic; auto. apply (LeFnumZERO radix); simpl in |- *; auto. apply Zlt_le_weak; apply nNormPos. intros H'3. case (FcanonicLePos (Fnormalize p) (Float (pPred (vNum b)) x)); try rewrite FnormalizeCorrect; simpl in |- *; auto. apply FnormalizeCanonic; auto. apply FcanonicPpred; auto. intros H'4; Contradict H'4; auto with zarith. intros (H'4, H'5); auto. apply Rle_trans with (2 := H'1). apply (LeFnumZERO radix); simpl in |- *; auto with zarith. apply Zlt_le_weak; apply nNormPos. Qed. End Fnormalized_Def. Hint Resolve FnormalBounded FnormalPrecision: float. Hint Resolve FnormalNotZero nNrMMimLevNum firstNormalPosNormal FsubnormFopp FsubnormalLtFirstNormalPos FnormalizeBounded FcanonicFopp FcanonicFabs FnormalizeCanonic: float. Hint Resolve nNrMMimLevNum: arith. Hint Resolve FsubnormalFbounded FsubnormalFexp FsubnormalDigit: float. Hint Resolve FcanonicBound: float. Float8.4/Fodd.v0000644000423700002640000003346312032774525013124 0ustar sboldotoccata(**************************************************************************** IEEE754 : Fodd Laurent Thery ******************************************************************************) Require Export Fmin. Section FOdd. Variable b : Fbound. Variable radix : Z. Variable precision : nat. Coercion Local FtoRradix := FtoR radix. Hypothesis radixMoreThanOne : (1 < radix)%Z. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. (* We define the parity predicates*) Definition Even (z : Z) : Prop := exists z1 : _, z = (2 * z1)%Z. Definition Odd (z : Z) : Prop := exists z1 : _, z = (2 * z1 + 1)%Z. Theorem OddSEven : forall n : Z, Odd n -> Even (Zsucc n). intros n H'; case H'; intros m H'1; exists (Zsucc m). rewrite H'1; unfold Zsucc in |- *; ring. Qed. Theorem EvenSOdd : forall n : Z, Even n -> Odd (Zsucc n). intros n H'; case H'; intros m H'1; exists m. rewrite H'1; unfold Zsucc in |- *; ring. Qed. Hint Resolve OddSEven EvenSOdd: zarith. Theorem OddSEvenInv : forall n : Z, Odd (Zsucc n) -> Even n. intros n H'; case H'; intros m H'1; exists m. apply Zsucc_inj; rewrite H'1; (unfold Zsucc in |- *; ring). Qed. Theorem EvenSOddInv : forall n : Z, Even (Zsucc n) -> Odd n. intros n H'; case H'; intros m H'1; exists (Zpred m). apply Zsucc_inj; rewrite H'1; (unfold Zsucc, Zpred in |- *; ring). Qed. Theorem EvenO : Even 0. exists 0%Z; simpl in |- *; auto. Qed. Hint Resolve EvenO: zarith. Theorem Odd1 : Odd 1. exists 0%Z; simpl in |- *; auto. Qed. Hint Resolve Odd1: zarith. Theorem OddOpp : forall z : Z, Odd z -> Odd (- z). intros z H; case H; intros z1 H1; exists (- Zsucc z1)%Z; rewrite H1. unfold Zsucc in |- *; ring. Qed. Theorem EvenOpp : forall z : Z, Even z -> Even (- z). intros z H; case H; intros z1 H1; exists (- z1)%Z; rewrite H1; ring. Qed. Hint Resolve OddOpp EvenOpp: zarith. Theorem OddEvenDec : forall n : Z, {Odd n} + {Even n}. intros z; case z; simpl in |- *; auto with zarith. intros p; case p; simpl in |- *; auto with zarith. intros p1; left; exists (Zpos p1); rewrite Zplus_comm; simpl in |- *; auto. intros p1; right; exists (Zpos p1); simpl in |- *; auto. change (forall p : positive, {Odd (- Zpos p)} + {Even (- Zpos p)}) in |- *. intros p; case p; auto with zarith. intros p1; left; apply OddOpp; exists (Zpos p1); rewrite Zplus_comm; simpl in |- *; auto. intros p1; right; apply EvenOpp; exists (Zpos p1); simpl in |- *; auto. Qed. Theorem OddNEven : forall n : Z, Odd n -> ~ Even n. intros n H1; red in |- *; intros H2; case H1; case H2; intros z1 Hz1 z2 Hz2. absurd (n = n); auto. pattern n at 1 in |- *; rewrite Hz1; rewrite Hz2; repeat rewrite (fun x => Zplus_comm x 1). case z1; case z2; simpl in |- *; try (intros; red in |- *; intros; discriminate). intros p p0; case p; simpl in |- *; try (intros; red in |- *; intros; discriminate). Qed. Theorem EvenNOdd : forall n : Z, Even n -> ~ Odd n. intros n H1; red in |- *; intros H2; case H1; case H2; intros z1 Hz1 z2 Hz2. absurd (n = n); auto. pattern n at 1 in |- *; rewrite Hz1; rewrite Hz2; repeat rewrite (fun x => Zplus_comm x 1). case z1; case z2; simpl in |- *; try (intros; red in |- *; intros; discriminate). intros p p0; case p0; simpl in |- *; try (intros; red in |- *; intros; discriminate). Qed. Hint Resolve OddNEven EvenNOdd: zarith. Theorem EvenPlus1 : forall n m : Z, Even n -> Even m -> Even (n + m). intros n m H H0; case H; case H0; intros z1 Hz1 z2 Hz2. exists (z2 + z1)%Z; try rewrite Hz1; try rewrite Hz2; ring. Qed. Theorem EvenPlus2 : forall n m : Z, Odd n -> Odd m -> Even (n + m). intros n m H H0; case H; case H0; intros z1 Hz1 z2 Hz2. exists (z2 + z1 + 1)%Z; try rewrite Hz1; try rewrite Hz2; ring. Qed. Theorem OddPlus1 : forall n m : Z, Odd n -> Even m -> Odd (n + m). intros n m H H0; case H; case H0; intros z1 Hz1 z2 Hz2. exists (z2 + z1)%Z; try rewrite Hz1; try rewrite Hz2; ring. Qed. Theorem OddPlus2 : forall n m : Z, Even n -> Odd m -> Odd (n + m). intros n m H H0; case H; case H0; intros z1 Hz1 z2 Hz2. exists (z2 + z1)%Z; try rewrite Hz1; try rewrite Hz2; ring. Qed. Hint Resolve EvenPlus1 EvenPlus2 OddPlus1 OddPlus2: zarith. Theorem EvenPlusInv1 : forall n m : Z, Even (n + m) -> Even n -> Even m. intros n m H H0; replace m with (n + m + - n)%Z; auto with zarith. Qed. Theorem EvenPlusInv2 : forall n m : Z, Even (n + m) -> Odd n -> Odd m. intros n m H H0; replace m with (n + m + - n)%Z; auto with zarith. Qed. Theorem OddPlusInv1 : forall n m : Z, Odd (n + m) -> Odd m -> Even n. intros n m H H0; replace n with (n + m + - m)%Z; auto with zarith. Qed. Theorem OddPlusInv2 : forall n m : Z, Odd (n + m) -> Even m -> Odd n. intros n m H H0; replace n with (n + m + - m)%Z; auto with zarith. Qed. Theorem EvenMult1 : forall n m : Z, Even n -> Even (n * m). intros n m H; case H; intros z1 Hz1; exists (z1 * m)%Z; rewrite Hz1; ring. Qed. Theorem EvenMult2 : forall n m : Z, Even m -> Even (n * m). intros n m H; case H; intros z1 Hz1; exists (z1 * n)%Z; rewrite Hz1; ring. Qed. Hint Resolve EvenMult1 EvenMult2: zarith. Theorem OddMult : forall n m : Z, Odd n -> Odd m -> Odd (n * m). intros n m H1 H2; case H1; case H2; intros z1 Hz1 z2 Hz2; exists (2 * z1 * z2 + z1 + z2)%Z; rewrite Hz1; rewrite Hz2; ring. Qed. Hint Resolve OddMult: zarith. Theorem EvenMultInv : forall n m : Z, Even (n * m) -> Odd n -> Even m. intros n m H H0; case (OddEvenDec m); auto; intros Z1. Contradict H; auto with zarith. Qed. Theorem OddMultInv : forall n m : Z, Odd (n * m) -> Odd n. intros n m H; case (OddEvenDec n); auto; intros Z1. Contradict H; auto with zarith. Qed. Theorem EvenExp : forall (n : Z) (m : nat), Even n -> Even (Zpower_nat n (S m)). intros n m; elim m. rewrite Zpower_nat_1; simpl in |- *; auto with zarith. intros n0 H H0; replace (S (S n0)) with (1 + S n0); auto with arith. rewrite Zpower_nat_is_exp; rewrite Zpower_nat_1; simpl in |- *; auto with zarith. Qed. Theorem OddExp : forall (n : Z) (m : nat), Odd n -> Odd (Zpower_nat n m). intros n m; elim m; simpl in |- *. rewrite Zpower_nat_O; simpl in |- *; auto with zarith. intros n0 H H0; replace (S n0) with (1 + n0); auto with arith. rewrite Zpower_nat_is_exp; rewrite Zpower_nat_1; simpl in |- *; auto with zarith. Qed. Hint Resolve OddExp EvenExp: zarith. Definition Feven (p : float) := Even (Fnum p). Definition Fodd (p : float) := Odd (Fnum p). Theorem FevenO : forall p : float, is_Fzero p -> Feven p. intros p H'; red in |- *; rewrite H'; simpl in |- *; auto with zarith. Qed. Theorem FevenOrFodd : forall p : float, Feven p \/ Fodd p. intros p; case (OddEvenDec (Fnum p)); auto. Qed. Theorem FevenSucProp : forall p : float, (Fodd p -> Feven (FSucc b radix precision p)) /\ (Feven p -> Fodd (FSucc b radix precision p)). intros p; unfold FSucc, Fodd, Feven in |- *. generalize (Z_eq_bool_correct (Fnum p) (pPred (vNum b))); case (Z_eq_bool (Fnum p) (pPred (vNum b))); intros H'1. rewrite H'1; simpl in |- *; auto. unfold pPred in |- *; rewrite pGivesBound; unfold nNormMin in |- *. case (OddEvenDec radix); auto with zarith. intros H'; split; intros H'0; auto with zarith. apply EvenMultInv with (n := radix); auto. pattern radix at 1 in |- *; rewrite <- Zpower_nat_1; rewrite <- Zpower_nat_is_exp. replace (1 + pred precision) with precision; [ idtac | inversion precisionGreaterThanOne; auto ]. rewrite (Zsucc_pred (Zpower_nat radix precision)); auto with zarith. intros H'; split; intros H'0; auto with zarith. replace (pred precision) with (S (pred (pred precision))); auto with zarith. Contradict H'0; apply OddNEven. replace (Zpred (Zpower_nat radix precision)) with (Zpower_nat radix precision + - (1))%Z; [ idtac | unfold Zpred in |- *; simpl in |- *; auto ]. replace precision with (S (pred precision)); [ auto with zarith | inversion precisionGreaterThanOne; auto ]. generalize (Z_eq_bool_correct (Fnum p) (- nNormMin radix precision)); case (Z_eq_bool (Fnum p) (- nNormMin radix precision)); intros H'2. generalize (Z_eq_bool_correct (Fexp p) (- dExp b)); case (Z_eq_bool (Fexp p) (- dExp b)); intros H'3. simpl in |- *; auto with zarith. simpl in |- *; auto with zarith. rewrite H'2; unfold pPred, nNormMin in |- *; rewrite pGivesBound. case (OddEvenDec radix); auto with zarith. intros H'; split; intros H'0; auto with zarith. apply EvenOpp; apply OddSEvenInv; rewrite <- Zsucc_pred; auto with zarith. Contradict H'0; replace precision with (S (pred precision)); [ auto with zarith | inversion precisionGreaterThanOne; auto ]. intros H'; split; intros H'0; auto with zarith. Contradict H'0; replace (pred precision) with (S (pred (pred precision))); [ auto with zarith | auto with zarith ]. replace precision with (S (pred precision)); [ auto with zarith | inversion precisionGreaterThanOne; auto ]. apply OddOpp; apply EvenSOddInv; rewrite <- Zsucc_pred; auto with zarith. simpl in |- *; auto with zarith. Qed. Theorem FoddSuc : forall p : float, Fodd p -> Feven (FSucc b radix precision p). intros p H'; case (FevenSucProp p); auto. Qed. Theorem FevenSuc : forall p : float, Feven p -> Fodd (FSucc b radix precision p). intros p H'; case (FevenSucProp p); auto. Qed. Theorem FevenFop : forall p : float, Feven p -> Feven (Fopp p). intros p; unfold Feven, Fopp in |- *; simpl in |- *; auto with zarith. Qed. Theorem FoddFop : forall p : float, Fodd p -> Fodd (Fopp p). intros p; unfold Fodd, Fopp in |- *; simpl in |- *; auto with zarith. Qed. Theorem FevenPred : forall p : float, Fodd p -> Feven (FPred b radix precision p). intros p H'; rewrite FPredFopFSucc; auto with arith. apply FevenFop; auto. apply FoddSuc; auto. apply FoddFop; auto with arith. Qed. Theorem FoddPred : forall p : float, Feven p -> Fodd (FPred b radix precision p). intros p H'; rewrite FPredFopFSucc; auto with arith. apply FoddFop; auto. apply FevenSuc; auto. apply FevenFop; auto. Qed. Definition FNodd (p : float) := Fodd (Fnormalize radix b precision p). Definition FNeven (p : float) := Feven (Fnormalize radix b precision p). Theorem FNoddEq : forall f1 f2 : float, Fbounded b f1 -> Fbounded b f2 -> f1 = f2 :>R -> FNodd f1 -> FNodd f2. intros f1 f2 H' H'0 H'1 H'2; red in |- *. rewrite FcanonicUnique with (3 := pGivesBound) (p := Fnormalize radix b precision f2) (q := Fnormalize radix b precision f1); auto with float arith. repeat rewrite FnormalizeCorrect; auto. Qed. Theorem FNevenEq : forall f1 f2 : float, Fbounded b f1 -> Fbounded b f2 -> f1 = f2 :>R -> FNeven f1 -> FNeven f2. intros f1 f2 H' H'0 H'1 H'2; red in |- *. rewrite FcanonicUnique with (3 := pGivesBound) (p := Fnormalize radix b precision f2) (q := Fnormalize radix b precision f1); auto with float arith. repeat rewrite FnormalizeCorrect; auto. Qed. Theorem FNevenFop : forall p : float, FNeven p -> FNeven (Fopp p). intros p; unfold FNeven in |- *. rewrite Fnormalize_Fopp; auto with arith. intros; apply FevenFop; auto. Qed. Theorem FNoddFop : forall p : float, FNodd p -> FNodd (Fopp p). intros p; unfold FNodd in |- *. rewrite Fnormalize_Fopp; auto with arith. intros; apply FoddFop; auto. Qed. Theorem FNoddSuc : forall p : float, Fbounded b p -> FNodd p -> FNeven (FNSucc b radix precision p). unfold FNodd, FNeven, FNSucc in |- *. intros p H' H'0. rewrite FcanonicFnormalizeEq; auto with float arith. apply FoddSuc; auto with float arith. Qed. Theorem FNevenSuc : forall p : float, Fbounded b p -> FNeven p -> FNodd (FNSucc b radix precision p). unfold FNodd, FNeven, FNSucc in |- *. intros p H' H'0. rewrite FcanonicFnormalizeEq; auto with float arith. apply FevenSuc; auto. Qed. Theorem FNevenPred : forall p : float, Fbounded b p -> FNodd p -> FNeven (FNPred b radix precision p). unfold FNodd, FNeven, FNPred in |- *. intros p H' H'0. rewrite FcanonicFnormalizeEq; auto with float arith. apply FevenPred; auto. Qed. Theorem FNoddPred : forall p : float, Fbounded b p -> FNeven p -> FNodd (FNPred b radix precision p). unfold FNodd, FNeven, FNPred in |- *. intros p H' H'0. rewrite FcanonicFnormalizeEq; auto with float arith. apply FoddPred; auto. Qed. Theorem FNevenOrFNodd : forall p : float, FNeven p \/ FNodd p. intros p; unfold FNeven, FNodd in |- *; apply FevenOrFodd. Qed. Theorem FnOddNEven : forall n : float, FNodd n -> ~ FNeven n. intros n H'; unfold FNeven, Feven in |- *; apply OddNEven; auto. Qed. Theorem FEvenD : forall p : float, Fbounded b p -> Feven p -> exists q : float, Fbounded b q /\ p = (2%nat * q)%R :>R. intros p H H0; case H0. intros z Hz; exists (Float z (Fexp p)); split; auto. repeat split; simpl in |- *; auto with float. apply Zle_lt_trans with (Zabs (Fnum p)); auto with float zarith. rewrite Hz; rewrite Zabs_Zmult; replace (Zabs 2 * Zabs z)%Z with (Zabs z + Zabs z)%Z; auto with zarith arith. pattern (Zabs z) at 1 in |- *; replace (Zabs z) with (0 + Zabs z)%Z; auto with zarith. rewrite (Zabs_eq 2); auto with zarith. unfold FtoRradix, FtoR in |- *; simpl in |- *. rewrite Hz; rewrite Rmult_IZR; simpl in |- *; ring. Qed. Theorem FNEvenD : forall p : float, Fbounded b p -> FNeven p -> exists q : float, Fbounded b q /\ p = (2%nat * q)%R :>R. intros p H' H'0; case (FEvenD (Fnormalize radix b precision p)); auto with float zarith arith. intros x H'1; elim H'1; intros H'2 H'3; clear H'1; exists x; split; auto. apply sym_eq. rewrite <- H'3; auto. unfold FtoRradix in |- *; apply FnormalizeCorrect; auto. Qed. End FOdd. Hint Resolve FevenO FoddSuc FevenSuc FevenFop FoddFop FevenPred FoddPred FNevenFop FNoddFop FNoddSuc FNevenSuc FNevenPred FNoddPred: float. Float8.4/Fop.v0000644000423700002640000001567712032774525013003 0ustar sboldotoccata(**************************************************************************** IEEE754 : Fop Laurent Thery ******************************************************************************) Require Export Fcomp. Section operations. Variable radix : Z. Coercion Local FtoRradix := FtoR radix. Hypothesis radixNotZero : (0 < radix)%Z. Definition Fplus (x y : float) := Float (Fnum x * Zpower_nat radix (Zabs_nat (Fexp x - Zmin (Fexp x) (Fexp y))) + Fnum y * Zpower_nat radix (Zabs_nat (Fexp y - Zmin (Fexp x) (Fexp y)))) (Zmin (Fexp x) (Fexp y)). Theorem Fplus_correct : forall x y : float, Fplus x y = (x + y)%R :>R. intros x y; unfold Fplus, Fshift, FtoRradix, FtoR in |- *; simpl in |- *. rewrite plus_IZR. rewrite Rmult_comm; rewrite Rmult_plus_distr_l; auto. repeat rewrite Rmult_IZR. repeat rewrite (Rmult_comm (Fnum x)); repeat rewrite (Rmult_comm (Fnum y)). repeat rewrite Zpower_nat_Z_powerRZ; auto. repeat rewrite <- Rmult_assoc. repeat rewrite <- powerRZ_add; auto with real zarith arith. repeat rewrite inj_abs; auto with real zarith. repeat rewrite Zplus_minus; auto. Qed. Definition Fopp (x : float) := Float (- Fnum x) (Fexp x). Theorem Fopp_correct : forall x : float, Fopp x = (- x)%R :>R. unfold FtoRradix, FtoR, Fopp in |- *; simpl in |- *. intros x. rewrite Ropp_Ropp_IZR; auto with real. Qed. Theorem Fopp_Fopp : forall p : float, Fopp (Fopp p) = p. intros p; case p; unfold Fopp in |- *; simpl in |- *; auto. intros; rewrite Zopp_involutive; auto. Qed. Theorem Fzero_opp : forall f : float, ~ is_Fzero f -> ~ is_Fzero (Fopp f). intros f; case f; intros n e; case n; unfold is_Fzero in |- *; simpl in |- *; auto with zarith; intros; red in |- *; intros; discriminate. Qed. Theorem Fdigit_opp : forall x : float, Fdigit radix (Fopp x) = Fdigit radix x. intros x; unfold Fopp, Fdigit in |- *; simpl in |- *. rewrite <- (digit_abs radix (- Fnum x)). rewrite <- (digit_abs radix (Fnum x)). case (Fnum x); simpl in |- *; auto. Qed. Definition Fabs (x : float) := Float (Zabs (Fnum x)) (Fexp x). Theorem Fabs_correct1 : forall x : float, (0 <= FtoR radix x)%R -> Fabs x = x :>R. intros x; case x; unfold FtoRradix, FtoR in |- *; simpl in |- *. intros Fnum1 Fexp1 H'. repeat rewrite <- (Rmult_comm (powerRZ radix Fexp1)); apply Rmult_eq_compat_l; auto. cut (0 <= Fnum1)%Z. unfold Zabs, Zle in |- *. case Fnum1; simpl in |- *; auto. intros p H'0; case H'0; auto. apply Znot_gt_le; auto. Contradict H'. apply Rgt_not_le; auto. rewrite Rmult_comm. replace 0%R with (powerRZ radix Fexp1 * 0)%R; auto with real. red in |- *; apply Rmult_lt_compat_l; auto with real zarith. replace 0%R with (IZR 0); auto with real zarith arith. Qed. Theorem Fabs_correct2 : forall x : float, (FtoR radix x <= 0)%R -> Fabs x = (- x)%R :>R. intros x; case x; unfold FtoRradix, FtoR in |- *; simpl in |- *. intros Fnum1 Fexp1 H'. rewrite <- Ropp_mult_distr_l_reverse; repeat rewrite <- (Rmult_comm (powerRZ radix Fexp1)); apply Rmult_eq_compat_l; auto. cut (Fnum1 <= 0)%Z. unfold Zabs, Zle in |- *. case Fnum1; simpl in |- *; auto with real. intros p H'0; case H'0; auto. apply Znot_gt_le. Contradict H'. apply Rgt_not_le; auto. rewrite Rmult_comm. replace 0%R with (powerRZ radix Fexp1 * 0)%R; auto with real. red in |- *; apply Rmult_lt_compat_l; auto with real arith. replace 0%R with (IZR 0); auto with real zarith arith. Qed. Theorem Fabs_correct : forall x : float, Fabs x = Rabs x :>R. intros x; unfold Rabs in |- *. case (Rcase_abs x); intros H1. unfold FtoRradix in |- *; apply Fabs_correct2; auto with arith. apply Rlt_le; auto. unfold FtoRradix in |- *; apply Fabs_correct1; auto with arith. apply Rge_le; auto. Qed. Theorem RleFexpFabs : forall p : float, p <> 0%R :>R -> (Float 1%nat (Fexp p) <= Fabs p)%R. intros p H'. unfold FtoRradix, FtoR, Fabs in |- *; simpl in |- *. apply Rmult_le_compat_r; auto with real arith. rewrite Zabs_absolu. replace 1%R with (INR 1); auto with real. repeat rewrite <- INR_IZR_INZ; apply Rle_INR; auto. cut (Zabs_nat (Fnum p) <> 0); auto with zarith. Contradict H'. unfold FtoRradix, FtoR in |- *; simpl in |- *. replace (Fnum p) with 0%Z; try (simpl;ring). generalize H'; case (Fnum p); simpl in |- *; auto with zarith arith; intros p0 H'3; Contradict H'3; auto with zarith arith. Qed. Theorem Fabs_Fzero : forall x : float, ~ is_Fzero x -> ~ is_Fzero (Fabs x). intros x; case x; unfold is_Fzero in |- *; simpl in |- *. intros n m; case n; simpl in |- *; auto with zarith; intros; red in |- *; discriminate. Qed. Hint Resolve Fabs_Fzero: float. Theorem Fdigit_abs : forall x : float, Fdigit radix (Fabs x) = Fdigit radix x. intros x; unfold Fabs, Fdigit in |- *; simpl in |- *. case (Fnum x); auto. Qed. Definition Fminus (x y : float) := Fplus x (Fopp y). Theorem Fminus_correct : forall x y : float, Fminus x y = (x - y)%R :>R. intros x y; unfold Fminus in |- *. rewrite Fplus_correct. rewrite Fopp_correct; auto. Qed. Theorem Fopp_Fminus : forall p q : float, Fopp (Fminus p q) = Fminus q p. intros p q; case p; case q; unfold Fopp, Fminus, Fplus in |- *; simpl in |- *; auto. intros; apply floatEq; simpl in |- *; repeat rewrite (Zmin_sym Fexp0 Fexp); repeat rewrite Zopp_mult_distr_l_reverse; auto with zarith. Qed. Theorem Fopp_Fminus_dist : forall p q : float, Fopp (Fminus p q) = Fminus (Fopp p) (Fopp q). intros p q; case p; case q; unfold Fopp, Fminus, Fplus in |- *; simpl in |- *; auto. intros; apply floatEq; simpl in |- *; repeat rewrite (Zmin_sym Fexp0 Fexp); repeat rewrite Zopp_mult_distr_l_reverse; auto with zarith. Qed. Theorem minusSameExp : forall x y : float, Fexp x = Fexp y -> Fminus x y = Float (Fnum x - Fnum y) (Fexp x). intros x y; case x; case y; unfold Fminus, Fplus, Fopp in |- *; simpl in |- *. intros Fnum1 Fexp1 Fnum2 Fexp2 H'; rewrite <- H'. repeat rewrite Zmin_n_n. apply floatEq; simpl in |- *; auto. replace (Zabs_nat (Fexp2 - Fexp2)) with 0; auto with zarith arith. replace (Zpower_nat radix 0) with (Z_of_nat 1); simpl in |- *; auto with zarith arith. replace (Fexp2 - Fexp2)%Z with 0%Z; simpl in |- *; auto with zarith arith. Qed. Definition Fmult (x y : float) := Float (Fnum x * Fnum y) (Fexp x + Fexp y). Definition Fmult_correct : forall x y : float, Fmult x y = (x * y)%R :>R. intros x y; unfold FtoRradix, FtoR, Fmult in |- *; simpl in |- *; auto. rewrite powerRZ_add; auto with real zarith. repeat rewrite Rmult_IZR. repeat rewrite Rmult_assoc. repeat rewrite (Rmult_comm (Fnum y)). repeat rewrite <- Rmult_assoc. repeat rewrite Zmult_assoc_reverse; auto. Qed. Theorem oneZplus : forall x y : Z, Float 1%nat (x + y) = Fmult (Float 1%nat x) (Float 1%nat y). intros x y; unfold Fmult in |- *; auto. Qed. End operations. Hint Resolve Fabs_Fzero: float. Hint Resolve Fzero_opp: float.Float8.4/Fprop.v0000644000423700002640000001236412032774525013333 0ustar sboldotoccata(**************************************************************************** IEEE754 : Fprop Laurent Thery ******************************************************************************) Require Export Fbound. Section Fprop. Variable radix : Z. Hypothesis radixMoreThanOne : (1 < radix)%Z. Coercion Local FtoRradix := FtoR radix. Variable b : Fbound. Theorem SterbenzAux : forall x y : float, Fbounded b x -> Fbounded b y -> (y <= x)%R -> (x <= 2%nat * y)%R -> Fbounded b (Fminus radix x y). intros x y H' H'0 H'1 H'2. cut (0 <= Fminus radix x y)%R; [ intros Rle1 | idtac ]. cut (Fminus radix x y <= y)%R; [ intros Rle2 | idtac ]. case (Zle_or_lt (Fexp x) (Fexp y)); intros Zle1. repeat split. apply Zle_lt_trans with (Zabs (Fnum x)); auto with float. change (Fnum (Fabs (Fminus radix x y)) <= Fnum (Fabs x))%Z in |- *. apply Rle_Fexp_eq_Zle with (radix := radix); auto with arith. repeat rewrite Fabs_correct. repeat rewrite Rabs_pos_eq; auto. apply Rle_trans with (2 := H'1); auto. apply Rle_trans with (2 := H'1); auto. apply Rle_trans with (2 := Rle2); auto. apply Zlt_trans with (2 := radixMoreThanOne); auto with zarith. apply Zlt_trans with (2 := radixMoreThanOne); auto with zarith. unfold Fminus in |- *; simpl in |- *; apply Zmin_le1; auto. unfold Fminus in |- *; simpl in |- *; rewrite Zmin_le1; auto with float. repeat split. apply Zle_lt_trans with (Zabs (Fnum y)); auto with float. change (Fnum (Fabs (Fminus radix x y)) <= Fnum (Fabs y))%Z in |- *. apply Rle_Fexp_eq_Zle with (radix := radix); auto with arith. repeat rewrite Fabs_correct. repeat rewrite Rabs_pos_eq; auto. apply Rle_trans with (2 := Rle2); auto. apply Zlt_trans with (2 := radixMoreThanOne); auto with zarith. apply Zlt_trans with (2 := radixMoreThanOne); auto with zarith. unfold Fminus in |- *; simpl in |- *; apply Zmin_le2; auto with zarith. unfold Fminus in |- *; simpl in |- *; rewrite Zmin_le2; auto with float zarith. rewrite (Fminus_correct radix); auto with arith; fold FtoRradix in |- *. apply Rplus_le_reg_l with (r := FtoRradix y); auto. replace (y + (x - y))%R with (FtoRradix x); [ idtac | ring ]. replace (y + y)%R with (2%nat * y)%R; [ auto | simpl in |- *; ring ]. apply Zlt_trans with (2 := radixMoreThanOne); auto with zarith. rewrite (Fminus_correct radix); auto with arith; fold FtoRradix in |- *. apply Rplus_le_reg_l with (r := FtoRradix y); auto. replace (y + (x - y))%R with (FtoRradix x); [ idtac | ring ]. replace (y + 0)%R with (FtoRradix y); [ auto | simpl in |- *; ring ]. apply Zlt_trans with (2 := radixMoreThanOne); auto with zarith. Qed. Theorem Sterbenz : forall x y : float, Fbounded b x -> Fbounded b y -> (/ 2%nat * y <= x)%R -> (x <= 2%nat * y)%R -> Fbounded b (Fminus radix x y). intros x y H' H'0 H'1 H'2. cut (y <= 2%nat * x)%R; [ intros Le1 | idtac ]. case (Rle_or_lt x y); intros Le2; auto. apply oppBoundedInv; auto. rewrite Fopp_Fminus. apply SterbenzAux; auto with real. apply SterbenzAux; auto with real. apply Rmult_le_reg_l with (r := (/ 2%nat)%R). apply Rinv_0_lt_compat; auto with real. rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real. rewrite Rmult_1_l; auto. Qed. Theorem BminusSameExpAux : forall x y : float, Fbounded b x -> Fbounded b y -> (0 <= y)%R -> (y <= x)%R -> Fexp x = Fexp y -> Fbounded b (Fminus radix x y). intros x y H' H'0 H'1 H'2 H'3. cut (0 < radix)%Z; [ intros Z1 | idtac ]. rewrite minusSameExp; auto. repeat split; simpl in |- *; auto with float. apply Zle_lt_trans with (Zabs (Fnum x)); auto with float zarith. change (Fnum (Fabs (Float (Fnum x - Fnum y) (Fexp x))) <= Fnum (Fabs x))%Z in |- *. apply Rle_Fexp_eq_Zle with (radix := radix); auto with zarith. rewrite <- (minusSameExp radix); auto. repeat rewrite (Fabs_correct radix); try rewrite Fminus_correct; auto with zarith. repeat rewrite Rabs_pos_eq; auto with real. apply Rle_trans with (x - 0)%R; auto with real. unfold Rminus in |- *; auto with real. apply Rle_trans with (FtoRradix y); auto with real. replace 0%R with (x - x)%R; auto with real. unfold Rminus in |- *; auto with real. apply Zlt_trans with (2 := radixMoreThanOne); auto with zarith. Qed. Theorem BminusSameExp : forall x y : float, Fbounded b x -> Fbounded b y -> (0 <= x)%R -> (0 <= y)%R -> Fexp x = Fexp y -> Fbounded b (Fminus radix x y). intros x y H' H'0 H'1 H'2 H'3. case (Rle_or_lt x y); intros Le2; auto. apply oppBoundedInv; auto. rewrite Fopp_Fminus. apply BminusSameExpAux; auto. apply BminusSameExpAux; auto with real. Qed. Theorem BminusSameExpNeg : forall x y : float, Fbounded b x -> Fbounded b y -> (x <= 0)%R -> (y <= 0)%R -> Fexp x = Fexp y -> Fbounded b (Fminus radix x y). intros x y H' H'0 H'1 H'2 H'3. apply oppBoundedInv; auto. rewrite Fopp_Fminus_dist. apply BminusSameExp; auto with float. unfold FtoRradix in |- *; rewrite Fopp_correct. replace 0%R with (-0)%R; auto with real. unfold FtoRradix in |- *; rewrite Fopp_correct. replace 0%R with (-0)%R; auto with real. Qed. End Fprop. Hint Resolve Sterbenz BminusSameExp BminusSameExpNeg: float.Float8.4/Fround.v0000644000423700002640000003325512032774525013504 0ustar sboldotoccata(**************************************************************************** IEEE754 : Fround Laurent Thery ******************************************************************************) Require Export Fprop. Require Export Fodd. Section FRound. Variable b : Fbound. Variable radix : Z. Variable precision : nat. Coercion Local FtoRradix := FtoR radix. Hypothesis radixMoreThanOne : (1 < radix)%Z. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Definition TotalP (P : R -> float -> Prop) := forall r : R, exists p : float, P r p. Definition UniqueP (P : R -> float -> Prop) := forall (r : R) (p q : float), P r p -> P r q -> p = q :>R. Definition CompatibleP (P : R -> float -> Prop) := forall (r1 r2 : R) (p q : float), P r1 p -> r1 = r2 -> p = q :>R -> Fbounded b q -> P r2 q. Definition MinOrMaxP (P : R -> float -> Prop) := forall (r : R) (p : float), P r p -> isMin b radix r p \/ isMax b radix r p. Definition RoundedModeP (P : R -> float -> Prop) := TotalP P /\ CompatibleP P /\ MinOrMaxP P /\ MonotoneP radix P. Theorem RoundedModeP_inv1 : forall P, RoundedModeP P -> TotalP P. intros P H; case H; auto. Qed. Theorem RoundedModeP_inv2 : forall P, RoundedModeP P -> CompatibleP P. intros P H; Casec H; intros H H1; Casec H1; auto. Qed. Theorem RoundedModeP_inv3 : forall P, RoundedModeP P -> MinOrMaxP P. intros P H; Casec H; intros H H1; Casec H1; intros H1 H2; Casec H2; auto. Qed. Theorem RoundedModeP_inv4 : forall P, RoundedModeP P -> MonotoneP radix P. intros P H; Casec H; intros H H1; Casec H1; intros H1 H2; Casec H2; auto. Qed. Hint Resolve RoundedModeP_inv1 RoundedModeP_inv2 RoundedModeP_inv3 RoundedModeP_inv4: inv. Theorem RoundedProjector : forall P, RoundedModeP P -> ProjectorP b radix P. intros P H'; red in |- *; simpl in |- *. intros p q H'0 H'1. red in H'. elim H'; intros H'2 H'3; elim H'3; intros H'4 H'5; elim H'5; intros H'6 H'7; case (H'6 p q); clear H'5 H'3 H'; auto. intros H'; apply (ProjectMin b radix p); auto. intros H'; apply (ProjectMax b radix p); auto. Qed. Theorem MinCompatible : CompatibleP (isMin b radix). red in |- *. intros r1 r2 p q H' H'0 H'1 H'2; split; auto. rewrite <- H'0; unfold FtoRradix in H'1; rewrite <- H'1; case H'; auto. Qed. Theorem MinRoundedModeP : RoundedModeP (isMin b radix). split; try red in |- *. intros r; apply MinEx with (precision := precision); auto with arith. split; try exact MinCompatible. split; try apply MonotoneMin; red in |- *; auto. Qed. Theorem MaxCompatible : CompatibleP (isMax b radix). red in |- *. intros r1 r2 p q H' H'0 H'1 H'2; split; auto. rewrite <- H'0; unfold FtoRradix in H'1; rewrite <- H'1; case H'; auto. Qed. Theorem MaxRoundedModeP : RoundedModeP (isMax b radix). split; try red in |- *. intros r; apply MaxEx with (precision := precision); auto with arith. split; try exact MaxCompatible. split; try apply MonotoneMax; red in |- *; auto. Qed. Definition ToZeroP (r : R) (p : float) := (0 <= r)%R /\ isMin b radix r p \/ (r <= 0)%R /\ isMax b radix r p. Theorem ToZeroTotal : TotalP ToZeroP. red in |- *; intros r; case (Rle_or_lt r 0); intros H1. case MaxEx with (r := r) (3 := pGivesBound); auto with arith. intros x H'; exists x; red in |- *; auto. case MinEx with (r := r) (3 := pGivesBound); auto with arith. intros x H'; exists x; red in |- *; left; split; auto. apply Rlt_le; auto. Qed. Theorem ToZeroCompatible : CompatibleP ToZeroP. red in |- *. intros r1 r2 p q H'; case H'. intros H'0 H'1 H'2; left; split; try apply MinCompatible with (p := p) (r1 := r1); try rewrite <- H'1; auto; case H'0; auto. intros H'0 H'1 H'2; right; split; try apply MaxCompatible with (p := p) (r1 := r1); try rewrite <- H'1; auto; case H'0; auto. Qed. Theorem ToZeroMinOrMax : MinOrMaxP ToZeroP. red in |- *. intros r p H'; case H'; clear H'; intros H'; case H'; auto. Qed. Theorem ToZeroMonotone : MonotoneP radix ToZeroP. red in |- *. cut (FtoR radix (Fzero (- dExp b)) = 0%R); [ intros Eq0 | unfold FtoR in |- *; simpl in |- * ]; auto with real. simpl in |- *; intros p q p' q' H' H'0; case H'0; clear H'0. intros H'0; elim H'0; intros H'1 H'2; clear H'0; intros H'0. case H'0; intros H'3; elim H'3; clear H'3; auto. intros H'3 H'4. apply (MonotoneMin b radix) with (p := p) (q := q); auto. intros H'3 H'4. apply Rle_trans with p; [ apply isMin_inv1 with (1 := H'2); auto | idtac ]. apply Rle_trans with q; [ idtac | apply isMax_inv1 with (1 := H'4) ]; auto. apply Rlt_le; auto. intros H'0; elim H'0; intros H'1 H'2; clear H'0. intros H'0; case H'0; clear H'0; intros H'0; case H'0; intros H'3 H'4; clear H'0. apply Rle_trans with (FtoRradix (Fzero (- dExp b))); auto. elim H'2. intros H'0 H'5; elim H'5; intros H'6 H'7; apply H'7; clear H'5; auto. repeat split; simpl in |- *; auto with zarith. rewrite Eq0; auto. elim H'4. intros H'0 H'5; elim H'5; intros H'6 H'7; apply H'7; clear H'5; auto. repeat split; simpl in |- *; auto with zarith. rewrite Eq0; auto. apply (MonotoneMax b radix) with (p := p) (q := q); auto. Qed. Theorem ToZeroRoundedModeP : RoundedModeP ToZeroP. repeat split. try exact ToZeroTotal. try exact ToZeroCompatible. try exact ToZeroMinOrMax. try exact ToZeroMonotone. Qed. Definition ToInfinityP (r : R) (p : float) := (r <= 0)%R /\ isMin b radix r p \/ (0 <= r)%R /\ isMax b radix r p. Theorem ToInfinityTotal : TotalP ToInfinityP. red in |- *; intros r; case (Rle_or_lt r 0); intros H1. case MinEx with (r := r) (3 := pGivesBound); auto with arith. intros x H'; exists x; red in |- *; auto. case MaxEx with (r := r) (3 := pGivesBound); auto with arith. intros x H'; exists x; red in |- *; right; split; auto. apply Rlt_le; auto. Qed. Theorem ToInfinityCompatible : CompatibleP ToInfinityP. red in |- *. intros r1 r2 p q H'; case H'. intros H'0 H'1 H'2; left; split; try apply MinCompatible with (p := p) (r1 := r1); try rewrite <- H'1; case H'0; auto. intros H'0 H'1 H'2; right; split; try apply MaxCompatible with (p := p) (r1 := r1); try rewrite <- H'1; case H'0; auto. Qed. Theorem ToInfinityMinOrMax : MinOrMaxP ToInfinityP. red in |- *. intros r p H'; case H'; clear H'; intros H'; case H'; auto. Qed. Theorem ToInfinityMonotone : MonotoneP radix ToInfinityP. red in |- *; simpl in |- *. cut (FtoR radix (Fzero (- dExp b)) = 0%R); [ intros Eq0 | unfold FtoR in |- *; simpl in |- * ]; auto with real. intros p q p' q' H' H'0; case H'0; clear H'0. intros H'0; elim H'0; intros H'1 H'2; clear H'0; intros H'0. case H'0; intros H'3; elim H'3; clear H'3; auto. intros H'3 H'4. apply (MonotoneMin b radix) with (p := p) (q := q); auto. intros H'3 H'4. apply Rle_trans with p; [ apply isMin_inv1 with (1 := H'2); auto | idtac ]. apply Rle_trans with q; [ auto | apply isMax_inv1 with (1 := H'4) ]; auto. apply Rlt_le; auto. intros H'0; elim H'0; intros H'1 H'2; clear H'0. intros H'0; case H'0; clear H'0; intros H'0; case H'0; intros H'3 H'4; clear H'0. 2: apply (MonotoneMax b radix) with (p := p) (q := q); auto. apply Rle_trans with (FtoRradix (Fzero (- dExp b))); auto. elim H'2. intros H'0 H'5; elim H'5; intros H'6 H'7; apply H'7; clear H'5; auto. repeat split; simpl in |- *; auto with zarith. apply Rle_trans with q; auto. apply Rlt_le; auto. rewrite Eq0; auto. elim H'4. intros H'0 H'5; elim H'5; intros H'6 H'7; apply H'7; clear H'5; auto. repeat split; simpl in |- *; auto with zarith. apply Rle_trans with p; auto. rewrite Eq0; auto. apply Rlt_le; auto. Qed. Theorem ToInfinityRoundedModeP : RoundedModeP ToInfinityP. repeat split. try exact ToInfinityTotal. try exact ToInfinityCompatible. try exact ToInfinityMinOrMax. try exact ToInfinityMonotone. Qed. Theorem MinUniqueP : UniqueP (isMin b radix). red in |- *. intros r p q H' H'0. unfold FtoRradix in |- *; apply MinEq with (1 := H'); auto. Qed. Theorem MaxUniqueP : UniqueP (isMax b radix). red in |- *. intros r p q H' H'0. unfold FtoRradix in |- *; apply MaxEq with (1 := H'); auto. Qed. Theorem ToZeroUniqueP : UniqueP ToZeroP. red in |- *. intros r p q H' H'0. inversion H'; inversion H'0; elim H0; elim H; clear H0 H; intros H'1 H'2 H'3 H'4. apply (MinUniqueP r); auto. cut (r = Fzero (- dExp b) :>R); [ intros Eq0 | apply Rle_antisym; unfold FtoRradix, Fzero, FtoR in |- *; simpl in |- * ]; try rewrite Rmult_0_l; auto with real. apply trans_eq with (FtoRradix (Fzero (- dExp b))). apply sym_eq; unfold FtoRradix in |- *; apply (RoundedProjector _ ToZeroRoundedModeP); auto with float. unfold FtoRradix in Eq0; rewrite <- Eq0; auto. unfold FtoRradix in |- *; apply (RoundedProjector _ ToZeroRoundedModeP); auto with float. unfold FtoRradix in Eq0; rewrite <- Eq0; auto. cut (r = Fzero (- dExp b) :>R); [ intros Eq0 | apply Rle_antisym; unfold FtoRradix, Fzero, FtoR in |- *; simpl in |- * ]; try rewrite Rmult_0_l; auto with real. apply trans_eq with (FtoRradix (Fzero (- dExp b))). apply sym_eq; unfold FtoRradix in |- *; apply (RoundedProjector _ ToZeroRoundedModeP); auto with float. unfold FtoRradix in Eq0; rewrite <- Eq0; auto. unfold FtoRradix in |- *; apply (RoundedProjector _ ToZeroRoundedModeP); auto with float. unfold FtoRradix in Eq0; rewrite <- Eq0; auto. apply (MaxUniqueP r); auto. Qed. Theorem ToInfinityUniqueP : UniqueP ToInfinityP. red in |- *. intros r p q H' H'0. inversion H'; inversion H'0; elim H0; elim H; clear H0 H; intros H'1 H'2 H'3 H'4. apply (MinUniqueP r); auto. cut (r = Fzero (- dExp b) :>R); [ intros Eq0 | apply Rle_antisym; unfold FtoRradix, Fzero, FtoR in |- *; simpl in |- * ]; try rewrite Rmult_0_l; auto with real. apply trans_eq with (FtoRradix (Fzero (- dExp b))). apply sym_eq; unfold FtoRradix in |- *; apply (RoundedProjector _ ToInfinityRoundedModeP); auto. apply FboundedFzero; auto. unfold FtoRradix in Eq0; rewrite <- Eq0; auto. unfold FtoRradix in |- *; apply (RoundedProjector _ ToInfinityRoundedModeP); auto. apply FboundedFzero; auto. unfold FtoRradix in Eq0; rewrite <- Eq0; auto. cut (r = Fzero (- dExp b) :>R); [ intros Eq0 | apply Rle_antisym; unfold FtoRradix, Fzero, FtoR in |- *; simpl in |- * ]; try rewrite Rmult_0_l; auto with float. apply trans_eq with (FtoRradix (Fzero (- dExp b))). apply sym_eq; unfold FtoRradix in |- *; apply (RoundedProjector _ ToInfinityRoundedModeP); auto. apply FboundedFzero; auto. unfold FtoRradix in Eq0; rewrite <- Eq0; auto. unfold FtoRradix in |- *; apply (RoundedProjector _ ToInfinityRoundedModeP); auto. apply FboundedFzero; auto. unfold FtoRradix in Eq0; rewrite <- Eq0; auto. apply (MaxUniqueP r); auto. Qed. Theorem MinOrMaxRep : forall P, MinOrMaxP P -> forall p q : float, P p q -> exists m : Z, q = Float m (Fexp p) :>R. intros P H' p q H'0; case (H' p q); auto; intros H'1. apply FminRep with (3 := pGivesBound); auto with arith. apply FmaxRep with (3 := pGivesBound); auto with arith. Qed. Theorem RoundedModeRep : forall P, RoundedModeP P -> forall p q : float, P p q -> exists m : Z, q = Float m (Fexp p) :>R. intros P H' p q H'0. apply MinOrMaxRep with (P := P); auto with inv. Qed. Definition SymmetricP (P : R -> float -> Prop) := forall (r : R) (p : float), P r p -> P (- r)%R (Fopp p). Theorem ToZeroSymmetric : SymmetricP ToZeroP. red in |- *; intros r p H'; case H'; clear H'; intros H'; case H'; intros H'1 H'2. right; split; auto. replace 0%R with (-0)%R; auto with real. apply MinOppMax; auto. left; split; auto. replace 0%R with (-0)%R; auto with real. apply MaxOppMin; auto. Qed. Theorem ToInfinitySymmetric : SymmetricP ToInfinityP. red in |- *; intros r p H'; case H'; clear H'; intros H'; case H'; intros H'1 H'2. right; split; auto. replace 0%R with (-0)%R; auto with real. apply MinOppMax; auto. left; split; auto. replace 0%R with (-0)%R; auto with real. apply MaxOppMin; auto. Qed. Theorem ScalableRoundedModeP : forall P (f s t : float), RoundedModeP P -> Fbounded b f -> P (radix * f)%R s -> P (s / radix)%R t -> f = t :>R. intros P f s t HP Ff H1 H2. cut (ProjectorP b radix P); [ unfold ProjectorP in |- *; intros HP2 | apply RoundedProjector; auto ]. cut (FtoR radix (Float (Fnum f) (Zsucc (Fexp f))) = (radix * FtoR radix f)%R); [ intros V | idtac]. 2: unfold FtoR, Zsucc in |- *; simpl in |- *; ring_simplify. 2: rewrite powerRZ_add; [ simpl in |- *; ring | auto with zarith real ]. unfold FtoRradix in |- *; apply HP2; auto. replace (FtoR radix f) with (FtoR radix s / radix)%R; auto. replace (FtoR radix s) with (radix * FtoR radix f)%R; [ unfold Rdiv in |- * | rewrite <- V ]. rewrite Rmult_comm; rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real zarith. apply HP2; auto with float. repeat (split; simpl in |- *; auto with zarith float). rewrite V; auto. Qed. Theorem RoundLessThanIsMax : forall P, RoundedModeP P -> forall (p m : float) (x : R), P x p -> isMax b radix x m -> (p <= m)%R. intros. elim H; intros. elim H3; intros H' H'0; clear H3. elim H'0; intros; clear H'0. case (H3 x p); auto. intros; apply Rle_trans with x; auto. elim H5; intros; elim H7; intros; auto with real. elim H1; intros; elim H7; intros; auto with real. intros; replace (FtoRradix p) with (FtoRradix m); auto with real. unfold FtoRradix in |- *; apply MaxEq with b x; auto. Qed. End FRound. Hint Resolve RoundedProjector MinCompatible MinRoundedModeP MaxCompatible MaxRoundedModeP ToZeroTotal ToZeroCompatible ToZeroMinOrMax ToZeroMonotone ToZeroRoundedModeP ToInfinityTotal ToInfinityCompatible ToInfinityMinOrMax ToInfinityMonotone ToInfinityRoundedModeP MinUniqueP MaxUniqueP ToZeroUniqueP ToInfinityUniqueP FnOddNEven ToZeroSymmetric ToInfinitySymmetric: float. Hint Resolve RoundedModeP_inv1 RoundedModeP_inv2 RoundedModeP_inv3 RoundedModeP_inv4: inv.Float8.4/FroundMult.v0000644000423700002640000010061612032774525014342 0ustar sboldotoccata(**************************************************************************** IEEE754 : FroundMult Laurent Thery, Sylvie Boldo ******************************************************************************) Require Export FroundProp. Section FRoundP. Variable b : Fbound. Variable radix : Z. Variable precision : 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 precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Theorem errorBoundedMultMin : forall p q fmin : float, Fbounded b p -> Fbounded b q -> (0 <= p)%R -> (0 <= q)%R -> (- dExp b <= Fexp p + Fexp q)%Z -> isMin b radix (p * q) fmin -> exists r : float, r = (p * q - fmin)%R :>R /\ Fbounded b r /\ Fexp r = (Fexp p + Fexp q)%Z. intros p q fmin 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 ]. cut (ex (fun m : Z => FtoRradix fmin = Float m (Fexp (Fmult p q)))). 2: unfold FtoRradix in |- *; apply RoundedModeRep with (b := b) (precision := precision) (P := isMin b radix); auto. 2: apply MinRoundedModeP with (precision := precision); auto. 2: rewrite (Fmult_correct radix); auto with zarith. intros H'3; elim H'3; intros m E; clear H'3. exists (Fminus radix (Fmult p q) (Float m (Fexp (Fmult p q)))). split. rewrite E; unfold FtoRradix in |- *; repeat rewrite Fminus_correct; repeat rewrite Fmult_correct; auto with zarith. split. cut (fmin <= Fmult p q)%R; [ idtac | unfold FtoRradix in |- *; rewrite Fmult_correct; auto; case H'2; auto with real zarith; (intros H1 H2; case H2; auto with zarith) ]. rewrite E; unfold Fmult, Fminus, Fopp, Fplus in |- *; simpl in |- *; auto. repeat rewrite Zmin_n_n; repeat rewrite <- Zminus_diag_reverse; auto. simpl in |- *; repeat rewrite Zpower_nat_O; repeat rewrite Zmult_1_r. unfold FtoRradix, FtoR in |- *; simpl in |- *. intros H'3; (cut (m <= Fnum p * Fnum q)%Z; [ idtac | apply le_IZR; apply Rmult_le_reg_l with (r := powerRZ radix (Fexp p + Fexp q)); auto with real zarith; repeat rewrite (Rmult_comm (powerRZ radix (Fexp p + Fexp q))); auto with zarith ]); intros H'4. repeat split; simpl in |- *; auto. case (ZquotientProp (Fnum p * Fnum q) (Zpower_nat radix precision)); auto with zarith. intros x (H'5, (H'6, H'7)). cut (Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision) * powerRZ radix (precision + (Fexp p + Fexp q)) <= fmin)%R; [ rewrite E; intros H'8 | idtac ]. cut (Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision) * powerRZ radix precision <= m)%R; [ intros H'9 | idtac ]. rewrite Zabs_eq; auto with zarith. apply Zle_lt_trans with x; auto. replace x with (Fnum p * Fnum q + - (Zquotient (Fnum p * Fnum q) (Zpower_nat radix precision) * Zpower_nat radix precision))%Z. apply Zplus_le_compat_l; auto. apply Zle_Zopp. apply le_IZR; auto. rewrite Rmult_IZR. rewrite Zpower_nat_Z_powerRZ; auto with zarith. pattern (Fnum p * Fnum q)%Z at 1 in |- *; rewrite H'5; ring. rewrite pGivesBound. rewrite <- (Zabs_eq (Zpower_nat radix precision)); auto with zarith. apply Zlt_Zabs_inv2; auto. apply Rmult_le_reg_l with (r := powerRZ radix (Fexp p + Fexp q)); auto with real zarith. repeat rewrite (Rmult_comm (powerRZ radix (Fexp p + Fexp q))); auto. rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with real 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'6); 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 x0 (H'8, H'9); rewrite <- H'9. case H'2. intros H'10 (H'11, H'12); apply H'12; auto. rewrite H'9; auto. rewrite powerRZ_add; auto with real zarith. rewrite <- Rmult_assoc. unfold FtoRradix in |- *; rewrite <- Fmult_correct; auto with zarith. unfold Fmult, FtoR in |- *; simpl in |- *. repeat rewrite (fun x => Rmult_comm x (powerRZ radix (Fexp p + Fexp q))). apply Rmult_le_compat_l; auto with real zarith. rewrite <- Zpower_nat_Z_powerRZ; auto with zarith. pattern (Fnum p * Fnum q)%Z at 2 in |- *; rewrite <- (Zabs_eq (Fnum p * Fnum q)); auto. rewrite <- Rmult_IZR; apply Rle_IZR; apply Zle_Zabs_inv2; auto. simpl in |- *; auto. apply Zmin_n_n; auto. Qed. Theorem errorBoundedMultMax : forall p q fmax : float, Fbounded b p -> Fbounded b q -> (0 <= p)%R -> (0 <= q)%R -> (- dExp b <= Fexp p + Fexp q)%Z -> isMax b radix (p * q) fmax -> exists r : float, FtoRradix r = (p * q - fmax)%R /\ Fbounded b r /\ Fexp r = (Fexp p + Fexp q)%Z. 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. 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. intros P H' p q pq H'0. case (RoundedModeRep b radix precision) with (p := Fmult p q) (q := pq) (P := P); auto with zarith. rewrite Fmult_correct; auto with zarith. simpl in |- *; intros x H'1. case (eqExpLess _ radixMoreThanOne b) with (p := pq) (q := Float x (Fexp (Fmult p q))); auto. apply RoundedModeBounded with (radix := radix) (P := P) (r := (p * q)%R); auto. simpl in |- *; intros x0 H'2; elim H'2; intros H'3 H'4; elim H'4; intros H'5 H'6; clear H'4 H'2. exists x0; split; [ idtac | split ]; auto. unfold FtoRradix in |- *; rewrite H'5; auto. apply le_IZR; auto. Qed. Theorem multExpUpperBound : forall P, RoundedModeP b radix P -> forall p q pq : float, P (p * q)%R pq -> Fbounded b p -> Fbounded b q -> (- dExp b <= Fexp p + Fexp q)%Z -> exists r : float, Fbounded b r /\ r = pq :>R /\ (Fexp r <= precision + (Fexp p + Fexp q))%Z. intros P H' p q pq H'0 H'1 H'2 H'3. replace (precision + (Fexp p + Fexp q))%Z with (Fexp (Float (pPred (vNum b)) (precision + (Fexp p + Fexp q)))); [ idtac | simpl in |- *; auto ]. unfold FtoRradix in |- *; apply eqExpMax; auto. apply RoundedModeBounded with (radix := radix) (P := P) (r := (p * q)%R); auto; auto. unfold pPred in |- *; apply maxFbounded; auto. apply Zle_trans with (1 := H'3); auto with zarith. replace (FtoR radix (Float (pPred (vNum b)) (precision + (Fexp p + Fexp q)))) with (radix * Float (pPred (vNum b)) (pred precision + (Fexp p + Fexp q)))%R. rewrite Fabs_correct; auto with zarith. unfold FtoRradix in |- *; apply RoundedModeMultAbs with (b := b) (precision := precision) (P := P) (r := (p * q)%R); auto. unfold pPred in |- *; apply maxFbounded; auto with zarith. rewrite Rabs_mult; auto. apply Rle_trans with (FtoR radix (Fmult (Float (pPred (vNum b)) (Fexp p)) (Float (pPred (vNum b)) (Fexp q)))). rewrite Fmult_correct; auto with arith. apply Rmult_le_compat; auto with real. rewrite <- (Fabs_correct radix); try apply maxMax1; auto with zarith. rewrite <- (Fabs_correct radix); try apply maxMax1; auto with zarith. unfold Fmult, FtoR in |- *; simpl in |- *; auto. rewrite powerRZ_add with (n := Z_of_nat (pred precision)); auto with real arith. repeat rewrite <- Rmult_assoc. repeat rewrite (fun (z : Z) (x : R) => Rmult_comm x (powerRZ radix z)); auto. apply Rmult_le_compat_l; auto with real arith. rewrite <- Rmult_assoc. rewrite (fun x : R => Rmult_comm x radix). rewrite <- powerRZ_Zs; auto with real arith. replace (Zsucc (pred precision)) with (Z_of_nat precision). rewrite Rmult_IZR; auto. apply Rmult_le_compat; auto with real arith. replace 0%R with (IZR 0); unfold pPred in |- *; try apply Rle_IZR; auto with real zarith. replace 0%R with (IZR 0); unfold pPred in |- *; try apply Rle_IZR; auto with real zarith. unfold pPred in |- *; rewrite pGivesBound; rewrite <- Zpower_nat_Z_powerRZ; auto with real zarith. rewrite inj_pred; auto with arith zarith. auto with real zarith. auto with real zarith. unfold FtoRradix, FtoR in |- *; simpl in |- *. repeat rewrite (Rmult_comm (pPred (vNum b))). rewrite <- Rmult_assoc. rewrite <- powerRZ_Zs; auto with real zarith. rewrite inj_pred; auto with arith zarith. replace (Zsucc (Zpred precision + (Fexp p + Fexp q))) with (precision + (Fexp p + Fexp q))%Z; auto; unfold Zsucc, Zpred in |- *; ring. Qed. Theorem errorBoundedMultPos : forall P, RoundedModeP b radix P -> forall p q f : float, Fbounded b p -> Fbounded b q -> (0 <= p)%R -> (0 <= q)%R -> (- dExp b <= Fexp p + Fexp q)%Z -> P (p * q)%R f -> exists r : float, r = (p * q - f)%R :>R /\ Fbounded b r /\ Fexp r = (Fexp p + Fexp q)%Z. intros P H p q f H0 H1 H2 H3 H4 H5. generalize errorBoundedMultMin errorBoundedMultMax; intros H6 H7. cut (MinOrMaxP b radix P); [ intros | case H; intros H'1 (H'2, (H'3, H'4)); auto ]. case (H8 (p * q)%R f); auto. Qed. Theorem errorBoundedMultNeg : forall P, RoundedModeP b radix P -> forall p q f : float, Fbounded b p -> Fbounded b q -> (p <= 0)%R -> (0 <= q)%R -> (- dExp b <= Fexp p + Fexp q)%Z -> P (p * q)%R f -> exists r : float, r = (p * q - f)%R :>R /\ Fbounded b r /\ Fexp r = (Fexp p + Fexp q)%Z. intros P H p q f H0 H1 H2 H3 H4 H5. generalize errorBoundedMultMin errorBoundedMultMax; intros H6 H7. cut (MinOrMaxP b radix P); [ intros | case H; intros H'1 (H'2, (H'3, H'4)); auto ]. case (H8 (p * q)%R f); auto; intros H9. generalize (H7 (Fopp p) q (Fopp f)); intros H12. lapply H12; auto with float; intros H10; clear H12. lapply H10; auto; intros H12; clear H10. lapply H12; [ intros H10 | unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real ]; clear H12. lapply H10; auto; intros H12; clear H10. lapply H12; [ intros H10 | simpl in |- *; auto ]; clear H12. lapply H10; [ intros H12 | idtac ]; clear H10. 2: replace (Fopp p * q)%R with (- (p * q))%R; [ apply MinOppMax; auto | idtac ]. 2: unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real. elim H12; intros r H10; clear H12; elim H10; intros H11 H12; clear H10. elim H12; clear H12; intros H10 H12. exists (Fopp r); split; [ generalize H11 | split; auto with float ]. unfold FtoRradix in |- *; repeat rewrite Fopp_correct; intros H13; rewrite H13; ring. generalize (H6 (Fopp p) q (Fopp f)); intros H12. lapply H12; auto with float; intros H10; clear H12. lapply H10; auto; intros H12; clear H10. lapply H12; [ intros H10 | unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real ]; clear H12. lapply H10; auto; intros H12; clear H10. lapply H12; [ intros H10 | simpl in |- *; auto ]; clear H12. lapply H10; [ intros H12 | idtac ]; clear H10. 2: replace (Fopp p * q)%R with (- (p * q))%R; [ apply MaxOppMin; auto | idtac ]. 2: unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real. elim H12; intros r H10; clear H12; elim H10; intros H11 H12; clear H10. elim H12; clear H12; intros H10 H12. exists (Fopp r); split; [ generalize H11 | split; auto with float ]. unfold FtoRradix in |- *; repeat rewrite Fopp_correct; intros H13; rewrite H13; ring. Qed. Theorem errorBoundedMult : forall P, RoundedModeP b radix P -> forall p q f : float, Fbounded b p -> Fbounded b q -> (- dExp b <= Fexp p + Fexp q)%Z -> P (p * q)%R f -> exists r : float, r = (p * q - f)%R :>R /\ Fbounded b r /\ Fexp r = (Fexp p + Fexp q)%Z. intros P H p q f H0 H1 H2 H3. case (Rle_or_lt 0 p); intros H4; case (Rle_or_lt 0 q); intros H5. apply errorBoundedMultPos with P; auto. replace (Fexp p) with (Fexp (Fopp p)); auto with float. replace (Fexp q) with (Fexp (Fopp q)); auto with float. cut ((p * q)%R = (Fopp p * Fopp q)%R); [ intros H6; rewrite H6 | idtac ]. apply errorBoundedMultNeg with P; auto with float real. unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real. unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real. rewrite <- H6; auto. unfold FtoRradix in |- *; repeat rewrite Fopp_correct; ring. apply errorBoundedMultNeg with P; auto with float real. replace (Fexp p) with (Fexp (Fopp p)); auto with float. replace (Fexp q) with (Fexp (Fopp q)); auto with float. cut ((p * q)%R = (Fopp p * Fopp q)%R); [ intros H6; rewrite H6 | idtac ]. apply errorBoundedMultPos with P; auto with float real. unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real. unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real. rewrite <- H6; auto. unfold FtoRradix in |- *; repeat rewrite Fopp_correct; ring. Qed. Theorem errorBoundedMultExp_aux : forall n1 n2 : Z, (Zabs n1 < Zpos (vNum b))%Z -> (Zabs n2 < Zpos (vNum b))%Z -> (exists ny : Z, (exists ey : Z, (n1 * n2)%R = (ny * powerRZ radix ey)%R :>R /\ (Zabs ny < Zpos (vNum b))%Z)) -> exists nx : Z, (exists ex : Z, (n1 * n2)%R = (nx * powerRZ radix ex)%R :>R /\ (Zabs nx < Zpos (vNum b))%Z /\ (0 <= ex)%Z /\ (ex <= precision)%Z). intros n1 n2 H H0 H1. case H1; intros ny (ey, (H2, H3)). case (Zle_or_lt 0 ey); intros Zl1. case (Zle_or_lt ey precision); intros Zl2. exists ny; exists ey; repeat (split; auto). exists (ny * Zpower_nat radix (Zabs_nat (ey - precision)))%Z; exists (Z_of_nat precision); repeat (split; auto with zarith). replace (IZR (ny * Zpower_nat radix (Zabs_nat (ey - precision)))) with (ny * powerRZ radix (ey - precision))%R. rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with zarith real. replace (ey - precision + precision)%Z with ey; [ auto | ring ]. rewrite Rmult_IZR. rewrite Zpower_nat_powerRZ_absolu; auto with real zarith. rewrite Zabs_Zmult. apply lt_IZR; apply Rmult_lt_reg_l with (r := powerRZ radix precision); auto with real zarith. repeat rewrite (fun x y => Rmult_comm (powerRZ x y)). rewrite Rmult_IZR. rewrite Rmult_assoc. rewrite (Zabs_eq (Zpower_nat radix (Zabs_nat (ey - precision)))); auto with zarith. rewrite Zpower_nat_powerRZ_absolu; auto with real zarith. rewrite <- powerRZ_add; auto with real zarith. replace (ey - precision + precision)%Z with ey; [ idtac | ring ]. replace (powerRZ radix precision) with (IZR (Zpos (vNum b))); [ idtac | rewrite pGivesBound; rewrite <- Zpower_nat_powerRZ_absolu; try rewrite absolu_INR; auto with zarith ]. rewrite <- (fun x y => Rabs_pos_eq (powerRZ x y)); auto with real zarith. rewrite <- Faux.Rabsolu_Zabs; rewrite <- Rabs_mult; rewrite <- H2. rewrite Rabs_mult; repeat rewrite Faux.Rabsolu_Zabs; auto with real zarith. case (Zle_lt_or_eq 0 (Zabs n2)); auto with zarith; intros Z1. apply Rlt_trans with (Zpos (vNum b) * Zabs n2)%R; auto with real zarith. rewrite <- Z1; auto with real zarith. replace (Zabs n1 * 0%Z)%R with (0 * Zpos (vNum b))%R; [ auto with real zarith | simpl; ring ]. exists (n1 * n2)%Z; exists 0%Z; repeat (split; auto with zarith). rewrite Rmult_IZR; rewrite powerRZ_O; ring. apply lt_IZR. rewrite <- Faux.Rabsolu_Zabs; rewrite Rmult_IZR; rewrite H2. rewrite Rabs_mult. apply Rle_lt_trans with (Rabs ny). pattern (Rabs ny) at 2 in |- *; replace (Rabs ny) with (Rabs ny * 1)%R; [ apply Rmult_le_compat_l | ring ]; auto with arith real. rewrite (Rabs_pos_eq (powerRZ radix ey)); [ idtac | apply powerRZ_le; auto with arith real ]. replace 1%R with (powerRZ radix 0); [ apply Rle_powerRZ | simpl in |- * ]; auto with real arith zarith. rewrite Faux.Rabsolu_Zabs; auto with real zarith. Qed. Theorem errorBoundedMultExpPos : forall P, RoundedModeP b radix P -> forall p q pq : float, Fbounded b p -> Fbounded b q -> (0 <= p)%R -> (0 <= q)%R -> P (p * q)%R pq -> (- dExp b <= Fexp p + Fexp q)%Z -> ex (fun r : float => ex (fun s : float => Fbounded b r /\ Fbounded b s /\ r = pq :>R /\ s = (p * q - r)%R :>R /\ Fexp s = (Fexp p + Fexp q)%Z :>Z /\ (Fexp s <= Fexp r)%Z /\ (Fexp r <= precision + (Fexp p + Fexp q))%Z)). intros P H p q pq H0 H1 H2 H3 H4 H5. case (multExpUpperBound P H p q pq); auto; intros r (H'1, (H'2, H'3)). case (Req_dec (p * q - pq) 0); intros H6. case (Req_dec pq 0); intros H7. cut (Fbounded b (Fzero (Fexp p + Fexp q))); [ intros Fb1 | idtac ]. exists (Fzero (Fexp p + Fexp q)); exists (Fzero (Fexp p + Fexp q)); repeat (split; simpl in |- *; auto with zarith). rewrite H7; unfold FtoRradix in |- *; apply FzeroisReallyZero. unfold FtoRradix in |- *; rewrite FzeroisReallyZero; rewrite <- H7. pattern (FtoRradix pq) at 1 in |- *; rewrite H7; auto with real. repeat (split; auto); simpl in |- *; auto with arith zarith. case (errorBoundedMultExp_aux (Fnum p) (Fnum q)); auto with float real zarith. exists (Fnum pq); exists (Fexp pq - (Fexp p + Fexp q))%Z; split. apply Rmult_eq_reg_l with (powerRZ radix (Fexp p + Fexp q)); auto with real zarith. repeat rewrite (fun x y => Rmult_comm (powerRZ x y)). apply trans_eq with (p * q)%R; auto. rewrite <- (Fmult_correct radix); auto with real zarith; unfold FtoRradix, FtoR, Fmult in |- *; simpl in |- *; rewrite Rmult_IZR; auto. apply trans_eq with (FtoRradix pq); auto with real. rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with real zarith. replace (Fexp pq - (Fexp p + Fexp q) + (Fexp p + Fexp q))%Z with (Fexp pq); auto; ring. cut (Fbounded b pq); [ intros Z1; case Z1 | idtac ]; auto with real zarith. apply (RoundedModeBounded b radix P (p * q)); auto. intros nx (ex, (H'4, (H'5, (H'6, H'7)))). cut (FtoRradix pq = FtoRradix (Float nx (ex + (Fexp p + Fexp q))) :>R); [ intros Eq1 | idtac ]. exists (Float nx (ex + (Fexp p + Fexp q))); exists (Fzero (Fexp p + Fexp q)); repeat (split; simpl in |- *; auto with real zarith). rewrite <- Eq1; rewrite H6; apply (FzeroisReallyZero radix). replace (FtoRradix pq) with (p * q)%R. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *. rewrite powerRZ_add; auto with zarith real. repeat rewrite <- Rmult_assoc; rewrite <- H'4; rewrite powerRZ_add; [ ring | auto with zarith real ]. replace (FtoRradix p * FtoRradix q)%R with (pq + (FtoRradix p * FtoRradix q - FtoRradix pq))%R; [ rewrite H6 | idtac ]; ring. case (errorBoundedMultPos P H p q pq); auto. intros s (H'4, (H'5, H'6)). exists r; exists s; repeat (split; auto with zarith). rewrite H'2; auto. apply Zlt_le_weak; apply RoundedModeErrorExpStrict with b radix precision P (p * q)%R; auto. cut (CompatibleP b radix P); [ intros H'7 | case H; try intros H'7 (H'8, (H'9, H'10)); auto ]. apply H'7 with (p * q)%R pq; auto with real. fold FtoRradix in |- *; rewrite H'2; auto with real. fold FtoRradix in |- *; rewrite H'4; auto with real. Qed. Theorem errorBoundedMultExp : forall P, (RoundedModeP b radix P) -> forall p q pq : float, (Fbounded b p) -> (Fbounded b q) -> (P (p * q)%R pq) -> (-(dExp b) <= Fexp p + Fexp q)%Z -> exists r : float, exists s : float, (Fbounded b r) /\ (Fbounded b s) /\ r = pq :>R /\ s = (p * q - r)%R :>R /\ (Fexp s = Fexp p + Fexp q)%Z /\ (Fexp s <= Fexp r)%Z /\ (Fexp r <= precision + (Fexp p + Fexp q))%Z. intros P H p q pq H1 H2 H3 H4. cut (MinOrMaxP b radix P); [ intros | case H; intros H'1 (H'2, (H'3, H'4)); auto ]. case H0 with (p*q)%R pq; auto; intros H0'; clear H0. case (Rle_or_lt 0 p); intros Rl1. case (Rle_or_lt 0 q); intros Rl2. apply (errorBoundedMultExpPos P); auto. case errorBoundedMultExpPos with (isMax b radix) p (Fopp q) (Fopp pq); auto with float real. apply MaxRoundedModeP with precision; auto. rewrite (Fopp_correct radix); auto with real. replace (FtoRradix p * FtoRradix (Fopp q))%R with (- (FtoRradix p * FtoRradix q))%R; [apply MinOppMax;auto|idtac]. rewrite (Fopp_correct radix); fold FtoRradix in |- *; auto with zarith; ring. intros r (s, (H5, (H6, (H7, (H8, H9))))); exists (Fopp r); exists (Fopp s); repeat (split; simpl in |- *; auto with float real zarith). repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix in |- *; rewrite H7; repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix; ring. repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix in |- *; rewrite H8; repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix; ring. case (Rle_or_lt 0 q); intros Rl2. case errorBoundedMultExpPos with (isMax b radix) (Fopp p) q (Fopp pq); auto with float real. apply MaxRoundedModeP with precision; auto. rewrite (Fopp_correct radix); auto with real. replace (FtoRradix (Fopp p) * FtoRradix q)%R with (- (FtoRradix p * FtoRradix q))%R; [apply MinOppMax;auto|idtac]. rewrite (Fopp_correct radix); fold FtoRradix in |- *; auto with zarith; ring. intros r (s, (H5, (H6, (H7, (H8, H9))))); exists (Fopp r); exists (Fopp s); repeat (split; simpl in |- *; auto with float real zarith). repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix in |- *; rewrite H7; repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix; ring. repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix in |- *; rewrite H8; repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix;ring. case (errorBoundedMultExpPos P H (Fopp p) (Fopp q) pq); auto with float real. rewrite (Fopp_correct radix); auto with real. rewrite (Fopp_correct radix); auto with real. replace (FtoRradix (Fopp p) * FtoRradix (Fopp q))%R with (FtoRradix p * FtoRradix q)%R; auto; repeat rewrite (Fopp_correct radix); fold FtoRradix in |- *; auto with zarith; ring. intros r (s, (H5, (H6, (H7, (H8, (H9, (H10, H11))))))); exists r; exists s; repeat (split; simpl in |- *; auto with float real zarith). fold FtoRradix in |- *; rewrite H8; repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix; ring. case (Rle_or_lt 0 p); intros Rl1. case (Rle_or_lt 0 q); intros Rl2. apply (errorBoundedMultExpPos P); auto. case errorBoundedMultExpPos with (isMin b radix) p (Fopp q) (Fopp pq); auto with float real. apply MinRoundedModeP with precision; auto. rewrite (Fopp_correct radix); auto with real. replace (FtoRradix p * FtoRradix (Fopp q))%R with (- (FtoRradix p * FtoRradix q))%R; [apply MaxOppMin;auto|idtac]. rewrite (Fopp_correct radix); fold FtoRradix in |- *; auto with zarith; ring. intros r (s, (H5, (H6, (H7, (H8, H9))))); exists (Fopp r); exists (Fopp s); repeat (split; simpl in |- *; auto with float real zarith). repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix in |- *; rewrite H7; repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix; ring. repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix in |- *; rewrite H8; repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix; ring. case (Rle_or_lt 0 q); intros Rl2. case errorBoundedMultExpPos with (isMin b radix) (Fopp p) q (Fopp pq); auto with float real. apply MinRoundedModeP with precision; auto. rewrite (Fopp_correct radix); auto with real. replace (FtoRradix (Fopp p) * FtoRradix q)%R with (- (FtoRradix p * FtoRradix q))%R; [apply MaxOppMin;auto|idtac]. rewrite (Fopp_correct radix); fold FtoRradix in |- *; auto with zarith; ring. intros r (s, (H5, (H6, (H7, (H8, H9))))); exists (Fopp r); exists (Fopp s); repeat (split; simpl in |- *; auto with float real zarith). repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix in |- *; rewrite H7; repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix; ring. repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix in |- *; rewrite H8; repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix;ring. case (errorBoundedMultExpPos P H (Fopp p) (Fopp q) pq); auto with float real. rewrite (Fopp_correct radix); auto with real. rewrite (Fopp_correct radix); auto with real. replace (FtoRradix (Fopp p) * FtoRradix (Fopp q))%R with (FtoRradix p * FtoRradix q)%R; auto; repeat rewrite (Fopp_correct radix); fold FtoRradix in |- *; auto with zarith; ring. intros r (s, (H5, (H6, (H7, (H8, (H9, (H10, H11))))))); exists r; exists s; repeat (split; simpl in |- *; auto with float real zarith). fold FtoRradix in |- *; rewrite H8; repeat rewrite (Fopp_correct radix); auto with zarith; fold FtoRradix; ring. Qed. End FRoundP. Float8.4/FroundPlus.v0000644000423700002640000006103212032774525014342 0ustar sboldotoccata(**************************************************************************** IEEE754 : FroundPlus Laurent Thery ******************************************************************************) Require Export Finduct. Require Export FroundProp. Section FRoundP. Variable b : Fbound. Variable radix : Z. Variable precision : 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 precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Theorem plusExpMin : 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 /\ (Zmin (Fexp p) (Fexp q) <= Fexp s)%Z. intros P H' p q pq H'0. case (RoundedModeRep b radix precision) with (p := Fplus radix p q) (q := pq) (P := P); auto with float arith. rewrite Fplus_correct; auto with float arith. simpl in |- *; intros x H'1. case (eqExpLess _ radixMoreThanOne b) with (p := pq) (q := Float x (Fexp (Fplus radix p q))); auto. apply (RoundedModeBounded b radix) with (P := P) (r := (p + q)%R); auto. simpl in |- *; intros x0 H'2; elim H'2; intros H'3 H'4; elim H'4; intros H'5 H'6; clear H'4 H'2. exists x0; split; [ idtac | split ]; auto. unfold FtoRradix in |- *; rewrite H'5; auto. apply le_IZR; auto. Qed. Theorem plusExpUpperBound : forall P, RoundedModeP b radix P -> forall p q pq : float, P (p + q)%R pq -> Fbounded b p -> Fbounded b q -> exists r : float, Fbounded b r /\ r = pq :>R /\ (Fexp r <= Zsucc (Zmax (Fexp p) (Fexp q)))%Z. intros P H' p q pq H'0 H'1 H'2. replace (Zsucc (Zmax (Fexp p) (Fexp q))) with (Fexp (Float (pPred (vNum b)) (Zsucc (Zmax (Fexp p) (Fexp q))))); [ idtac | simpl in |- *; auto ]. unfold FtoRradix in |- *; apply eqExpMax; auto. apply RoundedModeBounded with (radix := radix) (P := P) (r := (p + q)%R); auto with float arith. unfold pPred in |- *; apply maxFbounded; auto. apply Zle_trans with (Fexp p); auto with float. apply Zle_trans with (Zsucc (Fexp p)); auto with float zarith. replace (FtoR radix (Float (pPred (vNum b)) (Zsucc (Zmax (Fexp p) (Fexp q))))) with (radix * Float (pPred (vNum b)) (Zmax (Fexp p) (Fexp q)))%R. rewrite Fabs_correct; auto with zarith. unfold FtoRradix in |- *; apply RoundedModeMultAbs with (b := b) (precision := precision) (P := P) (r := (p + q)%R); auto. unfold pPred in |- *; apply maxFbounded; auto. apply Zle_trans with (Fexp p); auto with float zarith. apply Rle_trans with (Rabs p + Rabs q)%R. apply Rabs_triang; auto. apply Rle_trans with (2%nat * FtoR radix (Float (pPred (vNum b)) (Zmax (Fexp p) (Fexp q))))%R; auto. cut (forall r : R, (2%nat * r)%R = (r + r)%R); [ intros tmp; rewrite tmp; clear tmp | intros; simpl in |- *; ring ]. apply Rplus_le_compat; auto. rewrite <- (Fabs_correct radix); auto with arith; apply maxMax1; auto; apply ZmaxLe1. rewrite <- (Fabs_correct radix); auto with arith; apply maxMax1; auto; apply ZmaxLe2. apply Rmult_le_compat; auto with real arith. replace 0%R with (INR 0); auto with real arith. apply LeFnumZERO; simpl in |- *; auto; replace 0%Z with (Z_of_nat 0); auto with zarith. unfold pPred in |- *; apply Zle_Zpred; auto with zarith. rewrite INR_IZR_INZ; apply Rle_IZR; simpl in |- *; auto with zarith. cut (1 < radix)%Z; auto with zarith;intros. unfold FtoRradix, FtoR in |- *; simpl in |- *. rewrite powerRZ_Zs; auto with real zarith; ring. Qed. Theorem plusExpBound : forall P, RoundedModeP b radix P -> forall p q pq : float, P (p + q)%R pq -> Fbounded b p -> Fbounded b q -> exists r : float, Fbounded b r /\ r = pq :>R /\ (Zmin (Fexp p) (Fexp q) <= Fexp r)%Z /\ (Fexp r <= Zsucc (Zmax (Fexp p) (Fexp q)))%Z. intros P H' p q pq H'0 H'1 H'2. case (plusExpMin P H' _ _ _ H'0). intros r' H'3; elim H'3; intros H'4 H'5; elim H'5; intros H'6 H'7; clear H'5 H'3. case (Zle_or_lt (Fexp r') (Zsucc (Zmax (Fexp p) (Fexp q)))); intros Zl1. exists r'; repeat (split; auto). case (plusExpUpperBound P H' _ _ _ H'0); auto. intros r'' H'3; elim H'3; intros H'5 H'8; elim H'8; intros H'9 H'10; clear H'8 H'3. exists (Fshift radix (Zabs_nat (Fexp r' - Zsucc (Zmax (Fexp p) (Fexp q)))) r'); split. apply FboundedShiftLess with (n := Zabs_nat (Fexp r' - Fexp r'')); auto. apply ZleLe; auto. repeat rewrite <- Zabs_absolu. repeat rewrite Zabs_eq; auto with zarith. rewrite FshiftCorrectInv; auto. apply trans_eq with (FtoRradix pq); auto. apply Zle_trans with (1 := H'10); auto with zarith. split. unfold FtoRradix in |- *; rewrite FshiftCorrect; auto. split. simpl in |- *. repeat rewrite inj_abs; auto with zarith arith. apply Zle_trans with (Zmax (Fexp p) (Fexp q)); auto with zarith. apply Zmin_Zmax; auto. simpl in |- *. repeat rewrite inj_abs; auto with zarith arith. Qed. Theorem minusRoundRep : forall P, RoundedModeP b radix P -> forall p q qmp qmmp : float, (0 <= p)%R -> (p <= q)%R -> P (q - p)%R qmp -> Fbounded b p -> Fbounded b q -> exists r : float, Fbounded b r /\ r = (q - qmp)%R :>R. intros P H' p q qmp H'0 H'1 H'2 H'3 H'4 H'5. case (Rle_or_lt (/ 2%nat * q) p); intros Rle1. exists p; split; auto. replace (FtoRradix qmp) with (FtoRradix (Fminus radix q p)). rewrite (Fminus_correct radix); auto with arith; unfold FtoRradix in |- *; ring. apply (RoundedModeProjectorIdemEq b radix precision) with (P := P); auto. rewrite <- Fopp_Fminus. apply oppBounded; auto. apply Sterbenz; auto. apply Rle_trans with (FtoRradix q); auto with real. apply Rledouble; auto. apply Rle_trans with (FtoRradix p); auto with real. cut (CompatibleP b radix P); [ intros Cp | apply RoundedModeP_inv2 with (1 := H'); auto ]. apply (Cp (q - p)%R (Fminus radix q p) qmp); auto. rewrite (Fminus_correct radix); auto with arith. apply RoundedModeBounded with (radix := radix) (P := P) (r := (q - p)%R); auto; auto. exists (Fminus radix q qmp); split. rewrite <- Fopp_Fminus. apply oppBounded; auto. apply Sterbenz; auto. apply RoundedModeBounded with (radix := radix) (P := P) (r := (q - p)%R); auto; auto. case MaxEx with (r := (/ 2%nat * FtoR radix q)%R) (3 := pGivesBound); auto with arith. intros max H'6. apply Rle_trans with (FtoRradix max); [ apply isMax_inv1 with (1 := H'6); auto | idtac ]. apply (RleBoundRoundl b radix precision) with (P := P) (r := (q - p)%R); auto; fold FtoRradix in |- *. case H'6; auto. case MinEx with (r := (/ 2%nat * FtoR radix q)%R) (3 := pGivesBound); auto with arith. intros min H'7. replace (FtoRradix max) with (q - min)%R. apply Rplus_le_reg_l with (r := (- q)%R). cut (forall p q : R, (- p + (p - q))%R = (- q)%R); [ intros tmp; repeat rewrite tmp; clear tmp | intros; ring ]. apply Ropp_le_contravar. case H'7. intros H'8 H'9; elim H'9; intros H'10 H'11; apply H'11; clear H'9; auto. apply Rlt_le; auto. unfold FtoRradix in |- *; rewrite (div2IsBetween b radix precision) with (5 := H'7) (6 := H'6); auto. ring. apply Rle_trans with (FtoRradix q); auto with real. apply (RleBoundRoundr b radix precision) with (P := P) (r := (q - p)%R); auto; fold FtoRradix in |- *. apply Rplus_le_reg_l with (r := (- q)%R). cut (forall p q : R, (- p + (p - q))%R = (- q)%R); [ intros tmp; repeat rewrite tmp; clear tmp | intros; ring ]. replace (- q + q)%R with (-0)%R; [ auto with real | ring ]. apply Rle_trans with (FtoRradix q); auto with real. apply Rledouble; auto. apply Rle_trans with (FtoRradix p); auto with real. apply (Fminus_correct radix); auto with arith. Qed. Theorem radixRangeBoundExp : forall p q : float, Fcanonic radix b p -> Fcanonic radix b q -> (0 <= p)%R -> (p < q)%R -> (q < radix * p)%R -> Fexp p = Fexp q \/ Zsucc (Fexp p) = Fexp q. intros p q H' H'0 H'1 H'2 H'3. case (FcanonicLtPos _ radixMoreThanOne b precision) with (p := p) (q := q); auto with arith. 2: intros H'4; elim H'4; intros H'5 H'6; clear H'4; auto. intros H'4; right. Casec H'; intros H'. case (FcanonicLtPos _ radixMoreThanOne b precision) with (p := q) (q := Float (Fnum p) (Zsucc (Fexp p))); auto with arith. left. case H'; intros H1 H2. repeat split; simpl in |- *; auto with float. apply Zle_trans with (Fexp p); auto with float zarith. apply Rle_trans with (FtoRradix p); auto; apply Rlt_le; auto. unfold FtoR in |- *; simpl in |- *. rewrite powerRZ_Zs; auto with real zarith; auto. rewrite <- Rmult_assoc; rewrite (fun (x : R) (y : Z) => Rmult_comm x y); rewrite Rmult_assoc; auto. simpl in |- *; intros; apply Zle_antisym; auto with zarith. simpl in |- *; auto. intros H'5; elim H'5; intros H'6 H'7; auto. case (FcanonicLtPos _ radixMoreThanOne b precision) with (p := q) (q := Float (nNormMin radix precision) (Zsucc (Fexp p))); auto with arith. left; repeat split; simpl in |- *. rewrite Zabs_eq; auto with float zarith. apply ZltNormMinVnum; auto with zarith. apply Zlt_le_weak; auto with zarith. apply nNormPos; auto with zarith. case H'; auto with zarith float. rewrite (PosNormMin radix b precision); auto with zarith. apply Rle_trans with (1 := H'1); auto with real. apply Rlt_trans with (1 := H'3). unfold FtoR in |- *; simpl in |- *. rewrite powerRZ_Zs; auto with real arith; auto. rewrite <- Rmult_assoc; rewrite (fun (x : R) (y : Z) => Rmult_comm x y); rewrite Rmult_assoc; auto. apply Rmult_lt_compat_l; auto with real arith. replace (Fexp p) with (- dExp b)%Z. change (p < firstNormalPos radix b precision)%R in |- *. apply (FsubnormalLtFirstNormalPos radix); auto with arith. case H'; intros Z1 (Z2, Z3); auto. auto with real zarith. simpl in |- *; auto. intros H; apply Zle_antisym; auto with zarith. intros H'5; elim H'5; intros H'6 H'7; rewrite H'6; clear H'5; auto. Qed. Theorem ExactMinusIntervalAux : forall P, RoundedModeP b radix P -> forall p q : float, (0 < p)%R -> (2%nat * p < q)%R -> Fcanonic radix b p -> Fcanonic radix b q -> (exists r : float, Fbounded b r /\ r = (q - p)%R :>R) -> forall r : float, Fcanonic radix b r -> (2%nat * p < r)%R -> (r <= q)%R -> exists r' : float, Fbounded b r' /\ r' = (r - p)%R :>R. intros P H' p q H'0 H'1 H'2 H'3 H'4 r H'5 H'6 H'7. cut (0 <= p)%R; [ intros Rle0 | apply Rlt_le; auto ]. cut (0 <= r)%R; [ intros Rle1 | apply Rle_trans with (2%nat * p)%R; auto ]. 2: apply Rle_trans with (FtoRradix p); auto with float arith. 2: apply Rledouble; auto. 2: apply Rlt_le; auto. generalize H'6; clear H'6; pattern r in |- *; apply (FinductNeg b radix precision) with (p := q); auto with arith. apply Rle_trans with (FtoRradix r); auto. intros q0 H'6 H'8 H'9 H'10 H'11. elim H'10; [ intros r' E; elim E; intros H'13 H'14; clear E H'10 | clear H'10 ]; auto. 2: apply Rlt_trans with (1 := H'11); auto; apply (FPredLt b radix precision); auto with arith. cut (0 <= Fnormalize radix b precision r')%R; [ intros Rle2 | idtac ]. 2: rewrite (FnormalizeCorrect radix); auto with arith. 2: unfold FtoRradix in H'14; rewrite H'14. 2: apply Rplus_le_reg_l with (r := FtoR radix p). 2: replace (FtoR radix p + 0)%R with (FtoR radix p); [ idtac | ring ]. 2: replace (FtoR radix p + (FtoR radix q0 - FtoR radix p))%R with (FtoR radix q0); [ idtac | ring ]. 2: apply Rle_trans with (2%nat * p)%R; auto. 2: apply Rledouble; auto with real arith. 2: apply Rlt_le; apply Rlt_trans with (1 := H'11); auto with float. 2: apply (FPredLt b radix precision); auto with arith. cut (Fnormalize radix b precision r' < q0)%R; [ intros Rle3 | idtac ]. 2: rewrite (FnormalizeCorrect radix); auto with arith. 2: unfold FtoRradix in H'14; rewrite H'14. 2: apply Rplus_lt_reg_r with (r := (- q0)%R). 2: replace (- q0 + (FtoR radix q0 - FtoR radix p))%R with (- p)%R; [ idtac | unfold FtoRradix in |- *; ring; ring ]. 2: replace (- q0 + q0)%R with (-0)%R; [ auto with real | ring ]. case radixRangeBoundExp with (p := Fnormalize radix b precision r') (q := q0); auto with float arith; fold FtoRradix in |- *. rewrite (FnormalizeCorrect radix); auto with arith. apply Rlt_le_trans with (2%nat * r')%R; auto. rewrite H'14. rewrite Rmult_minus_distr_l. pattern (FtoRradix q0) at 1 in |- *; (replace (FtoRradix q0) with (2%nat * q0 - q0)%R; [ idtac | simpl in |- *; ring ]). unfold Rminus in |- *; apply Rplus_lt_compat_l; apply Ropp_lt_contravar. apply Rlt_trans with (1 := H'11). apply (FPredLt b radix precision); auto with arith. apply Rmult_le_compat_r; auto with real arith. unfold FtoRradix in Rle2; rewrite (FnormalizeCorrect radix) in Rle2; auto with arith. rewrite INR_IZR_INZ; cut (2 <= radix)%Z; auto with real zarith. cut (1 < radix)%Z; auto with zarith. intros H'10. case (FcanonicLtPos _ radixMoreThanOne b precision) with (p := Fnormalize radix b precision r') (q := q0); auto with arith. apply FnormalizeCanonic; auto with arith. intros; Contradict H'10; auto with zarith. intros H'12; elim H'12; intros H'15 H'16; clear H'12. exists (Float (Zpred (Fnum (Fnormalize radix b precision r'))) (Fexp (Fnormalize radix b precision r'))). split. cut (Fbounded b (Fnormalize radix b precision r')); [ intros Fb0 | idtac ]. repeat split; simpl in |- *; auto with float. case Rle2; intros Z1. apply Zle_lt_trans with (Zabs (Fnum (Fnormalize radix b precision r'))); auto with float zarith. repeat rewrite Zabs_eq; auto with zarith. apply (LeR0Fnum radix); auto with zarith. apply Zle_Zpred; apply (LtR0Fnum radix); auto with zarith. replace (Fnum (Fnormalize radix b precision r')) with 0%Z; simpl in |- *; auto with zarith. apply (vNumbMoreThanOne radix) with (precision := precision); auto with zarith. apply sym_equal; change (is_Fzero (Fnormalize radix b precision r')) in |- *; apply (is_Fzero_rep2 radix); auto with zarith. apply FcanonicBound with (radix := radix); auto. apply FnormalizeCanonic; auto with arith. replace (Float (Zpred (Fnum (Fnormalize radix b precision r'))) (Fexp (Fnormalize radix b precision r'))) with (Fminus radix (Fnormalize radix b precision r') (Fminus radix q0 (FPred b radix precision q0))). repeat rewrite (Fopp_correct radix); repeat rewrite (Fminus_correct radix); auto with arith. rewrite (FnormalizeCorrect radix); auto with arith. unfold FtoRradix in H'14; rewrite H'14. unfold FtoRradix in |- *; ring; ring. replace (FPred b radix precision q0) with (Float (Zpred (Fnum q0)) (Fexp q0)); auto. unfold Fminus, Fopp, Fplus in |- *; simpl in |- *. repeat rewrite Zmin_n_n; repeat rewrite <- Zminus_diag_reverse; simpl in |- *; auto. rewrite H. repeat rewrite Zmin_n_n; repeat rewrite <- Zminus_diag_reverse; simpl in |- *; auto. rewrite Zpower_nat_O; repeat rewrite Zmult_1_r. apply floatEq; simpl in |- *; auto; unfold Zpred in |- *; ring. case (Z_eq_dec (Fnum q0) (nNormMin radix precision)); intros Zeq2. case (Z_eq_dec (Fexp q0) (- dExp b)); intros Zeq1. rewrite Zeq1; rewrite Zeq2; rewrite <- (FPredSimpl3 b radix); auto with arith; rewrite <- Zeq1; rewrite <- Zeq2; auto. Contradict H'16. apply Zle_not_lt. rewrite Zeq2. rewrite <- (Zabs_eq (Fnum (Fnormalize radix b precision r'))); auto with zarith. apply pNormal_absolu_min with (b := b); auto with arith. cut (Fcanonic radix b (Fnormalize radix b precision r')); [ intros Ca1; case Ca1; auto | auto with float arith ]. intros H'12; case Zeq1; rewrite <- H. case H'12; auto. intros Hbis H0; case H0; auto. apply (LeR0Fnum radix); auto. rewrite FPredSimpl4; auto. Contradict H'16; rewrite H'16. apply Zle_not_lt. unfold pPred in |- *; rewrite Zopp_Zpred_Zs; apply Zlt_le_succ. apply Zlt_Zabs_inv1. cut (Fbounded b (Fnormalize radix b precision r')); [ auto with float | idtac ]. apply (FcanonicBound radix b); auto with float arith. intros H'10. case (Z_eq_dec (Fnum q0) (nNormMin radix precision)); intros Zeq2. exists (Float (Zpred (Fnum (Fnormalize radix b precision r'))) (Fexp (Fnormalize radix b precision r'))). cut (Fbounded b (Fnormalize radix b precision r')); [ intros Fb1 | idtac ]. repeat split; simpl in |- *; auto with float. case Rle2; intros Z1. apply Zlt_trans with (Zabs (Fnum (Fnormalize radix b precision r'))). repeat rewrite Zabs_eq; auto with zarith. apply (LeR0Fnum radix); auto. apply Zle_Zpred; apply (LtR0Fnum radix); auto. case Fb1; auto. replace (Fnum (Fnormalize radix b precision r')) with 0%Z. simpl in |- *; apply (vNumbMoreThanOne radix) with (precision := precision); auto with zarith. apply sym_equal; change (is_Fzero (Fnormalize radix b precision r')) in |- *; apply (is_Fzero_rep2 radix); auto with zarith. rewrite FPredSimpl2; auto with zarith. rewrite <- H'10. cut (forall z : Z, Zpred (Zsucc z) = z); [ intros tmp; rewrite tmp; clear tmp | intros; unfold Zsucc, Zpred in |- *; ring ]. unfold FtoRradix, FtoR in |- *; simpl in |- *. cut (forall x : Z, Zpred x = (x - 1%nat)%Z); [ intros tmp; rewrite tmp; clear tmp | intros; unfold Zpred in |- *; simpl in |- *; ring ]. unfold FtoRradix, FtoR in |- *; simpl in |- *. rewrite <- Z_R_minus; auto. rewrite (fun x y => Rmult_comm (x - y)); rewrite Rmult_minus_distr_l; repeat rewrite (fun x y => Rmult_comm (powerRZ x y)). replace (Fnum (Fnormalize radix b precision r') * powerRZ radix (Fexp (Fnormalize radix b precision r')))%R with (FtoRradix (Fnormalize radix b precision r')). rewrite (FnormalizeCorrect radix); auto. unfold FtoRradix in H'14; rewrite H'14. unfold FtoR in |- *; simpl in |- *. pattern (Fexp q0) at 1 in |- *; rewrite <- H'10. rewrite Zeq2; rewrite powerRZ_Zs; auto with real zarith. rewrite <- Rmult_assoc. replace (nNormMin radix precision * radix)%R with (powerRZ radix precision). unfold pPred, nNormMin, Zpred in |- *; rewrite pGivesBound. rewrite plus_IZR; repeat rewrite Zpower_nat_Z_powerRZ; simpl in |- *; try ring. rewrite <- Zpower_nat_Z_powerRZ; auto with zarith; rewrite <- Rmult_IZR; rewrite Zmult_comm; rewrite <- (PosNormMin radix b precision); auto with real zarith. auto. red in |- *; intros H'12; absurd (- dExp b <= Fexp (Fnormalize radix b precision r'))%Z; auto with float. apply Zlt_not_le. rewrite <- H'12; rewrite <- H'10; unfold Zsucc in |- *; auto with float zarith. apply (FcanonicBound radix b); auto with arith. apply FnormalizeCanonic; auto with arith. exists (Float (Fnum (Fnormalize radix b precision r') - radix) (Fexp (Fnormalize radix b precision r'))). cut (Fbounded b (Fnormalize radix b precision r')); [ intros Fb1 | idtac ]. repeat split; simpl in |- *; auto with float. case (Zle_or_lt (Fnum (Fnormalize radix b precision r')) radix); intros Z1. apply Zle_lt_trans with radix. rewrite Zabs_eq_opp; auto with zarith. cut (0 <= Fnum (Fnormalize radix b precision r'))%Z; auto with zarith. apply (LeR0Fnum radix); auto. rewrite <- (Zpower_nat_1 radix); rewrite pGivesBound; auto with zarith. apply Zle_lt_trans with (Zabs (Fnum (Fnormalize radix b precision r'))). repeat rewrite Zabs_eq; auto with zarith. case Fb1; auto. rewrite FPredSimpl4; auto with arith. rewrite <- H'10. unfold FtoRradix, FtoR in |- *; simpl in |- *. cut (forall x : Z, Zpred x = (x - 1%nat)%Z); [ intros tmp; rewrite tmp; clear tmp | intros; unfold Zpred in |- *; simpl in |- *; ring ]. repeat rewrite <- Z_R_minus; auto. repeat rewrite (fun x y => Rmult_comm (x - y)); repeat rewrite Rmult_minus_distr_l; repeat rewrite (fun x y => Rmult_comm (powerRZ x y)). replace (Fnum (Fnormalize radix b precision r') * powerRZ radix (Fexp (Fnormalize radix b precision r')))%R with (FtoRradix (Fnormalize radix b precision r')). rewrite (FnormalizeCorrect radix); auto. unfold FtoRradix in H'14; rewrite H'14. unfold FtoR in |- *; simpl in |- *. rewrite <- H'10. repeat rewrite powerRZ_Zs; auto with real arith. ring. auto with real zarith. unfold FtoR in |- *; simpl in |- *; auto. red in |- *; intros H'12; absurd (0 <= Fnum q0)%Z; auto. apply Zlt_not_le. rewrite H'12. replace 0%Z with (- 0%nat)%Z; [ apply Zlt_Zopp | simpl in |- *; auto ]. unfold pPred in |- *; apply Zlt_succ_pred; simpl in |- *; auto with zarith. apply (vNumbMoreThanOne radix) with (precision := precision); auto with zarith. apply (LeR0Fnum radix); auto. apply Rlt_le; auto. apply (FcanonicBound radix b); auto with arith. apply FnormalizeCanonic; auto with arith. Qed. Theorem ExactMinusIntervalAux1 : forall P, RoundedModeP b radix P -> forall p q : float, (0 <= p)%R -> (p <= q)%R -> Fcanonic radix b p -> Fcanonic radix b q -> (exists r : float, Fbounded b r /\ r = (q - p)%R :>R) -> forall r : float, Fcanonic radix b r -> (p <= r)%R -> (r <= q)%R -> exists r' : float, Fbounded b r' /\ r' = (r - p)%R :>R. intros P H' p q H'0 H'1 H'2 H'3 H'4 r H'5 H'6 H'7. Casec H'0; intros H'0. case (Rle_or_lt q (2%nat * p)); intros Rl1. exists (Fminus radix r p); split; auto. rewrite <- Fopp_Fminus. apply oppBounded. apply Sterbenz; auto. apply (FcanonicBound radix b); auto with arith. apply (FcanonicBound radix b); auto with arith. apply Rmult_le_reg_l with (r := INR 2); auto with real. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real arith; rewrite Rmult_1_l; auto. apply Rle_trans with (1 := H'7); auto. apply Rle_trans with (1 := H'6); auto. apply Rledouble; auto. apply Rle_trans with (2 := H'6); apply Rlt_le; auto. rewrite (Fminus_correct radix); auto with arith. case (Rle_or_lt r (2%nat * p)); intros Rl2. exists (Fminus radix r p); split; auto. rewrite <- Fopp_Fminus. apply oppBounded. apply Sterbenz; auto. apply (FcanonicBound radix b); auto with arith. apply (FcanonicBound radix b); auto with arith. apply Rmult_le_reg_l with (r := INR 2); auto with real. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real arith; rewrite Rmult_1_l; auto. apply Rle_trans with (1 := H'6); auto. apply Rledouble; auto. apply Rle_trans with (2 := H'6); apply Rlt_le; auto. rewrite (Fminus_correct radix); auto with arith. apply ExactMinusIntervalAux with (P := P) (q := q); auto. exists r; split; auto. apply (FcanonicBound radix b); auto with arith. rewrite <- H'0; ring. Qed. Theorem ExactMinusInterval : forall P, RoundedModeP b radix P -> forall p q : float, (0 <= p)%R -> (p <= q)%R -> Fbounded b p -> Fbounded b q -> (exists r : float, Fbounded b r /\ r = (q - p)%R :>R) -> forall r : float, Fbounded b r -> (p <= r)%R -> (r <= q)%R -> exists r' : float, Fbounded b r' /\ r' = (r - p)%R :>R. intros P H' p q H'0 H'1 H'2 H'3 H'4 r H'5 H'6 H'7. replace (FtoRradix r) with (FtoRradix (Fnormalize radix b precision r)); [ idtac | apply (FnormalizeCorrect radix) ]; auto. replace (FtoRradix p) with (FtoRradix (Fnormalize radix b precision p)); [ idtac | apply (FnormalizeCorrect radix) ]; auto. apply ExactMinusIntervalAux1 with (P := P) (q := Fnormalize radix b precision q); auto; try repeat rewrite (FnormalizeCorrect radix); auto; apply FnormalizeCanonic; auto with arith. Qed. (* Properties concerning LSB MSB *) Theorem MSBroundLSB : forall P : R -> float -> Prop, RoundedModeP b radix P -> forall f1 f2 : float, P f1 f2 -> ~ is_Fzero (Fminus radix f1 f2) -> (MSB radix (Fminus radix f1 f2) < LSB radix f2)%Z. intros P H' f1 f2 H'0 HZ. apply (oneExp_Zlt radix); auto. apply Rlt_le_trans with (Fulp b radix precision f2). apply Rle_lt_trans with (FtoRradix (Fabs (Fminus radix f1 f2))). unfold FtoRradix in |- *; apply MSB_le_abs; auto. unfold FtoRradix in |- *; rewrite Fabs_correct; auto with arith; rewrite Fminus_correct; auto with arith. apply RoundedModeUlp with (4 := H'); auto. apply FUlp_Le_LSigB; auto. apply RoundedModeBounded with (1 := H') (2 := H'0); auto. Qed. Theorem LSBMinus : forall p q : float, ~ is_Fzero (Fminus radix p q) -> (Zmin (LSB radix p) (LSB radix q) <= LSB radix (Fminus radix p q))%Z. intros p q H'1. elim (LSB_rep_min radix) with (p := p); auto; intros z E. elim (LSB_rep_min radix) with (p := q); auto; intros z0 E0. replace (LSB radix (Fminus radix p q)) with (LSB radix (Fminus radix (Float z (LSB radix p)) (Float z0 (LSB radix q)))). replace (Zmin (LSB radix p) (LSB radix q)) with (Fexp (Fminus radix (Float z (LSB radix p)) (Float z0 (LSB radix q)))); [ idtac | simpl in |- *; auto ]. apply Fexp_le_LSB; auto. apply sym_equal; apply LSB_comp; auto. repeat rewrite Fminus_correct; auto with arith. unfold FtoRradix in E; unfold FtoRradix in E0; rewrite E; rewrite E0; auto. Qed. Theorem LSBPlus : forall p q : float, ~ is_Fzero (Fplus radix p q) -> (Zmin (LSB radix p) (LSB radix q) <= LSB radix (Fplus radix p q))%Z. intros p q H'. elim (LSB_rep_min _ radixMoreThanOne p); intros z E. elim (LSB_rep_min _ radixMoreThanOne q); intros z0 E0. replace (LSB radix (Fplus radix p q)) with (LSB radix (Fplus radix (Float z (LSB radix p)) (Float z0 (LSB radix q)))). replace (Zmin (LSB radix p) (LSB radix q)) with (Fexp (Fplus radix (Float z (LSB radix p)) (Float z0 (LSB radix q)))); [ idtac | simpl in |- *; auto ]. apply Fexp_le_LSB; auto. apply sym_equal; apply LSB_comp; auto. repeat rewrite Fplus_correct; auto with arith. unfold FtoRradix in E; unfold FtoRradix in E0; rewrite E; rewrite E0; auto. Qed. End FRoundP. Float8.4/FroundProp.v0000644000423700002640000015117312032774525014345 0ustar sboldotoccata(**************************************************************************** IEEE754 : FroundProp Laurent Thery, Sylvie Boldo ******************************************************************************) Require Export Fround. Require Export MSB. Section FRoundP. Variable b : Fbound. Variable radix : Z. Variable precision : 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 precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Definition Fulp (p : float) := powerRZ radix (Fexp (Fnormalize radix b precision p)). Theorem FulpComp : forall p q : float, Fbounded b p -> Fbounded b q -> p = q :>R -> Fulp p = Fulp q. intros p q H' H'0 H'1; unfold Fulp in |- *. rewrite FcanonicUnique with (p := Fnormalize radix b precision p) (q := Fnormalize radix b precision q) (3 := pGivesBound); auto with float arith. apply trans_eq with (FtoR radix p). apply FnormalizeCorrect; auto. apply trans_eq with (FtoR radix q); auto. apply sym_eq; apply FnormalizeCorrect; auto. Qed. Theorem FulpLe : forall p : float, Fbounded b p -> (Fulp p <= Float 1 (Fexp p))%R. intros p H'; unfold Fulp, FtoRradix, FtoR, Fnormalize in |- *; simpl in |- *; rewrite Rmult_1_l. case (Z_zerop (Fnum p)); simpl in |- *; auto. intros H'0; apply (Rle_powerRZ radix (- dExp b) (Fexp p)); auto with float real zarith. intros H'0; apply Rle_powerRZ; auto with real zarith arith. Qed. Theorem Fulp_zero : forall x : float, is_Fzero x -> Fulp x = powerRZ radix (- dExp b). intros x; unfold is_Fzero, Fulp, Fnormalize in |- *; case (Z_zerop (Fnum x)); simpl in |- *; auto. intros H' H'0; Contradict H'; auto. Qed. Theorem FulpLe2 : forall p : float, Fbounded b p -> Fnormal radix b (Fnormalize radix b precision p) -> (Fulp p <= Rabs p * powerRZ radix (Zsucc (- precision)))%R. intros p H1 H2; unfold Fulp in |- *. replace (FtoRradix p) with (FtoRradix (Fnormalize radix b precision p)); [ idtac | unfold FtoRradix in |- *; apply FnormalizeCorrect; auto ]. apply Rmult_le_reg_l with (powerRZ radix (Zpred precision)). apply powerRZ_lt; auto with real arith. replace (powerRZ radix (Zpred precision) * (Rabs (Fnormalize radix b precision p) * powerRZ radix (Zsucc (- precision))))%R with (Rabs (Fnormalize radix b precision p)). unfold FtoRradix in |- *; rewrite <- Fabs_correct; auto with arith real. unfold Fabs, FtoR in |- *; simpl in |- *. apply Rmult_le_compat_r; [ apply powerRZ_le | rewrite <- inj_pred ]; auto with real arith zarith. rewrite <- Zpower_nat_Z_powerRZ. replace (Zpower_nat radix (pred precision)) with (nNormMin radix precision); auto; apply Rle_IZR. apply pNormal_absolu_min with b; auto with arith zarith real. apply trans_eq with (Rabs (Fnormalize radix b precision p) * (powerRZ radix (Zpred precision) * powerRZ radix (Zsucc (- precision))))%R; [ idtac | ring ]. rewrite <- powerRZ_add; auto with zarith real. replace (Zpred precision + Zsucc (- precision))%Z with 0%Z; [ simpl in |- *; ring | unfold Zsucc, Zpred in |- *; ring ]; auto with real zarith. Qed. Theorem FulpGe : forall p : float, Fbounded b p -> (Rabs p <= (powerRZ radix precision - 1) * Fulp p)%R. intros p H. replace (FtoRradix p) with (FtoRradix (Fnormalize radix b precision p)); [ idtac | unfold FtoRradix in |- *; apply FnormalizeCorrect; auto ]. unfold FtoRradix in |- *; rewrite <- Fabs_correct; auto with arith real. unfold FtoR in |- *; simpl in |- *; unfold Fulp in |- *. apply Rmult_le_compat_r; [ apply powerRZ_le | idtac ]; auto with real arith zarith. apply Rle_trans with (IZR (Zpred (Zpos (vNum b)))); [ apply Rle_IZR; auto with float zarith | idtac ]. unfold Zpred in |- *; right; rewrite pGivesBound; replace 1%R with (IZR 1); auto with real. rewrite <- Zpower_nat_Z_powerRZ; rewrite Z_R_minus;auto. Qed. Theorem LeFulpPos : forall x y : float, Fbounded b x -> Fbounded b y -> (0 <= x)%R -> (x <= y)%R -> (Fulp x <= Fulp y)%R. intros x y Hx Hy H1 H2; unfold Fulp in |- *. apply Rle_powerRZ; auto with real zarith. apply Fcanonic_Rle_Zle with radix b precision; auto with zarith arith. apply FnormalizeCanonic; auto with zarith arith. apply FnormalizeCanonic; auto with zarith arith. repeat rewrite FnormalizeCorrect; auto with zarith arith real. repeat rewrite Rabs_right; auto with zarith arith real. apply Rge_trans with (FtoRradix x); auto with real. Qed. Theorem FulpSucCan : forall p : float, Fcanonic radix b p -> (FSucc b radix precision p - p <= Fulp p)%R. intros p H'. replace (Fulp p) with (powerRZ radix (Fexp p)). 2: unfold Fulp in |- *; replace (Fnormalize radix b precision p) with p; auto; apply sym_equal; apply FcanonicUnique with (3 := pGivesBound); auto with arith; apply FnormalizeCanonic || apply FnormalizeCorrect; auto with float zarith. 2: apply FcanonicBound with (1 := H'); auto with float zarith. unfold FtoRradix in |- *; rewrite <- Fminus_correct; auto with zarith. case (Z_eq_dec (Fnum p) (- nNormMin radix precision)); intros H1'. case (Z_eq_dec (Fexp p) (- dExp b)); intros H2'. rewrite FSuccDiff2; auto with arith. unfold FtoR in |- *; simpl in |- *; rewrite Rmult_1_l; auto with real. rewrite FSuccDiff3; auto with arith. unfold FtoR in |- *; simpl in |- *; rewrite Rmult_1_l. apply Rlt_le; apply Rlt_powerRZ; auto with real zarith. unfold Zpred in |- *; auto with zarith. rewrite FSuccDiff1; auto with arith. unfold FtoR in |- *; simpl in |- *; rewrite Rmult_1_l; auto with real. Qed. Theorem FulpSuc : forall p : float, Fbounded b p -> (FNSucc b radix precision p - p <= Fulp p)%R. intros p H'. replace (Fulp p) with (Fulp (Fnormalize radix b precision p)). replace (FtoRradix p) with (FtoRradix (Fnormalize radix b precision p)). unfold FNSucc in |- *; apply FulpSucCan; auto with float arith. unfold FtoRradix in |- *; apply FnormalizeCorrect; auto. apply FulpComp; auto with float arith. unfold FtoRradix in |- *; apply FnormalizeCorrect; auto. Qed. Theorem FulpPredCan : forall p : float, Fcanonic radix b p -> (p - FPred b radix precision p <= Fulp p)%R. intros p H'. replace (Fulp p) with (powerRZ radix (Fexp p)). 2: unfold Fulp in |- *; replace (Fnormalize radix b precision p) with p; auto; apply sym_equal; apply FcanonicUnique with (3 := pGivesBound); auto with arith; apply FnormalizeCanonic || apply FnormalizeCorrect; auto with arith. unfold FtoRradix in |- *; rewrite <- Fminus_correct; auto with arith. case (Z_eq_dec (Fnum p) (nNormMin radix precision)); intros H1'. case (Z_eq_dec (Fexp p) (- dExp b)); intros H2'. rewrite FPredDiff2; auto with arith. unfold FtoR in |- *; simpl in |- *; rewrite Rmult_1_l; auto with real. rewrite FPredDiff3; auto with arith. unfold FtoR in |- *; simpl in |- *; rewrite Rmult_1_l; auto with real. apply Rlt_le; apply Rlt_powerRZ; auto with real zarith. replace 1%R with (INR 1); auto with real arith. unfold Zpred in |- *; auto with zarith. rewrite FPredDiff1; auto with arith. unfold FtoR in |- *; simpl in |- *; rewrite Rmult_1_l; auto with real. apply FcanonicBound with (1 := H'). Qed. Theorem FulpPred : forall p : float, Fbounded b p -> (p - FNPred b radix precision p <= Fulp p)%R. intros p H'. replace (Fulp p) with (Fulp (Fnormalize radix b precision p)). replace (FtoRradix p) with (FtoRradix (Fnormalize radix b precision p)). unfold FNPred in |- *; apply FulpPredCan; auto with float arith. unfold FtoRradix in |- *; apply FnormalizeCorrect; auto. apply FulpComp; auto with float arith. unfold FtoRradix in |- *; apply FnormalizeCorrect; auto. Qed. Theorem FSuccDiffPos : forall x : float, (0 <= x)%R -> Fminus radix (FSucc b radix precision x) x = Float 1%nat (Fexp x) :>R. intros x H. unfold FtoRradix in |- *; apply FSuccDiff1; auto with arith. Contradict H; unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite H. apply Rlt_not_le. replace 0%R with (0 * powerRZ radix (Fexp x))%R; [ idtac | ring ]. apply Rlt_monotony_exp; auto with real arith. generalize (nNormPos _ radixMoreThanOne precision); replace 0%R with (IZR (- 0%nat)); auto with real zarith arith. Qed. Theorem FulpFPredGePos : forall f : float, Fbounded b f -> Fcanonic radix b f -> (0 < f)%R -> (Fulp (FPred b radix precision f) <= Fulp f)%R. intros f Hf1 Hf2 H. apply LeFulpPos; auto with zarith float; unfold FtoRradix in |- *. apply R0RltRlePred; auto with arith. apply Rlt_le; apply FPredLt; auto with arith. Qed. Theorem CanonicFulp : forall p : float, Fcanonic radix b p -> Fulp p = Float 1%nat (Fexp p). intros p H; unfold Fulp in |- *. rewrite FcanonicFnormalizeEq; auto with arith. unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. Qed. Theorem FSuccUlpPos : forall x : float, Fcanonic radix b x -> (0 <= x)%R -> Fminus radix (FSucc b radix precision x) x = Fulp x :>R. intros x H H0; rewrite CanonicFulp; auto. apply FSuccDiffPos; auto. Qed. Theorem FNSuccUlpPos : forall x : float, Fcanonic radix b x -> (0 <= x)%R -> Fminus radix (FNSucc b radix precision x) x = Fulp x :>R. intros x H H0. unfold FNSucc in |- *. rewrite FcanonicFnormalizeEq; auto with arith. apply FSuccUlpPos; auto. Qed. Theorem FulpFabs : forall f : float, Fulp f = Fulp (Fabs f) :>R. intros f; unfold Fulp in |- *; case (Rle_or_lt 0 f); intros H'. replace (Fabs f) with f; auto; unfold Fabs in |- *; apply floatEq; simpl in |- *; auto with zarith real. apply sym_eq; apply Zabs_eq; apply LeR0Fnum with radix; auto with zarith real. replace (Fabs f) with (Fopp f); [ rewrite Fnormalize_Fopp | apply floatEq; simpl in |- * ]; auto with arith. apply sym_eq; apply Zabs_eq_opp; apply R0LeFnum with radix; auto with zarith real. Qed. Theorem RoundedModeUlp : forall P, RoundedModeP b radix P -> forall (p : R) (q : float), P p q -> (Rabs (p - q) < Fulp q)%R. intros P H' p q H'0. case (Req_dec p q); intros Eq1. rewrite <- Eq1. replace (p - p)%R with 0%R; [ idtac | ring ]. rewrite Rabs_R0; auto. unfold Fulp, FtoRradix, FtoR in |- *; simpl in |- *; auto with real arith. case H'. intros H'1 H'2; elim H'2; intros H'3 H'4; elim H'4; intros H'5 H'6; case H'5 with (1 := H'0); clear H'5 H'4 H'2; intros H'5. rewrite Rabs_right; auto. cut (Fbounded b q); [ intros B0 | case H'5; auto ]. apply Rlt_le_trans with (2 := FulpSuc q B0). apply Rplus_lt_reg_r with (r := FtoR radix q). repeat rewrite Rplus_minus; auto. case (Rle_or_lt (FNSucc b radix precision q) p); auto. intros H'2; absurd (FNSucc b radix precision q <= q)%R; auto. apply Rgt_not_le; red in |- *; unfold FtoRradix in |- *; auto with real float arith. case H'5; auto. intros H'4 H'7; elim H'7; intros H'8 H'9; apply H'9; clear H'7; auto. apply (FcanonicBound radix b); auto with float arith. apply Rle_ge; apply Rplus_le_reg_l with (r := FtoR radix q). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; apply isMin_inv1 with (1 := H'5); auto. rewrite Faux.Rabsolu_left1; auto. rewrite Ropp_minus_distr; auto. cut (Fbounded b q); [ intros B0 | case H'5; auto ]. apply Rlt_le_trans with (2 := FulpPred q B0). apply Ropp_lt_cancel; repeat rewrite Rminus_0_l. apply Rplus_lt_reg_r with (r := FtoR radix q). repeat rewrite Rplus_minus; auto. case (Rle_or_lt p (FNPred b radix precision q)); auto. intros H'2; absurd (q <= FNPred b radix precision q)%R; auto. apply Rgt_not_le; red in |- *; unfold FtoRradix in |- *; auto with real float arith. case H'5; auto. intros H'4 H'7; elim H'7; intros H'8 H'9; apply H'9; clear H'7; auto. apply (FcanonicBound radix b); auto with float arith. intros H1; apply Rplus_lt_compat_l; auto with real; apply Ropp_lt_contravar; unfold Rminus in |- *; auto with real. apply Rplus_le_reg_l with (r := FtoR radix q). repeat rewrite Rplus_minus; auto. rewrite Rplus_0_r; apply isMax_inv1 with (1 := H'5). Qed. Theorem RoundedModeErrorExpStrict : forall P, RoundedModeP b radix P -> forall (p q : float) (x : R), Fbounded b p -> Fbounded b q -> P x p -> q = (x - p)%R :>R -> q <> 0%R :>R -> (Fexp q < Fexp p)%Z. intros P H p q x H0 H1 H2 H3 H4. apply Zlt_powerRZ with (e := IZR radix); auto with real zarith. apply Rle_lt_trans with (FtoRradix (Fabs q)). replace (powerRZ radix (Fexp q)) with (FtoRradix (Float 1%nat (Fexp q))); unfold FtoRradix in |- *; [ apply Fop.RleFexpFabs; auto with arith | unfold FtoR in |- *; simpl in |- *; ring ]. rewrite (Fabs_correct radix); auto with zarith. fold FtoRradix in |- *; rewrite H3. apply Rlt_le_trans with (Fulp p); [ apply RoundedModeUlp with P; auto | unfold Fulp in |- * ]. apply Rle_powerRZ; auto with real zarith. apply FcanonicLeastExp with radix b precision; auto with real arith. apply sym_eq; apply FnormalizeCorrect; auto. apply FnormalizeCanonic; auto with zarith. Qed. Theorem RoundedModeProjectorIdem : forall P (p : float), RoundedModeP b radix P -> Fbounded b p -> P p p. intros P p H' H. elim H'; intros H'0 H'1; elim H'1; intros H'2 H'3; elim H'3; intros H'4 H'5; clear H'3 H'1. case (H'0 p). intros x H'6. apply (H'2 p p x); auto. apply sym_eq; apply (RoundedProjector _ _ P H'); auto. Qed. Theorem RoundedModeBounded : forall P (r : R) (q : float), RoundedModeP b radix P -> P r q -> Fbounded b q. intros P r q H' H'0. case H'. intros H'1 H'2; elim H'2; intros H'3 H'4; elim H'4; intros H'5 H'6; case H'5 with (1 := H'0); clear H'4 H'2; intros H; case H; auto. Qed. Theorem RoundedModeProjectorIdemEq : forall (P : R -> float -> Prop) (p q : float), RoundedModeP b radix P -> Fbounded b p -> P (FtoR radix p) q -> p = q :>R. intros P p q H' H'0 H'1. cut (MinOrMaxP b radix P); [ intros Mn; case (Mn p q); auto; intros Mn1 | auto with inv ]. apply sym_eq; apply MinEq with (1 := Mn1); auto. apply (RoundedModeProjectorIdem (isMin b radix)); auto. apply MinRoundedModeP with (precision := precision); auto. apply sym_eq; apply MaxEq with (1 := Mn1); auto. apply (RoundedModeProjectorIdem (isMax b radix)); auto. apply MaxRoundedModeP with (precision := precision); auto. Qed. Theorem RoundedModeMult : forall P, RoundedModeP b radix P -> forall (r : R) (q q' : float), P r q -> Fbounded b q' -> (r <= radix * q')%R -> (q <= radix * q')%R. intros P H' r q q' H'0 H'1. replace (radix * q')%R with (FtoRradix (Float (Fnum q') (Fexp q' + 1%nat))). intros H'2; case H'2. intros H'3; case H'; intros H'4 H'5; elim H'5; intros H'6 H'7; elim H'7; intros H'8 H'9; apply H'9 with (1 := H'3); clear H'7 H'5; auto. apply RoundedModeProjectorIdem; auto. apply FBoundedScale; auto. intros H'3. replace (FtoRradix q) with (FtoRradix (Float (Fnum q') (Fexp q' + 1%nat))); auto with real. apply (RoundedProjector _ _ P H'); auto. apply FBoundedScale; auto. case H'. intros H'4 H'5; elim H'5; intros H'6 H'7; clear H'5. apply (H'6 r (Float (Fnum q') (Fexp q' + 1%nat)) q); auto. apply RoundedModeBounded with (P := P) (r := r); auto. rewrite (FvalScale _ radixMoreThanOne b). rewrite powerRZ_1; auto. Qed. Theorem RoundedModeMultLess : forall P, RoundedModeP b radix P -> forall (r : R) (q q' : float), P r q -> Fbounded b q' -> (radix * q' <= r)%R -> (radix * q' <= q)%R. intros P H' r q q' H'0 H'1. replace (radix * q')%R with (FtoRradix (Float (Fnum q') (Fexp q' + 1%nat))). intros H'2; case H'2. intros H'3; case H'; intros H'4 H'5; elim H'5; intros H'6 H'7; elim H'7; intros H'8 H'9; apply H'9 with (1 := H'3); clear H'7 H'5; auto. apply RoundedModeProjectorIdem; auto. apply FBoundedScale; auto. intros H'3. replace (FtoRradix q) with (FtoRradix (Float (Fnum q') (Fexp q' + 1%nat))); auto with real. apply (RoundedProjector _ _ P H'); auto. apply FBoundedScale; auto. unfold FtoRradix in H'3; rewrite H'3; auto. case H'. intros H'4 H'5; elim H'5; intros H'6 H'7; clear H'5. unfold FtoRradix in |- *; rewrite FvalScale; auto. rewrite powerRZ_1; auto. Qed. Theorem RleMinR0 : forall (r : R) (min : float), (0 <= r)%R -> isMin b radix r min -> (0 <= min)%R. intros r min H' H'0. rewrite <- (FzeroisZero radix b). case H'; intros H'1. apply (MonotoneMin b radix) with (p := FtoRradix (Fzero (- dExp b))) (q := r); auto. unfold FtoRradix in |- *; rewrite (FzeroisZero radix b); auto. apply (RoundedModeProjectorIdem (isMin b radix)); auto. apply MinRoundedModeP with (precision := precision); auto with float. apply FboundedFzero; auto. replace (FtoR radix (Fzero (- dExp b))) with (FtoRradix min); auto with real. apply sym_eq; apply (ProjectMin b radix). apply FboundedFzero; auto. rewrite <- H'1 in H'0; rewrite <- (FzeroisZero radix b) in H'0; auto. Qed. Theorem RleRoundedR0 : forall (P : R -> float -> Prop) (p : float) (r : R), RoundedModeP b radix P -> P r p -> (0 <= r)%R -> (0 <= p)%R. intros P p r H' H'0 H'1. case H'. intros H'2 H'3; Elimc H'3; intros H'3 H'4; Elimc H'4; intros H'4 H'5; case (H'4 r p); auto; intros H'6. apply RleMinR0 with (r := r); auto. apply Rle_trans with r; auto; apply isMax_inv1 with (1 := H'6). Qed. Theorem RleMaxR0 : forall (r : R) (max : float), (r <= 0)%R -> isMax b radix r max -> (max <= 0)%R. intros r max H' H'0. rewrite <- (FzeroisZero radix b). case H'; intros H'1. apply (MonotoneMax b radix) with (q := FtoRradix (Fzero (- dExp b))) (p := r); auto. unfold FtoRradix in |- *; rewrite FzeroisZero; auto. apply (RoundedModeProjectorIdem (isMax b radix)); auto. apply MaxRoundedModeP with (precision := precision); auto. apply FboundedFzero; auto. replace (FtoR radix (Fzero (- dExp b))) with (FtoRradix max); auto with real. apply sym_eq; apply (ProjectMax b radix). apply FboundedFzero; auto. rewrite H'1 in H'0; rewrite <- (FzeroisZero radix b) in H'0; auto. Qed. Theorem RleRoundedLessR0 : forall (P : R -> float -> Prop) (p : float) (r : R), RoundedModeP b radix P -> P r p -> (r <= 0)%R -> (p <= 0)%R. intros P p r H' H'0 H'1. case H'. intros H'2 H'3; Elimc H'3; intros H'3 H'4; Elimc H'4; intros H'4 H'5; case (H'4 r p); auto; intros H'6. apply Rle_trans with r; auto; apply isMin_inv1 with (1 := H'6). apply RleMaxR0 with (r := r); auto. Qed. Theorem PminPos : forall p min : float, (0 <= p)%R -> Fbounded b p -> isMin b radix (/ 2%nat * p) min -> exists c : float, Fbounded b c /\ c = (p - min)%R :>R. intros p min H' H'0 H'1. cut (min <= / 2%nat * p)%R; [ intros Rl1; Casec Rl1; intros Rl1 | apply isMin_inv1 with (1 := H'1); auto ]. case (eqExpMax _ radixMoreThanOne b min p); auto. case H'1; auto. rewrite Fabs_correct; auto with arith. rewrite Rabs_right; auto. apply Rle_trans with (/ 2%nat * p)%R; auto. apply Rlt_le; auto. apply Rmult_le_reg_l with (r := INR 2); auto with real. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real; rewrite Rmult_ne_r; auto with real. apply Rle_ge; apply RleMinR0 with (r := (/ 2%nat * p)%R); auto. apply Rmult_le_reg_l with (r := INR 2); auto with real. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real; rewrite Rmult_1_l; rewrite Rmult_0_r; auto with real. intros min' H'2; elim H'2; intros H'3 H'4; elim H'4; intros H'5 H'6; clear H'4 H'2. case (FboundNext _ radixMoreThanOne b precision) with (p := min'); auto with arith; fold FtoRradix in |- *. intros Smin H'2; elim H'2; intros H'4 H'7; clear H'2. exists Smin; split; auto. rewrite H'7; auto. unfold FtoRradix in |- *. rewrite <- H'5; auto. replace (Float (Zsucc (Fnum min')) (Fexp min')) with (Float (Fnum (Fshift radix (Zabs_nat (Fexp p - Fexp min')) p) - Fnum min') (Fexp min')); auto. unfold FtoRradix, FtoR in |- *; simpl in |- *. rewrite <- Z_R_minus. rewrite (fun x y z : R => Rmult_comm (x - y) z); rewrite Rmult_minus_distr_l; repeat rewrite (fun x : Z => Rmult_comm (powerRZ radix x)). rewrite Rmult_IZR. rewrite Zpower_nat_powerRZ_absolu; auto with zarith. rewrite Rmult_assoc. rewrite <- (powerRZ_add radix); auto with real zarith. replace (Fexp p - Fexp min' + Fexp min')%Z with (Fexp p); [ auto | ring ]. apply floatEq; auto; simpl in |- *. apply Zle_antisym. apply Zlt_succ_le. apply Zplus_lt_reg_l with (p := Fnum min'); auto. cut (forall x y : Z, (x + (y - x))%Z = y); [ intros tmp; rewrite tmp; clear tmp | intros; ring ]. replace (Fnum min' + Zsucc (Zsucc (Fnum min')))%Z with (2%nat * Zsucc (Fnum min'))%Z. apply (Rlt_Float_Zlt radix) with (r := Fexp min'); auto; fold FtoRradix in |- *. replace (FtoRradix (Float (2%nat * Zsucc (Fnum min')) (Fexp min'))) with (2%nat * Float (Zsucc (Fnum min')) (Fexp min'))%R. rewrite <- H'7. replace (Float (Fnum p * Zpower_nat radix (Zabs_nat (Fexp p - Fexp min'))) (Fexp min')) with (Fshift radix (Zabs_nat (Fexp p - Fexp min')) p). unfold FtoRradix in |- *; rewrite FshiftCorrect; auto. apply Rmult_lt_reg_l with (r := (/ 2%nat)%R); auto with real. rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real; rewrite Rmult_1_l; auto with real. case (Rle_or_lt Smin (/ 2%nat * FtoR radix p)); auto. intros H'2; absurd (min < Smin)%R. apply Rle_not_lt. case H'1; auto. intros H'8 H'9; elim H'9; intros H'10 H'11; apply H'11; clear H'9; auto. rewrite H'7; unfold FtoRradix in |- *; rewrite <- H'5; auto. unfold FtoR in |- *; simpl in |- *; apply Rlt_monotony_exp; auto with real zarith. unfold Fshift in |- *; simpl in |- *. replace (Fexp p - Zabs_nat (Fexp p - Fexp min'))%Z with (Fexp min'); auto. rewrite inj_abs; auto. ring. auto with zarith. replace (FtoRradix (Float (2%nat * Zsucc (Fnum min')) (Fexp min'))) with ((2%nat * Zsucc (Fnum min'))%Z * powerRZ radix (Fexp min'))%R. rewrite Rmult_IZR; auto. unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. simpl in |- *; auto. replace (Z_of_nat 2) with (Zsucc (Zsucc 0)). repeat rewrite <- Zmult_succ_l_reverse; unfold Zsucc in |- *; ring. simpl in |- *; auto. apply Zlt_le_succ; auto. apply Zplus_lt_reg_l with (p := Fnum min'); auto. cut (forall x y : Z, (x + (y - x))%Z = y); [ intros tmp; rewrite tmp; clear tmp | intros; ring ]. replace (Fnum min' + Fnum min')%Z with (2%nat * Fnum min')%Z. apply (Rlt_Float_Zlt radix) with (r := Fexp min'); auto; fold FtoRradix in |- *. replace (FtoRradix (Float (2%nat * Fnum min') (Fexp min'))) with (2%nat * Float (Fnum min') (Fexp min'))%R. replace (Float (Fnum p * Zpower_nat radix (Zabs_nat (Fexp p - Fexp min'))) (Fexp min')) with (Fshift radix (Zabs_nat (Fexp p - Fexp min')) p). unfold FtoRradix in |- *; rewrite FshiftCorrect; auto. apply Rmult_lt_reg_l with (r := (/ 2%nat)%R); auto with real. rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real; rewrite Rmult_1_l; auto with real. replace (FtoR radix (Float (Fnum min') (Fexp min'))) with (FtoR radix min); auto. unfold Fshift in |- *; simpl in |- *. replace (Fexp p - Zabs_nat (Fexp p - Fexp min'))%Z with (Fexp min'); auto. rewrite inj_abs; auto. ring. auto with zarith. replace (FtoRradix (Float (2%nat * Fnum min') (Fexp min'))) with ((2%nat * Fnum min')%Z * powerRZ radix (Fexp min'))%R. rewrite Rmult_IZR; auto. unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. simpl in |- *; auto. replace (Z_of_nat 2) with (Zsucc (Zsucc 0)). repeat rewrite <- Zmult_succ_l_reverse; unfold Zsucc in |- *; ring. simpl in |- *; auto. exists min; split; auto. case H'1; auto. rewrite Rl1. pattern (FtoRradix p) at 2 in |- *; replace (FtoRradix p) with (2%nat * (/ 2%nat * p))%R. simpl in |- *; ring. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real; rewrite Rmult_ne_r; auto with real. Qed. Theorem div2IsBetweenPos : forall p min max : float, (0 <= p)%R -> Fbounded b p -> isMin b radix (/ 2%nat * p) min -> isMax b radix (/ 2%nat * p) max -> p = (min + max)%R :>R. intros p min max P H' H'0 H'1; apply Rle_antisym. apply Rplus_le_reg_l with (r := (- max)%R). replace (- max + p)%R with (p - max)%R; [ idtac | ring ]. replace (- max + (min + max))%R with (FtoRradix min); [ idtac | ring ]. rewrite <- (Fminus_correct radix); auto with arith. case H'0. intros H'2 H'3; elim H'3; intros H'4 H'5; apply H'5; clear H'3; auto. apply Sterbenz; auto. case H'1; auto. apply Rle_trans with (FtoRradix max); auto. apply Rmult_le_reg_l with (r := INR 2); auto with real. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real; rewrite Rmult_1_l; auto with real. apply Rledouble; auto. apply Rle_trans with (FtoRradix min); auto. apply RleMinR0 with (r := (/ 2%nat * p)%R); auto. apply Rmult_le_reg_l with (r := INR 2); auto with real. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real; rewrite Rmult_1_l; rewrite Rmult_0_r; auto with real. apply Rle_trans with (/ 2%nat * p)%R; auto; apply isMax_inv1 with (1 := H'1). case H'1. intros H'3 H'6; elim H'6; intros H'7 H'8; apply H'8; clear H'6; auto. apply Rmult_le_reg_l with (r := INR 2); auto with real. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real; rewrite Rmult_1_l; auto with real. apply Rmult_le_reg_l with (r := (/ 2%nat)%R); auto with real. rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real; rewrite Rmult_1_l; auto with real. apply isMax_inv1 with (1 := H'1). rewrite Fminus_correct; auto with arith. apply Rplus_le_reg_l with (r := FtoR radix max). replace (FtoR radix max + (FtoR radix p - FtoR radix max))%R with (FtoR radix p); [ idtac | ring ]. apply Rplus_le_reg_l with (r := (- (/ 2%nat * p))%R). replace (- (/ 2%nat * p) + FtoR radix p)%R with (/ 2%nat * p)%R. replace (- (/ 2%nat * p) + (FtoR radix max + / 2%nat * p))%R with (FtoR radix max); [ apply isMax_inv1 with (1 := H'1) | ring ]. replace (FtoR radix p) with (2%nat * (/ 2%nat * p))%R. simpl in |- *; ring. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real. apply Rplus_le_reg_l with (r := (- min)%R). replace (- min + p)%R with (p - min)%R; [ idtac | ring ]. replace (- min + (min + max))%R with (FtoRradix max); [ idtac | ring ]. case (PminPos p min); auto. intros x H'2; elim H'2; intros H'3 H'4; elim H'4; clear H'2. case H'1. intros H'2 H'5; elim H'5; intros H'6 H'7; apply H'7; clear H'5; auto. unfold FtoRradix in H'4; rewrite H'4; auto. fold FtoRradix in |- *; apply Rplus_le_reg_l with (r := FtoRradix min). replace (min + (p - min))%R with (FtoRradix p); [ idtac | ring ]. apply Rplus_le_reg_l with (r := (- (/ 2%nat * p))%R). replace (- (/ 2%nat * p) + p)%R with (/ 2%nat * p)%R. replace (- (/ 2%nat * p) + (min + / 2%nat * p))%R with (FtoRradix min); [ apply isMin_inv1 with (1 := H'0) | ring ]. pattern (FtoRradix p) at 3 in |- *; replace (FtoRradix p) with (2%nat * (/ 2%nat * p))%R. simpl in |- *; ring. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real. Qed. Theorem div2IsBetween : forall p min max : float, Fbounded b p -> isMin b radix (/ 2%nat * p) min -> isMax b radix (/ 2%nat * p) max -> p = (min + max)%R :>R. intros p min max H' H'0 H'1; case (Rle_or_lt 0 p); intros H'2. apply div2IsBetweenPos; auto. cut (forall x y : R, (- x)%R = (- y)%R -> x = y); [ intros H'3; apply H'3; clear H'3 | idtac ]. replace (- (min + max))%R with (- max + - min)%R; [ idtac | ring ]. repeat rewrite <- (Fopp_correct radix); auto with float. apply div2IsBetweenPos; auto with float. rewrite (Fopp_correct radix); auto. replace 0%R with (-0)%R; try apply Rlt_le; auto with real. replace (/ 2%nat * Fopp p)%R with (- (/ 2%nat * p))%R; auto with float. rewrite (Fopp_correct radix); auto; fold FtoRradix; ring. replace (/ 2%nat * Fopp p)%R with (- (/ 2%nat * p))%R; auto with float. rewrite (Fopp_correct radix); auto; fold FtoRradix;ring. intros x y H'3; rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive y); rewrite H'3; auto. Qed. Theorem RoundedModeMultAbs : forall P, RoundedModeP b radix P -> forall (r : R) (q q' : float), P r q -> Fbounded b q' -> (Rabs r <= radix * q')%R -> (Rabs q <= radix * q')%R. intros P H' r q q' H'0 H'1 H'2. case (Rle_or_lt 0 r); intros Rl0. rewrite Rabs_right; auto. apply RoundedModeMult with (P := P) (r := r); auto. rewrite <- (Rabs_right r); auto with real. apply Rle_ge; apply RleRoundedR0 with (P := P) (r := r); auto. rewrite Faux.Rabsolu_left1; auto. replace (radix * q')%R with (- (radix * - q'))%R; [ apply Ropp_le_contravar | ring ]. rewrite <- (Fopp_correct radix). apply RoundedModeMultLess with (P := P) (r := r); auto. apply oppBounded; auto. unfold FtoRradix in |- *; rewrite Fopp_correct. rewrite <- (Ropp_involutive r). replace (radix * - FtoR radix q')%R with (- (radix * q'))%R; [ apply Ropp_le_contravar | fold FtoRradix;ring ]; auto. rewrite <- (Faux.Rabsolu_left1 r); auto. apply Rlt_le; auto. apply RleRoundedLessR0 with (P := P) (r := r); auto. apply Rlt_le; auto. Qed. Theorem isMinComp : forall (r1 r2 : R) (min max : float), isMin b radix r1 min -> isMax b radix r1 max -> (min < r2)%R -> (r2 < max)%R -> isMin b radix r2 min. intros r1 r2 min max H' H'0 H'1 H'2; split. case H'; auto. split. apply Rlt_le; auto. intros f H'3 H'4. case H'; auto. intros H'5 H'6; elim H'6; intros H'7 H'8; apply H'8; clear H'6; auto. case (Rle_or_lt (FtoR radix f) r1); auto; intros C1. absurd (FtoR radix f < max)%R. apply Rle_not_lt. case H'0. intros H'6 H'9; elim H'9; intros H'10 H'11; apply H'11; clear H'9; auto. apply Rlt_le; auto. apply Rle_lt_trans with (2 := H'2); auto. Qed. Theorem isMaxComp : forall (r1 r2 : R) (min max : float), isMin b radix r1 min -> isMax b radix r1 max -> (min < r2)%R -> (r2 < max)%R -> isMax b radix r2 max. intros r1 r2 min max H' H'0 H'1 H'2; split. case H'0; auto. split. apply Rlt_le; auto. intros f H'3 H'4. case H'0; auto. intros H'5 H'6; elim H'6; intros H'7 H'8; apply H'8; clear H'6; auto. case (Rle_or_lt r1 (FtoR radix f)); auto; intros C1. absurd (min < FtoR radix f)%R. apply Rle_not_lt. case H'. intros H'6 H'9; elim H'9; intros H'10 H'11; apply H'11; clear H'9; auto. apply Rlt_le; auto. apply Rlt_le_trans with (1 := H'1); auto. Qed. Theorem roundedModeLessMult : forall (P : R -> float -> Prop) (p : float) (r : R), RoundedModeP b radix P -> P r p -> (Float 1%nat (- dExp b) <= r)%R -> (p <= radix * r)%R. intros P p r H' H'0 H'1. cut (0 < Float 1%nat (- dExp b))%R; [ intros Rl0 | unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite Rmult_1_l; auto with real arith ]. cut (0 < r)%R; [ intros Rl1 | apply Rlt_le_trans with (1 := Rl0) ]; auto. cut (0 <= r)%R; [ intros Rl2 | apply Rlt_le; auto ]. case H'. intros H'2 H'3; Elimc H'3; intros H'3 H'4; Elimc H'4; intros H'4 H'5; case (H'4 r p); auto; intros H'6. apply Rle_trans with r; auto with real. apply isMin_inv1 with (1 := H'6). rewrite Rmult_comm; pattern r at 1 in |- *; replace r with (r * 1%nat)%R; [ apply Rmult_le_compat_l | simpl; ring ]; auto with real arith. case (MinEx b radix precision) with (r := r); auto with arith; intros min Hmin. cut (Fbounded b (Float (Fnum min) (Zsucc (Fexp min)))); [ intros F2 | idtac ]. cut (FtoRradix (Float (Fnum min) (Zsucc (Fexp min))) = (radix * min)%R :>R); [ intros F2Eq | idtac ]. apply Rle_trans with (FtoRradix (Float (Fnum min) (Zsucc (Fexp min)))). case H'6. intros H'7 H'8; elim H'8; intros H'9 H'10; apply H'10; clear H'8; auto. case (Rle_or_lt r (Float (Fnum min) (Zsucc (Fexp min)))); auto; intros Rlt0. absurd (Float (Fnum min) (Zsucc (Fexp min)) <= min)%R. apply Rgt_not_le. rewrite F2Eq; auto with real. rewrite Rmult_comm. pattern (FtoRradix min) at 2 in |- *; replace (FtoRradix min) with (min * 1%nat)%R; auto with real. red in |- *; apply Rmult_lt_compat_l; auto with real arith. case (RleMinR0 r min); auto. intros H'8; case H'1. intros H'11; absurd (Float 1%nat (- dExp b) <= min)%R. apply Rgt_not_le; auto. rewrite <- H'8; auto. apply (MonotoneMin b radix) with (p := FtoRradix (Float 1%nat (- dExp b))) (q := r); auto. apply (RoundedModeProjectorIdem (isMin b radix)); auto. apply MinRoundedModeP with (precision := precision); auto. repeat split. simpl in |- *; auto with zarith. apply (vNumbMoreThanOne radix) with (precision := precision); auto with zarith. simpl in |- *; auto with zarith. intros H'11; absurd (min = Float 1%nat (- dExp b) :>R). rewrite <- H'8. apply Rlt_dichotomy_converse; left; auto. apply (MinUniqueP b radix r); auto. rewrite <- H'11. apply (RoundedModeProjectorIdem (isMin b radix)); auto. apply MinRoundedModeP with (precision := precision); auto. repeat split. simpl in |- *; auto with zarith. apply (vNumbMoreThanOne radix) with (precision := precision); auto with zarith. simpl in |- *; auto with zarith. case Hmin. intros H'8 H'11; elim H'11; intros H'12 H'13; apply H'13; clear H'11; auto. apply Rlt_le; auto. rewrite F2Eq. apply Rmult_le_compat_l; auto with real arith. replace 0%R with (INR 0); auto with real arith. apply isMin_inv1 with (1 := Hmin). unfold FtoRradix, FtoR in |- *; simpl in |- *. rewrite powerRZ_Zs; auto with real zarith; ring. cut (Fbounded b min); [ unfold Fbounded in |- *; intros Fb0 | case Hmin; auto ]. elim Fb0; intros H H0; auto. repeat (split; simpl in |- *); auto. apply Zle_trans with (Fexp min); auto with zarith. Qed. Theorem roundedModeMoreMult : forall (P : R -> float -> Prop) (p : float) (r : R), RoundedModeP b radix P -> P r p -> (r <= Float (- 1%nat) (- dExp b))%R -> (radix * r <= p)%R. intros P p r H' H'0 H'1. cut (Float (- 1%nat) (- dExp b) < 0)%R; [ intros Rl0 | unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite Ropp_mult_distr_l_reverse; rewrite Rmult_1_l; auto with real arith ]. 2: replace 0%R with (-0)%R; auto with real arith; ring. cut (r < 0)%R; [ intros Rl1 | apply Rle_lt_trans with (2 := Rl0) ]; auto. cut (r <= 0)%R; [ intros Rl2 | apply Rlt_le; auto ]. case H'. intros H'2 H'3; Elimc H'3; intros H'3 H'4; Elimc H'4; intros H'4 H'5; case (H'4 r p); auto; intros H'6. case (MaxEx b radix precision) with (r := r); auto with arith; intros max Hmax. cut (Fbounded b (Float (Fnum max) (Zsucc (Fexp max)))); [ intros F2 | idtac ]. cut (FtoRradix (Float (Fnum max) (Zsucc (Fexp max))) = (radix * max)%R :>R); [ intros F2Eq | idtac ]. apply Rle_trans with (FtoRradix (Float (Fnum max) (Zsucc (Fexp max)))). rewrite F2Eq; auto with real. apply Rmult_le_compat_l; auto with real arith. replace 0%R with (INR 0); auto with real arith. apply isMax_inv1 with (1 := Hmax); auto. case H'6. intros H'7 H'8; elim H'8; intros H'9 H'10; apply H'10; clear H'8; auto. case (Rle_or_lt (Float (Fnum max) (Zsucc (Fexp max))) r); auto; intros Rlt0. absurd (max <= Float (Fnum max) (Zsucc (Fexp max)))%R. apply Rgt_not_le. rewrite F2Eq. replace (radix * max)%R with (- (- max * radix))%R; [ idtac | ring ]. pattern (FtoRradix max) at 1 in |- *; replace (FtoRradix max) with (- (- max * 1%nat))%R; [ idtac | simpl in |- *; ring ]. apply Ropp_lt_gt_contravar; apply Rmult_lt_compat_l; auto with real. replace 0%R with (-0)%R; [ apply Ropp_lt_contravar | ring ]. case (RleMaxR0 r max); auto. intros H'8; case H'1. intros H'11; absurd (max <= Float (- 1%nat) (- dExp b))%R. apply Rgt_not_le; auto. rewrite H'8; auto. apply (MonotoneMax b radix) with (q := FtoRradix (Float (- 1%nat) (- dExp b))) (p := r); auto. apply (RoundedModeProjectorIdem (isMax b radix)); auto. apply MaxRoundedModeP with (precision := precision); auto. repeat split. simpl in |- *; auto with zarith. apply (vNumbMoreThanOne radix) with (precision := precision); auto with zarith. simpl in |- *; auto with zarith. intros H'11; absurd (Float (- 1%nat) (- dExp b) = max :>R). rewrite H'8; auto. apply Rlt_dichotomy_converse; left; auto. apply (MaxUniqueP b radix r); auto. rewrite H'11. apply (RoundedModeProjectorIdem (isMax b radix)); auto. apply MaxRoundedModeP with (precision := precision); auto. repeat split. simpl in |- *; auto with zarith. apply (vNumbMoreThanOne radix) with (precision := precision); auto with zarith. simpl in |- *; auto with zarith. case Hmax. intros H'8 H'11; elim H'11; intros H'12 H'13; apply H'13; clear H'11; auto. apply Rlt_le; auto. unfold FtoRradix, FtoR in |- *; simpl in |- *. rewrite powerRZ_Zs; auto with real zarith; ring. cut (Fbounded b max); [ unfold Fbounded in |- *; intros Fb0 | case Hmax; auto ]. elim Fb0; intros H H0; repeat (split; simpl in |- *); auto. apply Zle_trans with (Fexp max); auto with zarith. apply Rle_trans with r; auto with real. pattern r at 2 in |- *; replace r with (- (- r * 1%nat))%R; [ idtac | simpl; ring ]. replace (radix * r)%R with (- (- r * radix))%R; [ idtac | ring ]. apply Ropp_le_contravar; apply Rmult_le_compat_l; auto with real arith. replace 0%R with (-0)%R; auto with real arith. apply isMax_inv1 with (1 := H'6). Qed. Theorem roundedModeAbsMult : forall (P : R -> float -> Prop) (p : float) (r : R), RoundedModeP b radix P -> P r p -> (Float 1%nat (- dExp b) <= Rabs r)%R -> (Rabs p <= radix * Rabs r)%R. intros P p r H' H'0 H'1; case (Rle_or_lt 0 r); intros H'2. repeat rewrite Rabs_right; auto with real. apply roundedModeLessMult with (P := P); auto. rewrite <- (Rabs_right r); auto with real. apply Rle_ge; apply (RleRoundedR0 P) with (r := r); auto. repeat rewrite Faux.Rabsolu_left1; auto. replace (radix * - r)%R with (- (radix * r))%R; [ apply Ropp_le_contravar | ring ]. apply roundedModeMoreMult with (P := P); auto. rewrite <- (Ropp_involutive r); rewrite <- (Faux.Rabsolu_left1 r); auto. replace (Float (- 1%nat) (- dExp b)) with (Fopp (Float 1%nat (- dExp b))). unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real. simpl in |- *; auto. apply Rlt_le; auto. apply Rlt_le; auto. apply (RleRoundedLessR0 P) with (r := r); auto. apply Rlt_le; auto. Qed. Theorem RleBoundRoundl : forall P, RoundedModeP b radix P -> forall (p q : float) (r : R), Fbounded b p -> (p <= r)%R -> P r q -> (p <= q)%R. intros P H' p q r H'0 H'1 H'2; case H'1; intros H'3. cut (MonotoneP radix P); [ intros Mn | apply RoundedModeP_inv4 with (1 := H'); auto ]. apply (Mn p r); auto. apply RoundedModeProjectorIdem with (P := P); auto. rewrite RoundedModeProjectorIdemEq with (P := P) (p := p) (q := q); auto with real. cut (CompatibleP b radix P); [ intros Cp | apply RoundedModeP_inv2 with (1 := H'); auto ]. apply (Cp r p q); auto. apply RoundedModeBounded with (P := P) (r := r); auto. Qed. Theorem RleBoundRoundr : forall P, RoundedModeP b radix P -> forall (p q : float) (r : R), Fbounded b p -> (r <= p)%R -> P r q -> (q <= p)%R. intros P H' p q r H'0 H'1 H'2; case H'1; intros H'3. cut (MonotoneP radix P); [ intros Mn | apply RoundedModeP_inv4 with (1 := H'); auto ]. apply (Mn r p); auto. apply RoundedModeProjectorIdem with (P := P); auto. rewrite RoundedModeProjectorIdemEq with (P := P) (p := p) (q := q); auto with real. cut (CompatibleP b radix P); [ intros Cp | apply RoundedModeP_inv2 with (1 := H'); auto ]. apply (Cp r p q); auto. apply RoundedModeBounded with (P := P) (r := r); auto. Qed. Theorem RoundAbsMonotoner : forall (P : R -> float -> Prop) (p : R) (q r : float), RoundedModeP b radix P -> Fbounded b r -> P p q -> (Rabs p <= r)%R -> (Rabs q <= r)%R. intros P p q r H' H'0 H'1 H'2. case (Rle_or_lt 0 p); intros Rl1. rewrite Rabs_right; auto with real. apply RleBoundRoundr with (P := P) (r := p); auto with real. rewrite <- (Rabs_right p); auto with real. apply Rle_ge; apply RleRoundedR0 with (P := P) (r := p); auto. rewrite Faux.Rabsolu_left1; auto. rewrite <- (Ropp_involutive r); apply Ropp_le_contravar. rewrite <- (Fopp_correct radix); auto. apply RleBoundRoundl with (P := P) (r := p); auto with float. rewrite (Fopp_correct radix); rewrite <- (Ropp_involutive p); rewrite <- (Faux.Rabsolu_left1 p); auto with real; apply Rlt_le; auto. apply RleRoundedLessR0 with (P := P) (r := p); auto; apply Rlt_le; auto. Qed. Theorem RoundAbsMonotonel : forall (P : R -> float -> Prop) (p : R) (q r : float), RoundedModeP b radix P -> Fbounded b r -> P p q -> (r <= Rabs p)%R -> (r <= Rabs q)%R. intros P p q r H' H'0 H'1 H'2. case (Rle_or_lt 0 p); intros Rl1. rewrite Rabs_right; auto. apply RleBoundRoundl with (P := P) (r := p); auto. rewrite <- (Rabs_right p); auto with real. apply Rle_ge; apply RleRoundedR0 with (P := P) (r := p); auto. rewrite Faux.Rabsolu_left1; auto. rewrite <- (Ropp_involutive r); apply Ropp_le_contravar. rewrite <- (Fopp_correct radix); auto. apply RleBoundRoundr with (P := P) (r := p); auto with float. rewrite (Fopp_correct radix); rewrite <- (Ropp_involutive p); rewrite <- (Faux.Rabsolu_left1 p); auto with real; apply Rlt_le; auto. apply RleRoundedLessR0 with (P := P) (r := p); auto; apply Rlt_le; auto. Qed. (* Rounded of natural numbers are natural *) Theorem ZroundZ : forall (P : R -> float -> Prop) (z : Z) (p : float), RoundedModeP b radix P -> P z p -> exists z' : Z, p = z' :>R. intros P z p HP H'. case (RoundedModeRep b radix precision) with (P := P) (p := Float z 0%nat) (q := p); auto. cut (CompatibleP b radix P); [ intros Cp | apply RoundedModeP_inv2 with (1 := HP); auto ]; auto. apply Cp with (1 := H'); auto. unfold FtoRradix, FtoR in |- *; simpl in |- *. rewrite Rmult_1_r; auto. apply RoundedModeBounded with (P := P) (r := IZR z); auto. intros x H'0; exists x; auto. unfold FtoRradix in |- *; rewrite H'0. unfold FtoRradix, FtoR in |- *; simpl in |- *. rewrite Rmult_1_r; auto. Qed. Theorem NroundN : forall (P : R -> float -> Prop) (n : nat) (p : float), RoundedModeP b radix P -> P n p -> exists n' : nat, p = n' :>R. intros P n p HP H'. case (ZroundZ P (Z_of_nat n) p); auto. repeat rewrite <- INR_IZR_INZ; auto. intros x H'0; exists (Zabs_nat x). rewrite <- (inj_abs x) in H'0. rewrite H'0. repeat rewrite <- INR_IZR_INZ; auto. apply le_IZR; simpl in |- *. rewrite <- H'0; auto. apply RleRoundedR0 with (P := P) (r := INR n); auto. replace 0%R with (INR 0); auto with real arith. Qed. (* Properties of LSB and MSB *) Theorem FUlp_Le_LSigB : forall x : float, Fbounded b x -> (Fulp x <= Float 1%nat (LSB radix x))%R. intros x H; unfold is_Fzero, Fulp, Fnormalize in |- *; case (Z_zerop (Fnum x)); intros ZH. unfold FtoRradix, FtoR in |- *; simpl in |- *. rewrite Rmult_1_l. apply Rle_powerRZ. replace 1%R with (INR 1); auto with real arith. apply Zle_trans with (Fexp x); auto. case H; auto. apply Fexp_le_LSB; auto. rewrite LSB_shift with (n := min (precision - Fdigit radix x) (Zabs_nat (dExp b + Fexp x))); auto. unfold FtoRradix, FtoR in |- *; simpl in |- *. rewrite Rmult_1_l. apply Rle_powerRZ; auto with arith. replace 1%R with (INR 1); auto with real arith. exact (Fexp_le_LSB radix (Fshift radix (min (precision - Fdigit radix x) (Zabs_nat (dExp b + Fexp x))) x)). Qed. Theorem MSBisMin : forall f1 f2 : float, (0 <= f1)%R -> isMin b radix f1 f2 -> ~ is_Fzero f1 -> ~ is_Fzero f2 -> MSB radix f1 = MSB radix f2. intros f1 f2 H' H'0 H'1 H'2. apply Zle_antisym. 2: apply MSB_monotone; auto. 2: repeat rewrite Fabs_correct1; auto with arith. 2: apply isMin_inv1 with (1 := H'0). 2: apply RleRoundedR0 with (P := isMin b radix) (r := FtoRradix f1); auto. 2: apply MinRoundedModeP with (precision := precision); auto. case (Zle_or_lt (MSB radix f1) (MSB radix f2)); auto. intros H'3; absurd (Float 1%nat (Zsucc (MSB radix f2)) <= f2)%R. apply Rgt_not_le. red in |- *; unfold FtoRradix in |- *; rewrite <- Fabs_correct1; auto with float arith. apply abs_lt_MSB; auto. apply RleRoundedR0 with (P := isMin b radix) (r := FtoRradix f1); auto with float. apply MinRoundedModeP with (precision := precision); auto. case H'0. intros H'4 H'5; elim H'5; intros H'6 H'7; apply H'7; clear H'5; auto. apply (FboundedOne _ radixMoreThanOne b precision); auto with arith. apply Zle_trans with (Fexp f2). case H'4; auto. apply Zle_trans with (MSB radix f2); auto with zarith. apply Fexp_le_MSB; auto. apply Rle_trans with (FtoR radix (Float 1%nat (MSB radix f1))); auto. apply oneExp_le; auto with zarith. unfold FtoRradix in |- *; rewrite <- Fabs_correct1 with (x := f1); auto with float arith. apply MSB_le_abs; auto. Qed. Theorem MSBtoZero : forall f1 f2 : float, ToZeroP b radix f1 f2 -> ~ is_Fzero f1 -> ~ is_Fzero f2 -> MSB radix f1 = MSB radix f2. intros f1 f2 H' H'0 H'1; Casec H'; intros tmp; Elimc tmp; intros H1 H2. apply MSBisMin; auto. rewrite (MSB_opp radix f1). rewrite (MSB_opp radix f2). apply MSBisMin; auto with float. unfold FtoRradix in |- *; rewrite Fopp_correct. replace 0%R with (-0)%R; auto with real. unfold FtoRradix in |- *; rewrite Fopp_correct; auto with float. Qed. Theorem MSBBoundNotZero : forall P : R -> float -> Prop, RoundedModeP b radix P -> forall f1 f2 : float, P f1 f2 -> f1 <> 0%R :>R -> (- dExp b <= MSB radix f1)%Z -> f2 <> 0%R :>R. intros P H' f1 f2 H'0 H'1 H'2. case (Rle_or_lt 0 f1); intros Rl1. apply Rlt_dichotomy_converse; right; red in |- *. apply Rlt_le_trans with (r2 := FtoRradix (Float 1%nat (MSB radix f1))); auto. unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite Rmult_1_l; auto with real arith. cut (Float 1%nat (MSB radix f1) <= Fabs f1)%R; unfold FtoRradix in |- *; [ rewrite Fabs_correct; auto with arith; rewrite Rabs_right; auto with real; intros Rl2; Casec Rl2; intros Rl2 | apply MSB_le_abs ]; auto. cut (MonotoneP radix P); [ intros Mn | apply RoundedModeP_inv4 with (1 := H'); auto ]. apply (Mn (Float 1%nat (MSB radix f1)) f1); auto. apply RoundedModeProjectorIdem; auto. apply (FboundedOne radix) with (precision := precision); auto with real zarith arith. replace (FtoR radix f2) with (FtoR radix (Float 1%nat (MSB radix f1))); auto with float real. apply RoundedModeProjectorIdemEq with (P := P); auto. apply (FboundedOne radix) with (precision := precision); auto with real zarith arith. cut (CompatibleP b radix P); [ intros Cp | apply RoundedModeP_inv2 with (1 := H'); auto ]. apply (Cp f1) with (p := f2); auto. apply RoundedModeBounded with (P := P) (r := FtoRradix f1); auto. Contradict H'1; unfold FtoRradix in |- *; apply is_Fzero_rep1; auto. apply Rlt_dichotomy_converse; left. apply Rle_lt_trans with (r2 := FtoRradix (Float (- 1%nat) (MSB radix f1))); auto. cut (MonotoneP radix P); [ intros Mn | apply RoundedModeP_inv4 with (1 := H'); auto ]. cut (f1 <= Float (- 1%nat) (MSB radix f1))%R; [ intros Rle1; Casec Rle1; intros Rle1 | idtac ]. apply (Mn f1 (Float (- 1%nat) (MSB radix f1))); auto. apply RoundedModeProjectorIdem; auto. apply oppBoundedInv; unfold Fopp in |- *; simpl in |- *. apply (FboundedOne radix) with (precision := precision); auto with real zarith arith. replace (FtoRradix f2) with (FtoRradix (Float (- 1%nat) (MSB radix f1))); auto with real. apply RoundedModeProjectorIdemEq with (P := P); auto. apply oppBoundedInv; unfold Fopp in |- *; simpl in |- *. apply (FboundedOne _ radixMoreThanOne b precision); auto with real zarith arith. cut (CompatibleP b radix P); [ intros Cp | apply RoundedModeP_inv2 with (1 := H'); auto ]. apply (Cp f1) with (p := f2); auto. apply RoundedModeBounded with (P := P) (r := FtoRradix f1); auto. replace (FtoRradix f1) with (- FtoRradix (Fabs f1))%R. replace (Float (- 1%nat) (MSB radix f1)) with (Fopp (Float 1%nat (MSB radix f1))). unfold FtoRradix in |- *; rewrite Fopp_correct; auto. apply Ropp_le_contravar; apply MSB_le_abs; auto. Contradict H'1; unfold FtoRradix in |- *; apply is_Fzero_rep1; auto. unfold Fopp in |- *; simpl in |- *; auto. unfold FtoRradix in |- *; rewrite Fabs_correct; auto with arith; rewrite Faux.Rabsolu_left1; try apply Rlt_le; auto; ring. replace (Float (- 1%nat) (MSB radix f1)) with (Fopp (Float 1%nat (MSB radix f1))); [ idtac | unfold Fopp in |- *; simpl in |- *; auto ]. replace 0%R with (-0)%R; [ idtac | ring ]. unfold FtoRradix in |- *; repeat rewrite Fopp_correct; apply Ropp_lt_contravar. unfold FtoR in |- *; simpl in |- *; rewrite Rmult_1_l; auto with real arith. Qed. Theorem RoundMSBmax : forall (P : R -> float -> Prop) (p q : float), RoundedModeP b radix P -> P p q -> p <> 0%R :>R -> (- dExp b <= MSB radix p)%Z -> (MSB radix q <= Zsucc (MSB radix p))%Z. intros P p q H' H'0 H'1 H'2. apply (oneExp_Zle radix); auto. apply Rle_trans with (FtoRradix (Fabs q)). unfold FtoRradix in |- *; apply MSB_le_abs; auto. red in |- *; intros H'3; absurd (q = 0%R :>R). apply MSBBoundNotZero with (P := P) (f1 := p); auto. apply (is_Fzero_rep1 radix); auto. unfold FtoRradix in |- *; rewrite Fabs_correct; auto with arith; fold FtoRradix in |- *. apply RoundAbsMonotoner with (P := P) (p := FtoRradix p); auto. apply (FboundedOne _ radixMoreThanOne b precision); auto with zarith. unfold FtoRradix in |- *; rewrite <- (Fabs_correct radix); auto with arith. apply Rlt_le; apply abs_lt_MSB; auto. Qed. Theorem RoundMSBmin : forall (P : R -> float -> Prop) (p q : float), RoundedModeP b radix P -> P p q -> p <> 0%R :>R -> (- dExp b <= MSB radix p)%Z -> (MSB radix p <= MSB radix q)%Z. intros P p q H' H'0 H'1 H'2. replace (MSB radix p) with (MSB radix (Float 1%nat (MSB radix p))). apply MSB_monotone; auto. unfold is_Fzero in |- *; simpl in |- *; red in |- *; intros; discriminate. red in |- *; intros H'3; absurd (q = 0%R :>R). apply MSBBoundNotZero with (P := P) (f1 := p); auto. unfold FtoRradix in |- *; apply is_Fzero_rep1; auto. replace (Fabs (Float 1%nat (MSB radix p))) with (Float 1%nat (MSB radix p)); [ idtac | unfold Fabs in |- *; simpl in |- *; auto ]. rewrite Fabs_correct; auto with arith; fold FtoRradix in |- *. apply RoundAbsMonotonel with (P := P) (p := FtoRradix p); auto. apply (FboundedOne _ radixMoreThanOne b precision); auto with zarith. unfold FtoRradix in |- *; rewrite <- (Fabs_correct radix); auto with arith; apply MSB_le_abs; auto. Contradict H'1; unfold FtoRradix in |- *; apply is_Fzero_rep1; auto. unfold MSB, Fdigit in |- *; simpl in |- *. case (Zpred (digit radix (Fnum p) + Fexp p)); simpl in |- *; auto with zarith. intros p0; case p0; simpl in |- *; auto. intros p1; elim p1; simpl in |- *; auto. intros p2 H; injection H; intros H1; rewrite <- H1; auto. intros p0; case p0; simpl in |- *; auto. intros p1; case p1; simpl in |- *; auto. intros p2; elim p2; simpl in |- *; auto. intros p3 H; injection H; intros H1; rewrite H1; auto. Qed. Theorem RoundLSBMax : forall (P : R -> float -> Prop) (p q : float), RoundedModeP b radix P -> P p q -> ~ is_Fzero q -> (LSB radix p <= LSB radix q)%Z. intros P p q H' H'0 H'2. elim (LSB_rep_min radix) with (p := p); auto; intros z E. case (RoundedModeRep b radix precision) with (P := P) (p := Float z (LSB radix p)) (q := q); auto. cut (CompatibleP b radix P); [ intros Cp | apply RoundedModeP_inv2 with (1 := H'); auto ]. apply (Cp p (Float z (LSB radix p)) q); auto. apply RoundedModeBounded with (P := P) (r := FtoRradix p); auto. intros x H'3. replace (LSB radix p) with (Fexp (Float x (LSB radix p))); [ idtac | simpl in |- *; auto ]. replace (LSB radix q) with (LSB radix (Float x (LSB radix p))). apply Fexp_le_LSB. apply LSB_comp; auto. apply NisFzeroComp with (radix := radix) (x := q); auto. Qed. (* General theorem about the binade *) Theorem InBinade : forall (P : R -> float -> Prop) (p q r : float) (e : Z), RoundedModeP b radix P -> Fbounded b p -> Fbounded b q -> P (p + q)%R r -> (- dExp b <= e)%Z -> (Float (Zpower_nat radix (pred precision)) e <= p)%R -> (p <= Float (pPred (vNum b)) e)%R -> (0%nat < q)%R -> (q < powerRZ radix e)%R -> r = p :>R \/ r = (p + powerRZ radix e)%R :>R. intros P p q r e Rp H' H'0 H'1 H'2 H'3 H'4 H'5 H'6. cut (p < p + q)%R; [ intros Rlt1 | idtac ]. cut (p + q < FNSucc b radix precision p)%R; [ intros Rlt2 | idtac ]. cut (isMin b radix (p + q) p); [ intros Min1 | idtac ]. cut (isMax b radix (p + q) (FNSucc b radix precision p)); [ intros Max1 | idtac ]. cut (MinOrMaxP b radix P); [ intros MinOrMax | apply RoundedModeP_inv3 with (1 := Rp); auto ]. case (MinOrMax (p + q)%R r); auto; intros H1. left. apply (MinUniqueP b radix (p + q)%R); auto. right. cut ((p + powerRZ radix e)%R = FNSucc b radix precision p); [ intros Eq1; rewrite Eq1 | idtac ]. apply (MaxUniqueP b radix (p + q)%R); auto. replace (FtoRradix (FNSucc b radix precision p)) with (Fnormalize radix b precision p + (FNSucc b radix precision p - Fnormalize radix b precision p))%R; [ idtac | ring ]. unfold FNSucc in |- *; rewrite <- (Fminus_correct radix); auto with arith; rewrite (FSuccDiff1 b radix precision); auto with arith. rewrite (boundedNorMinGivesExp radix) with (x := e); auto with zarith. rewrite (FnormalizeCorrect radix); auto; unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. apply sym_not_equal; apply Zlt_not_eq. apply Zle_lt_trans with 0%Z; auto with zarith. replace 0%Z with (- (0))%Z; auto with zarith; apply Zle_Zopp; apply Zlt_le_weak; apply nNormPos; auto with zarith. apply (LtR0Fnum radix); auto. rewrite FnormalizeCorrect; fold FtoRradix in |- *; auto. apply Rlt_le_trans with (2 := H'3). apply (LtFnumZERO radix); simpl in |- *; (replace 0%Z with (Z_of_nat 0); auto with zarith arith). apply MinMax; auto with arith. Contradict Rlt1. rewrite Rlt1; auto with real. apply MinBinade with (precision := precision); auto with arith. apply Rlt_le; auto. replace (FtoRradix (FNSucc b radix precision p)) with (Fnormalize radix b precision p + (FNSucc b radix precision p - Fnormalize radix b precision p))%R; [ idtac | ring ]. unfold FNSucc in |- *; rewrite <- (Fminus_correct radix); auto with arith; rewrite (FSuccDiff1 b radix precision); auto with arith. rewrite (boundedNorMinGivesExp radix) with (x := e); auto with zarith. rewrite (FnormalizeCorrect radix); auto; fold FtoRradix in |- *. replace (FtoRradix (Float 1%nat e)) with (powerRZ radix e); auto with real. unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. apply sym_not_equal; apply Zlt_not_eq. apply Zle_lt_trans with 0%Z; auto with zarith. replace 0%Z with (- (0))%Z; auto with zarith; apply Zle_Zopp; apply Zlt_le_weak; apply nNormPos; auto with zarith. apply (LtR0Fnum radix); auto. rewrite FnormalizeCorrect; fold FtoRradix in |- *; auto. apply Rlt_le_trans with (2 := H'3). apply (LtFnumZERO radix); simpl in |- *; (replace 0%Z with (Z_of_nat 0); auto with zarith arith). pattern (FtoRradix p) at 1 in |- *; replace (FtoRradix p) with (p + 0)%R; [ idtac | ring ]. apply Rplus_lt_compat_l; auto. Qed. End FRoundP. Hint Resolve FulpSucCan FulpSuc FulpPredCan FulpPred: float.Float8.4/MSB.v0000644000423700002640000004572712032774526012700 0ustar sboldotoccata(**************************************************************************** IEEE754 : MSB Laurent Thery ******************************************************************************) Require Export Fprop. Require Export Zdivides. Require Export Fnorm. Section mf. Variable radix : Z. Hypothesis radixMoreThanOne : (1 < radix)%Z. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Coercion Local FtoRradix := FtoR radix. Fixpoint maxDiv (v : Z) (p : nat) {struct p} : nat := match p with | O => 0 | S p' => match ZdividesP v (Zpower_nat radix p) with | left _ => p | right _ => maxDiv v p' end end. Theorem maxDivLess : forall (v : Z) (p : nat), maxDiv v p <= p. intros v p; elim p; simpl in |- *; auto. intros n H'; case (ZdividesP v (Zpower_nat radix (S n))); auto. Qed. Theorem maxDivLt : forall (v : Z) (p : nat), ~ Zdivides v (Zpower_nat radix p) -> maxDiv v p < p. intros v p; case p; simpl in |- *; auto. intros H'; case H'. apply Zdivides1. intros n H'; case (ZdividesP v (Zpower_nat radix (S n))); auto. intros H'0; case H'; auto. intros H'0; generalize (maxDivLess v n); auto with arith. Qed. Theorem maxDivCorrect : forall (v : Z) (p : nat), Zdivides v (Zpower_nat radix (maxDiv v p)). intros v p; elim p. unfold maxDiv in |- *; rewrite Zpower_nat_O; auto. apply Zdivides1. simpl in |- *. intros n H'; case (ZdividesP v (Zpower_nat radix (S n))); simpl in |- *; auto with zarith. Qed. Theorem maxDivSimplAux : forall (v : Z) (p q : nat), p = maxDiv v (S (q + p)) -> p = maxDiv v (S p). intros v p q; elim q. simpl in |- *; case (ZdividesP v (Zpower_nat radix (S p))); auto. intros n H' H'0. apply H'; auto; clear H'. simpl in H'0; generalize H'0; clear H'0. case (ZdividesP v (Zpower_nat radix (S (S (n + p))))). 2: simpl in |- *; auto. intros H' H'0; Contradict H'0; auto with zarith. Qed. Theorem maxDivSimpl : forall (v : Z) (p q : nat), p < q -> p = maxDiv v q -> p = maxDiv v (S p). intros v p q H' H'0. apply maxDivSimplAux with (q := q - S p); auto. replace (S (q - S p + p)) with q; auto with zarith. Qed. Theorem maxDivSimplInvAux : forall (v : Z) (p q : nat), p = maxDiv v (S p) -> p = maxDiv v (S (q + p)). intros v p q H'; elim q. simpl in |- *; auto. intros n; simpl in |- *. case (ZdividesP v (Zpower_nat radix (S (n + p)))); auto. case (ZdividesP v (Zpower_nat radix (S (S (n + p))))); auto. intros H'0 H'1 H'2; Contradict H'2; auto with zarith. case (ZdividesP v (Zpower_nat radix (S (S (n + p))))); auto. intros H'0 H'1 H'2; case H'1. case H'0; intros z1 Hz1; exists (radix * z1)%Z;rewrite Hz1. unfold Zpower_nat; simpl; ring. Qed. Theorem maxDivSimplInv : forall (v : Z) (p q : nat), p < q -> p = maxDiv v (S p) -> p = maxDiv v q. intros v p q H' H'0. replace q with (S (q - S p + p)); auto with zarith. apply maxDivSimplInvAux; auto. Qed. Theorem maxDivUnique : forall (v : Z) (p : nat), p = maxDiv v (S p) -> Zdivides v (Zpower_nat radix p) /\ ~ Zdivides v (Zpower_nat radix (S p)). intros v p H'; split. rewrite H'. apply maxDivCorrect; auto. red in |- *; intros H'0; generalize H'; clear H'. simpl in |- *. case (ZdividesP v (Zpower_nat radix (S p))); simpl in |- *; auto. intros H' H'1; Contradict H'1; auto with zarith. Qed. Theorem maxDivUniqueDigit : forall v : Z, v <> 0 -> Zdivides v (Zpower_nat radix (maxDiv v (digit radix v))) /\ ~ Zdivides v (Zpower_nat radix (S (maxDiv v (digit radix v)))). intros v H'. apply maxDivUnique; auto. apply maxDivSimpl with (q := digit radix v); auto. apply maxDivLt; auto. apply NotDividesDigit; auto. Qed. Theorem maxDivUniqueInverse : forall (v : Z) (p : nat), Zdivides v (Zpower_nat radix p) -> ~ Zdivides v (Zpower_nat radix (S p)) -> p = maxDiv v (S p). intros v p H' H'0; simpl in |- *. case (ZdividesP v (Zpower_nat radix (S p))); auto. intros H'1; case H'0; simpl in |- *; auto. intros H'1. generalize H'; case p; simpl in |- *; auto. intros n H'2; case (ZdividesP v (Zpower_nat radix (S n))); auto. intros H'3; case H'3; auto. Qed. Theorem maxDivUniqueInverseDigit : forall (v : Z) (p : nat), v <> 0 -> Zdivides v (Zpower_nat radix p) -> ~ Zdivides v (Zpower_nat radix (S p)) -> p = maxDiv v (digit radix v). intros v p H' H'0 H'1. apply maxDivSimplInv; auto. 2: apply maxDivUniqueInverse; auto. apply Zpower_nat_anti_monotone_lt with (n := radix); auto. apply Zle_lt_trans with (m := Zabs v); auto. rewrite <- (fun x => Zabs_eq (Zpower_nat radix x)); auto with zarith; apply ZDividesLe; auto. apply digitMore; auto. Qed. Theorem maxDivPlus : forall (v : Z) (n : nat), v <> 0 -> maxDiv (v * Zpower_nat radix n) (digit radix v + n) = maxDiv v (digit radix v) + n. intros v n H. replace (digit radix v + n) with (digit radix (v * Zpower_nat radix n)); auto. apply sym_equal. apply maxDivUniqueInverseDigit; auto. red in |- *; intros Z1; case (Zmult_integral _ _ Z1); intros Z2. case H; auto. absurd (0 < Zpower_nat radix n)%Z; auto with zarith. rewrite Zpower_nat_is_exp. repeat rewrite (fun x : Z => Zmult_comm x (Zpower_nat radix n)). apply ZdividesMult; auto. case (maxDivUniqueDigit v); auto. replace (S (maxDiv v (digit radix v) + n)) with (S (maxDiv v (digit radix v)) + n); auto. rewrite Zpower_nat_is_exp. repeat rewrite (fun x : Z => Zmult_comm x (Zpower_nat radix n)). red in |- *; intros H'. absurd (Zdivides v (Zpower_nat radix (S (maxDiv v (digit radix v))))). case (maxDivUniqueDigit v); auto. apply ZdividesDiv with (p := Zpower_nat radix n); auto with zarith. apply digitAdd; auto with zarith. Qed. Definition LSB (x : float) := (Z_of_nat (maxDiv (Fnum x) (Fdigit radix x)) + Fexp x)%Z. Theorem LSB_shift : forall (x : float) (n : nat), ~ is_Fzero x -> LSB x = LSB (Fshift radix n x). intros x n H'; unfold LSB, Fdigit in |- *; simpl in |- *. rewrite digitAdd; auto with arith. rewrite maxDivPlus; auto. rewrite inj_plus; ring. Qed. Theorem LSB_comp : forall (x y : float) (n : nat), ~ is_Fzero x -> x = y :>R -> LSB x = LSB y. intros x y H' H'0 H'1. case (FshiftCorrectSym radix) with (2 := H'1); auto. intros m1 H'2; elim H'2; intros m2 E; clear H'2. rewrite (LSB_shift x m1); auto. rewrite E; auto. apply sym_equal; apply LSB_shift; auto. apply (NisFzeroComp radix) with (x := x); auto. Qed. Theorem maxDiv_opp : forall (v : Z) (p : nat), maxDiv v p = maxDiv (- v) p. intros v p; elim p; simpl in |- *; auto. intros n H; case (ZdividesP v (Zpower_nat radix (S n))); case (ZdividesP (- v) (Zpower_nat radix (S n))); auto. intros Z1 Z2; case Z1. case Z2; intros z1 Hz1; exists (- z1)%Z; rewrite Hz1; ring. intros Z1 Z2; case Z2. case Z1; intros z1 Hz1; exists (- z1)%Z. rewrite <- (Zopp_involutive v); rewrite Hz1; ring. Qed. Theorem LSB_opp : forall x : float, LSB x = LSB (Fopp x). intros x; unfold LSB in |- *; simpl in |- *. rewrite Fdigit_opp; auto. rewrite maxDiv_opp; auto. Qed. Theorem maxDiv_abs : forall (v : Z) (p : nat), maxDiv v p = maxDiv (Zabs v) p. intros v p; elim p; simpl in |- *; auto. intros n H; case (ZdividesP v (Zpower_nat radix (S n))); case (ZdividesP (Zabs v) (Zpower_nat radix (S n))); auto. intros Z1 Z2; case Z1. case Z2; intros z1 Hz1; exists (Zabs z1); rewrite Hz1. rewrite Zabs_Zmult; rewrite (fun x => Zabs_eq (Zpower_nat radix x)); auto with zarith. intros Z1 Z2; case Z2. case Z1; intros z1 Hz1. case (Zle_or_lt v 0); intros Z4. exists (- z1)%Z; rewrite <- (Zopp_involutive v); rewrite <- (Zabs_eq_opp v); auto; rewrite Hz1; ring. exists z1; rewrite <- (Zabs_eq v); auto with zarith; rewrite Hz1; ring. Qed. Theorem LSB_abs : forall x : float, LSB x = LSB (Fabs x). intros x; unfold LSB in |- *; simpl in |- *. rewrite Fdigit_abs; auto. rewrite maxDiv_abs; auto. Qed. Definition MSB (x : float) := Zpred (Z_of_nat (Fdigit radix x) + Fexp x). Theorem MSB_shift : forall (x : float) (n : nat), ~ is_Fzero x -> MSB x = MSB (Fshift radix n x). intros; unfold MSB, Fshift, Fdigit in |- *; simpl in |- *. rewrite digitAdd; auto with zarith. rewrite inj_plus; unfold Zpred in |- *; ring. Qed. Theorem MSB_comp : forall (x y : float) (n : nat), ~ is_Fzero x -> x = y :>R -> MSB x = MSB y. intros x y H' H'0 H'1. case (FshiftCorrectSym radix) with (2 := H'1); auto. intros m1 H'2; elim H'2; intros m2 E; clear H'2. rewrite (MSB_shift x m1); auto. rewrite E; auto. apply sym_equal; apply MSB_shift; auto. apply (NisFzeroComp radix) with (x := x); auto. Qed. Theorem MSB_opp : forall x : float, MSB x = MSB (Fopp x). intros x; unfold MSB in |- *; simpl in |- *. rewrite Fdigit_opp; auto. Qed. Theorem MSB_abs : forall x : float, MSB x = MSB (Fabs x). intros x; unfold MSB in |- *; simpl in |- *. rewrite Fdigit_abs; auto. Qed. Theorem LSB_le_MSB : forall x : float, ~ is_Fzero x -> (LSB x <= MSB x)%Z. intros x H'; unfold LSB, MSB in |- *. apply Zle_Zpred. cut (maxDiv (Fnum x) (Fdigit radix x) < Fdigit radix x); auto with zarith. apply maxDivLt; auto. unfold Fdigit in |- *; apply NotDividesDigit; auto. Qed. Theorem Fexp_le_LSB : forall x : float, (Fexp x <= LSB x)%Z. intros x; unfold LSB in |- *. auto with zarith. Qed. Theorem Ulp_Le_LSigB : forall x : float, (Float 1%nat (Fexp x) <= Float 1%nat (LSB x))%R. intros x; apply (oneExp_le radix); auto. apply Fexp_le_LSB; auto. Qed. Theorem Fexp_le_MSB : forall x : float, ~ is_Fzero x -> (Fexp x <= MSB x)%Z. intros x H'; unfold MSB in |- *. cut (Fdigit radix x <> 0%Z :>Z); unfold Zpred in |- *; auto with zarith. unfold Fdigit in |- *. red in |- *; intros H'0; absurd (digit radix (Fnum x) = 0); auto with zarith. apply not_eq_sym; apply lt_O_neq; apply digitNotZero; auto. Qed. Theorem MSB_le_abs : forall x : float, ~ is_Fzero x -> (Float 1%nat (MSB x) <= Fabs x)%R. intros x H'; unfold MSB, FtoRradix, FtoR in |- *; simpl in |- *. replace (Zpred (Fdigit radix x + Fexp x)) with (Zpred (Fdigit radix x) + Fexp x)%Z; [ idtac | unfold Zpred in |- *; ring ]. rewrite powerRZ_add; auto with real zarith. rewrite Rmult_1_l. repeat rewrite (fun r : R => Rmult_comm r (powerRZ radix (Fexp x))). apply Rmult_le_compat_l; auto with real zarith. rewrite <- inj_pred; auto with real zarith. rewrite <- Zpower_nat_Z_powerRZ; auto. apply Rle_IZR; auto. unfold Fdigit in |- *; auto with arith. apply digitLess; auto. unfold Fdigit in |- *. apply not_eq_sym; apply lt_O_neq; apply digitNotZero; auto. Qed. Theorem abs_lt_MSB : forall x : float, (Fabs x < Float 1%nat (Zsucc (MSB x)))%R. intros x. rewrite (MSB_abs x). unfold MSB, FtoRradix, FtoR in |- *. rewrite <- Zsucc_pred; simpl in |- *. rewrite powerRZ_add; auto with real zarith. rewrite Rmult_1_l. repeat rewrite (fun r : R => Rmult_comm r (powerRZ radix (Fexp x))). apply Rmult_lt_compat_l; auto with real zarith. rewrite <- Zpower_nat_Z_powerRZ; auto with arith. apply Rlt_IZR. unfold Fdigit in |- *; auto with arith. unfold Fabs in |- *; simpl in |- *. pattern (Zabs (Fnum x)) at 1 in |- *; rewrite <- (Zabs_eq (Zabs (Fnum x))); auto with zarith. Qed. Theorem LSB_le_abs : forall x : float, ~ is_Fzero x -> (Float 1%nat (LSB x) <= Fabs x)%R. intros x H'; apply Rle_trans with (FtoRradix (Float 1%nat (MSB x))). apply (oneExp_le radix); auto. apply LSB_le_MSB; auto. apply MSB_le_abs; auto. Qed. Theorem MSB_monotoneAux : forall x y : float, (Fabs x <= Fabs y)%R -> Fexp x = Fexp y -> (MSB x <= MSB y)%Z. intros x y H' H'0; unfold MSB in |- *. rewrite <- H'0. cut (Fdigit radix x <= Fdigit radix y)%Z; [ unfold Zpred in |- *; auto with zarith | idtac ]. unfold Fdigit in |- *; apply inj_le. apply digit_monotone; auto. apply le_IZR. apply Rmult_le_reg_l with (r := powerRZ radix (Fexp x)); auto with real zarith. repeat rewrite (Rmult_comm (powerRZ radix (Fexp x))); auto. pattern (Fexp x) at 2 in |- *; rewrite H'0; auto. Qed. Theorem MSB_monotone : forall x y : float, ~ is_Fzero x -> ~ is_Fzero y -> (Fabs x <= Fabs y)%R -> (MSB x <= MSB y)%Z. intros x y H' H'0 H'1; rewrite (MSB_abs x); rewrite (MSB_abs y). case (Zle_or_lt (Fexp (Fabs x)) (Fexp (Fabs y))); simpl in |- *; intros Zle1. rewrite MSB_shift with (x := Fabs y) (n := Zabs_nat (Fexp (Fabs y) - Fexp (Fabs x))). apply MSB_monotoneAux; auto. unfold FtoRradix in |- *; repeat rewrite Fabs_correct; auto with real arith. rewrite FshiftCorrect; auto with real arith. repeat rewrite Fabs_correct; auto with real arith. repeat rewrite Rabs_Rabsolu; repeat rewrite <- Fabs_correct; auto with real arith. unfold Fshift in |- *; simpl in |- *. rewrite inj_abs; [ ring | auto with zarith ]. apply Fabs_Fzero; auto. rewrite MSB_shift with (x := Fabs x) (n := Zabs_nat (Fexp (Fabs x) - Fexp (Fabs y))). apply MSB_monotoneAux; auto. unfold FtoRradix in |- *; repeat rewrite Fabs_correct; auto with real arith. rewrite FshiftCorrect; auto with real arith. repeat rewrite Fabs_correct; auto with real arith. repeat rewrite Rabs_Rabsolu; repeat rewrite <- Fabs_correct; auto with real arith. unfold Fshift in |- *; simpl in |- *. rewrite inj_abs; [ ring | auto with zarith ]. apply Fabs_Fzero; auto. Qed. Theorem MSB_le_multAux : forall x y : float, ~ is_Fzero x -> ~ is_Fzero y -> (MSB x + MSB y <= MSB (Fmult x y))%Z. intros x y H' H'0; unfold MSB, Fmult, Fdigit in |- *; simpl in |- *. replace (Zpred (digit radix (Fnum x) + Fexp x) + Zpred (digit radix (Fnum y) + Fexp y))%Z with (Zpred (digit radix (Fnum x) + Zpred (digit radix (Fnum y)) + (Fexp x + Fexp y))); [ idtac | unfold Zpred in |- *; ring ]. cut (digit radix (Fnum x) + Zpred (digit radix (Fnum y)) <= digit radix (Fnum x * Fnum y))%Z; [ unfold Zpred in |- *; auto with zarith | idtac ]. rewrite <- inj_pred; auto with float zarith; try rewrite <- inj_plus. apply inj_le. rewrite <- digitAdd; auto with zarith. apply digit_monotone; auto with zarith. repeat rewrite Zabs_Zmult. apply Zle_Zmult_comp_l; auto with zarith. rewrite (fun x => Zabs_eq (Zpower_nat radix x)); auto with zarith. apply not_eq_sym; apply lt_O_neq; apply digitNotZero; auto. Qed. Theorem MSB_le_mult : forall x y : float, ~ is_Fzero x -> ~ is_Fzero y -> (Fmult (Float 1%nat (MSB x)) (Float 1%nat (MSB y)) <= Float 1%nat (MSB (Fmult x y)))%R. intros x y H' H'0. rewrite <- oneZplus. apply (oneExp_le radix); auto. apply MSB_le_multAux; auto. Qed. Theorem mult_le_MSBAux : forall x y : float, ~ is_Fzero x -> ~ is_Fzero y -> (MSB (Fmult x y) <= Zsucc (MSB x + MSB y))%Z. intros x y H' H'0; unfold MSB, Fmult, Fdigit in |- *; simpl in |- *. replace (Zsucc (Zpred (digit radix (Fnum x) + Fexp x) + Zpred (digit radix (Fnum y) + Fexp y))) with (Zpred (digit radix (Fnum x) + digit radix (Fnum y) + (Fexp x + Fexp y))); [ idtac | unfold Zpred, Zsucc in |- *; ring ]. cut (digit radix (Fnum x * Fnum y) <= digit radix (Fnum x) + digit radix (Fnum y))%Z; [ unfold Zpred in |- *; auto with zarith | idtac ]. rewrite <- inj_plus. apply inj_le; auto. rewrite <- digitAdd; auto with arith. apply digit_monotone; auto with arith. repeat rewrite Zabs_Zmult. apply Zle_Zmult_comp_l; auto with zarith. rewrite (fun x => Zabs_eq (Zpower_nat radix x)); auto with zarith. Qed. Theorem mult_le_MSB : forall x y : float, ~ is_Fzero x -> ~ is_Fzero y -> (Float 1%nat (MSB (Fmult x y)) <= radix * Fmult (Float 1%nat (MSB x)) (Float 1%nat (MSB y)))%R. intros x y H' H'0; rewrite <- oneZplus. replace (radix * Float 1%nat (MSB x + MSB y))%R with (FtoRradix (Float 1%nat (Zsucc (MSB x + MSB y)))). apply (oneExp_le radix); auto. apply mult_le_MSBAux; auto. unfold FtoRradix, FtoR in |- *; simpl in |- *. rewrite powerRZ_Zs; auto with real zarith; ring. Qed. Theorem MSB_mix : forall x y : float, ~ is_Fzero x -> ~ is_Fzero y -> (Fabs x * Float 1%nat (MSB y) < radix * (Fabs y * Float 1%nat (MSB x)))%R. intros x y H' H'0; rewrite (MSB_abs x); rewrite (MSB_abs y). apply Rle_lt_trans with (Fabs x * Fabs y)%R; auto with real. apply Rmult_le_compat_l; auto with real. unfold FtoRradix in |- *; rewrite Fabs_correct; auto with real arith. rewrite <- MSB_abs; apply MSB_le_abs; auto. rewrite (Rmult_comm (Fabs x)). replace (radix * (Fabs y * Float 1%nat (MSB (Fabs x))))%R with (Fabs y * (radix * Float 1%nat (MSB (Fabs x))))%R; [ idtac | ring ]. apply Rmult_lt_compat_l; auto with real. unfold FtoRradix, FtoR in |- *; simpl in |- *; auto with real arith. rewrite Rmult_comm; replace 0%R with (powerRZ radix (Fexp y) * 0)%R; [ idtac | ring ]. apply Rmult_lt_compat_l; auto with real arith. rewrite Zabs_absolu. replace 0%R with (INR 0); [ idtac | simpl in |- *; auto ]; rewrite <- INR_IZR_INZ; apply INR_lt_nm. apply absolu_lt_nz; auto. replace (radix * Float 1%nat (MSB (Fabs x)))%R with (FtoRradix (Float 1%nat (Zsucc (MSB (Fabs x))))). rewrite <- MSB_abs; apply abs_lt_MSB; auto. unfold FtoRradix, FtoR in |- *; simpl in |- *. rewrite powerRZ_Zs; auto with real zarith; ring. Qed. Theorem LSB_rep : forall x y : float, ~ is_Fzero y -> (LSB x <= LSB y)%Z -> exists z : Z, y = Float z (Fexp x) :>R. intros x y H' H'0. case (Zle_or_lt (Fexp x) (Fexp y)); intros Zl1. exists (Fnum y * Zpower_nat radix (Zabs_nat (Fexp y - Fexp x)))%Z. pattern (Fexp x) at 2 in |- *; replace (Fexp x) with (Fexp y - Zabs_nat (Fexp y - Fexp x))%Z. unfold FtoRradix in |- *; rewrite <- (FshiftCorrect radix) with (n := Zabs_nat (Fexp y - Fexp x)) (x := y); auto. rewrite inj_abs; try ring; auto with zarith. exists (Zquotient (Fnum y) (Zpower_nat radix (Zabs_nat (Fexp x - Fexp y)))). unfold FtoRradix in |- *; rewrite <- (FshiftCorrect radix) with (n := Zabs_nat (Fexp x - Fexp y)) (x := Float (Zquotient (Fnum y) (Zpower_nat radix (Zabs_nat (Fexp x - Fexp y)))) (Fexp x)); auto. unfold Fshift in |- *; simpl in |- *. cut (0 <= Fexp x - Fexp y)%Z; [ intros Le1; repeat rewrite inj_abs | auto with zarith ]; auto. unfold FtoR in |- *; simpl in |- *; auto. replace (Fexp x - (Fexp x - Fexp y))%Z with (Fexp y); [ idtac | ring ]. replace (Zquotient (Fnum y) (Zpower_nat radix (Zabs_nat (Fexp x - Fexp y))) * Zpower_nat radix (Zabs_nat (Fexp x - Fexp y)))%Z with ( Fnum y); auto. apply ZdividesZquotient; auto with zarith. apply ZdividesTrans with (m := Zpower_nat radix (maxDiv (Fnum y) (Fdigit radix y))). apply maxDivCorrect. apply ZdividesLessPow; auto. apply ZleLe. rewrite inj_abs; auto with zarith. apply Zplus_le_reg_l with (p := Fexp y). apply Zle_trans with (LSB x). replace (Fexp y + (Fexp x - Fexp y))%Z with (Fexp x); [ idtac | ring ]. apply Fexp_le_LSB. rewrite Zplus_comm; auto. Qed. Theorem LSB_rep_min : forall p : float, exists z : Z, p = Float z (LSB p) :>R. intros p; exists (Zquotient (Fnum p) (Zpower_nat radix (Zabs_nat (LSB p - Fexp p)))). unfold FtoRradix, FtoR, LSB in |- *; simpl in |- *. rewrite powerRZ_add; auto with real zarith. rewrite <- Rmult_assoc. replace (maxDiv (Fnum p) (Fdigit radix p) + Fexp p - Fexp p)%Z with (Z_of_nat (maxDiv (Fnum p) (Fdigit radix p))); auto. rewrite absolu_INR. rewrite <- Zpower_nat_Z_powerRZ; auto with zarith. rewrite <- Rmult_IZR. rewrite <- ZdividesZquotient; auto with zarith. apply maxDivCorrect. ring. Qed. End mf.Float8.4/MSBProp.v0000644000423700002640000000627712032774526013536 0ustar sboldotoccata(**************************************************************************** IEEE754 : MSBProp Laurent Thery, Sylvie Boldo ******************************************************************************) Require Export MSB. Section MSBProp. Variable b : Fbound. Variable precision : nat. Variable radix : Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Hypothesis radixMoreThanOne : (1 < radix)%Z. Let radixMoreThanZERO : (0 < radix)%Z := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Theorem boundOnePrecision : forall a : float, Fbounded b a -> (Rabs a < Float 1%nat (precision + Fexp a))%R. intros a H. replace (FtoRradix (Float 1%nat (precision + Fexp a))) with (FtoRradix (Fshift radix precision (Float 1%nat (precision + Fexp a)))); [ idtac | apply (FshiftCorrect radix); auto ]. unfold Fshift, FtoRradix, FtoR in |- *; simpl in |- *. rewrite <- pGivesBound. replace (precision + Fexp a - precision)%Z with (Fexp a); [ idtac | ring ]. rewrite Rabs_mult; rewrite (fun x y => Rabs_pos_eq (powerRZ x y)); auto with real zarith. apply Rlt_monotony_exp; auto with float real zarith. rewrite Faux.Rabsolu_Zabs; auto with float real zarith. Qed. Theorem boundNormalMult : forall x y : float, Fnormal radix b x -> Fbounded b y -> (Rabs y * Float 1%nat (Fexp x) < radix * (Rabs x * Float 1%nat (Fexp y)))%R. intros x y H H0. apply Rlt_le_trans with (Float (Zpos (vNum b)) (Fexp y) * Float 1%nat (Fexp x))%R. apply Rmult_lt_compat_r. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *. replace (1 * powerRZ radix (Fexp x))%R with (powerRZ radix (Fexp x)); [ idtac | ring ]. apply powerRZ_lt; auto with real arith. unfold FtoRradix in |- *; apply MaxFloat; auto. replace (Float (Zpos (vNum b)) (Fexp y) * Float 1%nat (Fexp x))%R with (Zpos (vNum b) * Float 1%nat (Fexp x) * Float 1%nat (Fexp y))%R. replace (radix * (Rabs x * Float 1%nat (Fexp y)))%R with (radix * Rabs x * Float 1%nat (Fexp y))%R; [ idtac | ring ]. apply Rmult_le_compat_r. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *. replace (1 * powerRZ radix (Fexp y))%R with (powerRZ radix (Fexp y)); [ idtac | ring ]. apply powerRZ_le; auto with real arith. replace (Zpos (vNum b) * Float 1%nat (Fexp x))%R with (FtoRradix (Float (Zpos (vNum b)) (Fexp x))). rewrite <- (Fabs_correct radix); auto with real zarith. unfold Fabs, FtoRradix, FtoR in |- *. rewrite <- Rmult_assoc. apply Rle_monotone_exp; auto with real arith. rewrite <- Rmult_IZR; apply Rle_IZR; simpl in |- *. rewrite <- (Zabs_eq radix); auto with zarith; rewrite <- Zabs_Zmult; auto with float. case H; simpl in |- *; auto. unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. Qed. End MSBProp.Float8.4/Option.v0000644000423700002640000000016312032774526013510 0ustar sboldotoccata(* Usual option type *) Inductive Option (A : Set) : Set := | Some : forall x : A, Option A | None : Option A.Float8.4/Paux.v0000644000423700002640000011162412032774526013162 0ustar sboldotoccata(**************************************************************************** IEEE754 : Paux Laurent Thery ******************************************************************************) Require Export Digit. Require Export Option. Require Export Inverse_Image. Require Export Wf_nat. Require Import BinPos. Fixpoint exp (n m : nat) {struct m} : nat := match m with | O => 1 | S m' => n * exp n m' end. Theorem expPlus : forall n p q : nat, exp n (p + q) = exp n p * exp n q. intros n p; elim p; simpl in |- *; auto with arith. intros n0 H' q; rewrite mult_assoc_reverse; rewrite <- H'; auto. Qed. Fixpoint positive_exp (p n : positive) {struct n} : positive := match n with | xH => p | xO n1 => match positive_exp p n1 with | r => (fun (x : positive) (_ : positive -> positive) (y : positive) => (x * y)%positive) r ( fun x => x) r end | xI n1 => match positive_exp p n1 with | r => (fun (x : positive) (_ : positive -> positive) (y : positive) => (x * y)%positive) p ( fun x => x) ((fun (x : positive) (_ : positive -> positive) (y : positive) => (x * y)%positive) r ( fun x => x) r) end end. Theorem positive_exp_correct : forall p n : positive, nat_of_P (positive_exp p n) = exp (nat_of_P p) (nat_of_P n). intros p n; elim n; simpl in |- *; auto. intros p0 H. repeat rewrite (fun (x y : positive) (_ : positive -> positive) => nat_of_P_mult_morphism x y); simpl in |- *; auto. rewrite ZL6; rewrite expPlus; rewrite H; auto. intros p0 H. repeat rewrite (fun (x y : positive) (_ : positive -> positive) => nat_of_P_mult_morphism x y); simpl in |- *; auto. rewrite H; rewrite <- expPlus; rewrite <- ZL6; auto. rewrite mult_comm; simpl in |- *; auto. Qed. Fixpoint Pdiv (p q : positive) {struct p} : Option positive * Option positive := match p with | xH => match q with | xH => (Some _ 1%positive, None _) | xO r => (None _, Some _ p) | xI r => (None _, Some _ p) end | xI p' => match Pdiv p' q with | (None, None) => match (1 - Zpos q)%Z with | Z0 => (Some _ 1%positive, None _) | Zpos r' => (Some _ 1%positive, Some _ r') | Zneg r' => (None _, Some _ 1%positive) end | (None, Some r1) => match (Zpos (xI r1) - Zpos q)%Z with | Z0 => (Some _ 1%positive, None _) | Zpos r' => (Some _ 1%positive, Some _ r') | Zneg r' => (None _, Some _ (xI r1)) end | (Some q1, None) => match (1 - Zpos q)%Z with | Z0 => (Some _ (xI q1), None _) | Zpos r' => (Some _ (xI q1), Some _ r') | Zneg r' => (Some _ (xO q1), Some _ 1%positive) end | (Some q1, Some r1) => match (Zpos (xI r1) - Zpos q)%Z with | Z0 => (Some _ (xI q1), None _) | Zpos r' => (Some _ (xI q1), Some _ r') | Zneg r' => (Some _ (xO q1), Some _ (xI r1)) end end | xO p' => match Pdiv p' q with | (None, None) => (None _, None _) | (None, Some r1) => match (Zpos (xO r1) - Zpos q)%Z with | Z0 => (Some _ 1%positive, None _) | Zpos r' => (Some _ 1%positive, Some _ r') | Zneg r' => (None _, Some _ (xO r1)) end | (Some q1, None) => (Some _ (xO q1), None _) | (Some q1, Some r1) => match (Zpos (xO r1) - Zpos q)%Z with | Z0 => (Some _ (xI q1), None _) | Zpos r' => (Some _ (xI q1), Some _ r') | Zneg r' => (Some _ (xO q1), Some _ (xO r1)) end end end. Definition oZ h := match h with | None => 0 | Some p => nat_of_P p end. Theorem Pdiv_correct : forall p q, nat_of_P p = oZ (fst (Pdiv p q)) * nat_of_P q + oZ (snd (Pdiv p q)) /\ oZ (snd (Pdiv p q)) < nat_of_P q. intros p q; elim p; simpl in |- *; auto. 3: case q; simpl in |- *; try intros q1; split; auto; unfold nat_of_P in |- *; simpl in |- *; auto with arith. intros p'; simpl in |- *; case (Pdiv p' q); simpl in |- *; intros q1 r1 (H1, H2); split. unfold nat_of_P in |- *; simpl in |- *. rewrite ZL6; rewrite H1. case q1; case r1; simpl in |- *. intros r2 q2. rewrite Z.pos_sub_spec; unfold Pos.compare. CaseEq (Pcompare (xI r2) q Datatypes.Eq); simpl in |- *; auto. intros H3; rewrite <- (Pcompare_Eq_eq _ _ H3); simpl in |- *; unfold nat_of_P in |- *; simpl in |- *. apply f_equal with (f := S); repeat rewrite (fun x y => mult_comm x (S y)); repeat rewrite ZL6; unfold nat_of_P in |- *; simpl in |- *; ring. intros H3; unfold nat_of_P in |- *; simpl in |- *; repeat rewrite ZL6; unfold nat_of_P in |- *; repeat rewrite (fun x y => plus_comm x (S y)); simpl in |- *; apply f_equal with (f := S); ring. intros H3; case (Pminus_mask_Gt _ _ H3); intros h (H4, (H5, H6)); unfold Pminus in |- *; rewrite H4. apply trans_equal with (nat_of_P q + nat_of_P h + Pmult_nat q2 2 * Pmult_nat q 1); [ rewrite <- nat_of_P_plus_morphism; rewrite H5; simpl in |- *; repeat rewrite ZL6; unfold nat_of_P in |- *; apply f_equal with (f := S) | unfold nat_of_P in |- * ]; ring. intros r2. rewrite Z.pos_sub_spec; unfold Pos.compare. CaseEq (Pcompare 1 q Datatypes.Eq); simpl in |- *; auto. intros H3; rewrite <- (Pcompare_Eq_eq _ _ H3); simpl in |- *; repeat rewrite ZL6; unfold nat_of_P in |- *; simpl in |- *; apply f_equal with (f := S);ring. intros H3; unfold nat_of_P in |- *; simpl in |- *; repeat rewrite (fun x y => plus_comm x (S y)); simpl in |- *; apply f_equal with (f := S); repeat rewrite ZL6; unfold nat_of_P in |- *; simpl in |- *; ring. intros H3; case (Pminus_mask_Gt _ _ H3); intros h (H4, (H5, H6)); unfold Pminus in |- *; rewrite H4; apply trans_equal with (nat_of_P q + nat_of_P h + Pmult_nat r2 2 * Pmult_nat q 1); [ rewrite <- nat_of_P_plus_morphism; rewrite H5; simpl in |- *; repeat rewrite ZL6; unfold nat_of_P in |- *; apply f_equal with (f := S) | unfold nat_of_P in |- * ]; ring. intros r2. rewrite Z.pos_sub_spec; unfold Pos.compare. CaseEq (Pcompare (xI r2) q Datatypes.Eq); simpl in |- *; auto. intros H3; rewrite <- (Pcompare_Eq_eq _ _ H3); simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; repeat rewrite ZL6; unfold nat_of_P in |- *; apply f_equal with (f := S); ring. intros H3; unfold nat_of_P in |- *; simpl in |- *; repeat rewrite ZL6; unfold nat_of_P in |- *; apply f_equal with (f := S); ring. intros H3; case (Pminus_mask_Gt _ _ H3); intros h (H4, (H5, H6)); unfold Pminus in |- *; rewrite H4; apply trans_equal with (nat_of_P q + nat_of_P h); [ rewrite <- (nat_of_P_plus_morphism q); rewrite H5; unfold nat_of_P in |- *; simpl in |- *; repeat rewrite ZL6; unfold nat_of_P in |- *; apply f_equal with (f := S) | unfold nat_of_P in |- * ]; ring. case q; simpl in |- *; auto. generalize H2; case q1; case r1; simpl in |- *; auto. intros r2 q2. rewrite Z.pos_sub_spec; unfold Pos.compare. CaseEq (Pcompare (xI r2) q Datatypes.Eq); simpl in |- *; auto. intros; apply lt_O_nat_of_P; auto. intros H H0; apply nat_of_P_lt_Lt_compare_morphism; auto. intros H3 H7; case (Pminus_mask_Gt _ _ H3); intros h (H4, (H5, H6)); unfold Pminus in |- *; rewrite H4; apply plus_lt_reg_l with (p := nat_of_P q); rewrite <- (nat_of_P_plus_morphism q); rewrite H5; unfold nat_of_P in |- *; simpl in |- *; repeat rewrite ZL6; unfold nat_of_P in |- *; apply le_lt_trans with (Pmult_nat r2 1 + Pmult_nat q 1); auto with arith. intros r2 HH; case q; simpl in |- *; auto. intros p2; case p2; unfold nat_of_P in |- *; simpl in |- *; auto with arith. intros p2; case p2; unfold nat_of_P in |- *; simpl in |- *; auto with arith. intros r2 HH. rewrite Z.pos_sub_spec; unfold Pos.compare. CaseEq (Pcompare (xI r2) q Datatypes.Eq); simpl in |- *. intros; apply lt_O_nat_of_P; auto. intros H3; apply nat_of_P_lt_Lt_compare_morphism; auto. intros H3; case (Pminus_mask_Gt _ _ H3); intros h (H4, (H5, H6)); unfold Pminus in |- *; rewrite H4; apply plus_lt_reg_l with (p := nat_of_P q); rewrite <- (nat_of_P_plus_morphism q); rewrite H5; unfold nat_of_P in |- *; simpl in |- *; repeat rewrite ZL6; unfold nat_of_P in |- *; apply le_lt_trans with (Pmult_nat r2 1 + Pmult_nat q 1); auto with arith. intros HH; case q; simpl in |- *; auto. intros p2; case p2; unfold nat_of_P in |- *; simpl in |- *; auto with arith. intros p2; case p2; unfold nat_of_P in |- *; simpl in |- *; auto with arith. intros p'; simpl in |- *; case (Pdiv p' q); simpl in |- *; intros q1 r1 (H1, H2); split. unfold nat_of_P in |- *; simpl in |- *; rewrite ZL6; rewrite H1. case q1; case r1; simpl in |- *; auto. intros r2 q2. rewrite Z.pos_sub_spec; unfold Pos.compare. CaseEq (Pcompare (xO r2) q Datatypes.Eq); simpl in |- *; auto. intros H3; rewrite <- (Pcompare_Eq_eq _ _ H3); simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; repeat rewrite ZL6; unfold nat_of_P in |- *; ring. intros H3; unfold nat_of_P in |- *; simpl in |- *; repeat rewrite ZL6; unfold nat_of_P in |- *; ring. intros H3; case (Pminus_mask_Gt _ _ H3); intros h (H4, (H5, H6)); unfold Pminus in |- *; rewrite H4; apply trans_equal with (nat_of_P q + nat_of_P h + Pmult_nat q2 2 * Pmult_nat q 1); [ rewrite <- (nat_of_P_plus_morphism q); rewrite H5; unfold nat_of_P in |- *; simpl in |- *; repeat rewrite ZL6; unfold nat_of_P in |- * | unfold nat_of_P in |- * ]; ring. intros H3; unfold nat_of_P in |- *; simpl in |- *; repeat rewrite ZL6; unfold nat_of_P in |- *; ring. intros r2. rewrite Z.pos_sub_spec; unfold Pos.compare. CaseEq (Pcompare (xO r2) q Datatypes.Eq); simpl in |- *; auto. intros H3; rewrite <- (Pcompare_Eq_eq _ _ H3); simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; repeat rewrite ZL6; unfold nat_of_P in |- *; ring. intros H3; unfold nat_of_P in |- *; simpl in |- *; repeat rewrite ZL6; unfold nat_of_P in |- *; ring. intros H3; case (Pminus_mask_Gt _ _ H3); intros h (H4, (H5, H6)); unfold Pminus in |- *; rewrite H4; apply trans_equal with (nat_of_P q + nat_of_P h); [ rewrite <- (nat_of_P_plus_morphism q); rewrite H5; unfold nat_of_P in |- *; simpl in |- *; repeat rewrite ZL6; unfold nat_of_P in |- * | unfold nat_of_P in |- * ]; ring. generalize H2; case q1; case r1; simpl in |- *. intros r2 q2. rewrite Z.pos_sub_spec; unfold Pos.compare. CaseEq (Pcompare (xO r2) q Datatypes.Eq); simpl in |- *; auto. intros; apply lt_O_nat_of_P; auto. intros H H0; apply nat_of_P_lt_Lt_compare_morphism; auto. intros H3 H7; case (Pminus_mask_Gt _ _ H3); intros h (H4, (H5, H6)); unfold Pminus in |- *; rewrite H4; apply plus_lt_reg_l with (p := nat_of_P q); rewrite <- (nat_of_P_plus_morphism q); rewrite H5; unfold nat_of_P in |- *; simpl in |- *; unfold nat_of_P in |- *; simpl in |- *; repeat rewrite ZL6; unfold nat_of_P in |- *; apply lt_trans with (Pmult_nat r2 1 + Pmult_nat q 1); auto with arith. intros; apply lt_O_nat_of_P; auto. intros r2 HH. rewrite Z.pos_sub_spec; unfold Pos.compare. CaseEq (Pcompare (xO r2) q Datatypes.Eq); simpl in |- *. intros; apply lt_O_nat_of_P; auto. intros H3; apply nat_of_P_lt_Lt_compare_morphism; auto. intros H3; case (Pminus_mask_Gt _ _ H3); intros h (H4, (H5, H6)); unfold Pminus in |- *; rewrite H4; apply plus_lt_reg_l with (p := nat_of_P q); rewrite <- (nat_of_P_plus_morphism q); rewrite H5; unfold nat_of_P in |- *; simpl in |- *; repeat rewrite ZL6; unfold nat_of_P in |- *; apply lt_trans with (Pmult_nat r2 1 + Pmult_nat q 1); auto with arith. auto. Qed. Section bugFix. Variable PdivAux : positive -> positive -> Option positive * Option positive. Fixpoint PdivlessAux (bound p base length : positive) {struct length} : Option positive * Option positive * nat := match Pcompare bound p Datatypes.Eq with | Datatypes.Gt => (Some _ p, None _, 0) | _ => match PdivAux p base with | (None, None) => (None _, None _, 1) | (None, Some r1) => (None _, Some _ r1, 1) | (Some q1, None) => match length with | xH => (Some _ q1, None _, 0) | xO length' => match PdivlessAux bound q1 base length' with | (s2, None, n) => (s2, None _, S n) | (s2, Some r2, n) => (s2, Some _ ((fun (x : positive) (_ : positive -> positive) (y : positive) => (x * y)%positive) r2 (fun x => x) base), S n) end | xI length' => match PdivlessAux bound q1 base length' with | (s2, None, n) => (s2, None _, S n) | (s2, Some r2, n) => (s2, Some _ ((fun (x : positive) (_ : positive -> positive) (y : positive) => (x * y)%positive) r2 (fun x => x) base), S n) end end | (Some q1, Some r1) => match length with | xH => (Some _ q1, None _, 0) | xO length' => match PdivlessAux bound q1 base length' with | (s2, None, n) => (s2, Some _ r1, S n) | (s2, Some r2, n) => (s2, Some _ ((fun (x : positive) (_ : positive -> positive) (y : positive) => x * y) r2 ( fun x => x) base + r1)%positive, S n) end | xI length' => match PdivlessAux bound q1 base length' with | (s2, None, n) => (s2, Some _ r1, S n) | (s2, Some r2, n) => (s2, Some _ ((fun (x : positive) (_ : positive -> positive) (y : positive) => x * y) r2 ( fun x => x) base + r1)%positive, S n) end end end end. End bugFix. Definition Pdivless := PdivlessAux Pdiv. Theorem Pdivless1 : forall bound p q base, Pcompare bound p Datatypes.Eq = Datatypes.Gt -> Pdivless bound p base q = (Some _ p, None _, 0). intros bound p q base H; case q; simpl in |- *; auto; intros; rewrite H; auto. Qed. Theorem Pdivless2 : forall bound p length base, Pcompare bound p Datatypes.Eq <> Datatypes.Gt -> Pdivless bound p base length = match Pdiv p base with | (None, None) => (None _, None _, 1) | (None, Some r1) => (None _, Some _ r1, 1) | (Some q1, None) => match length with | xH => (Some _ q1, None _, 0) | xO length' => match Pdivless bound q1 base length' with | (s2, None, n) => (s2, None _, S n) | (s2, Some r2, n) => (s2, Some _ ((fun (x : positive) (_ : positive -> positive) (y : positive) => (x * y)%positive) r2 ( fun x => x) base), S n) end | xI length' => match Pdivless bound q1 base length' with | (s2, None, n) => (s2, None _, S n) | (s2, Some r2, n) => (s2, Some _ ((fun (x : positive) (_ : positive -> positive) (y : positive) => (x * y)%positive) r2 ( fun x => x) base), S n) end end | (Some q1, Some r1) => match length with | xH => (Some _ q1, None _, 0) | xO length' => match Pdivless bound q1 base length' with | (s2, None, n) => (s2, Some _ r1, S n) | (s2, Some r2, n) => (s2, Some _ ((fun (x : positive) (_ : positive -> positive) (y : positive) => x * y) r2 ( fun x => x) base + r1)%positive, S n) end | xI length' => match Pdivless bound q1 base length' with | (s2, None, n) => (s2, Some _ r1, S n) | (s2, Some r2, n) => (s2, Some _ ((fun (x : positive) (_ : positive -> positive) (y : positive) => x * y) r2 ( fun x => x) base + r1)%positive, S n) end end end. intros bound p length base; case length; simpl in |- *; case (Pcompare bound p Datatypes.Eq); auto; (intros H; case H; auto; fail) || (intros p' H; case H; auto). Qed. Theorem compare_SUP_dec : forall p q : positive, Pcompare p q Datatypes.Eq = Datatypes.Gt \/ Pcompare p q Datatypes.Eq <> Datatypes.Gt. intros p q; case (Pcompare p q Datatypes.Eq); auto; right; red in |- *; intros; discriminate. Qed. Hint Resolve lt_O_nat_of_P: arith. Theorem odd_even_lem : forall p q, 2 * p + 1 <> 2 * q. intros p; elim p; auto. intros q; case q; simpl in |- *. red in |- *; intros; discriminate. intros q'; rewrite (fun x y => plus_comm x (S y)); simpl in |- *; red in |- *; intros; discriminate. intros p' H q; case q. simpl in |- *; red in |- *; intros; discriminate. intros q'; red in |- *; intros H0; case (H q'). replace (2 * q') with (2 * S q' - 2). rewrite <- H0; simpl in |- *; auto. repeat rewrite (fun x y => plus_comm x (S y)); simpl in |- *; auto. simpl in |- *; repeat rewrite (fun x y => plus_comm x (S y)); simpl in |- *; auto. case q'; simpl in |- *; auto. Qed. Theorem Pdivless_correct : forall bound p q base, 1 < nat_of_P base -> nat_of_P p <= nat_of_P q -> nat_of_P p = oZ (fst (fst (Pdivless bound p base q))) * exp (nat_of_P base) (snd (Pdivless bound p base q)) + oZ (snd (fst (Pdivless bound p base q))) /\ (oZ (fst (fst (Pdivless bound p base q))) < nat_of_P bound /\ oZ (snd (fst (Pdivless bound p base q))) < exp (nat_of_P base) (snd (Pdivless bound p base q))) /\ (forall bound', nat_of_P bound = nat_of_P base * bound' -> nat_of_P bound <= nat_of_P p -> nat_of_P bound <= nat_of_P base * oZ (fst (fst (Pdivless bound p base q)))). intros bound p q base Hb; generalize q; pattern p in |- *; apply well_founded_ind with (R := fun a b => nat_of_P a < nat_of_P b); auto; clear p q. apply wf_inverse_image with (R := lt); auto. exact lt_wf; auto. intros p Rec q Hq. case (compare_SUP_dec bound p); intros H1. rewrite Pdivless1; auto; simpl in |- *. repeat (split; auto with arith). ring; auto. apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; auto. intros bound' H'1 H2; Contradict H2; apply lt_not_le; apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; auto. rewrite Pdivless2; auto; simpl in |- *. generalize (Pdiv_correct p base); case (Pdiv p base); simpl in |- *. intros o1; case o1; simpl in |- *. intros o1' o2; case o2; simpl in |- *. intros o2' (Ho1, Ho2). generalize Hq; case q; simpl in |- *; auto. intros p0 Hq0; (cut (nat_of_P o1' <= nat_of_P p0); [ intros Hrec | idtac ]). cut (nat_of_P o1' < nat_of_P p); [ intros Hrec1 | idtac ]. generalize (Rec _ Hrec1 _ Hrec). CaseEq (Pdivless bound o1' base p0); simpl in |- *. intros p1; case p1; simpl in |- *. intros o3; case o3; simpl in |- *; auto. intros o3' o4; case o4; simpl in |- *; auto. intros o4' n Eq1; rewrite nat_of_P_plus_morphism; rewrite nat_of_P_mult_morphism. intros (H'1, ((H'2, H'3), H'4)); repeat (split; auto). rewrite Ho1; rewrite H'1; ring. apply lt_le_trans with (S (nat_of_P o4') * nat_of_P base). simpl in |- *; rewrite (fun x y => plus_comm x (nat_of_P y)); auto with arith. rewrite (fun x y => mult_comm x (nat_of_P y)); auto with arith. intros bound' H'5 H'6; case (le_or_lt (nat_of_P bound) (nat_of_P o1')); intros H'7; auto. apply (H'4 bound'); auto. rewrite Pdivless1 in Eq1; auto. discriminate. apply nat_of_P_gt_Gt_compare_complement_morphism; auto. intros n Eq1 (H'1, ((H'2, H'3), H'4)); repeat (split; auto). rewrite Ho1; rewrite H'1; ring. apply lt_le_trans with (nat_of_P base * 1); auto with arith. rewrite mult_comm; simpl in |- *; auto with arith. intros bound' H'5 H'6; case (le_or_lt (nat_of_P bound) (nat_of_P o1')); intros H'7; auto. apply (H'4 bound'); auto. rewrite Pdivless1 in Eq1; auto. inversion Eq1. rewrite <- H0. case (le_or_lt bound' (nat_of_P o1')); intros H'8; auto. rewrite H'5; auto with arith. Contradict H'6; auto. apply lt_not_le; rewrite Ho1; auto. apply lt_le_trans with (nat_of_P o1' * nat_of_P base + 1 * nat_of_P base); auto with arith. simpl in |- *; auto with arith. rewrite <- mult_plus_distr_r. replace (nat_of_P o1' + 1) with (S (nat_of_P o1')); auto with arith. rewrite H'5; auto with arith. rewrite <- (fun x y => mult_comm (nat_of_P x) y); auto with arith. rewrite plus_comm; auto with arith. apply nat_of_P_gt_Gt_compare_complement_morphism; auto with arith. intros o4; case o4; simpl in |- *. intros o4' n Eq1; rewrite nat_of_P_plus_morphism; rewrite nat_of_P_mult_morphism. intros (H'1, ((H'2, H'3), H'4)); repeat (split; auto). rewrite Ho1; rewrite H'1; ring. apply lt_le_trans with (S (nat_of_P o4') * nat_of_P base). simpl in |- *; rewrite (fun x y => plus_comm x (nat_of_P y)); auto with arith. rewrite (fun x y => mult_comm x (nat_of_P y)); auto with arith. intros bound' H H0; apply (H'4 bound'); auto. case (le_or_lt (nat_of_P bound) (nat_of_P o1')); intros H'8; auto. rewrite Pdivless1 in Eq1; auto. discriminate. apply nat_of_P_gt_Gt_compare_complement_morphism; auto. intros n Eq1 (H'1, ((H'2, H'3), H'4)); repeat (split; auto). rewrite Ho1; rewrite H'1; ring. apply lt_le_trans with (nat_of_P base * 1); auto with arith. rewrite mult_comm; simpl in |- *; auto with arith. intros bound' H H0; apply (H'4 bound'); auto. case (le_or_lt (nat_of_P bound) (nat_of_P o1')); intros H'8; auto. rewrite Pdivless1 in Eq1; auto. discriminate. apply nat_of_P_gt_Gt_compare_complement_morphism; auto. rewrite Ho1; auto. apply lt_le_trans with (nat_of_P o1' * 1 + nat_of_P o2'); auto with arith. rewrite mult_comm; simpl in |- *; auto with arith. apply le_lt_trans with (nat_of_P o1' + 0); auto with arith. apply plus_le_lt_compat; auto with arith. apply mult_S_le_reg_l with (n := pred (nat_of_P base)). replace (S (pred (nat_of_P base))) with (nat_of_P base). apply (fun p n m : nat => plus_le_reg_l n m p) with (p := nat_of_P o2'). rewrite (plus_comm (nat_of_P o2')); simpl in |- *; auto with arith. rewrite (mult_comm (nat_of_P base)); simpl in |- *; auto with arith. rewrite <- Ho1; auto with arith. apply le_trans with (1 := Hq0); auto with arith. replace (nat_of_P (xI p0)) with (1 + 2 * nat_of_P p0); auto with arith. apply plus_le_compat; auto with arith. unfold nat_of_P in |- *; simpl in |- *; (rewrite ZL6; auto). generalize (lt_O_nat_of_P base); case (nat_of_P base); simpl in |- *; auto; intros tmp; inversion tmp. intros p0 Hq0; (cut (nat_of_P o1' <= nat_of_P p0); [ intros Hrec | idtac ]). cut (nat_of_P o1' < nat_of_P p); [ intros Hrec1 | idtac ]. generalize (Rec _ Hrec1 _ Hrec). CaseEq (Pdivless bound o1' base p0); simpl in |- *. intros p1; case p1; simpl in |- *. intros o3; case o3; simpl in |- *; auto. intros o3' o4; case o4; simpl in |- *; auto. intros o4' n Eq1; rewrite nat_of_P_plus_morphism; rewrite nat_of_P_mult_morphism. intros (H'1, ((H'2, H'3), H'4)); repeat (split; auto). rewrite Ho1; rewrite H'1; ring. apply lt_le_trans with (S (nat_of_P o4') * nat_of_P base). simpl in |- *; rewrite (fun x y => plus_comm x (nat_of_P y)); auto with arith. rewrite (fun x y => mult_comm x (nat_of_P y)); auto with arith. intros bound' H'5 H'6; case (le_or_lt (nat_of_P bound) (nat_of_P o1')); intros H'7; auto. apply (H'4 bound'); auto. rewrite Pdivless1 in Eq1; auto. discriminate. apply nat_of_P_gt_Gt_compare_complement_morphism; auto. intros n Eq1 (H'1, ((H'2, H'3), H'4)); repeat (split; auto). rewrite Ho1; rewrite H'1; ring. apply lt_le_trans with (nat_of_P base * 1); auto with arith. rewrite mult_comm; simpl in |- *; auto with arith. intros bound' H'5 H'6; case (le_or_lt (nat_of_P bound) (nat_of_P o1')); intros H'7; auto. apply (H'4 bound'); auto. rewrite Pdivless1 in Eq1; auto. inversion Eq1. rewrite <- H0. case (le_or_lt bound' (nat_of_P o1')); intros H'8; auto. rewrite H'5; auto with arith. Contradict H'6; auto. apply lt_not_le; rewrite Ho1; auto. apply lt_le_trans with (nat_of_P o1' * nat_of_P base + 1 * nat_of_P base); auto with arith. simpl in |- *; auto with arith. rewrite <- mult_plus_distr_r. replace (nat_of_P o1' + 1) with (S (nat_of_P o1')); auto with arith. rewrite H'5; auto with arith. rewrite <- (fun x y => mult_comm (nat_of_P x) y); auto with arith. rewrite plus_comm; auto with arith. apply nat_of_P_gt_Gt_compare_complement_morphism; auto with arith. intros o4; case o4; simpl in |- *. intros o4' n Eq1; rewrite nat_of_P_plus_morphism; rewrite nat_of_P_mult_morphism. intros (H'1, ((H'2, H'3), H'4)); repeat (split; auto). rewrite Ho1; rewrite H'1; ring. apply lt_le_trans with (S (nat_of_P o4') * nat_of_P base). simpl in |- *; rewrite (fun x y => plus_comm x (nat_of_P y)); auto with arith. rewrite (fun x y => mult_comm x (nat_of_P y)); auto with arith. intros bound' H H0; apply (H'4 bound'); auto. case (le_or_lt (nat_of_P bound) (nat_of_P o1')); intros H'8; auto. rewrite Pdivless1 in Eq1; auto. discriminate. apply nat_of_P_gt_Gt_compare_complement_morphism; auto. intros n Eq1 (H'1, ((H'2, H'3), H'4)); repeat (split; auto). rewrite Ho1; rewrite H'1; ring. apply lt_le_trans with (nat_of_P base * 1); auto with arith. rewrite mult_comm; simpl in |- *; auto with arith. rewrite Ho1; auto. intros bound' H H0; apply (H'4 bound'); auto. case (le_or_lt (nat_of_P bound) (nat_of_P o1')); intros H'8; auto. rewrite Pdivless1 in Eq1; auto. discriminate. apply nat_of_P_gt_Gt_compare_complement_morphism; auto. apply lt_le_trans with (nat_of_P o1' * 1 + nat_of_P o2'); auto with arith. rewrite mult_comm; simpl in |- *; auto with arith. apply le_lt_trans with (nat_of_P o1' + 0); auto with arith. apply plus_le_lt_compat; auto with arith. rewrite Ho1; auto with arith. apply mult_S_le_reg_l with (n := pred (nat_of_P base)). replace (S (pred (nat_of_P base))) with (nat_of_P base). apply (fun p n m : nat => plus_le_reg_l n m p) with (p := nat_of_P o2'). rewrite (plus_comm (nat_of_P o2')); simpl in |- *; auto with arith. rewrite (mult_comm (nat_of_P base)); simpl in |- *; auto with arith. rewrite <- Ho1; auto with arith. apply le_trans with (1 := Hq0); auto with arith. replace (nat_of_P (xO p0)) with (0 + 2 * nat_of_P p0); auto with arith. apply plus_le_compat; auto with arith. unfold nat_of_P in |- *; simpl in |- *; (rewrite ZL6; auto). generalize (lt_O_nat_of_P base); case (nat_of_P base); simpl in |- *; auto; intros tmp; inversion tmp. replace (nat_of_P 1) with 1; auto with arith. rewrite Ho1; generalize (lt_O_nat_of_P o2'); (case (nat_of_P o2'); simpl in |- *). intros tmp; Contradict tmp; auto with arith. generalize (lt_O_nat_of_P o1'); (case (nat_of_P o1'); simpl in |- *). intros tmp; Contradict tmp; auto with arith. generalize (lt_O_nat_of_P base); (case (nat_of_P base); simpl in |- *). intros tmp; Contradict tmp; auto with arith. intros n H n0 H0 n1 H01; rewrite (fun x y => plus_comm x (S y)); simpl in |- *. intros tmp; Contradict tmp; auto with arith. generalize Hq; case q; simpl in |- *; auto. intros p0 Hq0 (Ho1, Ho2); (cut (nat_of_P o1' <= nat_of_P p0); [ intros Hrec | idtac ]). cut (nat_of_P o1' < nat_of_P p); [ intros Hrec1 | idtac ]. generalize (Rec _ Hrec1 _ Hrec). CaseEq (Pdivless bound o1' base p0); simpl in |- *. intros p1; case p1; simpl in |- *. intros o3; case o3; simpl in |- *; auto. intros o3' o4; case o4; simpl in |- *; auto. intros o4' n Eq1; rewrite nat_of_P_mult_morphism. intros (H'1, ((H'2, H'3), H'4)); repeat (split; auto). rewrite Ho1; rewrite H'1; ring. rewrite (fun x y => mult_comm x (nat_of_P y)); auto with arith. intros bound' H'5 H'6; case (le_or_lt (nat_of_P bound) (nat_of_P o1')); intros H'7; auto. apply (H'4 bound'); auto. rewrite Pdivless1 in Eq1; auto. discriminate. apply nat_of_P_gt_Gt_compare_complement_morphism; auto. intros n Eq1 (H'1, ((H'2, H'3), H'4)); repeat (split; auto). rewrite Ho1; rewrite H'1; ring. apply lt_le_trans with (nat_of_P base * 1); auto with arith. rewrite mult_comm; simpl in |- *; auto with arith. intros bound' H'5 H'6; case (le_or_lt (nat_of_P bound) (nat_of_P o1')); intros H'7; auto. apply (H'4 bound'); auto. rewrite Pdivless1 in Eq1; auto. inversion Eq1. rewrite <- H0. case (le_or_lt bound' (nat_of_P o1')); intros H'8; auto. rewrite H'5; auto with arith. Contradict H'6; auto. apply lt_not_le; rewrite Ho1; auto. apply lt_le_trans with (nat_of_P o1' * nat_of_P base + 1 * nat_of_P base); auto with arith. simpl in |- *; auto with arith. rewrite <- mult_plus_distr_r. replace (nat_of_P o1' + 1) with (S (nat_of_P o1')); auto with arith. rewrite H'5; auto with arith. rewrite <- (fun x y => mult_comm (nat_of_P x) y); auto with arith. rewrite plus_comm; auto with arith. apply nat_of_P_gt_Gt_compare_complement_morphism; auto with arith. intros o4; case o4; simpl in |- *. intros o4' n Eq1; rewrite nat_of_P_mult_morphism. intros (H'1, ((H'2, H'3), H'4)); repeat (split; auto). rewrite Ho1; rewrite H'1; ring. rewrite (fun x y => mult_comm x (nat_of_P y)); auto with arith. intros bound' H H0; apply (H'4 bound'); auto. case (le_or_lt (nat_of_P bound) (nat_of_P o1')); intros H'8; auto. rewrite Pdivless1 in Eq1; auto. discriminate. apply nat_of_P_gt_Gt_compare_complement_morphism; auto. intros n Eq1 (H'1, (H'2, H'3)). generalize (lt_O_nat_of_P o1'); rewrite H'1; intros tmp; inversion tmp. rewrite Ho1; auto. apply le_lt_trans with (nat_of_P o1' * 1 + 0); auto with arith. rewrite mult_comm; simpl in |- *; auto with arith. repeat rewrite (fun x => plus_comm x 0); simpl in |- *; auto with arith. apply mult_S_le_reg_l with (n := pred (nat_of_P base)). replace (S (pred (nat_of_P base))) with (nat_of_P base). rewrite (mult_comm (nat_of_P base)); simpl in |- *; auto with arith. rewrite (fun x => plus_comm x 0) in Ho1; simpl in Ho1; rewrite <- Ho1. generalize Hq0; clear Hq0; replace (nat_of_P (xI p0)) with (2 * nat_of_P p0 + 1); try intros Hq0. case (le_lt_or_eq _ _ Hq0); auto. rewrite (fun x y => plus_comm x (S y)); intros Hl1. apply le_trans with (2 * nat_of_P p0); auto with arith. generalize Hb Ho1; case (nat_of_P base); auto. intros tmp; Contradict tmp; auto with arith. intros base'; case base'. intros tmp; Contradict tmp; auto with arith. intros base''; case base''. replace (nat_of_P (xI p0)) with (1 + 2 * nat_of_P p0); auto with arith. intros Hb0 Ho0 H; Contradict H; rewrite Ho0. rewrite (fun x y => mult_comm x (S y)). apply Compare.not_eq_sym. apply odd_even_lem. unfold nat_of_P in |- *; simpl in |- *; (rewrite ZL6; auto). intros n Hb0 Ho0 H; rewrite H. apply le_trans with (S (S n) * nat_of_P p0 + nat_of_P p0); auto with arith. apply plus_le_compat; auto with arith. rewrite plus_comm; simpl in |- *; auto with arith. rewrite plus_comm; unfold nat_of_P in |- *; simpl in |- *; (rewrite ZL6; unfold nat_of_P in |- *; auto). generalize (lt_O_nat_of_P base); case (nat_of_P base); simpl in |- *; auto; intros tmp; inversion tmp. intros p0 Hq0 (Ho1, Ho2); (cut (nat_of_P o1' <= nat_of_P p0); [ intros Hrec | idtac ]). cut (nat_of_P o1' < nat_of_P p); [ intros Hrec1 | idtac ]. generalize (Rec _ Hrec1 _ Hrec). CaseEq (Pdivless bound o1' base p0); simpl in |- *. intros p1; case p1; simpl in |- *. intros o3; case o3; simpl in |- *; auto. intros o3' o4; case o4; simpl in |- *; auto. intros o4' n Eq1; rewrite nat_of_P_mult_morphism. intros (H'1, ((H'2, H'3), H'4)); repeat (split; auto). rewrite Ho1; rewrite H'1; ring. rewrite (fun x y => mult_comm x (nat_of_P y)); auto with arith. intros bound' H'5 H'6; case (le_or_lt (nat_of_P bound) (nat_of_P o1')); intros H'7; auto. apply (H'4 bound'); auto. rewrite Pdivless1 in Eq1; auto. discriminate. apply nat_of_P_gt_Gt_compare_complement_morphism; auto. intros n Eq1 (H'1, ((H'2, H'3), H'4)); repeat (split; auto). rewrite Ho1; rewrite H'1; ring. replace 0 with (0 * exp (nat_of_P base) n); auto with arith. intros bound' H'5 H'6; case (le_or_lt (nat_of_P bound) (nat_of_P o1')); intros H'7; auto. apply (H'4 bound'); auto. rewrite Pdivless1 in Eq1; auto. inversion Eq1. rewrite <- H0. case (le_or_lt bound' (nat_of_P o1')); intros H'8; auto. rewrite H'5; auto with arith. Contradict H'6; auto. apply lt_not_le; rewrite Ho1; auto. apply lt_le_trans with (nat_of_P o1' * nat_of_P base + 1 * nat_of_P base); auto with arith. simpl in |- *; auto with arith. rewrite <- mult_plus_distr_r. replace (nat_of_P o1' + 1) with (S (nat_of_P o1')); auto with arith. rewrite H'5; auto with arith. rewrite <- (fun x y => mult_comm (nat_of_P x) y); auto with arith. rewrite plus_comm; auto with arith. apply nat_of_P_gt_Gt_compare_complement_morphism; auto with arith. intros o4; case o4; simpl in |- *. intros o4' n Eq1; rewrite nat_of_P_mult_morphism. intros (H'1, ((H'2, H'3), H'4)); repeat (split; auto). rewrite Ho1; rewrite H'1; ring. rewrite (fun x y => mult_comm x (nat_of_P y)); auto with arith. intros bound' H H0; apply (H'4 bound'); auto. case (le_or_lt (nat_of_P bound) (nat_of_P o1')); intros H'8; auto. rewrite Pdivless1 in Eq1; auto. discriminate. apply nat_of_P_gt_Gt_compare_complement_morphism; auto. intros n Eq1 (H'1, ((H'2, H'3), H'4)); repeat (split; auto). rewrite Ho1; rewrite H'1; ring. replace 0 with (0 * exp (nat_of_P base) n); auto with arith. intros bound' H H0; Contradict H0; rewrite Ho1; rewrite H'1; simpl in |- *; auto with arith. rewrite Ho1; auto with arith. apply le_lt_trans with (nat_of_P o1' * 1 + 0); auto with arith. rewrite mult_comm; simpl in |- *; auto with arith. apply mult_S_le_reg_l with (n := pred (nat_of_P base)). replace (S (pred (nat_of_P base))) with (nat_of_P base). apply le_trans with (nat_of_P p); auto. rewrite Ho1; rewrite (fun x => plus_comm x 0); simpl in |- *; auto. rewrite (mult_comm (nat_of_P base)); simpl in |- *; auto with arith. apply le_trans with (1 := Hq0); auto with arith. replace (nat_of_P (xO p0)) with (2 * nat_of_P p0); auto with arith. unfold nat_of_P in |- *; simpl in |- *; (rewrite ZL6; auto). generalize (lt_O_nat_of_P base); case (nat_of_P base); simpl in |- *; auto; intros tmp; inversion tmp. replace (nat_of_P 1) with 1; auto with arith. intros Hq0 (H, H0); Contradict Hq0. apply lt_not_le. rewrite H. generalize (lt_O_nat_of_P o1'); case (nat_of_P o1'); simpl in |- *; auto. intros tmp; Contradict tmp; auto with arith. intros n H2; generalize Hb. case (nat_of_P base); simpl in |- *; auto. intros tmp; Contradict tmp; auto with arith. intros base'; case base'; simpl in |- *; auto with arith. intros tmp; Contradict tmp; auto with arith. intros o2; case o2; simpl in |- *; auto with arith. intros o2' (Ho1, Ho2); repeat (split; auto with arith). rewrite mult_comm; simpl in |- *; auto with arith. intros bound' H H0; Contradict Ho2. apply le_not_lt. rewrite <- Ho1. generalize H; case bound'. rewrite mult_comm; simpl in |- *; auto. intros Eq2; generalize (lt_O_nat_of_P bound); rewrite Eq2; intros tmp; Contradict tmp; auto with arith. intros n Eq2; apply le_trans with (nat_of_P bound); auto with arith. rewrite Eq2; auto with arith. rewrite mult_comm; simpl in |- *; auto with arith. intros (Ho1, Ho2); generalize (lt_O_nat_of_P p); rewrite Ho1; intros tmp; Contradict tmp; auto with arith. Qed. Definition PdivBound bound p base := Pdivless bound p base p. Theorem PdivBound_correct : forall bound p base, 1 < nat_of_P base -> nat_of_P p = oZ (fst (fst (PdivBound bound p base))) * exp (nat_of_P base) (snd (PdivBound bound p base)) + oZ (snd (fst (PdivBound bound p base))) /\ (oZ (fst (fst (PdivBound bound p base))) < nat_of_P bound /\ oZ (snd (fst (PdivBound bound p base))) < exp (nat_of_P base) (snd (PdivBound bound p base))) /\ (forall bound', nat_of_P bound = nat_of_P base * bound' -> nat_of_P bound <= nat_of_P p -> nat_of_P bound <= nat_of_P base * oZ (fst (fst (PdivBound bound p base)))). intros; unfold PdivBound in |- *; apply Pdivless_correct; auto. Qed. Theorem PdivBound_correct1 : forall bound p base, 1 < nat_of_P base -> nat_of_P p = oZ (fst (fst (PdivBound bound p base))) * exp (nat_of_P base) (snd (PdivBound bound p base)) + oZ (snd (fst (PdivBound bound p base))). intros bound p base H; generalize (PdivBound_correct bound p base); intuition. Qed. Theorem PdivBound_correct2 : forall bound p base, 1 < nat_of_P base -> oZ (fst (fst (PdivBound bound p base))) < nat_of_P bound. intros bound p base H; generalize (PdivBound_correct bound p base); intuition. Qed. Theorem PdivBound_correct3 : forall bound p base, nat_of_P p < nat_of_P bound -> PdivBound bound p base = (Some _ p, None _, 0). intros bound p base H; (unfold PdivBound in |- *; apply Pdivless1; auto). apply nat_of_P_gt_Gt_compare_complement_morphism; auto with arith. Qed. Theorem PdivBound_correct4 : forall bound p base bound', 1 < nat_of_P base -> nat_of_P bound = nat_of_P base * bound' -> nat_of_P bound <= nat_of_P p -> nat_of_P bound <= nat_of_P base * oZ (fst (fst (PdivBound bound p base))). intros bound p base bound' H H1 H2; case (PdivBound_correct bound p base); auto; intros H'1 (H'2, H'3); apply (H'3 bound'); auto with arith. Qed. Transparent Pdiv. (* Eval Compute in (PdivBound (anti_convert (9)) (times1 (anti_convert (10)) [x : ?] x (anti_convert (10))) (anti_convert (9))).*) Float8.4/RND.v0000644000423700002640000010452212032774526012667 0ustar sboldotoccataRequire Export ClosestMult. Section Round. Variable b : Fbound. Variable radix : Z. Variable p : nat. Coercion Local FtoRradix := FtoR radix. Hypothesis radixMoreThanOne : (1 < radix)%Z. Hypothesis pGreaterThanOne : 1 < p. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix p. (** Various lemmas about exp, ln *) Theorem exp_ln_powerRZ : forall u v : Z, (0 < u)%Z -> exp (ln u * v) = powerRZ u v. intros u v H1. cut (forall e f : nat, (0 < e)%Z -> exp (ln e * f) = powerRZ e f). intros H2. case (Zle_or_lt 0 v); intros H3. replace u with (Z_of_nat (Zabs_nat u)); [ idtac | apply inj_abs; auto with zarith ]. replace v with (Z_of_nat (Zabs_nat v)); [ idtac | apply inj_abs; auto ]. repeat rewrite <- INR_IZR_INZ; apply H2. rewrite inj_abs; auto with zarith. replace v with (- Zabs_nat v)%Z. rewrite <- Rinv_powerRZ; auto with zarith real. replace u with (Z_of_nat (Zabs_nat u)); [ idtac | apply inj_abs; auto with zarith ]. rewrite Ropp_Ropp_IZR; rewrite Ropp_mult_distr_r_reverse; rewrite exp_Ropp; repeat rewrite <- INR_IZR_INZ. rewrite H2; auto with real. rewrite inj_abs; auto with zarith. rewrite <- Zabs_absolu; rewrite <- Zabs_Zopp. rewrite Zabs_eq; auto with zarith. intros e f H2. induction f as [| f Hrecf]. simpl in |- *; ring_simplify (ln e * 0)%R; apply exp_0. replace (ln e * S f)%R with (ln e * f + ln e)%R. rewrite exp_plus; rewrite Hrecf; rewrite exp_ln; auto with real zarith. replace (Z_of_nat (S f)) with (f + 1)%Z. rewrite powerRZ_add; auto with real zarith. rewrite inj_S; auto with zarith. replace (INR (S f)) with (f + 1)%R; [ ring | idtac ]. apply trans_eq with (IZR (f + 1)). rewrite plus_IZR; simpl in |- *; rewrite <- INR_IZR_INZ; auto with real. apply trans_eq with (IZR (Zsucc f)); auto with zarith real. rewrite <- inj_S; rewrite <- INR_IZR_INZ; auto with zarith real. Qed. Theorem ln_radix_pos : (0 < ln radix)%R. rewrite <- ln_1. apply ln_increasing; auto with real zarith. Qed. Theorem exp_le_inv : forall x y : R, (exp x <= exp y)%R -> (x <= y)%R. intros x y H; case H; intros H2. left; apply exp_lt_inv; auto. right; apply exp_inv; auto. Qed. Theorem exp_monotone : forall x y : R, (x <= y)%R -> (exp x <= exp y)%R. intros x y H; case H; intros H2. left; apply exp_increasing; auto. right; auto with real. Qed. Theorem firstNormalPos_eq : FtoRradix (firstNormalPos radix b p) = powerRZ radix (Zpred p + - dExp b). unfold firstNormalPos, nNormMin, FtoRradix, FtoR in |- *; simpl in |- *. rewrite Zpower_nat_Z_powerRZ; rewrite powerRZ_add; auto with real zarith. replace (Z_of_nat (pred p)) with (Zpred p); [ ring | rewrite inj_pred; auto with zarith ]. Qed. (** Results about the ineger rounding down *) Definition IRNDD (r : R) := Zpred (up r). Theorem IRNDD_correct1 : forall r : R, (IRNDD r <= r)%R. intros r; unfold IRNDD in |- *. generalize (archimed r); intros T; elim T; intros H1 H2; clear T. unfold Zpred in |- *; apply Rplus_le_reg_l with (1 + - r)%R. ring_simplify (1 + - r + r)%R. apply Rle_trans with (2 := H2). rewrite plus_IZR; right; simpl in |- *; ring. Qed. Theorem IRNDD_correct2 : forall r : R, (r < Zsucc (IRNDD r))%R. intros r; unfold IRNDD in |- *. generalize (archimed r); intros T; elim T; intros H1 H2; clear T. rewrite <- Zsucc_pred; auto. Qed. Theorem IRNDD_correct3 : forall r : R, (r - 1 < IRNDD r)%R. intros r; unfold IRNDD in |- *. generalize (archimed r); intros T; elim T; intros H1 H2; clear T. unfold Zpred, Rminus in |- *; rewrite plus_IZR; simpl in |- *; auto with real. Qed. Hint Resolve IRNDD_correct1 IRNDD_correct2 IRNDD_correct3: real. Theorem IRNDD_pos : forall r : R, (0 <= r)%R -> (0 <= IRNDD r)%R. intros r H1; unfold IRNDD in |- *. generalize (archimed r); intros T; elim T; intros H3 H2; clear T. replace 0%R with (IZR 0); auto with real; apply IZR_le. apply Zle_Zpred. apply lt_IZR; apply Rle_lt_trans with r; auto with real zarith. Qed. Theorem IRNDD_monotone : forall r s : R, (r <= s)%R -> (IRNDD r <= IRNDD s)%R. intros r s H. apply Rle_IZR; apply Zgt_succ_le; apply Zlt_gt; apply lt_IZR. apply Rle_lt_trans with r; auto with real. apply Rle_lt_trans with s; auto with real. Qed. Theorem IRNDD_eq : forall (r : R) (z : Z), (z <= r)%R -> (r < Zsucc z)%R -> IRNDD r = z. intros r z H1 H2. cut (IRNDD r - z < 1)%Z; [ intros H3 | apply lt_IZR; rewrite <- Z_R_minus; simpl in |- * ]. cut (z - IRNDD r < 1)%Z; [ intros H4; auto with zarith | apply lt_IZR; rewrite <- Z_R_minus; simpl in |- * ]. unfold Rminus in |- *; apply Rle_lt_trans with (r + - IRNDD r)%R; auto with real. apply Rlt_le_trans with (r + - (r - 1))%R; auto with real; right; ring. unfold Rminus in |- *; apply Rle_lt_trans with (r + - z)%R; auto with real. apply Rlt_le_trans with (Zsucc z + - z)%R; auto with real; right; unfold Zsucc in |- *; rewrite plus_IZR; simpl in |- *; ring. Qed. Theorem IRNDD_projector : forall z : Z, IRNDD z = z. intros z. apply IRNDD_eq; auto with zarith real. Qed. (** Rounding down of a positive real *) Definition RND_Min_Pos (r : R) := match Rle_dec (firstNormalPos radix b p) r with | left _ => let e := IRNDD (ln r / ln radix + (- Zpred p)%Z) in Float (IRNDD (r * powerRZ radix (- e))) e | right _ => Float (IRNDD (r * powerRZ radix (dExp b))) (- dExp b) end. Theorem RND_Min_Pos_bounded_aux : forall (r : R) (e : Z), (0 <= r)%R -> (- dExp b <= e)%Z -> (r < powerRZ radix (e + p))%R -> Fbounded b (Float (IRNDD (r * powerRZ radix (- e))) e). intros r e H1 H2 H3. split; auto. simpl in |- *; rewrite pGivesBound; apply lt_IZR. rewrite Zpower_nat_Z_powerRZ; rewrite <- Faux.Rabsolu_Zabs. rewrite Rabs_right; [ idtac | apply Rle_ge; apply IRNDD_pos; apply Rmult_le_pos; auto with real zarith ]. apply Rle_lt_trans with (1 := IRNDD_correct1 (r * powerRZ radix (- e))). apply Rmult_lt_reg_l with (powerRZ radix e); auto with zarith real. rewrite Rmult_comm; rewrite Rmult_assoc. rewrite <- powerRZ_add; auto with zarith real. rewrite <- powerRZ_add; auto with zarith real. apply Rle_lt_trans with (2 := H3); ring_simplify (- e + e)%Z; simpl in |- *; right; ring. Qed. Theorem RND_Min_Pos_canonic : forall r : R, (0 <= r)%R -> Fcanonic radix b (RND_Min_Pos r). intros r H1; unfold RND_Min_Pos in |- *. generalize ln_radix_pos; intros W. case (Rle_dec (firstNormalPos radix b p) r); intros H2. cut (0 < r)%R; [ intros V | idtac ]. 2: apply Rlt_le_trans with (2 := H2); rewrite firstNormalPos_eq; auto with real zarith. left; split. apply RND_Min_Pos_bounded_aux; auto. apply Zgt_succ_le; apply Zlt_gt. apply lt_IZR. apply Rle_lt_trans with (2 := IRNDD_correct2 (ln r / ln radix + (- Zpred p)%Z)). apply Rplus_le_reg_l with (Zpred p). apply Rmult_le_reg_l with (ln radix). apply ln_radix_pos. apply Rle_trans with (ln r). apply exp_le_inv. rewrite exp_ln; auto. replace (Zpred p + (- dExp b)%Z)%R with (IZR (Zpred p + - dExp b)). rewrite exp_ln_powerRZ; auto with zarith. apply Rle_trans with (2 := H2). rewrite firstNormalPos_eq; auto with real. rewrite plus_IZR; rewrite Ropp_Ropp_IZR; ring. rewrite Ropp_Ropp_IZR; right; field; auto with real. rewrite <- exp_ln_powerRZ; auto with zarith. pattern r at 1 in |- *; rewrite <- (exp_ln r); auto. apply exp_increasing. rewrite plus_IZR. apply Rle_lt_trans with (ln radix * (ln r / ln radix + (- Zpred p)%Z - 1 + p))%R. rewrite Ropp_Ropp_IZR; unfold Zpred in |- *; rewrite plus_IZR; simpl in |- *. repeat rewrite <- INR_IZR_INZ; right; field; auto with real. apply Rmult_lt_compat_l; auto with real. repeat rewrite <- INR_IZR_INZ. apply Rplus_lt_compat_r; auto with real. simpl in |- *; rewrite pGivesBound; apply le_IZR; simpl in |- *. rewrite Zpower_nat_Z_powerRZ; rewrite Zabs_eq. 2: apply le_IZR; rewrite Rmult_IZR; simpl in |- *. 2: apply Rmult_le_pos; auto with real zarith; apply IRNDD_pos; apply Rmult_le_pos; auto with real zarith. rewrite Rmult_IZR; pattern (Z_of_nat p) at 1 in |- *; replace (Z_of_nat p) with (1 + Zpred p)%Z. 2: unfold Zpred in |- *; ring. rewrite powerRZ_add; auto with zarith real; simpl in |- *; ring_simplify (radix * 1)%R. apply Rmult_le_compat_l; auto with zarith real. rewrite <- inj_pred; auto with zarith. rewrite <- Zpower_nat_Z_powerRZ; apply IZR_le. apply Zgt_succ_le; apply Zlt_gt; apply lt_IZR; rewrite Ropp_Ropp_IZR. apply Rle_lt_trans with (r * powerRZ radix (- IRNDD (ln r / ln radix + - pred p)))%R. 2: repeat rewrite <- INR_IZR_INZ; apply IRNDD_correct2. rewrite <- exp_ln_powerRZ; auto with zarith. rewrite Zpower_nat_Z_powerRZ; rewrite Ropp_Ropp_IZR. apply Rle_trans with (r * exp (ln radix * - (ln r / ln radix + - pred p)))%R. pattern r at 1 in |- *; rewrite <- (exp_ln r); auto; rewrite <- exp_plus. replace (ln r + ln radix * - (ln r / ln radix + - pred p))%R with (ln radix * pred p)%R. 2: field; auto with real. rewrite INR_IZR_INZ; rewrite exp_ln_powerRZ; auto with real zarith. apply Rmult_le_compat_l; auto with real. apply exp_monotone; auto with real. cut (r < powerRZ radix (Zpred p + - dExp b))%R; [ intros H3 | idtac ]. 2: rewrite <- firstNormalPos_eq; auto with real. right; split. pattern (dExp b) at 2 in |- *; replace (Z_of_N (dExp b)) with (- - dExp b)%Z; auto with zarith. apply RND_Min_Pos_bounded_aux; auto with zarith. apply Rlt_trans with (1 := H3); apply Rlt_powerRZ; auto with real zarith. split; [ simpl in |- *; auto | idtac ]. simpl in |- *; rewrite pGivesBound; apply lt_IZR. rewrite Zpower_nat_Z_powerRZ; rewrite <- Faux.Rabsolu_Zabs. rewrite mult_IZR; rewrite Rabs_right; [ idtac | apply Rle_ge; apply Rmult_le_pos; auto with real zarith; apply IRNDD_pos; apply Rmult_le_pos; auto with real zarith ]. apply Rle_lt_trans with (radix * (r * powerRZ radix (dExp b)))%R; auto with real zarith. apply Rlt_le_trans with (radix * (powerRZ radix (Zpred p + - dExp b) * powerRZ radix (dExp b)))%R; auto with real zarith. rewrite <- powerRZ_add; auto with zarith real. pattern (IZR radix) at 1 in |- *; replace (IZR radix) with (powerRZ radix 1); [ rewrite <- powerRZ_add | simpl in |- * ]; auto with zarith real; unfold Zpred in |- *. ring_simplify (1 + (p + -1 + - dExp b + dExp b))%Z; auto with real. Qed. Theorem RND_Min_Pos_Rle : forall r : R, (0 <= r)%R -> (RND_Min_Pos r <= r)%R. intros r H. unfold RND_Min_Pos in |- *; case (Rle_dec (firstNormalPos radix b p) r); intros H2. unfold FtoRradix, FtoR in |- *; simpl in |- *. apply Rle_trans with (r * powerRZ radix (- IRNDD (ln r / ln radix + (- Zpred p)%Z)) * powerRZ radix (IRNDD (ln r / ln radix + (- Zpred p)%Z)))%R; auto with real. rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with real zarith. ring_simplify (- IRNDD (ln r / ln radix + (- Zpred p)%Z) + IRNDD (ln r / ln radix + (- Zpred p)%Z))%Z; simpl in |- *; auto with real. unfold FtoRradix, FtoR in |- *; simpl in |- *. apply Rle_trans with (r * powerRZ radix (dExp b) * powerRZ radix (- dExp b))%R; auto with real. rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with real zarith. ring_simplify (dExp b + - dExp b)%Z; simpl in |- *; auto with real. Qed. Theorem RND_Min_Pos_monotone : forall r s : R, (0 <= r)%R -> (r <= s)%R -> (RND_Min_Pos r <= RND_Min_Pos s)%R. intros r s V1 H. cut (0 <= s)%R; [ intros V2 | apply Rle_trans with (1 := V1); auto with real ]. rewrite <- FPredSuc with (x := RND_Min_Pos s) (precision := p) (b := b) (radix := radix); auto with arith. 2: apply RND_Min_Pos_canonic; auto. unfold FtoRradix in |- *; apply FPredProp; auto with arith; fold FtoRradix in |- *. apply RND_Min_Pos_canonic; auto. apply FSuccCanonic; auto with arith; apply RND_Min_Pos_canonic; auto. apply Rle_lt_trans with r; auto with real. apply RND_Min_Pos_Rle; auto. apply Rle_lt_trans with (1 := H). replace (FtoRradix (FSucc b radix p (RND_Min_Pos s))) with (RND_Min_Pos s + powerRZ radix (Fexp (RND_Min_Pos s)))%R. unfold RND_Min_Pos in |- *; case (Rle_dec (firstNormalPos radix b p) s); intros H1. unfold FtoRradix, FtoR in |- *; simpl in |- *. apply Rle_lt_trans with ((s * powerRZ radix (- IRNDD (ln s / ln radix + (- Zpred p)%Z)) - 1) * powerRZ radix (IRNDD (ln s / ln radix + (- Zpred p)%Z)) + powerRZ radix (IRNDD (ln s / ln radix + (- Zpred p)%Z)))%R; auto with real. right; ring_simplify. rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with zarith real. ring_simplify (-IRNDD (ln s / ln radix + (- Zpred p)%Z) + IRNDD (ln s / ln radix + (- Zpred p)%Z))%Z; simpl; ring. unfold FtoRradix, FtoR in |- *; simpl in |- *. apply Rle_lt_trans with ((s * powerRZ radix (dExp b) - 1) * powerRZ radix (- dExp b) + powerRZ radix (- dExp b))%R; auto with real. right; ring_simplify. rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with zarith real. ring_simplify (dExp b + -dExp b)%Z; simpl in |- *; ring. replace (powerRZ radix (Fexp (RND_Min_Pos s))) with (FtoR radix (Float 1%nat (Fexp (RND_Min_Pos s)))); [ idtac | unfold FtoR in |- *; simpl in |- *; ring ]. rewrite <- FSuccDiff1 with b radix p (RND_Min_Pos s); auto with arith. rewrite Fminus_correct; auto with zarith; fold FtoRradix in |- *; ring. cut (- nNormMin radix p < Fnum (RND_Min_Pos s))%Z; auto with zarith. apply Zlt_le_trans with 0%Z. replace 0%Z with (- (0))%Z; unfold nNormMin in |- *; auto with arith zarith. apply le_IZR; unfold RND_Min_Pos in |- *; case (Rle_dec (firstNormalPos radix b p) s); intros H1; simpl in |- *; apply IRNDD_pos; apply Rmult_le_pos; auto with real zarith. Qed. Theorem RND_Min_Pos_projector : forall f : float, (0 <= f)%R -> Fcanonic radix b f -> FtoRradix (RND_Min_Pos f) = f. intros f H1 H2. unfold RND_Min_Pos in |- *; case (Rle_dec (firstNormalPos radix b p) f); intros H3. replace (IRNDD (ln f / ln radix + (- Zpred p)%Z)) with (Fexp f). replace (f * powerRZ radix (- Fexp f))%R with (IZR (Fnum f)). rewrite IRNDD_projector; unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. unfold FtoRradix, FtoR in |- *; simpl in |- *. rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with real zarith. ring_simplify (Fexp f + - Fexp f)%Z; simpl in |- *; ring. generalize ln_radix_pos; intros V1. cut (0 < Fnum f)%R; [ intros V2 | idtac ]. apply sym_eq; apply IRNDD_eq. unfold FtoRradix, FtoR in |- *; simpl in |- *. rewrite ln_mult; auto with real zarith. unfold Rdiv in |- *; rewrite Rmult_plus_distr_r. apply Rle_trans with (Zpred p + Fexp f + (- Zpred p)%Z)%R; [ rewrite Ropp_Ropp_IZR; right; ring | idtac ]. apply Rplus_le_compat_r; apply Rplus_le_compat. apply Rmult_le_reg_l with (ln radix); [ auto with real | idtac ]. apply Rle_trans with (ln (Fnum f)); [ idtac | right; field; auto with real ]. apply exp_le_inv. rewrite exp_ln; auto. rewrite exp_ln_powerRZ; auto with zarith. case H2; intros T; elim T; intros C1 C2. apply Rmult_le_reg_l with radix; auto with real zarith. apply Rle_trans with (IZR (Zpos (vNum b))); [ right; rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ | idtac ]. pattern (Z_of_nat p) at 2 in |- *; replace (Z_of_nat p) with (1 + Zpred p)%Z; [ rewrite powerRZ_add; auto with real zarith; simpl in |- *; ring | unfold Zpred in |- *; ring ]. rewrite <- (Rabs_right (radix * Fnum f)); auto with real zarith. rewrite <- mult_IZR; rewrite Faux.Rabsolu_Zabs; auto with real zarith. apply Rle_ge; apply Rmult_le_pos; auto with real zarith. Contradict H3; apply Rlt_not_le; unfold FtoRradix in |- *; apply FsubnormalLtFirstNormalPos; auto with zarith. apply Rmult_le_reg_l with (ln radix); [ auto with real | idtac ]. apply Rle_trans with (ln (powerRZ radix (Fexp f))); [ idtac | right; field; auto with real ]. rewrite <- exp_ln_powerRZ; auto with zarith. rewrite ln_exp; auto with real. unfold FtoRradix, FtoR in |- *; simpl in |- *. rewrite ln_mult; auto with real zarith. rewrite <- exp_ln_powerRZ; auto with zarith. rewrite ln_exp; auto with real. unfold Rdiv in |- *; rewrite Rmult_plus_distr_r. apply Rlt_le_trans with (p + Fexp f + (- Zpred p)%Z)%R. 2: rewrite Ropp_Ropp_IZR; unfold Zsucc, Zpred in |- *; repeat rewrite plus_IZR; repeat rewrite <- INR_IZR_INZ; simpl in |- *; right; ring. replace (ln radix * Fexp f * / ln radix)%R with (IZR (Fexp f)); [ idtac | field; auto with real ]. apply Rplus_lt_compat_r; apply Rplus_lt_compat_r. apply Rmult_lt_reg_l with (ln radix); [ auto with real | idtac ]. apply Rle_lt_trans with (ln (Fnum f)); [ right; field; auto with real | idtac ]. apply exp_lt_inv. rewrite exp_ln; auto. rewrite INR_IZR_INZ; rewrite exp_ln_powerRZ; auto with zarith. apply Rlt_le_trans with (IZR (Zpos (vNum b))). rewrite <- (Rabs_right (IZR (Fnum f))); auto with real. rewrite Faux.Rabsolu_Zabs; apply Rlt_IZR; cut (Fbounded b f); auto with real zarith float. apply FcanonicBound with radix; auto. apply Rle_ge; auto with real. right; rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; auto with real zarith. replace 0%R with (IZR 0); auto with real zarith; apply Rlt_IZR. apply LtR0Fnum with radix; auto with zarith; fold FtoRradix in |- *. apply Rlt_le_trans with (2 := H3); rewrite firstNormalPos_eq; auto with real zarith. case H2; intros T; elim T; intros C1 C2. absurd (firstNormalPos radix b p <= f)%R; auto with real. unfold FtoRradix in |- *; apply FnormalLtFirstNormalPos; auto with arith. elim C2; intros C3 C4. replace (f * powerRZ radix (dExp b))%R with (IZR (Fnum f)). rewrite IRNDD_projector; rewrite <- C3; unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. unfold FtoRradix, FtoR in |- *; rewrite C3. rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with real zarith. ring_simplify (- dExp b + dExp b)%Z; simpl in |- *; ring. Qed. Theorem RND_Min_Pos_correct : forall r : R, (0 <= r)%R -> isMin b radix r (RND_Min_Pos r). intros r H1. split. apply FcanonicBound with radix; apply RND_Min_Pos_canonic; auto. split. apply RND_Min_Pos_Rle; auto. fold FtoRradix in |- *; intros f H2 H3. case (Rle_or_lt 0 f); intros H4. unfold FtoRradix in |- *; rewrite <- FnormalizeCorrect with radix b p f; auto; fold FtoRradix in |- *. rewrite <- RND_Min_Pos_projector. apply RND_Min_Pos_monotone; unfold FtoRradix in |- *; rewrite FnormalizeCorrect; auto. unfold FtoRradix in |- *; rewrite FnormalizeCorrect; auto. apply FnormalizeCanonic; auto with arith. apply Rle_trans with 0%R; auto with real. unfold RND_Min_Pos in |- *; case (Rle_dec (firstNormalPos radix b p) r); intros H5; unfold FtoRradix, FtoR in |- *; simpl in |- *; apply Rmult_le_pos; auto with real zarith; apply IRNDD_pos; apply Rmult_le_pos; auto with real zarith. Qed. (** Easily deduced, the rounding up of a positive real *) Definition RND_Max_Pos (r : R) := match Req_EM_T r (RND_Min_Pos r) with | left _ => RND_Min_Pos r | right _ => FSucc b radix p (RND_Min_Pos r) end. Theorem RND_Max_Pos_canonic : forall r : R, (0 <= r)%R -> Fcanonic radix b (RND_Max_Pos r). intros r H; unfold RND_Max_Pos in |- *. case (Req_EM_T r (RND_Min_Pos r)); intros H1. apply RND_Min_Pos_canonic; auto. apply FSuccCanonic; auto with arith; apply RND_Min_Pos_canonic; auto. Qed. Theorem RND_Max_Pos_Rle : forall r : R, (0 <= r)%R -> (r <= RND_Max_Pos r)%R. intros r H. unfold RND_Max_Pos in |- *; case (Req_EM_T r (RND_Min_Pos r)); intros H1. rewrite <- H1; auto with real. case (Rle_or_lt r (FSucc b radix p (RND_Min_Pos r))); auto; intros H2. generalize (RND_Min_Pos_correct r H); intros T; elim T; intros H3 T1; elim T1; intros H4 H5; clear T T1. absurd (FSucc b radix p (RND_Min_Pos r) <= RND_Min_Pos r)%R; auto with float zarith real. apply Rlt_not_le; auto with float zarith. unfold FtoRradix in |- *; apply FSuccLt; auto with arith. Qed. Theorem RND_Max_Pos_correct : forall r : R, (0 <= r)%R -> isMax b radix r (RND_Max_Pos r). intros r H. split. apply FcanonicBound with radix; apply RND_Max_Pos_canonic; auto. split. apply RND_Max_Pos_Rle; auto. unfold RND_Max_Pos in |- *; case (Req_EM_T r (RND_Min_Pos r)); intros H1. fold FtoRradix in |- *; intros f H2 H3; rewrite <- H1; auto with real. fold FtoRradix in |- *; intros f H2 H3. case H3; intros V. case (Rle_or_lt (FSucc b radix p (RND_Min_Pos r)) f); auto; intros H4. absurd (f < f)%R; auto with real. apply Rle_lt_trans with (RND_Min_Pos r). rewrite <- FPredSuc with b radix p (RND_Min_Pos r); auto with arith. 2: apply RND_Min_Pos_canonic; auto. unfold FtoRradix in |- *; rewrite <- FnormalizeCorrect with radix b p f; auto. apply FPredProp; auto with arith float zarith. apply FSuccCanonic; auto with arith; apply RND_Min_Pos_canonic; auto. rewrite FnormalizeCorrect; auto with real. apply Rle_lt_trans with (2 := V). apply RND_Min_Pos_Rle; auto. Contradict H1. rewrite V; unfold FtoRradix in |- *; rewrite <- FnormalizeCorrect with radix b p f; auto. fold FtoRradix in |- *; apply sym_eq; apply RND_Min_Pos_projector; auto with zarith float. unfold FtoRradix in |- *; rewrite FnormalizeCorrect; fold FtoRradix in |- *; auto with real. apply Rle_trans with r; auto with real. Qed. (** Roundings up and down of any real *) Definition RND_Min (r : R) := match Rle_dec 0 r with | left _ => RND_Min_Pos r | right _ => Fopp (RND_Max_Pos (- r)) end. Theorem RND_Min_canonic : forall r : R, Fcanonic radix b (RND_Min r). intros r. unfold RND_Min in |- *; case (Rle_dec 0 r); intros H. apply RND_Min_Pos_canonic; auto. apply FcanonicFopp; apply RND_Max_Pos_canonic; auto with real. Qed. Theorem RND_Min_correct : forall r : R, isMin b radix r (RND_Min r). intros r. unfold RND_Min in |- *; case (Rle_dec 0 r); intros H. apply RND_Min_Pos_correct; auto. pattern r at 1 in |- *; rewrite <- (Ropp_involutive r). apply MaxOppMin; apply RND_Max_Pos_correct; auto with real. Qed. Definition RND_Max (r : R) := match Rle_dec 0 r with | left _ => RND_Max_Pos r | right _ => Fopp (RND_Min_Pos (- r)) end. Theorem RND_Max_canonic : forall r : R, Fcanonic radix b (RND_Max r). intros r. unfold RND_Max in |- *; case (Rle_dec 0 r); intros H. apply RND_Max_Pos_canonic; auto. apply FcanonicFopp; apply RND_Min_Pos_canonic; auto with real. Qed. Theorem RND_Max_correct : forall r : R, isMax b radix r (RND_Max r). intros r. unfold RND_Max in |- *; case (Rle_dec 0 r); intros H. apply RND_Max_Pos_correct; auto. pattern r at 1 in |- *; rewrite <- (Ropp_involutive r). apply MinOppMax; apply RND_Min_Pos_correct; auto with real. Qed. Definition RND_Zero (r : R) := match Rle_dec 0 r with | left _ => RND_Min r | right _ => RND_Max r end. Theorem RND_Zero_canonic : forall r : R, Fcanonic radix b (RND_Zero r). intros r. unfold RND_Zero in |- *; case (Rle_dec 0 r); intros H. apply RND_Min_canonic; auto. apply RND_Max_canonic; auto. Qed. Theorem RND_Zero_correct : forall r : R, ToZeroP b radix r (RND_Zero r). intros r. unfold ToZeroP, RND_Zero. case (Rle_dec 0 r); intros H. left; split; auto with real; apply RND_Min_correct; auto with real. right; split; auto with real;apply RND_Max_correct; auto with real. Qed. (** Rounding to the nearest of any real First, ClosestUp (when equality, the biggest is returned) Then, EvenClosest (when equality, the even is returned) *) Definition RND_ClosestUp (r : R) := match Rle_dec (Rabs (RND_Max r - r)) (Rabs (RND_Min r - r)) with | left _ => RND_Max r | right _ => RND_Min r end. Theorem RND_ClosestUp_canonic : forall r : R, Fcanonic radix b (RND_ClosestUp r). intros r. unfold RND_ClosestUp in |- *; case (Rle_dec (Rabs (RND_Max r - r)) (Rabs (RND_Min r - r))); intros H; [ apply RND_Max_canonic | apply RND_Min_canonic ]. Qed. Theorem RND_ClosestUp_correct : forall r : R, Closest b radix r (RND_ClosestUp r). intros r. cut (RND_Min r <= r)%R; [ intros V1 | idtac ]. 2: generalize (RND_Min_correct r); intros T; elim T; intros T1 T2; elim T2; intros T3 T4; auto with real. cut (r <= RND_Max r)%R; [ intros V2 | idtac ]. 2: generalize (RND_Max_correct r); intros T; elim T; intros T1 T2; elim T2; intros T3 T4; auto with real. cut (forall v w : R, (v <= w)%R -> (0 <= w - v)%R); [ intros V3 | idtac ]. 2: intros v w H; apply Rplus_le_reg_l with v; ring_simplify (v + (w - v))%R; ring_simplify (v + 0)%R; auto with real. cut (forall v w : R, (v <= w)%R -> (v - w <= 0)%R); [ intros V4 | idtac ]. 2: intros v w H; apply Rplus_le_reg_l with w; ring_simplify; auto with real. unfold RND_ClosestUp in |- *; case (Rle_dec (Rabs (RND_Max r - r)) (Rabs (RND_Min r - r))); intros H; split; [ apply FcanonicBound with radix; apply RND_Max_canonic | intros f H1; fold FtoRradix in |- * | apply FcanonicBound with radix; apply RND_Min_canonic | intros f H1; fold FtoRradix in |- * ]. rewrite Rabs_right in H; [ idtac | apply Rle_ge; apply V3; auto with real ]. rewrite Faux.Rabsolu_left1 in H; [ idtac | apply V4; auto with real ]. rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ]. case (Rle_or_lt f r); intros H2. rewrite Faux.Rabsolu_left1; [ idtac | apply V4; auto with real ]. apply Rle_trans with (1 := H); apply Ropp_le_contravar; unfold Rminus in |- *; apply Rplus_le_compat_r. generalize (RND_Min_correct r); intros T; elim T; intros T1 T2; elim T2; intros T3 T4; auto with real. rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ]. unfold Rminus in |- *; apply Rplus_le_compat_r. generalize (RND_Max_correct r); intros T; elim T; intros T1 T2; elim T2; intros T3 T4; auto with real. cut (Rabs (RND_Min r - r) < Rabs (RND_Max r - r))%R; auto with real; intros H'. rewrite Faux.Rabsolu_left1 in H'; [ idtac | apply V4; auto with real ]. rewrite Rabs_right in H'; [ idtac | apply Rle_ge; apply V3; auto with real ]. rewrite Faux.Rabsolu_left1; [ idtac | apply V4; auto with real ]. case (Rle_or_lt f r); intros H2. rewrite Faux.Rabsolu_left1; [ idtac | apply V4; auto with real ]. apply Ropp_le_contravar; unfold Rminus in |- *; apply Rplus_le_compat_r. generalize (RND_Min_correct r); intros T; elim T; intros T1 T2; elim T2; intros T3 T4; auto with real. rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ]. apply Rle_trans with (RND_Max r - r)%R; auto with real; unfold Rminus in |- *; apply Rplus_le_compat_r. generalize (RND_Max_correct r); intros T; elim T; intros T1 T2; elim T2; intros T3 T4; auto with real. Qed. Definition RND_EvenClosest (r : R) := match Rle_dec (Rabs (RND_Max r - r)) (Rabs (RND_Min r - r)) with | left H => match Rle_lt_or_eq_dec (Rabs (RND_Max r - r)) (Rabs (RND_Min r - r)) H with | left _ => RND_Max r | right _ => match OddEvenDec (Fnum (RND_Min r)) with | left _ => RND_Max r | right _ => RND_Min r end end | right _ => RND_Min r end. Theorem RND_EvenClosest_canonic : forall r : R, Fcanonic radix b (RND_EvenClosest r). intros r; unfold RND_EvenClosest in |- *. case (Rle_dec (Rabs (RND_Max r - r)) (Rabs (RND_Min r - r))); intros H1. case (Rle_lt_or_eq_dec (Rabs (RND_Max r - r)) (Rabs (RND_Min r - r)) H1); intros H2. apply RND_Max_canonic. case (OddEvenDec (Fnum (RND_Min r))); intros H3. apply RND_Max_canonic. apply RND_Min_canonic. apply RND_Min_canonic. Qed. Theorem RND_EvenClosest_correct : forall r : R, EvenClosest b radix p r (RND_EvenClosest r). intros r. cut (RND_Min r <= r)%R; [ intros V1 | idtac ]. 2: generalize (RND_Min_correct r); intros T; elim T; intros T1 T2; elim T2; intros T3 T4; auto with real. cut (r <= RND_Max r)%R; [ intros V2 | idtac ]. 2: generalize (RND_Max_correct r); intros T; elim T; intros T1 T2; elim T2; intros T3 T4; auto with real. cut (forall v w : R, (v <= w)%R -> (0 <= w - v)%R); [ intros V3 | idtac ]. 2: intros v w H; apply Rplus_le_reg_l with v; ring_simplify; auto with real. cut (forall v w : R, (v <= w)%R -> (v - w <= 0)%R); [ intros V4 | idtac ]. 2: intros v w H; apply Rplus_le_reg_l with w; ring_simplify; auto with real. unfold RND_EvenClosest in |- *; case (Rle_dec (Rabs (RND_Max r - r)) (Rabs (RND_Min r - r))); intros H1. case (Rle_lt_or_eq_dec (Rabs (RND_Max r - r)) (Rabs (RND_Min r - r)) H1); intros H2. split. split. apply FcanonicBound with radix; apply RND_Max_canonic. intros f H3; fold FtoRradix in |- *. rewrite Rabs_right in H1; [ idtac | apply Rle_ge; apply V3; auto with real ]. rewrite Faux.Rabsolu_left1 in H1; [ idtac | apply V4; auto with real ]. rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ]. case (Rle_or_lt f r); intros H4. rewrite Faux.Rabsolu_left1; [ idtac | apply V4; auto with real ]. apply Rle_trans with (1 := H1); apply Ropp_le_contravar; unfold Rminus in |- *; apply Rplus_le_compat_r. generalize (RND_Min_correct r); intros T; elim T; intros T1 T2; elim T2; intros T3 T4; auto with real. rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ]. unfold Rminus in |- *; apply Rplus_le_compat_r. generalize (RND_Max_correct r); intros T; elim T; intros T1 T2; elim T2; intros T3 T4; auto with real. right; intros q H3. generalize (ClosestMinOrMax b radix); unfold MinOrMaxP in |- *; intros T. case (T r q); auto; intros H4; clear T. Contradict H2; apply Rle_not_lt. replace (FtoRradix (RND_Min r)) with (FtoRradix q). elim H3; intros T1 T2; unfold FtoRradix in |- *; apply T2. apply FcanonicBound with radix; apply RND_Max_canonic. generalize (MinUniqueP b radix); unfold UniqueP in |- *; intros T; apply T with r; auto. apply RND_Min_correct. generalize (MaxUniqueP b radix); unfold UniqueP in |- *; intros T; apply T with r; auto. apply RND_Max_correct. case (OddEvenDec (Fnum (RND_Min r))); intros H3. split. split. apply FcanonicBound with radix; apply RND_Max_canonic. intros f H4; fold FtoRradix in |- *. rewrite Rabs_right in H1; [ idtac | apply Rle_ge; apply V3; auto with real ]. rewrite Faux.Rabsolu_left1 in H1; [ idtac | apply V4; auto with real ]. rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ]. case (Rle_or_lt f r); intros H5. rewrite Faux.Rabsolu_left1; [ idtac | apply V4; auto with real ]. apply Rle_trans with (1 := H1); apply Ropp_le_contravar; unfold Rminus in |- *; apply Rplus_le_compat_r. generalize (RND_Min_correct r); intros T; elim T; intros T1 T2; elim T2; intros T3 T4; auto with real. rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ]. unfold Rminus in |- *; apply Rplus_le_compat_r. generalize (RND_Max_correct r); intros T; elim T; intros T1 T2; elim T2; intros T3 T4; auto with real. case (Req_EM_T (RND_Max r) (RND_Min r)); intros W. right; intros q H4. generalize (ClosestMinOrMax b radix); unfold MinOrMaxP in |- *; intros T. case (T r q); auto; intros H5; clear T. fold FtoRradix in |- *; rewrite W; generalize (MinUniqueP b radix); unfold UniqueP in |- *; intros T; apply T with r; auto. apply RND_Min_correct. generalize (MaxUniqueP b radix); unfold UniqueP in |- *; intros T; apply T with r; auto. apply RND_Max_correct. left; unfold FNeven in |- *. rewrite FcanonicFnormalizeEq; auto with arith; [ idtac | apply RND_Max_canonic ]. replace (RND_Max r) with (FSucc b radix p (RND_Min r)). apply FoddSuc; auto. unfold RND_Max, RND_Min in |- *; case (Rle_dec 0 r); intros W1. unfold RND_Max_Pos in |- *. case (Req_EM_T r (RND_Min_Pos r)); intros W2; auto. Contradict W. pattern r at 1 in |- *; rewrite W2. apply sym_eq; unfold FtoRradix in |- *; apply RoundedModeProjectorIdemEq with b p (isMax b radix); auto. apply MaxRoundedModeP with p; auto. apply FcanonicBound with radix; apply RND_Min_canonic. replace (FtoR radix (RND_Min r)) with (FtoR radix (RND_Min_Pos r)); [ fold FtoRradix in |- *; rewrite <- W2; apply RND_Max_correct | idtac ]. fold FtoRradix in |- *; unfold RND_Min in |- *; auto with real. case (Rle_dec 0 r); auto with real; intros W3; Contradict W1; auto with real. unfold RND_Max_Pos in |- *. case (Req_EM_T (- r) (RND_Min_Pos (- r))); intros W2; auto. Contradict W. cut (r = FtoRradix (Fopp (RND_Min_Pos (- r)))); [ intros W3 | idtac ]. pattern r at 1 in |- *; rewrite W3. apply sym_eq; unfold FtoRradix in |- *; apply RoundedModeProjectorIdemEq with b p (isMax b radix); auto. apply MaxRoundedModeP with p; auto. apply FcanonicBound with radix; apply RND_Min_canonic. replace (FtoR radix (RND_Min r)) with (- FtoR radix (RND_Min_Pos (- r)))%R; [ fold FtoRradix in |- *; rewrite <- W3 | idtac ]. rewrite <- W2; rewrite Ropp_involutive; apply RND_Max_correct. fold FtoRradix in |- *; unfold RND_Min in |- *; auto with real. case (Rle_dec 0 r). intros W4; Contradict W1; auto with real. intros W4; unfold RND_Max_Pos in |- *; case (Req_EM_T (- r) (RND_Min_Pos (- r))); intros W5. unfold FtoRradix in |- *; rewrite Fopp_correct; ring. Contradict W2; auto with real. unfold FtoRradix in |- *; rewrite Fopp_correct; fold FtoRradix in |- *; rewrite <- W2; ring. pattern (RND_Min_Pos (- r)) at 1 in |- *; rewrite <- (Fopp_Fopp (RND_Min_Pos (- r))). rewrite <- FPredFopFSucc; auto with arith. apply FSucPred; auto with arith. apply FcanonicFopp; apply RND_Min_Pos_canonic; auto with real. split. split. apply FcanonicBound with radix; apply RND_Min_canonic. intros f H4; fold FtoRradix in |- *. rewrite Rabs_right in H1; [ idtac | apply Rle_ge; apply V3; auto with real ]. rewrite Faux.Rabsolu_left1 in H1; [ idtac | apply V4; auto with real ]. case (Rle_or_lt f r); intros H5. rewrite Faux.Rabsolu_left1; [ idtac | apply V4; auto with real ]. rewrite Faux.Rabsolu_left1; [ idtac | apply V4; auto with real ]. apply Ropp_le_contravar; unfold Rminus in |- *; apply Rplus_le_compat_r. generalize (RND_Min_correct r); intros T; elim T; intros T1 T2; elim T2; intros T3 T4; auto with real. rewrite <- H2. rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ]. rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ]. unfold Rminus in |- *; apply Rplus_le_compat_r. generalize (RND_Max_correct r); intros T; elim T; intros T1 T2; elim T2; intros T3 T4; auto with real. left; unfold FNeven in |- *. rewrite FcanonicFnormalizeEq; auto with arith; apply RND_Min_canonic. cut (Rabs (RND_Min r - r) < Rabs (RND_Max r - r))%R; auto with real; intros H'. cut (Rabs (RND_Min r - r) < Rabs (RND_Max r - r))%R; auto with real; intros H''. rewrite Faux.Rabsolu_left1 in H'; [ idtac | apply V4; auto with real ]. rewrite Rabs_right in H'; [ idtac | apply Rle_ge; apply V3; auto with real ]. split. split. apply FcanonicBound with radix; apply RND_Min_canonic. intros f W1. rewrite Faux.Rabsolu_left1; [ idtac | apply V4; auto with real ]. case (Rle_or_lt f r); intros H2. rewrite Faux.Rabsolu_left1; [ idtac | apply V4; auto with real ]. apply Ropp_le_contravar; unfold Rminus in |- *; apply Rplus_le_compat_r. generalize (RND_Min_correct r); intros T; elim T; intros T1 T2; elim T2; intros T3 T4; auto with real. rewrite Rabs_right; [ idtac | apply Rle_ge; apply V3; auto with real ]. apply Rle_trans with (RND_Max r - r)%R; auto with real; unfold Rminus in |- *; apply Rplus_le_compat_r. generalize (RND_Max_correct r); intros T; elim T; intros T1 T2; elim T2; intros T3 T4; auto with real. right; intros q H3. generalize (ClosestMinOrMax b radix); unfold MinOrMaxP in |- *; intros T. case (T r q); auto; intros H4; clear T. generalize (MinUniqueP b radix); unfold UniqueP in |- *; intros T; apply T with r; auto. apply RND_Min_correct. Contradict H''; apply Rle_not_lt. replace (FtoRradix (RND_Max r)) with (FtoRradix q). elim H3; intros T1 T2; unfold FtoRradix in |- *; apply T2. apply FcanonicBound with radix; apply RND_Min_canonic. generalize (MaxUniqueP b radix); unfold UniqueP in |- *; intros T; apply T with r; auto. apply RND_Max_correct. Qed. End Round. Float8.4/Rpow.v0000644000423700002640000002451712032774526013200 0ustar sboldotoccata(**************************************************************************** IEEE754 : Rpow Laurent Thery ***************************************************************************** Definition of an exponential function over relative numbers *) Require Export Omega. Require Export Digit. (* We have already an exponential over natural number, we prove some basic properties for this function *) Theorem pow_O : forall e : R, (e ^ 0)%R = 1%R. simpl in |- *; auto with real. Qed. Theorem pow_1 : forall e : R, (e ^ 1)%R = e. simpl in |- *; auto with real. Qed. Theorem pow_NR0 : forall (e : R) (n : nat), e <> 0%R -> (e ^ n)%R <> 0%R. intros e n; elim n; simpl in |- *; auto with real. Qed. Theorem pow_add : forall (e : R) (n m : nat), (e ^ (n + m))%R = (e ^ n * e ^ m)%R. intros e n; elim n; simpl in |- *; auto with real. intros n0 H' m; rewrite H'; auto with real. Qed. Hint Resolve pow_O pow_1 pow_NR0 pow_add: real. Theorem pow_RN_plus : forall (e : R) (n m : nat), e <> 0%R -> (e ^ n)%R = (e ^ (n + m) * / e ^ m)%R. intros e n; elim n; simpl in |- *; auto with real. intros n0 H' m H'0. rewrite Rmult_assoc; rewrite <- H'; auto. Qed. Theorem pow_lt : forall (e : R) (n : nat), (0 < e)%R -> (0 < e ^ n)%R. intros e n; elim n; simpl in |- *; auto with real. intros n0 H' H'0; replace 0%R with (e * 0)%R; auto with real. Qed. Hint Resolve pow_lt: real. Theorem Rlt_pow_R1 : forall (e : R) (n : nat), (1 < e)%R -> 0 < n -> (1 < e ^ n)%R. intros e n; elim n; simpl in |- *; auto with real. intros H' H'0; Contradict H'0; auto with arith. intros n0; case n0. simpl in |- *; rewrite Rmult_1_r; auto. intros n1 H' H'0 H'1. replace 1%R with (1 * 1)%R; auto with real. apply Rlt_trans with (r2 := (e * 1)%R); auto with real. apply Rmult_lt_compat_l; auto with real. apply Rlt_trans with (r2 := 1%R); auto with real. apply H'; auto with arith. Qed. Hint Resolve Rlt_pow_R1: real. Theorem Rlt_pow : forall (e : R) (n m : nat), (1 < e)%R -> n < m -> (e ^ n < e ^ m)%R. intros e n m H' H'0; replace m with (m - n + n). rewrite pow_add. pattern (e ^ n)%R at 1 in |- *; replace (e ^ n)%R with (1 * e ^ n)%R; auto with real. apply Rminus_lt. repeat rewrite (fun x : R => Rmult_comm x (e ^ n)); rewrite <- Rmult_minus_distr_l. replace 0%R with (e ^ n * 0)%R; auto with real. apply Rmult_lt_compat_l; auto with real. apply pow_lt; auto with real. apply Rlt_trans with (r2 := 1%R); auto with real. apply Rlt_minus; auto with real. apply Rlt_pow_R1; auto with arith. apply plus_lt_reg_l with (p := n); auto with arith. rewrite le_plus_minus_r; auto with arith; rewrite <- plus_n_O; auto. rewrite plus_comm; auto with arith. Qed. Hint Resolve Rlt_pow: real. Theorem pow_R1 : forall (r : R) (n : nat), (r ^ n)%R = 1%R -> Rabs r = 1%R \/ n = 0. intros r n H'. case (Req_dec (Rabs r) 1); auto; intros H'1. case (Rdichotomy _ _ H'1); intros H'2. generalize H'; case n; auto. intros n0 H'0. cut (r <> 0%R); [ intros Eq1 | idtac ]. 2: Contradict H'0; auto with arith. 2: simpl in |- *; rewrite H'0; rewrite Rmult_0_l; auto with real. cut (Rabs r <> 0%R); [ intros Eq2 | apply Rabs_no_R0 ]; auto. absurd (Rabs (/ r) ^ 0 < Rabs (/ r) ^ S n0)%R; auto. replace (Rabs (/ r) ^ S n0)%R with 1%R. simpl in |- *; apply Rlt_irrefl; auto. rewrite Rabs_Rinv; auto. rewrite <- Rinv_pow; auto. rewrite RPow_abs; auto. rewrite H'0; rewrite Rabs_right; auto with real. apply Rle_ge; auto with real. apply Rlt_pow; auto with arith. rewrite Rabs_Rinv; auto. apply Rmult_lt_reg_l with (r := Rabs r). case (Rabs_pos r); auto. intros H'3; case Eq2; auto. rewrite Rmult_1_r; rewrite Rinv_r; auto with real. generalize H'; case n; auto. intros n0 H'0. cut (r <> 0%R); [ intros Eq1 | auto with real ]. 2: Contradict H'0; simpl in |- *; rewrite H'0; rewrite Rmult_0_l; auto with real. cut (Rabs r <> 0%R); [ intros Eq2 | apply Rabs_no_R0 ]; auto. absurd (Rabs r ^ 0 < Rabs r ^ S n0)%R; auto with real arith. repeat rewrite RPow_abs; rewrite H'0; simpl in |- *; auto with real. Qed. Theorem Zpower_NR0 : forall (e : Z) (n : nat), (0 <= e)%Z -> (0 <= Zpower_nat e n)%Z. intros e n; elim n; unfold Zpower_nat in |- *; simpl in |- *; auto with zarith. Qed. Theorem Zpower_NR1 : forall (e : Z) (n : nat), (1 <= e)%Z -> (1 <= Zpower_nat e n)%Z. intros e n; elim n; unfold Zpower_nat in |- *; simpl in |- *; auto with zarith. Qed. Hint Resolve Zpower_NR0 Zpower_NR1: zarith. (* To define exponential over relative number, we simply do a case analysis on the sign of the number *) (*Definition powerRZ := [e : R] [n : Z] Cases n of ZERO => R1 | (POS p) => (pow e (convert p)) | (NEG p) => (Rinv (pow e (convert p))) end.*) (* we now prove some basic properties of our exponential *) Theorem powerRZ_O : forall e : R, powerRZ e 0 = 1%R. simpl in |- *; auto. Qed. Theorem powerRZ_1 : forall e : R, powerRZ e (Zsucc 0) = e. simpl in |- *; auto with real. Qed. Theorem powerRZ_NOR : forall (e : R) (z : Z), e <> 0%R -> powerRZ e z <> 0%R. intros e z; case z; simpl in |- *; auto with real. Qed. Hint Resolve powerRZ_O powerRZ_1 powerRZ_NOR powerRZ_add: real. Theorem powerRZ_Zopp : forall (e : R) (z : Z), e <> 0%R -> powerRZ e (- z) = (/ powerRZ e z)%R. intros e z H; case z; simpl in |- *; auto with real. intros p; apply sym_eq; apply Rinv_involutive. apply pow_nonzero; auto. Qed. Theorem powerRZ_Zs : forall (e : R) (n : Z), e <> 0%R -> powerRZ e (Zsucc n) = (e * powerRZ e n)%R. intros e n H'0. replace (Zsucc n) with (n + Zsucc 0)%Z. rewrite powerRZ_add; auto. rewrite powerRZ_1. rewrite Rmult_comm; auto. auto with zarith. Qed. (* Conversion theorem between relative numbers and reals *) Theorem Zpower_nat_Z_powerRZ : forall (n : Z) (m : nat), IZR (Zpower_nat n m) = powerRZ (IZR n) (Z_of_nat m). intros n m; elim m; simpl in |- *; auto with real. intros m1 H'; rewrite nat_of_P_o_P_of_succ_nat_eq_succ; simpl in |- *. replace (Zpower_nat n (S m1)) with (n * Zpower_nat n m1)%Z. rewrite Rmult_IZR; auto with real. rewrite H'; simpl in |- *. case m1; simpl in |- *; auto with real. intros m2; rewrite nat_of_P_o_P_of_succ_nat_eq_succ; auto. unfold Zpower_nat in |- *; auto. Qed. Theorem powerRZ_lt : forall (e : R) (z : Z), (0 < e)%R -> (0 < powerRZ e z)%R. intros e z; case z; simpl in |- *; auto with real. Qed. Hint Resolve powerRZ_lt: real. Theorem powerRZ_le : forall (e : R) (z : Z), (0 < e)%R -> (0 <= powerRZ e z)%R. intros e z H'; apply Rlt_le; auto with real. Qed. Hint Resolve powerRZ_le: real. Theorem Rlt_powerRZ : forall (e : R) (n m : Z), (1 < e)%R -> (n < m)%Z -> (powerRZ e n < powerRZ e m)%R. intros e n m; case n; case m; simpl in |- *; try (unfold Zlt in |- *; intros; discriminate); auto with real. intros p p0 H' H'0; apply Rlt_pow; auto with real. apply nat_of_P_lt_Lt_compare_morphism; auto. intros p H' H'0; replace 1%R with (/ 1)%R; auto with real. intros p p0 H' H'0; apply Rlt_trans with (r2 := 1%R). replace 1%R with (/ 1)%R; auto with real. apply Rlt_pow_R1; auto with real. intros p p0 H' H'0; apply Rinv_1_lt_contravar; auto with real. apply Rlt_pow; auto with real. apply nat_of_P_lt_Lt_compare_morphism; rewrite ZC4; auto. Qed. Hint Resolve Rlt_powerRZ: real. Theorem Rpow_R1 : forall (r : R) (z : Z), r <> 0%R -> powerRZ r z = 1%R -> Rabs r = 1%R \/ z = 0%Z. intros r z; case z; simpl in |- *; auto; intros p H' H'1; left. case (pow_R1 _ _ H'1); auto. intros H'0; Contradict H'0; auto with zarith; apply convert_not_O. rewrite Rinv_pow in H'1; auto. case (pow_R1 _ _ H'1); auto. intros H'0. rewrite <- H'0. apply Rmult_eq_reg_l with (r := 1%R); auto with real. pattern 1%R at 1 in |- *; rewrite <- H'0; auto with real. pattern (Rabs (/ r)) at 1 in |- *; rewrite Rabs_Rinv; try rewrite Rinv_l; auto with real. rewrite H'0; auto with real. apply Rabs_no_R0; auto. intros H'0; Contradict H'0; auto with zarith; apply convert_not_O. Qed. Theorem Rpow_eq_inv : forall (r : R) (p q : Z), r <> 0%R -> Rabs r <> 1%R -> powerRZ r p = powerRZ r q -> p = q. intros r p q H' H'0 H'1. cut (powerRZ r (p - q) = 1%R); [ intros Eq0 | idtac ]. case (Rpow_R1 _ _ H' Eq0); auto with zarith. intros H'2; case H'0; auto. apply Rmult_eq_reg_l with (r := powerRZ r q); auto with real. rewrite <- powerRZ_add; auto. replace (q + (p - q))%Z with p; auto with zarith. rewrite <- H'1; rewrite Rmult_1_r; auto with arith. Qed. Theorem Zpower_nat_powerRZ_absolu : forall n m : Z, (0 <= m)%Z -> IZR (Zpower_nat n (Zabs_nat m)) = powerRZ (IZR n) m. intros n m; case m; simpl in |- *; auto with zarith. intros p H'; elim (nat_of_P p); simpl in |- *; auto with zarith. intros n0 H'0; rewrite <- H'0; simpl in |- *; auto with zarith. rewrite <- Rmult_IZR; auto. intros p H'; Contradict H'; auto with zarith. Qed. Theorem powerRZ_R1 : forall n : Z, powerRZ 1 n = 1%R. intros n; case n; simpl in |- *; auto. intros p; elim (nat_of_P p); simpl in |- *; auto; intros n0 H'; rewrite H'; ring. intros p; elim (nat_of_P p); simpl in |- *. exact Rinv_1. intros n1 H'; rewrite Rinv_mult_distr; try rewrite Rinv_1; try rewrite H'; auto with real. Qed. Theorem Rle_powerRZ : forall (e : R) (n m : Z), (1 <= e)%R -> (n <= m)%Z -> (powerRZ e n <= powerRZ e m)%R. intros e n m H' H'0. case H'; intros E1. case (Zle_lt_or_eq _ _ H'0); intros E2. apply Rlt_le; auto with real. rewrite <- E2; auto with real. repeat rewrite <- E1; repeat rewrite powerRZ_R1; auto with real. Qed. Theorem Zlt_powerRZ : forall (e : R) (n m : Z), (1 <= e)%R -> (powerRZ e n < powerRZ e m)%R -> (n < m)%Z. intros e n m H' H'0. case (Zle_or_lt m n); auto; intros Z1. Contradict H'0. apply Rle_not_lt. apply Rle_powerRZ; auto. Qed. Theorem Zle_powerRZ : forall (e : R) (n m : Z), (1 < e)%R -> (powerRZ e n <= powerRZ e m)%R -> (n <= m)%Z. intros e n m H' H'0. case (Zle_or_lt n m); auto; intros Z1. absurd (powerRZ e n <= powerRZ e m)%R; auto. apply Rlt_not_le. apply Rlt_powerRZ; auto. Qed. Theorem Rinv_powerRZ : forall (e : R) (n : Z), e <> 0%R -> (/ powerRZ e n)%R = powerRZ e (- n). intros e n H. apply Rmult_eq_reg_l with (powerRZ e n); auto with real zarith. rewrite Rinv_r; auto with real zarith. rewrite <- powerRZ_add; auto with real zarith. ring_simplify (n + - n)%Z; simpl in |- *; auto. Qed. Float8.4/Zdivides.v0000644000423700002640000004313412032774526014026 0ustar sboldotoccata(**************************************************************************** IEEE754 : NDiv Laurent Thery ***************************************************************************** Definition of the quotient and divisibility for natural and relative numbers*) Require Export Omega. Require Export Paux. Definition oZ1 (x : Option positive) := match x with | None => 0%Z | Some z => Zpos z end. (* We use the function Pdiv function to build our Zquotient*) Definition Zquotient (n m : Z) := match n, m with | Z0, _ => 0%Z | _, Z0 => 0%Z | Zpos x, Zpos y => match Pdiv x y with | (x, _) => oZ1 x end | Zneg x, Zneg y => match Pdiv x y with | (x, _) => oZ1 x end | Zpos x, Zneg y => match Pdiv x y with | (x, _) => (- oZ1 x)%Z end | Zneg x, Zpos y => match Pdiv x y with | (x, _) => (- oZ1 x)%Z end end. Theorem inj_oZ1 : forall z, oZ1 z = Z_of_nat (oZ z). intros z; case z; simpl in |- *; try (intros; apply sym_equal; apply inject_nat_convert; auto); auto. Qed. Theorem Zero_le_oZ : forall z, 0 <= oZ z. intros z; case z; simpl in |- *; auto with arith. Qed. Hint Resolve Zero_le_oZ: arith. (* It has the required property *) Theorem ZquotientProp : forall m n : Z, n <> 0%Z -> ex (fun r : Z => m = (Zquotient m n * n + r)%Z /\ (Zabs (Zquotient m n * n) <= Zabs m)%Z /\ (Zabs r < Zabs n)%Z). intros m n; unfold Zquotient in |- *; case n; simpl in |- *. intros H; case H; auto. intros n' Hn'; case m; simpl in |- *; auto. exists 0%Z; repeat split; simpl in |- *; auto with zarith. intros m'; generalize (Pdiv_correct m' n'); case (Pdiv m' n'); simpl in |- *; auto. intros q r (H1, H2); exists (oZ1 r); repeat (split; auto with zarith). rewrite <- (inject_nat_convert (Zpos m') m'); auto. rewrite H1. rewrite inj_plus; rewrite inj_mult. rewrite <- (inject_nat_convert (Zpos n') n'); auto. repeat rewrite inj_oZ1; auto. rewrite inj_oZ1; rewrite Zabs_eq; auto with zarith. rewrite <- (inject_nat_convert (Zpos m') m'); auto with zarith. rewrite <- (inject_nat_convert (Zpos n') n'); auto with zarith. rewrite inj_oZ1; rewrite Zabs_eq; auto with zarith. rewrite <- (inject_nat_convert (Zpos n') n'); auto with zarith. intros m'; generalize (Pdiv_correct m' n'); case (Pdiv m' n'); simpl in |- *; auto. intros q r (H1, H2); exists (- oZ1 r)%Z; repeat (split; auto with zarith). replace (Zneg m') with (- Zpos m')%Z; [ idtac | simpl in |- *; auto ]. rewrite <- (inject_nat_convert (Zpos m') m'); auto. rewrite H1. rewrite inj_plus; rewrite inj_mult. rewrite <- (inject_nat_convert (Zpos n') n'); auto. repeat rewrite inj_oZ1; auto with zarith. ring. rewrite <- Zopp_mult_distr_l; rewrite Zabs_Zopp. rewrite inj_oZ1; rewrite Zabs_eq; auto with zarith. rewrite <- (inject_nat_convert (Zpos m') m'); auto with zarith. rewrite <- (inject_nat_convert (Zpos n') n'); auto with zarith. rewrite Zabs_Zopp. rewrite inj_oZ1; rewrite Zabs_eq; auto with zarith. rewrite <- (inject_nat_convert (Zpos n') n'); auto with zarith. intros n' Hn'; case m; simpl in |- *; auto. exists 0%Z; repeat split; simpl in |- *; auto with zarith. intros m'; generalize (Pdiv_correct m' n'); case (Pdiv m' n'); simpl in |- *; auto. intros q r (H1, H2); exists (oZ1 r); repeat (split; auto with zarith). replace (Zneg n') with (- Zpos n')%Z; [ idtac | simpl in |- *; auto ]. rewrite <- (inject_nat_convert (Zpos m') m'); auto. rewrite H1. rewrite inj_plus; rewrite inj_mult. rewrite <- (inject_nat_convert (Zpos n') n'); auto. repeat rewrite inj_oZ1; auto with zarith. ring. replace (Zneg n') with (- Zpos n')%Z; [ idtac | simpl in |- *; auto ]. rewrite Zmult_opp_opp. rewrite inj_oZ1; rewrite Zabs_eq; auto with zarith. rewrite <- (inject_nat_convert (Zpos n') n'); auto with zarith. rewrite <- (inject_nat_convert (Zpos m') m'); auto with zarith. rewrite inj_oZ1; rewrite Zabs_eq; auto with zarith. rewrite <- (inject_nat_convert (Zpos n') n'); auto with zarith. intros m'; generalize (Pdiv_correct m' n'); case (Pdiv m' n'); simpl in |- *; auto. intros q r (H1, H2); exists (- oZ1 r)%Z; repeat (split; auto with zarith). replace (Zneg m') with (- Zpos m')%Z; [ idtac | simpl in |- *; auto ]. rewrite <- (inject_nat_convert (Zpos m') m'); auto. replace (Zneg n') with (- Zpos n')%Z; [ idtac | simpl in |- *; auto ]. rewrite H1. rewrite inj_plus; rewrite inj_mult. rewrite <- (inject_nat_convert (Zpos n') n'); auto. repeat rewrite inj_oZ1; auto with zarith. ring. replace (Zneg n') with (- Zpos n')%Z; [ idtac | simpl in |- *; auto ]. rewrite <- Zopp_mult_distr_r; rewrite Zabs_Zopp. rewrite inj_oZ1; rewrite Zabs_eq; auto with zarith. rewrite <- (inject_nat_convert (Zpos m') m'); auto with zarith. rewrite <- (inject_nat_convert (Zpos n') n'); auto with zarith. rewrite Zabs_Zopp. rewrite inj_oZ1; rewrite Zabs_eq; auto with zarith. rewrite <- (inject_nat_convert (Zpos n') n'); auto with zarith. Qed. Theorem ZquotientPos : forall z1 z2 : Z, (0 <= z1)%Z -> (0 <= z2)%Z -> (0 <= Zquotient z1 z2)%Z. intros z1 z2 H H0; case (Z_eq_dec z2 0); intros Z1. rewrite Z1; red in |- *; case z1; simpl in |- *; auto; intros; red in |- *; intros; discriminate. case (ZquotientProp z1 z2); auto; intros r (H1, (H2, H3)). case (Zle_or_lt 0 (Zquotient z1 z2)); auto; intros Z2. Contradict H3; apply Zle_not_lt. replace r with (z1 - Zquotient z1 z2 * z2)%Z; [ idtac | pattern z1 at 1 in |- *; rewrite H1; ring ]. repeat rewrite Zabs_eq; auto. pattern z2 at 1 in |- *; replace z2 with (0 + 1 * z2)%Z; [ idtac | ring ]. unfold Zminus in |- *; apply Zle_trans with (z1 + 1 * z2)%Z; auto with zarith. apply Zplus_le_compat_l. rewrite Zopp_mult_distr_l. apply Zle_Zmult_comp_r; auto with zarith. unfold Zminus in |- *; rewrite Zopp_mult_distr_l; auto with zarith. Qed. (* The property of a number to divide another one (Ndivides n m) shoud be read as m divides n *) Definition Zdivides (n m : Z) := exists q : Z, n = (m * q)%Z. Theorem ZdividesZquotient : forall n m : Z, m <> 0%Z -> Zdivides n m -> n = (Zquotient n m * m)%Z. intros n m H' H'0. case H'0; intros z1 Hz1. case (ZquotientProp n m); auto; intros z2 (Hz2, (Hz3, Hz4)). cut (z2 = 0%Z); [ intros H1; pattern n at 1 in |- *; rewrite Hz2; rewrite H1; ring | idtac ]. cut (z2 = ((z1 - Zquotient n m) * m)%Z); [ intros H2 | idtac ]. case (Z_eq_dec (z1 - Zquotient n m) 0); intros H3. rewrite H2; rewrite H3; ring. Contradict Hz4. replace (Zabs m) with (1 * Zabs m)%Z; [ idtac | ring ]. apply Zle_not_lt; rewrite H2. rewrite Zabs_Zmult; apply Zle_Zmult_comp_r; auto with zarith. generalize H3; case (z1 - Zquotient n m)%Z; try (intros H1; case H1; auto; fail); simpl in |- *; intros p; case p; simpl in |- *; auto; intros; red in |- *; simpl in |- *; auto; red in |- *; intros; discriminate. rewrite Zmult_minus_distr_r; rewrite (Zmult_comm z1); rewrite <- Hz1; (pattern n at 1 in |- *; rewrite Hz2); ring. Qed. Theorem ZdividesZquotientInv : forall n m : Z, n = (Zquotient n m * m)%Z -> Zdivides n m. intros n m H'; red in |- *. exists (Zquotient n m); auto. pattern n at 1 in |- *; rewrite H'; auto with zarith. Qed. Theorem ZdividesMult : forall n m p : Z, Zdivides n m -> Zdivides (p * n) (p * m). intros n m p H'; red in H'. elim H'; intros q E. red in |- *. exists q. rewrite E. auto with zarith. Qed. Theorem Zeq_mult_simpl : forall a b c : Z, c <> 0%Z -> (a * c)%Z = (b * c)%Z -> a = b. intros a b c H H0. case (Zle_or_lt c 0); intros Zl1. apply Zle_antisym; apply Zmult_le_reg_r with (p := (- c)%Z); try apply Zlt_gt; auto with zarith; repeat rewrite <- Zopp_mult_distr_r; rewrite H0; auto with zarith. apply Zle_antisym; apply Zmult_le_reg_r with (p := c); try apply Zlt_gt; auto with zarith; rewrite H0; auto with zarith. Qed. Theorem ZdividesDiv : forall n m p : Z, p <> 0%Z -> Zdivides (p * n) (p * m) -> Zdivides n m. intros n m p H' H'0. case H'0; intros q E. exists q. apply Zeq_mult_simpl with (c := p); auto. rewrite (Zmult_comm n); rewrite E; ring. Qed. Definition ZdividesP : forall n m : Z, {Zdivides n m} + {~ Zdivides n m}. intros n m; case m. case n. left; red in |- *; exists 0%Z; auto with zarith. intros p; right; red in |- *; intros H; case H; simpl in |- *; intros f H1; discriminate. intros p; right; red in |- *; intros H; case H; simpl in |- *; intros f H1; discriminate. intros p; generalize (Z_eq_bool_correct (Zquotient n (Zpos p) * Zpos p) n); case (Z_eq_bool (Zquotient n (Zpos p) * Zpos p) n); intros H1. left; apply ZdividesZquotientInv; auto. right; Contradict H1; apply sym_equal; apply ZdividesZquotient; auto. red in |- *; intros; discriminate. intros p; generalize (Z_eq_bool_correct (Zquotient n (Zneg p) * Zneg p) n); case (Z_eq_bool (Zquotient n (Zneg p) * Zneg p) n); intros H1. left; apply ZdividesZquotientInv; auto. right; Contradict H1; apply sym_equal; apply ZdividesZquotient; auto. red in |- *; intros; discriminate. Defined. (* Eval Compute in (ZdividesP (POS (xO (xO xH))) (POS (xO xH))). *) Theorem Zquotient1 : forall m : Z, Zquotient m 1 = m. intros m. case (ZquotientProp m 1); auto. red in |- *; intros; discriminate. intros z (H1, (H2, H3)). pattern m at 2 in |- *; rewrite H1; replace z with 0%Z; try ring. generalize H3; case z; simpl in |- *; auto; intros p; case p; unfold Zlt in |- *; simpl in |- *; intros; discriminate. Qed. Theorem Zdivides1 : forall m : Z, Zdivides m 1. intros m; exists m; auto with zarith. Qed. Theorem Zabs_eq_case : forall z1 z2 : Z, Zabs z1 = Zabs z2 -> z1 = z2 \/ z1 = (- z2)%Z. intros z1 z2; case z1; case z2; simpl in |- *; auto; try (intros; discriminate); intros p1 p2 H1; injection H1; (intros H2; rewrite H2); auto. Qed. Theorem Zabs_tri : forall z1 z2 : Z, (Zabs (z1 + z2) <= Zabs z1 + Zabs z2)%Z. intros z1 z2; case z1; case z2; try (simpl in |- *; auto with zarith; fail). intros p1 p2; apply Zabs_intro with (P := fun x => (x <= Zabs (Zpos p2) + Zabs (Zneg p1))%Z); try rewrite Zopp_plus_distr; auto with zarith. intros p1 p2; apply Zabs_intro with (P := fun x => (x <= Zabs (Zpos p2) + Zabs (Zneg p1))%Z); try rewrite Zopp_plus_distr; auto with zarith. Qed. Hint Resolve Zabs_tri: zarith. Theorem ZquotientUnique : forall m n q r : Z, n <> 0%Z -> m = (q * n + r)%Z -> (Zabs (q * n) <= Zabs m)%Z -> (Zabs r < Zabs n)%Z -> q = Zquotient m n. intros m n q r H' H'0 H'1 H'2. case (ZquotientProp m n); auto; intros z (H0, (H1, H2)). case (Zle_or_lt (Zabs q) (Zabs (Zquotient m n))); intros Zl1; auto with arith. case (Zle_lt_or_eq _ _ Zl1); clear Zl1; intros Zl1; auto with arith. absurd ((Zabs (Zquotient m n * n) <= Zabs m)%Z); trivial. apply Zlt_not_le. pattern m at 1 in |- *; rewrite H'0. apply Zle_lt_trans with (Zabs (q * n) + Zabs r)%Z; auto with zarith. apply Zlt_le_trans with (Zabs (q * n) + Zabs n)%Z; auto with zarith. repeat rewrite Zabs_Zmult. replace (Zabs q * Zabs n + Zabs n)%Z with (Zsucc (Zabs q) * Zabs n)%Z; [ auto with zarith | unfold Zsucc in |- *; ring ]. case (Zabs_eq_case _ _ Zl1); auto. intros H; (cut (Zquotient m n = 0%Z); [ intros H3; rewrite H; repeat rewrite H3; simpl in |- *; auto | idtac ]). cut (Zabs (Zquotient m n) < 1)%Z. case (Zquotient m n); simpl in |- *; auto; intros p; case p; unfold Zlt in |- *; simpl in |- *; intros; discriminate. apply Zlt_mult_simpl_l with (c := Zabs n); auto with zarith. case (Zle_lt_or_eq 0 (Zabs n)); auto with zarith. intros H3; case H'; auto. generalize H3; case n; simpl in |- *; auto; intros; discriminate. rewrite <- Zabs_Zmult; rewrite (Zmult_comm n). replace (Zabs n * 1)%Z with (Zabs n); [ idtac | ring ]. apply Zle_lt_trans with (1 := H1). apply Zlt_mult_simpl_l with (c := (1 + 1)%Z); auto with zarith. replace ((1 + 1) * Zabs m)%Z with (Zabs (m + m)). replace ((1 + 1) * Zabs n)%Z with (Zabs n + Zabs n)%Z; [ idtac | ring ]. pattern m at 1 in |- *; rewrite H'0; rewrite H0; rewrite H. replace (- Zquotient m n * n + r + (Zquotient m n * n + z))%Z with (r + z)%Z; [ idtac | ring ]. apply Zle_lt_trans with (Zabs r + Zabs z)%Z; auto with zarith. rewrite <- (Zabs_eq (1 + 1)); auto with zarith. rewrite <- Zabs_Zmult; apply f_equal with (f := Zabs); auto with zarith. absurd ((Zabs (q * n) <= Zabs m)%Z); trivial. apply Zlt_not_le. pattern m at 1 in |- *; rewrite H0. apply Zle_lt_trans with (Zabs (Zquotient m n * n) + Zabs z)%Z; auto with zarith. apply Zlt_le_trans with (Zabs (Zquotient m n * n) + Zabs n)%Z; auto with zarith. repeat rewrite Zabs_Zmult. replace (Zabs (Zquotient m n) * Zabs n + Zabs n)%Z with (Zsucc (Zabs (Zquotient m n)) * Zabs n)%Z; [ auto with zarith | unfold Zsucc in |- *; ring ]. Qed. Theorem ZquotientZopp : forall m n : Z, Zquotient (- m) n = (- Zquotient m n)%Z. intros m n; case (Z_eq_dec n 0); intros Z1. rewrite Z1; unfold Zquotient in |- *; case n; case m; simpl in |- *; auto. case (ZquotientProp m n); auto; intros r1 (H'2, (H'3, H'4)); auto with zarith. apply sym_equal; apply ZquotientUnique with (q := (- Zquotient m n)%Z) (r := (- r1)%Z); auto. pattern m at 1 in |- *; rewrite H'2; ring. rewrite <- Zopp_mult_distr_l; repeat rewrite Zabs_Zopp; auto. rewrite Zabs_Zopp; auto. Qed. Theorem ZquotientMonotone : forall n m q : Z, (Zabs n <= Zabs m)%Z -> (Zabs (Zquotient n q) <= Zabs (Zquotient m q))%Z. intros n m q H; case (Zle_lt_or_eq _ _ H); intros Z0. case (Z_eq_dec q 0); intros Z1. rewrite Z1; unfold Zquotient in |- *; case n; case m; simpl in |- *; auto with zarith. case (Zle_or_lt (Zabs (Zquotient n q)) (Zabs (Zquotient m q))); auto; intros H'1. case (ZquotientProp m q); auto; intros r1 (H'2, (H'3, H'4)); auto with zarith. case (ZquotientProp n q); auto; intros r2 (H'5, (H'6, H'7)); auto with zarith. absurd ((Zabs (Zquotient n q * q) <= Zabs n)%Z); trivial. apply Zlt_not_le. apply Zlt_le_trans with (1 := Z0). rewrite H'2. apply Zle_trans with (Zabs (Zquotient m q * q) + Zabs r1)%Z; auto with zarith. apply Zle_trans with (Zabs (Zquotient m q * q) + Zabs q)%Z; auto with zarith. repeat rewrite Zabs_Zmult. replace (Zabs (Zquotient m q) * Zabs q + Zabs q)%Z with (Zsucc (Zabs (Zquotient m q)) * Zabs q)%Z; [ idtac | unfold Zsucc in |- *; ring ]. cut (0 < Zabs q)%Z; auto with zarith. case (Zle_lt_or_eq 0 (Zabs q)); auto with zarith. intros H'8; case Z1; auto. generalize H'8; case q; simpl in |- *; auto; intros; discriminate. case (Zabs_eq_case _ _ Z0); intros Z1; rewrite Z1; auto with zarith. rewrite ZquotientZopp; rewrite Zabs_Zopp; auto with zarith. Qed. Theorem NotDividesDigit : forall r v : Z, (1 < r)%Z -> v <> 0%Z -> ~ Zdivides v (Zpower_nat r (digit r v)). intros r v H H'; red in |- *; intros H'0; case H'0; intros q E. absurd (Zabs v < Zpower_nat r (digit r v))%Z; auto with zarith. apply Zle_not_lt. case (Z_eq_dec q 0); intros Z1. case H'; rewrite E; rewrite Z1; ring. pattern v at 2 in |- *; rewrite E. rewrite Zabs_Zmult. pattern (Zpower_nat r (digit r v)) at 1 in |- *; replace (Zpower_nat r (digit r v)) with (Zpower_nat r (digit r v) * 1)%Z; [ idtac | ring ]. rewrite (fun x y => Zabs_eq (Zpower_nat x y)); auto with zarith. apply Zle_Zmult_comp_l; auto with zarith. generalize Z1; case q; simpl in |- *; try (intros H1; case H1; auto; fail); intros p; (case p; unfold Zle in |- *; simpl in |- *; intros; red in |- *; intros; discriminate). Qed. Theorem ZDividesLe : forall n m : Z, n <> 0%Z -> Zdivides n m -> (Zabs m <= Zabs n)%Z. intros n m H' H'0; case H'0; intros q E; rewrite E. rewrite Zabs_Zmult. pattern (Zabs m) at 1 in |- *; replace (Zabs m) with (Zabs m * 1)%Z; [ idtac | ring ]. apply Zle_Zmult_comp_l; auto with zarith. generalize E H'; case q; simpl in |- *; auto; try (intros H1 H2; case H2; rewrite H1; ring; fail); intros p; case p; unfold Zle in |- *; simpl in |- *; intros; red in |- *; discriminate. Qed. Theorem Zquotient_mult_comp : forall m n p : Z, p <> 0%Z -> Zquotient (m * p) (n * p) = Zquotient m n. intros m n p Z1; case (Z_eq_dec n 0); intros Z2. rewrite Z2; unfold Zquotient in |- *; case (m * p)%Z; case m; simpl in |- *; auto. case (ZquotientProp m n); auto; intros r (H1, (H2, H3)). apply sym_equal; apply ZquotientUnique with (r := (r * p)%Z); auto with zarith. pattern m at 1 in |- *; rewrite H1; ring. rewrite Zmult_assoc. repeat rewrite (fun x => Zabs_Zmult x p); auto with zarith. repeat rewrite Zabs_Zmult; auto with zarith. apply Zmult_gt_0_lt_compat_r; auto with zarith. apply Zlt_gt; generalize Z1; case p; simpl in |- *; try (intros H4; case H4; auto; fail); unfold Zlt in |- *; simpl in |- *; auto; intros; red in |- *; intros; discriminate. Qed. Theorem ZDivides_add : forall n m p : Z, Zdivides n p -> Zdivides m p -> Zdivides (n + m) p. intros n m p H' H'0. case H'; intros z1 Hz1. case H'0; intros z2 Hz2. exists (z1 + z2)%Z; rewrite Hz1; rewrite Hz2; ring. Qed. Theorem NDivides_minus : forall n m p : Z, Zdivides n p -> Zdivides m p -> Zdivides (n - m) p. intros n m p H' H'0. case H'; intros z1 Hz1. case H'0; intros z2 Hz2. exists (z1 - z2)%Z; rewrite Hz1; rewrite Hz2; ring. Qed. Theorem ZDivides_mult : forall n m p q : Z, Zdivides n p -> Zdivides m q -> Zdivides (n * m) (p * q). intros n m p q H' H'0. case H'; intros z1 Hz1. case H'0; intros z2 Hz2. exists (z1 * z2)%Z; rewrite Hz1; rewrite Hz2; ring. Qed. Theorem ZdividesTrans : forall n m p : Z, Zdivides n m -> Zdivides m p -> Zdivides n p. intros n m p H' H'0. case H'; intros z1 Hz1. case H'0; intros z2 Hz2. exists (z1 * z2)%Z; rewrite Hz1; rewrite Hz2; ring. Qed. Theorem ZdividesLessPow : forall (n : Z) (m p : nat), m <= p -> Zdivides (Zpower_nat n p) (Zpower_nat n m). intros n m p H'; exists (Zpower_nat n (p - m)). rewrite <- Zpower_nat_is_exp. rewrite <- le_plus_minus; auto. Qed. Float8.4/Zenum.v0000644000423700002640000001300212032774526013332 0ustar sboldotoccata(**************************************************************************** IEEE754 : Zenum Laurent Thery ***************************************************************************** Simple functions to enumerate relative numbers *) Require Export Faux. Require Export Omega. Require Export List. (* Returns the list of relative numbers from z to z+n *) Fixpoint mZlist_aux (p : Z) (n : nat) {struct n} : list Z := match n with | O => p :: nil | S n1 => p :: mZlist_aux (Zsucc p) n1 end. Theorem mZlist_aux_correct : forall (n : nat) (p q : Z), (p <= q)%Z -> (q <= p + Z_of_nat n)%Z -> In q (mZlist_aux p n). intros n; elim n; clear n; auto. intros p q; try rewrite <- Zplus_0_r_reverse. intros H' H'0; simpl in |- *; left. apply Zle_antisym; auto. intros n H' p q H'0 H'1; case (Zle_lt_or_eq _ _ H'0); intros H'2. simpl in |- *; right. apply H'; auto with zarith. rewrite Zplus_succ_comm. rewrite <- inj_S; auto. simpl in |- *; auto. Qed. Theorem mZlist_aux_correct_rev1 : forall (n : nat) (p q : Z), In q (mZlist_aux p n) -> (p <= q)%Z. intros n; elim n; clear n; simpl in |- *; auto. intros p q H'; elim H'; auto with zarith. intros n H' p q H'0; elim H'0; auto with zarith. intros H'1; apply Zle_succ_le; auto with zarith. Qed. Theorem mZlist_aux_correct_rev2 : forall (n : nat) (p q : Z), In q (mZlist_aux p n) -> (q <= p + Z_of_nat n)%Z. intros n; elim n; clear n; auto. intros p q H'; elim H'; auto with zarith. intros H'0; elim H'0. intros n H' p q H'0; elim H'0; auto with zarith. intros H'1; rewrite inj_S; rewrite <- Zplus_succ_comm; auto. Qed. (* Return the list of of relative numbres from p to p+q if p= p :: nil | Zpos d => mZlist_aux p (nat_of_P d) | Zneg _ => nil (A:=Z) end. Theorem mZlist_correct : forall p q r : Z, (p <= r)%Z -> (r <= q)%Z -> In r (mZlist p q). intros p q r H' H'0; unfold mZlist in |- *; CaseEq (q - p)%Z; auto with zarith. intros H'1; rewrite (Zle_antisym r p); auto with datatypes. auto with zarith. intros p0 H'1; apply mZlist_aux_correct; auto. rewrite inject_nat_convert with (1 := H'1); auto with zarith. intros p0 H'1; absurd (p <= q)%Z; auto. apply Zlt_not_le; auto. apply Zlt_O_minus_lt; auto. replace (p - q)%Z with (- (q - p))%Z; auto with zarith. rewrite H'1; simpl in |- *; auto with zarith. unfold Zlt in |- *; simpl in |- *; auto. apply Zle_trans with (m := r); auto. Qed. Theorem mZlist_correct_rev1 : forall p q r : Z, In r (mZlist p q) -> (p <= r)%Z. intros p q r; unfold mZlist in |- *; CaseEq (q - p)%Z. intros H' H'0; elim H'0; auto with zarith. intros H'1; elim H'1. intros p0 H' H'0. apply mZlist_aux_correct_rev1 with (n := nat_of_P p0); auto. intros p0 H' H'0; elim H'0. Qed. Theorem mZlist_correct_rev2 : forall p q r : Z, In r (mZlist p q) -> (r <= q)%Z. intros p q r; unfold mZlist in |- *; CaseEq (q - p)%Z. intros H' H'0; elim H'0; auto with zarith. intros H'1; elim H'1. intros p0 H' H'0. rewrite <- (Zplus_minus p q). rewrite <- inject_nat_convert with (1 := H'). apply mZlist_aux_correct_rev2; auto. intros p0 H' H'0; elim H'0. Qed. (* Given two list returns the list of possible product of an element of the first list with an element of the second list *) Fixpoint mProd (A B C : Set) (l1 : list A) (l2 : list B) {struct l2} : list (A * B) := match l2 with | nil => nil | b :: l2' => map (fun a : A => (a, b)) l1 ++ mProd A B C l1 l2' end. Theorem mProd_correct : forall (A B C : Set) (l1 : list A) (l2 : list B) (a : A) (b : B), In a l1 -> In b l2 -> In (a, b) (mProd A B C l1 l2). intros A B C l1 l2; elim l2; simpl in |- *; auto. intros a l H' a0 b H'0 H'1; elim H'1; [ intros H'2; rewrite <- H'2; clear H'1 | intros H'2; clear H'1 ]; auto with datatypes. apply in_or_app; left; auto with datatypes. generalize H'0; elim l1; simpl in |- *; auto with datatypes. intros a1 l0 H'1 H'3; elim H'3; clear H'3; intros H'4; [ rewrite <- H'4 | idtac ]; auto with datatypes. Qed. Theorem mProd_correct_rev1 : forall (A B C : Set) (l1 : list A) (l2 : list B) (a : A) (b : B), In (a, b) (mProd A B C l1 l2) -> In a l1. intros A B C l1 l2; elim l2; simpl in |- *; auto. intros a H' H'0; elim H'0. intros a l H' a0 b H'0. case (in_app_or _ _ _ H'0); auto with datatypes. elim l1; simpl in |- *; auto with datatypes. intros a1 l0 H'1 H'2; elim H'2; clear H'2; intros H'3; [ inversion H'3 | idtac ]; auto with datatypes. intros H'1; apply H' with (b := b); auto. Qed. Theorem mProd_correct_rev2 : forall (A B C : Set) (l1 : list A) (l2 : list B) (a : A) (b : B), In (a, b) (mProd A B C l1 l2) -> In b l2. intros A B C l1 l2; elim l2; simpl in |- *; auto. intros a l H' a0 b H'0. case (in_app_or _ _ _ H'0); auto with datatypes. elim l1; simpl in |- *; auto with datatypes. intros H'1; elim H'1; auto. intros a1 l0 H'1 H'2; elim H'2; clear H'2; intros H'3; [ inversion H'3 | idtac ]; auto with datatypes. intros H'1; right; apply H' with (a := a0); auto. Qed. Theorem in_map_inv : forall (A B : Set) (f : A -> B) (l : list A) (x : A), (forall a b : A, f a = f b -> a = b) -> In (f x) (map f l) -> In x l. intros A B f l; elim l; simpl in |- *; auto. intros a l0 H' x H'0 H'1; elim H'1; clear H'1; intros H'2; auto. Qed. Float8.4/sTactic.v0000644000423700002640000000265412032774526013641 0ustar sboldotoccata (**************************************************************************** IEEE754 : sTactic Laurent Thery ***************************************************************************** *) (* Some simple tactics *) Theorem Contradict1 : forall a b : Prop, b -> (a -> ~ b) -> ~ a. intuition. Qed. Theorem Contradict2 : forall a b : Prop, b -> ~ b -> a. intuition. Qed. Theorem Contradict3 : forall a : Prop, a -> ~ ~ a. auto. Qed. (* Contradict is used to contradict an hypothesis H if we have H:~A |- B the result is |- A if we have H:~A |- ~B the result is H:B |- A *) Ltac Contradict name := (apply (fun a : Prop => Contradict1 a _ name); clear name; intros name) || (apply (fun a : Prop => Contradict2 a _ name); clear name); try apply Contradict3. (* Same as Case but keeps an equality *) Ltac CaseEq name := generalize (refl_equal name); pattern name at -1 in |- *; case name. (* Same as Case but cleans the case variable *) Ltac Casec name := case name; clear name. (* Same as Elim but cleans the elim variable *) Ltac Elimc name := elim name; clear name.Float8.4/Expansions/0000755000423700002640000000000012032777406014200 5ustar sboldotoccataFloat8.4/Expansions/EFast2Sum.v0000644000423700002640000003453612032774526016153 0ustar sboldotoccata(**************************************************************************** IEEE754 : EFast2Sum Laurent Thery ******************************************************************************) Require Export Fast2Sum. Section EFast. Variable b : Fbound. Variable precision : nat. Let radix := 2%Z. Let radixMoreThanOne : (1 < radix)%Z. unfold radix in |- *; red in |- *; simpl in |- *; auto. Qed. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne). Hint Resolve radixMoreThanZERO radixMoreThanOne: zarith. Coercion Local FtoRradix := FtoR radix. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Variable Iplus : float -> float -> float. Hypothesis IplusCorrect : forall p q : float, Fbounded b p -> Fbounded b q -> Closest b radix (p + q) (Iplus p q). Hypothesis IplusComp : forall p q r s : float, Fbounded b p -> Fbounded b q -> Fbounded b r -> Fbounded b s -> p = r :>R -> q = s :>R -> Iplus p q = Iplus r s :>R. Hypothesis IplusSym : forall p q : float, Iplus p q = Iplus q p. Hypothesis IplusOp : forall p q : float, Fopp (Iplus p q) = Iplus (Fopp p) (Fopp q). Variable Iminus : float -> float -> float. Hypothesis IminusPlus : forall p q : float, Iminus p q = Iplus p (Fopp q). Theorem IminusComp : forall p q r s : float, Fbounded b p -> Fbounded b q -> Fbounded b r -> Fbounded b s -> p = r :>R -> q = s :>R -> Iminus p q = Iminus r s :>R. intros p q r s H' H'0 H'1 H'2 H'3 H'4. repeat rewrite IminusPlus. apply IplusComp; auto; try apply oppBounded; auto. unfold FtoRradix in |- *; repeat rewrite Fopp_correct; auto. unfold FtoRradix in H'4; rewrite H'4; auto. Qed. Theorem EvenBound : forall (p : float) (m : Z), Even m -> (Zpred (Zpower_nat radix precision) <= m)%Z -> (m <= Zpower_nat radix (S precision) - radix)%Z -> Fbounded b p -> exists q : float, Fbounded b q /\ q = Float m (Fexp p) :>R. intros p m H' H'0 H'1 H'2. cut (0 < radix)%Z; [ intros Hr | unfold radix in |- *; auto with zarith ]. repeat split; simpl in |- *; auto with float zarith. case H'; intros am2 H'3. exists (Float am2 (Zsucc (Fexp p))); split. repeat split; simpl in |- *; auto with float zarith. apply Zmult_gt_0_lt_reg_r with (p := radix); auto with zarith. rewrite Zmult_comm. pattern radix at 1 in |- *; rewrite <- (Zabs_eq radix); auto with zarith. rewrite <- Zabs_Zmult. unfold radix in |- *; rewrite <- H'3. rewrite Zabs_eq; fold radix in |- *; auto. apply Zle_lt_trans with (1 := H'1). rewrite pGivesBound; replace (S precision) with (precision + 1); [ idtac | ring ]. rewrite Zpower_nat_is_exp; auto; rewrite Zpower_nat_1; unfold Zminus in |- *; auto with zarith. apply Zle_trans with (2 := H'0); auto with zarith arith. unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite powerRZ_Zs; auto with real. rewrite H'3; rewrite Rmult_IZR; simpl in |- *. ring. Qed. Theorem ExtMDekker1 : forall p q : float, Fbounded b p -> Fbounded b q -> (Fexp q <= Fexp p)%Z -> (0 <= p)%R -> Iminus (Iplus p q) p = (Iplus p q - p)%R :>R. intros p q H' H'0 H'1 H'2. cut (0 <= Fnum p)%Z; [ intros Z1 | apply LeR0Fnum with (radix := radix); auto ]. case (Rle_or_lt (Rabs q) (Rabs p)); intros Rl0. apply MDekker with (b := b) (precision := precision); auto. rewrite Rabs_right in Rl0; auto with real. case (LessExpBound _ TwoMoreThanOne b p (Fabs q)); auto. apply absFBounded; auto. unfold FtoRradix in |- *; rewrite Fabs_correct; auto; apply Rlt_le; auto. replace (Fexp (Fabs q)) with (Fexp q); [ idtac | case q; simpl in |- *; auto ]. intros m E; elim E; fold radix in |- *; intros H'4 H'5; clear E. cut (0 <= Fnum (Float m (Fexp q)))%Z; [ simpl in |- *; intros Z2 | apply LeR0Fnum with (radix := radix); auto with zarith; unfold FtoRradix in H'4; rewrite H'4 ]; auto. unfold FtoRradix in |- *; rewrite <- H'4; auto. apply trans_eq with (y := FtoRradix (Iminus (Iplus (Float m (Fexp q)) q) (Float m (Fexp q)))). apply IminusComp; auto. apply IplusBounded; auto. apply IplusBounded; auto. fold FtoRradix in |- *. rewrite (IplusComp p q (Float m (Fexp q)) q); auto. case (Rle_or_lt 0 q); intros Rl1. cut (0 <= Fnum q)%Z; [ intros Z3 | apply LeR0Fnum with (radix := radix); auto ]. rewrite Rabs_right in Rl0; auto with real. case (Zle_or_lt (Zpos (vNum b)) (m + Fnum q)); intros Rl2. 2: apply (MDekkerAux3 b); auto. 2: unfold Fplus in |- *; simpl in |- *. 2: repeat rewrite Zmin_n_n; repeat rewrite <- Zminus_diag_reverse; simpl in |- *. 2: rewrite Zpower_nat_O; repeat rewrite Zmult_1_r. 2: repeat split; simpl in |- *; auto with float zarith. 2: rewrite Zabs_eq; auto with zarith. cut (m + Fnum q <= Zpower_nat radix (S precision) - radix)%Z; [ intros Rl4 | idtac ]. 2: replace (Zpower_nat radix (S precision) - radix)%Z with (Zpred (Zpower_nat radix precision) + Zpred (Zpower_nat radix precision))%Z; auto with zarith. 2: apply Zplus_le_compat; auto. 2: apply Zle_Zpred; rewrite <- (Zabs_eq m); auto with float zarith. 2: rewrite <- pGivesBound; case H'5; simpl in |- *; auto. 2: apply Zle_Zpred; rewrite <- (Zabs_eq (Fnum q)); auto with float zarith. 2: rewrite <- pGivesBound; case H'0; auto. 2: replace (S precision) with (1 + precision); [ idtac | simpl in |- *; auto ]. 2: rewrite Zpower_nat_is_exp; auto with zarith; rewrite Zpower_nat_1. 2: replace radix with (1 + 1)%Z; [ idtac | unfold radix in |- *; simpl in |- *; auto ]. 2: unfold Zpred in |- *; replace (-1)%Z with (- (1))%Z; [ ring | simpl in |- *; auto ]. case (OddEvenDec (m + Fnum q)); intros E0. case (RoundedModeRep b radix precision) with (P := Closest b radix) (p := Fplus radix (Float m (Fexp q)) q) (q := Iplus (Float m (Fexp q)) q); auto. apply ClosestRoundedModeP with (precision := precision); auto. rewrite Fplus_correct; auto. replace (Fexp (Fplus radix (Float m (Fexp q)) q)) with (Fexp q). simpl in |- *; intros m' Hm'. 2: unfold Fplus in |- *; simpl in |- *. 2: repeat rewrite Zmin_n_n; repeat rewrite <- Zminus_diag_reverse; simpl in |- *; auto. cut (m' - m <= Zsucc (Fnum q))%Z; [ intros Rl5 | idtac ]. case (Zle_lt_or_eq _ _ Rl5); clear Rl5; intros Rl5. cut (Zpred (Fnum q) <= m' - m)%Z; [ intros Rl6 | idtac ]. unfold FtoRradix in |- *; rewrite Hm'. unfold FtoRradix in |- *; rewrite <- Fminus_correct; auto. apply sym_eq; apply (ClosestIdem b radix); auto. unfold Fminus, Fplus in |- *; simpl in |- *. repeat rewrite Zmin_n_n; repeat rewrite <- Zminus_diag_reverse; simpl in |- *. rewrite Zpower_nat_O; repeat rewrite Zmult_1_r. repeat split; simpl in |- *; auto with float zarith. apply Zlt_Zabs_intro. apply Zlt_le_trans with (Zpred 0); auto with zarith. replace (Zpred 0) with (- (1))%Z; auto with zarith. apply Zlt_Zopp; apply (vNumbMoreThanOne radix) with (precision := precision); auto with zarith. apply Zle_lt_trans with (Fnum q); auto with zarith. rewrite <- (Zabs_eq (Fnum q)); auto; case H'0; auto. rewrite Fminus_correct; auto. rewrite <- Hm'; auto. apply (IminusCorrect b Iplus); auto. apply IplusBounded; auto. apply Zplus_le_reg_l with (p := m); auto. replace (m + (m' - m))%Z with m'; auto with zarith. apply le_IZR. apply Rmult_le_reg_l with (r := powerRZ radix (Fexp q)); auto with real zarith. repeat rewrite (Rmult_comm (powerRZ radix (Fexp q))). change (Float (m + Zpred (Fnum q)) (Fexp q) <= Float m' (Fexp q))%R in |- *. replace (m + Zpred (Fnum q))%Z with (Zpred (m + Fnum q)). 2: unfold Zpred in |- *; ring. case (EvenBound (Float m (Fexp q)) (Zpred (m + Fnum q))); auto. apply OddSEvenInv; auto. rewrite <- Zsucc_pred; auto. case (Zle_lt_or_eq 0 (m + Fnum q)). replace 0%Z with (0 + 0)%Z; auto with zarith. intros H'3; apply Zlt_succ_le. cut (forall r : Z, Zsucc (Zpred r) = r); [ intros Er; rewrite Er; auto | intros r; unfold Zsucc, Zpred in |- *; ring ]. rewrite <- pGivesBound; auto with zarith. intros H'3; Contradict E0; rewrite <- H'3; simpl in |- *. apply EvenNOdd; apply EvenO. apply Zle_trans with (2 := Rl4); auto with zarith. simpl in |- *; intros x H'3; elim H'3; intros H'6 H'7; rewrite <- H'7; clear H'3. unfold FtoRradix in |- *; rewrite <- Hm'. apply (ClosestMonotone b radix x (Float m (Fexp q) + q)%R); auto. unfold FtoRradix in |- *; rewrite <- Fplus_correct; auto. unfold FtoRradix in H'7; rewrite H'7. unfold Fplus in |- *. repeat rewrite Zmin_n_n; repeat rewrite <- Zminus_diag_reverse; simpl in |- *; auto. rewrite Zpower_nat_O; repeat rewrite Zmult_1_r. unfold FtoR in |- *; simpl in |- *. repeat rewrite (fun x : Z => Rmult_comm x (powerRZ 2 (Fexp q))). apply Rmult_lt_compat_l; auto with real arith. apply Rlt_IZR; auto. apply Zlt_pred; auto. apply (RoundedModeProjectorIdem b radix (Closest b radix)); auto. apply ClosestRoundedModeP with (precision := precision); auto. case H'0; rewrite Zabs_eq; auto with zarith. intros Hq Hq'; case (Zlt_next _ _ Hq); intros H'3. 2: cut (Closest b radix (FtoR radix (Iplus (Float m (Fexp q)) q) - FtoR radix (Float m (Fexp q))) (Iminus (Iplus (Float m (Fexp q)) q) (Float m (Fexp q)))). 2: unfold FtoRradix in |- *; rewrite Hm'. 2: rewrite <- Fminus_correct; auto. 2: unfold Fminus, Fplus in |- *; simpl in |- *; auto. 2: repeat rewrite Zmin_n_n; repeat rewrite <- Zminus_diag_reverse; simpl in |- *; auto. 2: rewrite Zpower_nat_O; repeat rewrite Zmult_1_r. 2: replace (m' + - m)%Z with (m' - m)%Z; [ idtac | ring ]. 2: intros H'6; apply sym_eq; apply (ClosestIdem b radix); auto. 2: repeat split; simpl in |- *; auto with float zarith. 2: rewrite Rl5; rewrite Zabs_eq; auto with zarith. 2: apply (IminusCorrect b Iplus); auto. 2: apply IplusBounded; auto. cut (Closest b radix (FtoR radix (Iplus (Float m (Fexp q)) q) - FtoR radix (Float m (Fexp q))) (Iminus (Iplus (Float m (Fexp q)) q) (Float m (Fexp q)))). unfold FtoRradix in |- *; rewrite Hm'. rewrite <- Fminus_correct; auto. unfold Fminus, Fplus in |- *; simpl in |- *; auto. repeat rewrite Zmin_n_n; repeat rewrite <- Zminus_diag_reverse; simpl in |- *; auto. rewrite Zpower_nat_O; repeat rewrite Zmult_1_r. replace (m' + - m)%Z with (m' - m)%Z; [ idtac | ring ]. rewrite Rl5. rewrite <- H'3. replace (FtoR radix (Float (Zpos (vNum b)) (Fexp q))) with (FtoR radix (Float (nNormMin radix precision) (Zsucc (Fexp q)))). intros H'6; apply sym_eq; apply (ClosestIdem b radix); auto. repeat split; simpl in |- *; auto with float arith. rewrite Zabs_eq; auto with zarith arith. apply ZltNormMinVnum; auto with zarith. unfold nNormMin in |- *; auto with zarith. apply Zle_trans with (Fexp q); auto with float zarith. rewrite (PosNormMin radix b precision); unfold nNormMin in |- *; auto with zarith. rewrite Zmult_comm; unfold FtoR in |- *; simpl in |- *; rewrite powerRZ_Zs; auto with real. rewrite Rmult_IZR; auto with real. apply (IminusCorrect b Iplus); auto. apply IplusBounded; auto. apply Zplus_le_reg_l with (p := m); auto. replace (m + (m' - m))%Z with m'; auto with zarith. apply le_IZR. apply Rmult_le_reg_l with (r := powerRZ radix (Fexp q)); auto with real arith. repeat rewrite (Rmult_comm (powerRZ radix (Fexp q))). change (Float m' (Fexp q) <= Float (m + Zsucc (Fnum q)) (Fexp q))%R in |- *. replace (m + Zsucc (Fnum q))%Z with (Zsucc (m + Fnum q)); [ idtac | unfold Zsucc in |- *; ring ]. case (EvenBound (Float m (Fexp q)) (Zsucc (m + Fnum q))); auto. apply OddSEven; auto. apply Zle_trans with (m + Fnum q)%Z; auto with zarith. case (Zle_next _ _ Rl4); auto. intros H'3; Contradict E0. rewrite <- H'3; auto. apply EvenNOdd; auto. apply EvenPlusInv1 with (n := radix) (precision:=precision); auto. replace (radix + (Zpower_nat radix (S precision) - radix))%Z with (Zpower_nat radix (S precision)); [ idtac | ring ]. apply EvenExp; auto. exists 1%Z; unfold radix in |- *; ring. exists 1%Z; unfold radix in |- *; ring. simpl in |- *; intros x H'3; elim H'3; intros H'6 H'7; rewrite <- H'7; clear H'3. unfold FtoRradix in |- *; rewrite <- Hm'. apply (ClosestMonotone b radix (Float m (Fexp q) + q)%R x); auto. rewrite H'7. unfold FtoRradix in |- *; rewrite <- Fplus_correct; auto. unfold Fplus in |- *. repeat rewrite Zmin_n_n; repeat rewrite <- Zminus_diag_reverse; simpl in |- *; auto. rewrite Zpower_nat_O; repeat rewrite Zmult_1_r. unfold FtoR in |- *; simpl in |- *. repeat rewrite (fun x : Z => Rmult_comm x (powerRZ 2 (Fexp q))). apply Rmult_lt_compat_l; auto with real arith. apply Rlt_IZR; auto with zarith. apply (RoundedModeProjectorIdem b radix (Closest b radix)); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply (MDekkerAux2 b); auto. cut (Closest b radix (Float m (Fexp q) + q) (Iplus (Float m (Fexp q)) q)); auto. unfold FtoRradix in |- *; rewrite <- Fplus_correct; auto with arith. unfold Fplus in |- *. repeat rewrite Zmin_n_n; repeat rewrite <- Zminus_diag_reverse; simpl in |- *; auto. rewrite Zpower_nat_O; repeat rewrite Zmult_1_r. case (EvenBound (Float m (Fexp q)) (m + Fnum q)); auto. apply Zle_trans with (2 := Rl2); auto with zarith arith. intros x (H'6, H'7); fold radix in |- *; simpl in H'7. replace (FtoR radix (Float m (Fexp q)) + FtoR radix q)%R with (FtoR radix (Float (m + Fnum q) (Fexp q))). fold FtoRradix in |- *; rewrite <- H'7. intros H'3; apply sym_eq; apply (ClosestIdem b radix); auto with arith. unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite plus_IZR; ring. apply (MDekkerAux3 b); fold radix in |- *; auto. replace (Fplus radix (Float m (Fexp q)) q) with (Fminus radix (Float m (Fexp q)) (Fopp q)). apply BminusSameExp; auto. apply oppBounded; auto. unfold FtoRradix in H'4; rewrite H'4; auto. replace 0%R with (-0)%R; auto with real. rewrite Fopp_correct; apply Rlt_le; auto with real. unfold Fminus in |- *; rewrite Fopp_Fopp; auto. Qed. Theorem ExtMDekker : forall p q : float, Fbounded b p -> Fbounded b q -> (Fexp q <= Fexp p)%Z -> Iminus (Iplus p q) p = (Iplus p q - p)%R :>R. intros p q H' H'0 H'1. case (Rle_or_lt 0 p); intros H1. apply ExtMDekker1; auto. apply (MDekkerAux5 b); auto. apply ExtMDekker1; auto. apply oppBounded; auto. apply oppBounded; auto. apply Rlt_le; unfold FtoRradix in |- *; rewrite Fopp_correct; replace 0%R with (-0)%R; auto with real. Qed. Theorem ExtDekker : forall p q : float, Fbounded b p -> Fbounded b q -> (Fexp q <= Fexp p)%Z -> Iminus q (Iminus (Iplus p q) p) = (p + q - Iplus p q)%R :>R. intros p q H' H'0 H'1. apply (MDekkerAux1 b precision); auto. apply ExtMDekker; auto. Qed. End EFast. Float8.4/Expansions/Fast2Diff.v0000644000423700002640000000773012032774526016146 0ustar sboldotoccata(**************************************************************************** IEEE754 : Fast2Diff Laurent Thery ******************************************************************************) Require Export EFast2Sum. Section EDiff. Variable b : Fbound. Variable precision : nat. Let radix := 2%Z. Coercion Local FtoRradix := FtoR radix. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Variable Iplus : float -> float -> float. Hypothesis IplusCorrect : forall p q : float, Fbounded b p -> Fbounded b q -> Closest b radix (p + q) (Iplus p q). Hypothesis IplusComp : forall p q r s : float, Fbounded b p -> Fbounded b q -> Fbounded b r -> Fbounded b s -> p = r :>R -> q = s :>R -> Iplus p q = Iplus r s :>R. Hypothesis IplusSym : forall p q : float, Iplus p q = Iplus q p. Hypothesis IplusOp : forall p q : float, Fopp (Iplus p q) = Iplus (Fopp p) (Fopp q). Variable Iminus : float -> float -> float. Hypothesis IminusPlus : forall p q : float, Iminus p q = Iplus p (Fopp q). Theorem MDekkerDiffAux1 : forall p q : float, Iminus p (Iminus p q) = (p - Iminus p q)%R :>R -> Fbounded b p -> Fbounded b q -> Iminus (Iminus p (Iminus p q)) q = (p - q - Iminus p q)%R :>R. intros p q H' H'0 H'1. elim (ErrorBoundedIplus b precision) with (Iplus := Iplus) (p := p) (q := Fopp q); fold radix in |- *; auto. intros error H'2; elim H'2; intros H'3 H'4; clear H'2. cut (Closest b radix (Iminus p (Iminus p q) - q) (Iminus (Iminus p (Iminus p q)) q)); auto. rewrite H'. replace (p - Iminus p q - q)%R with (p - q - Iminus p q)%R; [ idtac | ring ]. replace (p - q)%R with (p + - q)%R; [ idtac | ring ]. rewrite (IminusPlus p q). unfold FtoRradix in |- *; rewrite <- Fopp_correct. rewrite <- H'3. intros H'2. apply sym_eq; apply (ClosestIdem b radix); auto. apply (IminusCorrect b Iplus); auto. apply (IminusBounded b Iplus); auto. apply (IminusBounded b Iplus); auto. apply oppBounded; auto. Qed. Theorem MDekkerDiff : forall p q : float, Fbounded b p -> Fbounded b q -> (Rabs q <= Rabs p)%R -> Iminus p (Iminus p q) = (p - Iminus p q)%R :>R. intros p q H' H'0 H'1. pattern (Iminus p q) at 2 in |- *; rewrite IminusPlus. replace (p - Iplus p (Fopp q))%R with (- (Iplus p (Fopp q) - p))%R; [ idtac | ring ]. unfold FtoRradix in |- *; rewrite <- (MDekker b precision) with (Iminus := Iminus); auto. rewrite <- Fopp_correct. repeat rewrite IminusPlus || rewrite IplusOp || rewrite Fopp_Fopp. rewrite IplusSym; auto. apply oppBounded; auto. rewrite Fopp_correct; auto. rewrite Rabs_Ropp; auto. Qed. Theorem DekkerDiff : forall p q : float, Fbounded b p -> Fbounded b q -> (Rabs q <= Rabs p)%R -> Iminus (Iminus p (Iminus p q)) q = (p - q - Iminus p q)%R :>R. intros p q H' H'0 H'1. apply MDekkerDiffAux1; auto. apply MDekkerDiff; auto. Qed. Theorem ExtMDekkerDiff : forall p q : float, Fbounded b p -> Fbounded b q -> (Fexp q <= Fexp p)%Z -> Iminus p (Iminus p q) = (p - Iminus p q)%R :>R. intros p q H' H'0 H'1. pattern (Iminus p q) at 2 in |- *; rewrite IminusPlus. replace (p - Iplus p (Fopp q))%R with (- (Iplus p (Fopp q) - p))%R; [ idtac | ring ]. unfold FtoRradix in |- *; rewrite <- (ExtMDekker b precision) with (Iminus := Iminus); auto. rewrite <- Fopp_correct. repeat rewrite IminusPlus || rewrite IplusOp || rewrite Fopp_Fopp. rewrite IplusSym; auto. apply oppBounded; auto. Qed. Theorem ExtDekkerDiff : forall p q : float, Fbounded b p -> Fbounded b q -> (Fexp q <= Fexp p)%Z -> Iminus (Iminus p (Iminus p q)) q = (p - q - Iminus p q)%R :>R. intros p q H' H'0 H'1. apply MDekkerDiffAux1; auto. apply ExtMDekkerDiff; auto. Qed. End EDiff.Float8.4/Expansions/Fast2Sum.v0000644000423700002640000003030112032774526016030 0ustar sboldotoccata(**************************************************************************** IEEE754 : Fast2Sum Laurent Thery ******************************************************************************) Require Export AllFloat. Section Fast. Variable b : Fbound. Variable precision : nat. Let radix := 2%Z. Coercion Local FtoRradix := FtoR radix. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Variable Iplus : float -> float -> float. Hypothesis IplusCorrect : forall p q : float, Fbounded b p -> Fbounded b q -> Closest b radix (p + q) (Iplus p q). Hypothesis IplusSym : forall p q : float, Iplus p q = Iplus q p. Hypothesis IplusOp : forall p q : float, Fopp (Iplus p q) = Iplus (Fopp p) (Fopp q). Variable Iminus : float -> float -> float. Hypothesis IminusPlus : forall p q : float, Iminus p q = Iplus p (Fopp q). Let radixMoreThanOne : (1 < radix)%Z. unfold radix in |- *; red in |- *; simpl in |- *; auto. Qed. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne). Hint Resolve radixMoreThanZERO radixMoreThanOne: zarith. Theorem IminusCorrect : forall p q : float, Fbounded b p -> Fbounded b q -> Closest b radix (p - q) (Iminus p q). intros p q H' H'0. rewrite IminusPlus. unfold Rminus in |- *. unfold FtoRradix in |- *; rewrite <- Fopp_correct. apply IplusCorrect; auto. apply oppBounded; auto. Qed. Hint Resolve IminusCorrect. Theorem ErrorBoundedIplus : forall p q : float, Fbounded b p -> Fbounded b q -> exists error : float, error = (p + q - Iplus p q)%R :>R /\ Fbounded b error. intros p q H' H'0. case (errorBoundedPlus b radix precision) with (p := p) (q := q) (pq := Iplus p q); auto. intros x H'1; elim H'1; intros H'2 H'3; elim H'3; intros H'4 H'5; exists x; auto. Qed. Theorem IplusOr : forall p q : float, Fbounded b p -> Fbounded b q -> q = 0%R :>R -> Iplus p q = p :>R. intros p q H' H'0 H'1. cut (Closest b radix (p + q) (Iplus p q)); auto. rewrite H'1. rewrite Rplus_0_r. intros H'2; apply sym_eq. unfold FtoRradix in |- *; apply (ClosestIdem b radix); auto. Qed. Theorem IminusId : forall p q : float, Fbounded b p -> Fbounded b q -> p = q :>R -> Iminus p q = 0%R :>R. intros p q H' H'0 H'1. cut (Closest b radix (p - q) (Iminus p q)); auto. replace (p - q)%R with 0%R; [ idtac | rewrite <- H'1; ring ]. replace 0%R with (FtoRradix (Fzero (- dExp b))). intros H'2; apply sym_eq. unfold FtoRradix in |- *; apply (ClosestIdem b radix); auto. apply FboundedFzero; auto. unfold Fzero, FtoRradix, FtoR in |- *; simpl in |- *; ring. Qed. Theorem IminusOl : forall p q : float, Fbounded b p -> Fbounded b q -> p = 0%R :>R -> Iminus p q = (- q)%R :>R. intros p q H' H'0 H'1. cut (Closest b radix (p - q) (Iminus p q)); auto. rewrite H'1. replace (0 - q)%R with (FtoRradix (Fopp q)). intros H'2; apply sym_eq. unfold FtoRradix in |- *; rewrite <- Fopp_correct; apply (ClosestIdem b radix); auto. apply oppBounded; auto. unfold FtoRradix in |- *; rewrite Fopp_correct; auto; ring. Qed. Theorem IplusBounded : forall p q : float, Fbounded b p -> Fbounded b q -> Fbounded b (Iplus p q). intros p q H' H'0; cut (Closest b radix (p + q) (Iplus p q)); auto. intros H1; case H1; auto. Qed. Theorem IminusBounded : forall p q : float, Fbounded b p -> Fbounded b q -> Fbounded b (Iminus p q). intros p q H' H'0; cut (Closest b radix (p - q) (Iminus p q)); auto. intros H1; case H1; auto. Qed. Theorem IminusInv : forall p q r s : float, Fbounded b p -> Fbounded b q -> Fbounded b r -> Fbounded b s -> p = s :>R -> r = (s - q)%R :>R -> Iminus p q = r :>R. intros p q r s H' H'0 H'1 H'2 H'3 H'4. cut (Closest b radix (p - q) (Iminus p q)); auto. rewrite H'3. rewrite <- H'4. intros H'5; apply sym_eq. unfold FtoRradix in |- *; apply (ClosestIdem b radix); auto. Qed. Theorem IminusFminus : forall p q : float, Fbounded b p -> Fbounded b q -> Fbounded b (Fminus radix p q) -> Iminus p q = Fminus radix p q :>R. intros p q H' H'0 H'1. cut (Closest b radix (p - q) (Iminus p q)); auto. intros H'2. apply sym_eq; apply (ClosestIdem b radix); auto. rewrite Fminus_correct; auto. Qed. Theorem MDekkerAux1 : forall p q : float, Iminus (Iplus p q) p = (Iplus p q - p)%R :>R -> Fbounded b p -> Fbounded b q -> Iminus q (Iminus (Iplus p q) p) = (p + q - Iplus p q)%R :>R. intros p q H' H'0 H'1. elim (ErrorBoundedIplus p q); [ intros error E; elim E; intros H'7 H'8; clear E | idtac | idtac ]; auto. cut (Closest b radix (q - Iminus (Iplus p q) p) (Iminus q (Iminus (Iplus p q) p))); auto. rewrite H'. replace (q - (Iplus p q - p))%R with (p + q - Iplus p q)%R; [ idtac | ring ]. rewrite <- H'7. intros H'2. apply sym_eq; apply (ClosestIdem b radix); auto. apply IminusCorrect; auto. repeat (try apply IplusBounded; try apply IminusBounded; auto); auto. Qed. Theorem MDekkerAux2 : forall p q : float, Iplus p q = (p + q)%R :>R -> Fbounded b p -> Fbounded b q -> Iminus (Iplus p q) p = (Iplus p q - p)%R :>R. intros p q H' H'0 H'1. cut (Closest b radix (Iplus p q - p) (Iminus (Iplus p q) p)); auto. repeat rewrite H'. replace (p + q - p)%R with (FtoRradix q); [ idtac | ring ]. intros H'2. apply sym_eq; apply (ClosestIdem b radix); auto. apply IminusCorrect; auto. apply IplusBounded; auto. Qed. Theorem MDekkerAux3 : forall p q : float, Fbounded b (Fplus radix p q) -> Fbounded b p -> Fbounded b q -> Iminus (Iplus p q) p = (Iplus p q - p)%R :>R. intros p q H' H'0 H'1. apply MDekkerAux2; auto. unfold FtoRradix in |- *; rewrite <- Fplus_correct; auto. apply sym_eq; apply (ClosestIdem b radix); auto. rewrite Fplus_correct; auto. Qed. Theorem MDekkerAux4 : forall p q : float, Fbounded b (Fminus radix (Iplus p q) p) -> Fbounded b p -> Fbounded b q -> Iminus (Iplus p q) p = (Iplus p q - p)%R :>R. intros p q H' H'0 H'1. unfold FtoRradix in |- *; rewrite <- Fminus_correct; auto. apply sym_eq; apply (ClosestIdem b radix); auto. rewrite Fminus_correct; auto. apply IminusCorrect; auto. repeat (try apply IplusBounded; try apply IminusBounded; auto); auto. Qed. Theorem Dekker1 : forall p q : float, (0 <= q)%R -> (q <= p)%R -> Fbounded b p -> Fbounded b q -> Iminus (Iplus p q) p = (Iplus p q - p)%R :>R. intros p q H' H'0 H'1 H'2. apply MDekkerAux4; auto. apply oppBoundedInv; auto. rewrite Fopp_Fminus; auto. apply Sterbenz; auto. apply IplusBounded; auto. apply Rmult_le_reg_l with (r := INR 2); auto with real arith. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real arith; rewrite Rmult_1_l. apply (RoundedModeMult b radix) with (P := Closest b radix) (r := (p + q)%R); auto. apply ClosestRoundedModeP with (precision := precision); auto. replace (radix * FtoR radix p)%R with (p + p)%R; [ idtac | simpl in |- *; fold FtoRradix; ring ]; auto with real. case H'; clear H'; intros H'. apply Rmult_le_reg_l with (r := (/ radix)%R); auto with real. rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real; rewrite Rmult_1_l. apply (FmultRadixInv b radix precision) with (y := (p + q)%R); auto. apply Rmult_lt_reg_l with (r := INR 2); auto with real. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real; rewrite Rmult_1_l. apply Rle_lt_trans with (radix * p)%R. apply Rledouble; auto. apply Rlt_le; apply Rlt_le_trans with (FtoRradix q); auto. apply Rmult_lt_reg_l with (r := (/ radix)%R); auto with real. repeat rewrite <- Rmult_assoc; repeat rewrite Rinv_l; auto with real zarith; repeat rewrite Rmult_1_l. pattern (FtoRradix p) at 1 in |- *; replace (FtoRradix p) with (p + 0)%R; [ idtac | ring ]; auto with real. rewrite IplusOr; auto. apply Rledouble; auto. rewrite H'; auto. Qed. Theorem Dekker2 : forall p q : float, (0 <= p)%R -> (- q <= p)%R -> (p <= radix * - q)%R -> Fbounded b p -> Fbounded b q -> Iminus (Iplus p q) p = (Iplus p q - p)%R :>R. intros p q H' H'0 H'1 H'2 H'3. apply MDekkerAux3; auto. rewrite <- (Fopp_Fopp q). change (Fbounded b (Fminus radix p (Fopp q))) in |- *. apply Sterbenz; auto. apply oppBounded; auto. apply Rmult_le_reg_l with (r := INR 2); auto with real arith. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real arith; rewrite Rmult_1_l; auto. rewrite Fopp_correct; auto. apply Rle_trans with (FtoRradix p); auto. apply Rledouble; auto. rewrite Fopp_correct; auto. Qed. Theorem Dekker3 : forall p q : float, (q <= 0)%R -> (radix * - q < p)%R -> Fbounded b p -> Fbounded b q -> Iminus (Iplus p q) p = (Iplus p q - p)%R :>R. intros p q H' H'0 H'1 H'2. apply MDekkerAux4; auto. apply Sterbenz; auto. apply IplusBounded; auto. apply (FmultRadixInv b radix precision) with (y := (p + q)%R); auto. apply Rmult_lt_reg_l with (r := INR 2); auto with real arith. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real arith; rewrite Rmult_1_l. replace (2%nat * (p + q))%R with (2%nat * p + 2%nat * q)%R; [ idtac | simpl in |- *; ring ]. apply Rplus_lt_reg_r with (r := (- FtoR radix p)%R). replace (- FtoR radix p + FtoR radix p)%R with 0%R; [ idtac | simpl in |- *; ring ]. replace (- FtoR radix p + (2%nat * p + 2%nat * q))%R with (p + 2%nat * q)%R; [ idtac | simpl in |- *; unfold FtoRradix in |- *; ring ]. apply Rplus_lt_reg_r with (r := (2%nat * - q)%R). replace (2%nat * - q + 0)%R with (2%nat * - q)%R; [ idtac | simpl in |- *; ring ]. replace (2%nat * - q + (p + 2%nat * q))%R with (FtoRradix p); [ idtac | simpl in |- *; ring ]; auto. apply (RoundedModeMult b radix) with (P := Closest b radix) (r := (p + q)%R); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply Rle_trans with (FtoR radix p); auto. replace (FtoR radix p) with (p + 0)%R; [ idtac | fold FtoRradix; ring ]. apply Rplus_le_compat_l; auto. apply Rledouble; auto. apply Rlt_le; auto. apply Rle_lt_trans with (2 := H'0). apply Rle_trans with (- q)%R; auto. replace 0%R with (-0)%R; auto with real. apply Rledouble; auto. replace 0%R with (-0)%R; auto with real. Qed. Theorem MDekkerAux5 : forall p q : float, Fbounded b p -> Fbounded b q -> Iminus (Iplus (Fopp p) (Fopp q)) (Fopp p) = (Iplus (Fopp p) (Fopp q) - Fopp p)%R :>R -> Iminus (Iplus p q) p = (Iplus p q - p)%R :>R. intros p q H' H'0 H'1. rewrite <- (Fopp_Fopp (Iminus (Iplus p q) p)); auto. repeat rewrite IminusPlus; auto. rewrite IplusOp; auto. rewrite <- IminusPlus. rewrite IplusOp; auto. unfold FtoRradix in |- *; rewrite Fopp_correct. unfold FtoRradix in H'1; rewrite H'1. rewrite <- IplusOp; auto. repeat rewrite Fopp_correct. ring. Qed. Theorem MDekker : forall p q : float, Fbounded b p -> Fbounded b q -> (Rabs q <= Rabs p)%R -> Iminus (Iplus p q) p = (Iplus p q - p)%R :>R. intros p q H' H'0 H'1. case (Rle_or_lt 0 p); intros Rl1. rewrite (Rabs_right p) in H'1; auto with real. case (Rle_or_lt 0 q); intros Rl2. rewrite (Rabs_right q) in H'1; auto with real. apply Dekker1; auto. rewrite (Faux.Rabsolu_left1 q) in H'1; auto with real. case (Rle_or_lt p (radix * - q)); intros Rl3. apply Dekker2; auto. apply Dekker3; auto. apply Rlt_le; auto. rewrite (Faux.Rabsolu_left1 p) in H'1; auto with real. apply MDekkerAux5; auto. case (Rle_or_lt 0 q); intros Rl2. rewrite (Rabs_right q) in H'1; auto with real. case (Rle_or_lt (- p) (radix * q)); intros Rl3. apply Dekker2; auto with float. unfold FtoRradix in |- *; rewrite Fopp_correct; auto. replace 0%R with (-0)%R; auto with real. unfold FtoRradix in |- *; repeat rewrite Fopp_correct; auto. rewrite Ropp_involutive; auto. unfold FtoRradix in |- *; repeat rewrite Fopp_correct; auto with real. rewrite Ropp_involutive; auto. apply Dekker3; auto with float. unfold FtoRradix in |- *; rewrite Fopp_correct; auto. replace 0%R with (-0)%R; auto with real. unfold FtoRradix in |- *; repeat rewrite Fopp_correct; auto. rewrite Ropp_involutive; auto. rewrite (Faux.Rabsolu_left1 q) in H'1; auto with real. apply Dekker1; auto with float. unfold FtoRradix in |- *; rewrite Fopp_correct; auto. replace 0%R with (-0)%R; auto with real. unfold FtoRradix in |- *; repeat rewrite Fopp_correct; auto. Qed. Theorem Dekker : forall p q : float, Fbounded b p -> Fbounded b q -> (Rabs q <= Rabs p)%R -> Iminus q (Iminus (Iplus p q) p) = (p + q - Iplus p q)%R :>R. intros p q H' H'0 H'1. apply MDekkerAux1; auto. apply MDekker; auto. Qed. End Fast.Float8.4/Expansions/Fexp.v0000644000423700002640000003362012032774526015275 0ustar sboldotoccataRequire Export AllFloat. Require Export List. Section mf. Variable b : Fbound. Variable radix : Z. Variable precision : nat. Coercion Local FtoRradix := FtoR radix. Hypothesis radixMoreThanOne : (1 < radix)%Z. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. (* because the flow of algorithm goes from the smallest element of the expansion to the biggest, expansion are defined as list of the smallest to the biggest *) Inductive IsExpansion : list float -> Prop := | IsExpansionNil : IsExpansion nil | IsExpansionSingle : forall x : float, Fbounded b x -> IsExpansion (x :: nil) | IsExpansionTop1 : forall (x : float) (L : list float), is_Fzero x -> Fbounded b x -> IsExpansion L -> IsExpansion (x :: L) | IsExpansionTop2 : forall (x y : float) (L : list float), Fbounded b x -> is_Fzero y -> Fbounded b y -> IsExpansion (x :: L) -> IsExpansion (x :: y :: L) | IsExpansionTop : forall (x y : float) (L : list float), ~ is_Fzero x -> ~ is_Fzero y -> Fbounded b x -> Fbounded b y -> (MSB radix x < LSB radix y)%Z -> IsExpansion (y :: L) -> IsExpansion (x :: y :: L). Theorem Zlt_MSB_LSB : forall x y : float, ~ is_Fzero y -> (MSB radix x < LSB radix y)%Z -> (Fabs x < Fabs y)%R. intros x y H' H'0; case (is_FzeroP x); intros F0. replace (FtoRradix (Fabs x)) with 0%R. case (Rabs_pos y). unfold FtoRradix in |- *; rewrite Fabs_correct; auto with arith. intros H'1; Contradict H'. apply is_Fzero_rep2 with (radix := radix); auto. generalize H'1; unfold Rabs in |- *; case (Rcase_abs y); auto with real. intros H'2 H'3; replace 0%R with (-0)%R; [ rewrite H'3 | idtac ]; fold FtoRradix;ring. unfold Fabs in |- *; rewrite F0; unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. case (Rle_or_lt (Fabs y) (Fabs x)); auto. intros H'1; Contradict H'0. apply Zle_not_lt; auto. apply Zle_trans with (MSB radix y). apply LSB_le_MSB; auto. apply MSB_monotone; auto. Qed. Theorem IsExpansion_comp1 : forall (L : list float) (x y : float), Fbounded b y -> x = y :>R -> IsExpansion (x :: L) -> IsExpansion (y :: L). simple induction L. intros x y H' H'0 H'1; apply IsExpansionSingle; auto. intros a l H' x y H'0 H'1 H'2; inversion H'2. apply IsExpansionTop1; auto. apply (is_Fzero_rep2 radix); auto with arith; unfold FtoRradix in H'1; rewrite <- H'1; apply is_Fzero_rep1; auto. apply IsExpansionTop2; auto. apply (H' x); auto. apply IsExpansionTop; auto. Contradict H2; apply (is_Fzero_rep2 radix); auto with arith; unfold FtoRradix in H'1; rewrite H'1; apply is_Fzero_rep1; auto. rewrite (MSB_comp radix) with (y := x); auto. Contradict H2; apply (is_Fzero_rep2 radix); auto with arith; unfold FtoRradix in H'1; rewrite H'1; apply is_Fzero_rep1; auto. Qed. Theorem IsExpansion_comp2 : forall (L : list float) (x y z : float), Fbounded b z -> y = z :>R -> IsExpansion (x :: y :: L) -> IsExpansion (x :: z :: L). intros L x y z H' H'0 H'1; inversion H'1. apply IsExpansionTop1; auto; apply IsExpansion_comp1 with y; auto. apply IsExpansionTop2; auto. apply (is_Fzero_rep2 radix); auto with arith; unfold FtoRradix in H'0; rewrite <- H'0; apply is_Fzero_rep1; auto. apply IsExpansionTop; auto. Contradict H3; apply (is_Fzero_rep2 radix); auto with arith; unfold FtoRradix in H'0; rewrite H'0; apply is_Fzero_rep1; auto. rewrite (LSB_comp radix) with (y := y); auto. Contradict H3; apply (is_Fzero_rep2 radix); auto with arith; unfold FtoRradix in H'0; rewrite H'0; apply is_Fzero_rep1; auto. apply IsExpansion_comp1 with (x := y); auto. Qed. Fixpoint expValue (L : list float) : float := match L with | nil => Fzero 0 | x :: L1 => Fplus radix x (expValue L1) end. Fixpoint expNormalize (L : list float) : list float := match L with | nil => nil | x :: L1 => match Fnum x with | Z0 => expNormalize L1 | Zpos p => x :: expNormalize L1 | Zneg p => x :: expNormalize L1 end end. Theorem expInv : forall (a : float) (L : list float), IsExpansion (a :: L) -> IsExpansion L. intros a L; generalize a; clear a; elim L; auto. intros a H'; apply IsExpansionNil. intros a l H' a0 H'0; inversion H'0; auto. apply IsExpansionTop1; auto. apply (H' a0); auto. Qed. Theorem expBoundedInv : forall (a : float) (L : list float), IsExpansion (a :: L) -> Fbounded b a. intros a L H'; inversion H'; auto. Qed. Theorem expNormalizeCorrect : forall L : list float, expValue L = expValue (expNormalize L) :>R. intros L; elim L; simpl in |- *; auto. intros a l H'; CaseEq (Fnum a); simpl in |- *; unfold FtoRradix in |- *; repeat rewrite Fplus_correct; auto with arith; unfold FtoRradix in H'; rewrite H'; auto. intros H'0; rewrite is_Fzero_rep1; auto; rewrite Rplus_0_l; auto. Qed. Theorem expNormalizeExp : forall L : list float, IsExpansion L -> IsExpansion (expNormalize L). intros L H'; elim H'; auto. simpl in |- *; apply IsExpansionNil; auto. simpl in |- *; intros a Ha; case (Fnum a); try apply IsExpansionNil; intros; apply IsExpansionSingle; auto. simpl in |- *; intros x L0 H'0 H'1 H'2 H'3; rewrite H'0; auto. intros x y L0 H'0 H'1 H'2 H'3; case (is_FzeroP x); intros Z0. simpl in |- *; rewrite Z0; rewrite H'1; auto. generalize Z0; unfold is_Fzero in |- *; simpl in |- *; case (Fnum x); try (intros tmp; case tmp; auto; fail); rewrite H'1; auto. intros x y L0 H'0 H'1 H'2 H'3 H'4 H'5; simpl in |- *; generalize H'0 H'1; unfold is_Fzero in |- *; case (Fnum x); try (intros tmp; case tmp; auto; fail); intros p H; case (Fnum y); try (intros tmp; case tmp; auto; fail); intros; apply IsExpansionTop; auto. Qed. (*A notion of expansion without zero*) Inductive IsNzExpansion : list float -> Prop := | IsNzExpansionNil : IsNzExpansion nil | IsNzExpansionSingle : forall x : float, ~ is_Fzero x -> Fbounded b x -> IsNzExpansion (x :: nil) | IsNzExpansionTop : forall (x y : float) (L : list float), ~ is_Fzero x -> ~ is_Fzero y -> Fbounded b x -> Fbounded b y -> (MSB radix x < LSB radix y)%Z -> IsNzExpansion (y :: L) -> IsNzExpansion (x :: y :: L). Theorem isNzExpansionIsExpansion : forall l : list float, IsNzExpansion l -> IsExpansion l. intros l H'; elim H'; simpl in |- *; auto. apply IsExpansionNil. intros x H'0 H'1; apply IsExpansionSingle; auto. intros x y L H'0 H'1 H'2 H'3 H'4 H'5 H'6. apply IsExpansionTop; auto. Qed. Theorem IsNzExpansionInv : forall (a : float) (l : list float), IsNzExpansion (a :: l) -> IsNzExpansion l. intros a l H'; inversion H'; auto. apply IsNzExpansionNil; auto. Qed. (*A notion of expansion without zero. in reverse order*) Inductive IsNzExpansionR : list float -> Prop := | IsNzExpansionNilR : IsNzExpansionR nil | IsNzExpansionSingleR : forall x : float, ~ is_Fzero x -> Fbounded b x -> IsNzExpansionR (x :: nil) | IsNzExpansionTopR : forall (x y : float) (L : list float), ~ is_Fzero x -> ~ is_Fzero y -> Fbounded b x -> Fbounded b y -> (MSB radix y < LSB radix x)%Z -> IsNzExpansionR (y :: L) -> IsNzExpansionR (x :: y :: L). Theorem isNzExpansionRIsNzExpansion : forall l : list float, IsNzExpansionR l -> IsNzExpansion (rev l). intros l H'; elim H'; simpl in |- *; auto. apply IsNzExpansionNil. exact IsNzExpansionSingle. intros x y L H'0 H'1 H'2 H'3 H'4 H'5; elim (rev L); simpl in |- *. intros H'6; apply IsNzExpansionTop; auto. apply IsNzExpansionSingle; auto. intros a l0; case l0; simpl in |- *. intros H'6 H'7; apply IsNzExpansionTop; auto. inversion H'7; auto. inversion H'7; auto. inversion H'7; auto. apply IsNzExpansionTop; auto. apply IsNzExpansionSingle; auto. intros f l1 H'6 H'7; apply IsNzExpansionTop; auto. inversion H'7; auto. inversion H'7; auto. inversion H'7; auto. inversion H'7; auto. inversion H'7; auto. apply H'6. inversion H'7; auto. Qed. Theorem IsNzExpansionRInv : forall (a : float) (l : list float), IsNzExpansionR (a :: l) -> IsNzExpansionR l. intros a l H'; inversion H'; auto. apply IsNzExpansionNilR; auto. Qed. Theorem mkIsNzAux : forall (n : nat) (p : float), (- dExp b <= LSB radix p)%Z -> (MSB radix p < - dExp b + n)%Z -> exists l : list float, IsNzExpansionR l /\ p = expValue l :>R /\ match l with | a :: _ => ToZeroP b radix p a | nil => True end. intros n; elim n. intros p H' H'0; case (is_FzeroP p); intros H'1. exists (nil (A:=float)); repeat split; simpl in |- *; auto. apply IsNzExpansionNilR. replace (FtoRradix (Fzero 0)) with 0%R. unfold FtoRradix in |- *; apply is_Fzero_rep1; auto. unfold FtoRradix, FtoR, Fzero in |- *; simpl in |- *; ring. absurd (LSB radix p <= MSB radix p)%Z. apply Zlt_not_le. apply Zlt_le_trans with (1 := H'0). replace (- dExp b + 0%nat)%Z with (- dExp b)%Z; [ auto | ring ]. apply LSB_le_MSB; auto. intros n0 H' p H'0 H'1. case (is_FzeroP p); intros H'2. exists (nil (A:=float)); repeat split; simpl in |- *; auto. apply IsNzExpansionNilR. replace (FtoRradix (Fzero 0)) with 0%R. unfold FtoRradix in |- *; apply is_Fzero_rep1; auto. unfold FtoRradix, FtoR, Fzero in |- *; simpl in |- *; ring. cut (TotalP (ToZeroP b radix)); [ intros tmp1; case (tmp1 (FtoRradix p)); clear tmp1; intros a Ha | apply ToZeroTotal with (precision := precision) ]; auto. cut (~ is_Fzero a); [ intros Na | idtac ]. 2: red in |- *; intros H'6; absurd (a = 0%R :>R). 2: apply (MSBBoundNotZero b radix precision) with (P := ToZeroP b radix) (f1 := p); auto. 2: apply ToZeroRoundedModeP with (precision := precision); auto. 2: Contradict H'2. 2: apply is_Fzero_rep2 with (radix := radix); auto. 2: apply Zle_trans with (1 := H'0). 2: apply LSB_le_MSB; auto. 2: unfold FtoRradix in |- *; apply is_Fzero_rep1; auto. case (is_FzeroP (Fminus radix p a)); intros H'3. exists (a :: nil); repeat split; auto. apply IsNzExpansionSingleR; auto. apply RoundedModeBounded with (radix := radix) (P := ToZeroP b radix) (r := FtoRradix p); auto. apply ToZeroRoundedModeP with (precision := precision); auto. simpl in |- *. replace (FtoRradix p) with (FtoRradix (Fplus radix (Fminus radix p a) a)). unfold FtoRradix in |- *; repeat rewrite Fplus_correct; auto with real arith. replace (FtoR radix (Fminus radix p a)) with 0%R. replace (FtoR radix (Fzero 0)) with 0%R. apply Rplus_comm. unfold FtoRradix, FtoR, Fzero in |- *; simpl in |- *; ring. apply sym_eq; apply is_Fzero_rep1; auto. unfold FtoRradix in |- *; repeat rewrite Fplus_correct; auto with real arith; repeat rewrite Fminus_correct; auto with real arith; ring. elim (H' (Fminus radix p a)); [ intros l E; elim E; intros H'7 H'8; elim H'8; intros H'9 H'10; clear H'8 E | idtac | idtac ]; auto. exists (a :: l); repeat split; auto. generalize H'7 H'10; case l. intros H'4 H'5; apply IsNzExpansionSingleR; auto. apply RoundedModeBounded with (radix := radix) (P := ToZeroP b radix) (r := FtoRradix p); auto. apply ToZeroRoundedModeP with (precision := precision); auto. intros f l0 H'4 H'5. apply IsNzExpansionTopR; auto. inversion H'4; auto. apply RoundedModeBounded with (radix := radix) (P := ToZeroP b radix) (r := FtoRradix p); auto. apply ToZeroRoundedModeP with (precision := precision); auto. inversion H'4; auto. replace (MSB radix f) with (MSB radix (Fminus radix p a)). apply (MSBroundLSB b radix precision) with (P := ToZeroP b radix); auto. apply ToZeroRoundedModeP with (precision := precision); auto. apply (MSBtoZero b radix precision); auto. inversion H'4; auto. simpl in |- *; unfold FtoRradix in |- *; rewrite Fplus_correct; auto with arith. unfold FtoRradix in H'9; rewrite <- H'9. rewrite Fminus_correct; auto with arith; ring. apply Zle_trans with (Zmin (LSB radix p) (LSB radix a)). apply Zmin_Zle; auto. apply Zle_trans with (Fexp a). cut (Fbounded b a); [ auto with float | idtac ]. apply RoundedModeBounded with (radix := radix) (P := ToZeroP b radix) (r := FtoRradix p); auto. apply ToZeroRoundedModeP with (precision := precision); auto. apply Fexp_le_LSB; auto. apply LSBMinus; auto. apply Zlt_le_trans with (LSB radix a). apply (MSBroundLSB b radix precision) with (P := ToZeroP b radix); auto. apply ToZeroRoundedModeP with (precision := precision); auto. apply Zle_trans with (MSB radix a); auto. apply LSB_le_MSB; auto. rewrite <- (MSBtoZero b radix precision) with (f1 := p) (f2 := a); auto. apply Zlt_succ_le. replace (Zsucc (- dExp b + n0)) with (- dExp b + S n0)%Z; auto. rewrite inj_S; unfold Zsucc in |- *; ring. Qed. Theorem expValueApp : forall l1 l2 : list float, expValue (l1 ++ l2) = (expValue l1 + expValue l2)%R :>R. intros l1; elim l1; simpl in |- *; auto. intros l2; unfold FtoRradix, FtoR, Fzero in |- *; simpl in |- *; ring. intros a l H' l2. unfold FtoRradix in |- *; repeat rewrite Fplus_correct; auto with zarith. rewrite H'; unfold FtoRradix in |- *; ring. Qed. Theorem expValueRev : forall l : list float, expValue (rev l) = expValue l :>R. intros l; elim l; simpl in |- *; auto. intros a l0 H'; rewrite expValueApp; simpl in |- *. rewrite H'. unfold FtoRradix in |- *; repeat rewrite Fplus_correct; auto with zarith. replace (FtoR radix (Fzero 0)) with 0%R; [ ring | idtac ]. unfold FtoRradix, FtoR, Fzero in |- *; simpl in |- *; ring. Qed. Theorem existExp : forall p : float, (- dExp b <= LSB radix p)%Z -> exists l : list float, IsExpansion l /\ p = expValue l :>R. intros p H'. elim (mkIsNzAux ( Zabs_nat (dExp b)+1 + Zabs_nat (MSB radix p)) p); [ intros l E; elim E; intros H'3 H'4; elim H'4; intros H'5 H'6; clear H'4 E | idtac | idtac ]; auto. exists (rev l); split; auto. apply isNzExpansionIsExpansion. apply isNzExpansionRIsNzExpansion; auto. rewrite expValueRev; auto. apply Zle_lt_trans with (Z_of_nat (Zabs_nat (MSB radix p))). rewrite <- Zabs_absolu. case (MSB radix p); simpl in |- *; auto with zarith; intros; unfold Zle in |- *; simpl in |- *; red in |- *; intros; discriminate. rewrite inj_plus. rewrite inj_plus. rewrite <- (Zabs_absolu (Z_of_N (dExp b))). rewrite Zabs_eq; [idtac|case (dExp b)]; auto with zarith. rewrite Zplus_assoc. replace (- dExp b + (dExp b + S 0))%Z with (Zsucc 0). auto with zarith. ring. Qed. End mf.Float8.4/Expansions/Fexp2.v0000644000423700002640000003076412032774526015365 0ustar sboldotoccata(**************************************************************************** IEEE754 : Fexp2 Sylvie Boldo ******************************************************************************) Require Export ThreeSumProps. Require Export List. Section Fexp2. Variable b : Fbound. Variable precision : nat. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Hypothesis Ngd : (1 <= pPred (vNum b) * (1 - / radix))%R. Hypothesis Ngd2 : (6%nat <= pPred (vNum b) * (1 - / radix * / radix))%R. Inductive IsExp : list float -> Prop := | IsExpNil : IsExp nil | IsExpSingle : forall x : float, Fbounded b x -> IsExp (x :: nil) | IsExpTop : forall (x y : float) (L : list float), Fbounded b x -> Fbounded b y -> (Fexp y <= Fexp x)%Z -> IsExp (y :: L) -> IsExp (x :: y :: L). Hint Resolve IsExpNil IsExpSingle IsExpTop. Inductive NearEqual : list float -> list float -> Prop := | IsEqual : forall x : list float, NearEqual x x | OneMoreR : forall (x : list float) (e : float), Fbounded b e -> NearEqual x (e :: x). Hint Resolve IsEqual OneMoreR. Fixpoint sum (L : list float) : R := match L with | nil => 0%R | x :: L1 => (FtoRradix x + sum L1)%R end. Definition hdexp (L : list float) := match L with | nil => (- dExp b)%Z | x :: L1 => Fexp x end. Fixpoint lastexp (L : list float) : Z := match L with | nil => (- dExp b)%Z | x :: nil => Fexp x | x :: L1 => lastexp L1 end. Definition hd (L : list float) := match L with | nil => Fzero (- dExp b) | x :: L1 => x end. Theorem IsExpZle : forall (i : float) (L : list float), IsExp (i :: L) -> (hdexp L <= Fexp i)%Z. simple induction L; simpl in |- *. intros H; cut (Fbounded b i). intros H'; case H'; auto. inversion H; auto. intros a l H H0; inversion H0; auto. Qed. Theorem isExpInv : forall (x y : float) (L : list float), IsExp (x :: y :: L) -> IsExp (y :: L). intros x y L H; inversion H; auto. Qed. Theorem isExpSkip : forall (x y : float) (L : list float), IsExp (x :: y :: L) -> IsExp (x :: L). intros x y L; case L; simpl in |- *. intros H1; apply IsExpSingle; inversion H1; auto. intros f l H1; apply IsExpTop; inversion H1; (cut (IsExp (y :: f :: l)); [ intros T2; inversion T2 | idtac ]); auto. apply Zle_trans with (Fexp y); auto. Qed. Theorem sum_IsExp : forall (L : list float) (x : float) (m : R), IsExp (x :: L) -> (Float (pPred (vNum b)) (Fexp x) <= m)%R -> (Rabs (sum (x :: L)) <= length (x :: L) * m)%R. intros L x m H H0. replace (sum (x :: L)) with (x + sum L)%R; [ idtac | simpl in |- *; auto with real ]. apply Rle_trans with (Rabs x + Rabs (sum L))%R; [ apply Rabs_triang | replace (INR (length (x :: L))) with (1 + length L)%R ]. replace ((1 + length L) * m)%R with (m + length L * m)%R; [ idtac | ring ]. apply Rle_trans with (m + Rabs (sum L))%R. apply Rplus_le_compat_r. apply Rle_trans with (FtoR radix (Float (pPred (vNum b)) (Fexp x))); [ rewrite <- (Fabs_correct radix); auto with zarith; apply maxMax1; auto with zarith | idtac ]; auto. inversion H; auto. apply Rplus_le_compat_l. induction L as [| a L HrecL]. simpl in |- *; rewrite Rabs_R0; auto with real. replace (sum (a :: L)) with (a + sum L)%R; [ idtac | simpl in |- *; auto with real ]. apply Rle_trans with (Rabs a + Rabs (sum L))%R; [ apply Rabs_triang | replace (INR (length (a :: L))) with (1 + length L)%R ]. replace ((1 + length L) * m)%R with (m + length L * m)%R; [ idtac | ring ]. apply Rle_trans with (m + Rabs (sum L))%R. apply Rplus_le_compat_r. apply Rle_trans with (FtoR radix (Float (pPred (vNum b)) (Fexp a))); [ rewrite <- (Fabs_correct radix); auto with zarith; apply maxMax1; auto with zarith | idtac ]; auto. inversion H; auto. apply Rle_trans with (FtoRradix (Float (pPred (vNum b)) (Fexp x))); auto. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *. apply Rmult_le_compat_l; auto with real zarith. apply (Rle_IZRO 0); apply Zlt_le_weak; apply (pPredMoreThanOne b radix) with (precision := precision); auto with real zarith. replace 2%R with (IZR radix); auto with real zarith. inversion H; auto with real zarith. apply Rle_powerRZ; auto with real zarith. apply Rplus_le_compat_l. apply HrecL. apply isExpSkip with (y := a); auto. rewrite (Rplus_comm 1 (length L)); simpl in |- *; auto with real arith. case (length L); intros; auto with real arith. rewrite (Rplus_comm 1 (length L)); simpl in |- *; auto with real arith. case (length L); intros; auto with real arith. Qed. Inductive IsRleExp : list float -> Prop := | IsRleExpNil : IsRleExp nil | IsRleExpSingle : forall x : float, Fbounded b x -> IsRleExp (x :: nil) | IsRleExpTop : forall (x y : float) (L : list float), Fbounded b x -> Fbounded b y -> (Rabs x <= Rabs y)%R -> IsRleExp (y :: L) -> IsRleExp (x :: y :: L). Hint Resolve IsRleExpNil IsRleExpSingle IsRleExpTop. Inductive EqListFloat : list float -> list float -> Prop := | EqListFloatnil : EqListFloat nil nil | EqListFloatTop : forall (x y : float) (L L' : list float), Fbounded b x -> Fbounded b y -> x = y :>R -> EqListFloat L L' -> EqListFloat (x :: L) (y :: L'). Hint Resolve EqListFloatnil EqListFloatTop. Theorem sum_app : forall (L : list float) (x : float), (x + sum L)%R = sum (L ++ x :: nil) :>R. intros L x; induction L as [| a L HrecL]; simpl in |- *; auto. replace (x + (a + sum L))%R with (a + (x + sum L))%R; [ rewrite HrecL | ring ]; auto. Qed. Theorem cons_neq : forall (x : float) (L : list float), x :: L <> L :>list float. intros x L; red in |- *; intros H; absurd (length L < length (x :: L)). rewrite H; auto with arith. simpl in |- *; auto with arith. Qed. Definition endof (all part : list float) := exists rest : list float, all = rest ++ part. Theorem app_length : forall l1 l2 : list float, length (l1 ++ l2) = length l1 + length l2. intros l1; induction l1 as [| a l1 Hrecl1]; simpl in |- *; auto. Qed. Theorem endof_length : forall L l : list float, endof L l -> length l <= length L. intros L l H; case H. intros x H0; rewrite H0. rewrite (app_length x l); auto with arith. Qed. Inductive IsCanExp : list float -> Prop := | IsCanExpNil : IsCanExp nil | IsCanExpTop : forall (x : float) (L : list float), Fcanonic radix b x -> IsCanExp L -> IsCanExp (x :: L). Hint Resolve IsCanExpNil IsCanExpTop. Theorem IsCanExpBounded : forall (i : float) (L : list float), IsCanExp (i :: L) -> Fbounded b i. intros i L H; try apply FcanonicBound with radix. inversion H; auto. Qed. Inductive IsRleExpRev : list float -> Prop := | IsRleExpRevNil : IsRleExpRev nil | IsRleExpRevSingle : forall x : float, Fbounded b x -> IsRleExpRev (x :: nil) | IsRleRevExpTop : forall (x y : float) (L : list float), Fbounded b x -> Fbounded b y -> (Rabs y <= Rabs x)%R -> IsRleExpRev (y :: L) -> IsRleExpRev (x :: y :: L). Hint Resolve IsRleExpRevNil IsRleExpRevSingle IsRleRevExpTop. Theorem IsRleExpRevComp : forall L1 L2, EqListFloat L1 L2 -> IsRleExpRev L1 -> IsRleExpRev L2. intros L1 L2 H; elim H; auto. intros x y L L' H0 H1 H2 H3; inversion H3; auto. intros H10 H11; apply IsRleRevExpTop; auto. rewrite <- H6; rewrite <- H2; inversion H11; auto. inversion H11; auto. Qed. Theorem IsRleExpRevIsExp : forall L : list float, IsRleExpRev L -> exists L' : list float, IsCanExp L' /\ IsRleExpRev L' /\ EqListFloat L L' /\ IsExp L'. intros L; induction L as [| a L HrecL]. intros H1; exists (nil (A:=float)); repeat split; [ apply IsCanExpNil | apply IsRleExpRevNil | apply EqListFloatnil | apply IsExpNil ]. intros H2; case HrecL; auto. inversion H2; auto; apply IsRleExpRevNil. intros L' (H'1, (H'2, (H'3, H'4))). cut (Fbounded b a); [ intros Ba | inversion H2; auto ]. cut (Fcanonic radix b (Fnormalize radix b precision a)); [ intros CNa | apply FnormalizeCanonic; auto with zarith ]. cut (Fbounded b (Fnormalize radix b precision a)); [ intros BNa | apply FnormalizeBounded; auto with zarith ]. cut (Fnormalize radix b precision a = a :>R); [ intros Eq1 | unfold FtoRradix in |- *; apply FnormalizeCorrect; auto with zarith ]. exists (Fnormalize radix b precision a :: L'); repeat split; auto. generalize H'2 H'3; case L'; simpl in |- *; auto. intros f l H'0 H'5; apply IsRleRevExpTop; auto. inversion H'0; auto. rewrite Eq1; inversion H2. cut (IsRleExpRev (a :: f :: l)); [ intros Z1; inversion Z1; auto | idtac ]. apply IsRleExpRevComp with (L1 := a :: L); auto. cut (IsRleExpRev (a :: f :: l)); [ intros Z1; inversion Z1; auto | idtac ]. apply IsRleExpRevComp with (L1 := a :: L); auto. generalize H'4 H'3 H'2 H'1; case L'; simpl in |- *; auto. intros f l H'0 H'5 H'6 H'7; apply IsExpTop; auto. inversion H'6; auto. apply Fcanonic_Rle_Zle with radix b precision; auto with zarith. inversion H'7; auto. fold FtoRradix in |- *; rewrite Eq1. cut (IsRleExpRev (a :: f :: l)); [ intros Z1; inversion Z1; auto | idtac ]. apply IsRleExpRevComp with (L1 := a :: L); auto. Qed. Fixpoint last (L : list float) : float := match L with | nil => Fzero (- dExp b) | x :: nil => x | x :: L1 => last L1 end. Theorem ExpRev_aux : forall (l : list float) (x : float), Fbounded b x -> IsRleExpRev l -> (Rabs x <= Rabs (last l))%R -> IsRleExpRev (l ++ x :: nil). intros l; elim l; simpl in |- *; auto. intros a l0; case l0. intros H x H0 H1 H2; simpl in |- *; auto. apply IsRleRevExpTop; auto. inversion H1; auto. intros f l1 H x H0 H1 H2; simpl in |- *; auto. apply IsRleRevExpTop; auto. inversion H1; auto. cut (IsRleExpRev (f :: l1)); [ intros Z1; inversion Z1 | inversion H1 ]; auto. inversion H1; auto. change (IsRleExpRev ((f :: l1) ++ x :: nil)) in |- *; apply H; auto. inversion H1; auto. Qed. Theorem Exp_aux : forall (l : list float) (x : float), Fbounded b x -> IsRleExp l -> (Rabs (last l) <= Rabs x)%R -> IsRleExp (l ++ x :: nil). intros l; elim l; simpl in |- *; auto. intros a l0; case l0. intros H x H0 H1 H2; simpl in |- *; auto. apply IsRleExpTop; auto. inversion H1; auto. intros f l1 H x H0 H1 H2; simpl in |- *. apply IsRleExpTop; auto. inversion H1; auto. cut (IsRleExp (f :: l1)); [ intros Z1; inversion Z1 | inversion H1 ]; auto. inversion H1; auto. change (IsRleExp ((f :: l1) ++ x :: nil)) in |- *; auto. apply H; auto. inversion H1; auto. Qed. Theorem last_hd : forall l : list float, last l = hd (rev l). intros l; elim l; simpl in |- *; auto. intros a l0; case l0; auto. intros f l1 H; rewrite H; cut (rev (f :: l1) <> nil). case (rev (f :: l1)); simpl in |- *; auto; intros Z1; case Z1; auto. case l1; simpl in |- *; auto. red in |- *; intros H0; discriminate. intros f0 l2; case (rev l2); simpl in |- *; intros; red in |- *; intros; discriminate. Qed. Theorem IsRleExpRev_IsRleExp : forall l : list float, IsRleExpRev l -> IsRleExp (rev l). intros l; elim l; simpl in |- *; auto. intros a l0; case l0. simpl in |- *; auto. intros H H0; apply IsRleExpSingle; auto; inversion H0; auto. intros f l1 H H0; apply Exp_aux; auto. inversion H0; auto. apply H; auto. inversion H0; auto. replace (last (rev (f :: l1))) with f; [ inversion H0; auto | auto ]. rewrite (last_hd (rev (f :: l1))). rewrite (rev_involutive (f :: l1)); auto. Qed. Theorem IsRleExp_IsRleExpRev : forall l : list float, IsRleExp l -> IsRleExpRev (rev l). intros l; elim l; simpl in |- *; auto. intros a l0; case l0. intros H H0; simpl in |- *; apply IsRleExpRevSingle; inversion H0; auto. intros f l1 H H0; apply ExpRev_aux; auto. inversion H0; auto. apply H. inversion H0; auto. replace (last (rev (f :: l1))) with f; [ inversion H0; auto | auto ]. rewrite (last_hd (rev (f :: l1))). rewrite (rev_involutive (f :: l1)); auto. Qed. Theorem EqListFloat_length : forall l l' : list float, EqListFloat l l' -> length l = length l'. intros l l' H; elim H; simpl in |- *; auto. Qed. Theorem EqListFloat_sum : forall l l' : list float, EqListFloat l l' -> sum l = sum l' :>R. intros l l' H; elim H; simpl in |- *; auto. intros x y L L' H0 H1 H2 H3 H4; rewrite H4; rewrite H2; auto. Qed. Theorem rev_sum : forall l : list float, sum l = sum (rev l) :>R. intros l; elim l; simpl in |- *; auto. intros a l0 H; rewrite H. apply sum_app. Qed. Theorem rev_length : forall l : list float, length l = length (rev l). intros l; elim l; simpl in |- *; auto. intros a l0 H; rewrite H; rewrite app_length; simpl in |- *; ring. Qed. End Fexp2.Float8.4/Expansions/FexpAdd.v0000644000423700002640000013223212032774526015705 0ustar sboldotoccata(**************************************************************************** IEEE754 : FexpAdd Sylvie Boldo ******************************************************************************) Require Export Fexp2. Section FexpAdd. Variable b : Fbound. Variable precision : nat. Let radix := 2%Z. Let TMTO : (1 < radix)%Z := TwoMoreThanOne. Hint Resolve TMTO: zarith. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Hypothesis Ngd : (1 <= pPred (vNum b) * (1 - / radix))%R. Hypothesis Ngd2 : (6%nat <= pPred (vNum b) * (1 - / radix * / radix))%R. Inductive NearEqual : list float -> list float -> Prop := | IsEqual : forall x : list float, NearEqual x x | OneMoreR : forall (x : list float) (e : float), Fbounded b e -> NearEqual x (e :: x). Hint Resolve IsEqual OneMoreR. Definition Step (x y i x' y' : float) (input output output' : list float) := Fbounded b x' /\ Fbounded b y' /\ NearEqual output output' /\ (x + (y + (sum (i :: input) + sum output)))%R = (x' + (y' + (sum input + sum output')))%R :>R /\ (Fexp i <= Fexp y')%Z /\ (Fexp y' <= Fexp x')%Z /\ IsExp b (i :: input) /\ (x' = 0%R :>R \/ y' = 0%R :>R \/ (Rabs y' <= pPred (vNum b) * (Float 1%nat (Fexp x') - Float 1%nat (hdexp b input)))%R /\ (Rabs y' <= pPred (vNum b) * (Float 1%nat (Fexp x') - Float 1%nat (Fexp i)))%R) /\ (output' = output \/ (Rabs (x' + y') <= 3%nat * radix * / pPred (vNum b) * Rabs (hd b output'))%R) /\ (output' = nil \/ (Rabs (hd b input) <= 3%nat * (radix * (Rabs (hd b output') * / (pPred (vNum b) - 1%nat))))%R /\ (input = nil \/ (Float (pPred (vNum b)) (Fexp (hd b input)) <= 3%nat * (radix * (Rabs (hd b output') * / (pPred (vNum b) - 1%nat))))%R /\ (Rabs (sum input) <= length input * (3%nat * (radix * (Rabs (hd b output') * / (pPred (vNum b) - 1%nat)))))%R)). Theorem Rle_mult_pos : forall r1 r2 : R, (0 <= r1)%R -> (0 <= r2)%R -> (0 <= r1 * r2)%R. intros r1 r2 H H0; replace 0%R with (0 * 0)%R; auto with real. Qed. Theorem AddStep : forall (x y i : float) (input output : list float), Fbounded b x -> Fbounded b y -> IsExp b (i :: input) -> (Fexp i <= Fexp y)%Z -> (Fexp y <= Fexp x)%Z -> (FtoR radix x = 0%R :>R \/ FtoR radix y = 0%R :>R \/ FtoR radix i = 0%R :>R) \/ (Rabs (FtoR radix y) <= pPred (vNum b) * (FtoR radix (Float 1%nat (Fexp x)) - FtoR radix (Float 1%nat (Fexp i))))%R -> output = nil \/ (Rabs i <= 3%nat * (radix * (Rabs (hd b output) * / (pPred (vNum b) - 1%nat))))%R /\ (Float (pPred (vNum b)) (Fexp i) <= 3%nat * (radix * (Rabs (hd b output) * / (pPred (vNum b) - 1%nat))))%R /\ (Rabs (sum (i :: input)) <= length (i :: input) * (3%nat * (radix * (Rabs (hd b output) * / (pPred (vNum b) - 1%nat)))))%R -> exists x' : float, (exists y' : float, (exists output' : list float, Step x y i x' y' input output output')). cut (1 < pPred (vNum b))%Z; [ intros Z1 | apply Zlt_trans with radix; auto with zarith; apply (pPredMoreThanRadix b radix precision); auto with zarith ]. cut (0 < pPred (vNum b) - 1)%R; [ intros Z2 | replace 1%R with (IZR 1); auto with real zarith ]. cut (0 < pPred (vNum b))%Z; [ intros Z3 | auto with real zarith ]. intros x y i input output H H0 H1 H2 H3 H4 G. cut (Fbounded b i); [ intros K | inversion H1; auto ]. cut (TotalP (Closest b radix)); [ intros ExC | apply (ClosestTotal b radix precision); auto ]. cut (RoundedModeP b radix (Closest b radix)); [ intros Rc | apply (ClosestRoundedModeP b radix precision); auto ]. case (ExC (y + i)%R); intros u Hu. cut (Fbounded b u); [ intros Bu | apply RoundedModeBounded with radix (Closest b radix) (y + i)%R; auto ]. case (ExC (x + u)%R); intros p' Hp'. cut (Fbounded b p'); [ intros Bp' | apply RoundedModeBounded with radix (Closest b radix) (x + u)%R; auto ]. case (ExC (x + u - p' + (y + i - u))%R); intros q' Hq'. cut (Fbounded b q'); [ intros Bq' | apply RoundedModeBounded with radix (Closest b radix) (x + u - p' + (y + i - u))%R; auto ]. case (errorBoundedPlus b radix precision TMTO precisionGreaterThanOne pGivesBound y i u); auto. intros v (H'1, (H'2, H'3)). case (errorBoundedPlus b radix precision TMTO precisionGreaterThanOne pGivesBound x u p'); auto. intros w (H'4, (H'5, H'6)). case (errorBoundedPlus b radix precision TMTO precisionGreaterThanOne pGivesBound w v q'); auto. replace (FtoR radix v) with (FtoR radix y + FtoR radix i - FtoR radix u)%R; replace (FtoR radix w) with (FtoR radix x + FtoR radix u - FtoR radix p')%R; auto with real. intros r' (H'7, (H'8, H'9)). case (ThreeSumLoop b precision precisionGreaterThanOne pGivesBound x y i u v w p' q' r'); auto. fold radix in |- *; replace (FtoR radix v) with (FtoR radix y + FtoR radix i - FtoR radix u)%R; replace (FtoR radix w) with (FtoR radix x + FtoR radix u - FtoR radix p')%R; auto with real. intros p'' (q'', (r'', ((H''0, (H''1, H''2)), (((H''3, (H''4, H''5)), (H''6, ((H''7, H''8), H''9))), [(Hr', H''10)| (Hr', H''10)])))). exists p''; exists q''; exists output; repeat (split; auto). replace (p'' + (q'' + (sum input + sum output)))%R with (p'' + (q'' + r'') + (sum input + sum output))%R; [ idtac | ring_simplify ]. replace (p'' + (q'' + r''))%R with (x + (y + i))%R; replace (sum (i :: input)) with (i + sum input)%R. ring. simpl in |- *; auto with real. replace (FtoRradix r'') with (FtoRradix r'); replace (FtoRradix r') with (w + v - q')%R; auto with real. replace (FtoRradix q') with (FtoRradix q''); auto with real. replace (FtoRradix p'') with (FtoRradix p'); auto with real. replace (FtoRradix w) with (FtoR radix x + FtoR radix u - FtoR radix p')%R. replace (FtoRradix v) with (y + i - u)%R; auto with real. unfold FtoRradix in |- *; ring; ring. simpl in |- *; auto with real. replace (FtoRradix r'') with (FtoRradix r'); replace (FtoRradix r') with 0%R; auto with real; ring. apply Zle_trans with (Fexp r''); auto. case (Req_dec p'' 0); intros; auto. case H''10; auto; intros H''11. right; right; split; auto. apply Rle_trans with (pPred (vNum b) * (FtoR radix (Float 1%nat (Fexp p'')) - FtoR radix (Float 1%nat (Fexp i))))%R; auto. apply Rmult_le_compat_l; auto with real arith. fold FtoRradix in |- *; replace (Float 1%nat (Fexp p'') - Float 1%nat (hdexp b input))%R with (Float 1%nat (Fexp p'') + - Float 1%nat (hdexp b input))%R; replace (Float 1%nat (Fexp p'') - Float 1%nat (Fexp i))%R with (Float 1%nat (Fexp p'') + - Float 1%nat (Fexp i))%R; try ring. apply Rplus_le_compat_l. apply Ropp_le_contravar; unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *. repeat rewrite Rmult_1_l. apply Rle_powerRZ; auto with real zarith. apply IsExpZle; auto. case G; clear G; auto. generalize H1; clear H1; case input. simpl in |- *; intros H1 (Hc1, (Hc2, Hc3)); right. split; auto. unfold FtoRradix, FtoR, Fzero in |- *; simpl in |- *; rewrite Rmult_0_l; rewrite Rabs_R0; repeat apply Rle_mult_pos; auto with real zarith. intros f l H1 (Hc1, (Hc2, Hc3)); right. cut (Fbounded b f); [ intros Bf | idtac ]. cut (Float (pPred (vNum b)) (Fexp f) <= 3%nat * (radix * (Rabs (FtoRradix (hd b output)) * / (pPred (vNum b) - 1%nat))))%R; [ intros HZ1 | idtac ]. cut (FtoRradix (Float (pPred (vNum b)) (Fexp f)) <= FtoRradix (Float (pPred (vNum b)) (Fexp i)))%R; [ intros HZ2 | idtac ]. split. apply Rle_trans with (2 := HZ1); auto with real zarith. simpl in |- *; (rewrite <- (Fabs_correct radix); auto with real zarith); apply (maxMax1 radix); auto with real zarith. right; split; auto. apply sum_IsExp with b precision; auto. inversion H1; auto with real zarith. unfold FtoRradix, FtoR in |- *; simpl in |- *; apply Rmult_le_compat_l; auto with real zarith. apply Rle_powerRZ; auto with real zarith. inversion H1; auto with real zarith. apply Rle_trans with (2 := Hc2); auto with real zarith. unfold FtoRradix, FtoR in |- *; simpl in |- *; apply Rmult_le_compat_l; auto with real zarith. apply Rle_powerRZ; auto with real zarith. inversion H1; auto with real zarith. inversion H1; auto. exists q''; exists r''; exists (p'' :: output); repeat (split; auto). simpl in |- *. replace (FtoRradix q'' + (FtoRradix r'' + (sum input + (FtoR 2 p'' + sum output))))%R with (p'' + (q'' + r'') + (sum input + sum output))%R; [ idtac | ring_simplify ]. replace (p'' + (q'' + r''))%R with (x + (y + i))%R; [ fold radix; fold FtoRradix; ring | idtac ]. replace (FtoRradix r'') with (FtoRradix r'); replace (FtoRradix r') with (w + v - q')%R; auto with real. replace (FtoRradix w) with (FtoR radix x + FtoR radix u - FtoR radix p')%R. replace (FtoRradix v) with (y + i - u)%R; auto with real. replace (FtoRradix p'') with (FtoR 2 p'); replace (FtoRradix q'') with (FtoRradix q'); fold radix FtoRradix in |- *; ring. simpl in |- *; fold radix FtoRradix in |- *; ring. right; right; split; auto. apply Rle_trans with (1 := H''10). apply Rmult_le_compat_l; auto with real zarith. unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_contravar. apply (oneExp_le radix); auto with real zarith. apply IsExpZle; auto. right; simpl in |- *. apply Rlt_le; fold radix in |- *; unfold FtoRradix in |- *; apply bound3Sum with (precision := precision) (w := w) (v := v) (p := x) (q := y) (r := i) (u := u); auto; fold radix FtoRradix in |- *. apply (ClosestCompatible b radix (x + u)%R (x + u)%R p'); auto with real. replace (FtoRradix p'') with (FtoR radix p'); auto with real. apply (ClosestCompatible b radix (w + v)%R (w + v)%R q'); auto with real. replace (FtoRradix w) with (x + u - p')%R; replace (FtoRradix v) with (y + i - u)%R; auto with real. replace (FtoRradix r'') with (FtoRradix r'); replace (FtoRradix q'') with (FtoRradix q'); auto with real. replace (FtoRradix r'') with (FtoRradix r'); auto with real. right; simpl in |- *. cut (forall z : float, (Fexp z <= Fexp i)%Z -> Fbounded b z -> (Rabs z <= 3%nat * (radix * (Rabs p'' * / (pPred (vNum b) - 1%nat))))%R); [ intros Hz1 | idtac ]. split; [ apply Hz1; auto with zarith | idtac ]. replace (Fexp (hd b input)) with (hdexp b input). apply IsExpZle; auto. case input; simpl in |- *; auto with zarith. generalize H1; case input; intros; simpl in |- *. apply FboundedFzero. inversion H5; auto. generalize H1; clear H1; case input; auto. intros f l H1; right. cut (Float (pPred (vNum b)) (Fexp f) <= 3%nat * (radix * (Rabs p'' * / (pPred (vNum b) - 1%nat))))%R; [ intros Hz2 | idtac ]. split. simpl in |- *; auto. apply sum_IsExp with b precision; auto. inversion H1; auto. rewrite <- (fun x : float => Rabs_pos_eq x); auto with real zarith. apply Hz1; auto with real zarith. simpl in |- *; inversion H1; auto. unfold pPred in |- *; apply maxFbounded; auto. cut (Fbounded b f); [ intros tmp; case tmp | idtac ]; auto. cut (IsExp b (f :: l)); [ intros tmp; inversion tmp | inversion H1 ]; auto. auto with float zarith. apply (LeFnumZERO radix); auto with real zarith. intros z H5 H6; apply Rle_trans with (FtoRradix (Float (pPred (vNum b)) (Fexp z))). rewrite <- (Fabs_correct radix); auto with real zarith; apply (maxMax1 radix); auto with real zarith. replace (FtoRradix (Float (pPred (vNum b)) (Fexp z))) with (pPred (vNum b) * powerRZ radix (Fexp z))%R; [ idtac | auto with real zarith ]. replace (3%nat * (radix * (Rabs p'' * / (pPred (vNum b) - 1%nat))))%R with (pPred (vNum b) * (3%nat * (radix * (radix * (Rabs p'' * / (pPred (vNum b) * (radix * pPred (vNum b) - radix)))))))%R. apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (FtoRradix (Float 1%nat (Fexp i))). unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *; rewrite Rmult_1_l; auto with real zarith. apply Rle_powerRZ; auto with real zarith. apply Rlt_le; apply OutSum3 with (precision := precision) (p := x) (q := y) (r := i) (u := u) (v := v) (w := w) (p' := p'') (q' := q'') (r' := r''); auto with real arith; fold radix FtoRradix in |- *. apply (ClosestCompatible b radix (x + u)%R (x + u)%R p'); auto with real. replace (FtoRradix p'') with (FtoRradix p'); auto with real. apply (ClosestCompatible b radix (w + v)%R (w + v)%R q'); auto with real. replace (FtoRradix w) with (x + u - p')%R; replace (FtoRradix v) with (y + i - u)%R; auto with real. replace (FtoRradix r'') with (FtoRradix r'); replace (FtoRradix q'') with (FtoRradix q'); auto with real. replace (FtoRradix r'') with (FtoRradix r'); auto with real. replace (radix * pPred (vNum b) - radix)%R with (radix * (pPred (vNum b) - 1%nat))%R; [ idtac | simpl; ring ]. repeat rewrite Rinv_mult_distr; auto with real zarith. pattern (INR 3) at 2 in |- *; replace (INR 3) with (radix * / radix * (pPred (vNum b) * / pPred (vNum b) * 3%nat))%R; [ simpl in |- *; ring | idtac ]. repeat rewrite Rinv_r; auto with real zarith; simpl in |- *; ring. Qed. Variable input : list float. Inductive IsRleEpsExp : list float -> Prop := | IsRleEpsExpNil : IsRleEpsExp nil | IsRleEpsExpSingle : forall x : float, Fbounded b x -> IsRleEpsExp (x :: nil) | IsRleEpsExpTop : forall (x y : float) (L : list float), Fbounded b x -> Fbounded b y -> (Rabs x <= (6%nat * length input + 6%nat) * / (pPred (vNum b) - 1%nat - 6%nat * length input) * Rabs y)%R -> IsRleEpsExp (y :: L) -> IsRleEpsExp (x :: y :: L). Theorem endof_Rle_length : forall (P Q : list float) (k : float), endof input (P ++ k :: Q) -> (length P <= length input - 1)%R. intros P Q k H; inversion H. rewrite H0; repeat rewrite app_length; simpl in |- *. replace 1%R with (INR 1); [ idtac | simpl in |- *; auto ]. replace (length x + (length P + S (length Q))) with (S (length P) + (length Q + length x)); [ idtac | repeat rewrite (fun x : list float => S_to_plus_one (length x)); ring ]. rewrite <- minus_INR; simpl in |- *; try apply Rle_INR; auto with arith. rewrite <- minus_n_O; auto with arith. Qed. Theorem FexpAdd_aux : (6%nat * length input * / (pPred (vNum b) - 1%nat) < 1)%R -> forall (L output : list float) (x y : float), endof input L -> IsExp b L -> IsRleEpsExp output -> output = nil \/ (Rabs (x + y) <= (pPred (vNum b) - 1%nat) * / pPred (vNum b) * ((6%nat * length input + 6%nat) * / (pPred (vNum b) - 1%nat - 6%nat * length input)) * Rabs (hd b output))%R -> output = nil \/ (exists L1 : list float, (exists x1 : float, (exists y1 : float, IsExp b (L1 ++ L) /\ endof input (L1 ++ L) /\ (x1 + (y1 + sum L1))%R = (x + y)%R :>R /\ (Rabs (sum L1) <= length L1 * (3%nat * (radix * (Rabs (hd b output) * / (pPred (vNum b) - 1%nat)))))%R /\ (Rabs (x1 + y1) <= 3%nat * radix * / pPred (vNum b) * Rabs (hd b output))%R))) -> Fbounded b x -> Fbounded b y -> (hdexp b L <= Fexp y)%Z -> (Fexp y <= Fexp x)%Z -> (FtoR radix x = 0%R :>R \/ FtoR radix y = 0%R :>R) \/ (Rabs (FtoR radix y) <= pPred (vNum b) * (FtoR radix (Float 1%nat (Fexp x)) - FtoR radix (Float 1%nat (hdexp b L))))%R -> output = nil \/ L = nil \/ (Rabs (hd b L) <= 3%nat * (radix * (Rabs (hd b output) * / (pPred (vNum b) - 1%nat))))%R /\ (Float (pPred (vNum b)) (Fexp (hd b L)) <= 3%nat * (radix * (Rabs (hd b output) * / (pPred (vNum b) - 1%nat))))%R /\ (Rabs (sum L) <= length L * (3%nat * (radix * (Rabs (hd b output) * / (pPred (vNum b) - 1%nat)))))%R -> exists x' : float, (exists y' : float, (exists output' : list float, Fbounded b x' /\ Fbounded b y' /\ (x + (y + (sum output + sum L)))%R = (x' + (y' + sum output'))%R :>R /\ length output' <= length L + length output /\ (Fexp y' <= Fexp x')%Z /\ IsRleEpsExp output' /\ (output = nil \/ (exists L1 : list float, (exists x1 : float, (exists y1 : float, IsExp b (L1 ++ L) /\ endof input (L1 ++ L) /\ (x1 + (y1 + sum L1))%R = (x + y)%R :>R /\ (Rabs (sum L1) <= length L1 * (3%nat * (radix * (Rabs (hd b output) * / (pPred (vNum b) - 1%nat)))))%R /\ (Rabs (x1 + y1) <= 3%nat * radix * / pPred (vNum b) * Rabs (hd b output))%R)))) /\ endof output' output /\ (output' = nil \/ (Rabs (x' + y') <= (pPred (vNum b) - 1%nat) * / pPred (vNum b) * ((6%nat * length input + 6%nat) * / (pPred (vNum b) - 1%nat - 6%nat * length input)) * Rabs (hd b output'))%R))). intros Z0. cut (1 < pPred (vNum b))%Z; [ intros Z1 | apply Zlt_trans with radix; try apply (pPredMoreThanRadix b radix precision); auto with zarith ]. cut (0 < pPred (vNum b))%Z; [ intros Zl2 | apply Zlt_1_O; apply Zlt_le_weak; auto with zarith ]. cut (0 < pPred (vNum b) - 1%nat - 6%nat * length input)%R; [ intros Z3 | apply Rlt_Rminus_ZERO; apply Rmult_lt_reg_l with (/ (pPred (vNum b) - 1%nat))%R; try rewrite Rinv_l; try rewrite (fun x => Rmult_comm (/ x)); auto with real zarith; replace (INR 1) with (IZR 1); try rewrite Z_R_minus; auto with real zarith ]. cut (3%nat * radix * / pPred (vNum b) <= (pPred (vNum b) - 1%nat) * / pPred (vNum b) * ((6%nat * length input + 6%nat) * / (pPred (vNum b) - 1%nat - 6%nat * length input)))%R; [ intros Z4 | auto with real zarith ]. 2: replace (3%nat * radix)%R with (INR 6 * 1)%R; [ idtac | rewrite Rmult_1_r; simpl in |- *; ring ]. 2: repeat rewrite Rmult_assoc. 2: rewrite (Rmult_comm 1). 2: rewrite (Rmult_comm (pPred (vNum b) - 1%nat)). 2: replace (6%nat * length input + 6%nat)%R with (INR 6 * (length input + 1%nat))%R; [ idtac | simpl in |- *; ring ]. 2: repeat rewrite <- (Rmult_assoc (/ pPred (vNum b))). 2: repeat rewrite (Rmult_comm (/ pPred (vNum b)) 6%nat). 2: repeat rewrite Rmult_assoc. 2: repeat apply Rmult_le_compat_l; auto with real zarith. 2: rewrite (Rmult_comm (length input + 1%nat)). 2: apply Rmult_le_reg_l with (pPred (vNum b) - 1%nat - 6%nat * length input)%R; auto with real zarith. 2: repeat rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real zarith; rewrite Rmult_1_r; rewrite Rmult_1_l. 2: rewrite (fun x => Rplus_comm x 1); rewrite Rmult_plus_distr_l; rewrite Rmult_1_r. 2: unfold Rminus in |- *; apply Rplus_le_compat_l. 2: rewrite <- Ropp_mult_distr_l_reverse; apply Rmult_le_compat_r; auto with real arith. 2: apply Rle_trans with (-0)%R; auto with real zarith arith. 2: rewrite Ropp_0; change (0 <= pPred (vNum b) - 1%nat)%R in |- *; auto with real zarith. intros L; elim L; clear L. intros output x y H H0 H1 H2 H3 H4 H5 H6 H7 H8 H9; exists x; exists y; exists output; repeat (split; simpl in |- *; auto); [ ring | exists (nil (A:=float)) ]; auto. intros a L HrecL output; case output; clear output. intros x y H H0 H1 H2 H3 H4 H5 H6 H7 H8 H9. cut (IsExp b L); [ intros Hp1 | inversion H0; auto; apply IsExpNil ]. cut (endof input L); [ intros Hp2 | case H; intros LL H10; exists (LL ++ a :: nil); rewrite H10; replace (a :: L) with ((a :: nil) ++ L); try apply ass_app; simpl in |- *; auto ]. case (AddStep x y a L nil); auto with real zarith. inversion H0; auto. case H8; auto; intros tmp; case tmp; auto. case H8; auto; intros tmp; case tmp; auto. intros x' (y', (output', H'1)). case H'1; intros T1 (T2, (T3, (T4, (T5, (T6, (T7, (T8, (T9, T10)))))))). case (HrecL output' x' y'); clear H2 H3 H9 HrecL; auto with real zarith. inversion T3; auto. apply IsRleEpsExpSingle; auto. CaseEq output'; auto; intros o output'' Eq1. right; case T9; rewrite Eq1; [ intros; discriminate | simpl in |- *; clear T9; intros T9 ]. apply Rle_trans with (3%nat * radix * / pPred (vNum b) * Rabs (FtoRradix o))%R; auto with real. CaseEq output'; auto; intros o output'' Eq1. right; exists (nil (A:=float)); exists x'; exists y'; repeat (split; simpl in |- *; auto with real). rewrite Rabs_R0; rewrite Rmult_0_l; auto with real. case T9; rewrite Eq1; [ intros; discriminate | simpl in |- *; auto ]. apply Zle_trans with (Fexp a); auto with zarith. apply IsExpZle; auto. repeat (case T8; auto; clear T8; intros T8). case T10; auto; clear T10; intros (T10, T11); right; case T11; auto. intros x'0 (y'0, (output'0, (V1, (V2, (V3, (V4, (V5, (V6, (V7, (V8, V9)))))))))). exists x'0; exists y'0; exists output'0; repeat (split; auto). rewrite (Rplus_comm (sum nil)); rewrite T4; rewrite <- V3; ring. generalize V4; case T3; simpl in |- *; auto with arith; intros e Be V0; rewrite plus_n_Sm; simpl in |- *; auto. exists output'0; apply app_nil_end. intros a0 output x y V' H H0 H1 M H2 H3 H4 H5 H6 H7. cut (IsExp b L); [ intros Hp1 | inversion H; auto; apply IsExpNil ]. cut (endof input L); [ intros Hp2 | case V'; intros LL H10; exists (LL ++ a :: nil); rewrite H10; replace (a :: L) with ((a :: nil) ++ L); try apply ass_app; simpl in |- *; auto ]. case H1; [ intros; discriminate | clear H1; intros H1 ]. case M; [ intros; discriminate | clear M; intros M ]. case H7; [ intros; discriminate | clear H7; intros H7 ]. case H7; [ intros; discriminate | clear H7; intros (H7, (H8, H9)) ]. case (AddStep x y a L (a0 :: output)); auto with real zarith. repeat (case H6; auto; clear H6; intros H6). intros x' (y', (output', (V1, (V2, (V3, (V4, (V5, (V6, (V7, (V8, (V9, V10))))))))))). cut (IsRleEpsExp output'); [ intros RR | idtac ]. case (HrecL output' x' y'); clear H2 H3 H9 HrecL; auto with real zarith. right; auto. 4: repeat (case V8; auto; clear V8; intros V8). 3: apply Zle_trans with (Fexp a); auto with zarith. 3: apply IsExpZle; auto. 3: case V10; auto; try intros (tmp1, [tmp2| tmp3]); auto. 3: intros x'0 (y'0, (output'0, (W1, (W2, (W3, (W4, (W5, (W6, (W7, (W8, W9)))))))))). 3: exists x'0; exists y'0; exists output'0; repeat (split; auto). 3: rewrite <- W3; rewrite (Rplus_comm (sum output')); rewrite <- V4; ring. 3: apply le_trans with (1 := W4). 3: inversion V3; simpl in |- *; auto with arith; repeat rewrite plus_n_Sm; simpl in |- *; auto with arith. 3: inversion V3; [ replace (a0 :: output) with output'; auto | idtac ]. 3: rewrite <- H9 in W8; inversion W8; exists (x1 ++ e :: nil); rewrite H10; replace (e :: a0 :: output) with ((e :: nil) ++ a0 :: output); try (apply sym_equal; apply app_ass); simpl in |- *; auto. 2: case M; intros L1 (x1, (y1, (X1, (X2, (X3, (X4, X5)))))). 2: inversion V3; auto. 2: right; exists (L1 ++ a :: nil); exists x1; exists y1; repeat (split; auto). 2: rewrite app_ass; simpl in |- *; auto. 2: rewrite app_ass; simpl in |- *; auto. 2: apply trans_eq with (FtoRradix x + FtoRradix y + a)%R; fold FtoRradix in |- *; [ rewrite <- X3; rewrite <- sum_app; fold radix; fold FtoRradix; ring | idtac ]. 2: replace (FtoRradix x + FtoRradix y)%R with (FtoRradix x + (FtoRradix y + (sum (a :: L) + sum (a0 :: output))) + - (sum (a :: L) + sum (a0 :: output)))%R; [ rewrite V4; rewrite H3; simpl in |- *; fold radix FtoRradix in |- *; ring | fold FtoRradix in |- *; ring ]. 2: rewrite <- sum_app. 2: apply Rle_trans with (1 := Rabs_triang (FtoR 2 a) (sum L1)). 2: rewrite app_length; simpl in |- *. 2: rewrite plus_INR; simpl in |- *; rewrite Rmult_plus_distr_r; rewrite Rmult_1_l. 2: rewrite (fun x => Rplus_comm (Rabs x)); apply Rplus_le_compat; auto. 2: right; exists (nil (A:=float)); exists x'; exists y'; repeat (split; simpl in |- *; auto). 2: rewrite Rplus_0_r; auto. 2: rewrite Rabs_R0; rewrite Rmult_0_l; auto with real. 2: case V9; rewrite <- H9; simpl in |- *; auto. 2: intros tmp; Contradict tmp; apply cons_neq; auto. inversion V3. case M; intros L1 (x1, (y1, (X1, (X2, (X3, (X4, X5)))))). replace (FtoRradix x' + FtoRradix y')%R with (a + (FtoRradix x1 + FtoRradix y1 + sum L1))%R. apply Rle_trans with (Rabs (FtoRradix a) + (Rabs (FtoRradix x1 + FtoRradix y1) + Rabs (sum L1)))%R. apply Rle_trans with (1 := Rabs_triang (FtoR 2 a) (FtoRradix x1 + FtoRradix y1 + sum L1)); auto with real. apply Rplus_le_compat_l; apply Rabs_triang; auto with real. apply Rle_trans with (3%nat * (2%nat * (Rabs (FtoRradix (hd b (a0 :: output))) * / (pPred (vNum b) - 1%nat))) + (Rabs (x1 + y1) + Rabs (sum L1)))%R; [ apply Rplus_le_compat_r; auto | idtac ]. apply Rle_trans with (3%nat * (2%nat * (Rabs (FtoRradix (hd b (a0 :: output))) * / (pPred (vNum b) - 1%nat))) + (3%nat * 2%nat * / pPred (vNum b) * Rabs (FtoRradix (hd b (a0 :: output))) + Rabs (sum L1)))%R; [ apply Rplus_le_compat_l; apply Rplus_le_compat_r; auto | idtac ]. apply Rle_trans with (3%nat * (2%nat * (Rabs (FtoRradix (hd b (a0 :: output))) * / (pPred (vNum b) - 1%nat))) + (3%nat * 2%nat * / pPred (vNum b) * Rabs (FtoRradix (hd b (a0 :: output))) + length L1 * (3%nat * (2%nat * (Rabs (FtoRradix (hd b (a0 :: output))) * / (pPred (vNum b) - 1%nat))))))%R; [ apply Rplus_le_compat_l; apply Rplus_le_compat_l; auto | idtac ]. apply Rle_trans with (3%nat * (2%nat * (Rabs (FtoRradix (hd b (a0 :: output))) * / (pPred (vNum b) - 1%nat))) + (3%nat * 2%nat * / (pPred (vNum b) - 1%nat) * Rabs (FtoRradix (hd b (a0 :: output))) + length L1 * (3%nat * (2%nat * (Rabs (FtoRradix (hd b (a0 :: output))) * / (pPred (vNum b) - 1%nat))))))%R; [ apply Rplus_le_compat_l; apply Rplus_le_compat_r; simpl in |- *; auto with real | idtac ]. apply Rmult_le_compat_r; auto with real. apply Rmult_le_compat_l; auto with real. replace ((2 + 1) * 2)%R with (INR 6); auto with real arith; simpl in |- *; ring. apply Rle_Rinv; auto with real arith. pattern (IZR (pPred (vNum b))) at 2 in |- *; replace (IZR (pPred (vNum b))) with (IZR (pPred (vNum b)) + -0)%R; [ unfold Rminus in |- *; auto with real | ring ]. apply Rle_trans with ((3%nat * 2%nat + (3%nat * 2%nat + length L1 * (3%nat * 2%nat))) * / (pPred (vNum b) - 1%nat) * Rabs (FtoRradix (hd b (a0 :: output))))%R; [ right; ring; ring | idtac ]. apply Rmult_le_compat_r; auto with real. replace (3%nat * 2%nat)%R with (INR 6); [ idtac | simpl in |- *; ring ]. apply Rle_trans with ((6%nat + (6%nat + (length input - 1) * 6%nat)) * / (pPred (vNum b) - 1%nat))%R. apply Rmult_le_compat_r; auto with real. apply Rplus_le_compat_l; apply Rplus_le_compat_l; apply Rmult_le_compat_r; auto with arith zarith real. apply endof_Rle_length with L a; auto. replace (6%nat + (length input - 1) * 6%nat)%R with (6%nat * length input)%R; [ idtac | ring; ring ]. apply Rle_trans with ((6%nat + 6%nat * length input) * ((pPred (vNum b) - 1%nat) * / pPred (vNum b) * / (pPred (vNum b) - 1%nat - 6%nat * length input)))%R; [ idtac | right; ring; ring ]. apply Rmult_le_compat_l; auto with arith zarith real. repeat rewrite <- plus_INR || rewrite <- mult_INR; apply pos_INR; simpl in |- *; auto with arith. apply Rmult_le_reg_l with (pPred (vNum b) - 1%nat)%R; auto with real. apply Rmult_le_reg_l with (pPred (vNum b) - 1%nat - 6%nat * length input)%R; auto with real. apply Rmult_le_reg_l with (IZR (pPred (vNum b))); auto with real. rewrite Rinv_r; [ idtac | simpl in |- *; replace 1%R with (IZR 1); try rewrite Z_R_minus; auto with real zarith ]. apply Rle_trans with ((pPred (vNum b) - 1%nat) * ((pPred (vNum b) - 1%nat) * (pPred (vNum b) * / pPred (vNum b) * ((pPred (vNum b) - 1%nat - 6%nat * length input) * / (pPred (vNum b) - 1%nat - 6%nat * length input)))))%R; [ idtac | right; ring; ring ]. rewrite Rinv_r; [ idtac | auto with real zarith ]. rewrite Rinv_r; [ idtac | auto with real zarith ]. apply Rle_trans with (pPred (vNum b) * pPred (vNum b) + - (pPred (vNum b) * (6%nat * length input + 1)))%R; [ right; simpl; ring | idtac ]. apply Rle_trans with (pPred (vNum b) * pPred (vNum b) + (- (pPred (vNum b) * 2) + 1))%R; [ idtac | right; simpl; ring ]. apply Rplus_le_compat_l. apply Rle_trans with (- (pPred (vNum b) * 2))%R. apply Ropp_le_contravar; apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (INR 6 * INR 1)%R. replace 2%R with (INR 2); repeat rewrite <- plus_INR || rewrite <- mult_INR; try apply Rle_INR; simpl in |- *; auto with real arith. apply Rle_trans with (6%nat * length input)%R; auto with real zarith. apply Rmult_le_compat_l; auto with real arith. case X2; intros LL HL; rewrite HL. repeat rewrite app_length; simpl in |- *; repeat rewrite <- plus_n_Sm; replace 1%R with (INR 1); auto with real arith. rewrite <- (Rplus_0_r (- (pPred (vNum b) * 2))); auto with real. repeat rewrite Rplus_assoc; rewrite X3; replace (FtoRradix x' + FtoRradix y')%R with (FtoRradix x' + (FtoRradix y' + (sum L + sum output')) + - (sum L + sum output'))%R; [ rewrite <- V4; rewrite <- H3; simpl in |- *; fold FtoRradix in |- *; fold radix; fold FtoRradix; ring | ring ]. case V9; [ rewrite <- H9; intros tmp; Contradict tmp; apply cons_neq | rewrite H9; intros H'9 ]. apply Rle_trans with (1 := H'9); auto with real. inversion V3; auto. apply IsRleEpsExpTop; auto. inversion H0; auto. apply Rmult_le_reg_l with (1 - 6%nat * length (a :: L) * / (pPred (vNum b) - 1%nat))%R. 2: apply Rle_trans with ((1 - (6%nat * / pPred (vNum b) + 6%nat * length L * / (pPred (vNum b) - 1%nat))) * Rabs e)%R. 2: apply Rmult_le_compat_r; auto with real. 2: unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_contravar. 2: replace (6%nat * length (a :: L) * / (pPred (vNum b) + - 1%nat))%R with (6%nat * / (pPred (vNum b) + -1) + 6%nat * length L * / (pPred (vNum b) + -1))%R; [ apply Rplus_le_compat_r | idtac ]. 2: apply Rmult_le_compat_l; apply Rlt_le; auto with real arith. 2: apply Rinv_1_lt_contravar; auto with real arith. 2: replace 1%R with (IZR 1); [ rewrite <- Ropp_Ropp_IZR; rewrite <- plus_IZR; apply Rle_IZR | simpl in |- *; auto ]. 2: change (1 <= Zpred (pPred (vNum b)))%Z in |- *; auto with zarith. 2: pattern (IZR (pPred (vNum b))) at 2 in |- *; replace (IZR (pPred (vNum b))) with (pPred (vNum b) + -0)%R; auto with real; ring. 2: replace (INR (length (a :: L))) with (1 + INR (length L))%R; [ simpl in |- *; ring | simpl in |- *; case (length L); simpl in |- *; intros; ring ]. 2: case V9; [ rewrite <- H12; intros tmp; Contradict tmp; apply cons_neq | rewrite <- H12; intros H'9 ]. 2: replace ((1 - (6%nat * / pPred (vNum b) + 6%nat * length L * / (pPred (vNum b) - 1%nat))) * Rabs e)%R with (Rabs e - (6%nat * / pPred (vNum b) * Rabs e + 6%nat * length L * / (pPred (vNum b) - 1%nat) * Rabs e))%R; [ idtac | ring; ring ]. 2: apply Rle_trans with (Rabs e - (Rabs (x' + y') + 6%nat * length L * / (pPred (vNum b) - 1%nat) * Rabs e))%R. 2: unfold Rminus in |- *; apply Rplus_le_compat_l. 2: apply Ropp_le_contravar; apply Rplus_le_compat_r. 2: replace (INR 6) with (3%nat * 2%nat)%R; replace e with (hd b (e :: x0)); auto with real. 2: rewrite <- (mult_INR 3 2); auto with arith. 2: case V10; [ rewrite <- H12; intros; discriminate | rewrite <- H12; intros (H'10, H'11) ]. 2: apply Rle_trans with (Rabs e - (Rabs (x' + y') + Rabs (sum L)))%R. 2: unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_contravar; apply Rplus_le_compat_l. 2: case H'11; [ intros H'12; rewrite H'12; simpl in |- *; rewrite Rabs_R0; right; ring | intros (H'12, H'13); auto ]. 2: apply Rle_trans with (1 := H'13); right; simpl in |- *. 2: ring_simplify (pPred (vNum b) +- 1)%R;ring. elim H2; intros; clear H2. 2: apply Rle_trans with (Rabs (e + (x' + y' + sum L))). 2: rewrite <- (Rabs_Ropp (x' + y')); rewrite <- (Rabs_Ropp (sum L)). 2: replace (Rabs e - (Rabs (- (x' + y')) + Rabs (- sum L)))%R with (Rabs e - Rabs (- (x' + y')) - Rabs (- sum L))%R; [ idtac | ring; ring ]. 2: apply Rle_trans with (Rabs (e - - (x' + y')) - Rabs (- sum L))%R. 2: unfold Rminus in |- *; apply Rplus_le_compat_r. 2: replace (Rabs e + - Rabs (- (x' + y')))%R with (Rabs e - Rabs (- (x' + y')))%R; replace (e + - - (x' + y'))%R with (e - - (x' + y'))%R; try ring. 2: apply Rabs_triang_inv. 2: replace (e + (x' + y' + sum L))%R with (e - - (x' + y') - - sum L)%R; try ring. 2: apply Rabs_triang_inv. 2: replace (e + (x' + y' + sum L))%R with (x + (y + sum (a :: L)))%R. 3: apply Rplus_eq_reg_l with (sum (a0 :: output)). 3: replace (sum (a0 :: output) + (x + (y + sum (a :: L))))%R with (FtoRradix x + (FtoRradix y + (sum (a :: L) + sum (a0 :: output))))%R; [ rewrite V4; rewrite <- H12; simpl in |- *; fold radix FtoRradix in |- *; ring | ring ]. 2: case M; intros L1 (x1, (y1, (X1, (X2, (X3, (X4, X5)))))). 2: replace (x + (y + sum (a :: L)))%R with (x + y + sum (a :: L))%R; [ rewrite <- X3 | ring ]. 2: replace (x1 + (y1 + sum L1) + sum (a :: L))%R with (x1 + y1 + (sum L1 + sum (a :: L)))%R; [ idtac | ring ]. 2: apply Rle_trans with (Rabs (x1 + y1) + Rabs (sum L1 + sum (a :: L)))%R; [ apply Rabs_triang | idtac ]. 2: apply Rle_trans with (6%nat * / pPred (vNum b) * Rabs a0 + Rabs (sum L1 + sum (a :: L)))%R. 2: apply Rplus_le_compat_r; apply Rle_trans with (1 := X5). 2: simpl in |- *; repeat apply Rmult_le_compat_r; auto with real. 2: replace ((2 + 1) * 2)%R with (INR 6); replace (2 + 1 + 1 + 1 + 1)%R with (INR 6); auto with real arith; simpl in |- *; ring. 2: apply Rle_trans with (6%nat * / pPred (vNum b) * Rabs (FtoRradix a0) + (Rabs (sum L1) + Rabs (sum (a :: L))))%R; [ apply Rplus_le_compat_l; apply Rabs_triang | idtac ]. 2: apply Rle_trans with (6%nat * / pPred (vNum b) * Rabs (FtoRradix a0) + (length L1 * (3%nat * (2%nat * (Rabs (hd b (a0 :: output)) * / (pPred (vNum b) - 1%nat)))) + Rabs (sum (a :: L))))%R. 2: apply Rplus_le_compat_l; apply Rplus_le_compat_r; auto. 2: apply Rle_trans with (6%nat * / pPred (vNum b) * Rabs (FtoRradix a0) + (length L1 * (3%nat * (2%nat * (Rabs (hd b (a0 :: output)) * / (pPred (vNum b) - 1%nat)))) + length (a :: L) * (3%nat * (2%nat * (Rabs (hd b (a0 :: output)) * / (pPred (vNum b) - 1%nat))))))%R. 2: apply Rplus_le_compat_l; apply Rplus_le_compat_l; auto. 2: replace (hd b (a0 :: output)) with a0; [ idtac | simpl in |- *; auto ]. 2: replace (length L1 * (3%nat * (2%nat * (Rabs a0 * / (pPred (vNum b) - 1%nat)))) + length (a :: L) * (3%nat * (2%nat * (Rabs a0 * / (pPred (vNum b) - 1%nat)))))%R with ((length L1 + length (a :: L)) * (3%nat * 2%nat * (Rabs a0 * / (pPred (vNum b) - 1%nat))))%R; [ idtac | ring; ring ]. 2: replace (3%nat * 2%nat)%R with (INR 6); [ idtac | simpl in |- *; ring ]. 2: replace (6%nat * / pPred (vNum b) * Rabs a0 + (length L1 + length (a :: L)) * (6%nat * (Rabs a0 * / (pPred (vNum b) - 1%nat))))%R with ((6%nat * / pPred (vNum b) + (length L1 + length (a :: L)) * (6%nat * / (pPred (vNum b) - 1%nat))) * Rabs a0)%R; [ idtac | ring ]. 2: apply Rle_trans with ((1 - 6%nat * length (a :: L) * / (pPred (vNum b) - 1%nat)) * ((6%nat * length input + 6%nat) * / (pPred (vNum b) - 1%nat - 6%nat * length input)) * Rabs a0)%R; [ idtac | right; ring ]. 2: apply Rmult_le_compat_r; auto with real. 2: apply Rle_trans with (6%nat * / (pPred (vNum b) - 1%nat) + (length L1 + length (a :: L)) * (6%nat * / (pPred (vNum b) - 1%nat)))%R. 2: apply Rplus_le_compat_r; apply Rmult_le_compat_l; auto with real arith. 2: apply Rlt_le; apply Rinv_1_lt_contravar; auto with real zarith. 2: simpl in |- *; replace 1%R with (IZR 1); [ unfold Rminus in |- *; rewrite <- Ropp_Ropp_IZR; rewrite <- plus_IZR; apply Rle_IZR | simpl in |- *; auto ]. 2: change (1 <= Zpred (pPred (vNum b)))%Z in |- *; auto with zarith. 2: simpl in |- *; unfold Rminus in |- *; pattern (IZR (pPred (vNum b))) at 2 in |- *; replace (IZR (pPred (vNum b))) with (pPred (vNum b) + -0)%R; auto with real; ring. 2: replace (6%nat * / (pPred (vNum b) - 1%nat) + (length L1 + length (a :: L)) * (6%nat * / (pPred (vNum b) - 1%nat)))%R with ((1 + (length L1 + length (a :: L))) * (6%nat * / (pPred (vNum b) - 1%nat)))%R; [ idtac | ring ]. 2: replace (length L1 + length (a :: L))%R with (INR (length (L1 ++ a :: L))). 2: cut (0 <= 6%nat * / (pPred (vNum b) - 1%nat))%R; [ intros T1 | idtac ]. 2: apply Rle_trans with ((1 + length input) * (6%nat * / (pPred (vNum b) - 1%nat)))%R; [ apply Rmult_le_compat_r; auto with real | idtac ]. 2: apply Rplus_le_compat_l; apply Rle_INR. 2: apply endof_length; auto. 2: apply Rle_trans with (1 * / (pPred (vNum b) - 1%nat) * (6%nat * length input + 6%nat))%R; [ right; ring; ring | idtac ]. 2: apply Rle_trans with (/ (pPred (vNum b) - 1%nat - 6%nat * length input) * (1 - 6%nat * length (a :: L) * / (pPred (vNum b) - 1%nat)) * (6%nat * length input + 6%nat))%R; [ idtac | right; ring ]. 2: apply Rmult_le_compat_r; auto with real. 2: apply Rle_trans with (0 + 6%nat)%R; [ apply Rlt_le | apply Rplus_le_compat_r ]; auto with real arith. 2: replace (0 + 6%nat)%R with (INR 6); auto with arith real. 2: replace 0%R with (0 * INR 0)%R; [ auto with real arith | simpl in |- *; ring ]. 2: replace (1 - 6%nat * length (a :: L) * / (pPred (vNum b) - 1%nat))%R with ((pPred (vNum b) - 1%nat - 6%nat * length (a :: L)) * / (pPred (vNum b) - 1%nat))%R. 2: rewrite <- Rmult_assoc; apply Rmult_le_compat_r. 2: apply Rlt_le; apply Rinv_0_lt_compat; auto. 2: simpl in |- *; replace 1%R with (IZR 1); [ auto with real zarith | simpl in |- *; auto ]. 2: apply Rle_trans with (/ (pPred (vNum b) - 1%nat - 6%nat * length input) * (pPred (vNum b) - 1%nat - 6%nat * length input))%R. 2: rewrite Rmult_comm; rewrite Rinv_r; auto with real. 2: apply Rmult_le_compat_l. 2: apply Rlt_le; apply Rinv_0_lt_compat; auto. 2: unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_contravar. 2: apply Rmult_le_compat_l; auto with real arith. 2: apply Rle_INR; apply endof_length; auto. 2: replace 1%R with ((pPred (vNum b) - 1%nat) * / (pPred (vNum b) - 1%nat))%R; [ ring | idtac ]. 2: apply Rinv_r; auto with real arith. 2: apply not_eq_sym; apply Rlt_dichotomy_converse; left; auto. 2: simpl in |- *; replace 1%R with (IZR 1); [ auto with real zarith | simpl in |- *; auto ]. 2: apply Rle_mult_pos; auto with real zarith arith. 2: rewrite app_length; rewrite plus_INR; auto. replace (1 - 6%nat * length (a :: L) * / (pPred (vNum b) - 1%nat))%R with ((pPred (vNum b) - 1%nat - 6%nat * length (a :: L)) * / (pPred (vNum b) - 1%nat))%R. apply Rmult_lt_0_compat; auto with real zarith arith. 2: replace 1%R with ((pPred (vNum b) - 1%nat) * / (pPred (vNum b) - 1%nat))%R; [ ring | idtac ]. 2: apply Rinv_r; auto with real zarith. 2: apply not_eq_sym; apply Rlt_dichotomy_converse; left; auto. 2: simpl in |- *; replace 1%R with (IZR 1); [ auto with real zarith | simpl in |- *; auto ]. apply Rlt_le_trans with (pPred (vNum b) - 1%nat - 6%nat * length input)%R. 2: unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_contravar; apply Rmult_le_compat_l; auto with real arith. 2: apply Rle_INR; apply endof_length; auto. apply Rlt_Rminus_ZERO. apply Rmult_lt_reg_l with (/ (pPred (vNum b) - 1%nat))%R; auto with real zarith. rewrite Rinv_l; try rewrite Rmult_comm; auto with real zarith. apply not_eq_sym; apply Rlt_dichotomy_converse; left; auto with real zarith. Qed. Theorem FexpAdd_aux2 : forall L : list float, L = input -> IsExp b input -> (6%nat * length input * / (pPred (vNum b) - 1%nat) < 1)%R -> exists output : list float, (input <> nil -> length output <= S (length input)) /\ sum input = sum output :>R /\ IsRleEpsExp output. cut (1 < pPred (vNum b))%Z; [ intros Z1 | apply Zlt_trans with radix; auto with zarith; apply (pPredMoreThanRadix b radix precision); auto with zarith ]. cut (0 < pPred (vNum b) - 1)%R; [ intros Z2 | replace 1%R with (IZR 1); auto with real zarith ]. intros L; case L. intros H H1 H2; rewrite <- H; exists (nil (A:=float)); repeat (split; auto); apply IsRleEpsExpNil. intros f l H H0 H1; rewrite <- H in H0. case (FexpAdd_aux H1 l nil f (Fzero (Fexp f))); auto. rewrite <- H; exists (f :: nil); auto. inversion H0; auto. apply IsExpNil. apply IsRleEpsExpNil. inversion H0; auto. apply FboundedZeroSameExp; auto. inversion H0; auto. inversion H0; simpl in |- *; auto. case H3; simpl in |- *; auto. simpl in |- *; auto with zarith. left; right; apply FzeroisReallyZero. intros x' (y', (output', (E1, (E2, (E3, (E4, (E5, (E6, (E7, (E8, E9)))))))))). cut (TotalP (Closest b radix)); [ intros CT | apply ClosestTotal with (precision := precision); auto ]. case (CT (x' + y')%R); intros p Ep. case (errorBoundedPlus b radix precision) with (6 := Ep); auto with zarith; intros q (Eq1, (Eq2, Eq3)). exists (q :: p :: output'); repeat split. intros H2; rewrite <- H; simpl in |- *. apply le_trans with (S (S (length l + 0))); auto with arith zarith. rewrite <- H; simpl in |- *; fold radix in |- *; rewrite Eq1. replace (FtoR radix x' + FtoR radix y' - FtoR radix p + (FtoR radix p + sum output'))%R with (FtoRradix x' + (FtoRradix y' + sum output'))%R; [ rewrite <- E3; simpl in |- * | fold FtoRradix in |- *; ring ]. rewrite (FzeroisReallyZero radix); fold FtoRradix; ring. cut (Fbounded b p); [ intros Bp | apply (RoundedModeBounded b radix) with (P := Closest b radix) (2 := Ep); apply ClosestRoundedModeP with precision; auto with float ]. apply IsRleEpsExpTop; auto. case (Req_dec p 0); intros Hp0. cut (FtoRradix q = 0%R); [ intros Hq0 | idtac ]. rewrite Hp0; rewrite Hq0; rewrite Rabs_R0; right; ring. unfold FtoRradix in |- *; rewrite Eq1; apply TwoSumNul with b precision; auto. apply Rle_trans with (Rabs p * / 2%nat * (radix * / Zpos (vNum b)))%R; auto. unfold FtoRradix in |- *; rewrite Eq1; rewrite <- Rabs_Ropp. replace (- (FtoR radix x' + FtoR radix y' - FtoR radix p))%R with (FtoR radix p - (FtoR radix x' + FtoR radix y'))%R; [ idtac | ring ]. apply plusErrorBound1bis with precision; auto with real zarith. Contradict Hp0; unfold FtoRradix in |- *; apply is_Fzero_rep1; auto. rewrite Rmult_assoc; rewrite Rmult_comm; apply Rmult_le_compat_r; auto with real. rewrite <- Rmult_assoc. replace (/ 2%nat * radix)%R with 1%R; [ idtac | rewrite Rinv_l; auto with real zarith ]. apply Rle_trans with ((6%nat * length input + 6%nat) * / Zpos (vNum b))%R; [ apply Rmult_le_compat_r | apply Rmult_le_compat_l ]; auto with real arith zarith. replace 1%R with (INR 1); repeat rewrite <- mult_INR; repeat rewrite <- plus_INR; simpl in |- *; try rewrite <- plus_n_Sm; auto with real zarith. replace 1%R with (INR 1); repeat rewrite <- mult_INR; repeat rewrite <- plus_INR; simpl in |- *; auto with real arith. apply Rle_Rinv. apply Rlt_Rminus_ZERO. apply Rmult_lt_reg_l with (/ (pPred (vNum b) - 1%nat))%R; auto with real zarith. rewrite Rmult_comm; rewrite Rinv_l; auto with real. apply Rle_trans with (Zpos (vNum b) - 6%nat * length input)%R; auto with real arith zarith. unfold Rminus in |- *; apply Rplus_le_compat_r; auto with real arith zarith. replace (- 1%nat)%R with (IZR (- (1))); [ rewrite <- plus_IZR; unfold pPred, Zpred in |- *; auto with real zarith | simpl in |- *; auto ]. pattern (IZR (Zpos (vNum b))) at 2 in |- *; replace (IZR (Zpos (vNum b))) with (Zpos (vNum b) - 0)%R; unfold Rminus in |- *; try ring; apply Rplus_le_compat_l; apply Ropp_le_contravar; auto with real arith zarith. apply Rle_mult_pos; replace 0%R with (INR 0); auto with real arith zarith. CaseEq output'. intros; apply IsRleEpsExpSingle; auto. intros f0 l0 Ho; apply IsRleEpsExpTop; auto. 3: rewrite <- Ho; auto. rewrite Ho in E6; inversion E6; auto. case E9. rewrite Ho; intros; discriminate. rewrite Ho; intros E10. apply Rle_trans with (/ (pPred (vNum b) - 1%nat) * pPred (vNum b) * Rabs (x' + y'))%R. apply Rle_trans with (Rabs (FtoR 2%nat x' + FtoR 2%nat y') * (2%nat * pPred (vNum b) * / (2%nat * pPred (vNum b) - radix)))%R. unfold FtoRradix in |- *; apply RoundBound with precision; auto. replace radix with (2%nat * 1)%Z; auto with zarith. apply Zmult_gt_0_lt_compat_l; auto with zarith. red in |- *; simpl in |- *; auto. right. replace (2%nat * pPred (vNum b) - radix)%R with (2%nat * (pPred (vNum b) - 1%nat))%R; [ idtac | simpl in |- *; ring ]. rewrite Rinv_mult_distr; auto with real zarith arith. pattern (IZR (pPred (vNum b))) at 4 in |- *; replace (IZR (pPred (vNum b))) with (2%nat * / 2%nat * IZR (pPred (vNum b)))%R. simpl in |- *; fold radix FtoRradix in |- *; ring. rewrite Rinv_r; auto with real zarith. apply Rmult_le_reg_l with (/ pPred (vNum b))%R; auto with real zarith. apply Rmult_le_reg_l with (pPred (vNum b) - 1%nat)%R; auto with real zarith. apply Rle_trans with (Rabs (x' + y') * ((pPred (vNum b) - 1%nat) * / (pPred (vNum b) - 1%nat) * (pPred (vNum b) * / pPred (vNum b))))%R; [ right; ring; ring | idtac ]. repeat rewrite Rinv_r; auto with real zarith. apply Rle_trans with (Rabs (x' + y')); [ right; ring | idtac ]. apply Rle_trans with ((pPred (vNum b) - 1%nat) * / pPred (vNum b) * ((6%nat * length input + 6%nat) * / (pPred (vNum b) - 1%nat - 6%nat * length input)) * Rabs (hd b (f0 :: l0)))%R; [ auto | simpl in |- *; right; ring; ring ]. Qed. Theorem FexpAdd_main : IsExp b input -> (6%nat * length input * / (pPred (vNum b) - 1%nat) < 1)%R -> exists output : list float, (input <> nil -> length output <= S (length input)) /\ sum input = sum output :>R /\ IsRleEpsExp output. intros H H0; apply (FexpAdd_aux2 input); auto. Qed. End FexpAdd.Float8.4/Expansions/FexpDiv.v0000644000423700002640000005245512032774526015747 0ustar sboldotoccata(**************************************************************************** IEEE754 : FexpDiv Sylvie Boldo ******************************************************************************) Require Export AllFloat. Section Div. Variables wi wi1 qi D N qi1 wi2 ai bi eps1 eps2 eps3 ep : R. Hypothesis Hw : wi = (wi1 - qi * D)%R :>R. Hypothesis Ha : (Rabs (/ wi1 * (ai - wi1)) <= eps1)%R. Hypothesis Hb : (Rabs (/ D * (bi - D)) <= eps2)%R. Hypothesis Hq : (Rabs (/ (/ bi * ai) * (qi - / bi * ai)) <= eps3)%R. Hypothesis NZwi : wi1 <> 0%R. Hypothesis NZD : D <> 0%R. Hypothesis NZbi : bi <> 0%R. Hypothesis NZai : ai <> 0%R. Hypothesis PosEps1 : (0 <= eps1)%R. Hypothesis PosEps2 : (0 <= eps2)%R. Hypothesis PosEps3 : (0 <= eps3)%R. Hypothesis LeEps1 : (eps1 < 1)%R. Hypothesis LeEps2 : (eps2 < 1)%R. Hypothesis LeEps3 : (eps3 < 1)%R. Hypothesis Hep : ep = Rmax (Rmax eps1 eps2) eps3 :>R. Theorem InegAbsInf : forall x y eps : R, x <> 0%R -> (Rabs (/ x * (y - x)) <= eps)%R -> (Rabs y <= (1 + eps) * Rabs x)%R. intros x y eps H H0. replace ((1 + eps) * Rabs x)%R with (Rabs x + eps * Rabs x)%R; [ idtac | ring ]. replace (Rabs y) with (Rabs x + (Rabs y - Rabs x))%R; [ idtac | ring ]. apply Rplus_le_compat_l. apply Rle_trans with (Rabs (y - x)). apply Rabs_triang_inv. apply Rmult_le_reg_l with (/ Rabs x)%R. replace (/ Rabs x * (eps * Rabs x))%R with eps. apply Rinv_0_lt_compat; apply Rabs_pos_lt; auto with real. rewrite (Rmult_comm eps); rewrite <- Rmult_assoc; rewrite Rinv_l; try ring; apply Rabs_no_R0; auto with real. rewrite (Rmult_comm eps); rewrite <- Rmult_assoc; rewrite Rinv_l; try apply Rabs_no_R0; auto with real; rewrite Rmult_1_l. rewrite <- Rabs_Rinv; auto with real; rewrite <- Rabs_mult; auto. Qed. Theorem InegAbsSup : forall x y eps : R, x <> 0%R -> (Rabs (/ x * (y - x)) <= eps)%R -> ((1 - eps) * Rabs x <= Rabs y)%R. intros x y eps H H0. replace ((1 - eps) * Rabs x)%R with (Rabs x + - (eps * Rabs x))%R; [ idtac | ring ]. replace (Rabs y) with (Rabs x + - (Rabs x - Rabs y))%R; [ idtac | ring ]. apply Rplus_le_compat_l. apply Ropp_le_contravar. apply Rle_trans with (Rabs (y - x)). rewrite Rabs_minus_sym. apply Rabs_triang_inv. apply Rmult_le_reg_l with (/ Rabs x)%R. apply Rinv_0_lt_compat; apply Rabs_pos_lt; auto with real. rewrite (Rmult_comm eps); rewrite <- Rmult_assoc; rewrite Rinv_l; try apply Rabs_no_R0; auto with real; rewrite Rmult_1_l. rewrite <- Rabs_Rinv; auto with real; rewrite <- Rabs_mult; auto. Qed. Theorem DivFirstCase : ((Rabs wi1 - Rabs (qi * D)) * / Rabs wi1 <= 1 - (1 - eps3) * (1 - eps1) * / (1 + eps2))%R. apply Rle_trans with (1 - Rabs (qi * D) * / Rabs wi1)%R. right. replace 1%R with (Rabs wi1 * / Rabs wi1)%R; [ ring | apply Rinv_r; apply Rabs_no_R0; auto with real ]. unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_contravar. fold (1 - eps1)%R in |- *; fold (1 - eps3)%R in |- *. apply Rle_trans with ((1 - eps3) * (1 - eps1) * Rabs D * / ((1 + eps2) * Rabs D))%R; [ right | idtac ]. replace ((1 - eps3) * (1 - eps1) * Rabs D * / ((1 + eps2) * Rabs D))%R with ((1 - eps3) * (1 - eps1) * (Rabs D * / Rabs D) * / (1 + eps2))%R; [ replace (Rabs D * / Rabs D)%R with 1%R | idtac ]. ring. apply sym_eq; apply Rinv_r; apply Rabs_no_R0; auto with real. replace (/ ((1 + eps2) * Rabs D))%R with (/ (1 + eps2) * / Rabs D)%R; [ ring | idtac ]. apply sym_eq; apply Rinv_mult_distr; [ auto with real | apply Rabs_no_R0; auto ]. apply not_eq_sym; apply Rlt_dichotomy_converse; left; auto with real. apply Rlt_le_trans with 1%R; auto with real. pattern 1%R at 1 in |- *; replace 1%R with (1 + 0)%R; auto with real. apply Rle_trans with ((1 - eps3) * (1 - eps1) * Rabs D * / Rabs bi)%R. apply Rmult_le_compat_l. left; apply Rmult_lt_0_compat; auto with real. apply Rmult_lt_0_compat; auto with real. apply Rabs_pos_lt; auto with real. apply Rle_Rinv; auto with real. apply Rabs_pos_lt; auto with real. apply InegAbsInf; auto. apply Rle_trans with ((1 - eps3) * ((1 - eps1) * Rabs wi1) * Rabs D * (/ Rabs wi1 * / Rabs bi))%R; [ right | idtac ]. replace ((1 - eps3) * ((1 - eps1) * Rabs wi1) * Rabs D * (/ Rabs wi1 * / Rabs bi))%R with ((1 - eps3) * ((1 - eps1) * / Rabs bi) * Rabs D * (Rabs wi1 * / Rabs wi1))%R; [ replace (Rabs wi1 * / Rabs wi1)%R with 1%R; [ ring | idtac ] | ring ]. apply sym_eq; apply Rinv_r; apply Rabs_no_R0; auto with real. apply Rle_trans with ((1 - eps3) * Rabs ai * Rabs D * (/ Rabs wi1 * / Rabs bi))%R. apply Rmult_le_compat_r. left; apply Rmult_lt_0_compat; auto with real. apply Rinv_0_lt_compat; auto with real; apply Rabs_pos_lt; auto with real. apply Rinv_0_lt_compat; auto with real; apply Rabs_pos_lt; auto with real. apply Rmult_le_compat_r; auto with real. apply Rmult_le_compat_l; auto with real. apply InegAbsSup; auto. replace ((1 - eps3) * Rabs ai * Rabs D * (/ Rabs wi1 * / Rabs bi))%R with (/ Rabs bi * ((1 - eps3) * Rabs ai) * Rabs D * / Rabs wi1)%R; [ apply Rmult_le_compat_r | ring ]. left; apply Rinv_0_lt_compat; auto with real; apply Rabs_pos_lt; auto with real. rewrite (Rabs_mult qi D). apply Rmult_le_compat_r; auto with real. replace (/ Rabs bi * ((1 - eps3) * Rabs ai))%R with ((1 - eps3) * (/ Rabs bi * Rabs ai))%R; [ idtac | ring; ring ]. replace (/ Rabs bi * Rabs ai)%R with (Rabs (/ bi * ai)). apply InegAbsSup; auto. apply Rmult_integral_contrapositive; split; auto; apply Rinv_neq_0_compat; auto. rewrite Rabs_mult; rewrite Rabs_Rinv; auto with real. Qed. Theorem DivSecondCase : ((Rabs (qi * D) - Rabs wi1) * / Rabs wi1 <= (1 + eps3) * (1 + eps1) * / (1 - eps2) - 1)%R. apply Rle_trans with (Rabs (qi * D) * / Rabs wi1 - 1)%R; [ right | idtac ]. rewrite <- (Rinv_l (Rabs wi1)); auto with real; try ring. apply Rabs_no_R0; auto with real. replace (Rabs (qi * D) * / Rabs wi1 - 1)%R with (-1 + Rabs (qi * D) * / Rabs wi1)%R; [ idtac | ring ]. replace ((1 + eps3) * (1 + eps1) * / (1 - eps2) - 1)%R with (-1 + (1 + eps3) * (1 + eps1) * / (1 - eps2))%R; [ idtac | ring ]. apply Rplus_le_compat_l. rewrite (Rabs_mult qi D). apply Rle_trans with ((1 + eps3) * Rabs (/ bi * ai) * Rabs D * / Rabs wi1)%R. apply Rmult_le_compat_r; auto with real. left; apply Rinv_0_lt_compat; auto with real; apply Rabs_pos_lt; auto with real. apply Rmult_le_compat_r; auto with real. apply InegAbsInf; auto. apply Rmult_integral_contrapositive; split; auto; apply Rinv_neq_0_compat; auto. rewrite Rabs_mult. apply Rle_trans with ((1 + eps3) * (Rabs (/ bi) * ((1 + eps1) * Rabs wi1)) * Rabs D * / Rabs wi1)%R. apply Rmult_le_compat_r; auto with real. left; apply Rinv_0_lt_compat; auto with real; apply Rabs_pos_lt; auto with real. apply Rmult_le_compat_r; auto with real. apply Rmult_le_compat_l; auto with real. apply Rle_trans with (1 + 0)%R; auto with real. replace (1 + 0)%R with 1%R; auto with real; ring. apply Rmult_le_compat_l; auto with real. apply InegAbsInf; auto. replace ((1 + eps3) * (Rabs (/ bi) * ((1 + eps1) * Rabs wi1)) * Rabs D * / Rabs wi1)%R with ((1 + eps3) * (1 + eps1) * (Rabs (/ bi) * Rabs D * (Rabs wi1 * / Rabs wi1)))%R; [ idtac | ring; ring ]. replace (Rabs wi1 * / Rabs wi1)%R with 1%R; [ idtac | apply sym_eq; apply Rinv_r; apply Rabs_no_R0; auto with real ]. replace (Rabs (/ bi) * Rabs D * 1)%R with (Rabs (/ bi) * Rabs D)%R; [ apply Rmult_le_compat_l; auto with real | ring ]. left; apply Rmult_lt_0_compat; auto with real. apply Rlt_le_trans with (1 + 0)%R; auto with real. replace (1 + 0)%R with 1%R; auto with real; ring. apply Rlt_le_trans with (1 + 0)%R; auto with real. replace (1 + 0)%R with 1%R; auto with real; ring. apply Rmult_le_reg_l with (1 - eps2)%R; auto with real. rewrite Rinv_r; auto with real. rewrite Rabs_Rinv; auto. apply Rmult_le_reg_l with (Rabs bi); auto with real. apply Rabs_pos_lt; auto with real. apply Rle_trans with ((1 - eps2) * (Rabs D * (Rabs bi * / Rabs bi)))%R; [ right; ring | rewrite (Rinv_r (Rabs bi)) ]; auto with real. repeat rewrite Rmult_1_r. apply InegAbsSup; auto. apply Rabs_no_R0; auto. Qed. Definition dsd (x y : R) := (0 <= x)%R /\ (0 <= y)%R \/ (x <= 0)%R /\ (y <= 0)%R. Theorem dsdAbs : forall x y : R, dsd x y -> Rabs (x - y) = Rabs (Rabs x - Rabs y). unfold dsd in |- *; intros. case H; intros H1; elim H1; intros; clear H1 H. rewrite (Rabs_pos_eq x); auto with real. rewrite (Rabs_pos_eq y); auto with real. rewrite (Faux.Rabsolu_left1 x); auto with real. rewrite (Faux.Rabsolu_left1 y); auto with real. replace (- x - - y)%R with (- (x - y))%R; [ rewrite (Rabs_Ropp (x - y)) | ring ]; auto with real. Qed. Theorem dsdsym : forall x y : R, dsd x y -> dsd y x. unfold dsd in |- *; intros; auto. case H; intros H1; case H1; intros; clear H H1; auto. Qed. Theorem Inegdsd : forall x y eps : R, x <> 0%R -> (eps < 1)%R -> (Rabs (/ x * (y - x)) <= eps)%R -> dsd x y. intros x y eps H H0 H1. cut (Rabs (/ x * (y - x)) < 1)%R; [ intros Z1 | apply Rle_lt_trans with eps; auto with real ]. case (Rle_or_lt x 0); intros Z2; case (Rle_or_lt y 0); intros Z3; auto. right; auto. 3: left; split; apply Rlt_le; auto with real. left; split; [ idtac | apply Rlt_le; auto with real ]. Contradict Z1. apply Rle_not_lt. rewrite Rabs_mult. rewrite Rabs_Rinv; auto. apply Rmult_le_reg_l with (Rabs x); auto with real. apply Rabs_pos_lt; auto with real. replace (Rabs x * (/ Rabs x * Rabs (y - x)))%R with (Rabs (y - x) * (Rabs x * / Rabs x))%R; [ idtac | ring ]. rewrite Rinv_r. apply Rmult_le_compat_r; auto with real. apply Rlt_le; auto with real. rewrite (Faux.Rabsolu_left1 x); auto. rewrite (Rabs_pos_eq (y - x)); auto with real. replace (- x)%R with (0 + - x)%R; [ unfold Rminus in |- *; auto with real | ring ]. apply Rle_trans with y; [ apply Rlt_le; auto | unfold Rminus in |- * ]. pattern y at 1 in |- *; replace y with (y + -0)%R; [ apply Rplus_le_compat_l; apply Ropp_le_contravar; auto with real | ring ]. apply Rabs_no_R0; auto. right; split; auto. Contradict Z1. apply Rle_not_lt. rewrite Rabs_mult. rewrite Rabs_Rinv; auto. apply Rmult_le_reg_l with (Rabs x); auto with real. apply Rabs_pos_lt; auto with real. replace (Rabs x * (/ Rabs x * Rabs (y - x)))%R with (Rabs (y - x) * (Rabs x * / Rabs x))%R; [ idtac | ring ]. rewrite Rinv_r. apply Rmult_le_compat_r; auto with real. rewrite (Rabs_pos_eq x); auto. rewrite (Faux.Rabsolu_left1 (y - x)); auto with real. rewrite Ropp_minus_distr'. pattern x at 1 in |- *; replace x with (x + -0)%R; [ unfold Rminus in |- *; auto with real | ring ]. apply Rle_trans with y; [ unfold Rminus in |- * | auto ]. pattern y at 2 in |- *; replace y with (y + -0)%R; [ apply Rplus_le_compat_l; apply Ropp_le_contravar; auto with real | ring ]. apply Rlt_le; auto. apply Rabs_no_R0; auto. Qed. Theorem dsdtrans : forall x y z : R, dsd x y -> dsd y z -> y <> 0%R -> dsd x z. intros x y z H H0 H1. case H0; intros (H'1, H'2); case H; intros (H'3, H'4); auto. left; auto. Contradict H1; apply Rle_antisym; auto. Contradict H1; apply Rle_antisym; auto. right; auto. Qed. Theorem dsdinv : forall x y : R, dsd x y -> y <> 0%R -> dsd x (/ y). intros x y H H0. case H; intros (H'1, H'2). left; split; auto with real. case H'2; intros H'3. apply Rlt_le; apply Rinv_0_lt_compat; auto. case H0; auto. right; split; auto. case H'2; intros H'3. apply Rlt_le; apply Rinv_lt_0_compat; auto. case H0; auto. Qed. Theorem dsdmult : forall x y r : R, dsd x y -> dsd (r * x) (r * y). intros x y r H. case (Rle_or_lt r 0); intros z1. case H; intros (H'1, H'2). right; split; apply Ropp_le_cancel; rewrite Ropp_0; rewrite <- Ropp_mult_distr_l_reverse; auto. replace 0%R with (-0 * 0)%R; [ auto with real | ring ]. replace 0%R with (-0 * 0)%R; [ auto with real | ring ]. left; split. replace (r * x)%R with (- r * - x)%R; [ idtac | ring ]. replace 0%R with (-0 * -0)%R; [ auto with real | ring ]. replace (r * y)%R with (- r * - y)%R; [ idtac | ring ]. replace 0%R with (-0 * -0)%R; [ auto with real | ring ]. case H; intros (H'1, H'2). left; split. replace 0%R with (0 * 0)%R; [ auto with real | ring ]. replace 0%R with (0 * 0)%R; [ auto with real | ring ]. right; split; apply Ropp_le_cancel; rewrite Ropp_0; rewrite Rmult_comm; rewrite <- Ropp_mult_distr_l_reverse. replace 0%R with (-0 * 0)%R; [ auto with real | ring ]. replace 0%R with (-0 * 0)%R; [ auto with real | ring ]. Qed. Theorem dsdwi1qiD : dsd wi1 (qi * D). case (Req_dec qi 0); intros H. rewrite H; replace (0 * D)%R with 0%R; [ auto with real | ring ]. case (Rle_or_lt wi1 0); intros H1; auto with real. right; split; auto with real. left; split; auto with real; apply Rlt_le; auto. cut (dsd wi1 ai); [ intros H1 | apply Inegdsd with eps1; auto ]. cut (dsd D bi); [ intros H2 | apply Inegdsd with eps2; auto ]. cut (dsd (/ bi * ai) qi); [ intros H3 | apply Inegdsd with eps3; auto ]. apply dsdtrans with ai; auto. apply dsdtrans with (qi * bi)%R. replace ai with (bi * (/ bi * ai))%R. rewrite (Rmult_comm qi bi); apply dsdmult; auto. replace (bi * (/ bi * ai))%R with (ai * (bi * / bi))%R; [ rewrite (Rinv_r bi); auto; ring | ring ]. apply dsdmult; apply dsdsym; auto. apply Rmult_integral_contrapositive; auto. apply Rmult_integral_contrapositive; split; auto. apply Rinv_neq_0_compat; auto. Qed. Theorem Maxwiwi1 : (Rabs wi * / Rabs wi1 <= Rmax (1 - (1 - eps3) * (1 - eps1) * / (1 + eps2)) ((1 + eps3) * (1 + eps1) * / (1 - eps2) - 1))%R. rewrite Hw. rewrite (dsdAbs wi1 (qi * D)); [ idtac | apply dsdwi1qiD ]. case (Rle_or_lt (Rabs wi1 - Rabs (qi * D)) 0); intros Z1. rewrite (fun x y => Faux.Rabsolu_left1 (x - y)); auto. replace (- (Rabs wi1 - Rabs (qi * D)))%R with (Rabs (qi * D) - Rabs wi1)%R; [ idtac | ring ]. apply Rle_trans with ((1 + eps3) * (1 + eps1) * / (1 - eps2) - 1)%R; [ apply DivSecondCase; auto | auto with real ]. apply RmaxLess2. rewrite (fun x y => Rabs_pos_eq (x - y)); [ idtac | apply Rlt_le; auto ]. apply Rle_trans with (1 - (1 - eps3) * (1 - eps1) * / (1 + eps2))%R; [ apply DivFirstCase; auto | auto with real ]. apply RmaxLess1. Qed. Theorem Rmax_simpl1 : forall p q : R, (p <= q)%R -> Rmax p q = q. intros p q H; unfold Rmax in |- *. case (Rle_dec p q); auto. intros H1; apply Rle_antisym; auto with real. Qed. Theorem RmaxProp : forall (P : R -> Prop) (x y : R), P x -> P y -> P (Rmax x y). intros. unfold Rmax in |- *; case (Rle_dec x y); simpl in |- *; auto. Qed. Theorem FexpEpsilon_aux : ((0 <= ep)%R /\ (ep < 1)%R) /\ (eps1 <= ep)%R /\ (eps2 <= ep)%R /\ (eps3 <= ep)%R. rewrite Hep. split. split; apply RmaxProp; auto; apply RmaxProp; auto. repeat split. apply Rle_trans with (Rmax eps1 eps2); apply RmaxLess1. apply Rle_trans with (Rmax eps1 eps2); [ apply RmaxLess2 | apply RmaxLess1 ]. apply RmaxLess2. Qed. Theorem FexpDivConv : (Rabs wi * / Rabs wi1 <= (ep + (ep + (ep + ep * ep))) * / (1 - ep))%R. generalize FexpEpsilon_aux; intros ((H1, H2), (H3, (H4, H5))). apply Rle_trans with (Rmax (1 - (1 - eps3) * (1 - eps1) * / (1 + eps2)) ((1 + eps3) * (1 + eps1) * / (1 - eps2) - 1)); [ apply Maxwiwi1 | idtac ]. apply RmaxProp. cut (0 < 1 + eps2)%R; [ intros Z1 | auto with real ]. pattern 1%R at 1 in |- *; replace 1%R with ((1 + eps2) * / (1 + eps2))%R; [ idtac | apply Rinv_r; apply Rlt_dichotomy_converse; auto with real ]. apply Rle_trans with ((1 + eps2 - (1 - eps3) * (1 - eps1)) * / (1 + eps2))%R; [ right; ring; ring | idtac ]. replace ((1 - eps3) * (1 - eps1))%R with (1 + (- eps3 + (- eps1 + eps3 * eps1)))%R; [ idtac | ring; ring ]. replace (1 + eps2 - (1 + (- eps3 + (- eps1 + eps3 * eps1))))%R with (eps2 + (eps3 + (eps1 + - (eps3 * eps1))))%R; [ idtac | ring; ring ]. apply Rle_trans with ((ep + (ep + ep)) * / (1 + eps2))%R. apply Rmult_le_compat_r. apply Rlt_le; apply Rinv_0_lt_compat; auto. apply Rplus_le_compat; auto. apply Rplus_le_compat; auto. apply Rle_trans with (ep + - (eps3 * eps1))%R; [ apply Rplus_le_compat; auto with real | idtac ]. pattern ep at 2 in |- *; replace ep with (ep + -0)%R; [ apply Rplus_le_compat; auto with real; apply Ropp_le_contravar; auto with real | ring ]. replace 0%R with (0 * 0)%R; [ auto with real | ring ]. apply Rle_trans with ((ep + (ep + ep)) * / (1 - ep))%R; [ apply Rmult_le_compat_l | idtac ]. replace 0%R with (0 + (0 + 0))%R; [ apply Rplus_le_compat; auto; apply Rplus_le_compat; auto | ring ]. apply Rle_Rinv; auto with real. unfold Rminus in |- *; apply Rplus_le_compat_l; apply Rle_trans with 0%R; auto. rewrite <- Ropp_0; apply Ropp_le_contravar; auto. apply Rmult_le_compat_r; [ apply Rlt_le; apply Rinv_0_lt_compat; auto | apply Rplus_le_compat_l; apply Rplus_le_compat_l ]; auto with real. pattern ep at 1 in |- *; replace ep with (ep + 0 * 0)%R; [ auto with real | ring ]. apply Rlt_le_trans with 1%R; [ auto with real | idtac ]. pattern 1%R at 1 in |- *; replace 1%R with (1 + 0)%R; [ apply Rplus_le_compat_l; auto | ring ]. pattern 1%R at 4 in |- *; replace 1%R with ((1 - eps2) * / (1 - eps2))%R; [ idtac | apply Rinv_r; auto with real ]. apply Rle_trans with ((eps3 + (eps1 + (eps2 + eps3 * eps1))) * / (1 - eps2))%R; [ right; ring; ring | idtac ]. apply Rle_trans with ((ep + (ep + (ep + ep * ep))) * / (1 - eps2))%R; [ apply Rmult_le_compat_r | apply Rmult_le_compat_l ]. apply Rlt_le; apply Rinv_0_lt_compat; auto with real. repeat apply Rplus_le_compat; auto with real. repeat (replace 0%R with (0 + 0)%R; [ apply Rplus_le_compat; auto | ring ]). replace 0%R with (0 * 0)%R; [ auto with real | ring ]. apply Rle_Rinv; [ auto with real | unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_contravar; auto with real ]. Qed. End Div. Section Div2. Variable b : Fbound. Variable radix : Z. Variable precision : nat. Coercion Local FtoRradix := FtoR radix. Hypothesis radixMoreThanOne : (1 < radix)%Z. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Theorem FulpDiv : forall x y p : float, Fbounded b x -> Fbounded b y -> Fbounded b p -> Closest b radix (x * / y) p -> y <> 0%R :>R -> Fnormal radix b (Fnormalize radix b precision x) -> (Fulp b radix precision x * / Rabs y <= radix * Fulp b radix precision p)%R. intros x y p H1 H2 H3 H4 H5 H6. replace (Fulp b radix precision x) with (1 * Fulp b radix precision x)%R; [ idtac | ring ]. replace 1%R with (powerRZ radix (Zpred precision) * powerRZ radix (Zsucc (- precision)))%R. 2: rewrite <- powerRZ_add; auto with zarith real. 2: replace (Zpred precision + Zsucc (- precision))%Z with 0%Z; [ simpl in |- *; ring | unfold Zsucc, Zpred in |- *; ring ]. apply Rle_trans with (powerRZ radix (Zpred precision) * Fulp b radix precision x * (powerRZ radix (Zsucc (- precision)) * / Rabs y))%R; [ right; ring | idtac ]. apply Rle_trans with (Rabs x * (powerRZ radix (Zsucc (- precision)) * / Rabs y))%R. apply Rmult_le_compat_r. replace 0%R with (0 * 0)%R; [ apply Rmult_le_compat | ring ]; auto with real. apply powerRZ_le; auto with real zarith. apply Rlt_le; apply Rinv_0_lt_compat; apply Rabs_pos_lt; auto. apply Rmult_le_reg_l with (powerRZ radix (Zsucc (- precision))). apply powerRZ_lt; auto with zarith real. rewrite <- Rmult_assoc. rewrite <- powerRZ_add; auto with zarith real. replace (Zsucc (- precision) + Zpred precision)%Z with 0%Z; [ simpl in |- * | unfold Zsucc, Zpred in |- *; ring ]. apply Rle_trans with (Fulp b radix precision x); [ right; ring | rewrite Rmult_comm ]. unfold FtoRradix in |- *; apply FulpLe2; auto. rewrite Rmult_comm. rewrite Rmult_assoc. apply Rle_trans with (powerRZ radix (Zsucc (- precision)) * (Rabs p + / 2%nat * Fulp b radix precision p))%R. apply Rmult_le_compat_l. apply powerRZ_le; auto with zarith real. rewrite <- Rabs_Rinv; auto; rewrite <- Rabs_mult. apply Rplus_le_reg_l with (- Rabs p)%R. replace (- Rabs p + Rabs (/ y * x))%R with (Rabs (/ y * x) - Rabs p)%R; [ idtac | ring ]. apply Rle_trans with (Rabs (/ y * x - p)); [ apply Rabs_triang_inv | idtac ]. apply Rle_trans with (/ 2%nat * Fulp b radix precision p)%R; [ idtac | right; ring ]. apply Rmult_le_reg_l with (INR 2); auto with arith real. rewrite <- Rmult_assoc. rewrite Rinv_r; auto with arith real. apply Rle_trans with (Fulp b radix precision p); [ idtac | right; ring ]. unfold FtoRradix in |- *; apply ClosestUlp; auto. fold FtoRradix in |- *; rewrite Rmult_comm; auto. apply Rle_trans with (powerRZ radix (Zsucc (- precision)) * ((powerRZ radix precision - 1) * Fulp b radix precision p + / 2%nat * Fulp b radix precision p))%R. apply Rmult_le_compat_l; [ apply powerRZ_le | apply Rplus_le_compat_r; unfold FtoRradix in |- *; apply FulpGe ]; auto with zarith real. apply Rle_trans with (powerRZ radix (Zsucc (- precision)) * (powerRZ radix precision - 1 + / 2%nat) * Fulp b radix precision p)%R; [ right; ring; ring | idtac ]. apply Rmult_le_compat_r. unfold Fulp in |- *; apply powerRZ_le; auto with zarith real. apply Rle_trans with (powerRZ radix (Zsucc (- precision)) * powerRZ radix precision)%R. apply Rmult_le_compat_l. apply powerRZ_le; auto with zarith real. unfold Rminus in |- *; rewrite Rplus_assoc. pattern (powerRZ radix precision) at 2 in |- *; replace (powerRZ radix precision) with (powerRZ radix precision + 0)%R; [ apply Rplus_le_compat_l | ring ]. apply Rplus_le_reg_l with 1%R. apply Rle_trans with (/ 2%nat)%R; [ right; ring | idtac ]. apply Rle_trans with 1%R; [ idtac | right; ring ]. rewrite <- Rinv_1; apply Rle_Rinv; auto with arith real. right; rewrite <- powerRZ_add; auto with zarith real. unfold Zsucc in |- *; simpl in |- *. replace (- precision + 1 + precision)%Z with 1%Z; [ simpl in |- * | idtac ]; ring. Qed. End Div2.Float8.4/Expansions/FexpPlus.v0000644000423700002640000006111512032774526016141 0ustar sboldotoccataRequire Export Fexp. Section mf. Variable radix : Z. Hypothesis radixMoreThanOne : (1 < radix)%Z. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Coercion Local FtoRradix := FtoR radix. Variable b : Fbound. Variable precision : nat. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Variable TwoSum : float -> float -> float * float. Hypothesis TwoSum1 : forall p q : float, Fbounded b p -> Fbounded b q -> Closest b radix (p + q) (fst (TwoSum p q)). Hypothesis TwoSum2 : forall p q : float, Fbounded b p -> Fbounded b q -> snd (TwoSum p q) = (p + q - fst (TwoSum p q))%R :>R. Hypothesis TwoSum3 : forall p q : float, Fbounded b p -> Fbounded b q -> Fbounded b (fst (TwoSum p q)). Hypothesis TwoSum4 : forall p q : float, Fbounded b p -> Fbounded b q -> Fbounded b (snd (TwoSum p q)). Hypothesis TwoSumEq1 : forall p q r s : float, Fbounded b p -> Fbounded b q -> Fbounded b r -> Fbounded b s -> p = q :>R -> r = s :>R -> fst (TwoSum p r) = fst (TwoSum q s) :>R. Hypothesis TwoSumEq2 : forall p q r s : float, Fbounded b p -> Fbounded b q -> Fbounded b r -> Fbounded b s -> p = q :>R -> r = s :>R -> snd (TwoSum p r) = snd (TwoSum q s) :>R. Fixpoint growExp (p : float) (L : list float) {struct L} : list float := match L with | nil => p :: nil | x :: L1 => match TwoSum p x with | (h, c) => c :: growExp h L1 end end. Theorem TwoSumExp : forall p q : float, Fbounded b p -> Fbounded b q -> IsExpansion b radix (snd (TwoSum p q) :: fst (TwoSum p q) :: nil). intros p q H' H'0. case (Z_zerop (Fnum (snd (TwoSum p q)))); intros Z1. apply IsExpansionTop1; auto. apply IsExpansionSingle; auto. case (Z_zerop (Fnum (fst (TwoSum p q)))); intros Z2. apply IsExpansionTop2; auto. apply IsExpansionSingle; auto. apply IsExpansionTop; auto. cut (snd (TwoSum p q) = Fminus radix (Fplus radix p q) (fst (TwoSum p q)) :>R); [ intros Eq1 | idtac ]. rewrite (MSB_comp radix) with (4 := Eq1); auto. apply (MSBroundLSB b radix precision) with (P := Closest b radix); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply (ClosestCompatible b radix (p + q)%R) with (p0 := fst (TwoSum p q)); auto. apply sym_eq; apply (Fplus_correct radix); auto with arith. apply NisFzeroComp with (radix := radix) (x := snd (TwoSum p q)); auto. rewrite (Fminus_correct radix); auto with arith; rewrite (Fplus_correct radix); auto with arith. apply IsExpansionSingle; auto. Qed. Theorem TwoSumOl1 : forall p q : float, Fbounded b p -> Fbounded b q -> is_Fzero q -> fst (TwoSum p q) = p :>R. intros p q H' H'0 H'1; generalize (TwoSum1 p q H' H'0); case (TwoSum p q); simpl in |- *; auto. intros f H'2 H'3. apply sym_eq; apply (RoundedModeProjectorIdemEq b radix precision) with (P := Closest b radix); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply (ClosestCompatible b radix) with (1 := H'3); auto. replace (FtoRradix q) with 0%R; [ unfold FtoRradix in |- *; ring | idtac ]. apply sym_eq; apply (is_Fzero_rep1 radix); auto. apply RoundedModeBounded with (radix := radix) (P := Closest b radix) (r := (p + q)%R); auto. apply ClosestRoundedModeP with (precision := precision); auto. Qed. Theorem TwoSumOl2 : forall p q : float, Fbounded b p -> Fbounded b q -> is_Fzero q -> snd (TwoSum p q) = 0%R :>R. intros p q H' H'0 H'1; generalize (TwoSumOl1 p q H' H'0 H'1); generalize (TwoSum2 p q H' H'0); case (TwoSum p q); simpl in |- *; auto. intros f f0 H'2 H'3. rewrite H'2. rewrite H'3. replace (FtoRradix q) with 0%R; [ unfold FtoRradix in |- *; ring | idtac ]. apply sym_eq; apply (is_Fzero_rep1 radix); auto. Qed. Theorem TwoSumOr1 : forall p q : float, Fbounded b p -> Fbounded b q -> is_Fzero p -> fst (TwoSum p q) = q :>R. intros p q H' H'0 H'1; generalize (TwoSum1 p q H' H'0); case (TwoSum p q); simpl in |- *; auto. intros f H'2 H'3. apply sym_eq; apply (RoundedModeProjectorIdemEq b radix precision) with (P := Closest b radix); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply (ClosestCompatible b radix) with (1 := H'3); auto. replace (FtoRradix p) with 0%R; [ unfold FtoRradix in |- *; ring | idtac ]. apply sym_eq; apply (is_Fzero_rep1 radix); auto. apply RoundedModeBounded with (radix := radix) (P := Closest b radix) (r := (p + q)%R); auto. apply ClosestRoundedModeP with (precision := precision); auto. Qed. Theorem TwoSumOr2 : forall p q : float, Fbounded b p -> Fbounded b q -> is_Fzero p -> snd (TwoSum p q) = 0%R :>R. intros p q H' H'0 H'1; generalize (TwoSumOr1 p q H' H'0 H'1); generalize (TwoSum2 p q H' H'0); case (TwoSum p q); simpl in |- *; auto. intros f f0 H'2 H'3. rewrite H'2. rewrite H'3. replace (FtoRradix p) with 0%R; [ unfold FtoRradix in |- *; ring | idtac ]. apply sym_eq; apply (is_Fzero_rep1 radix); auto. Qed. Theorem growExpIsVal : forall L : list float, IsExpansion b radix L -> forall p : float, Fbounded b p -> expValue radix (growExp p L) = (p + expValue radix L)%R :>R. intros L; elim L. simpl in |- *; auto. intros H' p H'0; rewrite (Fplus_correct radix); auto with arith. intros a l H' H'0 p H'1; simpl in |- *. CaseEq (TwoSum p a). intros f f0 H'2; simpl in |- *. repeat rewrite (Fplus_correct radix); auto with arith. rewrite H'. repeat rewrite <- Rplus_assoc. cut (Fbounded b a); [ intros Fb1 | apply (expBoundedInv b radix) with (L := l) ]; auto. generalize (TwoSum2 _ _ H'1 Fb1); rewrite H'2; simpl in |- *. unfold FtoRradix in |- *; intros H'3; rewrite H'3; ring; ring. apply expInv with (a := a); auto. cut (Fbounded b a); [ intros Fb1 | apply (expBoundedInv b radix) with (L := l) ]; auto. generalize (TwoSum3 _ _ H'1 Fb1); rewrite H'2; simpl in |- *; auto. Qed. Theorem IsExpansionCons : forall L : list float, IsExpansion b radix L -> forall p : float, ~ is_Fzero p -> Fbounded b p -> (forall q : float, In q L -> ~ is_Fzero q -> (MSB radix p < LSB radix q)%Z) -> IsExpansion b radix (p :: L). intros L; elim L. intros H' p H'0 H'1 H'2; apply IsExpansionSingle; auto. intros a l H' H'0 p H'1 H'2 H'3. case (is_FzeroP a); intros Z1. apply IsExpansionTop2; auto. apply expBoundedInv with (radix := radix) (L := l); auto. apply H'; auto. apply expInv with (a := a); auto. intros q H'4 H'5; apply H'3; auto. simpl in |- *; auto. apply IsExpansionTop; auto. apply expBoundedInv with (radix := radix) (L := l); auto. apply H'3; auto with datatypes. Qed. Theorem IsExpansionConsInvAux : forall L : list float, IsExpansion b radix L -> forall (L' : list float) (p q : float), ~ is_Fzero p -> L = p :: L' -> In q L' -> ~ is_Fzero q -> (MSB radix p < LSB radix q)%Z. intros L H'; elim H'; auto. intros L' p q H'0 H'1; discriminate. intros x H'0 L' p q H'1 H'2; inversion H'2; simpl in |- *. intros H'3; elim H'3. intros x L0 H'0 H'1 H'2 H'3 L' p q H'4 H'5; inversion H'5; auto. case H'4; rewrite <- H0; auto. intros x y L0 H'0 H'1 H'2 H'3 H'4 L' p q H'5 H'6; inversion H'6. simpl in |- *; auto. intros H'7 H'8; case H'7; intros H'9. case H'8; rewrite <- H'9; auto. apply H'4 with (L' := L0); auto. rewrite H0; auto. intros x y L0 H'0 H'1 H'2 H'3 H'4 H'5 H'6 L' p q H'7 H'8; inversion H'8; auto. simpl in |- *; auto. intros H'9 H'10; case H'9; intros H'11. rewrite <- H'11; rewrite <- H0; auto. apply Zlt_trans with (LSB radix y); auto. rewrite <- H0; auto. apply Zle_lt_trans with (MSB radix y); auto. apply LSB_le_MSB; auto. apply H'6 with (L' := L0); auto. Qed. Theorem IsExpansionConsInv : forall (L : list float) (p q : float), ~ is_Fzero p -> IsExpansion b radix (p :: L) -> In q L -> ~ is_Fzero q -> (MSB radix p < LSB radix q)%Z. intros L p q H' H'0 H'1 H'2. apply IsExpansionConsInvAux with (L := p :: L) (L' := L); auto. Qed. Theorem IsExpansionSkip : forall (L : list float) (p q : float), IsExpansion b radix (p :: q :: L) -> IsExpansion b radix (p :: L). intros L p q H'. case (is_FzeroP p); intros Z1. apply IsExpansionTop1; auto. apply expBoundedInv with (radix := radix) (L := q :: L); auto. apply expInv with (a := q); auto. apply expInv with (a := p); auto. apply IsExpansionCons; auto. apply expInv with (a := q); auto. apply expInv with (a := p); auto. apply expBoundedInv with (radix := radix) (L := q :: L); auto. intros q0 H'0 H'1. apply IsExpansionConsInv with (L := q :: L); auto with datatypes. Qed. Theorem TwoSumLt1 : forall p q : float, Fbounded b p -> Fbounded b q -> ~ is_Fzero p -> ~ is_Fzero q -> ~ is_Fzero (fst (TwoSum p q)) -> (Zmin (LSB radix p) (LSB radix q) <= LSB radix (fst (TwoSum p q)))%Z. intros p q H'0 H'1 H'2 H'3 H'4. apply Zle_trans with (LSB radix (Fplus radix p q)); auto. case (LSB_rep_min radix radixMoreThanOne p); auto; intros p' Hp'. case (LSB_rep_min radix radixMoreThanOne q); auto; intros q' Hq'. apply LSBPlus; auto. Contradict H'4; auto. apply (is_Fzero_rep2 radix); auto. rewrite <- (FzeroisZero radix b); auto. apply sym_eq; apply RoundedModeProjectorIdemEq with (b := b) (precision := precision) (P := Closest b radix); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply FboundedFzero; auto. apply (ClosestCompatible b radix) with (1 := TwoSum1 _ _ H'0 H'1); auto. rewrite (FzeroisZero radix b); auto. replace 0%R with (FtoRradix (Fplus radix p q)); auto. rewrite (Fplus_correct radix); auto with arith. apply (is_Fzero_rep1 radix); auto. repeat rewrite (Fplus_correct radix); auto with arith. apply RoundLSBMax with (b := b) (precision := precision) (P := Closest b radix); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply (ClosestCompatible b radix) with (1 := TwoSum1 _ _ H'0 H'1); auto. rewrite Fplus_correct; auto with arith. Qed. Theorem TwoSumLt2 : forall p q : float, Fbounded b p -> Fbounded b q -> ~ is_Fzero p -> ~ is_Fzero q -> ~ is_Fzero (snd (TwoSum p q)) -> (Zmin (LSB radix p) (LSB radix q) <= LSB radix (snd (TwoSum p q)))%Z. intros p q H' H'0 H'1 H'2 H'3. case (is_FzeroP (fst (TwoSum p q))); intros Z1. cut (snd (TwoSum p q) = Fplus radix p q :>R); [ intros Eq1 | idtac ]. replace (LSB radix (snd (TwoSum p q))) with (LSB radix (Fplus radix p q)); auto. apply LSBPlus; auto. apply (NisFzeroComp radix) with (3 := Eq1); auto. apply LSB_comp; auto. apply (NisFzeroComp radix) with (3 := Eq1); auto. rewrite TwoSum2; auto. unfold FtoRradix in |- *; rewrite (is_Fzero_rep1 radix) with (1 := Z1); auto. rewrite Fplus_correct; auto with arith; ring. cut (snd (TwoSum p q) = Fminus radix (Fplus radix p q) (fst (TwoSum p q)) :>R); [ intros Eq1 | idtac ]. replace (LSB radix (snd (TwoSum p q))) with (LSB radix (Fminus radix (Fplus radix p q) (fst (TwoSum p q)))). apply Zle_trans with (Zmin (LSB radix (Fplus radix p q)) (LSB radix (fst (TwoSum p q)))); auto. apply Zmin_Zle; auto. apply LSBPlus; auto. Contradict Z1; auto. apply (is_Fzero_rep2 radix); auto. rewrite <- (FzeroisZero radix b); auto. apply sym_eq; apply RoundedModeProjectorIdemEq with (b := b) (precision := precision) (P := Closest b radix); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply FboundedFzero; auto. apply (ClosestCompatible b radix) with (1 := TwoSum1 _ _ H' H'0); auto. rewrite (FzeroisZero radix b); auto. replace 0%R with (FtoRradix (Fplus radix p q)); auto. rewrite (Fplus_correct radix); auto with arith. apply (is_Fzero_rep1 radix); auto. apply TwoSumLt1; auto. apply LSBMinus; auto. apply (NisFzeroComp radix) with (3 := Eq1); auto. apply LSB_comp; auto. apply (NisFzeroComp radix) with (3 := Eq1); auto. rewrite TwoSum2; auto. rewrite (Fminus_correct radix); auto with arith; rewrite (Fplus_correct radix); auto with arith. Qed. Theorem IsExpansionGrowConsInvAux : forall L : list float, IsExpansion b radix L -> forall (L' : list float) (p q r : float), Fbounded b r -> ~ is_Fzero p -> L = p :: L' -> In q (growExp r L') -> ~ is_Fzero q -> (is_Fzero r -> (MSB radix p < LSB radix q)%Z) /\ (~ is_Fzero r -> (MSB radix p < LSB radix q)%Z \/ (LSB radix r <= LSB radix q)%Z). intros L H'; elim H'; simpl in |- *; auto. intros L' p q r H'0 H'1 H'2; discriminate. intros x H'0 L' p q r H'1 H'2 H'3; inversion H'3; simpl in |- *; auto. intros H'4 H'5; split; case H'4. intros H'6 H'7; case H'5; rewrite <- H'6; auto. intros H'6; elim H'6; auto. intros H'6; rewrite <- H'6; auto with zarith. intros H'6; elim H'6. intros x L0 H'0 H'1 H'2 H'3 L' p q r H'4 H'5 H'6; inversion H'6; auto. case H'5; rewrite <- H0; auto. intros x y L0 H'0 H'1 H'2 H'3 H'4 L' p q r H'5 H'6 H'7; inversion H'7. simpl in |- *. CaseEq (TwoSum r y); simpl in |- *; auto. intros f f0 H'8 H'9; elim H'9; intros H'10. intros H'11; case H'11; rewrite <- H'10. apply (is_Fzero_rep2 radix); auto. replace (FtoR radix f0) with (FtoRradix (snd (TwoSum r y))); auto. apply TwoSumOl2; auto. rewrite H'8; auto. split. intros H'11. case (H'4 L0 p q f); auto. replace f with (fst (TwoSum r y)); auto. rewrite H'8; auto. rewrite <- H0; auto. intros H'12 H'13; apply H'12; auto. replace f with (fst (TwoSum r y)); auto. apply (is_Fzero_rep2 radix); auto. replace 0%R with (FtoRradix r). apply TwoSumOl1; auto. apply (is_Fzero_rep1 radix); auto. rewrite H'8; auto. intros H'11. case (H'4 L0 p q f); auto. replace f with (fst (TwoSum r y)); auto. rewrite H'8; auto. rewrite <- H0; auto. intros H'13 H'14. case (is_FzeroP f); intros Z1; auto. replace (LSB radix r) with (LSB radix f); auto. apply LSB_comp; auto. replace f with (fst (TwoSum r y)); auto. apply TwoSumOl1; auto. rewrite H'8; auto. intros x y L0 H'0 H'1 H'2 H'3 H'4 H'5 H'6 L' p q r H'7 H'8 H'9; inversion H'9. simpl in |- *; auto. CaseEq (TwoSum r y); simpl in |- *; auto. intros f f0 H'10 H'11; case H'11; intros H'12. rewrite <- H'12; auto. intros H'13; split; auto. intros H'14; case H'13. replace f0 with (snd (TwoSum r y)); auto. apply (is_Fzero_rep2 radix); auto. apply TwoSumOr2; auto. rewrite H'10; auto. intros H'14. cut (Zmin (LSB radix r) (LSB radix y) <= LSB radix (snd (TwoSum r y)))%Z. rewrite H'10; simpl in |- *; auto. unfold Zmin in |- *; case (LSB radix r ?= LSB radix y)%Z; auto. intros H'15; left; apply Zlt_le_trans with (LSB radix y); auto. rewrite <- H0; auto. apply TwoSumLt2; auto. rewrite H'10; auto. intros H'13. case (H'6 L0 y q f); auto. replace f with (fst (TwoSum r y)); auto. rewrite H'10; auto. intros H'14 H'15; split. intros H'16. case H'15; auto. apply (NisFzeroComp radix) with (2 := H'1); auto. replace f with (fst (TwoSum r y)); auto. apply sym_eq; apply TwoSumOr1; auto. rewrite H'10; auto. intros H'17; apply Zlt_trans with (LSB radix y). rewrite <- H0; auto. apply Zle_lt_trans with (MSB radix y); auto. apply LSB_le_MSB; auto. intros H'17; apply Zlt_le_trans with (LSB radix y). rewrite <- H0; auto. replace (LSB radix y) with (LSB radix f); auto. apply sym_equal; apply LSB_comp; auto. replace f with (fst (TwoSum r y)); auto. apply sym_eq; apply TwoSumOr1; auto. rewrite H'10; auto. intros H'16; case (is_FzeroP f); intros Z1. left; apply Zlt_trans with (LSB radix y); auto. rewrite <- H0; auto. apply Zle_lt_trans with (MSB radix y); auto. apply LSB_le_MSB; auto. case H'15; auto; intros H'17. left; apply Zlt_trans with (LSB radix y); auto. rewrite <- H0; auto. apply Zle_lt_trans with (MSB radix y); auto. apply LSB_le_MSB; auto. cut (Zmin (LSB radix r) (LSB radix y) <= LSB radix (fst (TwoSum r y)))%Z. rewrite H'10; simpl in |- *; auto. unfold Zmin in |- *; case (LSB radix r ?= LSB radix y)%Z; auto. intros H'18; right; apply Zle_trans with (1 := H'18); auto. intros H'18; right; apply Zle_trans with (1 := H'18); auto. intros H'18; left; apply Zlt_le_trans with (LSB radix y). rewrite <- H0; auto. apply Zle_trans with (1 := H'18); auto. apply TwoSumLt1; auto. rewrite H'10; auto. Qed. Theorem growExpIsExp : forall L : list float, IsExpansion b radix L -> forall p : float, Fbounded b p -> IsExpansion b radix (growExp p L). intros L; elim L; simpl in |- *; auto. intros H' p H'0. apply IsExpansionSingle; auto. intros a l H' H'0 p H'1; CaseEq (TwoSum p a); auto. intros f f0 H'2. cut (Fbounded b a); [ intros Fba | apply (expBoundedInv b radix) with (L := l) ]; auto. case (is_FzeroP f0); intros Z1. apply IsExpansionTop1; auto. replace f0 with (snd (TwoSum p a)); auto. rewrite H'2; auto. apply H'; auto. apply expInv with (a := a); auto. replace f with (fst (TwoSum p a)); auto. rewrite H'2; auto. apply IsExpansionCons; auto. apply H'; auto. apply expInv with (a := a); auto. replace f with (fst (TwoSum p a)); auto. rewrite H'2; auto. replace f0 with (snd (TwoSum p a)); auto. rewrite H'2; auto. intros q H'3 H'4. cut (IsExpansion b radix (f0 :: l)); [ intros IsE1 | idtac ]. case (IsExpansionGrowConsInvAux (f0 :: l) IsE1 l f0 q f); auto. replace f with (fst (TwoSum p a)); auto. rewrite H'2; auto. intros H'5 H'6. case (is_FzeroP f); intros Z2; auto. case H'6; auto. intros H'7; apply Zlt_le_trans with (2 := H'7). generalize (TwoSumExp p a H'1 Fba); rewrite H'2; simpl in |- *; intros IsE2; inversion IsE2; auto. case Z1; auto. case Z2; auto. apply IsExpansionCons; auto. apply expInv with (a := a); auto. replace f0 with (snd (TwoSum p a)); auto. rewrite H'2; auto. intros q0 H'5 H'6. apply Zle_lt_trans with (MSB radix a). apply MSB_monotone; auto. Contradict Z1. apply (is_Fzero_rep2 radix); auto. replace f0 with (snd (TwoSum p a)); auto. apply TwoSumOl2; auto. rewrite H'2; auto. repeat rewrite Fabs_correct; auto with arith. replace f0 with (snd (TwoSum p a)); auto. rewrite TwoSum2; auto. replace (FtoR radix a) with (p + a - p)%R; [ idtac | unfold FtoRradix in |- *; ring ]. cut (forall x y : R, Rabs (x - y) = Rabs (y - x)); [ intros Re1; repeat rewrite (Re1 (p + a)%R) | intros x y; rewrite <- (Ropp_minus_distr x); rewrite Rabs_Ropp; auto ]. case (TwoSum1 _ _ H'1 Fba); auto. rewrite H'2; auto. apply IsExpansionConsInv with (L := l); auto. Contradict Z1. apply (is_Fzero_rep2 radix); auto. replace f0 with (snd (TwoSum p a)); auto. apply TwoSumOl2; auto. rewrite H'2; auto. Qed. Fixpoint addExp (L1 L2 : list float) {struct L1} : list float := match L1 with | nil => L2 | x :: L'1 => match growExp x L2 with | nil => L'1 | y :: L'2 => y :: addExp L'1 L'2 end end. Theorem addExpIsVal : forall L1 L2 : list float, IsExpansion b radix L1 -> IsExpansion b radix L2 -> expValue radix (addExp L1 L2) = (expValue radix L1 + expValue radix L2)%R :>R. intros L1; elim L1; simpl in |- *; auto. intros L2 HL1 HL2; replace (FtoRradix (Fzero 0)) with 0%R; [ ring | apply sym_eq; apply (is_Fzero_rep1 radix); red in |- *; simpl in |- * ]; auto. intros a l Rec L2 HL1 HL2. cut (Fbounded b a); [ intros Fba | apply (expBoundedInv b radix) with (L := l) ]; auto. generalize (growExpIsVal L2 HL2 a Fba); generalize (growExpIsExp L2 HL2 a Fba); case (growExp a L2); simpl in |- *; auto. intros H' H'0; rewrite (Fplus_correct radix); auto with zarith. replace (FtoR radix a + FtoR radix (expValue radix l) + expValue radix L2)%R with (a + expValue radix L2 + expValue radix l)%R; [ idtac | unfold FtoRradix in |- *; ring ]. rewrite <- H'0; auto. replace (FtoRradix (Fzero 0)) with 0%R; [ ring | apply sym_eq; apply (is_Fzero_rep1 radix); red in |- *; simpl in |- * ]; auto. intros f l0 H' H'0; repeat rewrite (Fplus_correct radix); auto with zarith. rewrite Rec; auto. replace (FtoR radix a + FtoR radix (expValue radix l) + expValue radix L2)%R with (a + expValue radix L2 + expValue radix l)%R; [ idtac | unfold FtoRradix in |- *; ring ]. rewrite <- H'0; repeat rewrite (Fplus_correct radix); auto with zarith. unfold FtoRradix in |- *; ring. apply expInv with (a := a); auto. apply expInv with (a := f); auto. Qed. Theorem IsExpansionAddInv : forall (L1 L2 : list float) (p q : float), ~ is_Fzero p -> ~ is_Fzero q -> IsExpansion b radix (p :: L1) -> IsExpansion b radix (p :: L2) -> In q (addExp L1 L2) -> (MSB radix p < LSB radix q)%Z. intros L1; elim L1; simpl in |- *; auto. intros L2 p q H' H'0 H'1 H'2 H'3. apply IsExpansionConsInv with (L := L2); auto. intros a l H' L2 p q H'0 H'1 H'2 H'3; CaseEq (growExp a L2); simpl in |- *. intros H'4 H'5. apply IsExpansionConsInv with (L := a :: l); auto with datatypes. intros f l0 H'4 H'5; elim H'5; clear H'5; intros H'5; [ rewrite <- H'5 | idtac ]; auto. generalize H'3 H'4; case L2; simpl in |- *; auto. intros H'6 H'7; inversion H'7. rewrite <- H0; auto. apply IsExpansionConsInv with (L := a :: l); auto with datatypes. rewrite H0; auto. rewrite H'5; auto. intros f0 l1 H'6; CaseEq (TwoSum a f0). intros f1 f2 H'7 H'8; inversion H'8. cut (~ is_Fzero a); [ intros Za | idtac ]. cut (~ is_Fzero f0); [ intros Zf0 | idtac ]. apply Zlt_le_trans with (Zmin (LSB radix a) (LSB radix f0)). unfold Zmin in |- *; case (LSB radix a ?= LSB radix f0)%Z. apply IsExpansionConsInv with (L := a :: l); auto with datatypes. apply IsExpansionConsInv with (L := a :: l); auto with datatypes. apply IsExpansionConsInv with (L := f0 :: l1); auto with datatypes. replace f with (snd (TwoSum a f0)); [ idtac | rewrite H'7; auto ]; apply TwoSumLt2; auto. apply expBoundedInv with (radix := radix) (L := l); auto. apply expInv with (a := p); auto. apply expBoundedInv with (radix := radix) (L := l1); auto. apply expInv with (a := p); auto. rewrite H'7; simpl in |- *. rewrite H0. rewrite H'5; auto. Contradict H'1. rewrite <- H'5. rewrite <- H0. replace f2 with (snd (TwoSum a f0)); [ idtac | rewrite H'7; auto ]; apply (is_Fzero_rep2 radix); auto; apply TwoSumOl2; auto. apply expBoundedInv with (radix := radix) (L := l); auto. apply expInv with (a := p); auto. apply expBoundedInv with (radix := radix) (L := l1); auto. apply expInv with (a := p); auto. Contradict H'1. rewrite <- H'5. rewrite <- H0. replace f2 with (snd (TwoSum a f0)); [ idtac | rewrite H'7; auto ]; apply (is_Fzero_rep2 radix); auto; apply TwoSumOr2; auto. apply expBoundedInv with (radix := radix) (L := l); auto. apply expInv with (a := p); auto. apply expBoundedInv with (radix := radix) (L := l1); auto. apply expInv with (a := p); auto. apply (H' l0); auto. apply IsExpansionSkip with (q := a); auto. apply IsExpansionCons; auto. apply expInv with (a := f); auto. rewrite <- H'4. apply growExpIsExp; auto. apply expInv with (a := p); auto. apply expBoundedInv with (radix := radix) (L := l); auto. apply expInv with (a := p); auto. apply expBoundedInv with (radix := radix) (L := L2); auto. intros q0 H'6 H'7. case (IsExpansionGrowConsInvAux (p :: L2) H'3 L2 p q0 a); auto. apply expBoundedInv with (radix := radix) (L := l); auto. apply expInv with (a := p); auto. rewrite H'4; auto with datatypes. intros H'8 H'9; case (is_FzeroP a); auto. intros H'10; case H'9; auto. intros H'11; apply Zlt_le_trans with (2 := H'11); auto. apply IsExpansionConsInv with (L := a :: l); auto with datatypes. Qed. Theorem addExpIsExp : forall L1 L2 : list float, IsExpansion b radix L1 -> IsExpansion b radix L2 -> IsExpansion b radix (addExp L1 L2). intros L1; elim L1; simpl in |- *; auto. intros a l Rec L2 HL1 HL2. cut (Fbounded b a); [ intros Fba | apply (expBoundedInv b radix) with (L := l) ]; auto. generalize (growExpIsVal L2 HL2 a Fba); generalize (growExpIsExp L2 HL2 a Fba); CaseEq (growExp a L2); simpl in |- *; auto. intros H' H'0 H'1. apply expInv with (a := a); auto. intros f l0 H' H'0 H'1. case (is_FzeroP f); intros Z1; auto. apply IsExpansionTop1; auto. apply expBoundedInv with (radix := radix) (L := l0); auto. apply Rec; auto. apply expInv with (a := a); auto. apply expInv with (a := f); auto. apply IsExpansionCons; auto. apply Rec; auto. apply expInv with (a := a); auto. apply expInv with (a := f); auto. apply expBoundedInv with (radix := radix) (L := l0); auto. intros q H'2 H'3. apply IsExpansionAddInv with (L1 := l) (L2 := l0); auto. generalize H' HL2; case L2; simpl in |- *; auto. intros H'4; inversion H'4; auto. rewrite <- H0; auto. intros f0 l1; CaseEq (TwoSum a f0). intros f1 f2 H'4 H'5; inversion H'5. intros H'6. cut (~ is_Fzero a); [ intros Z2 | idtac ]. apply IsExpansionCons; auto. apply expInv with (a := a); auto. apply expBoundedInv with (radix := radix) (L := l0); auto. intros q0 H'7 H'8. apply Zle_lt_trans with (MSB radix a). apply MSB_monotone; auto. rewrite <- H0; auto. repeat rewrite (Fabs_correct radix); auto with arith. replace (FtoR radix f2) with (FtoRradix (snd (TwoSum a f0))); [ idtac | rewrite H'4; auto ]. rewrite TwoSum2; auto. replace (FtoR radix a) with (a + f0 - f0)%R; [ idtac | unfold FtoRradix in |- *; ring ]. cut (forall x y z : R, Rabs (x + y - z) = Rabs (z - (x + y))); [ intros Ra1; repeat rewrite Ra1 | intros; rewrite <- Ropp_minus_distr; rewrite Rabs_Ropp ]; auto. case (TwoSum1 a f0); auto. apply expBoundedInv with (radix := radix) (L := l1); auto. intros H'9 H'10; apply H'10; auto. apply expBoundedInv with (radix := radix) (L := l1); auto. apply expBoundedInv with (radix := radix) (L := l1); auto. apply IsExpansionConsInv with (L := l); auto. Contradict Z1. rewrite <- H0. replace f2 with (snd (TwoSum a f0)). apply (is_Fzero_rep2 radix); auto. apply TwoSumOr2; auto. apply expBoundedInv with (radix := radix) (L := l1); auto. rewrite H'4; auto. Qed. End mf.Float8.4/Expansions/ThreeSum2.v0000644000423700002640000004563412032774526016221 0ustar sboldotoccata(**************************************************************************** IEEE754 : ThreeSum2 Laurent Thery & Sylvie Boldo ******************************************************************************) Require Export AllFloat. Section F2. Variable b : Fbound. Variable precision : nat. Let radix := 2%Z. Coercion Local FtoRradix := FtoR radix. Let TMTO : (1 < radix)%Z := TwoMoreThanOne. Hint Resolve TMTO: zarith. Hypothesis precisionNotZero : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Variables p q r u v w p' q' r' : float. Hypothesis Fp : Fbounded b p. Hypothesis Fq : Fbounded b q. Hypothesis Fr : Fbounded b r. Hypothesis Fu : Fbounded b u. Hypothesis Fv : Fbounded b v. Hypothesis Fw : Fbounded b w. Hypothesis Fp' : Fbounded b p'. Hypothesis Fq' : Fbounded b q'. Hypothesis Fr' : Fbounded b r'. Hypothesis epq : (Fexp q <= Fexp p)%Z. Hypothesis eqr : (Fexp r <= Fexp q)%Z. Hypothesis uDef : Closest b radix (q + r) u. Hypothesis vDef : v = (q + r - u)%R :>R. Hypothesis p'Def : Closest b radix (p + u) p'. Hypothesis wDef : w = (p + u - p')%R :>R. Hypothesis q'Def : Closest b radix (w + v) q'. Hypothesis r'Def : r' = (w + v - q')%R :>R. Theorem TwoSumNul : forall f g x : float, Closest b radix (f + g) x -> x = 0%R :>R -> Fbounded b f -> Fbounded b g -> (f + g - x)%R = 0%R. intros f g x H H0 H1 H2. replace (FtoRradix f + FtoRradix g - FtoRradix x)%R with (FtoRradix f + FtoRradix g)%R; [ idtac | rewrite H0; ring ]. replace 0%R with (FtoRradix (Fzero (- dExp b))); [ idtac | unfold FtoRradix, FtoR in |- *; simpl in |- *; ring ]. apply sym_eq; apply (plusExact1 b radix) with (precision := precision); auto with arith. cut (CompatibleP b radix (Closest b radix)); [ intros Cp | apply ClosestCompatible; auto ]. apply Cp with (r1 := (f + g)%R) (p := x); auto with real. fold FtoRradix in |- *; rewrite H0; unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. repeat split; simpl in |- *; auto with zarith. simpl in |- *; apply Zmin_Zle; auto with float. Qed. Theorem bound3Sum : r' <> 0%R :>R -> (Rabs (q' + r') < 3%nat * radix * / pPred (vNum b) * Rabs p')%R. intros H'; case (Req_dec w 0); intros Hw. Contradict H'. rewrite r'Def; auto. rewrite Hw; rewrite Rplus_0_l. apply Rminus_diag_eq. unfold FtoRradix in |- *; apply ClosestIdem with (b := b); auto. replace (FtoR radix v) with (w + v)%R; auto. rewrite Hw; rewrite Rplus_0_l; auto. rewrite r'Def; rewrite Rplus_minus. apply Rle_lt_trans with (1 := Rabs_triang w v). apply Rlt_le_trans with (3%nat * radix * / pPred (vNum b) * (/ radix * Rmax (Rabs p) (Rabs u)))%R. replace (3%nat * radix * / pPred (vNum b))%R with (radix * radix * / pPred (vNum b) + radix * / pPred (vNum b))%R; [ idtac | simpl in |- *; ring ]. rewrite (fun x y : R => Rmult_comm x (/ radix * y)); rewrite Rmult_plus_distr_l; repeat rewrite (fun y : R => Rmult_comm (/ radix * y)). apply Rplus_lt_compat. replace (radix * radix * / pPred (vNum b) * (/ radix * Rmax (Rabs p) (Rabs u)))%R with (radix * / radix * (radix * / pPred (vNum b) * Rmax (Rabs p) (Rabs u)))%R; [ rewrite Rinv_r; auto with real zarith; try rewrite Rmult_1_l | ring ]. rewrite wDef. rewrite <- Ropp_minus_distr; rewrite Rabs_Ropp. apply (plusErrorBound2 b precision); auto. Contradict Hw. rewrite wDef. apply Rminus_diag_eq. unfold FtoRradix in |- *; rewrite (is_Fzero_rep1 radix _ Hw); auto. rewrite <- (FzeroisZero radix b). apply sym_eq; apply (plusExact1 b radix precision); auto. apply (ClosestCompatible b radix (p + u)%R (FtoR radix p + FtoR radix u)%R p'); auto. rewrite FzeroisZero; apply is_Fzero_rep1; auto. apply FboundedFzero; auto. simpl in |- *; unfold Zmin in |- *; case (Fexp p ?= Fexp u)%Z; auto with float. apply Rlt_le_trans with (radix * / pPred (vNum b) * (/ radix * Rabs u))%R. rewrite vDef. rewrite <- Ropp_minus_distr; rewrite Rabs_Ropp. replace (radix * / pPred (vNum b) * (/ radix * Rabs u))%R with (Rabs u * / radix * (radix * / pPred (vNum b)))%R; [ idtac | ring ]. unfold FtoRradix in |- *; apply (plusErrorBound1 b radix precision); auto. Contradict Hw. rewrite wDef. unfold FtoRradix in |- *; rewrite (is_Fzero_rep1 radix _ Hw). rewrite Rplus_0_r. apply Rminus_diag_eq. unfold FtoRradix in |- *; apply ClosestIdem with (b := b); auto. replace (FtoR radix p) with (p + u)%R; auto. unfold FtoRradix in |- *; rewrite (is_Fzero_rep1 radix _ Hw). rewrite Rplus_0_r; auto. apply Rmult_le_compat_l; auto with real. replace 0%R with (radix * 0)%R; auto with real; apply Rmult_le_compat_l; auto with real arith. apply Rlt_le; apply Rinv_0_lt_compat; auto with real arith. apply Rlt_IZRO. apply (pPredMoreThanOne b radix precision); auto with arith. apply Rmult_le_compat_l; auto with real arith. apply RmaxLess2; auto. apply Rmult_le_compat_l; auto with real arith. replace 0%R with (3%nat * radix * 0)%R; auto with real; apply Rmult_le_compat_l; auto with real arith. replace (3%nat * radix)%R with (INR 6); [ idtac | simpl in |- *; ring ]. replace 0%R with (INR 0); auto with real arith. apply Rlt_le; apply Rinv_0_lt_compat; auto with real arith. apply Rlt_IZRO. apply (pPredMoreThanOne b radix precision); auto with arith. apply (plusClosestLowerBound b precision); auto with real. Contradict Hw. rewrite wDef. unfold FtoRradix, radix in |- *; rewrite Hw; ring. Qed. Theorem exp3Sum : exists p'' : float, (exists q'' : float, (exists r'' : float, (Fbounded b p'' /\ Fbounded b q'' /\ Fbounded b r'') /\ (p'' = p' :>R /\ q'' = q' :>R /\ r'' = r' :>R) /\ (Fexp r <= Fexp r'')%Z /\ ((Fexp r'' <= Fexp q'')%Z /\ (Fexp q'' <= Fexp p'')%Z) /\ Fexp r'' = Fexp r)). cut (Fbounded b (Fzero (Fexp r))); [ intros Fbr | apply FboundedZeroSameExp ]; auto. case (Req_dec v 0); intros Hv. cut (Fzero (Fexp r) = r' :>R); [ intros EqZr | rewrite (FzeroisReallyZero radix); rewrite r'Def; rewrite Hv; rewrite Rplus_0_r; apply sym_eq; apply Rminus_diag_eq; unfold FtoRradix in |- *; apply (ClosestIdem b radix); auto; apply (ClosestCompatible b radix (w + v)%R w q'); auto; rewrite Hv; ring ]. case (plusExpMin b radix precision) with (P := Closest b radix) (5 := uDef); auto. apply ClosestRoundedModeP with (precision := precision); auto. intros u' (H'0, (H'2, H'3)). case (Req_dec w 0); intros Hw. case (plusExpMin b radix precision) with (P := Closest b radix) (p := p) (q := u') (pq := p'); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply (ClosestCompatible b radix (p + u)%R (FtoR radix p + FtoR radix u')%R p'); auto. rewrite H'2; auto. intros p'' (H'1, (H'5, H'6)). exists p''; exists (Fzero (Fexp r)); exists (Fzero (Fexp r)); split; [ idtac | split ]; (split; [ idtac | split ]); auto. rewrite (FzeroisReallyZero radix); auto. rewrite <- (FzeroisZero radix b). unfold FtoRradix in |- *; apply (ClosestIdem b radix); auto. apply FboundedFzero; auto. apply (ClosestCompatible b radix (w + v)%R (Fzero (- dExp b)) q'); auto. rewrite Hw; rewrite Hv; unfold FtoRradix in |- *; rewrite (FzeroisZero radix b); ring. simpl in |- *; auto with zarith. split; simpl in |- *; auto with zarith. simpl in |- *. apply Zle_trans with (2 := H'6). apply Zmin_Zle; auto. apply Zle_trans with (Fexp q); auto. rewrite <- (Zmin_le2 (Fexp q) (Fexp r)); auto. case (errorBoundedPlus b radix precision) with (p := p) (q := u') (pq := p'); auto. apply (ClosestCompatible b radix (p + u)%R (FtoR radix p + FtoR radix u')%R p'); auto. rewrite H'2; auto. intros w' (H'1, (H'5, H'6)). exists p'; exists w'; exists (Fzero (Fexp r)); split; [ idtac | split ]; (split; [ idtac | split ]); auto. unfold FtoRradix in |- *; apply (ClosestIdem b radix); auto. apply (ClosestCompatible b radix (w + v)%R (FtoR radix w') q'); auto. rewrite Hv; rewrite Rplus_0_r; auto. rewrite wDef; unfold FtoRradix in |- *; rewrite <- H'2; auto. simpl in |- *; auto with zarith. split; simpl in |- *; auto with zarith. simpl in |- *; rewrite H'6. apply Zmin_Zle; auto. apply Zle_trans with (Fexp q); auto. apply Zle_trans with (2 := H'3); auto with zarith. rewrite Zmin_le2; auto with zarith. rewrite H'6. apply Zlt_le_weak. apply (plusExact1bis b radix precision); auto. apply (ClosestCompatible b radix (p + u)%R (FtoR radix p + FtoR radix u')%R p'); auto. rewrite H'2; auto. Contradict Hw. rewrite wDef; auto. unfold FtoRradix in |- *; rewrite <- H'2. rewrite <- Hw; ring; ring. case (Req_dec w 0); intros Hw. cut (Fzero (Fexp r) = r' :>R); [ intros EqZr | rewrite (FzeroisReallyZero radix); rewrite r'Def; rewrite Hw; rewrite Rplus_0_l; apply sym_eq; apply Rminus_diag_eq; unfold FtoRradix in |- *; apply (ClosestIdem b radix); auto; apply (ClosestCompatible b radix (w + v)%R (FtoR radix v) q'); auto; rewrite Hw; unfold FtoRradix in |- *; ring ]. case (plusExpMin b radix precision) with (P := Closest b radix) (5 := uDef); auto. apply ClosestRoundedModeP with (precision := precision); auto. intros u' (H'0, (H'2, H'3)). case (errorBoundedPlus b radix precision) with (p := q) (q := r) (pq := u'); auto. apply (ClosestCompatible b radix (FtoR radix q + FtoR radix r)%R (FtoR radix q + FtoR radix r)%R u); auto. intros v' H'; elim H'; intros H'1 H'4; elim H'4; intros H'5 H'6; clear H'4 H'. case (plusExpMin b radix precision) with (P := Closest b radix) (p := p) (q := u') (pq := p'); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply (ClosestCompatible b radix (p + u)%R (FtoR radix p + FtoR radix u')%R p'); auto. rewrite H'2; auto. intros p'' (H'4, (H'8, H'9)). exists p''; exists v'; exists (Fzero (Fexp r)); split; [ idtac | split ]; (split; [ idtac | split ]); auto. replace (FtoRradix v') with (FtoRradix v); [ idtac | rewrite vDef; auto ]. unfold FtoRradix in |- *; apply (ClosestIdem b radix); auto; apply (ClosestCompatible b radix (w + v)%R (FtoR radix v) q'); auto; rewrite Hw; unfold FtoRradix in |- *; ring. unfold FtoRradix in |- *; rewrite H'1; auto. rewrite H'2; auto. simpl in |- *; auto with zarith. split; simpl in |- *; auto with zarith. rewrite H'6; rewrite Zmin_le2; auto with zarith. apply Zle_trans with (2 := H'9). apply Zmin_Zle; auto. rewrite H'6; auto. apply Zle_trans with (Fexp q); auto with zarith. rewrite H'6; auto. case (plusExpMin b radix precision) with (P := Closest b radix) (5 := uDef); auto. apply ClosestRoundedModeP with (precision := precision); auto. intros u' (H'0, (H'2, H'3)). case (errorBoundedPlus b radix precision) with (p := q) (q := r) (pq := u'); auto. apply (ClosestCompatible b radix (FtoR radix q + FtoR radix r)%R (FtoR radix q + FtoR radix r)%R u); auto. intros v' H'; elim H'; intros H'1 H'4; elim H'4; intros H'5 H'6; clear H'4 H'. case (errorBoundedPlus b radix precision) with (p := p) (q := u') (pq := p'); auto. apply (ClosestCompatible b radix (p + u)%R (FtoR radix p + FtoR radix u')%R p'); auto. rewrite H'2; auto. intros w' (H'4, (H'8, H'9)). case (plusExpBound b radix precision) with (P := Closest b radix) (p := w') (q := v') (pq := q'); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply (ClosestCompatible b radix (w + v)%R (FtoR radix w' + FtoR radix v')%R q'); auto. rewrite wDef; unfold FtoRradix in |- *; rewrite H'4; auto. unfold FtoRradix in vDef; rewrite vDef; unfold FtoRradix in |- *; rewrite <- H'2; rewrite H'1; auto. intros q'' (H'7, (H'11, (H'13, H'14))). case (errorBoundedPlus b radix precision) with (p := v') (q := w') (pq := q''); auto. apply (ClosestCompatible b radix (w + v)%R (FtoR radix v' + FtoR radix w')%R q'); auto. rewrite wDef; rewrite vDef; rewrite H'4; rewrite H'1; unfold FtoRradix in |- *; repeat rewrite H'2; ring; ring. intros r'' (H'10, (H'15, H'16)). exists p'; exists q''; exists r''; split; [ idtac | split ]; (split; [ idtac | split ]); auto. rewrite r'Def; rewrite wDef; rewrite vDef; unfold FtoRradix in |- *; rewrite H'10; rewrite H'4; rewrite H'1; repeat rewrite H'2; rewrite H'11; ring; ring. rewrite H'16; apply Zmin_Zle; auto with zarith. rewrite H'6; apply Zmin_Zle; auto with zarith. rewrite H'9; apply Zmin_Zle; auto with zarith. apply Zle_trans with (2 := H'3); apply Zmin_Zle; auto with zarith. split. rewrite H'16; rewrite Zmin_sym; auto. apply Zle_trans with (1 := H'14). rewrite Zmax_le1; auto. apply Zlt_le_succ; auto. rewrite H'9. apply plusExact1bis with (b := b) (radix := radix) (precision := precision); auto. apply (ClosestCompatible b radix (p + u)%R (FtoR radix p + FtoR radix u')%R p'); auto. rewrite H'2; auto. Contradict Hw; auto. rewrite wDef; auto. unfold FtoRradix in |- *; rewrite <- H'2. rewrite <- Hw; ring; ring. rewrite H'9. apply Zmin_Zle; auto. rewrite H'6; rewrite Zmin_le2; auto with zarith. rewrite H'6; auto. rewrite H'16. rewrite H'6. rewrite H'9. replace (Zmin (Fexp q) (Fexp r)) with (Fexp r). apply Zmin_le1. apply Zmin_Zle; auto. apply Zle_trans with (Fexp q); auto. rewrite <- (Zmin_le2 (Fexp q) (Fexp r)); auto. apply sym_eq; apply Zmin_le2; auto. Qed. Theorem OutSum3 : r' <> 0%R :>R -> (Float 1%nat (Fexp r) < 3%nat * (radix * (radix * (Rabs p' * / (pPred (vNum b) * (radix * pPred (vNum b) - radix))))))%R. intros H; case exp3Sum; intros p'' (q'', (r'', ((H'1, (H'2, H'3)), ((H'4, (H'5, H'6)), (H'7, ((H'8, H'9), H'10)))))). cut (~ is_Fzero q'); [ intros Z1 | idtac ]. 2: Contradict H; auto with real float. 2: replace (FtoRradix r') with (w + v - q')%R; auto. 2: apply TwoSumNul; auto. 2: unfold is_Fzero in H. 2: unfold FtoRradix, FtoR in |- *. 2: replace (Fnum q') with 0%Z; simpl; ring. apply Rle_lt_trans with (Rabs r''). apply Rle_trans with (FtoR radix (Float 1%nat (Fexp r''))). unfold FtoRradix in |- *. replace (Fexp r) with (Fexp r''); auto with real. rewrite <- (Fabs_correct radix); auto with arith. apply Fop.RleFexpFabs; auto with arith. fold FtoRradix in |- *. rewrite H'6; auto. apply Rlt_trans with (Rabs q' * / radix * (radix * / pPred (vNum b)))%R. replace (FtoRradix r'') with (w + v - q')%R. replace (Rabs (w + v - q')) with (Rabs (q' - (w + v))). apply plusErrorBound1 with (b := b) (radix := radix) (precision := precision) (p := w) (q := v); auto with arith. apply Rabs_minus_sym. rewrite H'6; auto. cut ((Rabs q' < 3%nat * (radix * (Rabs p' * / pPred (vNum b))) + Rabs q' * / pPred (vNum b))%R -> (Rabs q' * / radix * (radix * / pPred (vNum b)) < 3%nat * (radix * (radix * (Rabs p' * / (pPred (vNum b) * (radix * pPred (vNum b) - radix))))))%R). intros C; apply C. apply Rlt_trans with (3%nat * (radix * (Rabs p' * / pPred (vNum b))) + Rabs r')%R. apply Rle_lt_trans with (Rabs (q' + r') + Rabs r')%R. replace (Rabs q') with (Rabs (q' + r' + - r')). replace (Rabs r') with (Rabs (- r')). apply Rabs_triang. apply Rabs_Ropp. replace (q' + r' + - r')%R with (FtoRradix q'); [ auto | ring ]. replace (Rabs (q' + r') + Rabs r')%R with (Rabs r' + Rabs (q' + r'))%R; [ auto | ring ]. replace (3%nat * (radix * (Rabs p' * / pPred (vNum b))) + Rabs r')%R with (Rabs r' + 3%nat * (radix * (Rabs p' * / pPred (vNum b))))%R; [ auto | ring ]. apply Rplus_lt_compat_l. replace (3%nat * (radix * (Rabs p' * / pPred (vNum b))))%R with (3%nat * radix * / pPred (vNum b) * Rabs p')%R; [ auto | ring ]. apply bound3Sum; auto. apply Rplus_lt_compat_l. replace (FtoRradix r') with (w + v - q')%R; auto. replace (Rabs (FtoRradix w + FtoRradix v - FtoRradix q')) with (Rabs (q' - (w + v))). replace (Rabs q' * / pPred (vNum b))%R with (Rabs q' * / radix * (radix * / pPred (vNum b)))%R. apply plusErrorBound1 with (b := b) (radix := radix) (precision := precision) (r := q') (p := w) (q := v); auto. replace (Rabs (FtoRradix q') * / radix * (radix * / pPred (vNum b)))%R with (Rabs (FtoRradix q') * (/ radix * radix) * / pPred (vNum b))%R; [ rewrite Rinv_l; auto with real zarith | idtac ]; ring. replace (q' - (w + v))%R with (- (w + v - q'))%R; [ rewrite Rabs_Ropp | idtac ]; ring. intros H'0. replace (Rabs q' * / radix * (radix * / pPred (vNum b)))%R with (radix * / radix * (/ pPred (vNum b) * Rabs q'))%R; try ring. rewrite Rinv_r; auto with real zarith; try rewrite Rmult_1_l. replace (radix * pPred (vNum b) - radix)%R with (radix * (pPred (vNum b) - 1))%R; [ idtac | simpl in |- *; ring; ring ]. cut (1 < pPred (vNum b))%Z; [ intros Rlt1 | apply Zle_lt_trans with radix; try apply (pPredMoreThanRadix b radix precision); auto with zarith ]. cut ((pPred (vNum b) - 1)%R <> 0%R); [ intros Rlt2 | replace (pPred (vNum b) - 1)%R with (IZR (pPred (vNum b) - 1)); auto with real zarith; rewrite <- Z_R_minus; simpl in |- *; auto ]. repeat rewrite Rinv_mult_distr; auto with real zarith. replace (3%nat * (radix * (radix * (Rabs p' * (/ pPred (vNum b) * (/ radix * / (pPred (vNum b) - 1)))))))%R with (radix * / radix * (/ pPred (vNum b) * (3%nat * (radix * (Rabs p' * / (pPred (vNum b) - 1))))))%R; [ idtac | ring ]. rewrite Rinv_r; auto with real zarith; rewrite Rmult_1_l. apply Rmult_lt_compat_l; auto with real. apply Rinv_0_lt_compat; auto with real. apply Rlt_IZRO. apply (pPredMoreThanOne b radix precision); auto with arith. apply Rmult_lt_reg_l with (r := (pPred (vNum b) - 1)%R); auto with real. replace ((pPred (vNum b) - 1) * (3%nat * (radix * (Rabs (FtoRradix p') * / (pPred (vNum b) - 1)))))%R with (3%nat * (radix * (Rabs (FtoRradix p') * ((pPred (vNum b) - 1) * / (pPred (vNum b) - 1)))))%R; [ rewrite Rinv_r; auto with real zarith; try rewrite Rmult_1_r | ring; ring ]. apply Rplus_lt_reg_r with (Rabs (FtoRradix q')); repeat rewrite (Rplus_comm (Rabs (FtoRradix q'))). replace ((pPred (vNum b) - 1) * Rabs (FtoRradix q') + Rabs (FtoRradix q'))%R with (pPred (vNum b) * Rabs (FtoRradix q'))%R; [ idtac | ring ]. apply Rmult_lt_reg_l with (r := (/ pPred (vNum b))%R); auto with real zarith. rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real zarith; rewrite Rmult_1_l. rewrite (fun x => Rmult_comm (/ x)); rewrite Rmult_plus_distr_r; repeat rewrite <- Rmult_assoc; repeat rewrite <- Rmult_assoc in H'0; auto. Qed. Theorem TwoSumNonNul : forall p q r pq : float, Fbounded b p -> Fbounded b q -> Closest b radix (p + q) pq -> r = (p + q - pq)%R :>R -> r <> 0%R :>R -> pq <> 0%R :>R. intros. Contradict H3. rewrite H2. apply TwoSumNul; auto with real. Qed. Theorem TwoSumOneNul : forall p q pq : float, Fbounded b p -> Fbounded b q -> Fbounded b pq -> Closest b radix (p + q) pq -> p = 0%R :>R -> pq = q :>R. intros. generalize H2. rewrite H3. replace (0 + q0)%R with (FtoRradix q0); [ idtac | ring ]. intro. apply sym_eq; apply (RoundedModeProjectorIdemEq b radix precision) with (P := Closest b radix); auto with real float arith zarith. apply (ClosestRoundedModeP b radix precision); auto with real float arith zarith. Qed. Theorem TwoSumOneNul2 : forall p q pq r : float, Fbounded b p -> Fbounded b q -> Fbounded b pq -> Closest b radix (p + q) pq -> p = 0%R :>R -> r = (p + q - pq)%R :>R -> r = 0%R :>R. intros. rewrite H4; rewrite H3. apply Rminus_diag_eq; ring_simplify. apply sym_eq; apply TwoSumOneNul with (p := p0); auto. Qed. End F2.Float8.4/Expansions/ThreeSumProps.v0000644000423700002640000007507012032774526017160 0ustar sboldotoccata(**************************************************************************** IEEE754 : ThreeSumProps Laurent Thery & Sylvie Boldo ******************************************************************************) Require Export ThreeSum2. Section F2. Variable b : Fbound. Variable precision : nat. Let radix := 2%Z. Let TMTO : (1 < radix)%Z := TwoMoreThanOne. Hint Resolve TMTO: zarith. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Hypothesis precisionNotZero : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Variables (p : float) (q : float) (r : float) (u : float) ( v : float) (w : float) (p' : float) (q' : float) ( r' : float). Hypothesis Fp : Fbounded b p. Hypothesis Fq : Fbounded b q. Hypothesis Fr : Fbounded b r. Hypothesis Fu : Fbounded b u. Hypothesis Fv : Fbounded b v. Hypothesis Fw : Fbounded b w. Hypothesis Fp' : Fbounded b p'. Hypothesis Fq' : Fbounded b q'. Hypothesis Fr' : Fbounded b r'. Hypothesis epq : (Fexp q <= Fexp p)%Z. Hypothesis eqr : (Fexp r <= Fexp q)%Z. Hypothesis uDef : Closest b radix (q + r) u. Hypothesis vDef : v = (q + r - u)%R :>R. Hypothesis p'Def : Closest b radix (p + u) p'. Hypothesis wDef : w = (p + u - p')%R :>R. Hypothesis q'Def : Closest b radix (w + v) q'. Hypothesis r'Def : r' = (w + v - q')%R :>R. Hypothesis Ngd : (1 <= pPred (vNum b) * (1 - / radix))%R. Hypothesis Hplus : (p = 0%R :>R \/ q = 0%R :>R \/ r = 0%R :>R) \/ (Rabs q <= pPred (vNum b) * (Float 1%nat (Fexp p) - Float 1%nat (Fexp r)))%R. Hypothesis Ngd2 : (6%nat <= pPred (vNum b) * (1 - / radix * / radix))%R. Theorem FTS : (Rabs q <= pPred (vNum b) * (Float 1%nat (Fexp p) - Float 1%nat (Fexp r)))%R -> exists u'' : float, FtoRradix u'' = u /\ Fbounded b u'' /\ (Fexp u'' <= Fexp p)%Z. intros H. case (Req_dec u 0); intros Hu. exists (Fzero (Fexp p)). split. replace (FtoRradix u) with 0%R; auto with real; unfold FtoRradix in |- *; apply FzeroisReallyZero. split; auto with zarith. apply FboundedZeroSameExp; auto. exists (Fnormalize radix b precision u). cut (FtoRradix (Fnormalize radix b precision u) = u); intros. split; auto with float. 2: unfold FtoRradix in |- *; apply FnormalizeCorrect; auto with arith. split. apply FcanonicBound with (radix := radix). apply FnormalizeCanonic; auto with arith. cut (Fcanonic radix b (Fnormalize radix b precision u)). 2: apply FnormalizeCanonic; auto with arith. intros H1; case H1. intros H2. rewrite (Zsucc_pred (Fexp (Fnormalize radix b precision u))). apply Zlt_le_succ. apply Zlt_powerRZ with (e := IZR radix); auto with real arith zarith. apply Rmult_lt_reg_l with (r := IZR (pPred (vNum b))); auto with real zarith. apply Rlt_IZRO; apply (pPredMoreThanOne b radix precision); auto with real zarith. apply Rlt_le_trans with (Zabs (Fnum (Fnormalize radix b precision u)) * powerRZ radix (Fexp (Fnormalize radix b precision u)))%R. unfold Zpred in |- *; rewrite powerRZ_add; auto with real arith zarith. replace (pPred (vNum b) * (powerRZ radix (Fexp (Fnormalize radix b precision u)) * powerRZ radix (-1)))%R with (pPred (vNum b) * powerRZ radix (-1) * powerRZ radix (Fexp (Fnormalize radix b precision u)))%R; [ idtac | ring ]. apply Rmult_lt_compat_r; auto with real zarith. apply Rmult_lt_reg_l with (IZR radix); auto with real zarith. replace (radix * (pPred (vNum b) * powerRZ radix (-1)))%R with (radix * / radix * pPred (vNum b))%R; [ rewrite Rinv_r; auto with real zarith; rewrite Rmult_1_l | idtac ]. rewrite <- Rmult_IZR; apply Rlt_IZR. rewrite <- (Zabs_eq radix); auto with zarith; rewrite <- Zabs_Zmult. unfold pPred in |- *; apply Zle_Zpred_Zlt; case H2; auto with float. replace (powerRZ radix (-1)) with (/ radix)%R; [ ring | simpl in |- *; rewrite Rmult_1_r; auto ]. change (FtoRradix (Fabs (Fnormalize radix b precision u)) <= Float (pPred (vNum b)) (Fexp p))%R in |- *. rewrite (Fabs_correct radix); auto with zarith; fold FtoRradix in |- *; rewrite H0; auto with zarith. apply (RoundAbsMonotoner b radix precision) with (P := Closest b radix) (p := (FtoRradix q + FtoRradix r)%R); auto. apply (ClosestRoundedModeP b radix precision); auto with real zarith. unfold pPred in |- *; apply maxFbounded; auto with float. apply Rle_trans with (Rabs q + Rabs r)%R; auto with real. apply Rabs_triang; auto with real. apply Rle_trans with (Rabs q + pPred (vNum b) * FtoRradix (Float 1%nat (Fexp r)))%R; auto with real. apply Rplus_le_compat_l. replace (pPred (vNum b) * FtoRradix (Float 1%nat (Fexp r)))%R with (FtoRradix (Float (pPred (vNum b)) (Fexp r))); [ idtac | unfold FtoRradix, FtoR in |- *; simpl in |- *; ring ]. rewrite <- (Fabs_correct radix); auto with real zarith; apply (maxMax1 radix); auto with real zarith. fold FtoRradix in |- *; replace (FtoRradix (Float (pPred (vNum b)) (Fexp p))) with (pPred (vNum b) * FtoRradix (Float 1%nat (Fexp p)))%R; [ idtac | unfold FtoRradix, FtoR in |- *; simpl in |- *; ring ]. replace (pPred (vNum b) * FtoRradix (Float 1%nat (Fexp p)))%R with (pPred (vNum b) * (FtoRradix (Float 1%nat (Fexp p)) - FtoRradix (Float 1%nat (Fexp r))) + pPred (vNum b) * FtoRradix (Float 1%nat (Fexp r)))%R; [ auto with real zarith | unfold FtoRradix, FtoR in |- *; simpl in |- *; ring ]. intros H'; case H'; (intros H2 (H3, H4); rewrite H3). case Fp; auto. Qed. Theorem FTSinSum3_allcases : p <> 0%R :>R -> exists u'' : float, u'' = u :>R /\ Fbounded b u'' /\ (Fexp u'' <= Fexp p)%Z. intros H. case Hplus; [ intros [H1| [H2| H3]] | intros H1 ]. case H; auto. exists r; split; [ idtac | split ]; auto. apply (ClosestIdem b radix); auto. apply (ClosestCompatible b radix) with (1 := uDef); auto. rewrite H2; fold FtoRradix; ring. apply Zle_trans with (1 := eqr); auto. exists q; split; [ idtac | split ]; auto. apply (ClosestIdem b radix); auto. apply (ClosestCompatible b radix) with (1 := uDef); auto. rewrite H3; fold FtoRradix; ring. apply FTS; auto. Qed. Theorem PuissLessThanHalf : forall z : Z, (Float 1%nat z * / radix <= Float 1%nat z)%R. intros z. pattern (FtoRradix (Float 1%nat z)) at 2 in |- *; replace (FtoRradix (Float 1%nat z)) with (Float 1%nat z * 1)%R; [ apply Rmult_le_compat_l | ring ]. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *; auto with real zarith. replace (1 * powerRZ 2 z)%R with (powerRZ 2 z); [ apply powerRZ_le; auto with real | ring ]. apply Rlt_le. replace 1%R with (/ 1)%R; [ apply Rinv_1_lt_contravar | idtac ]; auto with real. Qed. Theorem Rle_Rminus_ZERO : forall r1 r2 : R, (r2 <= r1)%R -> (0 <= r1 - r2)%R. intros r1 r2 H; case H; auto with real. intros H1; rewrite H1; auto with real. rewrite Rminus_diag_eq; auto with real. Qed. Theorem ThreeSumLoop : exists p'' : float, (exists q'' : float, (exists r'' : float, (Fbounded b p'' /\ Fbounded b q'' /\ Fbounded b r'') /\ ((p'' = p' :>R /\ q'' = q' :>R /\ r'' = r' :>R) /\ (Fexp r <= Fexp r'')%Z /\ ((Fexp r'' <= Fexp q'')%Z /\ (Fexp q'' <= Fexp p'')%Z) /\ Fexp r'' = Fexp r) /\ (r' = 0%R :>R /\ (p'' = 0%R :>R \/ (Rabs q'' <= pPred (vNum b) * (Float 1%nat (Fexp p'') - Float 1%nat (Fexp r)))%R) \/ r' <> 0%R :>R /\ (Rabs r'' <= pPred (vNum b) * (Float 1%nat (Fexp q'') - Float 1%nat (Fexp r)))%R))). cut (0 < pPred (vNum b))%Z; [ intros Pp1 | apply (pPredMoreThanOne b radix) with (precision := precision); auto with zarith ]. case (plusExactExp b radix precision) with (p := q) (q := r) (pq := u); auto with zarith. intros v' (u', (H1, (H2, (H3, (H4, (H5, (H6, H7))))))). cut (Fbounded b (Fzero (Fexp r))); [ intros Fbr | apply FboundedZeroSameExp; auto ]. case (Req_dec p 0); intros Hp. cut (w = 0%R :>R); [ intros v'Def | idtac ]. exists u'; exists v'; exists (Fzero (Fexp r)); repeat (split; auto). apply sym_eq; apply TwoSumOneNul with (precision := precision) (p := p) (b := b); auto. fold radix in |- *; rewrite H3; auto. apply sym_eq; apply TwoSumOneNul with (precision := precision) (p := w) (b := b); auto. fold radix in |- *; replace (FtoR radix v') with (FtoR radix v); auto with real. fold radix in |- *; rewrite H4; auto with real. fold radix in |- *; rewrite H3; auto with real. replace (FtoRradix (Fzero (Fexp r))) with 0%R; apply sym_eq; [ idtac | unfold FtoRradix in |- *; apply FzeroisReallyZero ]. apply TwoSumOneNul2 with (b := b) (precision := precision) (p := w) (q := v) (pq := q'); auto. simpl in |- *; auto with zarith. simpl in |- *; auto with zarith. rewrite H5; auto with zarith. apply Zmin_Zle; auto with zarith. left; split; auto with float zarith. apply TwoSumOneNul2 with (b := b) (precision := precision) (p := w) (q := v) (pq := q'); auto. case (Req_dec u' 0); intros Hu'; auto. right. case (Req_dec v' 0); intros Hv'; auto. rewrite Hv'. replace (Rabs 0) with (pPred (vNum b) * 0)%R; [ apply Rmult_le_compat_l | rewrite Rabs_R0; ring ]; auto with real zarith. apply Rle_Rminus_ZERO; auto with float real. apply (oneExp_le radix); auto with float real. apply Zle_trans with (2 := H6); rewrite H5. apply Zmin_Zle; auto with zarith. apply Rle_trans with (FtoR radix (Float 1%nat (Fexp u')) * / radix)%R; [ unfold FtoRradix in |- *; apply ClosestErrorBound with (b := b) (x := (q + r)%R) (q := v') (precision := precision) | apply Rle_trans with (FtoR radix (Float 1%nat (Fexp u'))) ]; auto with real arith. apply (ClosestCompatible b radix (q + r)%R (q + r)%R u); auto. apply PuissLessThanHalf. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *. apply Rle_trans with (pPred (vNum b) * (1 - / 2) * powerRZ 2 (Fexp u'))%R. apply Rmult_le_compat_r; auto with real. replace (pPred (vNum b) * (1 - / 2) * powerRZ 2 (Fexp u'))%R with (pPred (vNum b) * (powerRZ 2 (Fexp u') - powerRZ 2 (Zpred (Fexp u'))))%R. apply Rmult_le_compat_l; auto with real zarith. simpl in |- *; repeat rewrite Rmult_1_l. unfold Rminus in |- *; apply Rplus_le_compat_l. apply Ropp_le_contravar; apply Rle_powerRZ; auto with real zarith. apply Zle_Zpred. replace (Fexp r) with (Fexp v'); auto. apply ClosestErrorExpStrict with (x := (q + r)%R) (b := b) (radix := radix) (precision := precision); auto. apply (ClosestCompatible b radix (q + r)%R (q + r)%R u); auto. rewrite H5; apply Zmin_le2; auto. unfold Zpred in |- *; rewrite (powerRZ_add 2 (Fexp u') (-1)); auto. replace (powerRZ 2 (-1)) with (/ radix)%R. unfold radix; simpl; ring. unfold powerRZ in |- *; simpl in |- *. replace (2 * 1)%R with 2%R; auto with real. replace 2%R with (IZR radix); auto with real zarith. apply TwoSumOneNul2 with (b := b) (precision := precision) (p := p) (q := u) (pq := p'); auto. case (Req_dec v 0); intros Hv. case (plusExactExp b radix precision) with (p := p) (q := u') (pq := p'); auto with zarith. rewrite H3; auto. intros w' (p'', (H'1, (H'2, (H'3, (H'4, (H'5, (H'6, H'7))))))). cut (w' = w :>R); [ intros w'Def | unfold FtoRradix in |- *; replace (FtoR radix w) with (p + u - p')%R; unfold FtoRradix in |- *; replace (FtoR radix u) with (FtoR radix u'); replace (FtoR radix p') with (FtoR radix p''); auto with real ]. exists p''; exists w'; exists (Fzero (Fexp r)); repeat (split; auto). apply sym_eq; apply TwoSumOneNul with (precision := precision) (p := v) (b := b); auto. fold radix FtoRradix in |- *; rewrite w'Def; auto. rewrite Rplus_comm; auto. replace (FtoRradix (Fzero (Fexp r))) with 0%R; apply sym_eq; [ idtac | unfold FtoRradix in |- *; apply FzeroisReallyZero ]. apply TwoSumOneNul2 with (b := b) (precision := precision) (p := v) (q := w) (pq := q'); auto. rewrite Rplus_comm; auto. rewrite Rplus_comm; fold radix FtoRradix in |- *; rewrite r'Def; ring. simpl in |- *; auto with zarith. simpl in |- *; rewrite H'5; apply Zmin_Zle; auto with zarith. apply Zle_trans with (Fexp v'); auto with zarith. simpl in |- *; rewrite H5; apply Zmin_Zle; auto with zarith. left. split; auto with float zarith. apply TwoSumOneNul2 with (b := b) (precision := precision) (p := v) (q := w) (pq := q'); auto. rewrite Rplus_comm; auto. rewrite Rplus_comm; fold radix FtoRradix in |- *; rewrite r'Def; ring. case (Req_dec p'' 0); intros Hp''; auto. right. case (Req_dec w' 0); intros Hw'; auto. rewrite Hw'. replace (Rabs 0) with (pPred (vNum b) * 0)%R; [ apply Rmult_le_compat_l | rewrite Rabs_R0; ring ]; auto with real zarith. apply Rle_Rminus_ZERO; auto with float real. apply (oneExp_le radix); auto with float real. apply Zle_trans with (Fexp w'); auto with zarith. rewrite H'5; apply Zmin_Zle; auto. apply Zle_trans with (Fexp q); auto. apply Zle_trans with (Fexp v'); auto with zarith. rewrite H5; apply Zmin_Zle; auto with zarith. apply Rle_trans with (FtoR radix (Float 1%nat (Fexp p'')) * / radix)%R; [ unfold FtoRradix in |- *; apply ClosestErrorBound with (b := b) (x := (p + u')%R) (precision := precision) | apply Rle_trans with (FtoR radix (Float 1%nat (Fexp p''))) ]; auto with real arith. apply (ClosestCompatible b radix (p + u')%R (p + u')%R p'); auto. unfold FtoRradix in |- *; rewrite H3; auto. apply PuissLessThanHalf. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *. apply Rle_trans with (pPred (vNum b) * (1 - / radix) * powerRZ 2 (Fexp p''))%R. apply Rmult_le_compat_r; auto with real zarith. replace (pPred (vNum b) * (1 - / radix) * powerRZ 2 (Fexp p''))%R with (pPred (vNum b) * (powerRZ 2 (Fexp p'') - powerRZ 2 (Zpred (Fexp p''))))%R. apply Rmult_le_compat_l; auto with real zarith. simpl in |- *; repeat rewrite Rmult_1_l. unfold Rminus in |- *; apply Rplus_le_compat_l. apply Ropp_le_contravar; apply Rle_powerRZ; auto with real zarith. apply Zle_Zpred. apply Zle_lt_trans with (Fexp w'); auto. rewrite H'5; apply Zmin_Zle; auto. apply Zle_trans with (Fexp q); auto. apply Zle_trans with (Fexp v'); auto with zarith. rewrite H5; apply Zmin_Zle; auto with zarith. apply ClosestErrorExpStrict with (x := (p + u')%R) (b := b) (radix := radix) (precision := precision); auto. apply (ClosestCompatible b radix (p + u')%R (p + u')%R p'); auto. unfold FtoRradix in |- *; rewrite H3; auto. unfold Zpred in |- *; rewrite (powerRZ_add 2 (Fexp p'') (-1)); auto. replace (powerRZ 2 (-1)) with (/ radix)%R. ring; ring. unfold powerRZ in |- *; simpl in |- *. replace (2 * 1)%R with 2%R; auto with real. replace 2%R with (IZR radix); auto with real zarith. case (FTSinSum3_allcases Hp); intros u'' (Z1, (Z2, Z3)). case (plusExactExp b radix precision) with (p := p) (q := u'') (pq := p'); auto with zarith. fold radix FtoRradix in |- *; rewrite Z1; auto. intros w' (p'', (H''1, (H''2, (H''3, (H''4, (H''5, (H''6, H''7))))))). cut (v = v' :>R); [ intros v'Def | rewrite vDef; auto with real; unfold FtoRradix in |- *; replace (FtoR radix u) with (FtoR radix u'); auto with real ]. cut (w' = w :>R); [ intros w'Def | unfold FtoRradix in |- *; replace (FtoR radix w) with (p + u - p')%R; unfold FtoRradix in |- *; replace (FtoR radix u) with (FtoR radix u''); replace (FtoR radix p') with (FtoR radix p''); auto with real ]. case (plusExactExp b radix precision) with (p := w') (q := v') (pq := q'); auto with zarith. fold radix FtoRradix in |- *; rewrite w'Def; rewrite <- v'Def; auto. intros r'' (q'', (H'''1, (H'''2, (H'''3, (H'''4, (H'''5, (H'''6, H'''7))))))). cut (r' = r'' :>R); [ intros r'Def1 | rewrite r'Def; unfold FtoRradix in |- *; replace (FtoR radix w) with (FtoR radix w'); replace (FtoR radix v) with (FtoR radix v'); replace (FtoR radix q') with (FtoR radix q''); auto with real ]. case (Req_dec w' 0); intros Hw'. exists p''; exists v'; exists (Fzero (Fexp r)); repeat (split; auto). apply sym_eq; apply TwoSumOneNul with (b := b) (precision := precision) (p := w); auto. fold radix FtoRradix in |- *; rewrite <- v'Def; auto. fold radix FtoRradix in |- *; rewrite <- w'Def; auto. replace (FtoRradix (Fzero (Fexp r))) with 0%R; [ apply sym_eq | apply sym_eq; unfold FtoRradix in |- *; apply FzeroisReallyZero ]. rewrite r'Def; fold radix FtoRradix in |- *; rewrite <- w'Def; rewrite Hw'. apply Rminus_diag_eq; auto; rewrite Rplus_0_l. apply sym_eq; apply TwoSumOneNul with (b := b) (precision := precision) (p := w); auto. fold radix FtoRradix in |- *; rewrite <- w'Def; auto. simpl in |- *; auto with real. simpl in |- *; auto with zarith. simpl in |- *; rewrite H5; apply Zmin_Zle; auto with zarith. apply Zle_trans with (Fexp u''); auto with zarith. apply Zlt_le_weak. apply ClosestErrorExpStrict with (b := b) (radix := radix) (precision := precision) (x := (q + r)%R); auto. apply (ClosestCompatible b radix (q + r)%R (q + r)%R u); auto. replace (FtoR radix u'') with (FtoR radix u'); auto with real. replace (FtoR radix u'') with (FtoR radix u); auto with real. replace (FtoR radix v') with (FtoR radix v); auto with real. apply Zle_trans with (Fexp w'); [ rewrite H''5 | auto with zarith ]. apply Zmin_Zle; auto with zarith. left. split; auto. rewrite r'Def; unfold FtoRradix in |- *; replace (FtoR radix w) with (FtoR radix w'); replace (FtoR radix w') with 0%R; auto. rewrite Rplus_0_l; apply Rminus_diag_eq. apply sym_eq; apply TwoSumOneNul with (b := b) (precision := precision) (p := w); auto. fold radix FtoRradix in |- *; rewrite <- w'Def; auto. right. apply Rle_trans with (Float 1%nat (Fexp u'') * / radix)%R. unfold FtoRradix in |- *; apply ClosestErrorBound with (b := b) (precision := precision) (x := (q + r)%R); auto with real. apply (ClosestCompatible b radix (q + r)%R (q + r)%R u); auto. replace (FtoR radix u'') with (FtoR radix u); replace (FtoR radix v') with (FtoR radix v); auto with real. apply Rle_trans with (FtoRradix (Float 1%nat (Fexp u''))); auto with real. apply PuissLessThanHalf. apply Rle_trans with (FtoRradix (Float 1%nat (Fexp p''))); auto with real. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *. repeat rewrite Rmult_1_l; apply Rle_powerRZ; auto with real. apply Zle_trans with (Fexp w'); auto. rewrite H''5. apply Zmin_Zle; auto with zarith. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *. apply Rle_trans with (pPred (vNum b) * (1 - / radix) * powerRZ 2 (Fexp p''))%R. apply Rmult_le_compat_r; auto with real. replace (pPred (vNum b) * (1 - / radix) * powerRZ 2 (Fexp p''))%R with (pPred (vNum b) * (powerRZ 2 (Fexp p'') - powerRZ 2 (Zpred (Fexp p''))))%R. apply Rmult_le_compat_l; auto with real zarith. replace (powerRZ 2 (Fexp p'') - powerRZ 2 (Zpred (Fexp p'')))%R with (powerRZ 2 (Fexp p'') + - powerRZ 2 (Zpred (Fexp p'')))%R; [ idtac | ring ]. repeat rewrite Rmult_1_l; auto with real. unfold Rminus in |- *; apply Rplus_le_compat_l. apply Ropp_le_contravar; apply Rle_powerRZ; auto with real. apply Zle_Zpred. apply Zlt_le_trans with (Fexp w'); auto. replace (Fexp r) with (Zmin (Fexp q) (Fexp r)); [ rewrite <- H5 | rewrite Zmin_le2; auto ]. rewrite H''5; rewrite Zmin_le2; auto. apply ClosestErrorExpStrict with (b := b) (radix := radix) (precision := precision) (x := (q + r)%R); auto. apply (ClosestCompatible b radix (q + r)%R (q + r)%R u); auto. fold radix FtoRradix in |- *; rewrite Z1; unfold FtoRradix in |- *; rewrite <- H3; auto. fold radix FtoRradix in |- *; rewrite <- v'Def; auto. unfold Zpred in |- *. rewrite (powerRZ_add 2 (Fexp p'') (-1)); auto. replace (powerRZ 2 (-1)) with (/ radix)%R. ring; ring. unfold powerRZ in |- *; simpl in |- *. rewrite Rmult_1_r; auto with real. replace 2%R with (IZR radix); auto with real zarith. exists p''; exists q''; exists r''; repeat (split; simpl in |- *; auto). apply Zle_trans with (Fexp v'); auto with zarith. replace (Fexp r) with (Zmin (Fexp q) (Fexp r)); [ rewrite <- H5 | rewrite Zmin_le2 ]; auto with zarith. rewrite H'''5; rewrite Zmin_le2; auto with zarith. rewrite H''5; rewrite Zmin_le2; auto with zarith. apply Zlt_le_weak. apply ClosestErrorExpStrict with (b := b) (radix := radix) (precision := precision) (x := (q + r)%R); auto. apply (ClosestCompatible b radix (q + r)%R (q + r)%R u); auto. replace (FtoR radix u'') with (FtoR radix u'); auto with real. replace (FtoR radix u'') with (FtoR radix u); auto with real. replace (FtoR radix v') with (FtoR radix v); auto with real. apply Zle_trans with (1 := H'''7). apply Zlt_le_succ; replace (Zmax (Fexp w') (Fexp v')) with (Fexp w'). apply ClosestErrorExpStrict with (b := b) (radix := radix) (precision := precision) (x := (p + u'')%R); auto. apply (ClosestCompatible b radix (p + u)%R (p + u'')%R p'); auto. replace (FtoR radix u'') with (FtoR radix u); auto with real. apply sym_eq; apply Zmax_le1; auto. apply Zlt_le_weak. replace (Fexp w') with (Fexp u''). apply ClosestErrorExpStrict with (b := b) (radix := radix) (precision := precision) (x := (q + r)%R); auto. apply (ClosestCompatible b radix (q + r)%R (q + r)%R u); auto. replace (FtoR radix u'') with (FtoR radix u'); auto with real. replace (FtoR radix u'') with (FtoR radix u); auto with real. replace (FtoR radix v') with (FtoR radix v); auto with real. rewrite H''5; apply sym_eq; apply Zmin_le2; auto. replace (Fexp r) with (Fexp v'); auto. rewrite H'''5; apply Zmin_le2. replace (Fexp w') with (Fexp u''). apply Zlt_le_weak. apply ClosestErrorExpStrict with (b := b) (radix := radix) (precision := precision) (x := (q + r)%R); auto. apply (ClosestCompatible b radix (q + r)%R (q + r)%R u); auto. replace (FtoR radix u'') with (FtoR radix u'); auto with real. replace (FtoR radix u'') with (FtoR radix u); auto with real. replace (FtoR radix v') with (FtoR radix v); auto with real. rewrite H''5; apply sym_eq; apply Zmin_le2; auto. rewrite H5; apply Zmin_le2; auto. case (Req_dec r' 0); intros Hr'. left; split; auto. right. replace (FtoRradix q'') with (w' + v')%R. apply Rle_trans with (Rabs w' + Rabs v')%R; [ apply Rabs_triang | idtac ]. apply Rle_trans with (Rabs w' + Rabs (FtoR radix u) * / radix * (radix * / pPred (vNum b)))%R. apply Rplus_le_compat_l. rewrite <- v'Def; rewrite vDef. apply Rlt_le. replace (FtoRradix q + FtoRradix r - FtoRradix u)%R with (- (u - (q + r)))%R; [ rewrite Rabs_Ropp | ring ]. unfold FtoRradix in |- *; apply plusErrorBound1 with (precision := precision); auto. unfold is_Fzero in |- *. Contradict Hw'. apply TwoSumOneNul2 with (precision := precision) (p := u) (q := p) (pq := p') (b := b); auto. rewrite Rplus_comm; auto. unfold FtoR in |- *; simpl in |- *; rewrite Hw'; simpl; ring. fold radix FtoRradix in |- *; rewrite w'Def; (rewrite Rplus_comm; auto). replace (Rabs (FtoR radix u) * / radix * (radix * / pPred (vNum b)))%R with (Rabs (FtoR radix u) * / pPred (vNum b) * (/ radix * radix))%R; [ rewrite Rinv_l; auto with real zarith; try rewrite Rmult_1_r | ring ]. apply Rle_trans with (radix * / pPred (vNum b) * Rmax (Rabs (FtoR radix p)) (Rabs (FtoR radix u'')) + Rabs (FtoR radix u) * / pPred (vNum b))%R. replace (Rabs w' + Rabs (FtoR radix u) * / pPred (vNum b))%R with (Rabs (FtoR radix u) * / pPred (vNum b) + Rabs w')%R; [ idtac | ring ]. replace (radix * / pPred (vNum b) * Rmax (Rabs (FtoR radix p)) (Rabs (FtoR radix u'')) + Rabs (FtoR radix u) * / pPred (vNum b))%R with (Rabs (FtoR radix u) * / pPred (vNum b) + radix * / pPred (vNum b) * Rmax (Rabs (FtoR radix p)) (Rabs (FtoR radix u'')))%R; [ idtac | ring ]. apply Rplus_le_compat_l. replace (FtoRradix w') with (p + u'' - p'')%R; auto with real. apply Rlt_le. replace (FtoRradix p + FtoRradix u'' - FtoRradix p'')%R with (- (FtoRradix p'' - (FtoRradix p + FtoRradix u'')))%R; [ rewrite Rabs_Ropp | ring ]. apply plusErrorBound2 with (b := b) (precision := precision); auto. apply (ClosestCompatible b radix (p + u)%R (p + u'')%R p'); auto. replace (FtoR radix u'') with (FtoR radix u); auto with real. cut (p' <> 0%R :>R); [ intros T1; Contradict T1; unfold FtoRradix in |- *; rewrite <- H''3; apply is_Fzero_rep1; auto | idtac ]. apply TwoSumNonNul with (b := b) (precision := precision) (r := w') (p := p) (q := u''); auto. apply (ClosestCompatible b radix (p + u)%R (p + u'')%R p'); auto. replace (FtoR radix u'') with (FtoR radix u); auto with real. fold radix in |- *; rewrite <- H''3; auto. apply Rle_trans with (radix * / pPred (vNum b) * Rmax (Rabs (FtoR radix p)) (Rabs (FtoR radix u'')) + Rmax (Rabs (FtoR radix p)) (Rabs (FtoR radix u'')) * / pPred (vNum b))%R. apply Rplus_le_compat_l. apply Rmult_le_compat_r; auto with real zarith. replace (FtoR radix u) with (FtoR radix u''); auto with real. apply RmaxLess2. replace (radix * / pPred (vNum b) * Rmax (Rabs (FtoR radix p)) (Rabs (FtoR radix u'')) + Rmax (Rabs (FtoR radix p)) (Rabs (FtoR radix u'')) * / pPred (vNum b))%R with (3%nat * / pPred (vNum b) * Rmax (Rabs (FtoR radix p)) (Rabs (FtoR radix u'')))%R; [ idtac | simpl in |- *; ring ]. apply Rle_trans with (Rabs p'' * (6%nat * / pPred (vNum b)))%R. replace (3%nat * / pPred (vNum b) * Rmax (Rabs (FtoR radix p)) (Rabs (FtoR radix u'')))%R with (3%nat * Rmax (Rabs (FtoR radix p)) (Rabs (FtoR radix u'')) * / pPred (vNum b))%R; [ idtac | ring ]. replace (Rabs p'' * (6%nat * / pPred (vNum b)))%R with (Rabs p'' * 6%nat * / pPred (vNum b))%R; [ idtac | ring ]. apply Rmult_le_compat_r; auto with real zarith. replace (3%nat * Rmax (Rabs (FtoR radix p)) (Rabs (FtoR radix u'')))%R with (/ radix * Rmax (Rabs (FtoR radix p)) (Rabs (FtoR radix u'')) * 6%nat)%R. apply Rmult_le_compat_r; auto with real. apply plusClosestLowerBound with (b := b) (precision := precision); auto. apply (ClosestCompatible b radix (p + u)%R (p + u'')%R p'); auto. replace (FtoR radix u'') with (FtoR radix u); auto with real. Contradict Hw'. unfold FtoRradix in |- *; rewrite H''4; unfold radix, FtoRradix in |- *; rewrite Hw'; ring. replace (INR 3) with (/ radix * 6%nat)%R; [ ring | idtac ]. replace (INR 6) with (radix * 3%nat)%R; [ idtac | simpl in |- *; auto with real zarith ]. rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real zarith. simpl in |- *; ring. apply Rle_trans with (6%nat * powerRZ 2 (Fexp p''))%R. replace (Rabs p'' * (6%nat * / pPred (vNum b)))%R with (6%nat * (Rabs p'' * / pPred (vNum b)))%R; [ apply Rmult_le_compat_l | ring ]. replace 0%R with (INR 0); auto with real arith. replace (powerRZ 2 (Fexp p'')) with (Float (pPred (vNum b)) (Fexp p'') * / pPred (vNum b))%R; [ apply Rmult_le_compat_r; auto with real zarith | unfold FtoRradix, FtoR; simpl; field; auto with zarith real]. rewrite <- (Fabs_correct radix); auto with zarith; apply (maxMax1 radix); auto with zarith. apply Rle_trans with (pPred (vNum b) * (1 - / radix * / radix) * powerRZ 2 (Fexp p''))%R. apply Rmult_le_compat_r; auto with real zarith. replace (pPred (vNum b) * (1 - / radix * / radix) * powerRZ 2 (Fexp p''))%R with (pPred (vNum b) * (powerRZ 2 (Fexp p'') - powerRZ 2 (Zpred (Zpred (Fexp p'')))))%R; [ apply Rmult_le_compat_l; auto with real zarith | ring_simplify ]. replace (powerRZ 2 (Fexp p'') - powerRZ 2 (Zpred (Zpred (Fexp p''))))%R with (powerRZ 2 (Fexp p'') + - powerRZ 2 (Zpred (Zpred (Fexp p''))))%R; [ idtac | ring ]. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *. repeat rewrite Rmult_1_l. unfold Rminus in |- *; apply Rplus_le_compat_l; auto with real zarith. apply Ropp_le_contravar; apply Rle_powerRZ; auto with real zarith. apply Zle_Zpred. apply Zlt_le_trans with (Fexp u''). replace (Fexp r) with (Fexp v'); auto. apply ClosestErrorExpStrict with (b := b) (radix := radix) (precision := precision) (x := (q + r)%R); auto. apply (ClosestCompatible b radix (q + r)%R (q + r)%R u); auto. replace (FtoR radix u'') with (FtoR radix u'); auto with real. replace (FtoR radix u'') with (FtoR radix u); auto with real. replace (FtoR radix v') with (FtoR radix v); auto with real. rewrite H5; apply Zmin_le2; auto. apply Zle_Zpred. replace (Fexp u'') with (Fexp w'); auto. apply ClosestErrorExpStrict with (b := b) (radix := radix) (precision := precision) (x := (p + u'')%R); auto. apply (ClosestCompatible b radix (p + u'')%R (p + u'')%R p'); auto. replace (FtoRradix u'') with (FtoRradix u); auto with real. rewrite H''5; apply Zmin_le2; auto. replace (powerRZ 2 (Zpred (Zpred (Fexp p'')))) with (powerRZ 2 (Fexp p'') * (/ radix * / radix))%R; [ ring | idtac ]. unfold Zpred in |- *; repeat rewrite powerRZ_add; auto with real zarith. replace (/ radix)%R with (powerRZ 2 (-1)); [ ring | idtac ]. unfold powerRZ in |- *; simpl in |- *. ring_simplify (2*1)%R; auto. replace (w' + v')%R with (r'' + q'')%R. replace (FtoRradix r'') with 0%R; [ ring | idtac ]. replace (FtoRradix r'') with (FtoRradix r'); auto. replace (FtoRradix r'') with (FtoR radix w' + FtoR radix v' - FtoR radix q'')%R; auto with real. unfold FtoRradix in |- *; ring; ring. right; split; auto. unfold FtoRradix in |- *; apply Rle_trans with (FtoR radix (Float 1%nat (Fexp q'')) * / radix)%R. apply ClosestErrorBound with (b := b) (precision := precision) (x := (w' + v')%R); auto. apply (ClosestCompatible b radix (w' + v')%R (w' + v')%R q'); auto. replace (FtoRradix w') with (FtoRradix w); replace (FtoRradix v') with (FtoRradix v); auto with real. apply Rle_trans with (FtoR radix (Float 1%nat (Fexp q''))). apply PuissLessThanHalf. unfold FtoR in |- *; simpl in |- *. apply Rle_trans with (pPred (vNum b) * (1 - / radix) * powerRZ 2 (Fexp q''))%R. apply Rmult_le_compat_r; auto with real zarith. repeat rewrite Rmult_1_l; auto. replace (pPred (vNum b) * (1 - / radix) * powerRZ 2 (Fexp q''))%R with (pPred (vNum b) * ((1 - / radix) * powerRZ 2 (Fexp q'')))%R; [ apply Rmult_le_compat_l; auto with real zarith | ring; ring ]. replace ((1 - / radix) * powerRZ 2 (Fexp q''))%R with (powerRZ 2 (Fexp q'') - powerRZ 2 (Zpred (Fexp q'')))%R. unfold Rminus in |- *; apply Rplus_le_compat_l; auto with real zarith. apply Ropp_le_contravar; apply Rle_powerRZ; auto with real zarith. apply Zle_Zpred. replace (Fexp r) with (Fexp r''). apply ClosestErrorExpStrict with (b := b) (radix := radix) (precision := precision) (x := (w' + v')%R); auto. apply (ClosestCompatible b radix (w' + v')%R (w' + v')%R q'); auto. replace (FtoRradix w') with (FtoRradix w); replace (FtoRradix v') with (FtoRradix v); auto with real. replace (FtoR radix r'') with (FtoR radix r'); auto with real. replace (Fexp r) with (Fexp v'); auto. rewrite H'''5; apply Zmin_le2. replace (Fexp w') with (Fexp u''). apply Zlt_le_weak. apply ClosestErrorExpStrict with (b := b) (radix := radix) (precision := precision) (x := (q + r)%R); auto. apply (ClosestCompatible b radix (q + r)%R (q + r)%R u); auto. replace (FtoR radix u'') with (FtoR radix u'); auto with real. replace (FtoR radix u'') with (FtoR radix u); auto with real. replace (FtoR radix v') with (FtoR radix v); auto with real. rewrite H''5; apply sym_eq; apply Zmin_le2; auto. rewrite H5; apply Zmin_le2; auto. replace (powerRZ 2 (Zpred (Fexp q''))) with (/ radix * powerRZ 2 (Fexp q''))%R; auto with real. ring. unfold Zpred in |- *. rewrite (powerRZ_add 2 (Fexp q'') (-1)); auto with real. replace (powerRZ 2 (-1)) with (/ radix)%R; [ ring | unfold powerRZ in |- *; simpl in |- * ]. repeat rewrite Rmult_1_r; auto. Qed. End F2.Float8.4/Expansions/TwoSum.v0000644000423700002640000004532712032774526015640 0ustar sboldotoccata(**************************************************************************** IEEE754 : TwoSum Laurent Thery & Sylvie Boldo ******************************************************************************) Require Export Fast2Sum. Section EFast. Variable b : Fbound. Variable precision : nat. Let radix := 2%Z. Let TMTO : (1 < radix)%Z := TwoMoreThanOne. Hint Resolve TMTO: zarith. Coercion Local FtoRradix := FtoR radix. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Variable Iplus : float -> float -> float. Hypothesis IplusCorrect : forall p q : float, Fbounded b p -> Fbounded b q -> Closest b radix (p + q) (Iplus p q). Hypothesis IplusComp : forall p q r s : float, Fbounded b p -> Fbounded b q -> Fbounded b r -> Fbounded b s -> p = r :>R -> q = s :>R -> Iplus p q = Iplus r s :>R. Hypothesis IplusSym : forall p q : float, Iplus p q = Iplus q p. Hypothesis IplusOp : forall p q : float, Fopp (Iplus p q) = Iplus (Fopp p) (Fopp q). Variable Iminus : float -> float -> float. Hypothesis IminusPlus : forall p q : float, Iminus p q = Iplus p (Fopp q). Theorem IplusOl : forall p q : float, Fbounded b p -> Fbounded b q -> p = 0%R :>R -> Iplus p q = q :>R. intros p q H' H'0 H'1. rewrite IplusSym. apply (IplusOr b); auto. Qed. Let IminusCorrect := IminusCorrect b Iplus IplusCorrect Iminus IminusPlus. Let IplusBounded := IplusBounded b Iplus IplusCorrect. Let IminusBounded := IminusBounded b Iplus IplusCorrect Iminus IminusPlus. Let IminusId := IminusId b Iplus IplusCorrect Iminus IminusPlus. Theorem MKnuth : forall p q : float, Fbounded b p -> Fbounded b q -> Iminus (Iplus p q) p = (Iplus p q - p)%R :>R -> Iplus (Iminus p (Iminus (Iplus p q) (Iminus (Iplus p q) p))) (Iminus q (Iminus (Iplus p q) p)) = (p + q - Iplus p q)%R :>R. intros p q H' H'0 H'1. rewrite IplusOl; auto with float. case (errorBoundedPlus b radix precision) with (p := p) (q := q) (pq := Iplus p q); auto. intros x H'2; elim H'2; intros H'3 H'4; elim H'4; intros H'5 H'6; clear H'4 H'2. unfold FtoRradix in |- *; rewrite <- H'3. apply sym_eq; apply (ClosestIdem b); auto. apply (ClosestCompatible b radix (q - Iminus (Iplus p q) p)%R ( FtoR radix x) (Iminus q (Iminus (Iplus p q) p))); auto. rewrite H'3. rewrite H'1. unfold FtoRradix in |- *; ring; ring. replace 0%R with (FtoRradix (Iminus p p)). repeat rewrite IminusPlus; apply IplusComp; repeat rewrite <- IminusPlus; auto with float. unfold FtoRradix in |- *; repeat rewrite Fopp_correct. replace (FtoR radix (Iminus (Iplus p q) (Iminus (Iplus p q) p))) with (FtoR radix p); auto. apply (ClosestIdem b); auto. apply (ClosestCompatible b radix (Iplus p q - Iminus (Iplus p q) p)%R (FtoR radix p) (Iminus (Iplus p q) (Iminus (Iplus p q) p))); auto. rewrite H'1; auto. unfold FtoRradix in |- *; ring; ring. apply IminusId; auto. Qed. Theorem IplusCorrectEq : forall (p q pq : float) (r : R), Fbounded b p -> Fbounded b q -> Fbounded b pq -> r = pq :>R -> (p + q)%R = pq :>R -> Iplus p q = r :>R. intros p q pq r H' H'0 H'1 H'2 H'3; rewrite H'2. unfold FtoRradix in |- *; apply sym_eq; apply (ClosestIdem b radix); auto. apply (ClosestCompatible b radix (p + q)%R pq (Iplus p q)); auto. Qed. Theorem IminusCorrectEq : forall (p q pq : float) (r : R), Fbounded b p -> Fbounded b q -> Fbounded b pq -> r = pq :>R -> (p - q)%R = pq :>R -> Iminus p q = r :>R. intros p q pq r H' H'0 H'1 H'2 H'3; rewrite H'2. unfold FtoRradix in |- *; apply sym_eq; apply (ClosestIdem b radix); auto. apply (ClosestCompatible b radix (p - q)%R pq (Iminus p q)); auto. Qed. Theorem Iminus2Exact : forall p q : float, (0 <= p)%R -> (p <= q)%R -> Fbounded b p -> Fbounded b q -> Iminus q (Iminus q p) = (q - Iminus q p)%R :>R. intros p q H' H'0 H'1 H'2. case (minusRoundRep b radix precision) with (P := Closest b radix) (p := p) (q := q) (qmp := Iminus q p); auto. apply ClosestRoundedModeP with (precision := precision); auto. intros pq H'3; elim H'3; intros H'4 H'5; clear H'3. apply IminusCorrectEq with (pq := pq); auto. Qed. Theorem MKnuth1 : forall p q : float, Fbounded b p -> Fbounded b q -> Iminus q (Iminus (Iplus p q) p) = (q - Iminus (Iplus p q) p)%R :>R -> Iminus (Iplus p q) (Iminus (Iplus p q) p) = (Iplus p q - Iminus (Iplus p q) p)%R :>R -> Iplus (Iminus p (Iminus (Iplus p q) (Iminus (Iplus p q) p))) (Iminus q (Iminus (Iplus p q) p)) = (p + q - Iplus p q)%R :>R. intros p q H' H'0 H'1 H'2. cut (Iminus p (Iminus (Iplus p q) (Iminus (Iplus p q) p)) = (p - Iminus (Iplus p q) (Iminus (Iplus p q) p))%R :>R); [ intros H'3 | idtac ]. case (errorBoundedPlus b radix precision) with (p := p) (q := q) (pq := Iplus p q); auto. intros pq H'4; elim H'4; intros H'5 H'6; elim H'6; intros H'7 H'8; clear H'6 H'4. apply IplusCorrectEq with (pq := pq); auto. repeat rewrite H'3; repeat rewrite H'2; repeat rewrite H'1. unfold FtoRradix in |- *; rewrite H'5. ring. rewrite H'2. case (errorBoundedPlus b radix precision) with (p := Iplus p q) (q := Fopp p) (pq := Iminus (Iplus p q) p); auto with float. apply (ClosestCompatible b radix (Iplus p q - p)%R (Iplus p q + Fopp p)%R (Iminus (Iplus p q) p)); auto. rewrite (Fopp_correct radix); auto. intros pq H'3; elim H'3; intros H'4 H'5; elim H'5; intros H'6 H'7; clear H'5 H'3. rewrite (IminusPlus p); apply IplusCorrectEq with (pq := Fopp pq); auto with float. unfold FtoRradix in |- *; rewrite (Fopp_correct radix); auto; rewrite H'4; rewrite (Fopp_correct radix); auto; ring; ring. unfold FtoRradix in |- *; repeat rewrite (Fopp_correct radix); auto; rewrite H'4; rewrite (Fopp_correct radix); auto. unfold FtoRradix in H'2; rewrite H'2; ring. Qed. Theorem MKnuth2 : forall p q : float, (Rabs q <= Rabs p)%R -> Fbounded b p -> Fbounded b q -> Iplus (Iminus p (Iminus (Iplus p q) (Iminus (Iplus p q) p))) (Iminus q (Iminus (Iplus p q) p)) = (p + q - Iplus p q)%R :>R. intros p q H' H'0 H'1. apply MKnuth; auto. apply (MDekker b precision); auto. Qed. Theorem IminusOp : forall p q : float, Fopp (Iminus p q) = Iminus (Fopp p) (Fopp q). intros p q; repeat rewrite IminusPlus; repeat rewrite <- IplusOp; auto. Qed. Theorem MKnuthOpp : forall p q : float, Iplus (Iminus p (Iminus (Iplus p q) (Iminus (Iplus p q) p))) (Iminus q (Iminus (Iplus p q) p)) = Fopp (Iplus (Iminus (Fopp p) (Iminus (Iplus (Fopp p) (Fopp q)) (Iminus (Iplus (Fopp p) (Fopp q)) (Fopp p)))) (Iminus (Fopp q) (Iminus (Iplus (Fopp p) (Fopp q)) (Fopp p)))) :>R. intros p q; repeat rewrite <- IplusOp || rewrite <- IminusOp; rewrite Fopp_Fopp; auto. Qed. Theorem MKnuth3 : forall p q : float, (0 <= q)%R -> (q <= radix * - p)%R -> (- p <= q)%R -> Fbounded b p -> Fbounded b q -> Iplus (Iminus p (Iminus (Iplus p q) (Iminus (Iplus p q) p))) (Iminus q (Iminus (Iplus p q) p)) = (p + q - Iplus p q)%R :>R. intros p q H' H'0 H'1 H'2 H'3. apply MKnuth; auto. cut (FtoRradix (Iplus p q) = (p + q)%R :>R); [ intros Eq1 | idtac ]. apply IminusCorrectEq with (pq := q); auto. rewrite Eq1; ring. rewrite Eq1; ring. apply IplusCorrectEq with (pq := Fminus radix q (Fopp p)); auto. apply Sterbenz; auto with float. 2: repeat rewrite (Fopp_correct radix); auto. 2: rewrite (Fminus_correct radix); repeat rewrite (Fopp_correct radix); unfold FtoRradix in |- *; auto; ring; ring. 2: rewrite (Fminus_correct radix); repeat rewrite (Fopp_correct radix); unfold FtoRradix in |- *; auto; ring; ring. apply Rle_trans with (2 := H'1). apply Rmult_le_reg_l with (r := IZR radix); auto with real. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real arith; rewrite Rmult_1_l. rewrite (Fopp_correct radix). apply Rle_trans with (1 := H'1); auto. Qed. Theorem MKnuth4 : forall p q : float, (0 < - p)%R -> (0 < q)%R -> (radix * - p < q)%R -> Fbounded b p -> Fbounded b q -> Iplus (Iminus p (Iminus (Iplus p q) (Iminus (Iplus p q) p))) (Iminus q (Iminus (Iplus p q) p)) = (p + q - Iplus p q)%R :>R. intros p q H' H'0 H'1 H'2 H'3. cut (/ radix * q <= Iplus p q)%R; [ intros Rle1 | idtac ]. cut (Iplus p q <= Iminus (Iplus p q) p)%R; [ intros Rle2 | idtac ]. cut (Iminus (Iplus p q) p <= radix * Iplus p q)%R; [ intros Rle3 | idtac ]. cut (radix * Iplus p q <= radix * q)%R; [ intros Rle4 | idtac ]. apply MKnuth1; auto with float. apply IminusCorrectEq with (pq := Fminus radix q (Iminus (Iplus p q) p)); auto with float. rewrite <- (Fopp_Fopp (Fminus radix q (Iminus (Iplus p q) p))). apply oppBounded. rewrite Fopp_Fminus. apply Sterbenz; auto. apply Rle_trans with (1 := Rle1); auto. apply Rle_trans with (1 := Rle3); auto. apply sym_eq; apply (Fminus_correct radix); auto. apply sym_eq; apply (Fminus_correct radix); auto. apply IminusCorrectEq with (pq := Fminus radix (Iplus p q) (Iminus (Iplus p q) p)); auto. rewrite <- (Fopp_Fopp (Fminus radix (Iplus p q) (Iminus (Iplus p q) p))). apply oppBounded. rewrite Fopp_Fminus. apply Sterbenz; auto. apply Rle_trans with (2 := Rle2); auto. apply Rmult_le_reg_l with (r := IZR radix); auto with real. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real arith; rewrite Rmult_1_l. apply Rledouble. apply Rle_trans with (2 := Rle1). apply Rmult_le_reg_l with (r := IZR radix); auto with real. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real zarith; rewrite Rmult_1_l; rewrite Rmult_0_r; apply Rlt_le; auto. apply sym_eq; apply (Fminus_correct radix); auto. apply sym_eq; apply (Fminus_correct radix); auto. apply Rmult_le_reg_l with (r := (/ radix)%R); auto with real. repeat rewrite <- Rmult_assoc; repeat rewrite Rinv_l; auto with real zarith; repeat rewrite Rmult_1_l; auto with real. cut (MonotoneP radix (Closest b radix)); [ intros Cp | idtac ]. apply (Cp (p + q)%R q); auto. apply Rplus_lt_reg_r with (r := (- q)%R); auto. replace (- q + (p + q))%R with (- - p)%R; [ idtac | ring ]. replace (- q + q)%R with (-0)%R; [ auto with real | ring ]. apply (RoundedModeProjectorIdem b radix (Closest b radix)); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply ClosestMonotone; auto. apply (RoundedModeMult b radix) with (P := Closest b radix) (r := (Iplus p q - p)%R); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply Rplus_le_reg_l with (r := (- Iplus p q)%R); auto. replace (- Iplus p q + (Iplus p q - p))%R with (- p)%R; [ idtac | ring ]. replace (- FtoRradix (Iplus p q) + radix * FtoR radix (Iplus p q))%R with (FtoRradix (Iplus p q)); [ idtac | unfold FtoRradix in |- *; simpl in |- *; ring; ring ]. rewrite <- (Fopp_correct radix); auto. cut (MonotoneP radix (Closest b radix)); [ intros Cp | idtac ]. apply (Cp (Fopp p) (p + q)%R); auto. rewrite (Fopp_correct radix); auto. apply Rplus_lt_reg_r with (r := (- p)%R); auto. replace (- p + - FtoR radix p)%R with (radix * - p)%R; [ idtac | simpl in |- *; fold FtoRradix; ring ]. replace (- p + (p + q))%R with (FtoRradix q); [ auto | simpl in |- *; ring ]. apply (RoundedModeProjectorIdem b radix (Closest b radix)); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply oppBounded; auto. apply ClosestMonotone; auto. cut (MonotoneP radix (Closest b radix)); [ intros Cp | idtac ]. apply (Cp (Iplus p q) (Iplus p q - p)%R); auto. apply Rplus_lt_reg_r with (r := (- Iplus p q)%R); auto. replace (- Iplus p q + Iplus p q)%R with 0%R; [ auto | simpl in |- *; ring ]. replace (- Iplus p q + (Iplus p q - p))%R with (- p)%R; [ auto | simpl in |- *; ring ]. apply (RoundedModeProjectorIdem b radix (Closest b radix)); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply ClosestMonotone; auto. apply (FmultRadixInv b radix precision) with (y := (p + q)%R); auto. apply Rmult_lt_reg_l with (r := IZR radix); auto with real. repeat rewrite <- Rmult_assoc; repeat rewrite Rinv_r; auto with real arith; repeat rewrite Rmult_1_l; auto. apply Rplus_lt_reg_r with (r := (- q)%R); auto. apply Rplus_lt_reg_r with (r := (radix * - p)%R); auto. replace (radix * - p + (- q + FtoR radix q))%R with (radix * - p)%R; [ auto | unfold FtoRradix in |- *; simpl in |- *; ring ]. replace (radix * - p + (- q + radix * (p + q)))%R with (FtoRradix q); [ auto | simpl in |- *; ring ]. Qed. Theorem MKnuth5 : forall p q : float, (0 < p)%R -> (p < q)%R -> Fbounded b p -> Fbounded b q -> Iplus (Iminus p (Iminus (Iplus p q) (Iminus (Iplus p q) p))) (Iminus q (Iminus (Iplus p q) p)) = (p + q - Iplus p q)%R :>R. intros p q H' H'0 H'1 H'2. cut (Iminus (Iplus p q) (Iminus (Iplus p q) p) = (Iplus p q - Iminus (Iplus p q) p)%R :>R); [ intros Eq1 | idtac ]. apply MKnuth1; auto. cut (Iminus (Iplus p q) p <= Iplus p q)%R; [ intros Rle1 | idtac ]. cut (Iplus p q <= radix * q)%R; [ intros Rle2 | idtac ]. case (Rle_or_lt q (Iminus (Iplus p q) p)); intros Rle3. apply IminusCorrectEq with (pq := Fminus radix q (Iminus (Iplus p q) p)); auto with float. rewrite <- (Fopp_Fopp (Fminus radix q (Iminus (Iplus p q) p))). apply oppBounded. rewrite Fopp_Fminus. apply Sterbenz; auto. apply Rle_trans with (2 := Rle3); auto. apply Rmult_le_reg_l with (r := IZR radix); auto with real. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real arith; rewrite Rmult_1_l. apply Rledouble. apply Rlt_le; apply Rlt_trans with (1 := H'); auto. apply Rle_trans with (1 := Rle1); auto. apply sym_eq; apply (Fminus_correct radix); auto. apply sym_eq; apply (Fminus_correct radix); auto. case (ExactMinusInterval b radix precision) with (P := Closest b radix) (p := Iminus (Iplus p q) p) (q := Iplus p q) (r := q); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply (RleRoundedR0 b radix precision) with (P := Closest b radix) (r := (Iplus p q - p)%R); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply Rplus_le_reg_l with (r := FtoRradix p); auto. replace (p + 0)%R with (FtoRradix p); [ idtac | ring ]. replace (p + (Iplus p q - p))%R with (FtoRradix (Iplus p q)); [ idtac | ring ]. cut (MonotoneP radix (Closest b radix)); [ intros Cp | idtac ]. apply (Cp p (p + q)%R); auto. apply Rplus_lt_reg_r with (r := (- p)%R); auto. replace (- p + p)%R with 0%R; [ idtac | ring ]. replace (- p + (p + q))%R with (FtoRradix q); [ apply Rlt_trans with (1 := H'); auto | ring ]. apply (RoundedModeProjectorIdem b radix (Closest b radix)); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply ClosestMonotone; auto. exists (Iminus (Iplus p q) (Iminus (Iplus p q) p)); split; auto. apply Rlt_le; auto. cut (MonotoneP radix (Closest b radix)); [ intros Cp | idtac ]. apply (Cp q (p + q)%R); auto. apply Rplus_lt_reg_r with (r := (- q)%R); auto. replace (- q + q)%R with 0%R; [ idtac | ring ]. replace (- q + (p + q))%R with (FtoRradix p); [ auto | ring ]. apply (RoundedModeProjectorIdem b radix (Closest b radix)); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply ClosestMonotone; auto. intros x H'4; elim H'4; intros H'5 H'6; clear H'4. apply IminusCorrectEq with (pq := x); auto. apply (RoundedModeMult b radix) with (P := Closest b radix) (r := (p + q)%R); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply Rplus_le_reg_l with (r := (- q)%R); auto. replace (- q + (p + q))%R with (FtoRradix p); [ idtac | ring ]. replace (- FtoRradix q + radix * FtoR radix q)%R with (FtoRradix q); [ apply Rlt_le; auto | unfold FtoRradix in |- *; simpl in |- *; ring ]. cut (MonotoneP radix (Closest b radix)); [ intros Cp | idtac ]. apply (Cp (Iplus p q - p)%R (Iplus p q)); auto. apply Rplus_lt_reg_r with (r := (- Iplus p q)%R); auto. replace (- Iplus p q + (Iplus p q - p))%R with (- p)%R; [ idtac | ring ]. replace (- Iplus p q + Iplus p q)%R with (-0)%R; [ auto with real | ring ]. apply (RoundedModeProjectorIdem b radix (Closest b radix)); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply ClosestMonotone; auto. case (minusRoundRep b radix precision) with (P := Closest b radix) (p := p) (q := Iplus p q) (qmp := Iminus (Iplus p q) p); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply Rlt_le; auto. cut (MonotoneP radix (Closest b radix)); [ intros Cp | idtac ]. apply (Cp (FtoRradix p) (p + q)%R); auto. apply Rplus_lt_reg_r with (r := (- p)%R); auto. replace (- p + p)%R with 0%R; [ idtac | ring ]. replace (- p + (p + q))%R with (FtoRradix q); [ apply Rlt_trans with (1 := H'); auto | ring ]. apply (RoundedModeProjectorIdem b radix (Closest b radix)); auto. apply ClosestRoundedModeP with (precision := precision); auto. apply ClosestMonotone; auto. intros x H'4; elim H'4; intros H'5 H'6; clear H'4; auto with float. apply IminusCorrectEq with (pq := x); auto. Qed. Theorem MKnuth6 : forall p q : float, Iplus p q = (p + q)%R :>R -> Fbounded b p -> Fbounded b q -> Iplus (Iminus p (Iminus (Iplus p q) (Iminus (Iplus p q) p))) (Iminus q (Iminus (Iplus p q) p)) = (p + q - Iplus p q)%R :>R. intros p q H' H'0 H'1. apply MKnuth; auto. apply IminusCorrectEq with (pq := q); auto. rewrite H'; ring. rewrite H'; ring. Qed. Theorem MKnuth7 : forall p q : float, (Rabs p < q)%R -> Fbounded b p -> Fbounded b q -> Iplus (Iminus p (Iminus (Iplus p q) (Iminus (Iplus p q) p))) (Iminus q (Iminus (Iplus p q) p)) = (p + q - Iplus p q)%R :>R. intros p q H' H'0 H'1. cut (0 < q)%R; [ intros Rlt1 | apply Rle_lt_trans with (2 := H'); auto with real ]. case (Rle_or_lt 0 p); intros Rle1; [ Casec Rle1; intros Rle1 | idtac ]. apply MKnuth5; auto. rewrite <- (Rabs_right p); auto with real; apply Rle_ge; apply Rlt_le; auto. apply MKnuth6; auto. apply IplusCorrectEq with (pq := q); auto; rewrite <- Rle1; ring. case (Rle_or_lt q (radix * - p)); intros Rle2. apply MKnuth3; auto. apply Rlt_le; auto. rewrite <- (Faux.Rabsolu_left1 p); auto; apply Rlt_le; auto. apply MKnuth4; auto. replace 0%R with (-0)%R; [ auto with real | ring ]. Qed. Theorem Knuth : forall p q : float, Fbounded b p -> Fbounded b q -> Iplus (Iminus p (Iminus (Iplus p q) (Iminus (Iplus p q) p))) (Iminus q (Iminus (Iplus p q) p)) = (p + q - Iplus p q)%R :>R. intros p q H' H'0; case (Rle_or_lt (Rabs q) (Rabs p)); intros Rle1. apply MKnuth2; auto. case (Rle_or_lt 0 q); intros Rle2. apply MKnuth7; auto. rewrite <- (Rabs_right q); auto with real; apply Rle_ge; apply Rlt_le; auto. rewrite MKnuthOpp. rewrite (Fopp_correct radix). replace (p + q - Iplus p q)%R with (- (Fopp p + Fopp q - Iplus (Fopp p) (Fopp q)))%R. cut (forall x y : R, x = y -> (- x)%R = (- y)%R); [ intros tmp; apply tmp; clear tmp | intros x y tmp; rewrite tmp; auto ]. apply MKnuth7; auto with float. repeat rewrite (Fopp_correct radix); auto. rewrite <- (Faux.Rabsolu_left1 (FtoR radix q)); try apply Rlt_le; auto. rewrite Rabs_Ropp; auto. rewrite <- IplusOp; repeat rewrite (Fopp_correct radix); unfold FtoRradix in |- *; ring. Qed. End EFast.Float8.4/FnElem/0000755000423700002640000000000012032777406013217 5ustar sboldotoccataFloat8.4/FnElem/Axpy.v0000644000423700002640000027617312032774527014350 0ustar sboldotoccataRequire Export MinOrMax. Section AxpyMisc. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Variable b : Fbound. Variable precision : nat. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Theorem TwoMoreThanOne : (1 < radix)%Z. unfold radix in |- *; red in |- *; simpl in |- *; auto. Qed. Hint Resolve TwoMoreThanOne. Theorem TwoMoreThanOneR : (1 < radix)%R. replace 1%R with (IZR 1); auto with real. Qed. Hint Resolve TwoMoreThanOneR. Theorem FulpLeGeneral : forall p : float, Fbounded b p -> (Fulp b radix precision p <= Rabs (FtoRradix p) * powerRZ radix (Zsucc (- precision)) + powerRZ radix (- dExp b))%R. intros p Hp. cut (Fcanonic radix b (Fnormalize radix b precision p)); [ intros H | apply FnormalizeCanonic; auto with arith zarith ]. case H; intros H1. apply Rle_trans with (Rabs (FtoR radix p) * powerRZ radix (Zsucc (- precision)))%R. apply FulpLe2; auto with zarith. apply Rle_trans with (Rabs p * powerRZ radix (Zsucc (- precision)) + 0)%R; [ right; fold FtoRradix; ring | apply Rplus_le_compat_l; auto with real zarith ]. apply Rle_trans with (powerRZ radix (- dExp b)). right; unfold Fulp in |- *; simpl in |- *. replace (Fexp (Fnormalize radix b precision p)) with (- dExp b)%Z; [ auto with real zarith | elim H1; intuition ]. apply Rle_trans with (0 + powerRZ radix (- dExp b))%R; [ right; ring | apply Rplus_le_compat_r ]. apply Rmult_le_pos; auto with real zarith. Qed. Theorem RoundLeGeneral : forall (p : float) (z : R), Fbounded b p -> Closest b radix z p -> (Rabs p <= Rabs z * / (1 - powerRZ radix (- precision)) + powerRZ radix (Zpred (- dExp b)) * / (1 - powerRZ radix (- precision)))%R. intros p z Hp H. cut (0 < 1 - powerRZ radix (- precision))%R; [ intros H1 | idtac ]. 2: apply Rplus_lt_reg_r with (powerRZ radix (- precision)). 2: ring_simplify. 2: replace 1%R with (powerRZ radix 0); [ auto with real zarith | simpl in |- *; auto ]. apply Rmult_le_reg_l with (1 - powerRZ radix (- precision))%R; auto. ring_simplify ((1 - powerRZ radix (- precision)) * Rabs p)%R. apply Rle_trans with (Rabs z * ((1 - powerRZ radix (- precision)) * / (1 - powerRZ radix (- precision))) + powerRZ radix (Zpred (- dExp b)) * ((1 - powerRZ radix (- precision)) * / (1 - powerRZ radix (- precision))))%R; [ idtac | right; ring; ring ]. repeat rewrite Rinv_r; auto with real. ring_simplify. apply Rplus_le_reg_l with (- powerRZ radix (Zpred (- dExp b)))%R. ring_simplify. apply Rle_trans with (Rabs p + - (Rabs p * powerRZ radix (- precision) + powerRZ radix (Zpred (- dExp b))))%R; [ right; ring | idtac ]. apply Rle_trans with (Rabs p + - (/ radix * Fulp b radix precision p))%R. apply Rplus_le_compat_l; apply Ropp_le_contravar. apply Rmult_le_reg_l with (IZR radix); auto with real zarith. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real zarith. ring_simplify (1 * Fulp b radix precision p)%R. apply Rle_trans with (Rabs p * (powerRZ radix 1 * powerRZ radix (- precision)) + powerRZ radix 1 * powerRZ radix (Zpred (- dExp b)))%R; [ idtac | right; simpl in |- *; ring ]. repeat rewrite <- powerRZ_add; auto with zarith real. replace (1 + - precision)%Z with (Zsucc (- precision)); auto with zarith. replace (1 + Zpred (- dExp b))%Z with (- dExp b)%Z; auto with zarith. apply FulpLeGeneral; auto. unfold Zpred in |- *; auto with zarith. apply Rplus_le_reg_l with (- Rabs z + / radix * Fulp b radix precision p)%R. ring_simplify. apply Rle_trans with (Rabs (p - z)). apply Rle_trans with (Rabs p - Rabs z)%R; [ right; ring | apply Rabs_triang_inv ]. rewrite <- Rabs_Ropp. replace (- (p - z))%R with (z - p)%R; [ idtac | ring ]. apply Rmult_le_reg_l with (IZR radix); auto with real zarith. apply Rle_trans with (Fulp b radix precision p * (radix * / radix))%R; [ rewrite Rinv_r; auto with real zarith | right; ring ]. ring_simplify (Fulp b radix precision p * 1)%R. unfold FtoRradix in |- *; apply ClosestUlp; auto. Qed. Theorem RoundGeGeneral : forall (p : float) (z : R), Fbounded b p -> Closest b radix z p -> (Rabs z * / (1 + powerRZ radix (- precision)) - powerRZ radix (Zpred (- dExp b)) * / (1 + powerRZ radix (- precision)) <= Rabs p)%R. intros p z Hp H. cut (0 < 1 + powerRZ radix (- precision))%R; [ intros H1 | idtac ]. 2: apply Rlt_le_trans with 1%R; auto with real. 2: apply Rle_trans with (1 + 0)%R; auto with real zarith. apply Rmult_le_reg_l with (1 + powerRZ radix (- precision))%R; auto. apply Rle_trans with (Rabs z * ((1 + powerRZ radix (- precision)) * / (1 + powerRZ radix (- precision))) - powerRZ radix (Zpred (- dExp b)) * ((1 + powerRZ radix (- precision)) * / (1 + powerRZ radix (- precision))))%R; [ right; ring; ring | idtac ]. repeat rewrite Rinv_r; auto with real. ring_simplify. apply Rplus_le_reg_l with (powerRZ radix (Zpred (- dExp b))). ring_simplify (powerRZ radix (Zpred (- dExp b)) + (Rabs z - powerRZ radix (Zpred (- dExp b))))%R. apply Rle_trans with (Rabs p + (Rabs p * powerRZ radix (- precision) + powerRZ radix (Zpred (- dExp b))))%R; [ idtac | right; ring ]. apply Rle_trans with (Rabs p + / radix * Fulp b radix precision p)%R. apply Rplus_le_reg_l with (- Rabs p)%R. ring_simplify (- Rabs p + (Rabs p + / radix * Fulp b radix precision p))%R. apply Rle_trans with (Rabs (z - p)). apply Rle_trans with (Rabs z - Rabs p)%R; [ right; ring | apply Rabs_triang_inv ]. apply Rmult_le_reg_l with (IZR radix); auto with real zarith. apply Rle_trans with (Fulp b radix precision p * (radix * / radix))%R; [ rewrite Rinv_r; auto with real zarith | right; ring ]. ring_simplify (Fulp b radix precision p * 1)%R. unfold FtoRradix in |- *; apply ClosestUlp; auto. apply Rplus_le_compat_l. apply Rmult_le_reg_l with (IZR radix); auto with real zarith. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real zarith. ring_simplify (1 * Fulp b radix precision p)%R. apply Rle_trans with (Rabs p * (powerRZ radix 1 * powerRZ radix (- precision)) + powerRZ radix 1 * powerRZ radix (Zpred (- dExp b)))%R; [ idtac | right; simpl in |- *; ring ]. repeat rewrite <- powerRZ_add; auto with zarith real. replace (1 + - precision)%Z with (Zsucc (- precision)); auto with zarith. replace (1 + Zpred (- dExp b))%Z with (- dExp b)%Z; auto with zarith. apply FulpLeGeneral; auto. Qed. Theorem ExactSum_Near : forall p q f : float, Fbounded b p -> Fbounded b q -> Fbounded b f -> Closest b radix (p + q) f -> Fexp p = (- dExp b)%Z -> (Rabs (p + q - f) < powerRZ radix (- dExp b))%R -> (p + q)%R = f. intros p q f Hp Hq Hf H H12 H1. case errorBoundedPlus with (b := b) (radix := radix) (precision := precision) (p := p) (q := q) (pq := f); auto with zarith. intros x0 H'; elim H'; intros H2 H'1; elim H'1; intros H3 H4; clear H' H'1. apply Rplus_eq_reg_l with (- FtoRradix f)%R; ring_simplify (-f+f)%R. apply trans_eq with (FtoR radix p + FtoR radix q - FtoR radix f)%R; [ fold FtoRradix; ring | rewrite <- H2 ]. generalize H1; unfold FtoRradix in |- *; rewrite <- H2; intros H5. cut (forall r : R, Rabs r = 0%R -> r = 0%R); [ intros V; apply V | auto with real ]. rewrite <- Fabs_correct; auto with zarith. apply is_Fzero_rep1; unfold is_Fzero in |- *. cut (forall z : Z, (0 <= z)%Z -> (z < 1)%Z -> z = 0%Z); [ intros W; apply W | auto with zarith ]. unfold Fabs in |- *; simpl in |- *; apply Zle_ZERO_Zabs. replace 1%Z with (Fnum (Float 1 (- dExp b))); [ idtac | simpl in |- *; auto ]. apply Rlt_Fexp_eq_Zlt with (radix := radix); auto with zarith real float. rewrite Fabs_correct; auto with zarith; apply Rlt_le_trans with (1 := H5). right; unfold FtoR in |- *; simpl in |- *; ring. unfold Fabs in |- *; simpl in |- *. rewrite H4; rewrite H12; apply Zmin_le1; auto with zarith. elim Hq; auto with zarith. intros m; case (Rle_or_lt 0 m); intros H'. rewrite Rabs_right; auto with real. rewrite Faux.Rabsolu_left1; auto with real; intros H'1. rewrite <- (Ropp_involutive m); rewrite H'1; auto with real. Qed. End AxpyMisc. Section AxpyAux. Add Field RField : Rfield (completeness Zeq_bool_complete). Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Variable b : Fbound. Variable precision : nat. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Variables a1 x1 y1 : R. Variables a x y t u r : float. Hypothesis Fa : Fbounded b a. Hypothesis Fx : Fbounded b x. Hypothesis Fy : Fbounded b y. Hypothesis Ft : Fbounded b t. Hypothesis Fu : Fbounded b u. Hypothesis tDef : Closest b radix (a * x) t. Hypothesis uDef : Closest b radix (t + y) u. Hypothesis rDef : isMin b radix (a1 * x1 + y1) r. Theorem Axpy_aux1 : Fcanonic radix b u -> (Rabs (FtoRradix a * FtoRradix x - FtoRradix t) <= / 4%nat * Fulp b radix precision (FPred b radix precision u))%R -> (0 < u)%R -> (4%nat * Rabs t <= Rabs u)%R -> (Rabs (y1 - y) + Rabs (a1 * x1 - a * x) < / 4%nat * Fulp b radix precision (FPred b radix precision u))%R -> MinOrMax radix b (a1 * x1 + y1) u. intros H Hblop H1 H2 H3. cut (Rabs (a1 * x1 + y1 - u) < / 2%nat * Fulp b radix precision (FPred b radix precision u) + Rabs (t + y - u))%R; [ intros H4 | idtac ]. case (Rle_or_lt (t + y) u); intros H5. apply MinOrMax1 with precision; auto with zarith arith. apply Rlt_le_trans with (1 := H4). apply Rplus_le_reg_l with (- (/ 2%nat * Fulp b radix precision (FPred b radix precision u)))%R. ring_simplify (- (/ 2%nat * Fulp b radix precision (FPred b radix precision u)) + (/ 2%nat * Fulp b radix precision (FPred b radix precision u) + Rabs (FtoRradix t + FtoRradix y - FtoRradix u)))%R. apply Rle_trans with (/ 2%nat * Fulp b radix precision (FPred b radix precision u))%R; [ idtac | right ]. generalize uDef; unfold Closest in |- *; intros H6; elim H6; intros H7 H8; clear H6 H7. case (Rle_or_lt (Rabs (FtoRradix t + FtoRradix y - FtoRradix u)) (/ 2%nat * Fulp b radix precision (FPred b radix precision u))); auto; intros H6. cut (Rabs (FtoR radix u - (FtoRradix t + FtoRradix y)) <= Rabs (FtoR radix (FPred b radix precision u) - (FtoRradix t + FtoRradix y)))%R; [ intros H7 | apply H8 ]. 2: apply FBoundedPred; auto with zarith arith. Contradict H7; apply Rlt_not_le. apply Rlt_le_trans with (Rabs (FtoRradix t + FtoRradix y - FtoRradix u)). 2: right; rewrite <- Rabs_Ropp. 2: replace (- (FtoRradix t + FtoRradix y - FtoRradix u))%R with (FtoR radix u - (FtoRradix t + FtoRradix y))%R; auto with real; ring. apply Rle_lt_trans with (2 := H6). rewrite Faux.Rabsolu_left1. apply Rplus_le_reg_l with (u - (FtoRradix t + FtoRradix y) - / 2%nat * Fulp b radix precision (FPred b radix precision u))%R. ring_simplify. fold FtoRradix in |- *; pattern (FtoRradix u) at 1 in |- *; replace (FtoRradix u) with (FtoRradix (FPred b radix precision u) + Fulp b radix precision (FPred b radix precision u))%R; [ idtac | unfold FtoRradix in |- *; apply FpredUlpPos; auto with zarith arith ]. apply Rle_trans with (Fulp b radix precision (FPred b radix precision u) - Fulp b radix precision (FPred b radix precision u) * / 2%nat)%R; [ right; ring | idtac ]. apply Rle_trans with (/ 2%nat * Fulp b radix precision (FPred b radix precision u))%R. right; apply trans_eq with ((1 - / 2%nat) * Fulp b radix precision (FPred b radix precision u))%R; [ ring | auto with real arith ]. replace (1 - / 2%nat)%R with (/ 2%nat)%R; auto with real arith. rewrite <- (Rinv_r (INR 2)); auto with real arith. simpl; field; auto with real. apply Rlt_le; apply Rlt_le_trans with (1 := H6). rewrite Faux.Rabsolu_left1; [ right; ring | idtac ]. apply Rplus_le_reg_l with (FtoRradix u). ring_simplify; auto. fold FtoRradix in |- *; apply Rplus_le_reg_l with (Fulp b radix precision (FPred b radix precision u)). apply Rle_trans with (FtoRradix (FPred b radix precision u) + Fulp b radix precision (FPred b radix precision u) + - (FtoRradix t + FtoRradix y))%R; [ right; ring | unfold FtoRradix in |- *; rewrite FpredUlpPos; auto with zarith arith ]. ring_simplify (Fulp b radix precision (FPred b radix precision u) + 0)%R. apply Rle_trans with (Rabs (FtoRradix u + - (FtoRradix t + FtoRradix y))). apply RRle_abs. rewrite <- Rabs_Ropp. replace (- (FtoRradix u + - (FtoRradix t + FtoRradix y)))%R with (FtoRradix t + FtoRradix y - u)%R; [ idtac | ring ]. apply Rmult_le_reg_l with (INR 2); auto with arith real. apply Rle_trans with (Fulp b radix precision u). unfold FtoRradix in |- *; apply ClosestUlp; auto with arith zarith. replace (INR 2) with (IZR radix); auto with zarith arith real. apply FulpFPredLe; auto with zarith. apply trans_eq with ((1 - / 2%nat) * Fulp b radix precision (FPred b radix precision u))%R; [ idtac | ring ]. replace (1 - / 2%nat)%R with (/ 2%nat)%R; auto with real arith. rewrite <- (Rinv_r (INR 2)); auto with real arith. simpl; field; auto with real. case (Rle_or_lt (t + y) (u + / 2%nat * Fulp b radix precision (FPred b radix precision u))); intros H6. apply MinOrMax1 with precision; auto with arith zarith real float. apply Rlt_le_trans with (1 := H4); rewrite Rabs_right. apply Rplus_le_reg_l with (u + - (/ 2%nat * Fulp b radix precision (FPred b radix precision u)))%R. ring_simplify. apply Rle_trans with (1 := H6). apply Rle_trans with (FtoRradix u + (Fulp b radix precision (FPred b radix precision u) + - (Fulp b radix precision (FPred b radix precision u) * / 2%nat)))%R; [ apply Rplus_le_compat_l; right | right; ring ]. apply trans_eq with ((1 - / 2%nat) * Fulp b radix precision (FPred b radix precision u))%R; [ idtac | ring ]. replace (1 - / 2%nat)%R with (/ 2%nat)%R; auto with real arith. rewrite <- (Rinv_r (INR 2)); auto with real arith. simpl; field; auto with real. apply Rle_ge; apply Rplus_le_reg_l with (FtoRradix u); auto with real. apply MinOrMax2 with precision; auto with arith zarith float real. apply Rlt_le_trans with (1 := H4). apply Rle_trans with (/ 2%nat * Fulp b radix precision u + Rabs (FtoRradix t + FtoRradix y - FtoRradix u))%R; [ apply Rplus_le_compat_r | idtac ]. apply Rmult_le_compat_l; auto with real arith. apply FulpFPredGePos; auto with arith zarith. apply Rle_trans with (/ 2%nat * Fulp b radix precision u + / 2%nat * Fulp b radix precision u)%R; [ apply Rplus_le_compat_l | right ]. apply Rmult_le_reg_l with (INR 2); auto with real arith. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real arith. ring_simplify (1 * Fulp b radix precision u)%R. unfold FtoRradix in |- *; apply ClosestUlp; auto with real arith zarith float. apply trans_eq with ((/ 2%nat + / 2%nat) * Fulp b radix precision u)%R; [ ring | auto with real arith ]. replace (/ 2%nat + / 2%nat)%R with 1%R; [ ring | auto with real arith ]. rewrite <- (Rinv_r (INR 2)); auto with real arith; simpl in |- *; ring. cut (forall z z' : R, (Rabs z <= z')%R -> (- z' <= z)%R); [ intros V | idtac ]. replace (a1 * x1 + y1)%R with (a1 * x1 - a * x + (y1 - y) + (a * x - t + (t + y)))%R; [ fold FtoRradix in |- * | ring ]. replace (FtoRradix u) with (- (/ 4%nat * Fulp b radix precision (FPred b radix precision u)) + (- (/ 4%nat * Fulp b radix precision (FPred b radix precision u)) + (FtoRradix u + / 2%nat * Fulp b radix precision (FPred b radix precision u))))%R. apply Rplus_le_compat. apply V; auto with real. apply Rle_trans with (Rabs (y1 - FtoRradix y) + Rabs (a1 * x1 - FtoRradix a * FtoRradix x))%R; auto with real. rewrite Rplus_comm; apply Rabs_triang. apply Rplus_le_compat. apply V; auto with real. auto with real. apply trans_eq with (FtoRradix u + (- / 4%nat + (- / 4%nat + / 2%nat)) * Fulp b radix precision (FPred b radix precision u))%R; [ ring | idtac ]. replace (- / 4%nat + (- / 4%nat + / 2%nat))%R with 0%R; [ ring | idtac ]. replace (/ 2%nat)%R with (2%nat * / 4%nat)%R; [ simpl in |- *; ring | idtac ]. replace (INR 4) with (2%nat * 2%nat)%R; auto with arith real zarith. rewrite Rinv_mult_distr; auto with real arith. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real arith. rewrite <- mult_INR; auto with real arith. intros z z'; case (Rle_or_lt 0 z); intros P1 P2. apply Rle_trans with (-0)%R; [ apply Ropp_le_contravar | simpl in |- * ]; auto with real. apply Rle_trans with (Rabs z); auto with real. replace (-0)%R with 0%R; auto with real. apply Ropp_le_cancel; rewrite Ropp_involutive; rewrite <- Rabs_left; auto with real. replace (a1 * x1 + y1 - FtoRradix u)%R with (y1 - y + (a1 * x1 - a * x) + (a * x - t + (t + y - u)))%R; [ idtac | ring ]. apply Rle_lt_trans with (Rabs (y1 - FtoRradix y + (a1 * x1 - FtoRradix a * FtoRradix x)) + Rabs (FtoRradix a * FtoRradix x - FtoRradix t + (FtoRradix t + FtoRradix y - FtoRradix u)))%R; [ apply Rabs_triang | idtac ]. apply Rle_lt_trans with (Rabs (y1 - FtoRradix y + (a1 * x1 - FtoRradix a * FtoRradix x)) + (Rabs (FtoRradix a * FtoRradix x - FtoRradix t) + Rabs (FtoRradix t + FtoRradix y - FtoRradix u)))%R; [ apply Rplus_le_compat_l; apply Rabs_triang | idtac ]. apply Rle_lt_trans with (Rabs (y1 - FtoRradix y) + Rabs (a1 * x1 - FtoRradix a * FtoRradix x) + (Rabs (FtoRradix a * FtoRradix x - FtoRradix t) + Rabs (FtoRradix t + FtoRradix y - FtoRradix u)))%R. apply Rplus_le_compat_r; apply Rabs_triang. apply Rlt_le_trans with (/ 4%nat * Fulp b radix precision (FPred b radix precision u) + (Rabs (FtoRradix a * FtoRradix x - FtoRradix t) + Rabs (FtoRradix t + FtoRradix y - FtoRradix u)))%R; auto with real. apply Rle_trans with (/ 4%nat * Fulp b radix precision (FPred b radix precision u) + (/ 4%nat * Fulp b radix precision (FPred b radix precision u) + Rabs (FtoRradix t + FtoRradix y - FtoRradix u)))%R; auto with real. apply Rle_trans with ((/ 4%nat + / 4%nat) * Fulp b radix precision (FPred b radix precision u) + Rabs (FtoRradix t + FtoRradix y - FtoRradix u))%R; [ right; ring | apply Rplus_le_compat_r ]. replace (/ 4%nat + / 4%nat)%R with (/ 2%nat)%R; auto with real. replace (/ 2%nat)%R with (2%nat * / 4%nat)%R; [ simpl in |- *; ring | idtac ]. replace (INR 4) with (2%nat * 2%nat)%R; auto with arith real zarith. rewrite Rinv_mult_distr; auto with real arith. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real arith. rewrite <- mult_INR; auto with real arith. Qed. Theorem Axpy_aux1_aux1 : Fnormal radix b t -> Fcanonic radix b u -> (0 < u)%R -> (4%nat * Rabs t <= Rabs u)%R -> (Rabs (FtoRradix a * FtoRradix x - FtoRradix t) <= / 4%nat * Fulp b radix precision (FPred b radix precision u))%R. intros H1 H2 H3 H4. cut (Fcanonic radix b t); [ intros H5 | left; auto ]. apply Rle_trans with (/ 2%nat * Fulp b radix precision t)%R. apply Rmult_le_reg_l with (INR 2); auto with real arith. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real arith. ring_simplify (1 * Fulp b radix precision t)%R. unfold FtoRradix in |- *; apply ClosestUlp; auto with real arith zarith. apply Rle_trans with (/ 2%nat * (/ 4%nat * Fulp b radix precision u))%R. apply Rmult_le_compat_l; auto with real arith. apply Rmult_le_reg_l with (INR 4); auto with real arith. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real arith. ring_simplify (1 * Fulp b radix precision u)%R. cut (Fbounded b (Float (Fnum t) (Zsucc (Zsucc (Fexp t))))); [ intros H6 | idtac ]. 2: elim H1; intros H7 H8; elim H7; intros H9 H10. 2: repeat (split; simpl in |- *; auto with zarith). apply Rle_trans with (Fulp b radix precision (Float (Fnum t) (Zsucc (Zsucc (Fexp t))))). right; unfold Fulp in |- *. replace (Fnormalize radix b precision t) with t; [ idtac | apply FcanonicUnique with (radix := radix) (b := b) (precision := precision); auto with real float zarith ]. 2: apply sym_eq; apply FnormalizeCorrect; auto with real zarith. replace (Fnormalize radix b precision (Float (Fnum t) (Zsucc (Zsucc (Fexp t))))) with (Float (Fnum t) (Zsucc (Zsucc (Fexp t)))). replace (Fexp (Float (Fnum t) (Zsucc (Zsucc (Fexp t))))) with (Zsucc (Zsucc (Fexp t))); [ idtac | simpl in |- *; auto ]. replace (Zsucc (Zsucc (Fexp t))) with (2 + Fexp t)%Z; [ rewrite powerRZ_add | unfold Zsucc in |- * ]; auto with zarith real. replace (powerRZ radix 2) with (INR 4); [ idtac | simpl in |- * ]; auto with real zarith; ring. apply FcanonicUnique with (radix := radix) (b := b) (precision := precision); auto with real float arith zarith. 2: apply sym_eq; apply FnormalizeCorrect; auto with real zarith. elim H1; intros H7 H8. left; repeat (split; simpl in |- *; auto with zarith). rewrite FulpFabs with b radix precision (Float (Fnum t) (Zsucc (Zsucc (Fexp t)))); auto with zarith. rewrite FulpFabs with b radix precision u; auto with zarith. apply LeFulpPos; auto with zarith real float. unfold FtoRradix in |- *; rewrite Fabs_correct; auto with real zarith. replace (FtoR radix (Fabs (Float (Fnum t) (Zsucc (Zsucc (Fexp t)))))) with (Zabs (Fnum t) * powerRZ radix (Zsucc (Zsucc (Fexp t))))%R; [ idtac | unfold FtoR in |- *; simpl in |- *; auto ]. replace (Zsucc (Zsucc (Fexp t))) with (2 + Fexp t)%Z; [ rewrite powerRZ_add | unfold Zsucc in |- * ]; auto with zarith real. replace (powerRZ radix 2) with (INR 4); [ idtac | simpl in |- *; auto with real zarith; ring ]. rewrite Rmult_comm; rewrite Rmult_assoc. replace (powerRZ radix (Fexp t) * Zabs (Fnum t))%R with (Rabs (FtoRradix t)); [ unfold FtoRradix in |- *; repeat rewrite Fabs_correct; auto with real zarith | idtac ]. unfold FtoRradix in |- *; rewrite <- Fabs_correct; auto with zarith; unfold FtoR in |- *; simpl in |- *; ring. apply Rmult_le_reg_l with (INR 2); auto with arith real. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with arith real. ring_simplify (1 * (/ 4%nat * Fulp b radix precision u))%R. apply Rle_trans with (/ 4%nat * (2%nat * Fulp b radix precision (FPred b radix precision u)))%R; [ apply Rmult_le_compat_l; auto with real arith | right; ring ]. replace (INR 2) with (IZR radix); auto with arith zarith real. apply FulpFPredLe; auto with arith zarith real. Qed. Theorem Axpy_aux2 : Fcanonic radix b u -> Fsubnormal radix b t -> (0 < u)%R -> FtoRradix u = (t + y)%R -> (Rabs (y1 - y) + Rabs (a1 * x1 - a * x) < / 4%nat * Fulp b radix precision (FPred b radix precision u))%R -> MinOrMax radix b (a1 * x1 + y1) u. intros H1 H2 H3 H4 H5. apply MinOrMax1 with precision; auto with zarith; fold FtoRradix in |- *. replace (a1 * x1 + y1 - FtoRradix u)%R with (y1 - y + (a1 * x1 - a * x) + (a * x - t + (t + y - u)))%R; [ idtac | ring ]. apply Rle_lt_trans with (Rabs (y1 - FtoRradix y + (a1 * x1 - FtoRradix a * FtoRradix x)) + Rabs (FtoRradix a * FtoRradix x - FtoRradix t + (FtoRradix t + FtoRradix y - FtoRradix u)))%R; [ apply Rabs_triang | idtac ]. apply Rle_lt_trans with (Rabs (y1 - FtoRradix y) + Rabs (a1 * x1 - FtoRradix a * FtoRradix x) + Rabs (FtoRradix a * FtoRradix x - FtoRradix t + (FtoRradix t + FtoRradix y - FtoRradix u)))%R; [ apply Rplus_le_compat_r; apply Rabs_triang | idtac ]. apply Rle_lt_trans with (Rabs (y1 - FtoRradix y) + Rabs (a1 * x1 - FtoRradix a * FtoRradix x) + (Rabs (FtoRradix a * FtoRradix x - FtoRradix t) + Rabs (FtoRradix t + FtoRradix y - FtoRradix u)))%R; [ apply Rplus_le_compat_l; apply Rabs_triang | idtac ]. apply Rlt_le_trans with (/ 4%nat * Fulp b radix precision (FPred b radix precision u) + (Rabs (FtoRradix a * FtoRradix x - FtoRradix t) + Rabs (FtoRradix t + FtoRradix y - FtoRradix u)))%R; [ apply Rplus_lt_compat_r; auto | idtac ]. apply Rle_trans with (/ 4%nat * Fulp b radix precision (FPred b radix precision u) + (/ 2%nat * powerRZ radix (- dExp b) + 0))%R. apply Rplus_le_compat; auto with real. apply Rplus_le_compat. apply Rle_trans with (/ 2%nat * Fulp b radix precision t)%R; [ apply Rmult_le_reg_l with (INR 2) | apply Rmult_le_compat_l ]; auto with real arith. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real arith. ring_simplify (1 * Fulp b radix precision t)%R; unfold FtoRradix in |- *; apply ClosestUlp; auto with zarith. unfold Fulp in |- *; replace (Fnormalize radix b precision t) with t. elim H2; intros H6 H7; elim H7; intros H8 H9; rewrite H8; auto with zarith real. apply FcanonicUnique with (radix := radix) (b := b) (precision := precision); auto with real zarith float. right; auto. apply sym_eq; apply FnormalizeCorrect; auto with zarith. rewrite H4; right. ring_simplify (FtoRradix t + FtoRradix y - (FtoRradix t + FtoRradix y))%R; apply Rabs_R0. replace (/ 2%nat * powerRZ radix (- dExp b) + 0)%R with (/ 2%nat * powerRZ radix (- dExp b))%R; [ idtac | ring ]. apply Rle_trans with (/ 4%nat * Fulp b radix precision (FPred b radix precision u) + / 2%nat * Fulp b radix precision (FPred b radix precision u))%R; [ apply Rplus_le_compat_l; apply Rmult_le_compat_l; auto with real arith | idtac ]. unfold Fulp in |- *; apply Rle_powerRZ; auto with zarith real. cut (Fbounded b (Fnormalize radix b precision (FPred b radix precision u))); [ intros H6; elim H6; auto | idtac ]. apply FnormalizeBounded; auto with zarith arith. apply FBoundedPred; auto with zarith arith. apply Rle_trans with ((/ 4%nat + / 2%nat) * Fulp b radix precision (FPred b radix precision u))%R; [ right; ring | idtac ]. apply Rle_trans with (1 * Fulp b radix precision (FPred b radix precision u))%R; [ apply Rmult_le_compat_r; auto with real zarith | right; ring ]. unfold Fulp in |- *; auto with real zarith. apply Rmult_le_reg_l with (INR 4); auto with real arith. apply Rle_trans with (4%nat * / 4%nat + 2%nat * (2%nat * / 2%nat))%R; [ right; simpl; ring | idtac ]. replace (2%nat * 2%nat)%R with (INR (2 * 2)); auto with arith real. repeat rewrite Rinv_r; auto with real arith. simpl; ring_simplify; auto with real. apply Rle_trans with (3+1)%R; auto with real. right; ring. Qed. Theorem Axpy_aux1_aux2 : Fsubnormal radix b t -> Fcanonic radix b u -> (0 < u)%R -> (Zsucc (- dExp b) <= Fexp (FPred b radix precision u))%Z -> (Rabs (FtoRradix a * FtoRradix x - FtoRradix t) <= / 4%nat * Fulp b radix precision (FPred b radix precision u))%R. intros H1 H2 H3 H4. apply Rle_trans with (/ 2%nat * Fulp b radix precision t)%R; [ apply Rmult_le_reg_l with (INR 2) | idtac ]; auto with real arith. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real arith. ring_simplify (1 * Fulp b radix precision t)%R; unfold FtoRradix in |- *; apply ClosestUlp; auto with zarith. unfold Fulp in |- *; replace (Fnormalize radix b precision t) with t. 2: apply FcanonicUnique with (radix := radix) (b := b) (precision := precision); auto with real zarith float. 2: right; auto. 2: apply sym_eq; apply FnormalizeCorrect; auto with zarith. replace (Fnormalize radix b precision (FPred b radix precision u)) with (FPred b radix precision u). 2: apply FcanonicUnique with (radix := radix) (b := b) (precision := precision); auto with real zarith float. 2: apply sym_eq; apply FnormalizeCorrect; auto with zarith. elim H1; intros H5 H6; elim H6; intros H7 H8; rewrite H7. apply Rmult_le_reg_l with (INR 4); auto with real arith. repeat rewrite <- Rmult_assoc. pattern (INR 4) at 1 in |- *; replace (INR 4) with (2%nat * 2%nat)%R. rewrite Rmult_comm; rewrite Rmult_assoc; repeat rewrite Rinv_r; auto with real arith. ring_simplify. replace (INR 2) with (powerRZ radix 1); [ rewrite <- powerRZ_add | simpl in |- * ]; auto with zarith real. replace (- dExp b + 1)%Z with (Zsucc (- dExp b)); [ apply Rle_powerRZ | unfold Zsucc in |- * ]; auto with zarith real. rewrite <- mult_INR; auto with arith. Qed. Theorem Axpy_aux1_aux3 : Fsubnormal radix b t -> Fcanonic radix b u -> (0 < u)%R -> (Zsucc (- dExp b) <= Fexp (FPred b radix precision u))%Z -> (Rabs (FtoRradix a * FtoRradix x - FtoRradix t) <= / 4%nat * Fulp b radix precision (FPred b radix precision u))%R. intros H1 H2 H3 H4. apply Rle_trans with (/ 2%nat * Fulp b radix precision t)%R. apply Rmult_le_reg_l with (INR 2); auto with real arith; rewrite <- Rmult_assoc; rewrite Rinv_r; auto with arith real. ring_simplify (1 * Fulp b radix precision t)%R; unfold FtoRradix in |- *; apply ClosestUlp; auto with zarith. apply Rmult_le_reg_l with (INR 4); auto with real arith; repeat rewrite <- Rmult_assoc. replace (INR 4) with (2%nat * 2%nat)%R; [ rewrite (Rmult_assoc 2%nat 2%nat (/ 2%nat)); repeat rewrite Rinv_r; auto with real arith | rewrite <- mult_INR; auto with real arith ]. ring_simplify; unfold Fulp in |- *. replace (Fnormalize radix b precision t) with t; [ elim H1; intros H9 H10; elim H10; intros H11 H12; rewrite H11 | idtac ]. 2: apply FcanonicUnique with (radix := radix) (b := b) (precision := precision); auto with real zarith float. 2: right; auto. 2: apply sym_eq; apply FnormalizeCorrect; auto with zarith. replace (Fnormalize radix b precision (FPred b radix precision u)) with (FPred b radix precision u). 2: apply FcanonicUnique with (radix := radix) (b := b) (precision := precision); auto with real zarith float. 2: apply sym_eq; apply FnormalizeCorrect; auto with zarith. replace (2%nat * powerRZ radix (- dExp b))%R with (powerRZ radix (Zsucc (- dExp b))); [ apply Rle_powerRZ | unfold Zsucc in |- * ]; auto with zarith real float. rewrite powerRZ_add; auto with real zarith; simpl in |- *; ring. Qed. Theorem Axpy_aux3 : Fcanonic radix b u -> Fsubnormal radix b t -> (0 < u)%R -> Fexp (FPred b radix precision u) = (- dExp b)%Z -> (Zsucc (- dExp b) <= Fexp u)%Z -> (Rabs (y1 - y) + Rabs (a1 * x1 - a * x) < / 4%nat * Fulp b radix precision (FPred b radix precision u))%R -> MinOrMax radix b (a1 * x1 + y1) u. intros H1 H2 H3 H4 H5 H6. case (Rle_or_lt u (a1 * x1 + y1)); intros H7. apply MinOrMax2 with precision; auto with zarith float real; fold FtoRradix in |- *. replace (a1 * x1 + y1 - FtoRradix u)%R with (y1 - y + (a1 * x1 - a * x) + (a * x - t + (t + y - u)))%R; [ idtac | ring ]. apply Rlt_le_trans with (/ 4%nat * powerRZ radix (- dExp b) + (/ 2%nat * powerRZ radix (- dExp b) + / 2%nat * Fulp b radix precision u))%R. apply Rle_lt_trans with (Rabs (y1 - FtoRradix y + (a1 * x1 - FtoRradix a * FtoRradix x)) + Rabs (FtoRradix a * FtoRradix x - FtoRradix t + (FtoRradix t + FtoRradix y - FtoRradix u)))%R; [ apply Rabs_triang | idtac ]. apply Rlt_le_trans with (/ 4%nat * powerRZ radix (- dExp b) + Rabs (FtoRradix a * FtoRradix x - FtoRradix t + (FtoRradix t + FtoRradix y - FtoRradix u)))%R; [ apply Rplus_lt_compat_r | apply Rplus_le_compat_l ]. apply Rle_lt_trans with (Rabs (y1 - FtoRradix y) + Rabs (a1 * x1 - FtoRradix a * FtoRradix x))%R; [ apply Rabs_triang | idtac ]. apply Rlt_le_trans with (1 := H6); unfold Fulp in |- *. replace (Fexp (Fnormalize radix b precision (FPred b radix precision u))) with (- dExp b)%Z; auto with real zarith. replace (Fnormalize radix b precision (FPred b radix precision u)) with (FPred b radix precision u); auto with zarith. apply FcanonicUnique with (radix := radix) (b := b) (precision := precision); auto with real zarith float. apply sym_eq; apply FnormalizeCorrect; auto with zarith. apply Rle_trans with (Rabs (FtoRradix a * FtoRradix x - FtoRradix t) + Rabs (FtoRradix t + FtoRradix y - FtoRradix u))%R; [ apply Rabs_triang | apply Rplus_le_compat ]. apply Rmult_le_reg_l with (INR 2); [ idtac | rewrite <- Rmult_assoc; rewrite Rinv_r ]; auto with arith real. ring_simplify; apply Rle_trans with (Fulp b radix precision t); [ unfold FtoRradix in |- *; apply ClosestUlp; auto with zarith | unfold Fulp in |- * ]. replace (Fexp (Fnormalize radix b precision t)) with (- dExp b)%Z; auto with real zarith. replace (Fnormalize radix b precision t) with t; elim H2; auto with zarith. intros; apply FcanonicUnique with (radix := radix) (b := b) (precision := precision); auto with real zarith float. right; auto. apply sym_eq; apply FnormalizeCorrect; auto with zarith. apply Rmult_le_reg_l with (INR 2); [ idtac | rewrite <- Rmult_assoc; rewrite Rinv_r ]; auto with arith real. ring_simplify (1 * Fulp b radix precision u)%R; unfold FtoRradix in |- *; apply ClosestUlp; auto with zarith. apply Rmult_le_reg_l with (INR 4); auto with arith real. apply Rle_trans with (powerRZ radix (-dExp b) * 3%nat + Fulp b radix precision u * 2%nat)%R. right; simpl; field; auto with real. apply Rle_trans with (Fulp b radix precision u * 2%nat + Fulp b radix precision u * 2%nat)%R; [ apply Rplus_le_compat_r | idtac ]; auto with real arith. apply Rle_trans with (3%nat * powerRZ radix (- dExp b))%R; [ right;ring | idtac ]. apply Rle_trans with (4%nat * powerRZ radix (- dExp b))%R; auto with arith zarith real. unfold Fulp in |- *; replace (INR 2) with (powerRZ radix 1); [ idtac | simpl in |- *; auto with zarith real ]. replace (INR 4) with (powerRZ radix 2); [ idtac | simpl in |- *; auto with zarith real; ring ]. repeat rewrite <- powerRZ_add; auto with zarith real. replace (2 + - dExp b)%Z with (Zsucc (- dExp b) + 1)%Z; [ apply Rle_powerRZ | unfold Zsucc in |- * ]; auto with zarith real. replace (Fnormalize radix b precision u) with u; auto with zarith arith. apply FcanonicUnique with (radix := radix) (b := b) (precision := precision); auto with real zarith float. apply sym_eq; apply FnormalizeCorrect; auto with zarith. right; replace (INR 4) with (2%nat + 2%nat)%R; [ ring | rewrite <- plus_INR; auto with arith real ]. case (Rle_or_lt (t + y) u); intros H8. apply Axpy_aux2; auto. apply sym_eq; unfold FtoRradix in |- *; apply ExactSum_Near with b precision; auto with zarith. elim H2; intuition. cut (forall v w : R, (v <= w)%R -> v <> w -> (v < w)%R); [ intros V | idtac ]. 2: intros V W H' H'1; case H'; auto with real. 2: intros H'2; absurd (V = W); auto with real. apply V. apply Rmult_le_reg_l with (INR 2); auto with real arith. apply Rle_trans with (Fulp b radix precision u); [ unfold FtoRradix in |- *; apply ClosestUlp; auto with zarith | idtac ]. replace (powerRZ 2%Z (- dExp b)) with (Fulp b radix precision (FPred b radix precision u)). replace (INR 2) with (IZR radix); auto with zarith real. apply FulpFPredLe; auto with zarith. unfold Fulp in |- *; replace (Fnormalize radix b precision (FPred b radix precision u)) with (FPred b radix precision u). rewrite H4; auto with zarith real. apply FcanonicUnique with (radix := radix) (b := b) (precision := precision); auto with real zarith float. apply sym_eq; apply FnormalizeCorrect; auto with zarith. replace (powerRZ 2%Z (- dExp b)) with (Fulp b radix precision (FPred b radix precision u)). 2: unfold Fulp in |- *; replace (Fnormalize radix b precision (FPred b radix precision u)) with (FPred b radix precision u). 2: rewrite H4; auto with zarith real. rewrite Faux.Rabsolu_left1; auto with real. 2: apply Rplus_le_reg_l with (FtoRradix u); unfold FtoRradix, radix in |- *. 2: ring_simplify; auto with real zarith. case (Req_dec (- (FtoR 2 t + FtoR 2 y - FtoR 2 u)) (Fulp b radix precision (FPred b radix precision u))); auto. intros W; Contradict uDef. replace (FtoRradix t + FtoRradix y)%R with (FtoRradix (FPred b radix precision u)); auto with float real. cut (FtoRradix u <> FPred b radix precision u); [ intros V' | idtac ]. Contradict V'. cut (ProjectorP b radix (Closest b radix)); [ unfold ProjectorP in |- *; intros W' | idtac ]. apply sym_eq; apply W'; auto with zarith float real. apply RoundedProjector; apply ClosestRoundedModeP with precision; auto with zarith. apply not_eq_sym; apply Rlt_dichotomy_converse; left. unfold FtoRradix in |- *; apply FPredLt; auto with zarith. apply Rplus_eq_reg_l with (Fulp b radix precision (FPred b radix precision u)). rewrite Rplus_comm; unfold FtoRradix in |- *; rewrite FpredUlpPos; auto with zarith. rewrite <- W; unfold FtoRradix, radix in |- *; ring. apply FcanonicUnique with (radix := radix) (b := b) (precision := precision); auto with real zarith float. apply sym_eq; apply FnormalizeCorrect; auto with zarith. apply MinOrMax1 with precision; auto with zarith; fold FtoRradix in |- *. rewrite Faux.Rabsolu_left1. 2: apply Rplus_le_reg_l with (FtoRradix u). 2: ring_simplify; auto with real. apply Rle_lt_trans with (y - y1 + (t - a1 * x1) - (t + y - u))%R; [ right; ring | idtac ]. apply Rlt_le_trans with (Rabs (y - y1 + (t - a1 * x1))). cut (forall u v : R, (0 < v)%R -> (u - v < Rabs u)%R); [ intros V; apply V | idtac ]. apply Rplus_lt_reg_r with (FtoRradix u). ring_simplify; auto with real. intros v w H'1. apply Rlt_le_trans with v; auto with real. unfold Rminus in |- *; apply Rlt_le_trans with (v + -0)%R; [ auto with real | right; ring ]. apply RRle_abs. replace (FtoRradix y - y1 + (FtoRradix t - a1 * x1))%R with (- (y1 - FtoRradix y + (a1 * x1 - a * x) + (a * x - t)))%R; [ idtac | ring ]. rewrite Rabs_Ropp. apply Rle_trans with (Rabs (y1 - FtoRradix y + (a1 * x1 - FtoRradix a * FtoRradix x)) + Rabs (FtoRradix a * FtoRradix x - FtoRradix t))%R; [ apply Rabs_triang | idtac ]. apply Rmult_le_reg_l with (INR 2); auto with real arith. apply Rle_trans with (2%nat * Rabs (y1 - FtoRradix y + (a1 * x1 - FtoRradix a * FtoRradix x)) + 2%nat * Rabs (FtoRradix a * FtoRradix x - FtoRradix t))%R; [ right; ring | idtac ]. apply Rle_trans with (Fulp b radix precision (FPred b radix precision u) + Fulp b radix precision (FPred b radix precision u))%R; [ idtac | right; simpl; ring ]. apply Rplus_le_compat. apply Rle_trans with (2%nat * (/ 4%nat * Fulp b radix precision (FPred b radix precision u)))%R; auto with real. apply Rle_trans with (2%nat * (Rabs (y1 - FtoRradix y) + Rabs (a1 * x1 - FtoRradix a * FtoRradix x)))%R; [ apply Rmult_le_compat_l; auto with real arith; apply Rabs_triang | idtac ]. apply Rmult_le_compat_l; auto with real arith. apply Rle_trans with (1 * Fulp b radix precision (FPred b radix precision u))%R; [ rewrite <- Rmult_assoc; apply Rmult_le_compat_r | right; ring ]; auto with real arith zarith. unfold Fulp in |- *; auto with real float zarith. rewrite Rmult_comm; apply Rmult_le_reg_l with (INR 4); auto with arith real; rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real arith. simpl; ring_simplify; auto with real arith. apply Rle_trans with (Fulp b radix precision t); [ unfold FtoRradix in |- *; apply ClosestUlp; auto with zarith | unfold Fulp in |- * ]. apply Rle_powerRZ; auto with zarith real. replace (Fnormalize radix b precision t) with t; [ elim H2; intros H9 H10; elim H10; intros H11 H12; rewrite H11 | idtac ]. 2: apply sym_eq; apply FcanonicFnormalizeEq; auto with zarith; right; auto. replace (Fnormalize radix b precision (FPred b radix precision u)) with (FPred b radix precision u); [ rewrite H4; auto with zarith | idtac ]. apply sym_eq; apply FcanonicFnormalizeEq; auto with zarith float. Qed. Theorem AxpyPos : Fcanonic radix b u -> Fcanonic radix b t -> (0 < u)%R -> (4%nat * Rabs t <= Rabs u)%R -> (Rabs (y1 - y) + Rabs (a1 * x1 - a * x) < / 4%nat * Fulp b radix precision (FPred b radix precision u))%R -> MinOrMax radix b (a1 * x1 + y1) u. intros H1 H2 H3 H4 H5. case H2; intros H6. apply Axpy_aux1; auto; apply Axpy_aux1_aux1; auto. cut (forall z1 z2 : Z, (z1 <= z2)%Z -> z1 = z2 \/ (Zsucc z1 <= z2)%Z); [ intros V | idtac ]. 2: intros z1 z2 V; omega. case (V (- dExp b)%Z (Fexp u)); [ elim Fu; intuition | intros H7 | intros H7 ]. apply Axpy_aux2; auto. unfold FtoRradix in |- *; apply plusExact1 with b precision; auto with zarith float. rewrite <- H7; elim H6; intros H8 H9; elim H9; intros H10 H11; rewrite H10. rewrite Zmin_le1; auto with zarith; elim Fy; auto. case (V (- dExp b)%Z (Fexp (FPred b radix precision u))). cut (Fbounded b (FPred b radix precision u)); [ intros H8 | idtac ]; auto with float. apply FBoundedPred; auto with zarith. intros H8; apply Axpy_aux3; auto. intros H8; apply Axpy_aux1; auto. apply Axpy_aux1_aux3; auto. Qed. Definition FLess (p : float) := match Rcase_abs p with | left _ => FSucc b radix precision p | right _ => FPred b radix precision p end. Theorem UlpFlessuGe_aux : forall p : float, Fbounded b p -> Fcanonic radix b p -> (Rabs p - Fulp b radix precision p <= Rabs (FLess p))%R. intros p H H1. cut (forall p : float, Fbounded b p -> Fcanonic radix b p -> (0 < p)%R -> (Rabs p - Fulp b radix precision p <= Rabs (FPred b radix precision p))%R); [ intros V | idtac ]. unfold FLess in |- *; case (Rcase_abs p); intros H2. rewrite <- Rabs_Ropp; unfold FtoRradix in |- *; rewrite <- Fopp_correct. pattern p at 3 in |- *; rewrite <- Fopp_Fopp. rewrite <- (Rabs_Ropp (FtoR radix (FSucc b radix precision (Fopp (Fopp p))))); rewrite <- (Fopp_correct radix (FSucc b radix precision (Fopp (Fopp p)))). rewrite <- FPredFopFSucc with b radix precision (Fopp p); auto with zarith. replace (Fulp b radix precision p) with (Fulp b radix precision (Fopp p)); auto with float. fold FtoRradix in |- *; apply V; auto with float. unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real. unfold Fulp in |- *; rewrite Fnormalize_Fopp; auto with arith. unfold Fopp in |- *; simpl in |- *; auto with real. cut (0 <= p)%R; [ intros H3; case H3; intros H4 | auto with real ]. apply V; auto. rewrite <- H4; rewrite Rabs_R0. ring_simplify (0 - Fulp b radix precision p)%R; apply Rle_trans with 0%R; auto with real zarith. unfold Fulp in |- *; auto with real zarith. intros q H2 H3 H4. unfold FtoRradix in |- *; rewrite <- FpredUlpPos with b radix precision q; auto with zarith; fold FtoRradix in |- *. apply Rle_trans with (Rabs (FtoRradix (FPred b radix precision q)) + Rabs (Fulp b radix precision (FPred b radix precision q)) - Fulp b radix precision q)%R; [ unfold Rminus in |- *; apply Rplus_le_compat_r; apply Rabs_triang | idtac ]. rewrite (Rabs_right (Fulp b radix precision (FPred b radix precision q))); [ idtac | apply Rle_ge; unfold Fulp in |- *; auto with real zarith ]. apply Rplus_le_reg_l with (Fulp b radix precision q). ring_simplify (Fulp b radix precision q + (Rabs (FtoRradix (FPred b radix precision q)) + Fulp b radix precision (FPred b radix precision q) - Fulp b radix precision q))%R. rewrite Rplus_comm; apply Rplus_le_compat_r. apply FulpFPredGePos; auto with zarith real float. Qed. Theorem UlpFlessuGe : Fcanonic radix b u -> (/ (4%nat * (powerRZ radix precision - 1) * (1 + powerRZ radix (- precision))) * ((1 - powerRZ radix (Zsucc (- precision))) * Rabs y) + - (/ (4%nat * (powerRZ radix precision - 1) * (1 + powerRZ radix (- precision)) * (1 - powerRZ radix (- precision))) * ((1 - powerRZ radix (Zsucc (- precision))) * Rabs (a * x))) + - (powerRZ radix (Zpred (- dExp b)) * (/ (2%nat * (powerRZ radix precision - 1)) + / (4%nat * (powerRZ radix precision - 1) * (1 + powerRZ radix (- precision)) * (1 - powerRZ radix (- precision))) * (1 - powerRZ radix (Zsucc (- precision))))) <= / 4%nat * Fulp b radix precision (FLess u))%R. intros Cu. cut (0 < 1 - powerRZ radix (- precision))%R; [ intros H'1 | idtac ]. 2: apply Rplus_lt_reg_r with (powerRZ radix (- precision)). 2: ring_simplify. 2: replace 1%R with (powerRZ radix 0); [ auto with real zarith | simpl in |- *; auto ]. cut (0 < 1 + powerRZ radix (- precision))%R; [ intros H'2 | idtac ]. 2: apply Rlt_le_trans with 1%R; auto with real. 2: apply Rle_trans with (1 + 0)%R; auto with real zarith. cut (0 < powerRZ radix precision - 1)%R; [ intros H'3 | idtac ]. 2: apply Rplus_lt_reg_r with 1%R. 2: ring_simplify. 2: replace 1%R with (powerRZ radix 0); [ auto with real zarith | simpl in |- *; auto ]. cut (0 < 1 - powerRZ radix (Zsucc (- precision)))%R; [ intros H'4 | idtac ]. 2: apply Rplus_lt_reg_r with (powerRZ radix (Zsucc (- precision))). 2: ring_simplify. 2: replace 1%R with (powerRZ radix 0); [ auto with real zarith | simpl in |- *; auto ]. cut (0 < INR 4)%R; [ intros H'5 | auto with arith real ]. rewrite (Rinv_mult_distr (4%nat * (powerRZ radix precision - 1) * (1 + powerRZ radix (- precision))) (1 - powerRZ radix (- precision))) ; auto with real. 2: apply Rmult_integral_contrapositive; split; auto with real. apply Rle_trans with (/ (4%nat * (powerRZ radix precision - 1) * (1 + powerRZ radix (- precision))) * (1 - powerRZ radix (Zsucc (- precision))) * (Rabs y - (Rabs (FtoRradix a * FtoRradix x) * / (1 - powerRZ radix (- precision)) + powerRZ radix (Zpred (- dExp b)) * / (1 - powerRZ radix (- precision)))) + - (powerRZ radix (Zpred (- dExp b)) * / (2%nat * (powerRZ radix precision - 1))))%R; [ right; ring; ring | idtac ]. apply Rle_trans with (/ (4%nat * (powerRZ radix precision - 1) * (1 + powerRZ radix (- precision))) * (1 - powerRZ radix (Zsucc (- precision))) * (Rabs (FtoRradix y) - Rabs t) + - (powerRZ radix (Zpred (- dExp b)) * / (2%nat * (powerRZ radix precision - 1))))%R; [ apply Rplus_le_compat_r | idtac ]. apply Rmult_le_compat_l. apply Rlt_le; apply Rmult_lt_0_compat; auto with real. apply Rinv_0_lt_compat; apply Rmult_lt_0_compat; auto with real; apply Rmult_lt_0_compat; auto with real. unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_contravar. apply Rle_trans with (Rabs (FtoRradix a * FtoRradix x) * / (1 - powerRZ 2%Z (- precision)) + powerRZ 2%Z (Zpred (- dExp b)) * / (1 - powerRZ 2%Z (- precision)))%R; [ idtac | right; unfold FtoRradix, radix, Rminus in |- *; auto with real ]. apply RoundLeGeneral; auto with zarith. rewrite (Rinv_mult_distr (4%nat * (powerRZ radix precision - 1)) (1 + powerRZ radix (- precision))); auto with real. apply Rle_trans with (/ (4%nat * (powerRZ radix precision - 1)) * (1 - powerRZ radix (Zsucc (- precision))) * (/ (1 + powerRZ radix (- precision)) * (Rabs (FtoRradix y) - Rabs (FtoRradix t))) + - (powerRZ radix (Zpred (- dExp b)) * / (2%nat * (powerRZ radix precision - 1))))%R; [ right; ring | idtac ]. apply Rle_trans with (/ (4%nat * (powerRZ radix precision - 1)) * (1 - powerRZ radix (Zsucc (- precision))) * Rabs u + - (powerRZ radix (Zpred (- dExp b)) * / (2%nat * (powerRZ radix precision - 1))))%R. apply Rplus_le_compat_r; apply Rmult_le_compat_l. apply Rlt_le; apply Rmult_lt_0_compat; auto with real. apply Rinv_0_lt_compat; apply Rmult_lt_0_compat; auto with real. apply Rle_trans with (/ (1 + powerRZ radix (- precision)) * Rabs (FtoRradix y + FtoRradix t))%R. apply Rmult_le_compat_l; auto with real. rewrite <- (Rabs_Ropp (FtoRradix t)). replace (FtoRradix y + FtoRradix t)%R with (FtoRradix y - - FtoRradix t)%R; [ apply Rabs_triang_inv | ring ]. case Cu; intros H1. apply Rmult_le_reg_l with (1 + powerRZ radix (- precision))%R; auto. apply Rle_trans with (Rabs (FtoRradix y + FtoRradix t) * ((1 + powerRZ radix (- precision)) * / (1 + powerRZ radix (- precision))))%R; [ right; ring; ring | idtac ]. rewrite Rinv_r; auto with real. ring_simplify. apply Rle_trans with (Rabs u + / radix * Fulp b radix precision u)%R. apply Rplus_le_reg_l with (- Rabs u)%R. ring_simplify. apply Rle_trans with (Rabs (FtoRradix y + FtoRradix t - FtoRradix u)). apply Rle_trans with (Rabs (FtoRradix y + FtoRradix t) - Rabs (FtoRradix u))%R; [ right; ring | apply Rabs_triang_inv ]. apply Rmult_le_reg_l with (IZR radix); auto with real zarith. apply Rle_trans with (Fulp b radix precision u * (radix * / radix))%R; [ rewrite Rinv_r; auto with real zarith | right; ring ]. ring_simplify (Fulp b radix precision u * 1)%R. unfold FtoRradix in |- *; apply ClosestUlp; auto with real zarith. rewrite Rplus_comm; auto. rewrite Rplus_comm; apply Rplus_le_compat_r. apply Rmult_le_reg_l with (IZR radix); auto with real zarith. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real zarith. ring_simplify (1 * Fulp b radix precision u)%R. apply Rle_trans with (Rabs (FtoRradix u) * powerRZ radix (Zsucc (- precision)))%R. unfold FtoRradix in |- *; apply FulpLe2; auto with zarith. replace (Fnormalize radix b precision u) with u; [ idtac | apply FcanonicUnique with (radix := radix) (precision := precision) (b := b) ]; auto with zarith real. apply FnormalizeCanonic; auto with zarith. apply sym_eq; apply FnormalizeCorrect; auto with zarith. unfold Zsucc in |- *; rewrite powerRZ_add; auto with zarith real; simpl in |- *; auto with zarith real; right; ring. replace (FtoRradix y + FtoRradix t)%R with (FtoRradix u); auto with real. apply Rle_trans with (1 * Rabs (FtoRradix u))%R; [ apply Rmult_le_compat_r | right; ring ]; auto with real. pattern 1%R at 2 in |- *; replace 1%R with (/ 1)%R; auto with real zarith. apply Rle_Rinv; auto with real zarith. pattern 1%R at 1 in |- *; replace 1%R with (1 + 0)%R; auto with real zarith. unfold FtoRradix in |- *; apply plusExact1 with b precision; auto with real zarith. rewrite Rplus_comm; auto. elim H1; intros H5 H6; elim H6; intros H7 H8; rewrite H7; apply Zmin_Zle; elim Fy; elim Ft; auto with zarith. apply Rle_trans with (/ (4%nat * (powerRZ radix precision - 1)) * (Rabs (FtoRradix u) - (Rabs u * powerRZ radix (Zsucc (- precision)) + powerRZ radix (- dExp b))))%R. right; simpl; ring_simplify. unfold Zpred in |- *; rewrite powerRZ_add; auto with zarith real. simpl; field; auto with real. apply Rle_trans with (/ (4%nat * (powerRZ radix precision - 1)) * (Rabs (FtoRradix u) - Fulp b radix precision u))%R. apply Rmult_le_compat_l; auto with real. apply Rlt_le; apply Rinv_0_lt_compat; apply Rmult_lt_0_compat; auto with real. unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_contravar. apply FulpLeGeneral; auto. apply Rle_trans with (/ (4%nat * (powerRZ radix precision - 1)) * Rabs (FLess u))%R. apply Rmult_le_compat_l; auto with real. apply Rlt_le; apply Rinv_0_lt_compat; apply Rmult_lt_0_compat; auto with real. apply UlpFlessuGe_aux; auto. rewrite Rinv_mult_distr; auto with real. rewrite Rmult_assoc; apply Rmult_le_compat_l; auto with real. apply Rmult_le_reg_l with (powerRZ radix precision - 1)%R; auto. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real. ring_simplify (1 * Rabs (FtoRradix (FLess u)))%R; unfold FtoRradix in |- *; apply FulpGe; auto with zarith. unfold FLess in |- *; case (Rcase_abs u); intros H; auto with float. apply FBoundedSuc; auto with zarith. apply FBoundedPred; auto with zarith. Qed. Theorem UlpFlessuGe2 : Fcanonic radix b u -> (powerRZ radix (Zpred (Zpred (- precision))) * (1 - powerRZ radix (Zsucc (- precision))) * Rabs y + - (powerRZ radix (Zpred (Zpred (- precision))) * Rabs (a * x)) + - powerRZ radix (Zpred (Zpred (- dExp b))) < / 4%nat * Fulp b radix precision (FLess u))%R. intros H. apply Rlt_le_trans with (/ (4%nat * (powerRZ radix precision - 1) * (1 + powerRZ radix (- precision))) * ((1 - powerRZ radix (Zsucc (- precision))) * Rabs (FtoRradix y)) + - (/ (4%nat * (powerRZ radix precision - 1) * (1 + powerRZ radix (- precision)) * (1 - powerRZ radix (- precision))) * ((1 - powerRZ radix (Zsucc (- precision))) * Rabs (FtoRradix a * FtoRradix x))) + - (powerRZ radix (Zpred (- dExp b)) * (/ (2%nat * (powerRZ radix precision - 1)) + / (4%nat * (powerRZ radix precision - 1) * (1 + powerRZ radix (- precision)) * (1 - powerRZ radix (- precision))) * (1 - powerRZ radix (Zsucc (- precision))))))%R; [ idtac | apply UlpFlessuGe; auto ]. cut (0 < 1 - powerRZ radix (- precision))%R; [ intros H'1 | idtac ]. 2: apply Rplus_lt_reg_r with (powerRZ radix (- precision)). 2: ring_simplify. 2: replace 1%R with (powerRZ radix 0); [ auto with real zarith | simpl in |- *; auto ]. cut (0 < 1 + powerRZ radix (- precision))%R; [ intros H'2 | idtac ]. 2: apply Rlt_le_trans with 1%R; auto with real. 2: apply Rle_trans with (1 + 0)%R; auto with real zarith. cut (0 < powerRZ radix precision - 1)%R; [ intros H'3 | idtac ]. 2: apply Rplus_lt_reg_r with 1%R. 2: ring_simplify. 2: replace 1%R with (powerRZ radix 0); [ auto with real zarith | simpl in |- *; auto ]. cut (0 < 1 - powerRZ radix (Zsucc (- precision)))%R; [ intros H'4 | idtac ]. 2: apply Rplus_lt_reg_r with (powerRZ radix (Zsucc (- precision))). 2: ring_simplify. 2: replace 1%R with (powerRZ radix 0); [ auto with real zarith | simpl in |- *; auto ]. cut (0 < INR 4)%R; [ intros H'5 | auto with arith real ]. apply Rle_lt_trans with (/ (4%nat * (powerRZ radix precision - 1) * (1 + powerRZ radix (- precision))) * ((1 - powerRZ radix (Zsucc (- precision))) * Rabs (FtoRradix y)) + - (/ (4%nat * (powerRZ radix precision - 1) * (1 + powerRZ radix (- precision)) * (1 - powerRZ radix (- precision))) * ((1 - powerRZ radix (Zsucc (- precision))) * Rabs (FtoRradix a * FtoRradix x))) + - powerRZ radix (Zpred (Zpred (- dExp b))))%R; [ apply Rplus_le_compat_r | apply Rplus_lt_compat_l ]. apply Rplus_le_compat. repeat rewrite <- Rmult_assoc. apply Rmult_le_compat_r; auto with real. rewrite Rmult_assoc. ring_simplify ((powerRZ radix precision - 1) * (1 + powerRZ radix (- precision)))%R. rewrite <- powerRZ_add; auto with real zarith. replace (powerRZ radix (- precision + precision)) with 1%R; [ idtac | ring_simplify (- precision + precision)%Z; simpl in |- *; auto with real zarith ]. ring_simplify (-1 + (- powerRZ radix (- precision) + (powerRZ radix precision + 1)))%R. apply Rmult_le_compat_r; auto with real. apply Rle_trans with (/ (4%nat * powerRZ radix precision))%R; [ right | idtac ]. unfold Zpred in |- *. replace (- precision + -1 + -1)%Z with (- 2%nat + - precision)%Z; [ rewrite powerRZ_add | ring ]; auto with zarith real. rewrite Rinv_mult_distr; auto with real zarith. replace (powerRZ radix (- 2%nat)) with (/ 4%nat)%R. replace (/ powerRZ radix precision)%R with (powerRZ radix (- precision)); auto with real. apply powerRZ_Zopp; auto with zarith real. rewrite powerRZ_Zopp; auto with zarith real. replace (powerRZ radix 2%nat) with (INR 4); [ auto with zarith real | simpl in |- *; ring ]. apply Rle_Rinv; auto with real. apply Rlt_le_trans with (4%nat * (powerRZ radix precision - 1 + (1 - powerRZ radix (- precision))))%R. apply Rle_lt_trans with (4%nat * (0 + 0))%R; [ right; ring | auto with real ]. ring_simplify (precision+-precision)%Z; simpl; right;ring. apply Rmult_le_compat_l; auto with real zarith. ring_simplify (precision+-precision)%Z. apply Rle_trans with (powerRZ radix precision + - powerRZ radix (- precision))%R; [ right; simpl; ring | idtac ]; auto with real zarith. apply Rle_trans with (powerRZ radix precision + -0)%R; [ idtac | right; ring ]; auto with real zarith. apply Ropp_le_contravar. repeat rewrite <- Rmult_assoc. apply Rmult_le_compat_r; auto with real. unfold Zpred in |- *. replace (- precision + -1 + -1)%Z with (- 2%nat + - precision)%Z; [ rewrite powerRZ_add | ring ]; auto with zarith real. repeat rewrite Rmult_assoc; rewrite Rinv_mult_distr; auto with real zarith. 2: apply Rmult_integral_contrapositive; split; auto with real. replace (powerRZ radix (- 2%nat)) with (/ 4%nat)%R. 2: rewrite powerRZ_Zopp; auto with zarith real. 2: replace (powerRZ radix 2%nat) with (INR 4); [ auto with zarith real | simpl in |- *; ring ]. repeat rewrite Rmult_assoc; apply Rmult_le_compat_l; auto with real. apply Rmult_le_reg_l with ((powerRZ radix precision - 1) * ((1 + powerRZ radix (- precision)) * (1 - powerRZ radix (- precision))))%R; auto with real. apply Rmult_lt_0_compat; auto with real. apply Rmult_lt_0_compat; auto with real. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real. 2: apply Rmult_integral_contrapositive; split; auto with real. ring_simplify. repeat rewrite Ropp_mult_distr_l_reverse. repeat rewrite <- powerRZ_add; auto with real zarith. replace (powerRZ radix (precision + - precision)) with 1%R; [ idtac | ring_simplify ( precision +- precision)%Z; simpl in |- *; auto ]. ring_simplify ( precision + - precision + - precision + -precision)%Z. apply Rle_trans with (1 + (- powerRZ radix (- precision) + (- powerRZ radix (- precision) + 0)))%R; [ right | idtac ]. rewrite powerRZ_add; auto with real zarith; simpl; ring. ring_simplify (- precision + - precision + - precision)%Z. apply Rle_trans with (1 + (- powerRZ radix (- precision) + (- powerRZ radix (-2 * precision) + powerRZ radix (-3 * precision))))%R; [ idtac | right; ring ]. apply Rplus_le_compat_l; apply Rplus_le_compat_l. apply Rplus_le_compat; auto with real zarith. apply Ropp_lt_contravar. apply Rmult_lt_reg_l with (powerRZ radix (Z_of_nat 2 + dExp b)); auto with real zarith. rewrite <- Rmult_assoc; unfold Zpred in |- *. repeat rewrite <- powerRZ_add; auto with real zarith. replace (2%nat + dExp b + (- dExp b + -1 + -1))%Z with 0%Z by ring. replace (2%nat + dExp b + (- dExp b + -1))%Z with 1%Z by ring. replace (powerRZ radix 0) with 1%R; [ idtac | simpl in |- *; auto with real zarith ]. replace (powerRZ radix 1) with 2%R; [ idtac | simpl in |- *; ring; auto with real zarith ]. rewrite Rmult_plus_distr_l. apply Rlt_le_trans with (/ 3%nat + 2%nat * / 3%nat)%R. 2: simpl; right;field; auto with real. apply Rle_lt_trans with (/ 3%nat + 2 * (/ (4%nat * (powerRZ radix precision - 1) * (1 + powerRZ radix (- precision)) * (1 - powerRZ radix (- precision))) * (1 - powerRZ radix (- precision + 1))))%R; [ apply Rplus_le_compat_r | apply Rplus_lt_compat_l ]. rewrite Rinv_mult_distr; auto with arith real. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with arith real. rewrite Rmult_1_l; replace (INR 3) with (powerRZ radix 2%nat - 1)%R; auto with real zarith arith. apply Rle_Rinv; auto with real arith. replace 0%R with (powerRZ radix 0 - 1)%R; [ unfold Rminus in |- *; auto with real arith zarith | simpl in |- *; ring ]. unfold Rminus in |- *; auto with real arith zarith. apply Rplus_le_compat_r; apply Rle_powerRZ; auto with real arith zarith. simpl in |- *; ring; auto with arith zarith real. apply Rmult_lt_compat_l; auto with real arith. repeat rewrite Rinv_mult_distr; auto with real. 2: apply Rmult_integral_contrapositive; split; auto with real. apply Rle_lt_trans with (/ 4%nat * / (powerRZ radix 2%nat - 1) * / (1 + 0) * / (1 - powerRZ radix (- 2%nat)) * (1 - 0))%R. repeat rewrite Rmult_assoc. apply Rmult_le_compat_l; auto with real arith. apply Rmult_le_compat; auto with real arith zarith. apply Rmult_le_pos; auto with real. apply Rmult_le_pos; auto with real. apply Rle_Rinv; auto with real arith zarith. apply Rle_lt_trans with (powerRZ radix 0 - 1)%R; [ right; simpl in |- *; ring | auto with real arith zarith ]. unfold Rminus in |- *; apply Rplus_lt_compat_r; auto with real arith zarith. unfold Rminus in |- *; apply Rplus_le_compat_r; apply Rle_powerRZ; auto with real arith zarith. apply Rmult_le_compat; auto with real arith zarith. apply Rmult_le_pos; auto with real. apply Rmult_le_compat; auto with real arith zarith. apply Rle_Rinv; auto with real arith zarith. apply Rle_lt_trans with (1 - powerRZ radix 0)%R; [ simpl in |- *; right; ring | auto with real arith zarith ]. unfold Rminus in |- *; apply Rplus_lt_compat_l; apply Ropp_lt_contravar; auto with real arith zarith. unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_contravar; apply Rle_powerRZ; auto with real arith zarith. unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_contravar; auto with real arith zarith. ring_simplify (1 - 0)%R; rewrite Rmult_1_r. ring_simplify (1 + 0)%R; rewrite Rinv_1; rewrite Rmult_1_r. rewrite powerRZ_Zopp; auto with real arith zarith. replace (powerRZ radix 2%nat) with (INR 4); [ idtac | simpl in |- *; ring; auto with arith real zarith ]. replace (4%nat - 1)%R with (INR 3); [ idtac | simpl in |- *; ring; auto with arith real zarith ]. replace (1 - / 4%nat)%R with (3%nat * / 4%nat)%R. rewrite Rinv_mult_distr; auto with real arith zarith. rewrite Rinv_involutive; auto with real arith zarith. apply Rle_lt_trans with (4%nat * / 4%nat * (/ 3%nat * / 3%nat))%R; [ right; ring | idtac ]. rewrite Rinv_r; auto with real arith zarith; rewrite Rmult_1_l. apply Rlt_le_trans with (/ 3%nat * 1)%R; [ apply Rmult_lt_compat_l; auto with arith real zarith | right; ring ]. apply Rmult_lt_reg_l with (INR 3); auto with arith real. rewrite Rinv_r; auto with arith real; rewrite Rmult_1_r; auto with arith real. simpl; field; auto with real. Qed. End AxpyAux. Section Axpy. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Variable b : Fbound. Variable precision : nat. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Theorem Axpy_tFlessu : forall (a1 x1 y1 : R) (a x y t u : float), Fbounded b a -> Fbounded b x -> Fbounded b y -> Fbounded b t -> Fbounded b u -> Closest b radix (a * x) t -> Closest b radix (t + y) u -> Fcanonic radix b u -> Fcanonic radix b t -> (4%nat * Rabs t <= Rabs u)%R -> (Rabs (y1 - y) + Rabs (a1 * x1 - a * x) < / 4%nat * Fulp b radix precision (FLess b precision u))%R -> MinOrMax radix b (a1 * x1 + y1) u. intros a1 x1 y1 a x y t u Fa Fx Fy Ft Fu tDef uDef Cu Ct H1. unfold FLess in |- *; case (Rcase_abs (FtoR 2 u)); fold radix in |- *; intros H3 H2. 2: cut (0 <= u)%R; [ intros H'; case H'; intros H4; clear H' | auto with real ]. 2: apply AxpyPos with precision a x y t; auto. apply MinOrMax_Fopp. replace (- (a1 * x1 + y1))%R with (- a1 * x1 + - y1)%R; [ idtac | ring ]. apply AxpyPos with precision (Fopp a) x (Fopp y) (Fopp t); fold radix FtoRradix in |- *; auto with real float. replace (FtoRradix (Fopp a) * FtoRradix x)%R with (- (a * x))%R; [ apply ClosestOpp; auto | unfold FtoRradix in |- *; rewrite Fopp_correct; ring ]. replace (FtoRradix (Fopp t) + FtoRradix (Fopp y))%R with (- (t + y))%R; [ apply ClosestOpp; auto | unfold FtoRradix in |- *; repeat rewrite Fopp_correct; ring ]. unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real. unfold FtoRradix in |- *; repeat rewrite Fopp_correct; repeat rewrite Rabs_Ropp; auto with real. unfold FtoRradix in |- *; repeat rewrite Fopp_correct; rewrite <- (Rabs_Ropp (- a1 * x1 - - FtoR radix a * FtoR radix x)); auto with real. replace (- (- a1 * x1 - - FtoR radix a * FtoR radix x))%R with (a1 * x1 - FtoRradix a * FtoRradix x)%R; [ auto | unfold FtoRradix in |- *; ring ]. rewrite <- Rabs_Ropp. replace (- (- y1 - - FtoR radix y))%R with (y1 - FtoRradix y)%R; [ idtac | unfold FtoRradix in |- *; ring ]. rewrite FPredFopFSucc; auto with zarith; rewrite Fopp_Fopp; auto with zarith. replace (Fulp b radix precision (Fopp (FSucc b radix precision u))) with (Fulp b radix precision (FSucc b radix precision u)); auto. unfold Fulp in |- *; rewrite Fnormalize_Fopp; simpl in |- *; auto with real zarith. apply MinOrMax3 with precision; auto with zarith; fold FtoRradix in |- *. cut (FtoRradix t = 0%R); [ intros H' | idtac ]. cut (FtoRradix y = 0%R); [ intros H5 | idtac ]. replace (a1 * x1 + y1 - FtoRradix u)%R with (y1 - y + (a1 * x1 - a * x) + a * x)%R. 2: rewrite <- H4; rewrite H5; ring. apply Rle_lt_trans with (Rabs (y1 - FtoRradix y + (a1 * x1 - FtoRradix a * FtoRradix x)) + Rabs (FtoRradix a * FtoRradix x))%R; [ apply Rabs_triang | idtac ]. apply Rlt_le_trans with (/ 4%nat * Fulp b radix precision (FPred b radix precision u) + Rabs (FtoRradix a * FtoRradix x))%R; auto with real. apply Rplus_lt_compat_r; apply Rle_lt_trans with (2 := H2); apply Rabs_triang. apply Rle_trans with (/ 4%nat * Fulp b radix precision (FPred b radix precision u) + / 2%nat * Fulp b radix precision (FPred b radix precision u))%R; [ apply Rplus_le_compat_l | idtac ]. replace (FtoRradix a * FtoRradix x)%R with (FtoRradix a * FtoRradix x - t)%R; [ idtac | rewrite H'; ring ]. apply Rmult_le_reg_l with (INR 2); auto with real arith. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real arith. ring_simplify (1 * Fulp b radix precision (FPred b radix precision u))%R; apply Rle_trans with (Fulp b radix precision t). unfold FtoRradix in |- *; apply ClosestUlp; auto with zarith. unfold Fulp in |- *; apply Rle_powerRZ; auto with real zarith. replace (Fexp (Fnormalize radix b precision t)) with (- dExp b)%Z. cut (Fbounded b (Fnormalize radix b precision (FPred b radix precision u))); [ intros H6; elim H6; auto | apply FnormalizeBounded; auto with zarith ]. apply FBoundedPred; auto with zarith. replace (Fnormalize radix b precision t) with t. replace t with (Float 0 (- dExp b)); [ simpl in |- *; auto | idtac ]. apply FcanonicUnique with (radix := radix) (precision := precision) (b := b); auto with zarith. right; repeat (split; simpl in |- *; auto with zarith). fold FtoRradix in |- *; rewrite H'; unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. apply FcanonicUnique with (radix := radix) (precision := precision) (b := b); auto with zarith. apply FnormalizeCanonic; auto with zarith. apply sym_eq; apply FnormalizeCorrect; auto with zarith. apply Rle_trans with ((/ 4%nat + / 2%nat) * Fulp b radix precision (FPred b radix precision u))%R; [ right; ring | idtac ]. apply Rle_trans with (1 * Fulp b radix precision (FPred b radix precision u))%R; [ apply Rmult_le_compat_r | right; ring ]. unfold Fulp in |- *; auto with real zarith. apply Rmult_le_reg_l with (INR 4); auto with real arith. apply Rle_trans with 3%R;simpl;[right; field|idtac]. apply Rle_trans with (3+1)%R; auto with real; right; ring. cut (ProjectorP b radix (Closest b radix)); [ unfold ProjectorP in |- *; intros V | idtac ]. replace 0%R with (FtoRradix (Float 0 (- dExp b))); [ idtac | unfold FtoRradix, FtoR in |- *; simpl in |- *; ring ]. unfold FtoRradix in |- *; apply V; auto. replace (Float 0 (- dExp b)) with u; fold FtoRradix in |- *. replace (FtoRradix y) with (FtoRradix t + FtoRradix y)%R; auto. rewrite H'; ring. apply FcanonicUnique with (radix := radix) (precision := precision) (b := b); auto with zarith. right; repeat (split; simpl in |- *; auto with zarith). fold FtoRradix in |- *; rewrite <- H4; unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. apply RoundedProjector; auto. apply ClosestRoundedModeP with precision; auto with zarith. cut (forall z : R, (Rabs z <= 0)%R -> z = 0%R); [ intros V; apply V | idtac ]. apply Rmult_le_reg_l with (INR 4); auto with real arith. apply Rle_trans with (1 := H1); right; rewrite <- H4; auto with real. ring_simplify (4%nat*0)%R; apply Rabs_R0. intros z V; case (Req_dec 0 z); auto with real. intros V'; Contradict V. apply Rlt_not_le; apply Rabs_pos_lt; auto. Qed. Theorem Axpy_opt : forall (a1 x1 y1 : R) (a x y t u : float), (Fbounded b a) -> (Fbounded b x) -> (Fbounded b y) -> (Fbounded b t) -> (Fbounded b u) -> (Closest b radix (a * x) t) -> (Closest b radix (t + y) u) -> (Fcanonic radix b u) -> (Fcanonic radix b t) -> ((5%nat + 4%nat * (powerRZ radix (- precision))) * / (1 - powerRZ radix (- precision)) * (Rabs (a * x) + (powerRZ radix (Zpred (- dExp b)))) <= Rabs y)%R -> (Rabs (y1 - y) + Rabs (a1 * x1 - a * x) <= (powerRZ radix (Zpred (Zpred (- precision)))) * (1 - powerRZ radix (Zsucc (- precision))) * Rabs y + - (powerRZ radix (Zpred (Zpred (- precision))) * Rabs (a * x)) + - powerRZ radix (Zpred (Zpred (- dExp b))))%R -> (MinOrMax radix b (a1 * x1 + y1) u). intros a1 x1 y1 a x y t u Fa Fx Fy Ft Fu tDef uDef Cu Ct H1 H2. apply Axpy_tFlessu with a x y t; auto. cut (0 < 1 - powerRZ radix (- precision))%R; [ intros H'1 | idtac ]. 2: apply Rplus_lt_reg_r with (powerRZ radix (- precision)). 2: ring_simplify (powerRZ radix (- precision) + 0)%R. 2: ring_simplify (powerRZ radix (- precision) + (1 - powerRZ radix (- precision)))%R. 2: replace 1%R with (powerRZ radix 0); [ auto with real zarith | simpl in |- *; auto ]. cut (0 < 1 + powerRZ radix (- precision))%R; [ intros H'2 | idtac ]. 2: apply Rlt_le_trans with 1%R; auto with real. 2: apply Rle_trans with (1 + 0)%R; auto with real zarith. cut ((5%nat + 4%nat * powerRZ radix (- precision)) * Rabs t <= Rabs y)%R; [ intros H3 | idtac ]. apply Rplus_le_reg_l with (- Rabs (FtoRradix u))%R. ring_simplify (- Rabs (FtoRradix u) + Rabs (FtoRradix u))%R. apply Rle_trans with (- ((Rabs y + - Rabs t) * / (1 + powerRZ radix (- precision))) + 4%nat * Rabs (FtoRradix t))%R; [ apply Rplus_le_compat_r; apply Ropp_le_contravar | idtac ]. apply Rle_trans with (Rabs (FtoRradix y + FtoRradix t) * / (1 + powerRZ radix (- precision)))%R. apply Rmult_le_compat_r; auto with real zarith. rewrite <- (Rabs_Ropp (FtoRradix t)). apply Rle_trans with (Rabs (FtoRradix y) - Rabs (- FtoRradix t))%R; [ right; ring | idtac ]. replace (FtoRradix y + FtoRradix t)%R with (FtoRradix y - - FtoRradix t)%R; [ apply Rabs_triang_inv | ring ]. case Cu; intros H4. apply Rmult_le_reg_l with (1 + powerRZ radix (- precision))%R; auto. apply Rle_trans with (Rabs (FtoRradix y + FtoRradix t) * ((1 + powerRZ radix (- precision)) * / (1 + powerRZ radix (- precision))))%R; [ right; ring; ring | idtac ]. rewrite Rinv_r; auto with real. ring_simplify (Rabs (FtoRradix y + FtoRradix t) * 1)%R. rewrite Rmult_plus_distr_r. apply Rle_trans with (Rabs u + / radix * Fulp b radix precision u)%R. apply Rplus_le_reg_l with (- Rabs u)%R. apply Rle_trans with (/ radix * Fulp b radix precision u)%R; [idtac|right; ring]. apply Rle_trans with (Rabs (FtoRradix y + FtoRradix t - FtoRradix u)). apply Rle_trans with (Rabs (FtoRradix y + FtoRradix t) - Rabs (FtoRradix u))%R; [ right; ring | apply Rabs_triang_inv ]. apply Rmult_le_reg_l with (IZR radix); auto with real zarith. apply Rle_trans with (Fulp b radix precision u * (radix * / radix))%R; [ rewrite Rinv_r; auto with real zarith | right; ring ]. ring_simplify (Fulp b radix precision u * 1)%R. unfold FtoRradix in |- *; apply ClosestUlp; auto with real zarith. rewrite Rplus_comm; auto. ring_simplify (1*Rabs u)%R; apply Rplus_le_compat_l. apply Rmult_le_reg_l with (IZR radix); auto with real zarith. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real zarith. ring_simplify (1 * Fulp b radix precision u)%R. apply Rle_trans with (Rabs (FtoRradix u) * powerRZ radix (Zsucc (- precision)))%R. unfold FtoRradix in |- *; apply FulpLe2; auto with zarith. replace (Fnormalize radix b precision u) with u; [ idtac | apply FcanonicUnique with (radix := radix) (precision := precision) (b := b) ]; auto with zarith real. apply FnormalizeCanonic; auto with zarith. apply sym_eq; apply FnormalizeCorrect; auto with zarith. unfold Zsucc in |- *; rewrite powerRZ_add; auto with zarith real; simpl in |- *; auto with zarith real; right; ring. replace (FtoRradix y + FtoRradix t)%R with (FtoRradix u); auto with real. apply Rle_trans with (Rabs (FtoRradix u) * 1)%R; [ apply Rmult_le_compat_l | right; ring ]; auto with real. pattern 1%R at 2 in |- *; replace 1%R with (/ 1)%R; auto with real zarith. apply Rle_Rinv; auto with real zarith. pattern 1%R at 1 in |- *; replace 1%R with (1 + 0)%R; auto with real zarith. unfold FtoRradix in |- *; apply plusExact1 with b precision; auto with real zarith. rewrite Rplus_comm; auto. elim H4; intros H5 H6; elim H6; intros H7 H8; rewrite H7; apply Zmin_Zle; elim Fy; elim Ft; auto with zarith. apply Rle_trans with (((5%nat + 4%nat * powerRZ radix (- precision)) * Rabs (FtoRradix t) + - Rabs (FtoRradix y)) * / (1 + powerRZ radix (- precision)))%R. right; replace (INR 5) with (1 + 4%nat)%R; [ idtac | replace 1%R with (INR 1); [ rewrite <- plus_INR | idtac ]; auto with real arith ]. replace (4%nat * Rabs (FtoRradix t))%R with (4%nat * Rabs (FtoRradix t) * ((1 + powerRZ radix (- precision)) * / (1 + powerRZ radix (- precision))))%R. ring; ring. rewrite Rinv_r; auto with real; ring. apply Rle_trans with (0 * / (1 + powerRZ radix (- precision)))%R; [ apply Rmult_le_compat_r; auto with real | right; ring ]. apply Rplus_le_reg_l with (Rabs (FtoRradix y)). apply Rle_trans with ((5%nat + 4%nat * powerRZ radix (- precision)) * Rabs (FtoRradix t))%R; [ right; ring | ring_simplify (Rabs (FtoRradix y) + 0)%R ]; auto. apply Rle_trans with (2 := H1). rewrite Rmult_assoc. apply Rmult_le_compat_l; auto with real arith. apply Rle_trans with (5%nat + 4%nat * 0)%R; auto with real arith. ring_simplify (5%nat + 4%nat * 0)%R; auto with real arith. apply Rle_trans with (Rabs (FtoRradix a * FtoRradix x) * / (1 - powerRZ radix (- precision)) + powerRZ radix (Zpred (- dExp b)) * / (1 - powerRZ 2%Z (- precision)))%R; [ idtac | right; simpl; ring ]. unfold FtoRradix in |- *; apply RoundLeGeneral; auto with real zarith. apply Rle_lt_trans with (1 := H2). apply UlpFlessuGe2 with t; auto. Qed. Theorem Axpy_Simpl1 : forall (a1 x1 y1 : R) (a x y t u : float), 4 <= precision -> Fbounded b a -> Fbounded b x -> Fbounded b y -> Fbounded b t -> Fbounded b u -> Closest b radix (a * x) t -> Closest b radix (t + y) u -> Fcanonic radix b u -> Fcanonic radix b t -> (6%nat * (Rabs (a * x) + powerRZ radix (Zpred (- dExp b))) <= Rabs y)%R -> (Rabs (y1 - y) + Rabs (a1 * x1 - a * x) <= powerRZ radix (Zpred (Zpred (- precision))) * (1 - powerRZ radix (Zsucc (- precision))) * Rabs y + - (powerRZ radix (Zpred (Zpred (- precision))) * Rabs (a * x)) + - powerRZ radix (Zpred (Zpred (- dExp b))))%R -> MinOrMax radix b (a1 * x1 + y1) u. intros a1 x1 y1 a x y t u Enoughp Fa Fx Fy Ft Fu tDef uDef Cu Ct H1 H2. apply Axpy_opt with a x y t; auto. cut (0 < 1 - powerRZ radix (- precision))%R; [ intros H'1 | idtac ]. 2: apply Rplus_lt_reg_r with (powerRZ radix (- precision)). 2: ring_simplify (powerRZ radix (- precision) + 0)%R. 2: ring_simplify (powerRZ radix (- precision) + (1 - powerRZ radix (- precision)))%R. 2: replace 1%R with (powerRZ radix 0); [ auto with real zarith | simpl in |- *; auto ]. apply Rle_trans with (2 := H1). apply Rmult_le_compat_r. apply Rle_trans with (Rabs (FtoRradix a * FtoRradix x) + 0)%R; auto with real zarith. ring_simplify (Rabs (FtoRradix a * FtoRradix x) + 0)%R; auto with real. apply Rmult_le_reg_l with (1 - powerRZ radix (- precision))%R; auto. apply Rle_trans with ((5%nat + 4%nat * powerRZ radix (- precision)) * ((1 - powerRZ radix (- precision)) * / (1 - powerRZ radix (- precision))))%R; [ right; ring; ring | rewrite Rinv_r; auto with real ]. apply Rplus_le_reg_l with (- 5%nat + 6%nat * powerRZ radix (- precision))%R. simpl; ring_simplify. apply Rle_trans with (powerRZ radix 4%nat * powerRZ radix (- precision))%R; [ apply Rmult_le_compat_r; auto with real arith zarith | rewrite <- powerRZ_add; auto with real zarith ]. apply Rle_trans with (INR 10); [ right; simpl in |- *; ring | idtac ]. apply Rle_trans with (INR 16); [ idtac | right; simpl in |- *; ring ]. apply Rle_INR; auto with arith. apply Rle_trans with (powerRZ radix 0); [ idtac | right; simpl in |- *; ring ]. apply Rle_powerRZ; auto with zarith arith real. apply Zle_trans with (4-precision)%Z; auto with zarith. Qed. Theorem Axpy_Simpl1bis : forall (a1 x1 y1 : R) (a x y t u : float), 4 <= precision -> Fbounded b a -> Fbounded b x -> Fbounded b y -> Fbounded b t -> Fbounded b u -> Closest b radix (a * x) t -> Closest b radix (t + y) u -> Fcanonic radix b u -> Fcanonic radix b t -> (6%nat * (Rabs (a * x) + powerRZ radix (Zpred (- dExp b))) <= Rabs y)%R -> (Rabs (y1 - y) + Rabs (a1 * x1 - a * x) <= powerRZ radix (Zpred (Zpred (- precision))) * (5%nat * / 6%nat - powerRZ radix (Zsucc (- precision))) * Rabs y + - powerRZ radix (Zpred (Zpred (- dExp b))))%R -> MinOrMax radix b (a1 * x1 + y1) u. intros a1 x1 y1 a x y t u Enoughp Fa Fx Fy Ft Fu tDef uDef Cu Ct H1 H2. apply Axpy_Simpl1 with a x y t; auto. apply Rle_trans with (1 := H2). replace (5%nat * / 6%nat)%R with (1 - / 6%nat)%R. 2: apply Rmult_eq_reg_l with (INR 6); auto with arith real. 2: apply trans_eq with (6%nat - 6%nat * / 6%nat)%R; [ ring; ring | rewrite Rinv_r; auto with arith real ]. 2: apply trans_eq with (5%nat * (6%nat * / 6%nat))%R; [ rewrite Rinv_r; auto with arith real | ring ]; simpl in |- *; ring. apply Rplus_le_reg_l with (- (powerRZ radix (Zpred (Zpred (- precision))) * (1 - powerRZ radix (Zsucc (- precision))) * Rabs (FtoRradix y)))%R. ring_simplify. unfold Rminus;apply Rplus_le_compat_r. repeat rewrite Ropp_mult_distr_l_reverse; apply Ropp_le_contravar. rewrite Rmult_assoc; apply Rmult_le_compat_l; auto with real zarith. apply Rmult_le_reg_l with (INR 6); auto with arith real. apply Rle_trans with (Rabs (FtoRradix y) * (6%nat * / 6%nat))%R; [ rewrite Rinv_r; auto with arith real | right; ring ]. ring_simplify (Rabs (FtoRradix y) * 1)%R; apply Rle_trans with (2 := H1). apply Rle_trans with (6%nat * (Rabs (FtoRradix a * FtoRradix x) + 0))%R; auto with real zarith. Qed. Theorem Axpy_Simpl2 : forall (a1 x1 y1 : R) (a x y t u : float), 4 <= precision -> Fbounded b a -> Fbounded b x -> Fbounded b y -> Fbounded b t -> Fbounded b u -> Closest b radix (a * x) t -> Closest b radix (t + y) u -> Fcanonic radix b u -> Fcanonic radix b t -> (6%nat * (Rabs (a * x) + powerRZ radix (Zpred (- dExp b))) <= Rabs y)%R -> (Rabs (y1 - y) + Rabs (a1 * x1 - a * x) <= powerRZ radix (Zpred (Zpred (- precision))) * (2%nat * / 3%nat) * Rabs y + - powerRZ radix (Zpred (Zpred (- dExp b))))%R -> MinOrMax radix b (a1 * x1 + y1) u. intros a1 x1 y1 a x y t u Enoughp Fa Fx Fy Ft Fu tDef uDef Cu Ct H1 H2. apply Axpy_Simpl1bis with a x y t; auto. apply Rle_trans with (1 := H2). apply Rplus_le_compat_r; apply Rmult_le_compat_r; auto with real. apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (5%nat * / 6%nat - / 8%nat)%R. apply Rmult_le_reg_l with (6%nat * 8%nat)%R; [ apply Rmult_lt_0_compat; auto with real arith | idtac ]. apply Rle_trans with (6%nat * / 6%nat * (8%nat * 5%nat) - 8%nat * / 8%nat * 6%nat)%R; [ idtac | right; ring ]. pattern (INR 6) at 1 in |- *; replace (INR 6) with (2%nat * 3%nat)%R; [ idtac | rewrite <- mult_INR; auto with real arith ]. apply Rle_trans with (3%nat * / 3%nat * 8%nat * (2%nat * 2%nat))%R; [ right; ring | idtac ]. repeat rewrite Rinv_r; auto with real arith. apply Rle_trans with (INR 32);[simpl; right; ring|idtac]. apply Rle_trans with (INR 34);[auto with zarith real|simpl; right; ring]. unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_contravar. apply Rle_trans with (powerRZ radix (Zsucc (- 4%nat))); [ apply Rle_powerRZ; auto with real zarith | idtac ]. simpl; right; field; auto with real. Qed. End Axpy. Section AxpyFmac. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Variable b : Fbound. Variable precision : nat. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Theorem AxpyPos_Fmac : forall (a1 x1 y1 : R) (a x y u : float), Fbounded b a -> Fbounded b x -> Fbounded b y -> Fbounded b u -> Closest b radix (a * x + y) u -> Fcanonic radix b u -> (0 < u)%R -> (Rabs (y1 - y) + Rabs (a1 * x1 - a * x) < / 2%nat * Fulp b radix precision (FPred b radix precision u))%R -> MinOrMax radix b (a1 * x1 + y1) u. intros a1 x1 y1 a x y u Fa Fx Fy Fu uDef Cu Pu H. cut (Rabs (a1 * x1 + y1 - u) < / 2%nat * Fulp b radix precision (FPred b radix precision u) + Rabs (a * x + y - u))%R; [ intros H4 | idtac ]. case (Rle_or_lt (a * x + y) u); intros H5. apply MinOrMax1 with precision; auto with zarith arith. apply Rlt_le_trans with (1 := H4). replace 2%Z with radix; auto. apply Rplus_le_reg_l with (- (/ 2%nat * Fulp b radix precision (FPred b radix precision u)))%R. ring_simplify. apply Rle_trans with (/ 2%nat * Fulp b radix precision (FPred b radix precision u))%R; [ idtac | right ]. generalize uDef; unfold Closest in |- *; intros H6; elim H6; intros H7 H8; clear H6 H7. case (Rle_or_lt (Rabs (FtoRradix a * FtoRradix x + FtoRradix y - FtoRradix u)) (/ 2%nat * Fulp b radix precision (FPred b radix precision u))); auto; intros H6. cut (Rabs (FtoR radix u - (FtoRradix a * FtoRradix x + FtoRradix y)) <= Rabs (FtoR radix (FPred b radix precision u) - (FtoRradix a * FtoRradix x + FtoRradix y)))%R; [ intros H7 | apply H8 ]. 2: apply FBoundedPred; auto with zarith arith. Contradict H7; apply Rlt_not_le. apply Rlt_le_trans with (Rabs (FtoRradix a * FtoRradix x + FtoRradix y - FtoRradix u)). 2: right; rewrite <- Rabs_Ropp. 2: replace (- (FtoRradix a * FtoRradix x + FtoRradix y - FtoRradix u))%R with (FtoR radix u - (FtoRradix a * FtoRradix x + FtoRradix y))%R; auto with real; ring. apply Rle_lt_trans with (2 := H6). rewrite Faux.Rabsolu_left1. apply Rplus_le_reg_l with (u - (FtoRradix a * FtoRradix x + FtoRradix y) - / 2%nat * Fulp b radix precision (FPred b radix precision u))%R. ring_simplify. pattern (FtoRradix u) at 1 in |- *; replace (FtoRradix u) with (FtoRradix (FPred b radix precision u) + Fulp b radix precision (FPred b radix precision u))%R; [ idtac | unfold FtoRradix in |- *; apply FpredUlpPos; auto with zarith arith ]. apply Rle_trans with (Fulp b radix precision (FPred b radix precision u) - Fulp b radix precision (FPred b radix precision u) * / 2%nat)%R; [ right; fold FtoRradix; ring | idtac ]. apply Rle_trans with (/ 2%nat * Fulp b radix precision (FPred b radix precision u))%R. right; simpl; field. apply Rlt_le; apply Rlt_le_trans with (1 := H6). rewrite Faux.Rabsolu_left1; [ right; ring | idtac ]. apply Rplus_le_reg_l with (FtoRradix u). ring_simplify; auto with real. fold FtoRradix in |- *; apply Rplus_le_reg_l with (Fulp b radix precision (FPred b radix precision u)). apply Rle_trans with (FtoRradix (FPred b radix precision u) + Fulp b radix precision (FPred b radix precision u) + - (FtoRradix a * FtoRradix x + FtoRradix y))%R; [ right; ring | unfold FtoRradix in |- *; rewrite FpredUlpPos; auto with zarith arith ]. ring_simplify (Fulp b radix precision (FPred b radix precision u) + 0)%R. apply Rle_trans with (Rabs (FtoRradix u + - (FtoRradix a * FtoRradix x + FtoRradix y))). apply RRle_abs. rewrite <- Rabs_Ropp. replace (- (FtoRradix u + - (FtoRradix a * FtoRradix x + FtoRradix y)))%R with (FtoRradix a * FtoRradix x + FtoRradix y - FtoRradix u)%R; [ idtac | ring ]. apply Rmult_le_reg_l with (INR 2); auto with arith real. apply Rle_trans with (Fulp b radix precision u). unfold FtoRradix in |- *; apply ClosestUlp; auto with arith zarith. replace (INR 2) with (IZR radix); auto with zarith arith real. apply FulpFPredLe; auto with zarith. simpl; field. case (Rle_or_lt (a * x + y) (u + / 2%nat * Fulp b radix precision (FPred b radix precision u))); intros H6. apply MinOrMax1 with precision; auto with arith zarith real float. apply Rlt_le_trans with (1 := H4); rewrite Rabs_right. apply Rplus_le_reg_l with (u + - (/ 2%nat * Fulp b radix precision (FPred b radix precision u)))%R. ring_simplify. apply Rle_trans with (1 := H6). right; simpl; field. apply Rle_ge; apply Rplus_le_reg_l with (FtoRradix u); auto with real. apply MinOrMax2 with precision; auto with arith zarith float real. apply Rlt_le_trans with (1 := H4). apply Rle_trans with (/ 2%nat * Fulp b radix precision u + Rabs (FtoRradix a * FtoRradix x + FtoRradix y - FtoRradix u))%R; [ apply Rplus_le_compat_r | idtac ]. apply Rmult_le_compat_l; auto with real arith. apply FulpFPredGePos; auto with arith zarith. apply Rle_trans with (/ 2%nat * Fulp b radix precision u + / 2%nat * Fulp b radix precision u)%R; [ apply Rplus_le_compat_l | right ]. apply Rmult_le_reg_l with (INR 2); auto with real arith. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real arith. ring_simplify (1 * Fulp b radix precision u)%R. unfold FtoRradix in |- *; apply ClosestUlp; auto with real arith zarith float. apply trans_eq with ((/ 2%nat + / 2%nat) * Fulp b radix precision u)%R; [ ring | auto with real arith ]. replace (/ 2%nat + / 2%nat)%R with 1%R; [ ring | auto with real arith ]. rewrite <- (Rinv_r (INR 2)); auto with real arith; simpl in |- *; ring. replace 2%Z with radix; auto; fold FtoRradix in |- *; auto with real. apply Rlt_le; apply Rplus_lt_reg_r with (/ 2%nat * Fulp b radix precision (FPred b radix precision u))%R. rewrite Rplus_comm; apply Rlt_le_trans with (1 := H6). apply Rplus_le_reg_l with (- (a1 * x1 + y1))%R. ring_simplify (- (a1 * x1 + y1) + (/ 2%nat * Fulp b radix precision (FPred b radix precision u) + (a1 * x1 + y1)))%R. apply Rle_trans with (Rabs (- (a1 * x1 + y1) + (FtoRradix a * FtoRradix x + FtoRradix y))); [ apply RRle_abs | idtac ]. rewrite <- Rabs_Ropp. replace (- (- (a1 * x1 + y1) + (FtoRradix a * FtoRradix x + FtoRradix y)))%R with (y1 - FtoRradix y + (a1 * x1 - FtoRradix a * FtoRradix x))%R; [ auto with real | ring ]. apply Rle_trans with (Rabs (y1 - FtoRradix y) + Rabs (a1 * x1 - FtoRradix a * FtoRradix x))%R; [ apply Rabs_triang | auto with real ]. replace (a1 * x1 + y1 - FtoRradix u)%R with (y1 - y + (a1 * x1 - a * x) + (a * x + y - u))%R; [ idtac | ring ]. apply Rle_lt_trans with (Rabs (y1 - FtoRradix y + (a1 * x1 - FtoRradix a * FtoRradix x)) + Rabs (FtoRradix a * FtoRradix x + FtoRradix y - FtoRradix u))%R; [ apply Rabs_triang | idtac ]. apply Rplus_lt_compat_r; auto. apply Rle_lt_trans with (2 := H); apply Rabs_triang. Qed. Theorem AxpyFLessu_Fmac : forall (a1 x1 y1 : R) (a x y u : float), Fbounded b a -> Fbounded b x -> Fbounded b y -> Fbounded b u -> Closest b radix (a * x + y) u -> Fcanonic radix b u -> (Rabs (y1 - y) + Rabs (a1 * x1 - a * x) < / 2%nat * Fulp b radix precision (FLess b precision u))%R -> MinOrMax radix b (a1 * x1 + y1) u. intros a1 x1 y1 a x y u Fa Fx Fy Fu uDef Cu. unfold FLess in |- *; case (Rcase_abs (FtoR 2 u)); fold radix in |- *; intros H3 H2. 2: cut (0 <= u)%R; [ intros H'; case H'; intros H4; clear H' | auto with real ]. 2: apply AxpyPos_Fmac with a x y; auto. apply MinOrMax_Fopp. replace (- (a1 * x1 + y1))%R with (- a1 * x1 + - y1)%R; [ idtac | ring ]. apply AxpyPos_Fmac with (Fopp a) x (Fopp y); fold radix FtoRradix in |- *; auto with real float. replace (FtoRradix (Fopp a) * FtoRradix x + FtoRradix (Fopp y))%R with (- (a * x + y))%R; [ apply ClosestOpp; auto | unfold FtoRradix in |- *; repeat rewrite Fopp_correct;ring ]. unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real. unfold FtoRradix in |- *; repeat rewrite Fopp_correct; auto with real. rewrite <- Rabs_Ropp; rewrite <- (Rabs_Ropp (- a1 * x1 - - FtoR radix a * FtoR radix x)). replace (- (- y1 - - FtoR radix y))%R with (y1 - FtoRradix y)%R; [ idtac | fold FtoRradix; ring ]. replace (- (- a1 * x1 - - FtoR radix a * FtoR radix x))%R with (a1 * x1 - FtoRradix a * FtoRradix x)%R; [ auto | unfold FtoRradix in |- *; ring ]. rewrite FPredFopFSucc; auto with zarith; rewrite Fopp_Fopp; auto with zarith. replace (Fulp b radix precision (Fopp (FSucc b radix precision u))) with (Fulp b radix precision (FSucc b radix precision u)); auto. unfold Fulp in |- *; rewrite Fnormalize_Fopp; simpl in |- *; auto with real zarith. apply MinOrMax3 with precision; auto with zarith. cut (u = Float 0 (- dExp b)); [ intros H1 | idtac ]. 2: apply FcanonicUnique with (radix := radix) (precision := precision) (b := b); auto with zarith. 2: right; repeat (split; simpl in |- *; auto with zarith). 2: fold FtoRradix in |- *; rewrite <- H4; unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. replace 2%Z with radix; auto; fold FtoRradix in |- *. replace (a1 * x1 + y1 - FtoRradix u)%R with (y1 - y + (a1 * x1 - a * x) + (FtoRradix a * FtoRradix x + FtoRradix y - u))%R; [ idtac | ring ]. apply Rle_lt_trans with (Rabs (y1 - FtoRradix y + (a1 * x1 - FtoRradix a * FtoRradix x)) + Rabs (FtoRradix a * FtoRradix x + FtoRradix y - FtoRradix u))%R; [ apply Rabs_triang | idtac ]. apply Rlt_le_trans with (/ 2%nat * Fulp b radix precision (FPred b radix precision u) + Rabs (FtoRradix a * FtoRradix x + FtoRradix y - FtoRradix u))%R. apply Rplus_lt_compat_r; auto. apply Rle_lt_trans with (2 := H2); apply Rabs_triang. apply Rle_trans with (/ 2%nat * Fulp b radix precision (FPred b radix precision u) + / 2%nat * Fulp b radix precision u)%R. apply Rplus_le_compat_l. apply Rmult_le_reg_l with (INR 2); auto with real arith. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real arith. ring_simplify (1 * Fulp b radix precision u)%R. unfold FtoRradix in |- *; apply ClosestUlp; auto with zarith. unfold Fulp in |- *. repeat rewrite FcanonicFnormalizeEq; auto with zarith float. rewrite H1; rewrite FPredSimpl4; auto with zarith; simpl in |- *. 2: cut (0 < pPred (vNum b))%Z; [ idtac | apply pPredMoreThanOne with radix precision ]; auto with zarith. 2: cut (0 < nNormMin radix precision)%Z; [ idtac | apply nNormPos ]; auto with zarith. right; apply trans_eq with ((/ 2 + / 2) * powerRZ 2 (- dExp b))%R; [ ring | idtac ]. replace (/ 2 + / 2)%R with 1%R; [ ring | idtac ]. field; auto with real. Qed. Theorem Axpy_opt_Fmac : forall (a1 x1 y1 : R) (a x y u : float), (Fbounded b a) -> (Fbounded b x) -> (Fbounded b y) -> (Fbounded b u) -> (Closest b radix (a * x + y) u) -> (Fcanonic radix b u) -> (Rabs (y1 - y) + Rabs (a1 * x1 - a * x) < (Rabs (a * x + y)) * (powerRZ radix (Zpred (- precision)) * (1 - powerRZ radix (Zsucc (- precision)))) - powerRZ radix (Zpred (Zpred (- dExp b))) * (3 * / (powerRZ radix precision - powerRZ radix (- precision))))%R -> (MinOrMax radix b (a1 * x1 + y1) u). intros a1 x1 y1 a x y u Fa Fx Fy Fu uDef Cu H. apply AxpyFLessu_Fmac with a x y; auto. cut (0 < powerRZ radix precision - 1)%R; [ intros H'1 | idtac ]. 2: apply Rplus_lt_reg_r with 1%R. 2: ring_simplify. 2: replace 1%R with (powerRZ radix 0); [ idtac | simpl in |- * ]; auto with real zarith. cut (0 < powerRZ radix precision - powerRZ radix (- precision))%R; [ intros H'2 | idtac ]. 2: apply Rplus_lt_reg_r with (powerRZ radix (- precision)). 2: ring_simplify; auto with real zarith. apply Rlt_le_trans with (1 := H). apply Rle_trans with (/ 2%nat * (/ (powerRZ radix precision - 1) * (Rabs u * (1 - powerRZ radix (Zsucc (- precision))) - powerRZ radix (- dExp b))))%R. apply Rle_trans with (/ 2%nat * (/ (powerRZ radix precision - 1) * ((Rabs (a * x + y) * / (1 + powerRZ radix (- precision)) - powerRZ radix (Zpred (- dExp b)) * / (1 + powerRZ radix (- precision))) * (1 - powerRZ radix (Zsucc (- precision))) - powerRZ radix (- dExp b))))%R. apply Rle_trans with (/ 2%nat * (/ (powerRZ radix precision - 1) * (Rabs (FtoRradix a * FtoRradix x + FtoRradix y) * / (1 + powerRZ radix (- precision)) * (1 - powerRZ radix (Zsucc (- precision))))) - (/ 2%nat * (/ (powerRZ radix precision - 1) * ((1 - powerRZ radix (Zsucc (- precision))) * (powerRZ radix (Zpred (- dExp b)) * / (1 + powerRZ radix (- precision))))) + / 2%nat * (/ (powerRZ radix precision - 1) * powerRZ radix (- dExp b))))%R; [ idtac | right; ring; ring ]. apply Rle_trans with (/ 2%nat * (/ (powerRZ radix precision - 1) * (Rabs (FtoRradix a * FtoRradix x + FtoRradix y) * / (1 + powerRZ radix (- precision)) * (1 - powerRZ radix (Zsucc (- precision))))) - powerRZ radix (Zpred (Zpred (- dExp b))) * (3 * / (powerRZ radix precision - powerRZ radix (- precision))))%R; unfold Rminus in |- *; [ apply Rplus_le_compat_r | apply Rplus_le_compat_l ]. apply Rle_trans with (Rabs (FtoRradix a * FtoRradix x + FtoRradix y) * (/ 2%nat * (/ (powerRZ radix precision + -1) * (/ (1 + powerRZ radix (- precision)) * (1 + - powerRZ radix (Zsucc (- precision)))))))%R; [ idtac | right; ring ]. apply Rmult_le_compat_l; auto with real. apply Rle_trans with (/ 2%nat * (/ (powerRZ radix precision + -1) * / (1 + powerRZ radix (- precision))) * (1 + - powerRZ radix (Zsucc (- precision))))%R; [ idtac | right; ring ]. apply Rmult_le_compat_r; auto with real zarith. apply Rplus_le_reg_l with (powerRZ radix (Zsucc (- precision))). ring_simplify. replace 1%R with (powerRZ radix 0); auto with real zarith. replace (Zpred (- precision)) with (- Zsucc precision)%Z; [ idtac | unfold Zsucc, Zpred in |- *; ring ]. rewrite <- Rinv_powerRZ; auto with real zarith. rewrite <- Rinv_mult_distr; auto with real zarith. rewrite <- Rinv_mult_distr; auto with real zarith. apply Rle_Rinv; auto with real zarith. apply Rmult_lt_0_compat; auto with real arith zarith. apply Rmult_lt_0_compat; auto with real arith zarith. apply Rlt_le_trans with (1 + 0)%R; auto with real arith zarith. ring_simplify (1 + 0)%R; auto with real. replace (INR 2) with (powerRZ radix 1); auto with real zarith. ring_simplify (powerRZ radix 1 * ((powerRZ radix precision + -1) * (1 + powerRZ radix (- precision))))%R. repeat rewrite <- powerRZ_add; auto with zarith real. ring_simplify (1+ precision + -precision)%Z. apply Rle_trans with (powerRZ radix (precision + 1) + - powerRZ radix (- precision + 1))%R; [ right | idtac ]; auto with real zarith. unfold Zminus; rewrite Zplus_comm; rewrite Zplus_comm with (n:=(-precision)%Z); ring. apply Rle_trans with (powerRZ radix (precision + 1) + -0)%R; auto with real zarith. right;ring. apply Rmult_integral_contrapositive; split; auto with real zarith. apply not_eq_sym; apply Rlt_not_eq; auto with real zarith. apply Rlt_le_trans with (1 + 0)%R; [ ring_simplify (1 + 0)%R; auto with real | auto with real zarith ]. apply not_eq_sym; apply Rlt_not_eq; auto with real zarith. apply Rlt_le_trans with (1 + 0)%R; [ ring_simplify (1 + 0)%R; auto with real | auto with real zarith ]. apply Ropp_le_contravar. replace (powerRZ radix precision + -1)%R with (powerRZ radix precision - 1)%R; [ idtac | ring ]. replace (powerRZ radix precision + - powerRZ radix (- precision))%R with (powerRZ radix precision - powerRZ radix (- precision))%R; [ idtac | ring ]. cut (0 < 1 + powerRZ radix (- precision))%R; [ intros H'3 | idtac ]. 2: apply Rlt_le_trans with (1 + 0)%R; [ ring_simplify (1 + 0)%R; auto with real | auto with real zarith ]. apply Rmult_le_reg_l with (powerRZ radix precision - 1)%R; auto with real. apply Rle_trans with (/ 2%nat * ((powerRZ radix precision - 1) * / (powerRZ radix precision - 1) * ((1 + - powerRZ radix (Zsucc (- precision))) * (powerRZ radix (Zpred (- dExp b)) * / (1 + powerRZ radix (- precision))))) + / 2%nat * ((powerRZ radix precision - 1) * / (powerRZ radix precision - 1) * powerRZ radix (- dExp b)))%R; [ right; ring | idtac ]. repeat rewrite Rinv_r; auto with real. apply Rmult_le_reg_l with (1 + powerRZ radix (- precision))%R; auto with real. apply Rle_trans with (/ 2%nat * ((1 + - powerRZ radix (Zsucc (- precision))) * (powerRZ radix (Zpred (- dExp b)) * ((1 + powerRZ radix (- precision)) * / (1 + powerRZ radix (- precision))))) + / 2%nat * ((1 + powerRZ radix (- precision)) * powerRZ radix (- dExp b)))%R; [ right; ring; ring | idtac ]. rewrite Rinv_r; auto with real. apply Rle_trans with (powerRZ radix (Zpred (Zpred (- dExp b))) * (3 * ((1 + powerRZ radix (- precision)) * (powerRZ radix precision - 1) * / (powerRZ radix precision - powerRZ radix (- precision)))))%R; [ idtac | right; ring ]. replace ((1 + powerRZ radix (- precision)) * (powerRZ radix precision - 1))%R with (powerRZ radix precision - powerRZ radix (- precision))%R. rewrite Rinv_r; auto with real. right; unfold Zsucc, Zpred in |- *. repeat rewrite powerRZ_add; auto with real zarith. replace (powerRZ radix (-1)) with (/ 2%nat)%R; [ idtac | simpl in |- *; auto with real zarith ]. simpl; field. ring_simplify; repeat rewrite <- powerRZ_add; auto with real zarith. ring_simplify (precision + - precision)%Z; simpl in |- *; ring. apply Rmult_le_compat_l; auto with real arith. apply Rmult_le_compat_l; auto with real arith. unfold Rminus in |- *; apply Rplus_le_compat_r. apply Rmult_le_compat_r; auto with real. apply Rplus_le_reg_l with (powerRZ radix (Zsucc (- precision))). ring_simplify. replace 1%R with (powerRZ radix 0); auto with real zarith. fold (Rabs (FtoRradix a * FtoRradix x + FtoRradix y) * / (1 + powerRZ radix (- precision)) - powerRZ radix (Zpred (- dExp b)) * / (1 + powerRZ radix (- precision)))%R in |- *. unfold FtoRradix in |- *; apply RoundGeGeneral; auto. apply Rmult_le_compat_l; auto with real arith. apply Rle_trans with (/ (powerRZ radix precision - 1) * (Rabs (FtoRradix u) - Fulp b radix precision u))%R. apply Rmult_le_compat_l; auto with real arith. apply Rplus_le_reg_l with (Fulp b radix precision u + - (Rabs (FtoRradix u) * (1 - powerRZ radix (Zsucc (- precision))) - powerRZ radix (- dExp b)))%R. ring_simplify. apply FulpLeGeneral; auto. apply Rle_trans with (/ (powerRZ radix precision - 1) * Rabs (FLess b precision u))%R. apply Rmult_le_compat_l; auto with real arith. unfold FtoRradix in |- *; apply UlpFlessuGe_aux; auto. apply Rmult_le_reg_l with (powerRZ radix precision - 1)%R; auto with real. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real. ring_simplify (1 * Rabs (FtoRradix (FLess b precision u)))%R. unfold FtoRradix in |- *; apply FulpGe; auto with zarith. unfold FLess in |- *; case Rcase_abs; intros H3; auto with float zarith. Qed. End AxpyFmac.Float8.4/FnElem/DoubleRound.v0000644000423700002640000001303612032774527015634 0ustar sboldotoccata(**************************************************************************** IEEE754 : DoubleRound Sylvie Boldo ****************************************************************************) Require Export MinOrMax. Section MOMR. Variables b1 b2 : Fbound. Variable radix : Z. Variables prec1 prec2 : nat. Coercion Local FtoRradix := FtoR radix. Hypothesis radixMoreThanOne : (1 < radix)%Z. Hypothesis prec1GreaterThanOne : 1 < prec1. Hypothesis prec2GreaterThanOne : 1 < prec2. Hypothesis p1GivesBound : Zpos (vNum b1) = Zpower_nat radix prec1. Hypothesis p2GivesBound : Zpos (vNum b2) = Zpower_nat radix prec2. Theorem BoundedBounded : forall f : float, prec2 <= prec1 -> (prec1 - prec2 <= dExp b1 - dExp b2)%Z -> Fbounded b2 f -> Fbounded b1 f. intros f H1 H2 H3. repeat (split; auto with zarith). apply Zlt_le_trans with (Zpos (vNum b2)); auto with zarith float. rewrite p2GivesBound; rewrite p1GivesBound; auto with zarith arith. apply Zle_trans with (- dExp b2)%Z; auto with zarith float. Qed. Theorem DblRndStable : forall (z : R) (p q : float), prec2 <= prec1 -> (prec1 - prec2 <= dExp b1 - dExp b2)%Z -> Fbounded b1 p -> Fbounded b2 q -> MinOrMax radix b1 z p -> MinOrMax radix b2 p q -> MinOrMax radix b2 z q. intros z p q H H' Fp Fq H1 H2. case (Rle_or_lt q z); intros H3. left; red in |- *; split; auto; split; auto with real float. intros f Ff H4. case H2; intros H7; elim H7; intros H5 H6; elim H6; clear H2 H5 H6; intros H5 H6; case H1; intros H10; elim H10; intros H8 H9; elim H9; clear H9 H8 H1; intros H8 H9. apply H6; auto; apply H9; auto; apply BoundedBounded; auto. apply H6; auto; apply Rle_trans with z; auto with real. apply Rle_trans with (FtoRradix p); auto with real; apply H9; auto; apply BoundedBounded; auto. apply Rle_trans with z; auto with real; apply Rle_trans with (FtoRradix p); auto with real. right; red in |- *; split; auto; split; auto with real float. intros f Ff H4. case H2; intros H7; elim H7; intros H5 H6; elim H6; clear H2 H5 H6; intros H5 H6; case H1; intros H10; elim H10; intros H8 H9; elim H9; clear H9 H8 H1; intros H8 H9. apply Rle_trans with z; auto with real; apply Rle_trans with (FtoRradix p); auto with real. apply Rle_trans with (FtoRradix p); auto with real; apply H9; auto; apply BoundedBounded; auto. apply H6; auto; apply Rle_trans with z; auto with real. apply H6; auto; apply H9; auto; apply BoundedBounded; auto. Qed. Theorem DoubleRound2 : forall (z : R) (p q : float), prec2 <= prec1 -> (prec1 - prec2 = dExp b1 - dExp b2)%Z -> Fbounded b1 p -> Fbounded b2 q -> MinOrMax radix b1 z p -> Closest b2 radix p q -> (Rabs (z - q) < Fulp b2 radix prec2 q * (/ 2%nat + powerRZ radix (Zsucc (prec2 - prec1))))%R. intros z p q Hp He Fp Fq H1 H2. replace (z - FtoRradix q)%R with (z - p + (p - q))%R; [ idtac | ring ]. apply Rle_lt_trans with (Rabs (z - p) + Rabs (p - q))%R; [ apply Rabs_triang | idtac ]. apply Rle_lt_trans with (Rabs (z - FtoRradix p) + / 2%nat * Fulp b2 radix prec2 q)%R; [ apply Rplus_le_compat_l | idtac ]. apply Rmult_le_reg_l with (INR 2); auto with real arith. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real arith. ring_simplify (1 * Fulp b2 radix prec2 q)%R; unfold FtoRradix in |- *; apply ClosestUlp; auto. ring_simplify (Fulp b2 radix prec2 q * (/ 2%nat + powerRZ radix (Zsucc (prec2 - prec1))))%R. rewrite Rplus_comm; rewrite Rmult_comm;apply Rplus_lt_compat_l. apply Rlt_le_trans with (Fulp b1 radix prec1 p). unfold FtoRradix in |- *; apply MinOrMax_Rlt; auto with zarith. cut (Fcanonic radix b1 (Fnormalize radix b1 prec1 p)); [ intros H3 | apply FnormalizeCanonic; auto with arith ]. case H3; intros H4. apply Rle_trans with (Rabs (FtoR radix p) * powerRZ radix (Zsucc (- prec1)))%R. apply FulpLe2; auto. replace (Zsucc (prec2 - prec1)) with (Zsucc (- prec1) + prec2)%Z; [ rewrite powerRZ_add; auto with zarith real | unfold Zsucc in |- *; ring ]. apply Rle_trans with ((Fulp b2 radix prec2 q *powerRZ radix prec2)* powerRZ radix (Zsucc (- prec1)))%R;[idtac|right; ring]. apply Rmult_le_compat_r; auto with real zarith. fold FtoRradix in |- *; replace (FtoRradix p) with (FtoRradix q + (FtoRradix p - FtoRradix q))%R; [ idtac | ring ]. apply Rle_trans with (Rabs (FtoRradix q) + Rabs (FtoRradix p - FtoRradix q))%R; [ apply Rabs_triang | idtac ]. apply Rle_trans with ((powerRZ radix prec2 - 1) * Fulp b2 radix prec2 q + Fulp b2 radix prec2 q)%R; [ apply Rplus_le_compat | right; ring ]. unfold FtoRradix in |- *; apply FulpGe; auto. unfold FtoRradix in |- *; apply Rlt_le; apply RoundedModeUlp with (Closest b2 radix); auto. apply ClosestRoundedModeP with prec2; auto. elim H4; intros H5 H6; elim H6; intros H7 H8; clear H6. unfold Fulp in |- *; rewrite H7. apply Rle_trans with (powerRZ radix (prec2 - prec1) * powerRZ radix (- dExp b2))%R. rewrite <- powerRZ_add; auto with zarith real. apply Rle_powerRZ; auto with zarith real. replace (prec2 - prec1)%Z with (- (prec1 - prec2))%Z; [ rewrite He; auto with zarith | ring ]. apply Rle_trans with (powerRZ radix (- (dExp b1 - dExp b2)) * powerRZ radix (Fexp (Fnormalize radix b2 prec2 q)))%R; [ apply Rmult_le_compat_l | rewrite Rmult_comm;apply Rmult_le_compat_l ]; auto with zarith real. apply Rle_powerRZ; auto with real zarith float. Qed. End MOMR. Float8.4/FnElem/FArgReduct.v0000644000423700002640000007573012032774527015411 0ustar sboldotoccata(** IEEE754 : FArgReduct Sylvie Boldo *) Require Export FnormI. Require Export Classical. Section SterbenzApprox. Variable radix : Z. Hypothesis radixMoreThanOne : (1 < radix)%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Variables (b1 : Fbound) (b2 : Fbound). Variables (prec1 : nat) (prec2 : nat). Hypothesis prec1MoreThanOne : 1 < prec1. Hypothesis p1GivesBound : Zpos (vNum b1) = Zpower_nat radix prec1. Hypothesis prec2MoreThanOne : 1 < prec2. Hypothesis p2GivesBound : Zpos (vNum b2) = Zpower_nat radix prec2. Theorem Rmin_1 : forall x y : R, (x <= y)%R -> Rmin x y = x. intros x y H; unfold Rmin in |- *. case (Rle_dec x y); auto with real. Qed. Theorem Rmin_2 : forall x y : R, (y <= x)%R -> Rmin x y = y. intros x y H; unfold Rmin in |- *. case (Rle_dec x y); auto with real. Qed. Theorem Rmin_eq : forall x : R, Rmin x x = x. intros x; unfold Rmin in |- *. case (Rle_dec x x); auto with real. Qed. Theorem Rdiv_Rle : forall a b c d : R, (0 < a)%R -> (0 < b)%R -> (0 < c)%R -> (0 < d)%R -> (a <= c)%R -> (d <= b)%R -> (a / b <= c / d)%R. intros a b c d Ha Hb Hc Hd H1 H2; unfold Rdiv in |- *. apply Rle_trans with (c * / b)%R; auto with real. apply Rmult_le_compat_l; auto with real. apply Rle_Rinv; auto with real. Qed. Theorem SterbenzApprox : forall (rho : R) (x y : float), (0 < rho)%R -> IZR (Zpos (vNum b1)) = (rho * Zsucc (Zpos (vNum b2)))%R -> (- dExp b2 <= - dExp b1)%Z -> Fbounded b1 x -> Fbounded b1 y -> (/ (1 + / rho) * y <= x)%R -> (x <= (1 + / rho) * y)%R -> exists u : float, u = (x - y)%R :>R /\ Fbounded b2 u. intros rho x y Hrho Hrho' Hv0 Fx Fy H1 H2. cut (forall b : Fbound, Z_of_nat (vNumInf (BoundI (pred (nat_of_P (vNum b))) (nat_of_P (vNum b)) (Zabs_nat (dExp b)))) = Zpred (Zpos (vNum b))); [ intros V1 | idtac ]. 2: intros b; apply trans_eq with (Z_of_nat (pred (nat_of_P (vNum b)))); [ simpl in |- *; auto | idtac ]. 2: apply trans_eq with (Zpred (nat_of_P (vNum b))); [ apply inj_pred; auto with zarith | idtac ]. 2: rewrite inject_nat_convert with (Zpos (vNum b)) (vNum b); auto with zarith arith. cut (forall b : Fbound, Z_of_nat (vNumSup (BoundI (pred (nat_of_P (vNum b))) (nat_of_P (vNum b)) (Zabs_nat (dExp b)))) = Zpos (vNum b)); [ intros V2 | idtac ]. 2: intros b; apply trans_eq with (Z_of_nat (nat_of_P (vNum b))); [ simpl in |- *; auto | idtac ]. 2: apply inject_nat_convert; auto with zarith arith. elim SterbenzApproxI_pos with radix (BoundI (pred (nat_of_P (vNum b1))) (nat_of_P (vNum b1)) (Zabs_nat (dExp b1))) (BoundI (pred (nat_of_P (vNum b2))) (nat_of_P (vNum b2)) (Zabs_nat (dExp b2))) rho x y; auto with real zarith. 2: rewrite (V1 b1); rewrite (V1 b2); rewrite (V2 b1); rewrite (V2 b2). 2: repeat rewrite <- Zsucc_pred. 2: rewrite Rmin_1 with (x := (Zpos (vNum b1) / Zsucc (Zpos (vNum b2)))%R); [ idtac | apply Rdiv_Rle; auto with real zarith ]. 2: rewrite Rmin_2; [ rewrite Hrho' | idtac ]. 2: unfold Rdiv in |- *; rewrite Rmult_assoc; rewrite Rinv_r; auto with real zarith arith. 2: case (Rle_or_lt (Zpos (vNum b1) / Zpos (vNum b2)) (Zsucc (Zpos (vNum b1)) / Zsucc (Zpos (vNum b2)))); intros H. 2: rewrite Rmin_1; auto with real; apply Rdiv_Rle; auto with real zarith. 2: rewrite Rmin_2; auto with real; apply Rdiv_Rle; auto with real zarith. 2: simpl; repeat rewrite <- Zabs_absolu. 2: repeat rewrite Zabs_eq; auto with zarith. 2: case (dExp b1); auto with zarith. 2: case (dExp b2); auto with zarith. 2: intros z Hz. 2: apply FoppBoundedI2 with (Zabs_nat (Zpower_nat radix (pred prec2))); auto with zarith. 2: rewrite (V1 b2); rewrite p2GivesBound; rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith arith. 2: replace (radix * Zpower_nat radix (pred prec2))%Z with (Zpower_nat radix prec2); auto with zarith arith. 2: pattern prec2 at 1 in |- *; replace prec2 with (1 + pred prec2); auto with zarith arith. 2: rewrite (V2 b2); rewrite p2GivesBound; rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith arith. 2: pattern prec2 at 1 in |- *; replace prec2 with (1 + pred prec2); auto with zarith arith. 2: intros z Hz. 2: apply FoppBoundedI2 with (Zabs_nat (Zpower_nat radix (pred prec1))); auto with zarith. 2: rewrite (V1 b1); rewrite p1GivesBound; rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith arith. 2: replace (radix * Zpower_nat radix (pred prec1))%Z with (Zpower_nat radix prec1); auto with zarith arith. 2: pattern prec1 at 1 in |- *; replace prec1 with (1 + pred prec1); auto with zarith arith. 2: rewrite (V2 b1); rewrite p1GivesBound; rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith arith. 2: pattern prec1 at 1 in |- *; replace prec1 with (1 + pred prec1); auto with zarith arith. 2: split; simpl in |- *; auto with zarith float. 2: split. 2: apply Zle_Zopp_Inv; rewrite Zopp_involutive; apply Zle_trans with (Zabs (Fnum x)). 2: apply Zle_trans with (Zabs (- Fnum x)); auto with zarith. 2: rewrite Zabs_Zopp; auto with zarith. 2: rewrite inj_pred; auto with float zarith arith. 2: rewrite inject_nat_convert with (Zpos (vNum b1)) (vNum b1); auto with zarith float. 2: apply Zle_trans with (Zabs (Fnum x)); auto with zarith float. 2: rewrite inject_nat_convert with (Zpos (vNum b1)) (vNum b1); auto with zarith float. 2: rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith float. 2: case (dExp b1); auto with zarith. 2: split; simpl in |- *; auto with zarith arith float. 2: split. 2: apply Zle_Zopp_Inv; rewrite Zopp_involutive; apply Zle_trans with (Zabs (Fnum y)). 2: apply Zle_trans with (Zabs (- Fnum y)); auto with zarith float. 2: rewrite Zabs_Zopp; auto with zarith. 2: rewrite inj_pred; auto with float zarith arith. 2: rewrite inject_nat_convert with (Zpos (vNum b1)) (vNum b1); auto with zarith float. 2: apply Zle_trans with (Zabs (Fnum y)); auto with zarith float. 2: rewrite inject_nat_convert with (Zpos (vNum b1)) (vNum b1); auto with zarith float. 2: rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith float. 2: case (dExp b1); auto with zarith. intros u tmp; elim tmp; intros Hu1 Hu2; clear tmp. elim ReductRangeI with radix (BoundI (pred (nat_of_P (vNum b2))) (nat_of_P (vNum b2)) (Zabs_nat (dExp b2))) (BoundI (pred (nat_of_P (vNum b2))) (pred (nat_of_P (vNum b2))) (Zabs_nat (dExp b2))) (Zabs_nat (Zpower_nat radix (pred prec2))) u; auto with real zarith. 2: rewrite (V2 b2); apply trans_eq with (pred (nat_of_P (vNum b2)) + 1)%Z; [ idtac | simpl in |- *; auto ]. 2: rewrite inj_pred; auto with zarith. 2: rewrite inject_nat_convert with (Zpos (vNum b2)) (vNum b2); auto with zarith arith; unfold Zpred in |- *; ring. 2: rewrite (V2 b2); rewrite p2GivesBound; rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith arith. 2: pattern prec2 at 1 in |- *; replace prec2 with (1 + pred prec2); auto with zarith arith. intros v tmp; elim tmp; intros Hv1 Hv2; clear tmp. exists v; split. unfold FtoRradix in |- *; rewrite <- Hv2; rewrite Hu1; auto with real. elim Hv1; intros tmp H3; elim tmp; intros H4 H5; clear tmp; split; auto with zarith. case (Zle_or_lt 0 (Fnum v)); intros H'. rewrite Zabs_eq; auto with zarith. replace (Zpos (vNum b2)) with (Zsucc (vNumSup (BoundI (pred (nat_of_P (vNum b2))) (pred (nat_of_P (vNum b2))) (Zabs_nat (dExp b2))))); auto with zarith. apply trans_eq with (Zsucc (pred (nat_of_P (vNum b2)))); [ simpl in |- *; auto | idtac ]. rewrite inj_pred; auto with zarith. rewrite inject_nat_convert with (Zpos (vNum b2)) (vNum b2); auto with zarith; rewrite <- Zsucc_pred; auto. rewrite <- Zabs_Zopp; rewrite Zabs_eq; auto with zarith. replace (Zpos (vNum b2)) with (Zsucc (vNumInf (BoundI (pred (nat_of_P (vNum b2))) (pred (nat_of_P (vNum b2))) (Zabs_nat (dExp b2))))); auto with zarith. apply trans_eq with (Zsucc (pred (nat_of_P (vNum b2)))); [ simpl in |- *; auto | idtac ]. rewrite inj_pred; auto with zarith. rewrite inject_nat_convert with (Zpos (vNum b2)) (vNum b2); auto with zarith. apply Zle_trans with (2:=H3); simpl. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith; case (dExp b2); auto with zarith. Qed. Theorem SterbenzApprox_weak_1 : forall (rho : R) (x y : float), (0 < rho)%R -> IZR (Zpos (vNum b1)) = (rho * Zpos (vNum b2))%R -> (- dExp b2 <= - dExp b1)%Z -> Fbounded b1 x -> Fbounded b1 y -> (0 <= y)%R -> (y <= x)%R -> (x <= (1 + / rho) * y)%R -> Fbounded b2 (Fminus radix (Fnormalize radix b1 prec1 x) (Fnormalize radix b1 prec1 y)). intros rho x y H1 H2 H'' H3 H4 H5 H6 H7. cut (0 <= Fminus radix (Fnormalize radix b1 prec1 x) (Fnormalize radix b1 prec1 y))%R; [ intros Rle1 | idtac ]. 2: rewrite (Fminus_correct radix); auto with zarith; fold FtoRradix in |- *. 2: unfold FtoRradix in |- *; repeat rewrite FnormalizeCorrect; auto. 2: apply Rplus_le_reg_l with (r := FtoR radix y); auto. 2: fold FtoRradix in |- *; ring_simplify; auto with real. cut (Fexp (Fminus radix (Fnormalize radix b1 prec1 x) (Fnormalize radix b1 prec1 y)) = Fexp (Fnormalize radix b1 prec1 y)); [ intros He | idtac ]. 2: unfold Fminus in |- *; simpl in |- *; apply Zmin_le2. 2: apply Fcanonic_Rle_Zle with radix b1 prec1; auto with real zarith float. 2: repeat rewrite FnormalizeCorrect; auto. 2: fold FtoRradix in |- *; repeat rewrite Rabs_right; auto with real. 2: apply Rle_ge; apply Rle_trans with (FtoRradix y); auto with real. split. rewrite Zabs_eq; [ idtac | apply LeR0Fnum with radix; auto with real zarith ]. apply Zlt_Rlt; apply Rle_lt_trans with ((x - y) * powerRZ radix (- Fexp (Fnormalize radix b1 prec1 y)))%R. right; apply trans_eq with (Fminus radix (Fnormalize radix b1 prec1 x) (Fnormalize radix b1 prec1 y) * powerRZ radix (- Fexp (Fminus radix (Fnormalize radix b1 prec1 x) (Fnormalize radix b1 prec1 y))))%R. unfold FtoRradix, FtoR in |- *; rewrite Rmult_assoc. rewrite <- powerRZ_add; auto with zarith real. ring_simplify (Fexp (Fminus radix (Fnormalize radix b1 prec1 x) (Fnormalize radix b1 prec1 y)) + - Fexp (Fminus radix (Fnormalize radix b1 prec1 x) (Fnormalize radix b1 prec1 y)))%Z; simpl in |- *; ring. unfold FtoRradix in |- *; rewrite Fminus_correct; auto with zarith. rewrite <- FnormalizeCorrect with radix b1 prec1 x; auto. rewrite <- FnormalizeCorrect with radix b1 prec1 y; auto. rewrite He; ring. apply Rle_lt_trans with (/ rho * FtoRradix y * powerRZ radix (- Fexp (Fnormalize radix b1 prec1 y)))%R. apply Rmult_le_compat_r; auto with real zarith. apply Rplus_le_reg_l with (FtoRradix y); auto. ring_simplify (FtoRradix y + (FtoRradix x - FtoRradix y))%R. apply Rle_trans with (1 := H7); right; ring. apply Rle_lt_trans with (/ rho * Fnum (Fnormalize radix b1 prec1 y))%R. unfold FtoRradix in |- *; rewrite <- FnormalizeCorrect with radix b1 prec1 y; auto. right; unfold FtoR in |- *. apply trans_eq with (/ rho * (powerRZ radix (- Fexp (Fnormalize radix b1 prec1 y)) * powerRZ radix (Fexp (Fnormalize radix b1 prec1 y))) * Fnum (Fnormalize radix b1 prec1 y))%R. ring. rewrite <- powerRZ_add; auto with zarith real. ring_simplify (- Fexp (Fnormalize radix b1 prec1 y) + Fexp (Fnormalize radix b1 prec1 y))%Z; simpl in |- *; ring. apply Rlt_le_trans with (/ rho * Zpos (vNum b1))%R. apply Rmult_lt_compat_l; auto with real. rewrite <- (Zabs_eq (Fnum (Fnormalize radix b1 prec1 y))); auto with real zarith float. apply LeR0Fnum with radix; auto with zarith real. rewrite FnormalizeCorrect; auto with real float zarith. right; rewrite H2; rewrite <- Rmult_assoc; rewrite Rinv_l; [ ring | auto with zarith real ]. apply Zle_trans with (1 := H''); auto with zarith; rewrite He; auto with float zarith. Qed. Theorem SterbenzApprox2 : forall (rho : R) (x y : float), (0 < rho)%R -> IZR (Zpos (vNum b1)) = (rho * Zpos (vNum b2))%R -> (- dExp b2 <= - dExp b1)%Z -> Fbounded b1 x -> Fbounded b1 y -> (/ (1 + / rho) * y <= x)%R -> (x <= (1 + / rho) * y)%R -> Fbounded b2 (Fminus radix (Fnormalize radix b1 prec1 x) (Fnormalize radix b1 prec1 y)). intros rho x y Hrho Hv1 Hv2 F1x F1y H1 H2. cut (0 < 1 + / rho)%R; [ intros H' | idtac ]. 2: apply Rlt_trans with (1 + 0)%R; [ ring_simplify (1 + 0)%R | apply Rplus_lt_compat_l ]; auto with real. cut (y <= (1 + / rho) * x)%R; [ intros H'1 | idtac ]. 2: apply Rmult_le_reg_l with (/ (1 + / rho))%R; auto with real. 2: rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real; ring_simplify (1 * x)%R; auto with real. cut (0 <= y)%R; [ intros H'2 | idtac ]. 2: apply Rmult_le_reg_l with (1 + / rho - / (1 + / rho))%R. 2: apply Rplus_lt_reg_r with (/ (1 + / rho))%R. 2: ring_simplify. 2: apply Rmult_lt_reg_l with (1 + / rho)%R; auto with real. 2: rewrite Rinv_r; auto with real. 2: apply Rlt_le_trans with (1+(/rho+(/rho+/rho*/rho)))%R;[idtac|right; ring]. 2: apply Rle_lt_trans with (1 + (0 + (0 + 0)))%R; [ right; ring | apply Rplus_lt_compat_l; auto with real ]. 2: apply Rplus_lt_compat; auto with real. 2: apply Rplus_lt_compat; auto with real. 2: apply Rmult_lt_0_compat; auto with real. 2: ring_simplify ((1 + / rho - / (1 + / rho)) * 0)%R. 2: apply Rplus_le_reg_l with (/ (1 + / rho) * FtoRradix y)%R. 2: ring_simplify; auto with real. 2: apply Rle_trans with (FtoRradix x); auto with real. 2: apply Rle_trans with (1 := H2); right; ring. cut (0 <= x)%R; [ intros H'3 | idtac ]. 2: apply Rle_trans with (2 := H1); apply Rmult_le_pos; auto with real. case (Rle_or_lt y x); intros H3. apply SterbenzApprox_weak_1 with rho; auto with real float. apply oppBoundedInv; rewrite Fopp_Fminus. apply SterbenzApprox_weak_1 with rho; auto with real float. Qed. End SterbenzApprox. Section RinvProps. Variable radix : Z. Hypothesis radixMoreThanOne : (1 < radix)%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Variable b : Fbound. Variable prec : nat. Hypothesis precMoreThanOne : 1 < prec. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix prec. Theorem Rle_floats_isMax_Pos : forall (f g : float) (r : R), Fcanonic radix b f -> Fcanonic radix b g -> (0 < f)%R -> isMax b radix r g -> (f - Fulp b radix prec (FPred b radix prec f) < r)%R -> (f <= g)%R. intros f g r Hf Hg Hf' H1 H. rewrite <- FSucPred with b radix prec f; auto with arith. unfold FtoRradix in |- *; apply FSuccProp; fold FtoRradix in |- *; auto with arith float. apply Rlt_le_trans with r; auto with real float. 2: elim H1; intros H2 H3; elim H3; auto with real. apply Rle_lt_trans with (2 := H). apply Rplus_le_reg_l with (Fulp b radix prec (FPred b radix prec f)). right; ring_simplify (Fulp b radix prec (FPred b radix prec f) + (f - Fulp b radix prec (FPred b radix prec f)))%R. rewrite Rplus_comm; unfold FtoRradix in |- *; apply FpredUlpPos; auto with float real zarith. Qed. Theorem Rle_floats_isMax_Neg : forall (f g : float) (r : R), Fcanonic radix b f -> Fcanonic radix b g -> (f < 0)%R -> isMax b radix r g -> (f - Fulp b radix prec f < r)%R -> (f <= g)%R. intros f g r Hf Hg Hf' H1 H. rewrite <- FSucPred with b radix prec f; auto with arith. unfold FtoRradix in |- *; apply FSuccProp; fold FtoRradix in |- *; auto with arith float. apply Rlt_le_trans with r; auto with real float. 2: elim H1; intros H2 H3; elim H3; auto with real. apply Rle_lt_trans with (2 := H). apply Rplus_le_reg_l with (Fulp b radix prec f - FtoRradix (FPred b radix prec f))%R. right; ring_simplify. apply trans_eq with (Fulp b radix prec (Fopp f)). repeat rewrite CanonicFulp; auto with float zarith. rewrite <- FSuccUlpPos; auto with float real; [ idtac | rewrite Fopp_correct; auto with real ]. rewrite Fminus_correct; auto with zarith; rewrite FPredFopFSucc; auto with arith. unfold FtoRradix in |- *; repeat rewrite Fopp_correct; ring. Qed. Theorem FulpFPred_not_pow : forall f : float, (forall e : Z, FtoRradix f <> powerRZ radix e) -> (0 < f)%R -> Fcanonic radix b f -> Fulp b radix prec (FPred b radix prec f) = Fulp b radix prec f. intros f H Hfpos Hf. cut (Fcanonic radix b (FPred b radix prec f)); [ intros H1 | apply FPredCanonic; auto with arith ]. repeat rewrite CanonicFulp; auto. unfold FtoR in |- *; simpl in |- *; ring_simplify. generalize (Z_eq_bool_correct (Fnum f) (- pPred (vNum b))); case (Z_eq_bool (Fnum f) (- pPred (vNum b))); intros H2. Contradict Hfpos; apply Rle_not_lt; unfold FtoRradix in |- *; apply LeZEROFnum; auto. rewrite H2; unfold pPred in |- *; replace 0%Z with (- (0))%Z; auto with zarith float. generalize (Z_eq_bool_correct (Fnum f) (nNormMin radix prec)); case (Z_eq_bool (Fnum f) (nNormMin radix prec)); intros H3. unfold nNormMin in H3; Contradict H. apply ex_not_not_all with (U := Z) (P := fun t : Z => FtoRradix f <> powerRZ radix t). exists (Fexp f + Zpred prec)%Z. cut (FtoRradix f = powerRZ radix (Fexp f + Zpred prec)); auto with real. unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite powerRZ_add; auto with zarith real. rewrite H3; rewrite Zpower_nat_Z_powerRZ; rewrite inj_pred; auto with zarith; ring. rewrite FPredSimpl4; auto. Qed. Theorem RinvClosestRinvMaxRle_Pos : radix = 2%Z -> forall a u v : float, (forall e : Z, FtoRradix a <> powerRZ radix e) -> Fbounded b a -> Fbounded b u -> Fnormal radix b (Fnormalize radix b prec u) -> Fcanonic radix b a -> Fcanonic radix b v -> Closest b radix (/ a) u -> isMax b radix (/ u) v -> (0 < a)%R -> (0 < u)%R -> (a <= v)%R. intros Hradix a u v Hpow Fa Fu Nu Ca Cv Hu Hv H H'. apply Rle_floats_isMax_Pos with (/ u)%R; auto; unfold Rminus in |- *. rewrite FulpFPred_not_pow; auto. cut (0 < powerRZ radix prec - 1)%R; [ intros V0 | idtac ]. 2: apply Rplus_lt_reg_r with 1%R. 2: ring_simplify. 2: replace 1%R with (powerRZ radix 0); auto with real zarith arith. apply Rle_lt_trans with (FtoRradix a + - (a * / (powerRZ radix prec - 1)))%R; [ apply Rplus_le_compat_l; apply Ropp_le_contravar | idtac ]. apply Rmult_le_reg_l with (powerRZ radix prec - 1)%R; auto with real zarith. rewrite Rmult_comm; rewrite Rmult_assoc; rewrite Rinv_l; auto with real. ring_simplify (FtoRradix a * 1)%R. apply Rle_trans with (Rabs a); [ apply RRle_abs | idtac ]. unfold FtoRradix in |- *; apply FulpGe; auto with real zarith. apply Rle_lt_trans with (FtoRradix a * (1 + - / (powerRZ radix prec - 1)))%R; [ right; ring; ring | idtac ]. cut (0 < 1 + - / (powerRZ radix prec - 1))%R; [ intros V1 | idtac ]. 2: apply Rplus_lt_reg_r with (/ (powerRZ radix prec - 1))%R. 2: ring_simplify. 2: pattern 1%R at 2 in |- *; rewrite <- Rinv_1; apply Rinv_lt_contravar; auto with real. 2: apply Rlt_le_trans with (1 := V0); right; ring. 2: apply Rplus_lt_reg_r with 1%R; ring_simplify (1 + (powerRZ radix prec - 1))%R. 2: apply Rle_lt_trans with (IZR radix); auto with zarith real. 2: replace 2%R with (IZR 2); auto with real zarith. 2: pattern (IZR radix) at 1 in |- *; replace (IZR radix) with (powerRZ radix 1); auto with real zarith. cut (0 < 1 + - / (2%nat * powerRZ radix (Zpred prec)))%R; [ intros V2 | idtac ]. 2: apply Rplus_lt_reg_r with (/ (2%nat * powerRZ radix (Zpred prec)))%R. 2: ring_simplify. 2: rewrite <- Rinv_1; apply Rinv_lt_contravar; auto with real. 2: repeat apply Rmult_lt_0_compat; auto with arith zarith real. 2: apply Rlt_trans with (powerRZ radix (Zpred prec)). 2: replace 1%R with (powerRZ radix (Zpred 1)); auto with real zarith arith. 2: apply Rle_lt_trans with (1 * powerRZ radix (Zpred prec))%R; [ right; ring | auto with real arith ]. apply Rle_lt_trans with (/ FtoRradix u * / (1 + - / (2%nat * powerRZ radix (Zpred prec))) * (1 + - / (powerRZ radix prec - 1)))%R. apply Rmult_le_compat_r; auto with real. rewrite <- Rinv_involutive with (FtoRradix a); auto with real. rewrite <- Rinv_mult_distr; auto with real. apply Rle_Rinv; [ apply Rmult_lt_0_compat; auto with real | idtac ]. rewrite Rinv_mult_distr; auto with real arith zarith. apply Rle_trans with (FtoRradix u + - (/ 2%nat * Fulp b radix prec u))%R. apply Rle_trans with (u + - (/ 2%nat *( /powerRZ radix (Zpred prec)*u)))%R; [right; ring|idtac]. apply Rplus_le_compat_l; apply Ropp_le_contravar. apply Rmult_le_compat_l; auto with real arith. apply Rle_trans with (Rabs u * powerRZ radix (Zsucc (- prec)))%R. unfold FtoRradix in |- *; apply FulpLe2; auto with float. rewrite Rinv_powerRZ; auto with zarith real. rewrite Rabs_right with (FtoRradix u); [ idtac | apply Rle_ge; auto with real ]. replace (Zsucc (- prec)) with (- Zpred prec)%Z; [ right | unfold Zsucc, Zpred in |- * ]; ring. apply Rplus_le_reg_l with (/ 2%nat * Fulp b radix prec u + - / FtoRradix a)%R. ring_simplify. apply Rle_trans with (Rabs (- / FtoRradix a + FtoRradix u)); [ apply RRle_abs | idtac ]. rewrite <- Rabs_Ropp. replace (- (- / FtoRradix a + FtoRradix u))%R with (/ FtoRradix a - u)%R; [ idtac | ring ]. apply Rmult_le_reg_l with (INR 2); auto with arith real. apply Rle_trans with (Fulp b radix prec u). unfold FtoRradix in |- *; apply ClosestUlp; auto. right; simpl; field. rewrite Rmult_assoc; apply Rlt_le_trans with (/u * 1)%R;[ apply Rmult_lt_compat_l; auto with real| right; ring]. apply Rmult_lt_reg_l with (1 + - / (2%nat * powerRZ radix (Zpred prec)))%R; auto with real. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real. ring_simplify. apply Rplus_lt_compat_r; apply Ropp_lt_contravar; apply Rinv_lt_contravar. apply Rmult_lt_0_compat; auto with real arith zarith. apply Rmult_lt_0_compat; auto with real arith zarith. apply Rlt_le_trans with (powerRZ radix prec - 0)%R; unfold Rminus in |- *; auto with real. ring_simplify (powerRZ radix prec + -0)%R. pattern (Z_of_nat prec) at 1 in |- *; replace (Z_of_nat prec) with (1 + Zpred prec)%Z; [ rewrite powerRZ_add; auto with real zarith | unfold Zpred in |- *; ring ]. apply Rmult_le_compat_r; auto with real zarith; simpl in |- *. ring_simplify (radix * 1)%R; rewrite Hradix; auto with real zarith. Qed. Theorem RinvClosestRinvMaxRle_Neg : radix = 2%Z -> forall a u v : float, Fbounded b a -> Fbounded b u -> Fnormal radix b (Fnormalize radix b prec u) -> Fcanonic radix b a -> Fcanonic radix b v -> Closest b radix (/ a) u -> isMax b radix (/ u) v -> (a < 0)%R -> (u < 0)%R -> (a <= v)%R. intros Hradix a u v Fa Fu Nu Ca Cv Hu Hv H H'. apply Rle_floats_isMax_Neg with (/ u)%R; auto; unfold Rminus in |- *. cut (0 < powerRZ radix prec - 1)%R; [ intros V0 | idtac ]. 2: apply Rplus_lt_reg_r with 1%R. 2: ring_simplify. 2: replace 1%R with (powerRZ radix 0); auto with real zarith arith. apply Rle_lt_trans with (FtoRradix a + a * / (powerRZ radix prec - 1))%R; [ apply Rplus_le_compat_l | idtac ]. apply Ropp_le_cancel; rewrite Ropp_involutive; rewrite <- Ropp_mult_distr_l_reverse. apply Rmult_le_reg_l with (powerRZ radix prec - 1)%R; auto with real zarith. rewrite Rmult_comm; rewrite Rmult_assoc; rewrite Rinv_l; auto with real. ring_simplify (- FtoRradix a * 1)%R; rewrite <- Rabs_left; auto with real. unfold FtoRradix in |- *; apply FulpGe; auto with real zarith. apply Rle_lt_trans with (FtoRradix a * (1 + / (powerRZ radix prec - 1)))%R; [ right; ring; ring | idtac ]. cut (0 < 1 + / (powerRZ radix prec - 1))%R; [ intros V1 | idtac ]. 2: apply Rlt_trans with (1 + 0)%R; [ ring_simplify (1 + 0)%R | apply Rplus_lt_compat_l ]; auto with real. cut (0 < 1 + / (2%nat * powerRZ radix (Zpred prec)))%R; [ intros V2 | idtac ]. 2: apply Rlt_trans with (1 + 0)%R; [ ring_simplify (1 + 0)%R | apply Rplus_lt_compat_l ]; auto with real. 2: apply Rinv_0_lt_compat; apply Rmult_lt_0_compat; auto with real arith zarith. apply Rle_lt_trans with (/ FtoRradix u * / (1 + / (2%nat * powerRZ radix (Zpred prec))) * (1 + / (powerRZ radix prec - 1)))%R. apply Rmult_le_compat_r; auto with real. rewrite <- Rinv_involutive with (FtoRradix a); auto with real. rewrite <- Rinv_mult_distr; auto with real. apply Ropp_le_cancel; rewrite Ropp_inv_permute; auto with real. rewrite Ropp_inv_permute with (/ FtoRradix a)%R; auto with real. apply Rle_Rinv; [ auto with real | apply Ropp_le_contravar ]. rewrite Rinv_mult_distr; auto with real arith zarith. apply Rle_trans with (FtoRradix u + - (/ 2%nat * Fulp b radix prec u))%R. apply Rle_trans with (u+(/2%nat*(/ powerRZ radix (Zpred prec) * u)))%R; [right; ring|idtac]. apply Rplus_le_compat_l; apply Ropp_le_cancel; rewrite Ropp_involutive. apply Rle_trans with (/ 2%nat * (/ powerRZ radix (Zpred prec) * - FtoRradix u))%R; [ apply Rmult_le_compat_l; auto with real arith | right; ring ]. apply Rle_trans with (Rabs u * powerRZ radix (Zsucc (- prec)))%R. unfold FtoRradix in |- *; apply FulpLe2; auto with float. rewrite Rinv_powerRZ; auto with zarith real. rewrite Rabs_left with (FtoRradix u); [ idtac | auto with real ]. replace (Zsucc (- prec)) with (- Zpred prec)%Z; [ right | unfold Zsucc, Zpred in |- * ]; ring. apply Rplus_le_reg_l with (/ 2%nat * Fulp b radix prec u + - / FtoRradix a)%R. ring_simplify. apply Rle_trans with (Rabs (- / FtoRradix a + FtoRradix u)); [ apply RRle_abs | idtac ]. rewrite <- Rabs_Ropp. replace (- (- / FtoRradix a + FtoRradix u))%R with (/ FtoRradix a - u)%R; [ idtac | ring ]. apply Rmult_le_reg_l with (INR 2); auto with arith real. apply Rle_trans with (Fulp b radix prec u). unfold FtoRradix in |- *; apply ClosestUlp; auto. right; simpl; field. apply Ropp_lt_cancel; rewrite Ropp_inv_permute; auto with real. rewrite <- Ropp_mult_distr_l_reverse; rewrite <- Ropp_mult_distr_l_reverse; rewrite Ropp_inv_permute; auto with real. pattern (/ - FtoRradix u)%R at 1 in |- *; replace (/ - FtoRradix u)%R with (/ - FtoRradix u * 1)%R; [ idtac | ring ]. rewrite Rmult_assoc; apply Rmult_lt_compat_l; auto with real. apply Rmult_lt_reg_l with (1 + / (2%nat * powerRZ radix (Zpred prec)))%R; auto with real. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real. ring_simplify. apply Rplus_lt_compat_r; apply Rinv_lt_contravar; auto with real. apply Rmult_lt_0_compat; auto with real arith zarith. apply Rmult_lt_0_compat; auto with real arith zarith. apply Rlt_le_trans with (powerRZ radix prec - 0)%R; unfold Rminus in |- *; auto with real. ring_simplify (powerRZ radix prec + -0)%R. pattern (Z_of_nat prec) at 1 in |- *; replace (Z_of_nat prec) with (1 + Zpred prec)%Z; [ rewrite powerRZ_add; auto with real zarith | unfold Zpred in |- *; ring ]. apply Rmult_le_compat_r; auto with real zarith; simpl in |- *. ring_simplify (radix * 1)%R; rewrite Hradix; auto with real zarith. Qed. Theorem RinvClosestRinvMaxRle_pow : forall (a u v : float) (e : Z), a = powerRZ radix e :>R -> (e <= dExp b)%Z -> Fbounded b a -> Closest b radix (/ a) u -> isMax b radix (/ u) v -> a = v :>R. intros a u v e Ha He Fa Hu Hv. cut (ProjectorP b radix (isMax b radix)); [ unfold ProjectorP in |- *; intros V | apply ProjectMax ]. unfold FtoR in |- *; apply V; auto. replace (FtoR radix a) with (/ FtoRradix u)%R; auto. replace (FtoRradix u) with (powerRZ radix (- e)); fold FtoRradix in |- *. rewrite Ha; rewrite Rinv_powerRZ; auto with zarith real; ring_simplify (- - e)%Z; auto. apply trans_eq with (FtoRradix (Float 1 (- e))); [ unfold FtoRradix, FtoR in |- *; simpl in |- *; ring | idtac ]. unfold FtoRradix in |- *; apply RoundedModeProjectorIdemEq with b prec (Closest b radix); auto. apply ClosestRoundedModeP with prec; auto. split; simpl in |- *; auto with zarith; rewrite pGivesBound; replace 1%Z with (Zpower_nat radix 0); auto with zarith. replace (FtoR radix (Float 1 (- e))) with (/ FtoRradix a)%R; auto. rewrite Ha; rewrite Rinv_powerRZ; auto with zarith real; unfold FtoR in |- *; simpl in |- *; ring. Qed. Theorem RinvClosestRinvMaxRle_pow2 : forall (a u v : float) (e : Z), a = powerRZ radix e :>R -> Fnormal radix b (Fnormalize radix b prec u) -> Fbounded b a -> Closest b radix (/ a) u -> isMax b radix (/ u) v -> a = v :>R. intros a u v e Ha Nu Fa Hu Hv. apply RinvClosestRinvMaxRle_pow with u e; auto. case (Zle_or_lt e (dExp b)); intros H; auto with zarith. absurd (u <= powerRZ radix (- dExp b))%R. apply Rlt_not_le; apply Rlt_le_trans with (FtoRradix (firstNormalPos radix b prec)). unfold firstNormalPos, nNormMin, FtoRradix, FtoR in |- *; simpl in |- *; rewrite Zpower_nat_Z_powerRZ. apply Rle_lt_trans with (powerRZ radix 0 * powerRZ radix (- dExp b))%R; [ right; simpl in |- *; ring | idtac ]. apply Rmult_lt_compat_r; auto with real zarith; rewrite inj_pred; auto with zarith arith. apply Rlt_powerRZ; unfold Zpred in |- *; auto with arith zarith real. unfold FtoRradix in |- *; rewrite <- FnormalizeCorrect with (p := u) (b := b) (precision := prec); auto. apply FnormalLtFirstNormalPos; auto with arith. rewrite FnormalizeCorrect; auto. apply RleRoundedR0 with b prec (Closest b radix) (/ a)%R; auto; [ apply ClosestRoundedModeP with prec; auto | rewrite Ha; auto with real zarith ]. cut (MonotoneP radix (Closest b radix)); [ unfold MonotoneP in |- *; intros V | apply ClosestMonotone ]. apply Rle_trans with (FtoRradix (Float 1 (- dExp b))); unfold FtoRradix in |- *; [ idtac | right; unfold FtoR in |- *; simpl in |- *; ring ]. unfold FtoRradix in |- *; apply V with (/ a)%R (FtoRradix (Float 1 (- dExp b))); auto. rewrite Ha; rewrite Rinv_powerRZ; unfold FtoRradix, FtoR in |- *; simpl in |- *; auto with real zarith. ring_simplify (1 * powerRZ radix (- dExp b))%R; auto with real zarith. unfold FtoRradix in |- *; apply RoundedModeProjectorIdem with b; auto with float zarith. apply ClosestRoundedModeP with prec; auto. split; simpl in |- *; auto with zarith float. rewrite pGivesBound; replace 1%Z with (Zpower_nat radix 0); auto with arith zarith real. Qed. Theorem RinvClosestRinvMaxRle : radix = 2%Z -> forall a u v : float, Fbounded b a -> Fbounded b u -> Fnormal radix b (Fnormalize radix b prec u) -> Fcanonic radix b a -> Fcanonic radix b v -> Closest b radix (/ a) u -> isMax b radix (/ u) v -> a <> 0%R :>R -> (a <= v)%R. intros Hradix a u v Fa Fu Nu Ca Cv Hu Hv Ha. cut (forall a b : R, (a <= b)%R -> a <> b -> (a < b)%R); [ intros V | idtac ]. 2: intros x y H'1 H'2; case H'1; auto with real; intros H'3. 2: absurd (x = y :>R); auto with real. cut (u <> 0%R :>R); [ intros H' | idtac ]. 2: unfold FtoRradix in |- *; rewrite <- FnormalizeCorrect with (b := b) (precision := prec); auto. 2: cut (~ is_Fzero (Fnormalize radix b prec u) -> FtoR radix (Fnormalize radix b prec u) <> 0%R :>R); [ intros V'; apply V' | idtac ]. 2: apply FnormalNotZero with radix b; auto with float real. 2: unfold is_Fzero in |- *; intros H2; unfold FtoR in |- *; simpl in |- *. 2: apply prod_neq_R0; auto with real zarith. case (Rle_or_lt a 0); intros H. case H; intros H1; [ idtac | absurd (FtoRradix a = 0%R :>R); auto with real ]. apply RinvClosestRinvMaxRle_Neg with u; auto. apply V; auto; unfold FtoRradix in |- *. apply RleRoundedLessR0 with b prec (Closest b radix) (/ a)%R; auto with float zarith real. apply ClosestRoundedModeP with prec; auto. case (classic (forall e : Z, FtoRradix a <> powerRZ radix e :>R)); intros H1. apply RinvClosestRinvMaxRle_Pos with u; auto with real. apply V; auto; unfold FtoRradix in |- *. apply RleRoundedR0 with b prec (Closest b radix) (/ a)%R; auto with float zarith real. apply ClosestRoundedModeP with prec; auto. cut (exists e : Z, FtoRradix a = powerRZ radix e :>R); [ intros H2 | idtac ]. elim H2; intros e H3. right; apply RinvClosestRinvMaxRle_pow2 with u e; auto. apply not_all_not_ex with (U := Z) (P := fun t : Z => FtoRradix a = powerRZ radix t :>R); auto. Qed. End RinvProps. Float8.4/FnElem/FArgReduct2.v0000644000423700002640000024612012032774527015464 0ustar sboldotoccata(** FArgReduct2 file Sylvie Boldo This file explains an improvement of Cody & Waite argument reduction technique using the FMA (fused-multiply-and-add). *) Require Export FArgReduct. Section Reduct. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. (** Variables *) Variable b : Fbound. Variables prec q : nat. Variables k N : Z. Variables alpha gamma x zH : float. Variable zL : R. (** Various bounds *) Let bmoinsq := Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (prec - q))))) (dExp b). Let bzH := Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (Zabs_nat (Zsucc (k + N))))))) (dExp b). Let b1 := Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (prec - q + Zabs_nat (Zsucc (k + N))))))) (dExp b). (** All the hypotheses *) Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix prec. Hypothesis Fboundedx : Fbounded b x. (** alpha (the constant, such as pi) and gamma (its inverse) *) Hypothesis gammaInvalpha : Closest bmoinsq radix (/ alpha) gamma. Hypothesis alphaNormal : Fnormal radix b alpha. Hypothesis gammaNormal : Fnormal radix bmoinsq gamma. Hypothesis alphaPos : (0 < alpha)%R. Hypothesis gammaPos : (0 < gamma)%R. Hypothesis gamma_not_pow_2 : forall e : Z, FtoRradix gamma <> powerRZ radix e. (** zH, the approximation of x*alpha *) Hypothesis zHNormal : Fnormal radix bzH zH. Hypothesis zHDef : (Rabs (x * alpha - zH) <= powerRZ radix (Zpred (- N)))%R. Hypothesis zLDef : zL = (x * alpha - zH)%R. Hypothesis NDef : N = (- Fexp zH)%Z. Hypothesis zHPos : (0 <= zH)%R. (** Various precisions: gamma on p-q bits and zH on k+N+1 *) Hypothesis precMoreThanThree : 3 < prec. Hypothesis pMoinsqGreaterThanOne : 1 < prec - q. Hypothesis preczH_Less_Than_Prec : (Zsucc (k + N) <= Zpred prec)%Z. Hypothesis preczH_Pos : (0 <= Zsucc (k + N))%Z. Hypothesis preczH_Greater_Than_One : 1 < Zabs_nat (Zsucc (k + N)). Hypothesis q_enough : (2 <= q)%Z. Hypothesis q_not_too_big : (q <= Zsucc (k + N))%Z. (** No underflow *) Hypothesis exp_alpha_enough : (- dExp b <= Zsucc q + - (Fexp alpha + (prec + prec)))%Z. Hypothesis exp_gamma_enough : (- dExp b <= Fexp zH + Fexp gamma)%Z. (** A few lemmas *) Theorem minus_Zminus_precq : (prec - q)%Z = prec - q. clear - pMoinsqGreaterThanOne. apply sym_eq; apply inj_minus1; auto with zarith arith. Qed. Theorem vNum_eq_Zpower : forall n : nat, Zpos (vNum (Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix n)))) (dExp b))) = Zpower_nat radix n. intros n; unfold vNum in |- *. apply trans_eq with (Z_of_nat (nat_of_P (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix n)))))). 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 n) = Zpower_nat radix n). intros H; pattern (Zpower_nat radix n) at 2 in |- *; rewrite <- H. rewrite Zabs_absolu. rewrite <- (S_pred (Zabs_nat (Zpower_nat radix n)) 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. Theorem vNum_eq_Zpower_bmoinsq : Zpos (vNum bmoinsq) = Zpower_nat radix (prec - q). unfold bmoinsq in |- *; apply vNum_eq_Zpower. Qed. Theorem vNum_eq_Zpower_bzH : Zpos (vNum bzH) = Zpower_nat radix (Zabs_nat (Zsucc (k + N))). unfold bzH in |- *; apply vNum_eq_Zpower. Qed. Theorem vNum_eq_Zpower_bzH2 : powerRZ radix (Zsucc (k + N)) = Zpos (vNum bzH). rewrite vNum_eq_Zpower_bzH. rewrite Zpower_nat_powerRZ_absolu; auto with arith zarith. Qed. Theorem vNum_eq_Zpower_b1 : Zpos (vNum b1) = Zpower_nat radix (prec - q + Zabs_nat (Zsucc (k + N))). unfold b1 in |- *; apply vNum_eq_Zpower. Qed. Theorem vNum_eq_Zpower_b1bis : powerRZ radix (prec - q + Zsucc (k + N)) = Zpos (vNum b1). rewrite vNum_eq_Zpower_b1. rewrite Zpower_nat_Z_powerRZ; auto with arith zarith. replace (prec - q + Zsucc (k + N))%Z with (Z_of_nat (prec - q + Zabs_nat (Zsucc (k + N)))); auto with real zarith. rewrite inj_plus; rewrite <- minus_Zminus_precq; auto with arith zarith. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. Qed. Theorem prec1_Greater_Than_One : 1 < prec - q + Zabs_nat (Zsucc (k + N)). auto with arith zarith. Qed. Hint Resolve vNum_eq_Zpower_b1 vNum_eq_Zpower_b1bis prec1_Greater_Than_One vNum_eq_Zpower_bzH vNum_eq_Zpower_bzH2 vNum_eq_Zpower vNum_eq_Zpower_bmoinsq minus_Zminus_precq: zarith. (** First results *) Theorem gamma_exp : Fexp gamma = (Zsucc q + - (Fexp alpha + (prec + prec)))%Z. clear k N x bzH b1 Fboundedx zHNormal zHDef zLDef NDef zL k preczH_Less_Than_Prec preczH_Pos preczH_Greater_Than_One q_not_too_big. rewrite <- FcanonicFnormalizeEq with radix bmoinsq (prec - q) gamma; auto with zarith real. 2: left; auto. apply boundedNorMinGivesExp; auto with arith zarith. elim gammaNormal; auto. apply RleBoundRoundl with bmoinsq (prec - q) (Closest bmoinsq radix) (/ alpha)%R; auto with float zarith arith real. apply ClosestRoundedModeP with (prec - q); auto with arith zarith. split; auto with zarith. simpl (Fnum (Float (nNormMin radix (prec - q)) (Zsucc q + - (Fexp alpha + (prec + prec))))) in |- *. rewrite Zabs_eq; auto with zarith float. apply ZltNormMinVnum; auto with arith zarith. unfold nNormMin in |- *; auto with zarith arith. apply Rle_trans with (nNormMin radix (prec - q) * powerRZ radix (Zsucc q + - (Fexp alpha + (prec + prec))))%R. right; unfold FtoR in |- *; simpl in |- *; ring. unfold nNormMin in |- *. rewrite Zpower_nat_Z_powerRZ; rewrite <- powerRZ_add; auto with zarith real. rewrite inj_pred; auto with arith zarith. rewrite <- minus_Zminus_precq. unfold Zpred, Zsucc in |- *. replace (prec - q + -1 + (q + 1 + - (Fexp alpha + (prec + prec))))%Z with (- (prec + Fexp alpha))%Z; [ idtac | unfold Zpred in |- *; ring ]. rewrite <- Rinv_powerRZ; auto with real zarith. apply Rle_Rinv; auto with real zarith. rewrite powerRZ_add; auto with real zarith. unfold FtoRradix, FtoR in |- *; simpl in |- *. apply Rmult_le_compat_r; auto with real zarith. elim alphaNormal; intros V1 V2; elim V1; intros V3 V4. apply Rle_trans with (Zabs (Fnum alpha)); auto with real zarith. apply Rle_trans with (Zpos (vNum b)); auto with zarith real. rewrite pGivesBound; auto with real zarith. rewrite Zpower_nat_Z_powerRZ; auto with real zarith. rewrite <- FPredSuc with bmoinsq radix (prec - q) (Float (pPred (vNum bmoinsq)) (Zsucc q + - (Fexp alpha + (prec + prec)))); auto with zarith arith. 2: left; apply FnormalPpred with (prec - q); auto with zarith. apply FPredProp; auto with zarith. left; auto. apply FSuccCanonic; auto with zarith. left; apply FnormalPpred with (prec - q); auto with zarith. cut (FtoR radix (FSucc bmoinsq radix (prec - q) (Float (pPred (vNum bmoinsq)) (Zsucc q + - (Fexp alpha + (prec + prec))))) = powerRZ radix (- Zpred (Fexp alpha + prec))); [ intros W | idtac ]. cut (FtoR radix gamma <= FtoR radix (FSucc bmoinsq radix (prec - q) (Float (pPred (vNum bmoinsq)) (Zsucc q + - (Fexp alpha + (prec + prec))))))%R; [ intros V | idtac ]. case V; auto with real. intros V1; Contradict V1; rewrite W; apply gamma_not_pow_2. apply RleBoundRoundr with bmoinsq (prec - q) (Closest bmoinsq radix) (/ alpha)%R; auto with float zarith arith real. apply ClosestRoundedModeP with (prec - q); auto with arith zarith. apply FBoundedSuc; auto with zarith. cut (Fnormal radix bmoinsq (Float (pPred (vNum bmoinsq)) (Zsucc q + - (Fexp alpha + (prec + prec))))); [ intros V; elim V; auto | idtac ]. apply FnormalPpred with (prec - q); auto with zarith. rewrite W. rewrite <- Rinv_powerRZ; auto with real zarith. apply Rle_Rinv; auto with real zarith. unfold FtoRradix, FtoR in |- *; simpl in |- *. replace (Zpred (Fexp alpha + prec)) with (Zpred prec + Fexp alpha)%Z; [ idtac | unfold Zpred in |- *; ring ]. rewrite powerRZ_add; auto with real zarith. apply Rmult_le_compat_r; auto with real zarith. elim alphaNormal; intros V1 V2; clear V1. apply Rmult_le_reg_l with radix; auto with zarith real. apply Rle_trans with (Zpos (vNum b)); [ right | idtac ]. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; pattern (IZR radix) at 1 in |- *; replace (IZR radix) with (powerRZ 2 1); auto with real zarith. rewrite <- powerRZ_add; unfold Zpred in |- *; auto with real zarith. ring_simplify (1 + (prec + -1))%Z; auto with real. rewrite <- Rmult_IZR. rewrite <- (Zabs_eq (radix * Fnum alpha)); auto with real zarith. cut (0 <= Fnum alpha)%Z; [ idtac | apply LeR0Fnum with radix ]; auto with real zarith. rewrite FSuccSimpl1; auto. unfold FtoR, nNormMin in |- *. simpl (Fnum (Float (Zpower_nat radix (pred (prec - q))) (Zsucc (Fexp (Float (pPred (vNum bmoinsq)) (Zsucc q + - (Fexp alpha + (prec + prec)))))))) in |- *. replace (Fexp (Float (Zpower_nat radix (pred (prec - q))) (Zsucc (Fexp (Float (pPred (vNum bmoinsq)) (Zsucc q + - (Fexp alpha + (prec + prec)))))))) with (Zsucc (Zsucc q + - (Fexp alpha + (prec + prec)))); [ idtac | simpl in |- *; auto with zarith ]. rewrite Zpower_nat_Z_powerRZ. rewrite <- powerRZ_add; auto with zarith real. replace (pred (prec - q) + Zsucc (Zsucc q + - (Fexp alpha + (prec + prec))))%Z with (- Zpred (Fexp alpha + prec))%Z; auto with real. rewrite inj_pred; auto with zarith arith. rewrite <- minus_Zminus_precq. unfold Zsucc, Zpred in |- *; ring. Qed. Theorem delta_inf : (Rabs (1 - alpha * gamma) <= powerRZ radix (q - prec))%R. apply Rmult_le_reg_l with (Rabs (/ alpha)); auto with real. rewrite Rabs_right; auto with real. apply Rle_ge; auto with real. rewrite <- Rabs_mult. replace (/ alpha * (1 - alpha * gamma))%R with (/alpha-gamma)%R; [idtac|field; auto with real]. apply Rmult_le_reg_l with (INR 2); auto with arith real. apply Rle_trans with (Fulp bmoinsq radix (prec - q) gamma). unfold FtoRradix in |- *; apply ClosestUlp; auto with zarith. rewrite CanonicFulp; auto with zarith. 2: left; auto. unfold FtoR in |- *; simpl (Fnum (Float 1%nat (Fexp gamma))) in |- *; simpl (Fexp (Float 1%nat (Fexp gamma))) in |- *. apply Rle_trans with (powerRZ radix (Fexp gamma)); [right; simpl; ring|idtac]. rewrite gamma_exp; auto. rewrite Rabs_right; auto with real. 2: apply Rle_ge; auto with real. apply Rmult_le_reg_l with (FtoRradix alpha); auto with real. apply Rle_trans with (alpha * / alpha * 2%nat * powerRZ radix (q - prec))%R; [ idtac | right; ring ]. rewrite Rinv_r; auto with real. ring_simplify (1 * 2%nat * powerRZ radix (q - prec))%R. replace (INR 2) with (powerRZ radix 1); [ idtac | simpl in |- *; ring ]. rewrite <- powerRZ_add; auto with real zarith. unfold FtoRradix, FtoR in |- *. rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with real zarith; unfold Zsucc in |- *. replace (Fexp alpha + (q + 1 + - (Fexp alpha + (prec + prec))))%Z with (q-2*prec+1)%Z by ring. apply Rmult_le_reg_l with (powerRZ radix (- (1 + (-2 * prec + q)))); auto with real zarith. rewrite <- powerRZ_add; auto with real zarith. rewrite Rmult_comm; rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with real zarith; unfold Zsucc in |- *. replace (q - 2 * prec + 1 + - (1 + (-2 * prec + q)))%Z with 0%Z by ring. replace (- (1 + (-2 * prec + q)) + (1 + (q - prec)))%Z with (Z_of_nat prec) by ring. apply Rle_trans with (Fnum alpha); [ right; simpl in |- *; ring | idtac ]. apply Rle_trans with (Zabs (Fnum alpha)); auto with real zarith. apply Rle_trans with (Zpos (vNum b)); auto with zarith real. elim alphaNormal; intros V1 V2; elim V1; auto with zarith real. rewrite pGivesBound; auto with real zarith. rewrite Zpower_nat_Z_powerRZ; auto with real zarith. Qed. Theorem zL_over_zH : (Rabs (zL / zH) <= powerRZ radix (- Zsucc (k + N)))%R. unfold Rdiv in |- *; rewrite Rabs_mult. apply Rle_trans with (Rabs zL * powerRZ radix (- k))%R. apply Rmult_le_compat_l; auto with real zarith. rewrite Rabs_Rinv. rewrite <- Rinv_powerRZ; auto with real zarith. apply Rle_Rinv; auto with real. unfold FtoRradix in |- *; rewrite <- Fabs_correct; auto with real zarith. apply Rle_trans with (Zpos (vNum bzH) * FtoR radix (Float 1%nat (Zpred (Fexp zH))))%R. 2: apply FnormalBoundAbs2 with (Zabs_nat (Zsucc (k+N))); auto with zarith. rewrite <- vNum_eq_Zpower_bzH2; unfold FtoR in |- *; simpl in |- *; right; ring_simplify. rewrite <- powerRZ_add; auto with real zarith; rewrite NDef; unfold Zsucc, Zpred in |- *. ring_simplify (k + - Fexp zH + 1 + (Fexp zH + -1))%Z; auto with real. cut (~ is_Fzero zH); [ unfold is_Fzero in |- * | apply FnormalNotZero with radix bzH; auto ]. intros V; unfold FtoRradix, FtoR in |- *; apply Rmult_integral_contrapositive; auto with real zarith. replace (- Zsucc (k + N))%Z with (Zpred (- N) + - k)%Z; [ idtac | unfold Zsucc, Zpred in |- *; ring ]. rewrite powerRZ_add; auto with real zarith. apply Rmult_le_compat_r; auto with real zarith. rewrite zLDef; auto with real. Qed. Theorem x_over_zHgamma_eq : (x / (zH * gamma))%R = ((1 + zL / zH) / (1 + (alpha * gamma - 1)))%R. cut (FtoRradix zH <> 0%R); [ intros V | idtac ]. rewrite zLDef; unfold Rdiv in |- *; field. repeat (split; auto with real). ring_simplify (1 + (alpha * gamma -1))%R; auto with real. cut (~ is_Fzero zH); [ unfold is_Fzero in |- * | apply FnormalNotZero with radix bzH; auto ]. intros V; unfold FtoRradix, FtoR in |- *; apply Rmult_integral_contrapositive; auto with real zarith. Qed. Theorem SterbenzApprox3 : forall (rho : R) (x y : float) (b1 b2: Fbound) (prec1 prec2: nat), 1 < prec1 -> 1 < prec2 -> Zpos (vNum b1) = Zpower_nat radix prec1 -> Zpos (vNum b2) = Zpower_nat radix prec2 -> (0 < rho)%R -> IZR (Zpos (vNum b1)) = (rho * Zpos (vNum b2))%R -> (- dExp b2 <= - dExp b1)%Z -> Fbounded b1 x -> Fbounded b1 y -> (/ (1 + / rho) * y <= x)%R -> (x <= (1 + / rho) * y)%R -> Fbounded b2 (Fminus radix (Fnormalize radix b1 prec1 x) (Fnormalize radix b1 prec1 y)) /\ (Rabs (x-y) <= /rho*Rmin x y)%R. intros; split. apply SterbenzApprox2 with prec2 rho; auto with zarith. assert (0 <(1 + / rho))%R. apply Rlt_trans with (1+0)%R; auto with real. apply Rlt_le_trans with 1%R; auto with real. case (Rle_or_lt x0 y); intros. rewrite Rmin_1; auto. rewrite Rabs_left1; auto with real. apply Rplus_le_reg_l with x0; apply Rmult_le_reg_l with (/ (1 + / rho))%R; auto with real. apply Rle_trans with (/ (1 + / rho) * y)%R;[right; ring|idtac]. apply Rle_trans with (1:=H8); right; field; split; auto with real. assert (0 < rho+1)%R; auto with real. apply Rplus_le_reg_l with y; apply Rle_trans with x0;[right; ring|idtac]. apply Rle_trans with y; auto with real. rewrite Rmin_2; auto with real. rewrite Rabs_right; auto with real. apply Rplus_le_reg_l with y. apply Rle_trans with x0;[right; ring|idtac]. apply Rle_trans with (1:=H9); right; ring. apply Rle_ge; apply Rplus_le_reg_l with y; apply Rle_trans with y;[right; ring|idtac]. apply Rle_trans with x0; auto with real. Qed. (** Main theorem *) Theorem Fmac_arg_reduct_correct1_aux : ex (fun u : float => FtoRradix u = (x - zH * gamma)%R /\ Fbounded b u) /\ (Rabs (x-zH*gamma) < powerRZ radix (prec-N+Fexp gamma))%R. case zHPos; intros H. cut (exists u : float, FtoRradix u = (x - zH * gamma)%R /\ Fbounded b u /\ (Rabs (x - zH * gamma) < powerRZ radix (prec - N + Fexp gamma))%R). intros T; elim T; intros u (L1,(L2,L3)); clear T. split; auto; exists u; split; auto. exists (Fminus radix (Fnormalize radix b1 (prec - q + Zabs_nat (Zsucc (k + N))) x) (Fnormalize radix b1 (prec - q + Zabs_nat (Zsucc (k + N))) (Fmult zH gamma))). cut (Fbounded b1 x); [ intros V1 | idtac ]. cut (Fbounded b1 (Fmult zH gamma)); [ intros V2 | idtac ]. split. unfold FtoRradix in |- *; rewrite Fminus_correct; auto with zarith. rewrite FnormalizeCorrect; auto with zarith. rewrite FnormalizeCorrect; auto with zarith. rewrite Fmult_correct; auto with zarith real. 2: unfold Fmult in |- *; split. 2: rewrite vNum_eq_Zpower_b1; simpl in |- *; rewrite Zpower_nat_is_exp; rewrite Zabs_Zmult; rewrite Zmult_comm. 2: apply Zlt_le_trans with (Zabs (Fnum gamma) * Zpower_nat radix (Zabs_nat (Zsucc (k + N))))%Z. 2: apply Zmult_gt_0_lt_compat_l. 2: apply Zlt_gt. 2: replace (Zabs (Fnum gamma)) with (Fnum (Fabs gamma)); [ idtac | simpl in |- *; auto with zarith ]. 2: apply LtR0Fnum with radix; auto with real zarith. 2: rewrite Fabs_correct; fold FtoRradix in |- *; auto with real zarith. 2: rewrite Rabs_right; auto with real; apply Rle_ge; auto with real. 2: apply Zlt_le_trans with (Zpos (vNum bzH)); auto with zarith float. 2: elim zHNormal; auto with float zarith. 2: apply Zle_Zmult_comp_r; auto with zarith. 2: apply Zlt_le_weak; apply Zlt_le_trans with (Zpos (vNum bmoinsq)); auto with zarith. 2: elim gammaNormal; auto with float zarith. 2: simpl in |- *; auto with zarith. 2: split; [ apply Zlt_le_trans with (Zpos (vNum b)) | simpl in |- * ]; auto with float zarith. 2: rewrite pGivesBound; rewrite vNum_eq_Zpower_b1; auto with zarith. 2: apply Zpower_nat_monotone_le; auto with zarith. 2: apply ZleLe; idtac; rewrite inj_plus; rewrite <- minus_Zminus_precq. 2: rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. assert (Fbounded b (Fminus radix (Fnormalize radix b1 (prec - q + Zabs_nat (Zsucc (k + N))) x) (Fnormalize radix b1 (prec - q + Zabs_nat (Zsucc (k + N))) (Fmult zH gamma))) /\ (Rabs (x - Fmult zH gamma) <= /(powerRZ radix (Zsucc (k + N) - q))*Rmin x (Fmult zH gamma))%R). unfold FtoRradix; apply SterbenzApprox3 with prec; auto with zarith real. rewrite <- vNum_eq_Zpower_b1bis; rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ. rewrite <- powerRZ_add; auto with real zarith. replace (prec - q + Zsucc (k + N))%Z with (Zsucc (k + N) - q + prec)%Z; ring. unfold FtoRradix; rewrite Fmult_correct; auto with zarith; fold FtoRradix in |- *. apply Rmult_le_reg_l with (/ (zH * gamma))%R; auto with real. apply Rinv_0_lt_compat; apply Rmult_lt_0_compat; auto with real. apply Rle_trans with (/ (1 + / powerRZ radix (Zsucc (k + N) - q)) * (zH * gamma * / (zH * gamma)))%R; [ right; ring | idtac ]. rewrite Rinv_r; auto with real. replace (/ (zH * gamma) * x)%R with (x / (zH * gamma))%R; [ rewrite x_over_zHgamma_eq | unfold Rdiv in |- *; ring ]. rewrite Rinv_powerRZ; auto with real zarith. cut (0 < 1 + powerRZ radix (- (Zsucc (k + N) - q)))%R; [ intros V3 | idtac ]. 2: apply Rlt_trans with (1 + 0)%R; auto with real zarith; ring_simplify (1 + 0)%R; auto with real. apply Rmult_le_reg_l with (1 + powerRZ radix (- (Zsucc (k + N) - q)))%R; auto with real. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real zarith. cut (0 < alpha * gamma)%R; [ intros V4 | apply Rmult_lt_0_compat; auto with real ]. ring_simplify (1 + (alpha * gamma - 1))%R; apply Rmult_le_reg_l with (alpha * gamma)%R; auto with real. replace (alpha * gamma * (1 * 1))%R with (alpha*gamma)%R;[idtac|ring]. apply Rle_trans with (alpha * gamma * / ( alpha*gamma) * ((1 + powerRZ radix (- (Zsucc (k + N) - q))) * (1 + zL / zH)))%R; [ idtac | right; unfold Rdiv in |- *; ring ]. rewrite Rinv_r; auto with real. apply Rle_trans with (Rabs (alpha * gamma)); auto with real. rewrite Rabs_right; auto with real; apply Rle_ge; auto with real. replace (alpha * gamma)%R with (1 + - (1 - alpha * gamma))%R; [ idtac | ring ]. apply Rle_trans with (Rabs 1 + Rabs (- (1 - alpha * gamma)))%R. apply Rabs_triang. rewrite Rabs_R1; rewrite Rabs_Ropp. apply Rle_trans with (1 + powerRZ radix (q - prec))%R. apply Rplus_le_compat_l; apply delta_inf. apply Rle_trans with (1 * ((1 + powerRZ radix (- (Zsucc (k + N) - q))) * (1 - powerRZ radix (- Zsucc (k + N)))))%R. apply Rle_trans with (1 + (powerRZ radix (- (Zsucc (k + N) - q)) - powerRZ radix (- Zsucc (k + N)) - powerRZ radix (- (Zsucc (k + N) - q))*powerRZ radix (- Zsucc (k + N))))%R; [idtac|right; ring]. apply Rplus_le_compat_l. rewrite <- powerRZ_add; auto with real zarith. apply Rle_trans with (powerRZ radix (q - Zsucc (Zsucc (k + N)))). apply Rle_powerRZ; auto with real zarith. apply Rmult_le_reg_l with (powerRZ radix (Zsucc (k + N))); auto with real zarith. rewrite <- powerRZ_add; auto with real zarith. ring_simplify. repeat rewrite <- powerRZ_add; auto with real zarith. unfold Zsucc in |- *. replace (k + N + 1 + (q - (k + N + 1 + 1)))%Z with (q-1)%Z by ring. ring_simplify (k + N + 1 + - (k + N + 1 - q))%Z. ring_simplify (k + N + 1 + - (k + N + 1))%Z. ring_simplify (k + N + 1 + (- (k + N + 1 - q) + - (k + N + 1)))%Z. pattern (Z_of_nat q) at 2 in |- *; replace (Z_of_nat q) with (1 + (q-1))%Z; [ idtac | ring ]. rewrite powerRZ_add with (n := 1%Z); auto with real zarith. apply Rplus_le_reg_l with (- powerRZ radix (q-1))%R. ring_simplify (- powerRZ radix (q-1) + powerRZ radix (q -1))%R. simpl (powerRZ radix 1) in |- *. simpl (powerRZ radix 0) in |- *. replace (- powerRZ radix (q -1) + (2 * 1 * powerRZ radix (q -1) - 1 - powerRZ radix (- k - N + q -1)))%R with (powerRZ radix (q -1) - 1 - powerRZ radix (- k - N + q -1))%R by ring. apply Rle_trans with (powerRZ radix (q -1) - 1- powerRZ radix (q-2) )%R; [ idtac | unfold Rminus; apply Rplus_le_compat_l ]. replace (q -1)%Z with (1 + (q -2))%Z; [ idtac | ring ]. rewrite powerRZ_add with (n := 1%Z); auto with real zarith. simpl (powerRZ radix 1) in |- *. apply Rplus_le_reg_l with 1%R. ring_simplify. apply Rle_trans with (powerRZ radix 0)%R; [ simpl in |- * ; right; ring| idtac ]. apply Rle_powerRZ; auto with real zarith. apply Ropp_le_contravar. apply Rle_powerRZ; auto with real zarith. apply Rmult_le_compat_l; auto with real. apply Rmult_le_compat_l; auto with real. unfold Rminus in |- *; apply Rplus_le_compat_l. apply Rle_trans with (- Rabs (zL / zH))%R; auto with real. apply Ropp_le_contravar; apply zL_over_zH. case (Rcase_abs (zL / zH)); intros V5. rewrite Rabs_left; auto with real. rewrite Rabs_right; auto with real. apply Rle_trans with 0%R; auto with real. unfold FtoRradix;rewrite Fmult_correct; auto with zarith; fold FtoRradix in |- *. apply Rmult_le_reg_l with (/ (zH * gamma))%R; auto with real. apply Rinv_0_lt_compat; apply Rmult_lt_0_compat; auto with real. apply Rle_trans with ((1 + / powerRZ radix (Zsucc (k + N) - q)) * (zH * gamma * / (zH * gamma)))%R; [ idtac | right; ring ]. rewrite Rinv_r; auto with real. replace (/ (zH * gamma) * x)%R with (x / (zH * gamma))%R; [ rewrite x_over_zHgamma_eq | unfold Rdiv in |- *; ring ]. rewrite Rinv_powerRZ; auto with real zarith. replace (1 + (alpha * gamma - 1))%R with (alpha * gamma)%R; [ idtac | ring ]. cut (0 < alpha * gamma)%R; [ intros V4 | apply Rmult_lt_0_compat; auto with real ]. apply Rmult_le_reg_l with (alpha * gamma)%R; auto with real. apply Rle_trans with (alpha * gamma * / (alpha * gamma) * (1 + zL / zH))%R; [ right; unfold Rdiv in |- *; ring | idtac ]. rewrite Rinv_r; auto with real. apply Rle_trans with (1 + zL / zH)%R; [ right; ring | idtac ]. apply Rle_trans with (1 + Rabs (zL / zH))%R; [ apply Rplus_le_compat_l; apply RRle_abs | idtac ]. apply Rle_trans with (1 + powerRZ radix (- Zsucc (k + N)))%R; [ apply Rplus_le_compat_l; apply zL_over_zH | idtac ]. apply Rle_trans with ((1 - powerRZ radix (q - prec)) * ((1 + powerRZ radix (- (Zsucc (k + N) - q))) * 1))%R. apply Rle_trans with (1 +(- powerRZ radix (q - prec) + powerRZ radix (- (Zsucc (k + N) - q)) - powerRZ radix (q - prec) * powerRZ radix (- (Zsucc (k + N) - q))))%R; [idtac|right; ring]. rewrite <- powerRZ_add; auto with real zarith. apply Rplus_le_compat_l. apply Rmult_le_reg_l with (powerRZ radix (Zsucc (k + N))); auto with real zarith. rewrite <- powerRZ_add; auto with real zarith. ring_simplify (Zsucc (k + N) + - Zsucc (k + N))%Z. ring_simplify. rewrite Ropp_mult_distr_l_reverse. repeat rewrite <- powerRZ_add; auto with real zarith. ring_simplify (k + N + 1 + - (k + N + 1 - q))%Z. ring_simplify (k + N + 1 + (q - prec + - (k + N + 1 - q)))%Z. replace (powerRZ radix 0) with 1%R; [ idtac | simpl in |- *; ring ]. apply Rle_trans with (- powerRZ radix (q + -1) +powerRZ radix q - powerRZ radix (2*q+-1 * prec))%R; [ idtac | unfold Rminus; repeat apply Rplus_le_compat_r; apply Ropp_le_contravar; apply Rle_powerRZ; auto with real zarith ]. pattern (Z_of_nat q) at 2 in |- *; replace (Z_of_nat q) with (1 + (q + -1))%Z; [ idtac | ring ]. rewrite powerRZ_add with (n := 1%Z); auto with real zarith. simpl (powerRZ radix 1) in |- *. ring_simplify. apply Rle_trans with (powerRZ radix (q + -1) + - powerRZ radix (-1 + (q + -1)))%R; [ idtac | unfold Rminus; apply Rplus_le_compat_l ]. 2: apply Ropp_le_contravar; apply Rle_powerRZ; auto with real zarith. pattern (q + -1)%Z at 1 in |- *; replace (q + -1)%Z with (1 + (-1 + (q + -1)))%Z; [ idtac | ring ]. rewrite powerRZ_add with (n := 1%Z); auto with real zarith. simpl (powerRZ radix 1) in |- *. ring_simplify. replace 1%R with (powerRZ radix 0); [ apply Rle_powerRZ | simpl in |- * ]; auto with real zarith. apply Rmult_le_compat_r. apply Rmult_le_pos; auto with real zarith. apply Rle_trans with (1 + 0)%R; auto with real zarith; ring_simplify (1 + 0)%R; auto with real zarith. apply Rle_trans with (1 + - (1 - alpha * gamma))%R; [ unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_contravar | right; ring ]. fold Rminus in |- *; apply Rle_trans with (Rabs (1 - alpha * gamma)); [ apply RRle_abs | apply delta_inf ]. elim H0; intros T1 T2; clear H0; split; auto. unfold FtoRradix; rewrite <- Fmult_correct; auto with zarith; fold FtoRradix. apply Rle_lt_trans with (1:=T2). rewrite <- powerRZ_Zopp; auto with real zarith. replace (prec - N + Fexp gamma)%Z with ((- (Zsucc (k + N) - q))+((prec-q+Zsucc (k +N))+(-N+Fexp gamma)))%Z;[idtac|ring]. rewrite powerRZ_add; auto with real zarith. apply Rmult_lt_compat_l; auto with real zarith. apply Rle_lt_trans with (Fmult zH gamma); auto with real. unfold Rmin; case (Rle_dec x (Fmult zH gamma)); auto with real. unfold FtoRradix, FtoR; rewrite powerRZ_add; auto with real zarith. replace (Fexp (Fmult zH gamma)) with (-N+Fexp gamma)%Z; [idtac|unfold Fmult; simpl; auto with zarith]. apply Rmult_lt_compat_r; auto with real zarith. elim V2; intros. apply Rle_lt_trans with (Rabs (Fnum (Fmult zH gamma))); [apply RRle_abs|rewrite Rabs_Zabs]. rewrite vNum_eq_Zpower_b1bis; auto with real zarith. split. exists x; split; auto with real. rewrite <- H; ring. replace (x-zH*gamma)%R with (FtoRradix x);[idtac|rewrite <- H; ring]. apply Rmult_lt_reg_l with alpha; auto. apply Rle_lt_trans with (Rabs (x*alpha-zH)). right; replace (x*alpha-zH)%R with (x*alpha)%R; auto with real. rewrite Rabs_mult; rewrite (Rabs_right alpha); try apply Rle_ge; auto with real. rewrite <- H; ring. apply Rle_lt_trans with (1:=zHDef). replace (Zpred (-N)) with ((-Fexp gamma-1-prec)+(prec-N+Fexp gamma))%Z; [idtac|unfold Zpred; ring]. rewrite powerRZ_add; auto with real zarith. apply Rmult_lt_compat_r; auto with real zarith. replace (- Fexp gamma - 1 - prec)%Z with ((-q-2+prec) +Fexp alpha)%Z;[idtac|rewrite gamma_exp; unfold Zsucc; ring]. apply Rlt_le_trans with (Zpos (vNum b) * (Float (S 0) (Zpred (Fexp alpha))))%R. apply Rlt_le_trans with (powerRZ radix (prec+Fexp alpha-1)); auto with real zarith. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ. unfold FtoRradix, FtoR; simpl; right;ring_simplify. unfold Zpred, Zminus; repeat rewrite powerRZ_add; auto with real zarith; ring. apply Rle_trans with (Fabs alpha). unfold FtoRradix; apply FnormalBoundAbs2 with prec; auto with zarith. unfold FtoRradix; rewrite Fabs_correct; auto with zarith; rewrite Rabs_right; try apply Rle_ge; auto with zarith real. Qed. End Reduct. Section Reduct2. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. (** Variables *) Variable b : Fbound. Variables prec q : nat. Variables k N : Z. Variables alpha gamma x zH : float. Variable zL : R. (** Various bounds *) Let bmoinsq := Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (prec - q))))) (dExp b). Let bzH := Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (Zabs_nat (Zsucc (k + N))))))) (dExp b). Let b1 := Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (prec - q + Zabs_nat (Zsucc (k + N))))))) (dExp b). (** All the hypotheses *) Hypothesis precMoreThanThree : 3 < prec. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix prec. Hypothesis Fboundedx : Fbounded b x. Hypothesis alphaNormal : Fnormal radix b alpha. Hypothesis gammaNormal : Fnormal radix bmoinsq gamma. Hypothesis alphaPos : (0 < alpha)%R. Hypothesis gammaPos : (0 < gamma)%R. Hypothesis q_enough : (2 <= q)%Z. Hypothesis pMoinsqGreaterThanOne : 1 < prec - q. Hypothesis gammaInvalpha : Closest bmoinsq radix (/ alpha) gamma. Hypothesis gamma_not_pow_2 : forall e : Z, FtoRradix gamma <> powerRZ radix e. Hypothesis zHPos : (0 <= zH)%R. Hypothesis zHDef : (Rabs (x * alpha - zH) <= powerRZ radix (Zpred (- N)))%R. Hypothesis zLDef : zL = (x * alpha - zH)%R. Hypothesis preczH_Less_Than_Prec : (Zsucc (k + N) <= Zpred prec)%Z. Hypothesis preczH_Pos : (2 <= Zsucc (k + N))%Z. Hypothesis NDef : N = (- Fexp zH)%Z. Hypothesis zHNormal : Fnormal radix bzH zH. Hypothesis q_not_too_big : (q <= Zsucc (k + N))%Z. Hypothesis gamma_ge: (powerRZ radix (-dExp b+prec -q +(Zmax 1 (N-1)))<= gamma)%R. (** Same as previous, but with an inequality for gamma for the no-unverflow *) Theorem Fmac_arg_reduct_correct1_aux2 : ex (fun u : float => FtoRradix u = (x - zH * gamma)%R /\ Fbounded b u) /\ (Rabs (x-zH*gamma) < powerRZ radix (prec-N+Fexp gamma))%R. cut (- dExp b <= Zsucc q + - (Fexp alpha + (prec + prec)))%Z. intros V. apply Fmac_arg_reduct_correct1_aux with q k alpha zL; auto with zarith. assert (1 < Zabs_nat (Zsucc (k + N)))%Z; auto with zarith. rewrite <- Zabs_absolu; auto with zarith. rewrite Zabs_eq; auto with zarith. assert (- dExp b + prec -q + N - 1 < prec-q + Fexp gamma)%Z; auto with zarith. apply Zle_lt_trans with (- dExp b + prec -q + Zmax 1 (N - 1))%Z; auto with zarith. unfold Zminus; repeat rewrite <- Zplus_assoc; repeat apply Zplus_le_compat_l; auto with zarith. apply Zlt_powerRZ with radix; auto with real zarith. apply Rle_lt_trans with (1:=gamma_ge). rewrite powerRZ_add; auto with real zarith. unfold FtoRradix, FtoR; apply Rmult_lt_compat_r; auto with real zarith. apply Rle_lt_trans with (Zabs (Fnum gamma)); auto with real zarith. apply Rlt_le_trans with (Zpos (vNum (bmoinsq))). elim gammaNormal; intros I1 I2; elim I1; intros; auto with zarith real. unfold bmoinsq; rewrite vNum_eq_Zpower_bmoinsq. rewrite Zpower_nat_Z_powerRZ; auto with real zarith. rewrite minus_Zminus_precq; auto with real zarith. assert (prec-1+Fexp alpha <= dExp b+q-prec)%Z; unfold Zsucc; auto with zarith arith. apply Zle_powerRZ with radix; auto with real zarith. apply Rle_trans with alpha. rewrite powerRZ_add; auto with real zarith. unfold FtoRradix, FtoR; apply Rmult_le_compat_r; auto with real zarith. elim alphaNormal; intros. apply Rmult_le_reg_l with radix; auto with real zarith. apply Rle_trans with (Zpos (vNum b)). rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ. right; unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl. ring_simplify (2*1)%R; field; auto with real. apply Rle_trans with ( Zabs (radix * Fnum alpha)); auto with real zarith. rewrite Zabs_eq; auto with real zarith. rewrite mult_IZR; auto with real. assert (0 < Fnum alpha)%Z; auto with zarith real float. apply LtR0Fnum with radix; auto with real zarith. case (Rle_or_lt alpha (powerRZ radix (dExp b + q - prec))); auto with real. intros V. absurd (powerRZ radix (- dExp b + prec - q+1) <= gamma)%R. apply Rlt_not_le. assert (exists f:float, Fbounded bmoinsq f /\ (FtoRradix f= powerRZ radix (- dExp b+prec-q))%R). exists (Float 1 (-dExp b+prec-q)). split;[split|idtac]. apply Zle_lt_trans with (Zabs 1); auto with zarith. rewrite Zabs_eq; auto with zarith. unfold bmoinsq; rewrite vNum_eq_Zpower_bmoinsq; auto with zarith. apply Zle_lt_trans with (Zpower_nat 2 0); auto with zarith. simpl; auto with zarith. unfold FtoRradix, FtoR; simpl; ring. elim H; intros f H'; elim H'; intros I1 I2; clear H H'. apply Rle_lt_trans with (FtoRradix f). unfold FtoRradix; apply RleBoundRoundr with bmoinsq (prec-q) (Closest bmoinsq radix) (/alpha)%R; auto with real zarith float. unfold bmoinsq; apply vNum_eq_Zpower_bmoinsq; auto. apply ClosestRoundedModeP with (prec-q); auto with zarith. unfold bmoinsq; apply vNum_eq_Zpower_bmoinsq; auto. fold FtoRradix; rewrite I2. apply Rle_trans with (/(powerRZ radix (dExp b + q - prec)))%R. apply Rle_Rinv; auto with real zarith. rewrite Rinv_powerRZ; auto with real zarith. replace (- (dExp b + q - prec))%Z with (- dExp b + prec - q)%Z; auto with real zarith. rewrite I2; auto with real zarith. apply Rle_trans with (2:=gamma_ge). apply Rle_powerRZ; auto with real zarith. Qed. End Reduct2. Section Reduct3. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. (** Variables *) Variable b : Fbound. Variables prec q : nat. Variables k N : Z. Variables alpha gamma x zH : float. Variable zL : R. (** Various bounds *) Let bmoinsq := Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (prec - q))))) (dExp b). Let bzH := Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (Zabs_nat (Zsucc (k + N))))))) (dExp b). Let b1 := Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (prec - q + Zabs_nat (Zsucc (k + N))))))) (dExp b). (** All the hypotheses *) Hypothesis precMoreThanThree : 3 < prec. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix prec. Hypothesis Fboundedx : Fbounded b x. (** alpha (the constant, such as pi) and gamma (its inverse) *) Hypothesis alphaNormal : Fnormal radix b alpha. Hypothesis gammaNormal : Fnormal radix bmoinsq gamma. Hypothesis alphaPos : (0 < alpha)%R. Hypothesis gammaPos : (0 < gamma)%R. (** q such that gamma is on prec-q bits *) Hypothesis q_enough : (2 <= q)%Z. Hypothesis pMoinsqGreaterThanOne : 1 < prec - q. Hypothesis gammaInvalpha : Closest bmoinsq radix (/ alpha) gamma. Hypothesis gamma_not_pow_2 : forall e : Z, FtoRradix gamma <> powerRZ radix e. (** zH, the approximation of x*alpha *) Hypothesis zHDef : (Rabs (x * alpha - zH) <= powerRZ radix (Zpred (- N)))%R. Hypothesis zLDef : zL = (x * alpha - zH)%R. Hypothesis preczH_Less_Than_Prec : (Zsucc (k + N) <= Zpred prec)%Z. Hypothesis preczH_Pos : (2 <= Zsucc (k + N))%Z. Hypothesis NDef : N = (- Fexp zH)%Z. Hypothesis zHNormal : Fnormal radix bzH zH. Hypothesis q_not_too_big : (q <= Zsucc (k + N))%Z. (** No underflow *) Hypothesis gamma_ge: (powerRZ radix (-dExp b+prec -q +(Zmax 1 (N-1)))<= gamma)%R. (** Main result, works fine except when z=2^(-N) *) Theorem Fmac_arg_reduct_correct1 : ex (fun u : float => FtoRradix u = (x - zH * gamma)%R /\ Fbounded b u) /\ (Rabs (x-zH*gamma) < powerRZ radix (prec-N+Fexp gamma))%R. case (Rle_or_lt 0 zH); intros. apply Fmac_arg_reduct_correct1_aux2 with q k alpha zL; auto. elim Fmac_arg_reduct_correct1_aux2 with b prec q k N alpha gamma (Fopp x) (Fopp zH) (-zL)%R; auto. intros M1 M2; elim M1;intros u T; elim T; intros; clear T M1. split. exists (Fopp u); split. unfold FtoRradix; rewrite Fopp_correct; unfold radix; rewrite H0. repeat rewrite Fopp_correct; ring. apply oppBounded; auto. generalize M2; repeat rewrite Fopp_correct; auto. fold radix; fold FtoRradix; intros. replace (x-zH*gamma)%R with (-(-x-(-zH*gamma)))%R; [rewrite Rabs_Ropp; auto with real|ring]. apply oppBounded; auto. rewrite Fopp_correct; auto with real. apply Rle_trans with (Rabs (x * alpha - zH)); auto with real. repeat rewrite Fopp_correct. replace (- FtoR 2 x * FtoR 2 alpha - - FtoR 2 zH)%R with (-(x * alpha - zH))%R. rewrite Rabs_Ropp; auto with real. unfold FtoRradix, radix; ring. rewrite zLDef. repeat rewrite Fopp_correct; unfold FtoRradix, radix; ring. apply FnormalFop; auto. Qed. End Reduct3. Section Algo. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. (** Variables *) Variable b : Fbound. Variable prec : nat. Variable N : Z. Variables alpha x u zH1 : float. Let bzH (k : Z) := Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (Zabs_nat (Zsucc (k + N))))))) (dExp b). (** All the hypotheses *) Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix prec. Hypothesis precMoreThanOne : 1 < prec. Hypothesis Fboundedx : Fbounded b x. Hypothesis alphaNormal : Fnormal radix b alpha. Hypothesis alphaPos : (0 < alpha)%R. (** Algorithm to compute z *) Hypothesis uDef : Closest b radix (3%nat * powerRZ radix (Zpred (Zpred (prec - N))) + x * alpha) u. Hypothesis zH1Def : Closest b radix (u - 3%nat * powerRZ radix (Zpred (Zpred (prec - N)))) zH1. Hypothesis p_enough : (3 < prec)%Z. Hypothesis N_not_too_big : (N <= dExp b)%Z. (** As before, zH shall no be 2^(-N) *) Hypothesis zH_not_too_small : (powerRZ radix (2 - Zsucc N) <= Rabs zH1)%R. (** And x must not be too big *) Hypothesis xalpha_small : (Rabs (x * alpha) <= powerRZ radix (Zpred (Zpred (prec - N))) - powerRZ radix (- N))%R. (** A few lemmas *) Theorem vNum_eq_Zpower_bzH_fn : forall k : Z, Zpos (vNum (bzH k)) = Zpower_nat radix (Zabs_nat (Zsucc (k + N))). intros k; unfold bzH in |- *; apply vNum_eq_Zpower. Qed. Theorem vNum_eq_Zpower_bzH2_fn : forall k : Z, (0 <= Zsucc (k + N))%Z -> powerRZ radix (Zsucc (k + N)) = Zpos (vNum (bzH k)). intros k H; rewrite vNum_eq_Zpower_bzH_fn. rewrite Zpower_nat_powerRZ_absolu; auto with arith zarith. Qed. Hint Resolve vNum_eq_Zpower_bzH_fn vNum_eq_Zpower_bzH2_fn: zarith. Theorem zH1Pos : (0 <= x)%R -> (0 <= zH1)%R. intros L. unfold FtoRradix in |- *; apply RleRoundedR0 with b prec (Closest b radix) (u - 3%nat * powerRZ radix (Zpred (Zpred (prec - N))))%R; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. replace (3%nat * powerRZ radix (Zpred (Zpred (prec - N))))%R with (FtoRradix (Float 3%nat (Zpred (Zpred (prec - N))))); [ idtac | unfold FtoRradix, FtoR in |- *; simpl in |- *; ring ]. apply Rplus_le_reg_l with (FtoRradix (Float 3%nat (Zpred (Zpred (prec - N))))). ring_simplify. unfold FtoRradix in |- *; apply RleBoundRoundl with b prec (Closest b radix) (3%nat * powerRZ radix (Zpred (Zpred (prec - N))) + x * alpha)%R; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl in |- *; auto with zarith. rewrite pGivesBound; apply Zlt_le_trans with (Zpower_nat radix 2); auto with zarith arith. replace (FtoR radix (Float 3%nat (Zpred (Zpred (prec - N))))) with (3%nat * powerRZ radix (Zpred (Zpred (prec - N))) + 0)%R; [ auto with real | unfold FtoRradix, FtoR in |- *; simpl in |- *; ring ]. apply Rplus_le_compat_l; apply Rmult_le_pos; auto with real. Qed. Theorem zH1Neg : (x <= 0)%R -> (zH1 <= 0)%R. intros L. unfold FtoRradix in |- *; apply RleRoundedLessR0 with b prec (Closest b radix) (u - 3%nat * powerRZ radix (Zpred (Zpred (prec - N))))%R; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. replace (3%nat * powerRZ radix (Zpred (Zpred (prec - N))))%R with (FtoRradix (Float 3%nat (Zpred (Zpred (prec - N))))); [ idtac | unfold FtoRradix, FtoR in |- *; simpl in |- *; ring ]. apply Rplus_le_reg_l with (FtoRradix (Float 3%nat (Zpred (Zpred (prec - N))))). ring_simplify. unfold FtoRradix in |- *; apply RleBoundRoundr with b prec (Closest b radix) (3%nat * powerRZ radix (Zpred (Zpred (prec - N))) + x * alpha)%R; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl in |- *; auto with zarith. rewrite pGivesBound; apply Zlt_le_trans with (Zpower_nat radix 2); auto with zarith arith. replace (FtoR radix (Float 3%nat (Zpred (Zpred (prec - N))))) with (3%nat * powerRZ radix (Zpred (Zpred (prec - N))) + 0)%R; [ auto with real | unfold FtoRradix, FtoR in |- *; simpl in |- *; ring ]. apply Rplus_le_compat_l; auto with real. apply Rle_trans with (0*alpha)%R; auto with real. Qed. (** First computation correct *) Theorem zH1_eq : FtoRradix zH1 = (u - 3%nat * powerRZ radix (Zpred (Zpred (prec - N))))%R. cut (- dExp b <= Zpred (Zpred (prec - N)))%Z; [ intros V | idtac ]. 2: apply Zle_trans with (- N)%Z; auto with zarith arith. replace (3%nat * powerRZ radix (Zpred (Zpred (prec - N))))%R with (FtoRradix (Float 3%nat (Zpred (Zpred (prec - N))))); [ idtac | unfold FtoRradix, FtoR in |- *; simpl in |- *; ring ]. unfold FtoRradix in |- *; rewrite <- Fminus_correct; auto with zarith. apply sym_eq; apply RoundedModeProjectorIdemEq with b prec (Closest b radix); auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. 2: replace (FtoR radix (Float 3%nat (Zpred (Zpred (prec - N))))) with (3%nat * powerRZ radix (Zpred (Zpred (prec - N))))%R; [ idtac | unfold FtoRradix, FtoR in |- *; simpl in |- *; ring ]. 2: rewrite Fminus_correct; auto with zarith real. apply Sterbenz; auto with zarith. apply RoundedModeBounded with radix (Closest b radix) (3%nat * powerRZ radix (Zpred (Zpred (prec - N))) + x * alpha)%R; auto with zarith float. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl in |- *; auto with zarith. rewrite pGivesBound; apply Zlt_le_trans with (Zpower_nat radix 2); auto with zarith arith. apply Rle_trans with (FtoR radix (Float 2%nat (Zpred (Zpred (prec - N))))). unfold FtoRradix, FtoR; simpl. rewrite <- Rmult_assoc; apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (/2*(2+1+1))%R; auto with real. right; field. apply RleBoundRoundl with b prec (Closest b radix) (3%nat * powerRZ radix (Zpred (Zpred (prec - N))) + x * alpha)%R; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl in |- *; auto with zarith. rewrite pGivesBound; apply Zlt_le_trans with (Zpower_nat radix 2); auto with zarith arith. replace (FtoR radix (Float 2%nat (Zpred (Zpred (prec - N))))) with (2%nat * powerRZ radix (Zpred (Zpred (prec - N))))%R; [ auto with real | unfold FtoRradix, FtoR in |- *; simpl in |- *; ring ]. apply Rplus_le_reg_l with (-x*alpha - 2%nat * powerRZ radix (Zpred (Zpred (prec - N))))%R. simpl; ring_simplify. apply Rle_trans with (-(x*alpha))%R; auto with real. apply Rle_trans with (Rabs (-(x*alpha)));[apply RRle_abs|idtac]. rewrite Rabs_Ropp; apply Rle_trans with (1:=xalpha_small). simpl; unfold Rminus; apply Rle_trans with (powerRZ radix (Zpred (Zpred (prec - N))) +-0)%R; auto with real zarith. unfold radix; simpl; right; ring. cut (FtoR radix (Float 2%nat (Zpred (prec - N))) = (4%nat * powerRZ radix (Zpred (Zpred (prec - N))))%R); [ intros W | idtac ]. apply Rle_trans with (FtoR radix (Float 2%nat (Zpred (prec - N)))). apply RleBoundRoundr with b prec (Closest b radix) (3%nat * powerRZ radix (Zpred (Zpred (prec - N))) + x * alpha)%R; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl in |- *; auto with zarith. rewrite pGivesBound; apply Zlt_le_trans with (Zpower_nat radix 2); auto with zarith arith. apply Rle_trans with (3%nat * powerRZ radix (Zpred (Zpred (prec - N))) + powerRZ radix (Zpred (Zpred (prec - N))))%R; auto with real. apply Rplus_le_compat_l. apply Rle_trans with (Rabs (x*alpha));[apply RRle_abs|idtac]. apply Rle_trans with (1 := xalpha_small); apply Rle_trans with (powerRZ radix (Zpred (Zpred (prec - N))) - 0)%R; auto with real zarith; unfold Rminus in |- *; apply Rplus_le_compat_l; auto with real zarith. rewrite W; simpl in |- *; right; ring. rewrite W; unfold FtoR in |- *. simpl (Fexp (Float 3%nat (Zpred (Zpred (prec - N))))) in |- *. rewrite <- Rmult_assoc; apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (2%nat * 3%nat)%R; auto with zarith real. rewrite <- mult_INR; auto with zarith real. unfold FtoR in |- *; simpl in |- *. pattern (Zpred (prec - N)) at 1 in |- *; replace (Zpred (prec - N)) with (1 + Zpred (Zpred (prec - N)))%Z; [ idtac | unfold Zpred in |- *; ring ]. rewrite powerRZ_add; auto with real zarith. simpl (powerRZ 2 1) in |- *; ring. Qed. Theorem Normal_and_exp : forall (f : float) (d : Fbound) (e : Z) (p : nat), Zpos (vNum d) = Zpower_nat radix p -> 1 < p -> Fbounded d f -> (- dExp d <= e)%Z -> (powerRZ radix (Zpred p + e) <= f)%R -> (f < powerRZ radix (p + e))%R -> Fexp (Fnormalize radix d p f) = e. intros f d e p H1 H2 H3 H4 H5 H6. apply boundedNorMinGivesExp; auto with arith zarith. fold FtoRradix in |- *; apply Rle_trans with (2 := H5). right; unfold nNormMin, FtoRradix, FtoR in |- *; simpl in |- *. rewrite Zpower_nat_Z_powerRZ; rewrite powerRZ_add; auto with real zarith. rewrite inj_pred; auto with zarith arith real. apply Rle_trans with (FPred d radix p (Float (nNormMin radix p) (Zsucc e))). unfold FtoRradix in |- *; rewrite <- FnormalizeCorrect with radix d p f; auto with zarith. apply FPredProp; auto with zarith arith float. left; apply FnormalNnormMin; auto with zarith. rewrite FnormalizeCorrect; auto with zarith. fold FtoRradix in |- *; apply Rlt_le_trans with (1 := H6); unfold FtoRradix, FtoR, nNormMin in |- *; simpl in |- *. rewrite Zpower_nat_Z_powerRZ; rewrite <- powerRZ_add; auto with real zarith. right; rewrite inj_pred; auto with zarith arith real. replace (Zpred p + Zsucc e)%Z with (p + e)%Z; [ idtac | unfold Zsucc, Zpred in |- * ]; ring. right; rewrite FPredSimpl2; auto with zarith; fold FtoRradix in |- *; simpl in |- *. replace (Zpred (Zsucc e)) with e; [ auto with real | unfold Zsucc, Zpred in |- *; ring ]. cut (- dExp d < Zsucc e)%Z; auto with zarith. Qed. Theorem Fexp_u : Fexp (Fnormalize radix b prec u) = (- N)%Z. apply Normal_and_exp; auto with zarith. elim uDef; auto. apply Rle_trans with (Float 1%nat (Zpred prec + - N)); [ right; unfold FtoRradix, FtoR in |- *; simpl in |- *; ring | idtac ]. unfold FtoRradix in |- *; apply RleBoundRoundl with b prec (Closest b radix) (3%nat * powerRZ radix (Zpred (Zpred (prec - N))) + x * alpha)%R; auto with zarith float. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl in |- *; auto with zarith. rewrite pGivesBound; apply Zlt_le_trans with (Zpower_nat radix 2); auto with zarith arith. apply Rle_trans with (powerRZ radix (Zpred prec + - N))%R; [ right; unfold FtoRradix, FtoR in |- *; simpl in |- *; ring | idtac ]. apply Rle_trans with (2%nat * powerRZ radix (Zpred (Zpred (prec - N))))%R. unfold Zpred, Zminus; repeat rewrite powerRZ_add; auto with real zarith. simpl; right; field. apply Rplus_le_reg_l with (-x*alpha- 2%nat * powerRZ radix (Zpred (Zpred (prec - N))))%R; simpl; ring_simplify. apply Rle_trans with (-(x*alpha))%R; auto with real. apply Rle_trans with (Rabs (-(x*alpha)))%R; try apply RRle_abs. rewrite Rabs_Ropp;apply Rle_trans with (1:=xalpha_small). unfold Rminus, radix; simpl. apply Rle_trans with (powerRZ 2 (Zpred (Zpred (prec - N))) + - 0)%R; auto with real zarith. right; ring. apply Rle_lt_trans with (FtoRradix (Float (Zpower_nat radix prec - 1) (- N))). unfold FtoRradix in |- *; apply RleBoundRoundr with b prec (Closest b radix) (3%nat * powerRZ radix (Zpred (Zpred (prec - N))) + x * alpha)%R; auto with zarith float. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl in |- *; auto with zarith. rewrite pGivesBound; rewrite Zabs_eq; auto with zarith arith. apply Rle_trans with (3%nat * powerRZ radix (Zpred (Zpred (prec - N))) + (powerRZ radix (Zpred (Zpred (prec - N))) - powerRZ radix (- N)))%R; auto with real. apply Rplus_le_compat_l; apply Rle_trans with (Rabs (x*alpha)); auto. apply RRle_abs. right; unfold FtoR in |- *; simpl in |- *. rewrite <- Z_R_minus; rewrite Zpower_nat_Z_powerRZ; ring_simplify. rewrite <- powerRZ_add; auto with real zarith. replace (- N + prec)%Z with (2 + Zpred (Zpred (prec - N)))%Z; [ idtac | unfold Zpred in |- *; ring ]. rewrite powerRZ_add; auto with real zarith; simpl in |- *; ring. unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite <- Z_R_minus; rewrite Zpower_nat_Z_powerRZ. ring_simplify ((powerRZ radix prec - 1%Z) * powerRZ 2 (- N))%R. simpl in |- *; rewrite <- powerRZ_add; auto with real zarith; rewrite Zplus_comm. unfold Rminus; apply Rlt_le_trans with ( powerRZ 2 (- N+prec)+-0)%R; auto with real zarith. apply Rplus_lt_compat_l; apply Ropp_lt_contravar. ring_simplify; auto with real zarith. right; ring. Qed. Theorem Normal_and_exp2 : forall (f : float) (d : Fbound) (e m : Z) (p : nat), Zpos (vNum d) = Zpower_nat radix p -> 1 < p -> (- dExp d <= e)%Z -> f = Float m e :>R -> (powerRZ radix (Zpred p + e) <= Rabs f)%R -> (Rabs f < powerRZ radix (p + e))%R -> ex (fun g : float => g = f :>R /\ Fnormal radix d g /\ Fexp g = e). intros f d e m p H1 H2 H3 H4 H5 H6. cut (Fbounded d (Float m e)); [ intros H7 | idtac ]. exists (Float m e). split; auto with real; split; auto; split; auto. rewrite H1; simpl (Fnum (Float m e)) in |- *. rewrite Zabs_Zmult; rewrite Zabs_eq; auto with zarith. apply le_IZR; rewrite Zpower_nat_Z_powerRZ; rewrite mult_IZR. apply Rmult_le_reg_l with (powerRZ radix (Zpred e)); auto with real zarith. rewrite <- powerRZ_add; auto with real zarith. replace (Zpred e + p)%Z with (Zpred p + e)%Z; [ idtac | unfold Zpred in |- *; ring ]. rewrite <- Rabs_Zabs. apply Rle_trans with (1 := H5); rewrite H4; unfold FtoRradix, FtoR in |- *; simpl in |- *. rewrite Rabs_mult; rewrite Rabs_right with (powerRZ 2 e);[idtac| apply Rle_ge; auto with real zarith]. pattern e at 1 in |- *; replace e with (1 + Zpred e)%Z; [ idtac | unfold Zpred in |- *; ring ]. rewrite powerRZ_add; auto with zarith real; simpl in |- *; right; ring. split; auto with zarith. rewrite H1; simpl (Fnum (Float m e)) in |- *. apply lt_IZR; rewrite Zpower_nat_Z_powerRZ. apply Rmult_lt_reg_l with (powerRZ radix e); auto with real zarith. rewrite <- powerRZ_add; auto with real zarith. rewrite Zplus_comm; apply Rle_lt_trans with (2 := H6); rewrite H4. unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith. unfold Fabs, FtoR in |- *; simpl in |- *; right; ring. Qed. Theorem u_bounds : (2%nat * powerRZ radix (Zpred (Zpred (prec - N))) + powerRZ radix (- N) <= u)%R /\ (u <= powerRZ radix (prec - N) - powerRZ radix (- N))%R. split. apply Rle_trans with (FtoRradix (Float (Zpower_nat radix (prec-1) + 1) (- N))). right; unfold FtoRradix, FtoR in |- *; simpl in |- *. rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ; ring_simplify. rewrite <- powerRZ_add; auto with real zarith. replace (- N + (prec-1)%nat)%Z with (1 + Zpred (Zpred (prec - N)))%Z. rewrite powerRZ_add; auto with real zarith; simpl in |- *; ring. apply trans_eq with (-N+pred prec)%Z; auto with zarith. rewrite inj_pred; auto with zarith; unfold Zpred; ring. unfold FtoRradix in |- *; apply RleBoundRoundl with b prec (Closest b radix) (3%nat * powerRZ radix (Zpred (Zpred (prec - N))) + x * alpha)%R; auto with zarith float. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl in |- *; auto with zarith. rewrite pGivesBound; rewrite Zabs_eq; auto with zarith arith. apply Zlt_le_trans with (Zpower_nat radix (prec - 1)+Zpower_nat radix (prec - 1))%Z; auto with zarith. assert (1 < Zpower_nat radix (prec - 1))%Z; auto with zarith. apply Zle_lt_trans with (Zpower_nat radix 0); auto with zarith. pattern prec at 3; replace prec with (1+(prec-1))%nat; auto with zarith. rewrite Zpower_nat_is_exp. replace (Zpower_nat radix 1) with 2%Z; auto with zarith. apply Rle_trans with (3%nat * powerRZ radix (Zpred (Zpred (prec - N))) - (powerRZ radix (Zpred (Zpred (prec - N))) - powerRZ radix (- N)))%R; auto with real. unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ. simpl; ring_simplify. rewrite Rplus_comm; apply Rplus_le_compat_l. replace (Z_of_nat (prec -1)%nat) with (prec -1)%Z; auto with zarith. unfold Zpred, Zminus; repeat rewrite powerRZ_add; auto with real zarith. simpl; right; field; auto with real. apply trans_eq with (Z_of_nat (pred prec)); auto with zarith. rewrite inj_pred; auto with zarith. unfold Rminus; apply Rplus_le_compat_l. apply Rle_trans with (-(-(x*alpha)))%R; auto with real. apply Ropp_le_contravar. apply Rle_trans with (Rabs (-(x*alpha))); try apply RRle_abs; rewrite Rabs_Ropp. apply Rle_trans with (1:=xalpha_small); auto with real. apply Rle_trans with (FtoRradix (Float (Zpower_nat radix prec - 1) (- N))). unfold FtoRradix in |- *; apply RleBoundRoundr with b prec (Closest b radix) (3%nat * powerRZ radix (Zpred (Zpred (prec - N))) + x * alpha)%R; auto with zarith float. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl in |- *; auto with zarith. rewrite pGivesBound; rewrite Zabs_eq; auto with zarith arith. apply Rle_trans with (3%nat * powerRZ radix (Zpred (Zpred (prec - N))) + (powerRZ radix (Zpred (Zpred (prec - N))) - powerRZ radix (- N)))%R; auto with real. apply Rplus_le_compat_l; apply Rle_trans with (Rabs (x*alpha)); auto. apply RRle_abs. right; unfold FtoR in |- *; simpl in |- *. rewrite <- Z_R_minus; rewrite Zpower_nat_Z_powerRZ; ring_simplify. rewrite <- powerRZ_add; auto with real zarith. replace (- N + prec)%Z with (2 + Zpred (Zpred (prec - N)))%Z; [ idtac | unfold Zpred in |- *; ring ]. rewrite powerRZ_add; auto with real zarith; simpl in |- *; ring. unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite <- Z_R_minus; rewrite Zpower_nat_Z_powerRZ. simpl (IZR 1). ring_simplify ((powerRZ radix prec - 1) * powerRZ 2 (- N))%R. simpl in |- *; rewrite <- powerRZ_add; auto with real zarith; rewrite Zplus_comm. Qed. Theorem exists_k : ex (fun k : Z => (powerRZ radix k <= Rabs zH1)%R /\ (Rabs zH1 < powerRZ radix (Zsucc k))%R /\ (Zsucc (k + N) <= Zpred (Zpred prec))%Z /\ (0 <= Zsucc (k + N))%Z /\ 1 < Zabs_nat (Zsucc (k + N)) /\ (2 <= Zsucc (k + N))%Z). generalize u_bounds; intros T; elim T; intros H'1 H'2; clear T. exists (pred (digit radix (Fnum zH1)) + Fexp zH1)%Z. cut (powerRZ radix (pred (digit radix (Fnum zH1)) + Fexp zH1) <= Rabs zH1)%R; [ intros H2 | idtac ]. cut (Rabs zH1 < powerRZ radix (Zsucc (pred (digit radix (Fnum zH1)) + Fexp zH1)))%R; [ intros H3 | idtac ]. 2: replace (Zsucc (pred (digit radix (Fnum zH1)) + Fexp zH1)) with (Zsucc (pred (digit radix (Fnum zH1))) + Fexp zH1)%Z; [ idtac | unfold Zsucc in |- *; ring ]. 2: rewrite powerRZ_add; auto with real zarith. 2: unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith; unfold Fabs, FtoR in |- *; simpl. 2: apply Rmult_lt_compat_r; auto with real zarith. 2: replace (Zsucc (pred (digit radix (Fnum zH1)))) with (Z_of_nat (S (pred (digit radix (Fnum zH1))))); auto with arith zarith. 2: replace 2%R with (IZR radix); auto with real zarith. 2: rewrite <- Zpower_nat_Z_powerRZ; apply Rlt_IZR. 2: apply Zlt_le_trans with (Zpower_nat radix (digit radix (Fnum zH1))); auto with arith zarith. 2: unfold Zsucc in |- *; replace 1%Z with (Z_of_nat 1); auto with arith zarith. 2: rewrite <- inj_plus; auto with arith zarith. split; auto. split; auto. split. apply Zgt_le_succ; apply Zlt_gt. apply Zplus_lt_reg_r with (- N)%Z. replace (pred (digit radix (Fnum zH1)) + Fexp zH1 + N + - N)%Z with (pred (digit radix (Fnum zH1)) + Fexp zH1)%Z; [ idtac | ring ]. apply Zlt_powerRZ with radix; auto with real zarith. apply Rle_lt_trans with (1 := H2); rewrite zH1_eq. unfold Rabs; case Rcase_abs; intros. apply Rplus_lt_reg_r with (u-powerRZ radix (Zpred (Zpred prec) + - N))%R; ring_simplify. apply Rlt_le_trans with (2:=H'1). apply Rle_lt_trans with (2%nat * powerRZ radix (Zpred (Zpred (prec - N))) + 0)%R;[right|auto with real zarith]. replace (Zpred (Zpred prec) + - N)%Z with (Zpred (Zpred (prec - N))); [idtac|unfold Zpred]; simpl; ring. apply Rplus_lt_reg_r with (3%nat * powerRZ radix (Zpred (Zpred (prec - N))))%R. ring_simplify (3%nat * powerRZ radix (Zpred (Zpred (prec - N))) + (u - 3%nat * powerRZ radix (Zpred (Zpred (prec - N)))))%R. apply Rle_lt_trans with (1 := H'2). apply Rlt_le_trans with (powerRZ radix (prec - N) - 0)%R; auto with real zarith. unfold Rminus in |- *; apply Rplus_lt_compat_l; auto with real zarith. right; replace (Zpred (Zpred prec) + - N)%Z with (Zpred (Zpred (prec - N))); [ idtac | unfold Zpred in |- *; ring ]. pattern (prec - N)%Z at 1 in |- *; replace (prec - N)%Z with (2 + Zpred (Zpred (prec - N)))%Z; [ idtac | unfold Zpred in |- *; ring ]. rewrite powerRZ_add; auto with real zarith; simpl in |- *; ring. cut (2 <= Zsucc (pred (digit radix (Fnum zH1)) + Fexp zH1 + N))%Z; [ intros H4 | idtac ]. split; auto with zarith. split; auto. apply lt_Zlt_inv; rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. replace (Zsucc (pred (digit radix (Fnum zH1)) + Fexp zH1 + N)) with (Zsucc (pred (digit radix (Fnum zH1)) + Fexp zH1) + N)%Z; [ idtac | unfold Zsucc in |- *; ring ]. replace 2%Z with (Zsucc 1); [ idtac | unfold Zsucc in |- *; ring ]. apply Zgt_le_succ; apply Zlt_gt. apply Zplus_lt_reg_l with (- N)%Z. ring_simplify (- N + (Zsucc (pred (digit radix (Fnum zH1)) + Fexp zH1) + N))%Z. replace (- N + 1)%Z with (Zsucc (- N)); [ idtac | unfold Zsucc in |- *; ring ]. apply Zlt_powerRZ with radix; auto with real zarith. apply Rle_lt_trans with (2 := H3). apply Rle_trans with (2:=zH_not_too_small). apply Rle_powerRZ; unfold Zsucc; auto with real zarith. unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith. unfold Fabs, FtoR in |- *; rewrite powerRZ_add; auto with real zarith; simpl. apply Rmult_le_compat_r; auto with real zarith. replace 2%R with (IZR radix); auto with real zarith. rewrite <- Zpower_nat_Z_powerRZ; apply Rle_IZR. apply digitLess. unfold not; intros. Contradict zH_not_too_small. apply Rlt_not_le; apply Rle_lt_trans with 0%R; auto with real. replace (FtoRradix zH1) with 0%R. rewrite Rabs_R0; auto with real. unfold FtoRradix, FtoR; rewrite H; simpl; ring. Qed. (** Not very readable, I know, but those are the hypotheses I will need to make things go right when calling the previous theorem. This is the theorem stating the correctness of the algorithm computing z. *) Theorem arg_reduct_exists_k_zH : ex (fun k : Z => ex (fun zH : float => zH1 = zH :>R /\ (Zsucc (k + N) <= Zpred (Zpred prec))%Z /\ (0 <= Zsucc (k + N))%Z /\ 1 < Zabs_nat (Zsucc (k + N)) /\ N = (- Fexp zH)%Z /\ Fnormal radix (bzH k) zH /\ (Rabs (x * alpha - zH) <= powerRZ radix (Zpred (- N)))%R /\ (powerRZ radix k <= Rabs zH1)%R /\ (Rabs zH1 < powerRZ radix (Zsucc k))%R)). generalize exists_k; intros T1. elim T1; intros k T2; elim T2; intros H1 T3; elim T3; intros H2 T4; elim T4; intros H3 T5; elim T5; intros H4 T6; elim T6; intros H5 H6; clear T1 T2 T3 T4 T5 T6. generalize (Normal_and_exp2 zH1 (bzH k) (- N) (Fnum (Fnormalize radix b prec u) - 3%nat * Zpower_nat radix (pred (pred prec))) ( Zabs_nat (Zsucc (k + N)))); intros T. lapply T; auto with zarith; intros T1; clear T. lapply T1; auto with zarith; intros T; clear T1. lapply T; auto with zarith; intros T1; clear T. lapply T1; auto with zarith; [ intros T; clear T1 | idtac ]. lapply T; auto with zarith; [ intros T1; clear T | idtac ]. lapply T1; auto with zarith; [ intros T; clear T1 | idtac ]. elim T; intros zH T1. elim T1; intros H9 T2; elim T2; intros H10 H11; clear T T1 T2. exists k; exists zH. split; auto with real. split; auto with zarith. split; auto. split; auto. split; auto with zarith. split; auto. split; auto. 2: rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. 2: replace (Zsucc (k + N) + - N)%Z with (Zsucc k); [ auto with real | unfold Zsucc in |- *; ring ]. 2: rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. 2: replace (Zpred (Zsucc (k + N)) + - N)%Z with k; [ auto with real | unfold Zsucc, Zpred in |- *; ring ]. 2: rewrite zH1_eq; unfold FtoRradix in |- *; rewrite <- FnormalizeCorrect with radix b prec u; auto with zarith; unfold FtoR in |- *. 2: apply trans_eq with ((Fnum (Fnormalize radix b prec u) - 3%nat * Zpower_nat radix (pred (pred prec)))%Z * powerRZ radix (- N))%R; [ idtac | simpl in |- *; auto with real ]. 2: rewrite Fexp_u; unfold Zminus in |- *; rewrite plus_IZR; rewrite Ropp_Ropp_IZR; rewrite mult_IZR; rewrite Zpower_nat_Z_powerRZ. 2: ring_simplify. 2: replace (Zpred (Zpred (prec + - N))) with (-N+ (pred (pred prec)))%Z. 2: rewrite powerRZ_add; auto with real zarith. 2: simpl; ring. 2: rewrite inj_pred; auto with zarith; rewrite inj_pred; auto with zarith. rewrite H9; rewrite zH1_eq. replace (x * alpha - (u - 3%nat * powerRZ radix (Zpred (Zpred (prec - N)))))%R with (3%nat * powerRZ radix (Zpred (Zpred (prec - N))) + x * alpha - u)%R; [ idtac | ring ]. apply Rmult_le_reg_l with (INR 2); auto with arith real. apply Rle_trans with (Fulp b radix prec u). unfold FtoRradix in |- *; apply ClosestUlp; auto with zarith. unfold Fulp in |- *; rewrite Fexp_u. pattern (- N)%Z at 1 in |- *; replace (- N)%Z with (1 + Zpred (- N))%Z; [ idtac | unfold Zpred in |- *; ring ]. rewrite powerRZ_add; auto with real zarith; right; simpl in |- *; ring. Qed. End Algo. Section Total. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. (** Variables *) Variable b : Fbound. Variables prec q : nat. Variable N : Z. Variables alpha gamma x zH1 u : float. Variable zL : R. Let bmoinsq := Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (prec - q))))) (dExp b). (** All the hypotheses *) Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix prec. Hypothesis Fboundedx : Fbounded b x. (** alpha (the constant, such as pi) and gamma (its inverse) *) Hypothesis alphaNormal : Fnormal radix b alpha. Hypothesis gammaNormal : Fnormal radix bmoinsq gamma. Hypothesis alphaPos : (0 < alpha)%R. Hypothesis gammaPos : (0 < gamma)%R. Hypothesis gamma_not_pow_2 : forall e : Z, FtoRradix gamma <> powerRZ radix e. (** About q *) Hypothesis pMoinsqGreaterThanOne : 1 < prec - q. Hypothesis q_enough : (2 <= q)%Z. Hypothesis gammaDef : Closest bmoinsq radix (/ alpha) gamma. (** About the computation of z *) Hypothesis uDef : Closest b radix (3%nat * powerRZ radix (Zpred (Zpred (prec - N))) + x * alpha) u. Hypothesis zH1Def : Closest b radix (u - 3%nat * powerRZ radix (Zpred (Zpred (prec - N)))) zH1. Hypothesis precMoreThanThree : 3 < prec. Hypothesis N_not_too_big : (N <= dExp b)%Z. (** x not too big *) Hypothesis xalpha_small : (Rabs (x * alpha) <= powerRZ radix (Zpred (Zpred (prec - N))) - powerRZ radix (- N))%R. (** No underflow *) Hypothesis gamma_ge: (powerRZ radix (-dExp b+prec -q +(Zmax 1 (N-1)))<= gamma)%R. Lemma Sterbenzbis: forall (x y :float), Fbounded b x -> Fbounded b y -> (/ S 1 * y <= x)%R -> (x <= S 1 * y)%R -> Fbounded b (Fminus radix x y) /\ (Rabs (x - y) <= y)%R. intros; split. apply Sterbenz; auto with zarith. assert (0 <= y)%R. case (Rle_or_lt 0 y); auto; intros. absurd (y <= 4*y)%R. apply Rlt_not_le. apply Rle_lt_trans with (y+3*y)%R;[right; ring|idtac]. apply Rlt_le_trans with (y+0)%R;[apply Rplus_lt_compat_l; auto with real|right; ring]. apply Rlt_le_trans with (3*0)%R; auto with real. apply Rmult_lt_compat_l; auto with real. apply Rlt_trans with 2%R; auto with real. apply Rmult_le_reg_l with (/(INR 2))%R; auto with real zarith. apply Rle_trans with (1:=H1). apply Rle_trans with (1:=H2); right; simpl; field; auto with real. case (Rle_or_lt x0 y); intros. rewrite Rabs_left1. apply Rplus_le_reg_l with (x0-y)%R. apply Rle_trans with 0%R;[right; ring|idtac]. apply Rle_trans with x0;[idtac| right; ring]. apply Rle_trans with (2:=H1); auto with real zarith. apply Rle_trans with (0*y)%R;[right; ring|apply Rmult_le_compat_r; auto with real]. apply Rplus_le_reg_l with y; apply Rle_trans with x0; auto with real. apply Rle_trans with y; auto with real. rewrite Rabs_right. apply Rplus_le_reg_l with y; apply Rle_trans with x0; auto with real. apply Rle_trans with (1:=H2); right; simpl; ring. apply Rle_ge; apply Rplus_le_reg_l with y; apply Rle_trans with y; auto with real. apply Rle_trans with x0; auto with real. Qed. Lemma Sterbenzter: forall (x y :float), Fbounded b x -> Fbounded b y -> (/ S 1 * Rabs y <= Rabs x)%R -> (Rabs x <= S 1 * Rabs y)%R -> (0 <= x*y)%R -> Fbounded b (Fminus radix x y) /\ (Rabs (x - y) <= Rabs y)%R. intros r1 r2; intros. case (Rle_or_lt 0 r1); case (Rle_or_lt 0 r2); intros. rewrite (Rabs_right r2); try apply Rle_ge; auto with real. apply Sterbenzbis; auto. rewrite Rabs_right in H1; rewrite Rabs_right in H1; try apply Rle_ge; auto with real. rewrite Rabs_right in H2; rewrite Rabs_right in H2; try apply Rle_ge; auto with real. case H5; intros. Contradict H3; auto with real. apply Rlt_not_le; apply Rlt_le_trans with (r1*0)%R; auto with real. assert (FtoRradix r2=0)%R. assert (Rabs r2=0)%R; auto with real. assert (Rabs r2 <=0)%R; auto with real. apply Rmult_le_reg_l with (/2%nat)%R; auto with real zarith. apply Rle_trans with (1:=H1); rewrite <- H6; rewrite Rabs_R0; right; ring. case (Req_dec r2 0); auto. intros; Contradict H7; apply Rabs_no_R0; auto. rewrite (Rabs_right r2). apply Sterbenzbis; auto. rewrite <- H6; rewrite H7; auto with real. rewrite <- H6; rewrite H7; auto with real. rewrite H7; auto with real. case H4; intros. Contradict H3; auto with real. apply Rlt_not_le; apply Rlt_le_trans with (0*r2)%R; auto with real. assert (FtoRradix r1=0)%R. assert (Rabs r1=0)%R; auto with real. assert (Rabs r1 <=0)%R; auto with real. apply Rle_trans with (1:=H2); rewrite <- H6; rewrite Rabs_R0; right; ring. case (Req_dec r1 0); auto. intros; Contradict H7; apply Rabs_no_R0; auto. rewrite (Rabs_right r2). apply Sterbenzbis; auto. rewrite <- H6; rewrite H7; auto with real. rewrite <- H6; rewrite H7; auto with real. rewrite <- H6; auto with real. assert (Fbounded b (Fminus radix (Fopp r1) (Fopp r2)) /\ (Rabs (Fopp r1 - Fopp r2) <= (Fopp r2))%R). apply Sterbenzbis; auto with zarith float. unfold FtoRradix; repeat rewrite Fopp_correct; fold FtoRradix. rewrite Rabs_left1 in H1; rewrite Rabs_left1 in H1; auto with real. unfold FtoRradix; repeat rewrite Fopp_correct; fold FtoRradix. rewrite Rabs_left1 in H2; rewrite Rabs_left1 in H2; auto with real. elim H6; intros; split. apply oppBoundedInv. rewrite Fopp_Fminus_dist; auto with zarith float. replace (r1-r2)%R with (-(Fopp r1-Fopp r2))%R. rewrite Rabs_Ropp; apply Rle_trans with (1:=H8). right; rewrite Rabs_left1; auto with real. unfold FtoRradix; rewrite Fopp_correct; auto. unfold FtoRradix; repeat rewrite Fopp_correct; ring. Qed. (** Main result: q can be anything but we need alpha * gamma <= 1 *) Theorem Fmac_arg_reduct_correct2 : (alpha * gamma <= 1)%R -> ex (fun u : float => FtoRradix u = (x - zH1 * gamma)%R /\ Fbounded b u) /\ (Rabs (x-zH1*gamma) < powerRZ radix (prec-N+Fexp gamma))%R. assert (J:(- dExp b <= Zsucc q + - (Fexp alpha + (prec + prec)))%Z). assert (prec-1+Fexp alpha <= dExp b+q-prec)%Z; unfold Zsucc; auto with zarith. apply Zle_powerRZ with radix; auto with real zarith. apply Rle_trans with alpha. rewrite powerRZ_add; auto with real zarith. unfold FtoRradix, FtoR; apply Rmult_le_compat_r; auto with real zarith. elim alphaNormal; intros. apply Rmult_le_reg_l with radix; auto with real zarith. apply Rle_trans with (Zpos (vNum b)). rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ. right; unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl. ring_simplify (2*1)%R; field; auto with real. apply Rle_trans with ( Zabs (radix * Fnum alpha)); auto with real zarith. rewrite Zabs_eq; auto with real zarith. rewrite mult_IZR; auto with real. assert (0 < Fnum alpha)%Z; auto with zarith real float. apply LtR0Fnum with radix; auto with real zarith. case (Rle_or_lt alpha (powerRZ radix (dExp b + q - prec))); auto with real. intros V. absurd (powerRZ radix (- dExp b + prec - q+1) <= gamma)%R. apply Rlt_not_le. assert (exists f:float, Fbounded bmoinsq f /\ (FtoRradix f= powerRZ radix (- dExp b+prec-q))%R). exists (Float 1 (-dExp b+prec-q)). split;[split|idtac]. apply Zle_lt_trans with (Zabs 1); auto with zarith. rewrite Zabs_eq; auto with zarith. unfold bmoinsq; rewrite vNum_eq_Zpower_bmoinsq; auto with zarith. apply Zle_lt_trans with (Zpower_nat 2 0); auto with zarith. simpl; auto with zarith. unfold FtoRradix, FtoR; simpl; ring. elim H; intros f H''; elim H''; intros I1 I2; clear H H''. apply Rle_lt_trans with (FtoRradix f). unfold FtoRradix; apply RleBoundRoundr with bmoinsq (prec-q) (Closest bmoinsq radix) (/alpha)%R; auto with real zarith float. unfold bmoinsq; apply vNum_eq_Zpower_bmoinsq; auto. apply ClosestRoundedModeP with (prec-q); auto with zarith. unfold bmoinsq; apply vNum_eq_Zpower_bmoinsq; auto. fold FtoRradix; rewrite I2. apply Rle_trans with (/(powerRZ radix (dExp b + q - prec)))%R. apply Rle_Rinv; auto with real zarith. rewrite Rinv_powerRZ; auto with real zarith. replace (- (dExp b + q - prec))%Z with (- dExp b + prec - q)%Z; auto with real zarith. rewrite I2; auto with real zarith. apply Rle_trans with (2:=gamma_ge). apply Rle_powerRZ; auto with real zarith. intros G. case (Req_dec zH1 0); intros H1. split. exists x; split; auto with real. rewrite H1; ring. replace (x-zH1*gamma)%R with (FtoRradix x);[idtac|rewrite H1; ring]. apply Rmult_lt_reg_l with alpha; auto. apply Rle_lt_trans with (Rabs (x*alpha-zH1)). right; replace (x*alpha-zH1)%R with (x*alpha)%R; auto with real. rewrite Rabs_mult; rewrite (Rabs_right alpha); try apply Rle_ge; auto with real. rewrite H1; ring. apply Rle_lt_trans with (powerRZ radix (Zpred (-N))). replace (x*alpha-zH1)%R with ((S 2 * powerRZ radix (Zpred (Zpred (prec - N))) + x * alpha)-u)%R. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp b radix prec u). unfold FtoRradix; apply ClosestUlp; auto with zarith. unfold Fulp,radix; rewrite Fexp_u with b prec N alpha x u; auto with zarith. unfold Zpred; rewrite powerRZ_add; auto with real zarith; right. simpl; field; auto with real. ring_simplify (2*1)%R; auto with real. unfold FtoRradix, radix;rewrite zH1_eq with b prec N alpha x u zH1; auto with real zarith. ring. replace (Zpred (-N)) with ((-Fexp gamma-1-prec)+(prec-N+Fexp gamma))%Z; [idtac|unfold Zpred; ring]. rewrite powerRZ_add; auto with real zarith. apply Rmult_lt_compat_r; auto with real zarith. replace (- Fexp gamma - 1 - prec)%Z with ((-q-2+prec) +Fexp alpha)%Z;[idtac| rewrite gamma_exp with b prec q alpha gamma; auto with zarith; unfold Zsucc; ring]. apply Rlt_le_trans with (Zpos (vNum b) * (Float (S 0) (Zpred (Fexp alpha))))%R. apply Rlt_le_trans with (powerRZ radix (prec+Fexp alpha-1)); auto with real zarith. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ. unfold FtoRradix, FtoR; simpl; right;ring_simplify. unfold Zpred, Zminus; repeat rewrite powerRZ_add; auto with real zarith; ring. apply Rle_trans with (Fabs alpha). unfold FtoRradix; apply FnormalBoundAbs2 with prec; auto with zarith. unfold FtoRradix; rewrite Fabs_correct; auto with zarith; rewrite Rabs_right; try apply Rle_ge; auto with zarith real. case (Rle_or_lt (powerRZ radix (q - Zsucc N)) (Rabs zH1)); intros H'. cut (exists k : Z, (exists zH : float, FtoR 2 zH1 = FtoR 2 zH /\ (Zsucc (k + N) <= Zpred (Zpred prec))%Z /\ (0 <= Zsucc (k + N))%Z /\ 1 < Zabs_nat (Zsucc (k + N)) /\ N = (- Fexp zH)%Z /\ Fnormal 2 ((fun k0 : Z => Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat 2 (Zabs_nat (Zsucc (k0 + N))))))) (dExp b)) k) zH /\ (Rabs (FtoR 2 x * FtoR 2 alpha - FtoR 2 zH) <= powerRZ 2%Z (Zpred (- N)))%R /\ (powerRZ 2%Z k <= Rabs (FtoR 2 zH1) < powerRZ 2%Z (Zsucc k))%R)). 2: apply arg_reduct_exists_k_zH with u; auto with real zarith. fold radix FtoRradix in |- *. intros T1; elim T1; intros k T2; elim T2; intros zH T3; elim T3; intros H3 T4; elim T4; intros H4 T5; elim T5; intros H5 T6; elim T6; intros H6 T7; elim T7; intros H7 T8; elim T8; intros H8 T9; elim T9; intros H9 T10; elim T10; intros H10 H11; clear T1 T2 T3 T4 T5 T6 T7 T8 T9 T10. rewrite H3. apply Fmac_arg_reduct_correct1 with q k alpha (x * alpha - zH)%R; auto with zarith real arith. assert (1 < Zabs (Zsucc (k+N)))%Z; auto with zarith. rewrite Zabs_absolu; auto with zarith. rewrite Zabs_eq in H; auto with zarith. apply Zplus_le_reg_l with (- Zsucc N)%Z. replace (- Zsucc N + q)%Z with (q - Zsucc N)%Z; [ idtac | ring ]; replace (- Zsucc N + Zsucc (k + N))%Z with k; [ idtac | unfold Zsucc in |- *; ring ]. apply Zgt_succ_le; apply Zlt_gt. apply Zlt_powerRZ with radix; auto with zarith real; apply Rle_lt_trans with (1 := H'); auto. fold radix FtoRradix in |- *; apply Rle_trans with (2 := H'); auto with real zarith. apply Rle_powerRZ; unfold radix in |- *; auto with real zarith. cut (exists zH : float, FtoRradix zH1 = zH /\ Fexp zH = (- N)%Z /\ (Zabs (Fnum zH) < powerRZ radix (Zpred q))%R /\ (0 < Rabs zH)%R). intros V; elim V; intros zH V1; elim V1; intros H2 V2; elim V2; intros H3 V3; elim V3; intros H4 H5; clear V V1 V2 V3. assert ((Fbounded b (Fminus radix x (Fmult zH gamma)) /\ (Rabs (x - (Fmult zH gamma)) <= Rabs (Fmult zH gamma))%R)). apply Sterbenzter; auto with zarith. split; unfold Fmult in |- *; simpl in |- *. apply Zlt_Rlt; rewrite <- Faux.Rabsolu_Zabs; rewrite Rmult_IZR; rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ. replace (Z_of_nat prec) with (q + (prec - q)%nat)%Z; [ rewrite powerRZ_add | rewrite inj_minus1 ]; auto with arith zarith real. rewrite Rabs_mult; apply Rmult_le_0_lt_compat; auto with real. rewrite Rabs_Zabs; apply Rlt_trans with (1 := H4); auto with real zarith. apply Rlt_le_trans with (IZR (Zpos (vNum bmoinsq))); auto with real zarith. rewrite Faux.Rabsolu_Zabs; elim gammaNormal; intros T1 T2; elim T1; intros T3 T4; auto with real zarith. right; unfold bmoinsq in |- *; rewrite vNum_eq_Zpower_bmoinsq; auto with real zarith. rewrite Zpower_nat_Z_powerRZ; auto with real zarith. assert (- dExp b + prec -q + N - 1 < prec-q + Fexp gamma)%Z; auto with zarith. apply Zle_lt_trans with (- dExp b + prec -q + Zmax 1 (N - 1))%Z; auto with zarith. unfold Zminus; repeat rewrite <- Zplus_assoc; repeat apply Zplus_le_compat_l; auto with zarith. apply Zlt_powerRZ with radix; auto with real zarith. apply Rle_lt_trans with (1:=gamma_ge). rewrite powerRZ_add; auto with real zarith. unfold FtoRradix, FtoR; apply Rmult_lt_compat_r; auto with real zarith. apply Rle_lt_trans with (Zabs (Fnum gamma)); auto with real zarith. apply Rlt_le_trans with (Zpos (vNum (bmoinsq))). elim gammaNormal; intros I1 I2; elim I1; intros; auto with zarith real. unfold bmoinsq; rewrite vNum_eq_Zpower_bmoinsq. rewrite Zpower_nat_Z_powerRZ; auto with real zarith. rewrite minus_Zminus_precq; auto with real zarith. unfold FtoRradix; rewrite Fmult_correct; auto with zarith; fold FtoRradix in |- *; apply Rmult_le_reg_l with alpha; auto with real. rewrite Rabs_mult; rewrite Rabs_right with gamma; try apply Rle_ge; auto with real. apply Rle_trans with (/ 2%nat * Rabs zH * (alpha * gamma))%R; [ right; ring | idtac ]. apply Rle_trans with (/ 2%nat * Rabs zH * 1)%R; [ apply Rmult_le_compat_l; auto | idtac ]. apply Rmult_le_pos; auto with real zarith arith real. apply Rplus_le_reg_l with (/ 2%nat * Rabs zH - alpha * Rabs x)%R. ring_simplify. apply Rle_trans with (Rabs zH - Rabs x * alpha)%R; [ right | idtac ]. simpl; field; auto with real. replace (Rabs x*alpha)%R with (Rabs (x*alpha));[idtac|rewrite Rabs_mult; rewrite Rabs_right with alpha; try apply Rle_ge; auto with real]. apply Rle_trans with (Rabs (zH - x * alpha)); [ apply Rabs_triang_inv | idtac ]. rewrite <- H2; unfold FtoRradix, radix in |- *; rewrite zH1_eq with b prec N alpha x u zH1; auto with real zarith. fold radix FtoRradix in |- *; rewrite <- Rabs_Ropp. replace (- (u - 3%nat * powerRZ radix (Zpred (Zpred (prec - N))) - x * alpha))%R with (3%nat * powerRZ radix (Zpred (Zpred (prec - N))) + x * alpha - u)%R; [ idtac | ring ]. apply Rmult_le_reg_l with (INR 2); auto with real arith. apply Rle_trans with (Fulp b radix prec u). unfold FtoRradix in |- *; apply ClosestUlp; auto with zarith real. rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real zarith. unfold Fulp, radix in |- *; rewrite Fexp_u with b prec N alpha x u; auto with real zarith. unfold FtoRradix, radix in |- *; rewrite <- zH1_eq with b prec N alpha x u zH1; auto with real zarith. fold radix FtoRradix in |- *; rewrite H2; rewrite <- H3; fold radix in |- *; unfold FtoRradix, FtoR in |- *; auto with real zarith. apply Rle_trans with (1 * (1 * powerRZ radix (Fexp zH)))%R; [ right; ring | idtac ]. rewrite Rabs_mult. rewrite Rabs_right with (powerRZ radix (Fexp zH)); try apply Rle_ge; auto with real zarith. apply Rmult_le_compat_l; auto with real; apply Rmult_le_compat_r; auto with real zarith. rewrite Rabs_Zabs. cut (0 < Zabs (Fnum zH))%Z; auto with real float zarith. apply Zlt_le_trans with (Fnum (Fabs (zH))); auto with zarith. apply LtR0Fnum with radix; auto with real zarith. rewrite Fabs_correct; auto with real zarith. unfold FtoRradix; rewrite Fmult_correct; auto with zarith; fold FtoRradix in |- *; apply Rmult_le_reg_l with alpha; auto with real. apply Rplus_le_reg_l with (- Rabs zH)%R. replace (alpha*Rabs x)%R with (Rabs (x*alpha));[idtac| rewrite Rabs_mult; rewrite (Rabs_right alpha); try apply Rle_ge; auto with real]. apply Rle_trans with (Rabs (x * alpha) - Rabs zH)%R; [ right; ring | idtac ]. apply Rle_trans with (Rabs (x * alpha - zH)); [ apply Rabs_triang_inv | idtac ]. pattern (FtoRradix zH) at 1 in |- *; rewrite <- H2. unfold FtoRradix, radix in |- *; rewrite zH1_eq with b prec N alpha x u zH1; auto with real zarith. fold radix FtoRradix in |- *. replace (x * alpha - (u - 3%nat * powerRZ radix (Zpred (Zpred (prec - N)))))%R with (3%nat * powerRZ radix (Zpred (Zpred (prec - N))) + x * alpha - u)%R; [ idtac | ring ]. apply Rmult_le_reg_l with (INR 2); auto with real arith. apply Rle_trans with (Fulp b radix prec u). unfold FtoRradix in |- *; apply ClosestUlp; auto with zarith real. unfold Fulp, radix in |- *; rewrite Fexp_u with b prec N alpha x u; auto with real zarith; fold radix in |- *. apply Rle_trans with (2%nat * Rabs zH * (2%nat * (alpha * gamma) - 1))%R; [ idtac | rewrite Rabs_mult; rewrite (Rabs_right gamma); try apply Rle_ge; auto with real; right; ring ]. apply Rle_trans with (powerRZ radix (- N) * (2%nat * (2%nat * (alpha * gamma) - 1)))%R. apply Rle_trans with (powerRZ radix (- N) * 1)%R; auto with real. apply Rmult_le_compat_l; auto with real zarith. apply Rmult_le_reg_l with (/ INR 2)%R; auto with real arith. rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real arith. ring_simplify. apply Rplus_le_reg_l with 1%R. apply Rmult_le_reg_l with (/ INR 2)%R; auto with real arith. apply Rle_trans with (/ 2%nat * 2%nat * (alpha * gamma))%R; [ idtac | right; ring ]. rewrite Rinv_l; auto with real arith. apply Rplus_le_reg_l with (-1)%R. apply Rle_trans with (- (1 - alpha * gamma))%R; [ idtac | right; ring ]. apply Rle_trans with (- powerRZ radix (-2))%R. right; simpl in |- *; field; auto with real arith zarith. apply Ropp_le_contravar. apply Rle_trans with (Rabs (1 - alpha * gamma)); [ apply RRle_abs | idtac ]. apply Rle_trans with (powerRZ radix (q - prec)). unfold FtoRradix, radix in |- *; apply delta_inf with b; auto with zarith. apply Rle_powerRZ; auto with real zarith. apply Rle_trans with (Rabs zH * (2%nat * (2%nat * (alpha * gamma) - 1)))%R; [ apply Rmult_le_compat_r | right; ring ]. apply Rmult_le_pos; auto with real arith zarith. apply Rplus_le_reg_l with (-1)%R. ring_simplify (-1 + 0)%R; apply Rle_trans with (- (2 * (1 - alpha * gamma)))%R; [ idtac | right; simpl in |- *; ring ]. apply Ropp_le_contravar; apply Rmult_le_reg_l with (/ 2)%R; auto with real. rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real. apply Rle_trans with (1 - alpha * gamma)%R; auto with real. apply Rle_trans with (Rabs (1 - alpha * gamma)); [ apply RRle_abs | idtac ]. apply Rle_trans with (powerRZ radix (q - prec)). unfold FtoRradix, radix in |- *; apply delta_inf with b; auto with zarith. apply Rle_trans with (powerRZ radix (-1)); [ apply Rle_powerRZ; auto with real zarith | idtac ]. right; simpl in |- *; field; auto with real zarith. unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith. unfold Fabs, FtoR in |- *; simpl; rewrite <- H3. apply Rle_trans with (1 * powerRZ 2 (Fexp zH))%R; [ right; simpl ; ring | idtac ]. apply Rmult_le_compat_r; auto with real zarith. cut (0 < Zabs (Fnum zH))%Z; auto with real float zarith. apply Zlt_le_trans with (Fnum (Fabs zH)); auto with zarith. apply LtR0Fnum with radix; auto with real zarith. rewrite Fabs_correct; auto with real zarith. unfold FtoRradix; rewrite Fmult_correct; auto with zarith; fold FtoRradix. cut (0 <= x*zH)%R. intros; rewrite <- Rmult_assoc. apply Rle_trans with (0*gamma)%R; auto with real. case (Rle_or_lt 0 x); intros. assert (0 <= zH)%R; auto with real. rewrite <- H2; apply zH1Pos with b prec N alpha x u; auto with zarith. apply Rle_trans with (x*0)%R; auto with real. assert (zH <= 0)%R; auto with real. rewrite <- H2; apply zH1Neg with b prec N alpha x u; auto with zarith real. apply Rle_trans with ((-x)*(-zH))%R; auto with real. apply Rle_trans with ((-x)*0)%R; auto with real. elim H; intros; split. exists (Fminus radix x (Fmult zH gamma)). split; [ rewrite H2; unfold FtoRradix in |- *; rewrite Fminus_correct; auto with zarith; rewrite Fmult_correct; auto with zarith; ring | auto ]. rewrite H2; unfold FtoRradix; rewrite <- Fmult_correct; auto with zarith. apply Rle_lt_trans with (1:=H6). unfold FtoRradix; rewrite Fmult_correct; auto with zarith. fold FtoRradix; rewrite Rabs_mult; rewrite (Rabs_right gamma). 2: apply Rle_ge; auto with real. apply Rlt_le_trans with (powerRZ radix (q-Zsucc N)*powerRZ radix ((prec-q)+Fexp gamma))%R. apply Rlt_le_trans with (powerRZ radix (q - Zsucc N)* gamma)%R. apply Rmult_lt_compat_r; auto with real. fold FtoRradix; rewrite <- H2; exact H'. apply Rmult_le_compat_l; auto with real zarith. unfold FtoRradix, FtoR; rewrite powerRZ_add; auto with real zarith. apply Rmult_le_compat_r; auto with real zarith. elim gammaNormal; intros T1 T2; elim T1; intros T3 T4. apply Rle_trans with (Rabs (Fnum gamma));[apply RRle_abs|rewrite Rabs_Zabs]. apply Rle_trans with (Zpos (vNum bmoinsq)); auto with real zarith float. unfold bmoinsq; rewrite vNum_eq_Zpower_bmoinsq; rewrite Zpower_nat_Z_powerRZ. rewrite inj_minus1; auto with real zarith. rewrite <- powerRZ_add; auto with real zarith. exists (Float (Fnum (Fnormalize radix b prec u) - 3%nat * Zpower_nat radix (pred (pred prec))) ( - N)). cut (zH1 = Float (Fnum (Fnormalize radix b prec u) - 3%nat * Zpower_nat radix (pred (pred prec))) ( - N) :>R); [ intros V | idtac ]. split; [ auto | idtac ]. split; [ simpl in |- *; auto | idtac ]. split. apply Rmult_lt_reg_l with (powerRZ radix (- N)); auto with real zarith. apply Rle_lt_trans with (Rabs (FtoRradix zH1)). right; rewrite V; unfold FtoRradix, Fabs, FtoR. apply trans_eq with (Rabs ((Fnum (Fnormalize radix b prec u) - 3%nat * Zpower_nat radix (pred (pred prec)))%Z*powerRZ radix (-N))); auto with real. rewrite Rabs_mult. rewrite Rabs_right with (powerRZ radix (-N)); try apply Rle_ge; auto with real zarith. rewrite Rabs_Zabs; auto with real zarith. rewrite <- powerRZ_add; auto with real zarith. replace (- N + Zpred q)%Z with (q - Zsucc N)%Z; auto; unfold Zsucc, Zpred in |- *; ring. rewrite <- V. assert (0 <= Rabs zH1)%R; auto with real. case H; auto; intros. absurd (Rabs zH1 =0)%R; auto with real. apply Rabs_no_R0; auto with real. unfold FtoRradix, radix in |- *; rewrite zH1_eq with b prec N alpha x u zH1; auto with zarith. rewrite <- FnormalizeCorrect with 2%Z b prec u; auto with zarith; unfold FtoR in |- *. apply trans_eq with ((Fnum (Fnormalize 2 b prec u) - 3%nat * Zpower_nat 2 (pred (pred prec)))%Z * powerRZ 2%Z (- N))%R; [ idtac | simpl in |- *; auto with zarith real ]. unfold Zminus in |- *; rewrite plus_IZR; rewrite Ropp_Ropp_IZR; rewrite mult_IZR; rewrite Zpower_nat_Z_powerRZ. rewrite Fexp_u with b prec N alpha x u; auto with zarith. replace (Zpred (Zpred (prec + - N))) with (-N + pred (pred prec))%Z. rewrite powerRZ_add; auto with real zarith. simpl; ring. rewrite inj_pred; auto with zarith; rewrite inj_pred; auto with zarith. Qed. End Total. Float8.4/FnElem/FArgReduct3.v0000644000423700002640000010655612032774527015475 0ustar sboldotoccata(** FArgReduct3 file Sylvie Boldo This file explains an improvement of Cody & Waite argument reduction technique using the FMA (fused-multiply-and-add). *) Require Export FArgReduct2. Section Total. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. (** Variables *) Variable b : Fbound. Variables prec : nat. Variable N : Z. Variables alpha gamma x zH1 u : float. Variable zL : R. (** Various bounds *) Let bmoinsq := Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (prec - 2)%nat)))) (dExp b). (** All the hypotheses *) Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix prec. Hypothesis Fboundedx : Fbounded b x. Hypothesis xCanonic : Fcanonic radix b x. (** alpha (the constant, such as pi) and gamma (its inverse) *) Hypothesis alphaNormal : Fnormal radix b alpha. Hypothesis gammaNormal : Fnormal radix bmoinsq gamma. Hypothesis alphaPos : (0 < alpha)%R. Hypothesis gammaPos : (0 < gamma)%R. Hypothesis gamma_not_pow_2 : forall e : Z, FtoRradix gamma <> powerRZ radix e. Hypothesis gammaDef : Closest bmoinsq radix (/ alpha) gamma. (** About the computation of z *) Hypothesis uDef : Closest b radix (3%nat * powerRZ radix (Zpred (Zpred (prec - N))) + x * alpha) u. Hypothesis zH1Def : Closest b radix (u - 3%nat * powerRZ radix (Zpred (Zpred (prec - N)))) zH1. Hypothesis precMoreThanThree : 3 < prec. Hypothesis N_not_too_big : (N <= dExp b)%Z. (** x not too big *) Hypothesis xalpha_small : (Rabs (x * alpha) <= powerRZ radix (Zpred (Zpred (prec - N))) - powerRZ radix (- N))%R. (** No underflow *) Hypothesis gamma_ge: (powerRZ radix (-dExp b+prec+(Zmax (-1) N))<= gamma)%R. (** A few lemmas *) Theorem gamma_ge2: (powerRZ radix (-dExp b+prec -2 +(Zmax 1 (N-1)))<= gamma)%R. apply Rle_trans with (2:=gamma_ge). apply Rle_powerRZ; auto with real zarith. unfold Zminus; repeat rewrite <- Zplus_assoc; repeat apply Zplus_le_compat_l; auto with zarith. fold (Zminus N 1); fold (Zminus N 3). case (Zle_or_lt 1 (N-1)); intros. rewrite Zmax_le2; auto. apply Zle_trans with N; auto with zarith. rewrite Zmax_le1; auto with zarith. Qed. Theorem exp_gamma_enough2: (- dExp b <= Zpred (Zpred (Fexp gamma)))%Z. assert (- dExp b + prec-1 < prec-2 + Fexp gamma)%Z; auto with zarith. apply Zle_lt_trans with (- dExp b + prec + Zmax (-1) N)%Z; auto with zarith. unfold Zminus; repeat rewrite <- Zplus_assoc; repeat apply Zplus_le_compat_l; auto with zarith. apply Zlt_powerRZ with radix; auto with real zarith. apply Rle_lt_trans with (1:=gamma_ge). rewrite powerRZ_add; auto with real zarith. unfold FtoRradix, FtoR; apply Rmult_lt_compat_r; auto with real zarith. apply Rle_lt_trans with (Zabs (Fnum gamma)); auto with real zarith. apply Rlt_le_trans with (Zpos (vNum (bmoinsq))). elim gammaNormal; intros I1 I2; elim I1; intros; auto with zarith real. unfold bmoinsq; rewrite vNum_eq_Zpower_bmoinsq. rewrite Zpower_nat_Z_powerRZ; auto with real zarith. unfold radix; replace (Z_of_nat ((prec-2)%nat)) with (prec-2)%Z; auto with zarith real. replace 2%Z with (Z_of_nat 2); auto with zarith. apply sym_eq; apply inj_minus1; auto with zarith arith. Qed. Theorem exp_alpha_le: (- dExp b <= 3 + - (Fexp alpha + (prec + prec)))%Z. assert (prec-1+Fexp alpha <= dExp b+2-prec)%Z; unfold Zsucc; auto with zarith. apply Zle_powerRZ with radix; auto with real zarith. apply Rle_trans with alpha. rewrite powerRZ_add; auto with real zarith. unfold FtoRradix, FtoR; apply Rmult_le_compat_r; auto with real zarith. elim alphaNormal; intros. apply Rmult_le_reg_l with radix; auto with real zarith. apply Rle_trans with (Zpos (vNum b)). rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ. right; unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl. ring_simplify (2*1)%R; field; auto with real. apply Rle_trans with ( Zabs (radix * Fnum alpha)); auto with real zarith. rewrite Zabs_eq; auto with real zarith. rewrite mult_IZR; auto with real. assert (0 < Fnum alpha)%Z; auto with zarith real float. apply LtR0Fnum with radix; auto with real zarith. case (Rle_or_lt alpha (powerRZ radix (dExp b + 2 - prec))); auto with real. intros V. absurd (powerRZ radix (- dExp b + prec - 1) <= gamma)%R. apply Rlt_not_le. assert (exists f:float, Fbounded bmoinsq f /\ (FtoRradix f= powerRZ radix (- dExp b+prec-2))%R). exists (Float 1 (-dExp b+prec-2)). split;[split|idtac]. apply Zle_lt_trans with (Zabs 1); auto with zarith. rewrite Zabs_eq; auto with zarith. unfold bmoinsq; rewrite vNum_eq_Zpower_bmoinsq; auto with zarith. apply Zle_lt_trans with (Zpower_nat 2 0); auto with zarith. simpl; auto with zarith. unfold FtoRradix, FtoR; simpl; ring. elim H; intros f H'; elim H'; intros I1 I2; clear H H'. apply Rle_lt_trans with (FtoRradix f). unfold FtoRradix; apply RleBoundRoundr with bmoinsq (prec-2) (Closest bmoinsq radix) (/alpha)%R; auto with real zarith float. unfold bmoinsq; apply vNum_eq_Zpower_bmoinsq; auto. apply ClosestRoundedModeP with (prec-2); auto with zarith. unfold bmoinsq; apply vNum_eq_Zpower_bmoinsq; auto. fold FtoRradix; rewrite I2. apply Rle_trans with (/(powerRZ radix (dExp b + 2 - prec)))%R. apply Rle_Rinv; auto with real zarith. rewrite Rinv_powerRZ; auto with real zarith. replace (- (dExp b + 2 - prec))%Z with (- dExp b + prec - 2)%Z; auto with real zarith. rewrite I2; auto with real zarith. apply Rle_trans with (2:=gamma_ge). apply Rle_powerRZ; auto with real zarith. unfold Zminus; repeat rewrite <- Zplus_assoc. repeat apply Zplus_le_compat_l; auto with zarith. Qed. Theorem exp_gamma_enough3: (- dExp b <= Fexp gamma - N-3)%Z. assert (- dExp b + prec +N< prec-2 + Fexp gamma)%Z; auto with zarith. apply Zle_lt_trans with (- dExp b + prec + Zmax (-1) N)%Z; auto with zarith. apply Zlt_powerRZ with radix; auto with real zarith. apply Rle_lt_trans with (1:=gamma_ge). rewrite powerRZ_add; auto with real zarith. unfold FtoRradix, FtoR; apply Rmult_lt_compat_r; auto with real zarith. apply Rle_lt_trans with (Zabs (Fnum gamma)); auto with real zarith. apply Rlt_le_trans with (Zpos (vNum (bmoinsq))). elim gammaNormal; intros I1 I2; elim I1; intros; auto with zarith real. unfold bmoinsq; rewrite vNum_eq_Zpower_bmoinsq. rewrite Zpower_nat_Z_powerRZ; auto with real zarith. unfold radix; replace (Z_of_nat ((prec-2)%nat)) with (prec-2)%Z; auto with zarith real. replace 2%Z with (Z_of_nat 2); auto with zarith. apply sym_eq; apply inj_minus1; auto with zarith arith. Qed. Theorem gamma_p: ex (fun gam2 : float => FtoRradix gam2 = gamma /\ Fnormal radix b gam2 /\ (Fexp gam2=Zpred (Zpred (Fexp gamma))) /\ ((powerRZ radix (Zpred prec))+4 <=Fnum gam2)%R /\ (Fnum gam2 <= (powerRZ radix prec)-4)%R). assert (0 < (Fnum gamma))%Z;[apply LtR0Fnum with radix ;auto with real zarith|idtac]. exists (Float ((Fnum gamma)*radix*radix)%Z (Zpred (Zpred (Fexp gamma)))). split. unfold FtoRradix, FtoR;simpl. pattern (Fexp gamma)%Z at 2; replace (Fexp gamma)%Z with (2+(Zpred (Zpred (Fexp gamma))))%Z; [idtac|unfold Zpred;ring]. rewrite mult_IZR;rewrite mult_IZR. rewrite powerRZ_add; auto with real zarith; simpl;ring. cut ((powerRZ radix (Zpred prec))+4 <= (Fnum gamma * radix * radix)%Z)%R;[intros V1|idtac]. cut ((Fnum gamma * radix * radix)%Z <= (powerRZ radix prec)-4)%R;[intros V2|idtac]. split;[idtac|split;auto]. split;[split|idtac]. simpl; apply Zlt_Rlt. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; apply Rle_lt_trans with (powerRZ radix prec - 4)%R;auto with real. rewrite Zabs_eq; auto with real zarith. apply Rlt_le_trans with (powerRZ radix prec - 0)%R;[unfold Rminus; apply Rplus_lt_compat_l|right;ring]. apply Ropp_lt_contravar;apply Rlt_le_trans with 1%R;auto with real;apply Rle_trans with 2%R;auto with real. simpl;auto with zarith. apply exp_gamma_enough2. apply Zle_Rle;rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ. rewrite Zabs_eq; auto with zarith. apply Rle_trans with (radix*( (powerRZ radix (Zpred prec) + 4)))%R;auto with real zarith. apply Rle_trans with (radix * (powerRZ radix (Zpred prec)))%R;[idtac|apply Rmult_le_compat_l;auto with real zarith]. right; unfold Zpred; rewrite powerRZ_add; auto with real zarith;simpl; field. apply Rle_trans with (powerRZ radix (Zpred prec) + 0)%R;[right;ring| apply Rplus_le_compat_l]. apply Rle_trans with 1%R; auto with real. apply Rle_trans with 2%R; auto with real. rewrite mult_IZR; apply Rmult_le_compat_l;auto with real zarith. apply Zle_trans with (radix* (Fnum gamma * radix * radix))%Z;auto with zarith. rewrite mult_IZR;rewrite mult_IZR. apply Rle_trans with ((powerRZ radix (Zminus prec 2)- 1)*radix*radix)%R. apply Rmult_le_compat_r;auto with real zarith. apply Rmult_le_compat_r;auto with real zarith. rewrite <- (Zabs_eq (Fnum gamma)); auto with zarith. apply Rle_trans with (Zpred (Zpos (vNum bmoinsq))). cut ((Zabs (Fnum gamma) < (Zpos (vNum bmoinsq))))%Z;auto with zarith real float. elim gammaNormal; auto with zarith float. unfold bmoinsq;rewrite vNum_eq_Zpower_bmoinsq; unfold Zpred;simpl. rewrite plus_IZR;rewrite Zpower_nat_Z_powerRZ;right. rewrite <- minus_Zminus_precq with prec 2;auto with zarith real. unfold Zminus; rewrite powerRZ_add; auto with real zarith. simpl; right;field. apply Rle_trans with (radix*((powerRZ radix (Zpred (Zpred prec)) + 2)))%R. right; unfold Zpred; repeat rewrite powerRZ_add; auto with zarith real; simpl; field; auto with real. apply Rle_trans with ((radix * (Zpower_nat radix (pred (pred prec)) + 2)))%Z. rewrite <- inj_pred;auto with zarith;rewrite <- inj_pred;auto with zarith. rewrite mult_IZR;rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ;auto with real zarith. apply Rle_IZR. apply Zle_trans with (radix * (radix * (Fnum gamma)))%Z;[idtac|apply Zeq_le;ring]. apply Zmult_le_compat_l;auto with zarith. apply Zle_trans with (radix*(Zsucc (Zpower_nat radix (pred (pred (pred prec))))))%Z. pattern (pred (pred prec)) at 1;replace (pred (pred prec)) with (1+(pred (pred (pred prec))))%nat. rewrite Zpower_nat_is_exp. replace (Zpower_nat radix 1)%Z with radix;[unfold Zsucc, radix; apply Zeq_le; ring|unfold Zpower_nat;simpl;auto with zarith]. auto with zarith. apply Zmult_le_compat_l;auto with zarith. apply Zlt_le_succ. cut ((Zpower_nat radix (pred (pred (pred prec))) <= Fnum gamma)%Z);[intros H2|idtac]. cut (~((Zpower_nat radix (pred (pred (pred prec))) = Fnum gamma)%Z));[intros H3;auto with zarith|idtac]. Contradict gamma_not_pow_2. apply ex_not_not_all with (U := Z) (P := fun t : Z => FtoRradix gamma <> powerRZ radix t). exists ((Fexp gamma)+(pred (pred (pred prec))))%Z. unfold FtoRradix, FtoR; rewrite powerRZ_add; auto with real zarith. rewrite <- gamma_not_pow_2; rewrite Zpower_nat_Z_powerRZ; auto with real. apply Zmult_le_reg_r with radix; auto with zarith. apply Zlt_gt;auto with zarith. apply Zle_trans with (Zpos (vNum bmoinsq)). apply Zeq_le;unfold bmoinsq;rewrite vNum_eq_Zpower_bmoinsq. replace (prec-2)%nat with (1 + (pred (pred (pred prec))))%nat. rewrite Zpower_nat_is_exp. replace (Zpower_nat 2 1)%Z with radix;[unfold radix;ring|unfold Zpower_nat;simpl;auto with zarith]. auto with zarith. rewrite <- (Zabs_eq ( Fnum gamma * radix)%Z);auto with zarith. elim gammaNormal; rewrite Zmult_comm; auto with zarith. Qed. (** Main result: q=2 *) Theorem Fmac_arg_reduct_correct3 : ex (fun u : float => FtoRradix u = (x - zH1 * gamma)%R /\ Fbounded b u) /\ (Rabs (x-zH1*gamma) < powerRZ radix (prec-N+Fexp gamma))%R. case (Req_dec zH1 0); intros H1. split. exists x; split; auto with real. rewrite H1; ring. replace (x-zH1*gamma)%R with (FtoRradix x);[idtac|rewrite H1; ring]. apply Rmult_lt_reg_l with alpha; auto. apply Rle_lt_trans with (Rabs (x*alpha-zH1)). right; replace (x*alpha-zH1)%R with (x*alpha)%R; auto with real. rewrite Rabs_mult; rewrite (Rabs_right alpha); try apply Rle_ge; auto with real. rewrite H1; ring. apply Rle_lt_trans with (powerRZ radix (Zpred (-N))). replace (x*alpha-zH1)%R with ((S 2 * powerRZ radix (Zpred (Zpred (prec - N))) + x * alpha)-u)%R. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp b radix prec u). unfold FtoRradix; apply ClosestUlp; auto with zarith. unfold Fulp,radix; rewrite Fexp_u with b prec N alpha x u; auto with zarith. unfold Zpred; rewrite powerRZ_add; auto with real zarith; right. simpl; field; auto with real. unfold FtoRradix, radix;rewrite zH1_eq with b prec N alpha x u zH1; auto with real zarith. ring. replace (Zpred (-N)) with ((-Fexp gamma-1-prec)+(prec-N+Fexp gamma))%Z; [idtac|unfold Zpred; ring]. rewrite powerRZ_add; auto with real zarith. apply Rmult_lt_compat_r; auto with real zarith. replace (- Fexp gamma - 1 - prec)%Z with ((-4+prec) +Fexp alpha)%Z. apply Rlt_le_trans with (Zpos (vNum b) * (Float (S 0) (Zpred (Fexp alpha))))%R. apply Rlt_le_trans with (powerRZ radix (prec+Fexp alpha-1)); auto with real zarith. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ. unfold FtoRradix, FtoR; simpl; right. unfold Zpred, Zminus; repeat rewrite powerRZ_add; auto with real zarith. simpl; ring. apply Rle_trans with (Fabs alpha). unfold FtoRradix; apply FnormalBoundAbs2 with prec; auto with zarith. unfold FtoRradix; rewrite Fabs_correct; auto with zarith; rewrite Rabs_right; try apply Rle_ge; auto with zarith real. rewrite gamma_exp with b prec 2 alpha gamma; auto with zarith. replace (Zsucc (S 1)) with 3%Z; ring; simpl; ring. apply Zle_trans with (1:=exp_alpha_le). replace (Zsucc (S 1)) with 3%Z; auto with zarith. case (Rle_or_lt (powerRZ radix (2 - Zsucc N)) (Rabs zH1)); intros H'. cut (exists k : Z, (exists zH : float, FtoR 2 zH1 = FtoR 2 zH /\ (Zsucc (k + N) <= Zpred (Zpred prec))%Z /\ (0 <= Zsucc (k + N))%Z /\ 1 < Zabs_nat (Zsucc (k + N)) /\ N = (- Fexp zH)%Z /\ Fnormal 2 ((fun k0 : Z => Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat 2 (Zabs_nat (Zsucc (k0 + N))))))) (dExp b)) k) zH /\ (Rabs (FtoR 2 x * FtoR 2 alpha - FtoR 2 zH) <= powerRZ 2%Z (Zpred (- N)))%R /\ (powerRZ 2%Z k <= (Rabs (FtoR 2 zH1)) < powerRZ 2%Z (Zsucc k))%R)). 2: apply arg_reduct_exists_k_zH with u; auto with real zarith. fold radix FtoRradix in |- *. intros T1; elim T1; intros k T2; elim T2; intros zH T3; elim T3; intros H3 T4; elim T4; intros H4 T5; elim T5; intros H5 T6; elim T6; intros H6 T7; elim T7; intros H7 T8; elim T8; intros H8 T9; elim T9; intros H9 T10; elim T10; intros H10 H11; clear T1 T2 T3 T4 T5 T6 T7 T8 T9 T10. rewrite H3. apply Fmac_arg_reduct_correct1 with 2 k alpha (x * alpha - zH)%R; auto with zarith real arith. apply Zplus_le_reg_l with (- Zsucc N)%Z. replace (- Zsucc N + 2)%Z with (2 - Zsucc N)%Z; [ idtac | ring ]; replace (- Zsucc N + Zsucc (k + N))%Z with k; [ idtac | unfold Zsucc in |- *; ring ]. apply Zgt_succ_le; apply Zlt_gt. apply Zlt_powerRZ with radix; auto with zarith real; apply Rle_lt_trans with (1 := H'); auto. apply Zplus_le_reg_l with (- Zsucc N)%Z. replace (- Zsucc N + 2%nat)%Z with (2 - Zsucc N)%Z; [ idtac | ring ]; replace (- Zsucc N + Zsucc (k + N))%Z with k; [ idtac | unfold Zsucc in |- *; ring ]. apply Zgt_succ_le; apply Zlt_gt. apply Zlt_powerRZ with radix; auto with zarith real; apply Rle_lt_trans with (1 := H'); auto. apply gamma_ge2. cut (zH1 = Float (Fnum (Fnormalize radix b prec u) - 3%nat * Zpower_nat radix (pred (pred prec))) ( - N) :>R); [ intros H'1 | idtac ]. 2:unfold FtoRradix, radix in |- *; rewrite zH1_eq with b prec N alpha x u zH1; auto with zarith. 2:rewrite <- FnormalizeCorrect with 2%Z b prec u; auto with zarith; unfold FtoR in |- *. 2:apply trans_eq with ((Fnum (Fnormalize 2 b prec u) - 3%nat * Zpower_nat 2 (pred (pred prec)))%Z * powerRZ 2%Z (- N))%R; [ idtac | simpl in |- *; auto with zarith real ]. 2:unfold Zminus in |- *; rewrite plus_IZR; rewrite Ropp_Ropp_IZR; rewrite mult_IZR; rewrite Zpower_nat_Z_powerRZ. 2:rewrite Fexp_u with b prec N alpha x u; auto with zarith. 2: replace (Zpred (Zpred (prec + - N))) with (- N + pred (pred prec))%Z. 2: rewrite powerRZ_add; auto with real zarith; simpl; ring. 2: rewrite inj_pred; auto with zarith; rewrite inj_pred; auto with zarith; unfold Zpred; ring. cut (exists zH : float, FtoRradix zH1 = zH /\ Fexp zH = (- N)%Z /\ (Zabs (Fnum zH) < powerRZ radix (Zpred 2))%R /\ (0 < Rabs zH)%R). 2:exists (Float (Fnum (Fnormalize radix b prec u) - 3%nat * Zpower_nat radix (pred (pred prec))) ( - N)). 2:split; [ auto | idtac ]. 2:split; [ simpl in |- *; auto | idtac ]. 2:split. 2:apply Rmult_lt_reg_l with (powerRZ radix (- N)); auto with real zarith. 2:apply Rle_lt_trans with (Rabs (FtoRradix zH1)). 2: right; rewrite H'1; unfold FtoRradix, FtoR; simpl. 2: rewrite Rabs_mult; rewrite Rabs_Zabs. 2: rewrite Rabs_right; try apply Rle_ge; auto with real zarith. 2:rewrite <- powerRZ_add; auto with real zarith. 2:replace (- N + Zpred 2)%Z with (2 - Zsucc N)%Z; auto; unfold Zsucc, Zpred in |- *; ring. 2:rewrite <- H'1; cut (0 <= Rabs zH1)%R; auto with real. 2:intros H''; case H''; auto with real; intros H2. 2:absurd (Rabs zH1=0); auto with real. 2: apply Rabs_no_R0; auto. intros V; elim V; intros zH V1; elim V1; intros H2 V2; elim V2; intros H3 V3; elim V3; intros H4 H5; clear V V1 V2 V3. cut (Zabs (Fnum zH)=1)%Z;[intros H6|idtac]. 2: cut (0 < (Zabs (Fnum zH)))%Z;[intros H'3| apply Zlt_le_trans with (Fnum (Fabs zH)); auto with zarith; apply LtR0Fnum with radix];auto with real zarith. 2: cut (Zabs (Fnum zH) < 2)%Z;[intros H'4|idtac];auto with real zarith. 2:apply Zlt_Rlt; apply Rlt_le_trans with (1:=H4);auto with real zarith. 2: rewrite Fabs_correct; auto with real zarith. cut ((((powerRZ radix (Zpred (-N))) <= (Rabs x)*alpha)%R) /\ (((Rabs x)*alpha <=3*(powerRZ radix (Zpred (-N))))%R)). intros T;elim T; intros W1 W2;clear T. case (Rle_or_lt (/2%nat*(Rabs (Fmult zH gamma))) (Rabs x));intros H7. assert (Fbounded b (Fminus 2 x (Fmult zH gamma)) /\ (Rabs (x - (Fmult zH gamma)) <= Rabs (Fmult zH gamma))%R). unfold FtoRradix; apply Sterbenzter; auto with zarith. split; simpl in |- *;auto with zarith. rewrite Zabs_Zmult; rewrite H6. apply Zle_lt_trans with (Zabs (Fnum gamma)); auto with zarith. apply Zlt_trans with (Zpos (vNum bmoinsq)). elim gammaNormal;intros W;elim W;auto. rewrite pGivesBound;unfold bmoinsq; rewrite vNum_eq_Zpower_bmoinsq;auto with zarith. apply Zle_trans with (1:=exp_gamma_enough3); auto with zarith. fold FtoRradix; apply Rmult_le_reg_l with alpha;auto with real. rewrite Rmult_comm;apply Rle_trans with (1:=W2). apply Rle_trans with (((alpha*gamma)*4)*(powerRZ radix (Zpred (-N))))%R. apply Rmult_le_compat_r;auto with real zarith. apply Rle_trans with ((1-(powerRZ radix (2-prec)))*4)%R. apply Rplus_le_reg_l with (-3+4*(powerRZ radix (2 - prec)))%R. apply Rle_trans with (4*(powerRZ radix (2 - prec)))%R;[right;ring|idtac]. apply Rle_trans with (powerRZ radix (2+(2 - prec)));[right;rewrite powerRZ_add;auto with real zarith;simpl;ring|idtac]. apply Rle_trans with (powerRZ radix 0)%R;[idtac|simpl;right;ring]. apply Rle_powerRZ;auto with real zarith. apply Rmult_le_compat_r;auto with real. apply Rle_trans with 1%R;auto with real. apply Rle_trans with 2%R;auto with real. apply Rplus_le_reg_l with ((powerRZ radix (2 - prec))- alpha * gamma)%R. apply Rle_trans with (1-alpha*gamma)%R;[right;ring|idtac]. apply Rle_trans with (powerRZ radix (2 - prec));[idtac|right;ring]. apply Rle_trans with (Rabs (1 - FtoR 2 alpha * FtoR 2 gamma)). fold radix FtoRradix; apply RRle_abs. replace (2-prec)%Z with (2%nat-prec)%Z;auto with zarith. apply delta_inf with b;auto with zarith. apply exp_alpha_le. rewrite Fmult_correct; auto with zarith; rewrite Rabs_mult. replace (Rabs (FtoR 2 zH) ) with (powerRZ radix (-N)). rewrite Rabs_right. unfold Zpred, Zminus; rewrite powerRZ_add; auto with real zarith. fold radix; fold FtoRradix; simpl; right; field; auto with real. apply Rle_ge; auto with real. rewrite <- Fabs_correct; auto with zarith;unfold FtoR, Fabs; simpl. rewrite H6; rewrite H3; simpl; ring. rewrite Fmult_correct; auto with zarith; fold radix; fold FtoRradix. cut (0 <= x*zH)%R. intros; rewrite <- Rmult_assoc; apply Rle_trans with (0*gamma)%R; auto with real. case (Rle_or_lt 0 x); intros. assert (0 <= zH)%R. rewrite <- H2; apply zH1Pos with b prec N alpha x u; auto with zarith. apply Rle_trans with (0*zH)%R; auto with real. assert (zH <= 0)%R. rewrite <- H2; apply zH1Neg with b prec N alpha x u; auto with zarith real. apply Rle_trans with ((-x)*(-zH))%R; auto with real. apply Rmult_le_pos; auto with real. elim H; intros; split. exists (Fminus radix x (Fmult zH gamma));split; auto. rewrite H2; unfold FtoRradix in |- *; rewrite Fminus_correct; auto with zarith. rewrite Fmult_correct; auto with zarith real. replace (zH1 * gamma)%R with (FtoRradix (Fmult zH gamma)). apply Rle_lt_trans with (1:=H8). unfold FtoRradix; rewrite Fmult_correct; auto with zarith. rewrite Rabs_mult. replace (prec-N+Fexp gamma)%Z with (-N+(prec+Fexp gamma))%Z; [rewrite powerRZ_add; auto with real zarith|ring]. replace (Rabs (FtoR radix zH)) with (powerRZ radix (- N)). apply Rmult_lt_compat_l; auto with real zarith. 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 gammaNormal; intros T1 T2; elim T1; intros. apply Rlt_le_trans with (Zpos (vNum bmoinsq)); auto with real zarith. unfold bmoinsq; rewrite vNum_eq_Zpower_bmoinsq; rewrite Zpower_nat_Z_powerRZ; auto with real zarith. rewrite <- Fabs_correct; auto with zarith; unfold FtoR, Fabs; simpl. rewrite H3; rewrite H6; simpl; ring. rewrite H2; unfold FtoRradix; rewrite Fmult_correct; auto with real zarith. generalize gamma_p; intros T1; elim T1; intros gam2 T2;elim T2; intros W3 T3;elim T3; intros W4 T4; elim T4; intros W5 T5; elim T5; intros W6 W7; clear T1 T2 T3 T4 T5. rewrite H2; rewrite <- W3. cut (0 < (1 + powerRZ radix (2 - prec)))%R;[intros W8|idtac]. 2: apply Rlt_trans with 1%R; auto with real zarith. 2: apply Rle_lt_trans with (1+0)%R; auto with real zarith. cut ((powerRZ radix (Zpred (-N)))*gamma/(1+(powerRZ radix (Zminus 2 prec))) <= Rabs x)%R;[intros H9|idtac]. cut ((Fexp x)=(Fexp gam2)-N-1)%Z;[intros H8|idtac]. assert (Rabs (x - zH * gam2) < powerRZ radix (Fexp gam2 - N - 1) * Zpos (vNum b))%R. apply Rle_lt_trans with (- Rabs x+Rabs zH*gam2)%R. assert (forall (r1 r2:R), ((0 <= r1)%R -> (0 <= r2)%R) -> ((r1<=0)%R -> (r2 <= 0)%R) -> (Rabs r1 <= Rabs r2)%R -> (Rabs (r1-r2) = - Rabs r1 + Rabs r2)%R). intros r1 r2 L1 L2; case (Rle_or_lt 0 r1); intros L3. rewrite (Rabs_right r1); try apply Rle_ge; auto with real. rewrite (Rabs_right r2); try apply Rle_ge; auto with real. intros; rewrite Rabs_left1; auto with real. ring. apply Rplus_le_reg_l with r2; ring_simplify; auto with real. rewrite (Rabs_left1 r1); try apply Rle_ge; auto with real. rewrite (Rabs_left1 r2); try apply Rle_ge; auto with real. intros; rewrite Rabs_right; auto with real. ring. apply Rle_ge; apply Rplus_le_reg_l with (-r1)%R; ring_simplify; auto with real. rewrite H; auto. rewrite Rabs_mult; rewrite (Rabs_right gam2); auto with real. apply Rle_ge; rewrite W3; auto with real. intros; assert (0 <= zH)%R. rewrite <- H2; apply zH1Pos with b prec N alpha x u; auto with zarith. apply Rmult_le_pos; auto with real. rewrite W3; auto with real. intros; assert (zH <= 0)%R. rewrite <- H2; apply zH1Neg with b prec N alpha x u; auto with zarith. assert (0 < gam2)%R;[rewrite W3|idtac]; auto with real. apply Rle_trans with (0*gam2)%R; auto with real. apply Rlt_le; apply Rlt_le_trans with (1:=H7). apply Rle_trans with (1*Rabs (Fmult zH gamma))%R. apply Rmult_le_compat_r; auto with real zarith. simpl; apply Rmult_le_reg_l with 2%R; auto with real;apply Rle_trans with 1%R;[right;field|idtac];auto with real. rewrite W3; unfold FtoRradix; rewrite Fmult_correct; auto with zarith real. apply Rle_lt_trans with (- (powerRZ radix (Zpred (- N)) * gamma / (1 + powerRZ radix (2 - prec)))+Rabs zH*gam2)%R;auto with real. rewrite <- W3; apply Rmult_lt_reg_l with (1 + powerRZ radix (2 - prec))%R; auto with real zarith. apply Rle_lt_trans with ((1 + powerRZ radix (2 - prec)) * gam2 * Rabs zH - (powerRZ radix (Zpred (- N)) * gam2))%R. right; field; auto with real zarith. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ. replace (Rabs zH) with (powerRZ radix (-N))%R. apply Rle_lt_trans with (gam2*(powerRZ radix (-N-1))*(1+(powerRZ radix (3-prec))))%R;[right|idtac]. pattern (-N)%Z at 1; replace (-N)%Z with (1+(-N-1))%Z; [rewrite powerRZ_add; auto with real zarith|ring]. replace (2%nat-prec)%Z with (2-prec)%Z;auto with zarith. replace (Zpred (-N))%Z with (-N-1)%Z;[idtac|unfold Zpred;ring]. replace (3-prec)%Z with (1+(2-prec))%Z; [rewrite powerRZ_add; auto with real zarith|ring]. simpl;ring. unfold FtoRradix, FtoR. apply Rle_lt_trans with ((powerRZ radix prec - 4) * powerRZ radix (Fexp gam2) * powerRZ radix (- N - 1) * (1 + powerRZ radix (3 - prec)))%R. apply Rmult_le_compat_r;auto with real. apply Rle_trans with (1+0)%R; auto with real zarith;apply Rle_trans with 1%R;auto with real. apply Rle_lt_trans with ( (powerRZ radix (Fexp gam2) * powerRZ radix (- N - 1)) * ((powerRZ radix prec - 4) * (1 + powerRZ radix (3 - prec))))%R;[right;ring|idtac]. rewrite <- powerRZ_add;auto with real zarith. replace (Fexp gam2 + (- N - 1))%Z with (Fexp gam2-N-1)%Z;[idtac|ring]. apply Rlt_le_trans with (powerRZ radix (Fexp gam2 - N - 1) * ((1 + powerRZ radix (2 - prec)) * powerRZ radix prec))%R;[idtac|right;ring]. apply Rmult_lt_compat_l;auto with real zarith. replace (2-prec)%Z with (2-prec)%Z; auto with zarith. apply Rle_lt_trans with ( ((powerRZ radix prec)+4)-(powerRZ radix (5-prec)))%R;[right;ring_simplify|idtac]. rewrite <- powerRZ_add; auto with real zarith; ring_simplify (prec + (3 - prec))%Z. replace (powerRZ radix (5 - prec))%R with (4*(powerRZ radix (3 - prec)))%R;[simpl;ring|idtac]. replace (5-prec)%Z with (2+(3-prec))%Z;[rewrite powerRZ_add;auto with real zarith|ring];simpl;ring. apply Rlt_le_trans with ((powerRZ radix prec + 4) - 0)%R; auto with real zarith. unfold Rminus; apply Rplus_lt_compat_l. apply Ropp_lt_contravar;auto with real zarith. right;ring_simplify; rewrite <- powerRZ_add; auto with real zarith. ring_simplify (prec+(2-prec))%Z;simpl;ring. unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith. unfold FtoR, Fabs; simpl; rewrite H3; rewrite H6; simpl; ring. split. exists (Fminus radix x (Fmult zH gam2));split. unfold FtoRradix; rewrite Fminus_correct;auto with zarith; rewrite Fmult_correct;auto with real zarith. split. 2:unfold Fmult, Fminus, Fopp, Fplus;simpl. 2:rewrite Zmin_le1;[idtac|rewrite H8; rewrite H3;auto with zarith]. 2: auto with zarith float. apply Zlt_Rlt;apply Rmult_lt_reg_l with (powerRZ radix (Fexp (Fminus radix x (Fmult zH gam2))));auto with real zarith. apply Rle_lt_trans with (Rabs (Fminus radix x (Fmult zH gam2)));[right|idtac]. unfold FtoRradix; rewrite <- Fabs_correct;auto with zarith. unfold Fabs, FtoR; simpl; ring. unfold FtoRradix; rewrite Fminus_correct;auto with zarith; rewrite Fmult_correct;auto with real zarith;fold FtoRradix. replace (Fexp (Fminus radix x (Fmult zH gam2))) with (Fexp gam2 - N - 1)%Z. 2:unfold Fmult, Fminus, Fopp, Fplus;simpl; rewrite Zmin_le1;[auto with zarith|rewrite H8; rewrite H3;auto with zarith]. auto. apply Rlt_le_trans with (1:=H). rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ. rewrite <- powerRZ_add; auto with real zarith. rewrite W5; unfold Zpred; auto with zarith. cut ((Fexp gam2 - N - 1) <= Fexp x)%Z;[intros T1|idtac]. cut (Fexp x <=(Fexp gam2 - N - 1))%Z;[intros T2;auto with zarith|idtac]. apply Zle_powerRZ with radix; auto with zarith real. apply Rle_trans with (FtoR radix(Float 1%nat (Fexp x)))%R;[right; unfold FtoR;simpl;ring|idtac]. rewrite <- CanonicFulp with b radix prec x; auto with zarith. apply Rle_trans with (FtoR radix(Float 1%nat (Fexp (Float (Fnum gam2) (Fexp gam2-N-1)))))%R;[idtac|right; unfold FtoR;simpl;ring]. cut (Fcanonic radix b (Float (Fnum gam2) (Fexp gam2-N-1)));[intros W'|idtac]. rewrite <- CanonicFulp with b radix prec (Float (Fnum gam2) (Fexp gam2-N-1)); auto with zarith. rewrite FulpFabs; auto with zarith. apply LeFulpPos; auto with real float zarith. apply FcanonicBound with radix;auto. rewrite Fabs_correct; auto with zarith real. rewrite Fabs_correct; auto with zarith. fold FtoRradix; apply Rlt_le; apply Rlt_le_trans with (1:=H7). unfold FtoRradix; rewrite Fmult_correct; auto with zarith. fold FtoRradix; rewrite <- W3; rewrite Rabs_mult. rewrite (Rabs_right gam2);[idtac|apply Rle_ge; rewrite W3; auto with real]. unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith. right; unfold FtoRradix, FtoR;simpl; unfold Zminus;repeat rewrite powerRZ_add;auto with real zarith. rewrite H3; rewrite H6. simpl; field;auto with real. elim W4; intros T3 T2; elim T3; intros T4 T5. left;split;simpl; auto with zarith. split;simpl; auto with zarith. rewrite W5; unfold Zpred; auto with zarith. apply Zle_trans with (1:=exp_gamma_enough3); auto with zarith. apply Zle_powerRZ with radix; auto with zarith real. apply Rle_trans with (FtoR radix(Float 1%nat (Fexp x)))%R;[idtac|right; unfold FtoR;simpl;ring]. rewrite <- CanonicFulp with b radix prec x; auto with zarith. cut (Fcanonic radix b (Float ((Fnum gam2)-4) (Fexp gam2-N-1)));[intros W'|idtac]. apply Rle_trans with (FtoR radix(Float 1%nat (Fexp (Float ((Fnum gam2)-4) (Fexp gam2-N-1)))))%R;[right; unfold FtoR;simpl;ring|idtac]. cut (0 < FtoR radix (Float ((Fnum gam2)-4) (Fexp gam2 - N - 1)))%R; [intros W''|idtac]. rewrite <- CanonicFulp with b radix prec (Float ((Fnum gam2)-4) (Fexp gam2-N-1)); auto with zarith. rewrite FulpFabs with b radix prec x; auto with zarith. apply LeFulpPos; auto with real float zarith. apply FcanonicBound with radix;auto. rewrite Fabs_correct; auto with zarith. fold FtoRradix; apply Rle_trans with (2:=H9). fold FtoRradix; rewrite <- W3. apply Rle_trans with (powerRZ radix (Zpred (- N))*(((Fnum gam2)-4)*(powerRZ radix (Fexp gam2))))%R. right; unfold FtoRradix, FtoR;simpl; unfold Zminus, Zpred;repeat rewrite powerRZ_add; auto with real zarith. rewrite plus_IZR; simpl;ring. apply Rle_trans with (powerRZ radix (Zpred (- N)) * (gam2 * / (1 + powerRZ radix (2 - prec))))%R;[idtac|unfold Rdiv;right;ring]. apply Rmult_le_compat_l; auto with real zarith. apply Rmult_le_reg_l with (1 + powerRZ radix (2 - prec))%R; auto with real. apply Rle_trans with (FtoRradix gam2);[idtac|right;field;auto with real]. unfold FtoRradix, FtoR;rewrite <- Rmult_assoc. apply Rmult_le_compat_r;auto with real zarith. apply Rplus_le_reg_l with (-(Fnum gam2)+4+4*(powerRZ radix (2-prec)))%R. replace (2-prec)%Z with (2-prec)%Z;auto with zarith. ring_simplify. apply Rle_trans with 4; auto with real zarith. apply Rmult_le_reg_l with (powerRZ radix (prec-2));auto with real zarith. rewrite Rmult_comm; rewrite Rmult_assoc. rewrite <- powerRZ_add; auto with real zarith. ring_simplify (2 - prec + (prec - 2))%Z. apply Rle_trans with (Fnum gam2);[right;simpl;ring|idtac]. apply Rle_trans with (Zpos (vNum b))%R;auto with real zarith float. elim W4; intros T1 T2; elim T1; intros T3 T4. apply Rlt_le; rewrite <- (Zabs_eq (Fnum gam2));auto with real zarith. apply LeR0Fnum with radix;auto with real zarith;fold FtoRradix; rewrite W3;auto with real. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ;right. replace (powerRZ radix prec) with (powerRZ radix (2+(prec-2))%Z); [rewrite powerRZ_add;auto with real zarith;simpl|ring_simplify (2+(prec-2))%Z];ring. apply Rle_trans with (4*0+4)%R;[right;simpl;ring|idtac]. apply Rplus_le_compat_r;apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with 2%R; auto with real. apply LtFnumZERO; simpl;auto with real zarith. apply Zlt_Rlt; unfold Zminus; rewrite plus_IZR;simpl. apply Rlt_le_trans with (powerRZ radix (Zpred prec));auto with real zarith. apply Rle_trans with ((powerRZ radix (Zpred prec) + 4)+- (2 + 1 + 1))%R;[right;ring|idtac];auto with real. cut (0 < (Fnum gam2) - 4)%Z;[intros W'|apply Zlt_Rlt; unfold Zminus; rewrite plus_IZR;simpl]. 2:apply Rlt_le_trans with (powerRZ radix (Zpred prec));auto with real zarith. 2:apply Rle_trans with ((powerRZ radix (Zpred prec) + 4)+- (2 + 1 + 1))%R;[right;ring|idtac];auto with real. left;split;[split|idtac]. simpl;rewrite Zabs_eq; auto with zarith. apply Zlt_trans with (Fnum gam2);auto with zarith. rewrite <- (Zabs_eq (Fnum gam2)); auto with zarith float. elim W4; intros T1 T2; elim T1;auto with zarith. simpl;rewrite W5; apply Zle_trans with (1:=exp_gamma_enough3);unfold Zpred; auto with zarith. apply Zle_trans with (Zabs (radix * (Fnum gam2 - 4)))%Z;auto with zarith. rewrite Zabs_eq; auto with zarith. apply Zle_Rle; rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ;unfold Zminus; rewrite mult_IZR;rewrite plus_IZR;simpl. apply Rle_trans with (2 * (((powerRZ radix (Zpred prec) + 4 ) + - (2 + 1 + 1))))%R;auto with real. right; unfold Zpred, Zminus; rewrite powerRZ_add; auto with real zarith;simpl. field; auto with real. apply Rmult_le_reg_l with (1 + powerRZ radix (2 - prec))%R;auto with real. apply Rle_trans with ((powerRZ radix (Zpred (- N)) * gamma))%R;[right;field;auto with real|idtac]. apply Rle_trans with ((Rabs x*alpha)*gamma)%R;auto with real. apply Rle_trans with ((alpha*gamma)*Rabs x)%R;[right;ring|apply Rmult_le_compat_r;auto with real]. apply Rplus_le_reg_l with (-1)%R. apply Rle_trans with (Rabs (-1 + alpha * gamma ))%R;[apply RRle_abs|idtac]. rewrite <- Rabs_Ropp. replace (- (-1 + alpha * gamma))%R with (1-alpha*gamma)%R;[idtac|ring]. apply Rle_trans with (powerRZ radix (2 - prec));[idtac|right;ring]. replace (2-prec)%Z with (2%nat-prec)%Z;auto with zarith. apply delta_inf with b;auto with zarith. apply exp_alpha_le. cut (Rabs (Rabs x*alpha-2*(powerRZ radix (Zpred (- N)))) <= (powerRZ radix (Zpred (- N))))%R;[intros H7|idtac]. split. apply Rplus_le_reg_l with (- Rabs x*alpha+(powerRZ radix (Zpred (- N))))%R. ring_simplify. apply Rle_trans with (2:=H7). rewrite <- (Rabs_Ropp (Rabs x * alpha - 2 * powerRZ radix (Zpred (- N)))). apply Rle_trans with (- (Rabs x * alpha - 2 * powerRZ radix (Zpred (- N))))%R; [right;ring|apply RRle_abs]. apply Rplus_le_reg_l with (-2*(powerRZ radix (Zpred (-N))))%R. ring_simplify (-2 * powerRZ radix (Zpred (- N)) + 3 * powerRZ radix (Zpred (- N)))%R. apply Rle_trans with (2:=H7). apply Rle_trans with (Rabs x * alpha - 2 * powerRZ radix (Zpred (- N)))%R; [right;ring|apply RRle_abs]. replace (2 * powerRZ radix (Zpred (- N)))%R with (Rabs zH). 2: unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith. 2: unfold Fabs, FtoR; simpl; rewrite H3; rewrite H6. 2: simpl; unfold Zpred, Zminus; rewrite powerRZ_add; auto with real zarith;simpl. 2: field; auto with real. assert (forall (r1 r2 C:R), ((0 <= r1)%R -> (0 <= r2)%R) -> ((r1<=0)%R -> (r2 <= 0)%R) -> (Rabs (Rabs r1*C- Rabs r2) = Rabs (r1*C- r2))%R). intros r1 r2 C L1 L2; case (Rle_or_lt 0 r1); intros L3. rewrite (Rabs_right r1); try apply Rle_ge; auto with real. rewrite (Rabs_right r2); try apply Rle_ge; auto with real. rewrite (Rabs_left1 r1); try apply Rle_ge; auto with real. rewrite (Rabs_left1 r2); try apply Rle_ge; auto with real. replace (-r1*C-(-r2))%R with (-(r1*C-r2))%R; [apply Rabs_Ropp| ring]. rewrite H. 2: intros; rewrite <- H2; apply zH1Pos with b prec N alpha x u; auto with zarith. 2: intros; rewrite <- H2; apply zH1Neg with b prec N alpha x u; auto with zarith. rewrite <- H2; unfold FtoRradix, radix. rewrite zH1_eq with b prec N alpha x u zH1; auto with zarith. fold radix; fold FtoRradix. replace (x * alpha - (u - 3%nat * powerRZ radix (Zpred (Zpred (prec - N)))))%R with (((3%nat * powerRZ radix (Zpred (Zpred (prec - N))))+x*alpha)-u)%R;[idtac|ring]. apply Rmult_le_reg_l with 2%nat;auto with real. apply Rle_trans with (Fulp b radix prec u). unfold FtoRradix;apply ClosestUlp; auto with zarith. right; simpl; unfold Fulp, radix. rewrite Fexp_u with b prec N alpha x u;auto with zarith. unfold Zpred, Zminus; rewrite powerRZ_add; auto with real zarith;simpl. field; auto with real. Qed. End Total. Float8.4/FnElem/FArgReduct4.v0000644000423700002640000021657612032774527015502 0ustar sboldotoccata(** FArgReduct4 file Sylvie Boldo This file explains an improvement of Cody & Waite argument reduction technique using the FMA (fused-multiply-and-add). *) Require Export Dekker. Require Export discriminant3. Require Export FmaErr. Require Export FArgReduct3. Section Total. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. (** Variables *) Variable b : Fbound. Variables prec : nat. Variable N : Z. Variables alpha gamma x zH1 u gamma2 v res vL t1 t2: float. (** Various bounds *) Let bmoinsq := Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (prec - 2)%nat)))) (dExp b). (** All the hypotheses *) Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix prec. Hypothesis Fboundedx : Fbounded b x. Hypothesis xCanonic : Fcanonic radix b x. (** alpha (the constant, such as pi) and gamma (its inverse) *) Hypothesis alphaNormal : Fnormal radix b alpha. Hypothesis gammaNormal : Fnormal radix bmoinsq gamma. Hypothesis alphaPos : (0 < alpha)%R. Hypothesis gammaPos : (0 < gamma)%R. Hypothesis gamma_not_pow_2 : forall e : Z, FtoRradix gamma <> powerRZ radix e. Hypothesis gammaDef : Closest bmoinsq radix (/ alpha) gamma. (** About the computation of z *) Hypothesis uDef : Closest b radix (3%nat * powerRZ radix (Zpred (Zpred (prec - N))) + x * alpha) u. Hypothesis zH1Def : Closest b radix (u - 3%nat * powerRZ radix (Zpred (Zpred (prec - N)))) zH1. Hypothesis precMoreThanThree : 5 <= prec. (** 2^-N is a normal float *) Hypothesis N_not_too_big : (N +prec -1 <= dExp b)%Z. (** x not too big *) Hypothesis xalpha_small : (Rabs (x * alpha) <= powerRZ radix (Zpred (Zpred (prec - N))) - powerRZ radix (- N))%R. (** No underflow *) Hypothesis gamma_ge: (powerRZ radix (-dExp b+prec+(Zmax (-1) (prec+N-2)))<= gamma)%R. (** gamma2 is the lower part of the constant *) Hypothesis gamma2Bounded: Fbounded b gamma2. Hypothesis gamma2_le: (Rabs gamma2 <= powerRZ radix (Fexp gamma))%R. Hypothesis gamma2_e_eq: (Fexp gamma2 = Fexp gamma - prec+2)%Z. (** v is the rounding of z gamma2 and vL the error *) Hypothesis vDef : Closest b radix (zH1*gamma2)%R v. Hypothesis vLDef: (FtoRradix vL=zH1*gamma2-v)%R. Hypothesis vLBounded: Fbounded b vL. (** t1 and t2 are the results of the FTS between v and (x-zH1*gamma) *) Hypothesis t1Def: EvenClosest b radix prec (x-zH1*gamma-v)%R t1. Hypothesis t2Def: (FtoRradix t2=x-zH1*gamma-v-t1)%R. Hypothesis t2Bounded: Fbounded b t2. (** res is the final result *) Hypothesis resDef: EvenClosest b radix prec ((x-zH1*gamma)-zH1*gamma2)%R res. Lemma Zmax_case: forall m n:Z, ((n <= m)%Z /\ Zmax m n=m) \/ ((m <= n)%Z /\ Zmax m n=n). intros; unfold Zmax, Zle. CaseEq (m ?= n)%Z; simpl; intros. right; split; auto with zarith; discriminate. right; split; auto with zarith; discriminate. left; split; auto with zarith. rewrite <- Zcompare_antisym; rewrite H; unfold CompOpp; discriminate. Qed. Lemma gamma_ge2: (powerRZ radix (-dExp b+prec+(Zmax (-1) N))<= gamma)%R. apply Rle_trans with (2:=gamma_ge). apply Rle_powerRZ; auto with real zarith. case (Zmax_case (-1) N); intros (L1,L1'); rewrite L1'; case (Zmax_case (-1) (prec+N-2)); intros (L2,L2'); rewrite L2'; auto with zarith. Qed. Lemma exp_gamma_enough: (-dExp b <= Fexp gamma-prec-N)%Z. cut (-dExp b +prec+N+prec-2 < prec-2+Fexp gamma)%Z; auto with zarith. apply Zlt_powerRZ with radix; auto with real zarith. apply Rle_lt_trans with gamma. apply Rle_trans with (2:=gamma_ge); apply Rle_powerRZ; auto with zarith real. apply Zle_trans with (- dExp b + prec + (prec + N-2))%Z; auto with zarith. rewrite powerRZ_add; auto with real zarith. unfold FtoRradix, FtoR; apply Rmult_lt_compat_r; auto with real zarith. apply Rle_lt_trans with (Rabs (Fnum gamma));[apply RRle_abs|idtac]. elim gammaNormal; intros T1 T2; elim T1; intros T3 T4. rewrite Rabs_Zabs; apply Rlt_le_trans with (Zpos (vNum bmoinsq)); auto with real zarith. unfold bmoinsq; rewrite vNum_eq_Zpower_bmoinsq. rewrite Zpower_nat_Z_powerRZ; rewrite inj_minus1; auto with zarith real. Qed. Theorem Fexp_x_aprox_zh_gamma: (0 <> zH1)%R -> (exists k:Z, (powerRZ radix k <= Rabs zH1 < powerRZ radix (k+1))%R /\ (Fexp gamma+k-3 <= Fexp x)%Z /\ (-N <= k <= prec-3-N)%Z /\ ((Fexp gamma-N-2 <= Fexp x)%Z \/ (Rabs zH1=powerRZ radix (-N))%R)). intros P. case (Rle_or_lt (powerRZ (Zpos 2) (2 - Zsucc N)) (Rabs zH1)); intros M. elim (arg_reduct_exists_k_zH b prec N alpha x u zH1); auto with zarith. intros k (zH, (L2,(L3,(L4,(L5,(L6,(L7,(L8,(L9,L10))))))))). exists k. split; auto with real zarith. assert (Fexp gamma + k - 3 <= Fexp x)%Z. assert (k-1+Fexp gamma+(prec-3) < Fexp x+prec)%Z; auto with zarith. apply Zlt_le_trans with (Fexp (Fabs x) + prec)%Z; auto with zarith. apply Zlt_powerRZ with radix; auto with real zarith. apply Rle_lt_trans with (Rabs x). 2: unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith. 2: unfold Fabs, FtoR; simpl; rewrite powerRZ_add; auto with real zarith. 2: rewrite Rmult_comm; apply Rmult_lt_compat_l; auto with real zarith. 2: elim Fboundedx; intros. 2: replace (powerRZ 2 prec) with (IZR ( Zpos (vNum b))); auto with zarith real. 2: rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; auto with real. apply Rle_trans with (gamma*powerRZ radix (k-1))%R. rewrite Rmult_comm; rewrite powerRZ_add; auto with real zarith. rewrite powerRZ_add; auto with real zarith; rewrite Rmult_assoc. apply Rmult_le_compat_l; auto with real zarith. rewrite Rmult_comm; unfold FtoRradix, FtoR. apply Rmult_le_compat_r; auto with real zarith. elim gammaNormal; intros. apply Rmult_le_reg_l with radix; auto with real zarith. apply Rle_trans with (Zpos (vNum bmoinsq)). unfold bmoinsq; rewrite vNum_eq_Zpower_bmoinsq. rewrite Zpower_nat_Z_powerRZ; rewrite inj_minus1; auto with zarith. unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith. simpl; right; field; auto with real. repeat apply prod_neq_R0; auto with real zarith. apply Rle_trans with (Zabs (radix * Fnum gamma)); auto with real zarith. rewrite Zabs_Zmult; rewrite Zabs_eq; auto with zarith. rewrite mult_IZR; rewrite Zabs_eq; auto with zarith real. apply LeR0Fnum with radix; auto with real zarith. apply Rle_trans with (Rabs (/alpha) / (1 - powerRZ (Zpos 2) (- (prec-2)%nat)) * powerRZ radix (k-1))%R. apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (Rabs gamma);[apply RRle_abs|idtac]. unfold FtoRradix, radix; apply RoundLeNormal with bmoinsq; auto with zarith. unfold bmoinsq; rewrite vNum_eq_Zpower_bmoinsq; auto. rewrite Rabs_right; auto with real. 2: apply Rle_ge; auto with real. assert (0 < 3)%R. apply Rlt_le_trans with 2%R; auto with real. apply Rmult_le_reg_l with (FtoRradix alpha); auto with real. rewrite inj_minus1; auto with zarith. assert (0 < (1 - powerRZ radix (- (prec-S 1))))%R. apply Rplus_lt_reg_r with (powerRZ radix (- (prec-S 1))). ring_simplify. replace 1%R with (powerRZ radix 0); [ apply Rlt_powerRZ; simpl;auto with real zarith | simpl in |- *; auto ]. apply Rle_trans with (/ (1 - powerRZ (Zpos 2) (- (prec - S 1))) * powerRZ radix (k-1))%R;[right; field|idtac]. repeat apply prod_neq_R0; auto with real zarith. apply Rle_trans with (3/2* powerRZ radix (k-1))%R. apply Rmult_le_compat_r; auto with real zarith. replace (3/2)%R with (/(2/3))%R; [idtac|field;auto with real]. apply Rle_Rinv; auto with real. unfold Rdiv; apply Rmult_lt_0_compat; auto with real. apply Rmult_le_reg_l with 3%R; auto with real. apply Rle_trans with 2%R;[right; field; auto with real|idtac]. apply Rplus_le_reg_l with (3*powerRZ radix (- (prec-S 1))-2)%R. apply Rle_trans with (3*powerRZ radix (- (prec-S 1)))%R;[right; ring|idtac]. apply Rle_trans with (powerRZ radix 0);[idtac|simpl; right;ring]. apply Rle_trans with (powerRZ radix (2+- (prec-S 1))). rewrite powerRZ_add; auto with real zarith; apply Rmult_le_compat_r; auto with real zarith. simpl; apply Rle_trans with (3+1)%R; auto with real. right; ring. apply Rle_powerRZ; auto with zarith real. replace (2 + - (prec - S 1))%Z with (4-prec)%Z; auto with zarith. replace (Z_of_nat (S 1)) with 2%Z; auto with zarith. repeat apply prod_neq_R0; auto with real. apply Rle_trans with (Rabs zH-/4*Rabs zH)%R. apply Rle_trans with (3/4* powerRZ radix k)%R. unfold Zminus; rewrite powerRZ_add; auto with real zarith. simpl; right;field; auto with real. apply Rle_trans with (3/4* Rabs zH)%R. apply Rmult_le_compat_l; auto with real. left; unfold Rdiv; apply Rmult_lt_0_compat; auto with real. assert (0 < 4)%R; try apply Rmult_lt_0_compat; auto with real. unfold FtoRradix, radix; rewrite <- L2; auto with real. right; field; auto with real. apply Rplus_le_reg_l with (-alpha*Rabs x+/4*Rabs zH)%R. apply Rle_trans with (-(Rabs x*alpha-Rabs zH))%R;[right; ring|idtac]. apply Rle_trans with (Rabs (-(Rabs x*alpha-Rabs zH)));[apply RRle_abs|rewrite Rabs_Ropp]. assert (forall (r1 r2 C:R), ((0 <= r1)%R -> (0 <= r2)%R) -> ((r1<=0)%R -> (r2 <= 0)%R) -> (Rabs (Rabs r1*C-Rabs r2) = Rabs (r1*C- r2))%R). intros r1 r2 C G1 G2; case (Rle_or_lt 0 r1); intros G3. rewrite (Rabs_right r1); try apply Rle_ge; auto with real. rewrite (Rabs_right r2); try apply Rle_ge; auto with real. rewrite (Rabs_left1 r1); try apply Rle_ge; auto with real. rewrite (Rabs_left1 r2); try apply Rle_ge; auto with real. replace (-r1*C-(-r2))%R with (-(r1*C-r2))%R; [apply Rabs_Ropp| ring]. rewrite H1. 2: intros; unfold FtoRradix, radix; rewrite <- L2; apply zH1Pos with b prec N alpha x u; auto with zarith. 2: intros; unfold FtoRradix, radix; rewrite <- L2; apply zH1Neg with b prec N alpha x u; auto with zarith. apply Rle_trans with (powerRZ (Zpos 2) (Zpred (- N))); auto with real. apply Rle_trans with (/4*Rabs zH)%R;[idtac|right; ring]. apply Rle_trans with (/4*powerRZ radix (2 - Zsucc N))%R;[idtac| apply Rmult_le_compat_l; auto with real]. 2: assert (0 < 4)%R; auto with real. 2: apply Rmult_lt_0_compat; auto with real. 2: unfold FtoRradix,radix; rewrite <- L2; auto with real. replace (2 - Zsucc N)%Z with (1-N)%Z;[idtac|unfold Zsucc; ring]. unfold Zpred,Zminus; repeat rewrite powerRZ_add; auto with real zarith. unfold radix; simpl; right; field; auto with real. repeat apply prod_neq_R0; auto with real. split; trivial. split. split. apply Zplus_le_reg_l with (1+N)%Z. apply Zle_trans with (Zsucc (k+N)); auto with zarith. apply Zle_trans with (Zabs_nat (Zsucc (k + N))); auto with zarith. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. apply Zplus_le_reg_l with (1+N)%Z. apply Zle_trans with (Zsucc (k+N)); auto with zarith. left; apply Zle_trans with (2:=H). assert (-N < k)%Z; auto with zarith. assert (2 - Zsucc N < Zsucc k)%Z; [idtac|unfold Zsucc; auto with zarith]. apply Zlt_powerRZ with (Zpos 2); auto with real zarith. apply Rle_lt_trans with (1:=M); auto with real. assert (Rabs zH1=powerRZ radix (-N))%R. cut (zH1 = Float (Fnum (Fnormalize radix b prec u) - 3%nat * Zpower_nat radix (pred (pred prec))) ( - N) :>R); [ intros H'1 | idtac ]. 2:unfold FtoRradix, radix in |- *; rewrite zH1_eq with b prec N alpha x u zH1; auto with zarith. 2:rewrite <- FnormalizeCorrect with 2%Z b prec u; auto with zarith; unfold FtoR in |- *. 2:apply trans_eq with ((Fnum (Fnormalize 2 b prec u) - 3%nat * Zpower_nat 2 (pred (pred prec)))%Z * powerRZ 2%Z (- N))%R; [ idtac | simpl in |- *; auto with zarith real ]. 2:unfold Zminus in |- *; rewrite plus_IZR; rewrite Ropp_Ropp_IZR; rewrite mult_IZR; rewrite Zpower_nat_Z_powerRZ. 2:rewrite Fexp_u with b prec N alpha x u; auto with zarith. 2: replace (Zpred (Zpred (prec + - N))) with (- N + pred (pred prec))%Z. 2: rewrite powerRZ_add; auto with real zarith; simpl; ring. 2: rewrite inj_pred; auto with zarith; rewrite inj_pred; auto with zarith; unfold Zpred; ring. cut (exists zH : float, FtoRradix zH1 = zH /\ Fexp zH = (- N)%Z /\ (Zabs (Fnum zH) < powerRZ radix (Zpred 2))%R /\ (0 < Rabs zH)%R). 2:exists (Float (Fnum (Fnormalize radix b prec u) - 3%nat * Zpower_nat radix (pred (pred prec))) ( - N)). 2:split; [ auto | idtac ]. 2:split; [ simpl in |- *; auto | idtac ]. 2:split. 2:apply Rmult_lt_reg_l with (powerRZ radix (- N)); auto with real zarith. 2:apply Rle_lt_trans with (Rabs zH1); [ right; rewrite H'1; unfold FtoRradix, FtoR; simpl | idtac]. 2: rewrite Rabs_mult; rewrite Rabs_Zabs; rewrite Rabs_right; auto with real. 2: apply Rle_ge; auto with real zarith. 2:rewrite <- powerRZ_add; auto with real zarith. 2:replace (- N + Zpred 2)%Z with (2 - Zsucc N)%Z; auto; unfold Zsucc, Zpred in |- *; ring. 2:rewrite <- H'1; cut (0 <= Rabs zH1)%R; auto with real. 2: intros L; case L; auto with real. 2: intros; absurd (Rabs zH1=0)%R; auto with real; apply Rabs_no_R0; auto with real. intros V; elim V; intros zH V1; elim V1; intros H2 V2; elim V2; intros H3 V3; elim V3; intros H4 H5; clear V V1 V2 V3. cut (Zabs (Fnum zH)=1)%Z;[intros H6|idtac]. 2: cut (0 < Zabs (Fnum zH))%Z;[intros H'3| apply Zlt_le_trans with (Fnum (Fabs zH)); auto with zarith; apply LtR0Fnum with radix];auto with real zarith. 2: cut (Zabs (Fnum zH) < 2)%Z;[intros H'4|idtac];auto with real zarith. 2:apply Zlt_Rlt; apply Rlt_le_trans with (1:=H4);auto with real zarith. rewrite H2; unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith. unfold Fabs, FtoR; rewrite H6; rewrite H3; simpl; ring. rewrite Fabs_correct; auto with real zarith. exists (-N)%Z. split. rewrite H;split;auto with real zarith. split;[idtac|auto with zarith]. cut ((((powerRZ radix (Zpred (-N))) <= Rabs x*alpha)%R) /\ ((Rabs x*alpha <=3*(powerRZ radix (Zpred (-N))))%R)). intros T;elim T; intros W1 W2;clear T. elim (gamma_p b prec N gamma); auto with zarith. fold radix; fold FtoRradix. intros gam2 T2;elim T2; intros W3 T3;elim T3; intros W4 T4; elim T4; intros W5 T5; elim T5; intros W6 W7; clear T2 T3 T4 T5. cut (0 < (1 + powerRZ radix (2 - prec)))%R;[intros W8|idtac]. 2: apply Rlt_trans with 1%R; auto with real zarith. 2: apply Rle_lt_trans with (1+0)%R; auto with real zarith. cut ((powerRZ radix (Zpred (-N)))*gamma/(1+(powerRZ radix (Zminus 2 prec))) <= Rabs x)%R;[intros H9|idtac]. cut ((Fexp gam2 - N - 1) <= Fexp x)%Z. rewrite W5; unfold Zpred; auto with zarith. apply Zle_powerRZ with radix; auto with zarith real. apply Rle_trans with (FtoR radix(Float 1%nat (Fexp x)))%R;[idtac|right; unfold FtoR;simpl;ring]. rewrite <- CanonicFulp with b radix prec x; auto with zarith. cut (Fcanonic radix b (Float ((Fnum gam2)-4) (Fexp gam2-N-1)));[intros W'|idtac]. apply Rle_trans with (FtoR radix(Float 1%nat (Fexp (Float ((Fnum gam2)-4) (Fexp gam2-N-1)))))%R;[right; unfold FtoR;simpl;ring|idtac]. cut (0 < FtoR radix (Float ((Fnum gam2)-4) (Fexp gam2 - N - 1)))%R; [intros W''|idtac]. rewrite <- CanonicFulp with b radix prec (Float ((Fnum gam2)-4) (Fexp gam2-N-1)); auto with zarith. rewrite FulpFabs with b radix prec x; auto with zarith. apply LeFulpPos; auto with real float zarith. apply FcanonicBound with radix;auto. rewrite Fabs_correct; auto with zarith. fold FtoRradix; apply Rle_trans with (2:=H9). fold FtoRradix; rewrite <- W3. apply Rle_trans with (powerRZ radix (Zpred (- N))*(((Fnum gam2)-4)*(powerRZ radix (Fexp gam2))))%R. right; unfold FtoRradix, FtoR;simpl; unfold Zminus, Zpred;repeat rewrite powerRZ_add; auto with real zarith. rewrite plus_IZR; simpl;ring. apply Rle_trans with (powerRZ radix (Zpred (- N)) * (gam2 * / (1 + powerRZ radix (2 - prec))))%R;[idtac|unfold Rdiv;right;ring]. apply Rmult_le_compat_l; auto with real zarith. apply Rmult_le_reg_l with (1 + powerRZ radix (2 - prec))%R; auto with real. apply Rle_trans with (FtoRradix gam2);[idtac|right;field;auto with real]. unfold FtoRradix, FtoR;rewrite <- Rmult_assoc. apply Rmult_le_compat_r;auto with real zarith. apply Rplus_le_reg_l with (-(Fnum gam2)+4+4*(powerRZ radix (2-prec)))%R. replace (2-prec)%Z with (2-prec)%Z;auto with zarith. ring_simplify. apply Rle_trans with 4; auto with real zarith. apply Rmult_le_reg_l with (powerRZ radix (prec-2));auto with real zarith. rewrite Rmult_comm; rewrite Rmult_assoc. rewrite <- powerRZ_add; auto with real zarith. ring_simplify (2 - prec + (prec - 2))%Z. apply Rle_trans with (Fnum gam2);[right;simpl;ring|idtac]. apply Rle_trans with (Zpos (vNum b))%R;auto with real zarith float. elim W4; intros T1 T2; elim T1; intros T3 T4. apply Rlt_le; rewrite <- (Zabs_eq (Fnum gam2));auto with real zarith. apply LeR0Fnum with radix;auto with real zarith;fold FtoRradix; rewrite W3;auto with real. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ;right. replace (powerRZ radix prec) with (powerRZ radix (2+(prec-2))%Z); [rewrite powerRZ_add;auto with real zarith;simpl|ring_simplify (2+(prec-2))%Z];ring. apply Rle_trans with (4*0+4)%R;[right;simpl;ring|idtac]. apply Rplus_le_compat_r;apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with 2%R; auto with real. apply LtFnumZERO; simpl;auto with real zarith. apply Zlt_Rlt; unfold Zminus; rewrite plus_IZR;simpl. apply Rlt_le_trans with (powerRZ radix (Zpred prec));auto with real zarith. apply Rle_trans with ((powerRZ radix (Zpred prec) + 4)+- (2 + 1 + 1))%R;[right;ring|idtac];auto with real. cut (0 < (Fnum gam2) - 4)%Z;[intros W'|apply Zlt_Rlt; unfold Zminus; rewrite plus_IZR;simpl]. 2:apply Rlt_le_trans with (powerRZ radix (Zpred prec));auto with real zarith. 2:apply Rle_trans with ((powerRZ radix (Zpred prec) + 4)+- (2 + 1 + 1))%R;[right;ring|idtac];auto with real. left;split;[split|idtac]. simpl;rewrite Zabs_eq; auto with zarith. apply Zlt_trans with (Fnum gam2);auto with zarith. rewrite <- (Zabs_eq (Fnum gam2)); auto with zarith float. elim W4; intros T1 T2; elim T1;auto with zarith. simpl;rewrite W5; apply Zle_trans with (Fexp gamma - N - 3)%Z. apply exp_gamma_enough3 with prec; auto with zarith. apply gamma_ge2. unfold Zpred; auto with zarith. apply Zle_trans with (Zabs (radix * (Fnum gam2 - 4)))%Z;auto with zarith. rewrite Zabs_eq; auto with zarith. apply Zle_Rle; rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ;unfold Zminus; rewrite mult_IZR;rewrite plus_IZR;simpl. apply Rle_trans with (2 * (((powerRZ radix (Zpred prec) + 4 ) + - (2 + 1 + 1))))%R;auto with real. right; unfold Zpred, Zminus; rewrite powerRZ_add; auto with real zarith;simpl. field; auto with real. apply Rmult_le_reg_l with (1 + powerRZ radix (2 - prec))%R;auto with real. apply Rle_trans with ((powerRZ radix (Zpred (- N)) * gamma))%R;[right;field;auto with real|idtac]. apply Rle_trans with ((Rabs x*alpha)*gamma)%R;auto with real. apply Rle_trans with ((alpha*gamma)*Rabs x)%R;[right;ring|apply Rmult_le_compat_r;auto with real]. apply Rplus_le_reg_l with (-1)%R. apply Rle_trans with (Rabs (-1 + alpha * gamma ))%R;[apply RRle_abs|idtac]. rewrite <- Rabs_Ropp. replace (- (-1 + alpha * gamma))%R with (1-alpha*gamma)%R;[idtac|ring]. apply Rle_trans with (powerRZ radix (2 - prec));[idtac|right;ring]. replace (2-prec)%Z with (2%nat-prec)%Z;auto with zarith. apply delta_inf with b;auto with zarith. apply exp_alpha_le with N gamma; auto with zarith. apply gamma_ge2. apply gamma_ge2. cut (Rabs (Rabs x*alpha-2*(powerRZ radix (Zpred (- N)))) <= (powerRZ radix (Zpred (- N))))%R;[intros H7|idtac]. split. apply Rplus_le_reg_l with (-Rabs x*alpha+(powerRZ radix (Zpred (- N))))%R. ring_simplify. apply Rle_trans with (2:=H7). rewrite <- (Rabs_Ropp (Rabs x * alpha - 2 * powerRZ radix (Zpred (- N)))). apply Rle_trans with (- (Rabs x * alpha - 2 * powerRZ radix (Zpred (- N))))%R; [right;ring|apply RRle_abs]. apply Rplus_le_reg_l with (-2*(powerRZ radix (Zpred (-N))))%R. ring_simplify (-2 * powerRZ radix (Zpred (- N)) + 3 * powerRZ radix (Zpred (- N)))%R. apply Rle_trans with (2:=H7). apply Rle_trans with (Rabs x * alpha - 2 * powerRZ radix (Zpred (- N)))%R; [right;ring|apply RRle_abs]. replace (2 * powerRZ radix (Zpred (- N)))%R with (Rabs zH1). 2: rewrite H; unfold Zpred, Zminus; rewrite powerRZ_add; auto with real zarith;simpl. 2: field; auto with real. assert (forall (r1 r2 C:R), ((0 <= r1)%R -> (0 <= r2)%R) -> ((r1<=0)%R -> (r2 <= 0)%R) -> (Rabs (Rabs r1*C-Rabs r2) = Rabs (r1*C- r2))%R). intros r1 r2 C L1 L2; case (Rle_or_lt 0 r1); intros L3. rewrite (Rabs_right r1); try apply Rle_ge; auto with real. rewrite (Rabs_right r2); try apply Rle_ge; auto with real. rewrite (Rabs_left1 r1); try apply Rle_ge; auto with real. rewrite (Rabs_left1 r2); try apply Rle_ge; auto with real. replace (-r1*C-(-r2))%R with (-(r1*C-r2))%R; [apply Rabs_Ropp| ring]. rewrite H0; auto with real. 2: intros; apply zH1Pos with b prec N alpha x u; auto with zarith. 2: intros; apply zH1Neg with b prec N alpha x u; auto with zarith. unfold FtoRradix, radix. rewrite zH1_eq with b prec N alpha x u zH1; auto with zarith. fold radix; fold FtoRradix. replace (x * alpha - (u - 3%nat * powerRZ radix (Zpred (Zpred (prec - N)))))%R with (((3%nat * powerRZ radix (Zpred (Zpred (prec - N))))+x*alpha)-u)%R;[idtac|ring]. apply Rmult_le_reg_l with 2%nat;auto with real. apply Rle_trans with (Fulp b radix prec u). unfold FtoRradix;apply ClosestUlp; auto with zarith. right; simpl; unfold Fulp, radix. rewrite Fexp_u with b prec N alpha x u;auto with zarith. unfold Zpred, Zminus; rewrite powerRZ_add; auto with real zarith;simpl. field; auto with real. Qed. Lemma zH_exp_N: exists f:float, (FtoRradix f=zH1)%R /\ Fbounded b f /\ (Fexp f=-N)%Z. case (Rle_or_lt (powerRZ (Zpos 2) (2 - Zsucc N)) (Rabs zH1)); intros M. elim (arg_reduct_exists_k_zH b prec N alpha x u zH1); auto with zarith. fold radix; fold FtoRradix. intros k (zH, (L2,(L3,(L4,(L5,(L6,(L7,(L8,(L9,L10))))))))). exists zH; split; auto with real; split. elim L7; intros T1 T2; elim T1; rewrite vNum_eq_Zpower_bzH; intros T3 T4; clear T1 T2. split;[idtac|simpl in T4; auto]. apply Zlt_le_trans with (Zpower_nat 2 (Zabs_nat (Zsucc (k + N)))); trivial. rewrite pGivesBound; auto with zarith. assert (Zabs_nat (Zsucc (k + N)) < prec)%Z; auto with zarith. apply Zle_lt_trans with (Zpred (Zpred prec)); auto with zarith. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. rewrite L6; ring. case (Req_dec zH1 0); intros M'. exists (Float 0 (-N)). split;[rewrite M'; unfold FtoRradix, FtoR; simpl; ring|split; auto]. split; simpl; auto with zarith. assert (Rabs zH1=powerRZ radix (-N))%R. cut (zH1 = Float (Fnum (Fnormalize radix b prec u) - 3%nat * Zpower_nat radix (pred (pred prec))) ( - N) :>R); [ intros H'1 | idtac ]. 2:unfold FtoRradix, radix in |- *; rewrite zH1_eq with b prec N alpha x u zH1; auto with zarith. 2:rewrite <- FnormalizeCorrect with 2%Z b prec u; auto with zarith; unfold FtoR in |- *. 2:apply trans_eq with ((Fnum (Fnormalize 2 b prec u) - 3%nat * Zpower_nat 2 (pred (pred prec)))%Z * powerRZ 2%Z (- N))%R; [ idtac | simpl in |- *; auto with zarith real ]. 2:unfold Zminus in |- *; rewrite plus_IZR; rewrite Ropp_Ropp_IZR; rewrite mult_IZR; rewrite Zpower_nat_Z_powerRZ. 2:rewrite Fexp_u with b prec N alpha x u; auto with zarith. 2: replace (Zpred (Zpred (prec + - N))) with (- N + pred (pred prec))%Z. 2: rewrite powerRZ_add; auto with real zarith; simpl; ring. 2: rewrite inj_pred; auto with zarith; rewrite inj_pred; auto with zarith; unfold Zpred in |- *; ring. cut (exists zH : float, FtoRradix zH1 = zH /\ Fexp zH = (- N)%Z /\ (Zabs (Fnum zH) < powerRZ radix (Zpred 2))%R /\ (0 < Rabs zH)%R). 2:exists (Float (Fnum (Fnormalize radix b prec u) - 3%nat * Zpower_nat radix (pred (pred prec))) ( - N)). 2:split; [ auto | idtac ]. 2:split; [ simpl in |- *; auto | idtac ]. 2:split. 2:apply Rmult_lt_reg_l with (powerRZ radix (- N)); auto with real zarith. 2:apply Rle_lt_trans with (Rabs zH1); [ right; rewrite H'1; unfold FtoRradix, FtoR in |- *; simpl | idtac ]. 2: rewrite Rabs_mult; rewrite Rabs_Zabs; rewrite Rabs_right; try apply Rle_ge; auto with real zarith. 2:rewrite <- powerRZ_add; auto with real zarith. 2:replace (- N + Zpred 2)%Z with (2 - Zsucc N)%Z; auto; unfold Zsucc, Zpred in |- *; ring. 2:rewrite <- H'1; auto with real. intros V; elim V; intros zH V1; elim V1; intros H2' V2; elim V2; intros H3 V3; elim V3; intros H4 H5; clear V V1 V2 V3. cut (Zabs (Fnum zH)=1)%Z;[intros H6|idtac]. 2: cut (0 < Zabs (Fnum zH))%Z;[intros H'3| apply Zlt_le_trans with (Fnum (Fabs zH)); auto with zarith; apply LtR0Fnum with radix];auto with real zarith. 2: cut (Zabs (Fnum zH) < 2)%Z;[intros H'4|idtac];auto with real zarith. 2:apply Zlt_Rlt; apply Rlt_le_trans with (1:=H4);auto with real zarith. 2: rewrite Fabs_correct; auto with real zarith. rewrite H2'; unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith. unfold Fabs, FtoR; rewrite H6; rewrite H3; simpl; ring. assert (0 <= Rabs zH1)%R; auto with real. case H; auto. intros; absurd (Rabs zH1=0)%R; auto with real; apply Rabs_no_R0; auto. generalize H; unfold Rabs; case Rcase_abs; intros. exists (Float (-1) (-N)). split;[apply trans_eq with (-(-zH1))%R; auto with real; rewrite H0; unfold FtoRradix, FtoR; simpl; ring|split; auto]. split; simpl; auto with zarith. apply vNumbMoreThanOne with radix prec; auto with zarith. exists (Float 1 (-N)). split;[ rewrite H0; unfold FtoRradix, FtoR; simpl; ring|split; auto]. split; simpl; auto with zarith. apply vNumbMoreThanOne with radix prec; auto with zarith. Qed. (** A Fast Two Sum can be used to compute the sum of the first reduced argument and o(zH*gamma2) *) Theorem FTS_correct_aux: ((FtoRradix zH1=0)%R\/(FtoRradix v=0)%R) \/ exists ff:float, FtoRradix ff = (x - zH1 * gamma)%R /\ Fbounded b ff /\ (Fexp (Fnormalize radix b prec v) <= -N + Fexp gamma -2)%Z /\ (-N + Fexp gamma -3 <= Fexp ff)%Z /\ (~(Rabs zH1) = powerRZ radix (-N) -> (-N + Fexp gamma -2 <= Fexp ff)%Z) /\ ((Rabs zH1) = powerRZ radix (-N) -> (Fexp (Fnormalize radix b prec v) <= Fexp ff)%Z). case (Req_dec zH1 0); auto with real; intros L. case (Req_dec v 0); auto with real; intros LL;right. elim Fexp_x_aprox_zh_gamma; auto. intros k (H1,(H2,(K1,K2))). assert ((exists f : float, FtoRradix f = (x - zH1 * gamma)%R /\ Fbounded b f) /\ (Rabs (x-zH1 * gamma) < powerRZ radix (prec - N + Fexp gamma))%R). unfold FtoRradix; apply Fmac_arg_reduct_correct3 with alpha u; auto with zarith. apply gamma_ge2. elim H;intros T' M; elim T'; intros f T; elim T; intros H3 H4; clear H T T'. assert (exists zH:float, FtoRradix zH=zH1 /\ (Fexp zH=-N)%Z /\ (Rabs zH <= (powerRZ radix prec -1)*powerRZ radix (-N-2))%R). exists (Fminus radix (Fnormalize radix b prec u) (Float 3 (Zpred (Zpred (prec - N))))). split. unfold FtoRradix, radix; rewrite zH1_eq with b prec N alpha x u zH1; auto with zarith. rewrite Fminus_correct; auto with zarith; rewrite FnormalizeCorrect; auto with zarith. split;[simpl|idtac]. unfold radix; rewrite Fexp_u with b prec N alpha x u; auto with zarith. apply Zmin_le1; unfold Zpred; auto with zarith. apply Rle_trans with (Rabs zH1). unfold FtoRradix,radix. rewrite Fminus_correct; auto with zarith; rewrite FnormalizeCorrect; auto with zarith. rewrite zH1_eq with b prec N alpha x u zH1; auto with zarith. unfold FtoR; simpl; right; ring. case (Rle_or_lt (powerRZ (Zpos 2) (2 - Zsucc N)) (Rabs zH1)); intros L'. elim arg_reduct_exists_k_zH with b prec N alpha x u zH1; auto with zarith. intros k' (zH',(L2,(L3,(L4,(L5,(L6,(L7,(L8,(L9,L10))))))))). apply Rle_trans with (Rabs (Fnormalize radix b prec zH1)). unfold FtoRradix; rewrite FnormalizeCorrect; auto with zarith real. apply Rle_trans with (FPred b radix prec (Float (nNormMin radix prec) (k'-prec+2))). unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith. apply FPredProp; auto with zarith. apply FcanonicFabs; auto with zarith. apply FnormalizeCanonic; auto with zarith. elim zH1Def; auto. left; split; try split. apply Zle_lt_trans with (Zabs (nNormMin radix prec)); auto with zarith. rewrite Zabs_eq; auto with zarith float. apply ZltNormMinVnum; auto with zarith. apply Zlt_le_weak; apply nNormPos; auto with zarith. apply Zle_trans with (k'-prec+2)%Z; auto with zarith. apply Zle_trans with (Zabs (radix*(nNormMin radix prec))); auto with zarith. rewrite <- PosNormMin with radix b prec; auto with zarith. rewrite Fabs_correct; auto with zarith. rewrite FnormalizeCorrect; auto with zarith. apply Rlt_le_trans with (powerRZ radix (Zsucc k')); auto with real. unfold FtoR; simpl; unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. rewrite <- powerRZ_add; auto with real zarith. apply Rle_powerRZ; auto with real zarith. rewrite inj_pred; unfold Zsucc, Zpred; auto with zarith. rewrite FPredSimpl2; auto with real zarith. unfold FtoRradix, FtoR; simpl. replace (powerRZ 2 prec - 1)%R with (IZR (pPred (vNum b))). apply Rmult_le_compat_l. assert (0 < pPred (vNum b))%Z;[apply pPredMoreThanOne with radix prec|idtac]; auto with real zarith. apply Rle_powerRZ; unfold Zpred; auto with zarith real. generalize L3; unfold Zsucc, Zpred; auto with zarith. unfold pPred, Zpred, Zminus; rewrite plus_IZR; rewrite pGivesBound. rewrite Zpower_nat_Z_powerRZ; simpl; auto with real. assert (-dExp b < k'-prec+2)%Z; auto with zarith. apply Zlt_le_trans with (-N-prec+2)%Z; auto with zarith. cut (1 < Zsucc (k'+N))%Z;[unfold Zsucc; auto with zarith|idtac]. apply Zlt_le_trans with (Zabs_nat (Zsucc (k' + N))); auto with zarith. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. apply Rle_trans with (powerRZ radix (2-Zsucc N)); auto with real zarith. apply Rle_trans with (powerRZ radix (prec-1)* powerRZ radix (- N - 2))%R. rewrite <- powerRZ_add; auto with real zarith. apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (powerRZ radix prec-powerRZ radix (prec - 1))%R; [right|unfold Rminus; apply Rplus_le_compat_l; apply Ropp_le_contravar]. unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith. simpl; field; auto with real. apply Rle_trans with (powerRZ radix 0); auto with real zarith. elim H; intros zH (H3',(H4',H5')); clear H. elim plusExpMin with b radix prec (Closest b radix) x (Fopp (Fmult zH gamma)) f; auto with zarith. 2: apply ClosestRoundedModeP with prec; auto with zarith. 2: replace (FtoR radix x + FtoR radix (Fopp (Fmult zH gamma)))%R with (FtoR radix f). 2: apply RoundedModeProjectorIdem with b; auto with zarith. 2: apply ClosestRoundedModeP with prec; auto with zarith. 2: rewrite Fopp_correct; rewrite Fmult_correct; auto with real zarith. 2: fold FtoRradix; rewrite H3'; auto with real. intros ff (H5, (H6,H7)). replace (Fexp (Fopp (Fmult zH gamma))) with (-N+Fexp gamma)%Z in H7. 2: simpl;auto with zarith. exists ff; split. unfold FtoRradix; rewrite H6; fold FtoRradix; auto with real. split; auto. split. 2: split. 2: apply Zle_trans with (2:=H7). 2: case (Zmin_or (Fexp x) (- N + Fexp gamma)); intros Y; rewrite Y; auto with zarith. elim vDef; intros Fv T; clear T. assert (H:(Fcanonic radix b (Fnormalize radix b prec v))); [apply FnormalizeCanonic; auto with zarith|idtac]. case H; clear H; intros H. assert (prec - 1 + Fexp (Fnormalize radix b prec v) < prec + (- N + Fexp gamma - 2))%Z; auto with zarith. apply Zlt_powerRZ with radix; auto with real zarith. apply Rle_lt_trans with (Rabs v). apply Rle_trans with (Zpos (vNum b) * (Float (S 0) (Zpred (Fexp (Fnormalize radix b prec v)))))%R. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ. apply Rle_trans with (powerRZ radix prec * powerRZ radix (Zpred (Fexp (Fnormalize radix b prec v))))%R. rewrite <- powerRZ_add; auto with zarith real. apply Rle_powerRZ; unfold Zpred; auto with zarith real. unfold FtoRradix, FtoR; simpl; right; ring. apply Rle_trans with (Fabs (Fnormalize radix b prec v)). unfold FtoRradix; apply FnormalBoundAbs2 with prec; auto with zarith. unfold FtoRradix; rewrite Fabs_correct; auto with zarith. rewrite FnormalizeCorrect; auto with zarith real. apply Rle_lt_trans with (Float (Zpred (Zpos (vNum b))) (-N+Fexp gamma-2)). unfold FtoRradix; apply RoundAbsMonotoner with b prec (Closest b radix) (zH1 * gamma2)%R; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. split. apply Zle_lt_trans with (Zabs (Zpred (Zpos (vNum b)))); auto with zarith. rewrite Zabs_eq; auto with zarith. apply Zle_trans with (- N + Fexp gamma - 2)%Z; auto with zarith. assert (- dExp b <= Fexp gamma - prec - N)%Z; auto with zarith. apply exp_gamma_enough; auto with zarith. apply Rle_trans with (((powerRZ radix prec - 1) * powerRZ radix (- N - 2)) * (powerRZ radix (Fexp gamma)))%R. rewrite Rabs_mult;apply Rmult_le_compat; auto with real zarith. rewrite <- H3';auto with real. rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with real zarith. fold (pPred (vNum b)); right; unfold FtoRradix, FtoR; simpl. replace (- N - 2 + Fexp gamma)%Z with (- N + Fexp gamma - 2)%Z;[idtac|ring]. replace (IZR (pPred (vNum b))) with (powerRZ 2 prec - 1)%R; auto with real. unfold pPred, Zpred, Zminus; rewrite plus_IZR; rewrite pGivesBound. rewrite Zpower_nat_Z_powerRZ; simpl; auto with real zarith. fold (pPred (vNum b)); unfold FtoRradix, FtoR; simpl. rewrite powerRZ_add; auto with real zarith. apply Rmult_lt_compat_r; auto with real zarith. unfold pPred, Zpred, Zminus; rewrite plus_IZR; rewrite pGivesBound. rewrite Zpower_nat_Z_powerRZ; simpl; auto with real zarith. apply Rlt_le_trans with (powerRZ 2 prec + -0)%R; auto with real; right; ring. elim H; intros T1 (T2,T3). rewrite T2; auto with zarith float. apply Zle_trans with (Fexp gamma -N -3)%Z; auto with zarith. apply exp_gamma_enough3 with prec; auto with zarith. apply gamma_ge2. case (Req_dec (Rabs zH1) (powerRZ radix (- N))); intros I1. split. intros I2; Contradict I1; auto with real. intros I2; clear I2. apply Zle_trans with (2:=H7). apply Zle_trans with (Fexp gamma-N-prec+1)%Z. 2: case (Zmin_or (Fexp x) (- N + Fexp gamma)); intros Y; rewrite Y; auto with zarith. assert (H:(Fcanonic radix b (Fnormalize radix b prec v))); [apply FnormalizeCanonic; auto with zarith float|idtac]. elim vDef; auto. case H; clear H; intros H. assert (prec - 1 + Fexp (Fnormalize radix b prec v) <= Fexp gamma - N)%Z; auto with zarith. apply Zle_powerRZ with radix; auto with real zarith. apply Rle_trans with (Rabs v). apply Rle_trans with (Zpos (vNum b) * (Float (S 0) (Zpred (Fexp (Fnormalize radix b prec v)))))%R. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ. apply Rle_trans with (powerRZ radix prec * powerRZ radix (Zpred (Fexp (Fnormalize radix b prec v))))%R. rewrite <- powerRZ_add; auto with zarith real. apply Rle_powerRZ; unfold Zpred; auto with zarith real. unfold FtoRradix, FtoR; simpl; right; ring. apply Rle_trans with (Fabs (Fnormalize radix b prec v)). unfold FtoRradix; apply FnormalBoundAbs2 with prec; auto with zarith. unfold FtoRradix; rewrite Fabs_correct; auto with zarith. rewrite FnormalizeCorrect; auto with zarith real. apply Rle_trans with (Float 1 (Fexp gamma-N)). unfold FtoRradix; apply RoundAbsMonotoner with b prec (Closest b radix) (zH1 * gamma2)%R; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. split. simpl; apply vNumbMoreThanOne with radix prec; auto with zarith. apply Zle_trans with (Fexp gamma - N)%Z; auto with zarith. assert (- dExp b <= Fexp gamma - prec - N)%Z; auto with zarith. apply exp_gamma_enough; auto with zarith. apply Rle_trans with (powerRZ radix (- N)*(powerRZ radix (Fexp gamma)))%R. rewrite Rabs_mult;apply Rmult_le_compat; auto with real zarith. right; unfold FtoR; simpl. unfold Zminus; rewrite powerRZ_add; auto with real zarith; ring. right; unfold FtoRradix, FtoR; simpl; ring. elim H; intros T1 (T2,T3). rewrite T2; auto with zarith float. apply Zle_trans with (Fexp gamma -prec -N)%Z; auto with zarith. apply exp_gamma_enough; auto with zarith. split;[idtac|intros I2; Contradict I2; auto with real]. case K2;intros I2; [idtac| Contradict I2; auto with real]. intros; apply Zle_trans with (2:=H7). case (Zmin_or (Fexp x) (- N + Fexp gamma)); intros Y; rewrite Y; auto with zarith. Qed. Theorem FTS_correct: ((FtoRradix zH1=0)%R\/(FtoRradix v=0)%R) \/ exists ff:float, FtoRradix ff = (x - zH1 * gamma)%R /\ Fbounded b ff /\ (Fexp (Fnormalize radix b prec v) <= Fexp ff)%Z. case FTS_correct_aux; intros H. case H; auto. elim H; intros ff (T1,(T2,(T3,(T4,(T5,T6))))). right; exists ff; split; trivial; split; trivial. case (Req_dec (Rabs zH1) (powerRZ radix (-N))); intros I. apply T6; auto. apply Zle_trans with (- N + Fexp gamma - 2)%Z; auto with zarith. Qed. Theorem v_neq_zero: (0 <> zH1)%R -> (FtoRradix gamma2<>0)%R -> (FtoRradix v<>0)%R. generalize exp_gamma_enough; intros. cut (0 < Rabs v)%R. intros L; Contradict L. rewrite L; rewrite Rabs_R0; auto with real. apply Rlt_le_trans with (Float 1 (Fexp gamma - prec - N)). unfold FtoRradix; apply LtFnumZERO; auto with zarith. unfold FtoRradix; apply RoundAbsMonotonel with b prec (Closest b radix) (zH1 * gamma2)%R; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl; auto with zarith. apply vNumbMoreThanOne with radix prec; auto with zarith. apply Rle_trans with (powerRZ radix (Fexp gamma - prec - N)); [right; unfold FtoR; simpl; ring|idtac]. assert (forall f:float, (FtoRradix f <> 0)%R -> (powerRZ radix (Fexp f) <= Rabs f)%R). intros; unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith. apply Rle_trans with (1%Z*powerRZ radix (Fexp f))%R;[simpl; right; ring|idtac]. unfold FtoR, Fabs; simpl; apply Rmult_le_compat_r; auto with real zarith. assert (0 < Zabs (Fnum f))%Z; auto with zarith real. cut (0 < Fnum (Fabs f))%Z; [simpl; auto with zarith|idtac]. apply LtR0Fnum with radix; auto with zarith. rewrite Fabs_correct; auto with zarith;fold FtoRradix. cut (0 <= Rabs f)%R; auto with real; intros T; case T; trivial. intros; absurd (Rabs f <> 0)%R; auto with real. apply Rabs_no_R0; auto. replace (Fexp gamma - prec - N)%Z with (-N+(Fexp gamma-prec))%Z;[idtac|ring]. rewrite powerRZ_add; auto with real zarith; rewrite Rabs_mult. apply Rmult_le_compat; auto with real zarith. elim zH_exp_N; intros zH (L1,(L2,L3)). rewrite <- L1; rewrite <- L3; apply H2. rewrite L1; auto with real. apply Rle_trans with (powerRZ radix (Fexp gamma2)). apply Rle_powerRZ; auto with real zarith. apply H2; auto. Qed. Theorem First_Comput_ok: exists f:float, (FtoRradix f=t1-res)%R /\ Fbounded b f. case (Req_dec 0 zH1); intros. exists (Fzero (- dExp b)); split;[idtac|apply FboundedFzero]. unfold FtoRradix; rewrite FzeroisReallyZero; fold FtoRradix. replace (FtoRradix res) with (FtoRradix x). replace (FtoRradix t1) with (FtoRradix x). ring. unfold FtoRradix; apply RoundedModeProjectorIdemEq with b prec (EvenClosest b radix prec); auto with zarith float. replace (FtoR radix x) with (x - zH1 * gamma - v)%R; auto with real. replace (FtoRradix v) with 0%R. fold FtoRradix; rewrite <- H; ring. assert (0 <= v)%R. unfold FtoRradix; apply RleRoundedR0 with b prec (Closest b radix) (zH1*gamma2)%R; auto with zarith float. apply ClosestRoundedModeP with prec; auto with zarith. rewrite <- H; auto with real. assert (v <= 0)%R; auto with real. unfold FtoRradix; apply RleRoundedLessR0 with b prec (Closest b radix) (zH1*gamma2)%R; auto with zarith float. apply ClosestRoundedModeP with prec; auto with zarith. rewrite <- H; auto with real. unfold FtoRradix; apply RoundedModeProjectorIdemEq with b prec (EvenClosest b radix prec); auto with zarith float. replace (FtoR radix x) with (x - zH1 * gamma - zH1*gamma2)%R; auto with real. fold FtoRradix; repeat rewrite <- H; ring. case (Req_dec gamma2 0); intros. exists (Fzero (- dExp b)); split;[idtac|apply FboundedFzero]. unfold FtoRradix; rewrite FzeroisReallyZero; fold FtoRradix. replace (FtoRradix res) with (FtoRradix t1); [ring|idtac]. assert ((exists f : float, FtoRradix f = (x - zH1 * gamma)%R /\ Fbounded b f) /\ (Rabs (x-zH1 * gamma) < powerRZ radix (prec - N + Fexp gamma))%R). unfold FtoRradix; apply Fmac_arg_reduct_correct3 with alpha u; auto with zarith. apply gamma_ge2. elim H1; intros (f,(H1',H2')) H3'; clear H1. apply trans_eq with (FtoRradix f). apply sym_eq; unfold FtoRradix; apply RoundedModeProjectorIdemEq with b prec (EvenClosest b radix prec); auto with zarith float. replace (FtoR radix f) with (x - zH1 * gamma - v)%R; auto with real. replace (FtoRradix v) with 0%R. fold FtoRradix; rewrite H1'; ring. assert (0 <= v)%R. unfold FtoRradix; apply RleRoundedR0 with b prec (Closest b radix) (zH1*gamma2)%R; auto with zarith float. apply ClosestRoundedModeP with prec; auto with zarith. rewrite H0; auto with real. assert (v <= 0)%R; auto with real. unfold FtoRradix; apply RleRoundedLessR0 with b prec (Closest b radix) (zH1*gamma2)%R; auto with zarith float. apply ClosestRoundedModeP with prec; auto with zarith. rewrite H0; auto with real. unfold FtoRradix; apply RoundedModeProjectorIdemEq with b prec (Closest b radix); auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. replace (FtoR radix f) with (x - zH1 * gamma - zH1*gamma2)%R; auto with real. elim resDef; trivial. rewrite H0; rewrite <- H1'; simpl; unfold FtoRradix; ring. case FTS_correct_aux. intros T; case T. intros G; Contradict G; auto with real. intros G; Contradict G. apply v_neq_zero; auto. intros (f,(H1,(H2,(H3,(H4, H4'))))). case (Req_dec t1 res). intros T; rewrite T. exists (Fzero (- dExp b)); split; [unfold FtoRradix; rewrite FzeroisReallyZero;ring|apply FboundedFzero]. intros HH. elim plusExpMin with b radix prec (EvenClosest b radix prec) f (Fopp (Fnormalize radix b prec v)) t1; auto with zarith float. 2: rewrite Fopp_correct; auto with zarith; rewrite FnormalizeCorrect; auto with zarith. 2: fold FtoRradix; rewrite H1; auto with real. unfold Fopp; simpl; intros t1' (M1,(M2,M3)); fold FtoRradix in M2. rewrite Zmin_le2 in M3; auto with zarith. 2: elim H4'; intros T1 T2. 2: case (Req_dec (Rabs zH1) (powerRZ radix (-N))); intros I; auto with zarith real. 2: apply Zle_trans with (- N + Fexp gamma - 2)%Z; auto with zarith. elim zH_exp_N; intros zH (N1,(N2,N3)). elim plusExpMin with b radix prec (EvenClosest b radix prec) f (Fopp (Fmult zH gamma2)) res; auto with zarith float. 2: rewrite Fopp_correct; auto with zarith; rewrite Fmult_correct; auto with zarith. 2: fold FtoRradix; rewrite H1; rewrite N1; auto with real. unfold Fopp; simpl; intros res' (O1,(O2,O3)); fold FtoRradix in M2. assert (O4:(-N+Fexp gamma-prec+2 <= Fexp res')%Z). apply Zle_trans with (2:=O3). rewrite N3; rewrite gamma2_e_eq; apply Zmin_Zle; auto with zarith. cut (exists f:float, (FtoRradix f=t1-res)%R /\ Fbounded b f /\ (Fexp f=-N+Fexp gamma-prec+2)%Z). intros (ff, (H1',(H2',H3'))). exists ff; split; auto. unfold FtoRradix; apply BoundedL with prec (Fminus radix t1' res'); auto with zarith. unfold Fminus; simpl; apply Zmin_Zle; auto with zarith. apply Zle_trans with (2:=M3); apply Zlt_le_weak. elim errorBoundedMult with b radix prec (Closest b radix) zH gamma2 v; auto with zarith. 2: apply ClosestRoundedModeP with prec; auto with zarith. 2: rewrite N3; rewrite gamma2_e_eq. 2: generalize exp_gamma_enough; auto with zarith. 2: fold FtoRradix; rewrite N1; auto. fold FtoRradix; intros errv (P1,(P2,P3)). replace (- N + Fexp gamma - prec + 2)%Z with (Fexp errv); [idtac|rewrite P3; rewrite N3; rewrite gamma2_e_eq; ring]. apply RoundedModeErrorExpStrict with b radix prec (Closest b radix) (zH*gamma2)%R; auto with real zarith. apply ClosestRoundedModeP with prec; auto with zarith. apply FnormalizeBounded; auto with zarith; elim vDef; auto. generalize ClosestCompatible; unfold CompatibleP; intros T. apply T with (zH1*gamma2)%R v; auto with real. rewrite N1; auto with real. rewrite FnormalizeCorrect; auto with zarith real. apply FnormalizeBounded; auto with zarith; elim vDef; auto. rewrite FnormalizeCorrect; auto with zarith; fold FtoRradix; rewrite P1; ring. Contradict HH. generalize EvenClosestUniqueP; unfold UniqueP; intros T. unfold FtoRradix; apply T with b prec (x - zH1 * gamma - zH1 * gamma2)%R; auto with zarith. replace (x - zH1 * gamma - zH1 * gamma2)%R with (x-zH1*gamma-v)%R; auto with real. apply trans_eq with (x - zH1 * gamma - zH*gamma2+errv)%R; [rewrite P1; ring| rewrite N1; unfold FtoRradix; rewrite HH; ring]. generalize exp_gamma_enough; auto with zarith. rewrite Fminus_correct; auto with zarith. rewrite O2; fold FtoRradix; rewrite M2; auto with real. assert (forall r:R, forall g:float, forall e:Z, Closest b radix r g -> (-dExp b <= e+1)%Z -> (Rabs g < powerRZ radix (prec+1+e))%R -> (Rabs (r-g) <= powerRZ radix e)%R ). intros r g e K1 K2 K3. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp b radix prec g). unfold FtoRradix; apply ClosestUlp; auto with zarith. apply Rle_trans with (powerRZ radix (e+1));[idtac| rewrite powerRZ_add; auto with real zarith; simpl; right; ring]. unfold Fulp; apply Rle_powerRZ; auto with real zarith. assert (Fcanonic radix b (Fnormalize radix b prec g)). apply FnormalizeCanonic; auto with zarith; elim K1; auto. case H5; intros L. cut (prec + (Zpred (Fexp (Fnormalize radix b prec g))) < prec+1+e)%Z; [unfold Zpred; auto with zarith|apply Zlt_powerRZ with radix; auto with real zarith]. apply Rle_lt_trans with (2:=K3). unfold FtoRradix; rewrite <- FnormalizeCorrect with radix b prec g; auto with zarith. rewrite <- Fabs_correct; auto with zarith. apply Rle_trans with (Zpos (vNum b) * FtoR radix (Float (S 0) (Zpred (Fexp (Fnormalize radix b prec g)))))%R. right; rewrite powerRZ_add; auto with real zarith. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; unfold FtoR; simpl; ring. apply FnormalBoundAbs2 with prec; auto with zarith. elim L; intros T1 (T2,T3). rewrite T2; auto with zarith. assert (forall (r : R) (g g': float), Closest b radix r g -> Fbounded b g' -> (FtoRradix g'=g) -> (Rabs (r - g) <= powerRZ radix (Fexp g'-1))%R). intros r g g' K1 K2 K3; elim K2; intros K4 K5. apply H5; auto with zarith. rewrite <- K3; unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith. unfold FtoR, Fabs; simpl. replace (prec + 1 + (Fexp g' - 1))%Z with (prec+Fexp g')%Z;[idtac|ring]. rewrite powerRZ_add; auto with real zarith. apply Rmult_lt_compat_r; auto with real zarith. apply Rlt_le_trans with (IZR (Zpos (vNum b))); auto with real zarith. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; auto with real zarith. fold FtoRradix; replace (t1-res)%R with (-((x - zH1 * gamma - v)-t1)+(zH1*gamma2-v)+((x - zH1 * gamma - zH1 * gamma2)-res))%R; [idtac|ring]. apply Rle_lt_trans with (Rabs (-((x - zH1 * gamma - v)-t1)+(zH1*gamma2-v))+ Rabs((x - zH1 * gamma - zH1 * gamma2)-res))%R;[apply Rabs_triang|idtac]. apply Rle_lt_trans with ((Rabs (-((x - zH1 * gamma - v)-t1))+Rabs (zH1*gamma2-v))+ Rabs((x - zH1 * gamma - zH1 * gamma2)-res))%R; [apply Rplus_le_compat_r; apply Rabs_triang |rewrite Rabs_Ropp]. apply Rle_lt_trans with (powerRZ radix (-N+Fexp gamma)+powerRZ radix (Fexp (Fnormalize radix b prec v) -1)+powerRZ radix (-N+Fexp gamma))%R. elim Fmac_arg_reduct_correct3 with b prec N alpha gamma x zH1 u; auto with zarith. 2: apply gamma_ge2; auto. fold radix; fold FtoRradix; intros T1 M; clear T1. assert (Rabs (zH1*gamma2) <= powerRZ radix (prec+Fexp gamma-N-2))%R. elim Fexp_x_aprox_zh_gamma; auto. intros k ((Q1,Q2),(Q3,Q4)). replace (prec + Fexp gamma - N - 2)%Z with (((prec-3-N)+1)+Fexp gamma)%Z;[idtac|ring]. rewrite powerRZ_add; auto with real zarith. rewrite Rabs_mult; apply Rmult_le_compat; auto with real zarith. apply Rle_trans with (powerRZ radix (k+1)); auto with real zarith. apply Rle_powerRZ; auto with real zarith. assert (forall (r : R) (g: float), EvenClosest b radix prec (x-zH1*gamma-r) g -> (Rabs r <= powerRZ radix (prec + Fexp gamma - N - 2))%R -> (Rabs (x-zH1*gamma - r -g) <= powerRZ radix (-N+Fexp gamma))%R). intros r g K1 K2. apply H5; auto. elim K1; auto. generalize exp_gamma_enough; auto with zarith. apply Rle_lt_trans with (Float 5 (prec+Fexp gamma -N -2)). unfold FtoRradix; apply RoundAbsMonotoner with b prec (EvenClosest b radix prec) (x - zH1 * gamma - r)%R; auto with zarith float. split; simpl. rewrite pGivesBound; apply Zlt_le_trans with (Zpower_nat radix 3); auto with zarith. generalize exp_gamma_enough; auto with zarith. unfold Rminus; apply Rle_trans with (Rabs (x+-(zH1*gamma))+Rabs (-r))%R; [apply Rabs_triang|idtac]. apply Rle_trans with (powerRZ radix (prec - N + Fexp gamma)+ powerRZ radix (prec + Fexp gamma - N - 2))%R; [apply Rplus_le_compat; auto with real|idtac]. rewrite Rabs_Ropp; auto with real. apply Rle_trans with (4* powerRZ radix (prec + Fexp gamma - N - 2)+ powerRZ radix (prec + Fexp gamma - N - 2))%R; [apply Rplus_le_compat_r|idtac]; right. unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith. simpl; field. repeat apply prod_neq_R0; auto with real. unfold FtoR; simpl; ring. unfold FtoRradix, FtoR; simpl. apply Rlt_le_trans with (8%Z * powerRZ 2 (prec + Fexp gamma - N - 2))%R. apply Rmult_lt_compat_r; auto with real zarith. apply Rle_lt_trans with 5%Z; auto with real zarith. replace (IZR 8) with (powerRZ 2 3);[idtac|simpl; ring]. rewrite <- powerRZ_add; auto with real zarith. apply Rle_powerRZ; auto with real zarith. repeat apply Rplus_le_compat. apply H8; auto. assert (FtoRradix (Float 1 (prec + Fexp gamma - N - 2))= powerRZ radix (prec + Fexp gamma - N - 2))%R. unfold FtoRradix, FtoR; simpl; ring. rewrite <- H9. unfold FtoRradix; apply RoundAbsMonotoner with b prec (Closest b radix) (zH1*gamma2)%R; auto with zarith float. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl. apply vNumbMoreThanOne with radix prec; auto with zarith. generalize exp_gamma_enough; auto with zarith. fold FtoRradix; rewrite H9; auto with real. apply H6; auto. apply FnormalizeBounded; auto with zarith; elim vDef; auto. unfold FtoRradix;rewrite FnormalizeCorrect; auto with zarith real. apply H8; auto with real. apply Rle_lt_trans with (powerRZ radix (- N + Fexp gamma+1) + powerRZ radix (Fexp (Fnormalize radix b prec v) - 1))%R. right; rewrite powerRZ_add with radix (- N + Fexp gamma)%Z 1%Z; auto with zarith real. simpl; ring. apply Rlt_le_trans with (powerRZ radix (- N + Fexp gamma + 1) + powerRZ radix (Fexp (Fnormalize radix b prec v)))%R. apply Rplus_lt_compat_l; apply Rlt_powerRZ; auto with real zarith. replace (- N + Fexp gamma - prec + 2 + prec)%Z with ((-N+Fexp gamma+1)+1)%Z;[idtac|ring]. apply powerRZSumRle; auto with zarith. Qed. Theorem Second_Comput_ok: exists f:float, (FtoRradix f=t1+t2-res)%R /\ Fbounded b f. replace (t1+t2-res)%R with (x-zH1*gamma-v-res)%R; [idtac|rewrite t2Def; ring]. case (Req_dec 0 zH1); intros. assert (FtoRradix v=0)%R. assert (0 <= v)%R. unfold FtoRradix; apply RleRoundedR0 with b prec (Closest b radix) (zH1*gamma2)%R; auto with zarith float. apply ClosestRoundedModeP with prec; auto with zarith. rewrite <- H; auto with real. assert (v <= 0)%R; auto with real. unfold FtoRradix; apply RleRoundedLessR0 with b prec (Closest b radix) (zH1*gamma2)%R; auto with zarith float. apply ClosestRoundedModeP with prec; auto with zarith. rewrite <- H; auto with real. exists (Fzero (- dExp b)); split;[idtac|apply FboundedFzero]. unfold FtoRradix; rewrite FzeroisReallyZero; fold FtoRradix. replace (FtoRradix res) with (FtoRradix x). replace (FtoRradix t1) with (FtoRradix x). rewrite H0; rewrite <- H; ring. unfold FtoRradix; apply RoundedModeProjectorIdemEq with b prec (EvenClosest b radix prec); auto with zarith float. replace (FtoR radix x) with (x - zH1 * gamma - v)%R; auto with real. fold FtoRradix; rewrite H0; rewrite <- H; ring. unfold FtoRradix; apply RoundedModeProjectorIdemEq with b prec (EvenClosest b radix prec); auto with zarith float. replace (FtoR radix x) with (x - zH1 * gamma - zH1*gamma2)%R; auto with real. fold FtoRradix; repeat rewrite <- H; ring. case (Req_dec gamma2 0); intros. exists (Fzero (- dExp b)); split;[idtac|apply FboundedFzero]. unfold FtoRradix; rewrite FzeroisReallyZero; fold FtoRradix. assert ((exists f : float, FtoRradix f = (x - zH1 * gamma)%R /\ Fbounded b f) /\ (Rabs (x-zH1 * gamma) < powerRZ radix (prec - N + Fexp gamma))%R). unfold FtoRradix; apply Fmac_arg_reduct_correct3 with alpha u; auto with zarith. apply gamma_ge2. elim H1; intros (f,(H1',H2')) H3'; clear H1. assert (FtoRradix v=0)%R. assert (0 <= v)%R. unfold FtoRradix; apply RleRoundedR0 with b prec (Closest b radix) (zH1*gamma2)%R; auto with zarith float. apply ClosestRoundedModeP with prec; auto with zarith. rewrite H0; auto with real. assert (v <= 0)%R; auto with real. unfold FtoRradix; apply RleRoundedLessR0 with b prec (Closest b radix) (zH1*gamma2)%R; auto with zarith float. apply ClosestRoundedModeP with prec; auto with zarith. rewrite H0; auto with real. replace (FtoRradix res) with (FtoRradix f); [rewrite H1; rewrite H1'; ring|idtac]. unfold FtoRradix; apply RoundedModeProjectorIdemEq with b prec (EvenClosest b radix prec); auto with zarith float. replace (FtoR radix f) with (x - zH1 * gamma - zH1*gamma2)%R; auto with real. fold FtoRradix; rewrite H1'; rewrite H0; ring. case FTS_correct_aux. intros T; case T. intros G; Contradict G; auto with real. intros G; Contradict G. apply v_neq_zero; auto. intros (f,(H1,(H2,(H3,(H4,(H4',H4'')))))). case (Req_dec t1 res). intros T; rewrite <- T. exists t2; split; auto. intros HH. (*elim plusExpMin with b radix prec (EvenClosest b radix prec) f (Fopp (Fnormalize radix b prec v)) t1; auto with zarith float. 2: rewrite Fopp_correct; auto with zarith; rewrite FnormalizeCorrect; auto with zarith. 2: fold FtoRradix; rewrite H1; auto with real. unfold Fopp; simpl; intros t1' (M1,(M2,M3)); fold FtoRradix in M2. rewrite Zmin_le2 in M3; auto with zarith.*) elim zH_exp_N; intros zH (N1,(N2,N3)). elim plusExpMin with b radix prec (EvenClosest b radix prec) f (Fopp (Fmult zH gamma2)) res; auto with zarith float. 2: rewrite Fopp_correct; auto with zarith; rewrite Fmult_correct; auto with zarith. 2: fold FtoRradix; rewrite H1; rewrite N1; auto with real. unfold Fopp; simpl; intros res' (O1,(O2,O3)). assert (O4:(-N+Fexp gamma-prec+2 <= Fexp res')%Z). apply Zle_trans with (2:=O3). rewrite N3; rewrite gamma2_e_eq; apply Zmin_Zle; auto with zarith. cut (exists f:float, (FtoRradix f=x-zH1*gamma-v-res)%R /\ Fbounded b f /\ (Fexp f=-N+Fexp gamma-prec+2)%Z). intros (ff, (H1',(H2',H3'))). exists ff; split; auto. unfold FtoRradix; apply BoundedL with prec (Fminus radix (Fminus radix f (Fnormalize radix b prec v)) res'); auto with zarith. unfold Fminus; simpl; apply Zmin_Zle; auto with zarith. apply Zmin_Zle; auto with zarith. apply Zlt_le_weak. elim errorBoundedMult with b radix prec (Closest b radix) zH gamma2 v; auto with zarith. 2: apply ClosestRoundedModeP with prec; auto with zarith. 2: rewrite N3; rewrite gamma2_e_eq. 2: generalize exp_gamma_enough; auto with zarith. 2: fold FtoRradix; rewrite N1; auto. fold FtoRradix; intros errv (P1,(P2,P3)). replace (- N + Fexp gamma - prec + 2)%Z with (Fexp errv); [idtac|rewrite P3; rewrite N3; rewrite gamma2_e_eq; ring]. apply RoundedModeErrorExpStrict with b radix prec (Closest b radix) (zH*gamma2)%R; auto with real zarith. apply ClosestRoundedModeP with prec; auto with zarith. apply FnormalizeBounded; auto with zarith; elim vDef; auto. generalize ClosestCompatible; unfold CompatibleP; intros T. apply T with (zH1*gamma2)%R v; auto with real. rewrite N1; auto with real. rewrite FnormalizeCorrect; auto with zarith real. apply FnormalizeBounded; auto with zarith; elim vDef; auto. rewrite FnormalizeCorrect; auto with zarith; fold FtoRradix; rewrite P1; ring. Contradict HH. generalize EvenClosestUniqueP; unfold UniqueP; intros T. unfold FtoRradix; apply T with b prec (x - zH1 * gamma - zH1 * gamma2)%R; auto with zarith. replace (x - zH1 * gamma - zH1 * gamma2)%R with (x-zH1*gamma-v)%R; auto with real. apply trans_eq with (x - zH1 * gamma - zH*gamma2+errv)%R; [rewrite P1; ring| rewrite N1; unfold FtoRradix; rewrite HH; ring]. generalize exp_gamma_enough; auto with zarith. repeat rewrite Fminus_correct; auto with zarith. rewrite O2; rewrite FnormalizeCorrect; auto with zarith; fold FtoRradix. rewrite H1; auto with real. assert (forall r:R, forall g:float, forall e:Z, Closest b radix r g -> (-dExp b <= e+1)%Z -> (Rabs g < powerRZ radix (prec+1+e))%R -> (Rabs (r-g) <= powerRZ radix e)%R ). intros r g e K1 K2 K3. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp b radix prec g). unfold FtoRradix; apply ClosestUlp; auto with zarith. apply Rle_trans with (powerRZ radix (e+1));[idtac| rewrite powerRZ_add; auto with real zarith; simpl; right; ring]. unfold Fulp; apply Rle_powerRZ; auto with real zarith. assert (Fcanonic radix b (Fnormalize radix b prec g)). apply FnormalizeCanonic; auto with zarith; elim K1; auto. case H5; intros L. cut (prec + (Zpred (Fexp (Fnormalize radix b prec g))) < prec+1+e)%Z; [unfold Zpred; auto with zarith|apply Zlt_powerRZ with radix; auto with real zarith]. apply Rle_lt_trans with (2:=K3). unfold FtoRradix; rewrite <- FnormalizeCorrect with radix b prec g; auto with zarith. rewrite <- Fabs_correct; auto with zarith. apply Rle_trans with (Zpos (vNum b) * FtoR radix (Float (S 0) (Zpred (Fexp (Fnormalize radix b prec g)))))%R. right; rewrite powerRZ_add; auto with real zarith. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; unfold FtoR; simpl; ring. apply FnormalBoundAbs2 with prec; auto with zarith. elim L; intros T1 (T2,T3). rewrite T2; auto with zarith. assert (forall (r : R) (g g': float), Closest b radix r g -> Fbounded b g' -> (FtoRradix g'=g) -> (Rabs (r - g) <= powerRZ radix (Fexp g'-1))%R). intros r g g' K1 K2 K3; elim K2; intros K4 K5. apply H5; auto with zarith. rewrite <- K3; unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith. unfold FtoR, Fabs; simpl. replace (prec + 1 + (Fexp g' - 1))%Z with (prec+Fexp g')%Z;[idtac|ring]. rewrite powerRZ_add; auto with real zarith. apply Rmult_lt_compat_r; auto with real zarith. apply Rlt_le_trans with (IZR (Zpos (vNum b))); auto with real zarith. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; auto with real zarith. fold FtoRradix; replace (x-zH1*gamma-v-res)%R with ((zH1*gamma2-v)+((x - zH1 * gamma - zH1 * gamma2)-res))%R; [idtac|ring]. apply Rle_lt_trans with (Rabs (zH1*gamma2-v)+ Rabs((x - zH1 * gamma - zH1 * gamma2)-res))%R; [apply Rabs_triang | idtac]. apply Rle_lt_trans with (powerRZ radix (Fexp (Fnormalize radix b prec v) -1) +powerRZ radix (-N+Fexp gamma))%R. elim Fmac_arg_reduct_correct3 with b prec N alpha gamma x zH1 u; auto with zarith. 2: apply gamma_ge2; auto. fold radix; fold FtoRradix; intros T1 M; clear T1. assert (Rabs (zH1*gamma2) <= powerRZ radix (prec+Fexp gamma-N-2))%R. elim Fexp_x_aprox_zh_gamma; auto. intros k ((Q1,Q2),(Q3,Q4)). replace (prec + Fexp gamma - N - 2)%Z with (((prec-3-N)+1)+(Fexp gamma))%Z;[idtac|ring]. rewrite powerRZ_add; auto with real zarith. rewrite Rabs_mult; apply Rmult_le_compat; auto with real zarith. apply Rle_trans with (powerRZ radix (k+1)); auto with real zarith. apply Rle_powerRZ; auto with real zarith. assert (forall (r : R) (g: float), EvenClosest b radix prec (x-zH1*gamma-r) g -> (Rabs r <= powerRZ radix (prec + Fexp gamma - N - 2))%R -> (Rabs (x-zH1*gamma - r -g) <= powerRZ radix (-N+Fexp gamma))%R). intros r g K1 K2. apply H5; auto. elim K1; auto. generalize exp_gamma_enough; auto with zarith. apply Rle_lt_trans with (Float 5 (prec+Fexp gamma -N -2)). unfold FtoRradix; apply RoundAbsMonotoner with b prec (EvenClosest b radix prec) (x - zH1 * gamma - r)%R; auto with zarith float. split; simpl. rewrite pGivesBound; apply Zlt_le_trans with (Zpower_nat radix 3); auto with zarith. generalize exp_gamma_enough; auto with zarith. unfold Rminus; apply Rle_trans with (Rabs (x+-(zH1*gamma))+Rabs (-r))%R; [apply Rabs_triang|idtac]. apply Rle_trans with (powerRZ radix (prec - N + Fexp gamma)+ powerRZ radix (prec + Fexp gamma - N - 2))%R; [apply Rplus_le_compat; auto with real|idtac]. rewrite Rabs_Ropp; auto with real. apply Rle_trans with (4* powerRZ radix (prec + Fexp gamma - N - 2)+ powerRZ radix (prec + Fexp gamma - N - 2))%R; [apply Rplus_le_compat_r|idtac]; right. unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith. simpl; field. repeat apply prod_neq_R0; auto with real. unfold FtoR; simpl; ring. unfold FtoRradix, FtoR; simpl. apply Rlt_le_trans with (8%Z * powerRZ 2 (prec + Fexp gamma - N - 2))%R. apply Rmult_lt_compat_r; auto with real zarith. apply Rle_lt_trans with 5%Z; auto with real zarith. replace (IZR 8) with (powerRZ 2 3);[idtac|simpl; ring]. rewrite <- powerRZ_add; auto with real zarith. apply Rle_powerRZ; auto with real zarith. apply Rplus_le_compat. apply H6; auto. apply FnormalizeBounded; auto with zarith; elim vDef; auto. unfold FtoRradix;rewrite FnormalizeCorrect; auto with zarith real. apply H8; auto with real. rewrite Rplus_comm; apply Rle_lt_trans with (powerRZ radix (- N + Fexp gamma+1)). apply powerRZSumRle; auto with zarith. apply Rlt_powerRZ; auto with real zarith. Qed. Lemma Farg_reduct_bounded_diff: forall (f1 f2 r:float), Closest b radix (f1+f2) r -> (- dExp b <= Fexp f2)%Z -> (Fexp f2 <= Fexp f1)%Z -> (Rabs (f1+f2) <= powerRZ radix (2*prec-1+(Fexp f2)))%R -> exists g:float, (FtoRradix g=f1+f2-r)%R /\ Fbounded b g. intros. cut (exists x' : float, (FtoR radix x' = f1+f2-r)%R /\ Fbounded b x' /\ Fexp x' = Fexp f2). fold FtoRradix; intros T; elim T; intros f (M1,(M2,M3)); clear T. exists f; split; trivial. elim plusExpMin with b radix prec (Closest b radix) f1 f2 r; auto with zarith. 2: apply ClosestRoundedModeP with prec; auto with zarith. intros r' (M1,(M2,M3)); fold FtoRradix in M2. apply BoundedL with prec (Fminus radix (Fplus radix f1 f2) r'); auto with zarith. unfold Fminus, Fplus; simpl. rewrite Zmin_le1; auto with zarith. rewrite Zmin_le2; auto with zarith. rewrite Fminus_correct; auto with zarith; rewrite Fplus_correct; auto with zarith. fold FtoRradix; rewrite M2; ring. assert (Fcanonic radix b (Fnormalize radix b prec r)). elim H; intros Fr T; clear T. apply FnormalizeCanonic; auto with zarith. case H3; intros. apply Rle_lt_trans with (/2*(Fulp b radix prec r))%R. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp b radix prec r);[idtac|simpl; right; field; auto with real]. unfold FtoRradix; apply ClosestUlp; auto with zarith. apply Rle_lt_trans with (powerRZ radix (Fexp (Fnormalize radix b prec r)-1)). unfold Zminus; rewrite powerRZ_add; auto with real zarith. unfold Fulp; simpl; right; field; auto with real. repeat apply prod_neq_R0; auto with real. apply Rlt_powerRZ; auto with real zarith. cut (prec+(Zpred (Fexp (Fnormalize radix b prec r))) <= 2 * prec - 1 + Fexp f2)%Z. unfold Zpred; auto with zarith. apply Zle_powerRZ with radix; auto with zarith real. apply Rle_trans with (Fabs (Fnormalize radix b prec r)). apply Rle_trans with (Zpos (vNum b) * (Float (S 0) (Zpred (Fexp (Fnormalize radix b prec r)))))%R. rewrite powerRZ_add; auto with real zarith. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; unfold FtoRradix, FtoR; simpl; right; ring. unfold FtoRradix; apply FnormalBoundAbs2 with prec; auto with zarith. unfold FtoRradix; rewrite Fabs_correct; try rewrite FnormalizeCorrect; auto with zarith. assert (exists f:float, Fbounded b f /\ (FtoRradix f= powerRZ radix (2 * prec - 1 + Fexp f2))%R). exists (Float 1 (2 * prec - 1 + Fexp f2)); split; try split. simpl; apply vNumbMoreThanOne with radix prec; auto with zarith. apply Zle_trans with ((2 * prec - 1 + Fexp f2))%Z; auto with zarith. unfold FtoRradix, FtoR; simpl; ring. elim H5; intros f (H6,H7). rewrite <- H7; unfold FtoRradix. apply RoundAbsMonotoner with b prec (Closest b radix) (f1+f2)%R; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. fold FtoRradix; rewrite H7; auto with real. apply Rlt_le_trans with (Fulp b radix prec r). unfold FtoRradix; apply RoundedModeUlp with (Closest b radix); auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. elim H4; intros T1 T2; elim T2; intros T T3. unfold Fulp; rewrite T; apply Rle_powerRZ; auto with real zarith. Qed. Theorem OneErrorOnly: ex (fun f : float => FtoRradix f = (x - zH1 * gamma -zH1*gamma2-res)%R /\ Fbounded b f). case (Req_dec gamma2 0); intros. exists (Fzero (- dExp b)); split;[idtac|apply FboundedFzero]. unfold FtoRradix; rewrite FzeroisReallyZero; fold FtoRradix. assert ((exists f : float, FtoRradix f = (x - zH1 * gamma)%R /\ Fbounded b f) /\ (Rabs (x-zH1*gamma)< powerRZ radix (prec - N + Fexp gamma))%R). unfold FtoRradix; apply Fmac_arg_reduct_correct3 with alpha u; auto with zarith. apply gamma_ge2. elim H0;intros T' M; elim T'; intros f T; elim T; intros H3 H4; clear H0 T T'. replace (FtoRradix res) with (FtoRradix f). rewrite H3; rewrite H; ring. unfold FtoRradix; apply RoundedModeProjectorIdemEq with b prec (EvenClosest b radix prec); auto with zarith float. replace (FtoR radix f) with (x - zH1 * gamma - zH1 * gamma2)%R; auto with real. fold FtoRradix; rewrite H3; rewrite H; ring. case (Req_dec zH1 0); intros. exists (Fzero (- dExp b)); split;[idtac|apply FboundedFzero]. unfold FtoRradix; rewrite FzeroisReallyZero; fold FtoRradix. replace (FtoRradix res) with (FtoRradix x). repeat rewrite H0; ring. unfold FtoRradix; apply RoundedModeProjectorIdemEq with b prec (Closest b radix); auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. replace (FtoR radix x) with (x - zH1 * gamma - zH1 * gamma2)%R; auto with real. elim resDef; auto. fold FtoRradix; repeat rewrite H0; ring. case FTS_correct. intros T; case T; intros. absurd (FtoRradix zH1=0)%R; auto with real. absurd (FtoRradix v=0)%R; trivial; apply v_neq_zero; auto with real. intros T; elim T; intros f (H1,(H2,H3)); clear T. generalize exp_gamma_enough; intros H4. elim Fexp_x_aprox_zh_gamma; auto; intros k ((M1,M2),(M3,(M4,M5))). elim zH_exp_N; intros zH (L1,(L2,L3)). assert (x-zH1*gamma-zH1*gamma2=(Fminus radix x (Fmult zH gamma))+Fopp (Fmult zH gamma2))%R. repeat rewrite <- L1; unfold FtoRradix. rewrite Fminus_correct; auto with zarith; rewrite Fopp_correct. repeat rewrite Fmult_correct; auto with zarith; ring. rewrite H5. apply Farg_reduct_bounded_diff. rewrite <- H5; elim resDef; auto with real. unfold Fopp, Fmult; simpl; auto with zarith. unfold Fopp, Fmult; simpl; auto with zarith. rewrite L3; rewrite gamma2_e_eq; apply Zmin_Zle; auto with zarith. rewrite <- H5. assert ((exists f : float, FtoRradix f = (x - zH1 * gamma)%R /\ Fbounded b f) /\ (Rabs (x-zH1 * gamma) < powerRZ radix (prec - N + Fexp gamma))%R). unfold FtoRradix; apply Fmac_arg_reduct_correct3 with alpha u; auto with zarith. apply gamma_ge2. elim H6; intros H7 H8; clear H6 H7. replace (2 * prec - 1 +(Fexp (Fopp (Fmult zH gamma2))))%Z with (prec +1-N+Fexp gamma)%Z;[idtac| simpl; rewrite L3; rewrite gamma2_e_eq]. 2: apply trans_eq with (2 * prec -1+(-N +(Fexp gamma -prec + 2)))%Z; [ring|simpl; auto with zarith]. replace (x - zH1 * gamma - zH1 * gamma2)%R with (x - zH1 * gamma +- zH1 * gamma2)%R;[idtac|ring]. apply Rle_trans with (Rabs (x-zH1*gamma)+Rabs (-zH1*gamma2))%R. apply Rabs_triang. apply Rle_trans with (powerRZ radix (prec - N + Fexp gamma)+ powerRZ radix ((prec-2-N)+(Fexp gamma)))%R; [apply Rplus_le_compat; auto with real|idtac]. rewrite Rabs_mult; rewrite Rabs_Ropp; rewrite powerRZ_add; auto with real zarith. apply Rmult_le_compat; auto with real. apply Rle_trans with (powerRZ radix (k+1)); auto with real zarith. apply Rle_powerRZ; auto with real zarith. replace (prec + 1 - N + Fexp gamma)%Z with ((prec - N + Fexp gamma)+1)%Z; [idtac|ring]. apply powerRZSumRle; auto with zarith. Qed. End Total. Section Gamma2Comput. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. (** Variables *) Variable C : R. Variable b : Fbound. Variables prec : nat. Variables alpha gamma gam2: float. (** Various bounds *) Let bmoinsq := Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (prec - 2)%nat)))) (dExp b). (** All the hypotheses *) Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix prec. Hypothesis precMoreThanThree : 3 < prec. Hypothesis CPos : (0 < C)%R. (** Possible algorithm to get alpha and gamma *) Hypothesis alphaDef : Closest b radix (/ C) alpha. Hypothesis gammaDef : Closest bmoinsq radix (/ alpha) gamma. (** Hypotheses on alpha and gamma *) Hypothesis alphaNormal : Fnormal radix b alpha. Hypothesis gammaNormal : Fnormal radix bmoinsq gamma. Hypothesis alphaPos : (0 < alpha)%R. Hypothesis gammaPos : (0 < gamma)%R. Hypothesis gamma_not_pow_2 : forall e : Z, FtoRradix gamma <> powerRZ radix e. (** No Underflow *) Hypothesis gamma_ge: (powerRZ radix (-dExp b+prec-1)<= gamma)%R. (** Then C-gamma can be rounded in any way, it will be small enough for the preceding theorems to hold. Note it also needs to be chopped *) Theorem gamma2_le: (Rabs (C - gamma) <= powerRZ radix (Fexp gamma))%R. assert (Zpos (vNum bmoinsq) = Zpower_nat radix (prec - 2))%Z. unfold bmoinsq; apply vNum_eq_Zpower_bmoinsq. replace (C-gamma)%R with ((/alpha-gamma)+(C-/alpha))%R;[idtac|ring]. apply Rle_trans with (Rabs (/alpha-gamma)+Rabs (C-/alpha))%R;[apply Rabs_triang|idtac]. apply Rle_trans with (/2*powerRZ radix (Fexp gamma)+/2*powerRZ radix (Fexp gamma))%R; [apply Rplus_le_compat|right; field; auto with real]. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bmoinsq radix (prec-2) gamma). unfold FtoRradix; apply ClosestUlp; auto with zarith. rewrite CanonicFulp; auto with zarith float. unfold FtoR; right; simpl; field; auto with real. left; auto. apply Rmult_le_reg_l with alpha; auto with real. apply Rle_trans with (C*Rabs(/C-alpha))%R. right; apply trans_eq with (Rabs (C*alpha-1)). replace (C*alpha-1)%R with (alpha*(C - / alpha))%R;[idtac|field; auto with real]. rewrite Rabs_mult; rewrite (Rabs_right alpha); try apply Rle_ge; auto with real. replace (C*alpha-1)%R with (C*(-(/C - alpha)))%R;[idtac|field; auto with real]. rewrite Rabs_mult; rewrite Rabs_Ropp; rewrite (Rabs_right C); try apply Rle_ge; auto with real. apply Rle_trans with (C*(/2*powerRZ radix (Fexp alpha)))%R. apply Rmult_le_compat_l; auto with real. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp b radix prec alpha). unfold FtoRradix; apply ClosestUlp; auto with zarith. rewrite CanonicFulp; auto with zarith float. unfold FtoR; right; simpl; field; auto with real. left; auto. apply Rle_trans with ((Fnum alpha * powerRZ radix (Fexp gamma)) *(/ 2 * powerRZ radix (Fexp alpha)))%R;[idtac|right; unfold FtoRradix, FtoR; simpl; ring]. apply Rmult_le_compat_r. left; apply Rmult_lt_0_compat; auto with real zarith. assert (powerRZ radix (prec-1) <= Fnum alpha)%R. elim alphaNormal; intros T1 T2. apply Rmult_le_reg_l with radix; auto with real zarith. apply Rle_trans with (Zpos (vNum b)). rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ. unfold Zminus; rewrite powerRZ_add; auto with real zarith. right; simpl; field; auto with real. apply Rle_trans with (Zabs (radix * Fnum alpha)); auto with real zarith. rewrite Zabs_Zmult; repeat rewrite Zabs_eq; auto with zarith real. rewrite mult_IZR; auto with real zarith. apply LeR0Fnum with radix; auto with real zarith. apply Rle_trans with (powerRZ radix (prec-1)*powerRZ radix (Fexp gamma))%R; [idtac|apply Rmult_le_compat_r; auto with real zarith]. rewrite <- powerRZ_add; auto with real zarith. rewrite gamma_exp with b prec 2 alpha gamma; auto with zarith. replace (prec - 1 + (Zsucc (S 1) + - (Fexp alpha + (prec + prec))))%Z with (2-prec-Fexp alpha)%Z;[idtac|unfold Zsucc; simpl (Z_of_nat (S 1)); ring]. case (Rle_or_lt C (powerRZ radix (2 - prec - Fexp alpha))); trivial. intros H1; absurd (alpha <= powerRZ radix (prec-2 + Fexp alpha))%R. apply Rlt_not_le. unfold FtoRradix, FtoR; rewrite powerRZ_add; auto with real zarith. apply Rmult_lt_compat_r; auto with real zarith. apply Rlt_le_trans with (2:=H0); apply Rlt_powerRZ; auto with real zarith. apply Rle_trans with (Float 1 (prec-2+Fexp alpha));[idtac| unfold FtoRradix, FtoR; simpl; right; ring]. apply Rle_trans with (Rabs alpha);[apply RRle_abs|idtac]. unfold FtoRradix; apply RoundAbsMonotoner with b prec (Closest b radix) (/C)%R; auto with real zarith. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl. apply vNumbMoreThanOne with radix prec; auto with zarith. apply Zle_trans with (Fexp alpha); auto with zarith float. elim alphaNormal; intros T1 T2; elim T1; trivial. rewrite Rabs_right;[idtac|apply Rle_ge; auto with real]. apply Rle_trans with (/(powerRZ radix (2 - prec - Fexp alpha)))%R. apply Rle_Rinv; auto with real zarith. rewrite Rinv_powerRZ; auto with real zarith. replace (- (2 - prec - Fexp alpha))%Z with (prec - 2 + Fexp alpha)%Z; [ unfold FtoRradix, FtoR; simpl;right|idtac]; ring. apply exp_alpha_le with (-1)%Z gamma; auto with zarith. Qed. End Gamma2Comput. Float8.4/FnElem/FIA64elem.v0000644000423700002640000003130612032774527015026 0ustar sboldotoccata(** IEEE754 : FIA64elem Copyright Sylvie Boldo 2002 Theorems based on "IA 64 and elementary function" by Markstein 2000. *) Require Export AllFloat. Section FulpRinv. Variable b : Fbound. Variable radix : Z. Variable precision : nat. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Hypothesis radixMoreThanOne : (1 < radix)%Z. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Theorem Fabs_Fexp : forall f : float, Fexp f = Fexp (Fabs f). intros f; unfold Fabs in |- *; simpl in |- *; auto. Qed. Theorem Fulp_pow : forall (f : float) (n : Z), (- dExp b <= n + Zsucc (- precision))%Z -> Fbounded b f -> Rabs f = powerRZ radix n :>R -> Fulp b radix precision f = powerRZ radix (n + Zsucc (- precision)). intros f n H1 H2 H3; unfold Fulp in |- *. rewrite Fabs_Fexp. replace (Fabs (Fnormalize radix b precision f)) with (Float (Zpower_nat radix (pred precision)) (n + Zsucc (- precision))); [ simpl in |- *; auto with real | idtac ]. apply FcanonicUnique with radix b precision; auto with zarith float. unfold Fcanonic in |- *; left; split; [ split | idtac ]; simpl in |- *; auto. rewrite pGivesBound; rewrite Zabs_eq; auto with zarith. rewrite pGivesBound; rewrite Zabs_eq; auto with zarith. pattern precision at 1 in |- *; replace precision with (1 + pred precision); auto with arith zarith. rewrite Fabs_correct; auto with zarith. rewrite FnormalizeCorrect; auto; fold FtoRradix in |- *; rewrite H3. unfold FtoRradix, FtoR in |- *; simpl. rewrite Zpower_nat_Z_powerRZ; rewrite <- powerRZ_add; auto with real zarith. unfold Zsucc in |- *; repeat rewrite <- Zplus_assoc. rewrite inj_pred; auto with zarith. unfold Zpred. ring_simplify (precision + -1 + (n + (- precision + 1)))%Z; auto with zarith. Qed. Theorem Fulp_R1 : forall f : float, (- dExp b <= Zsucc (- precision))%Z -> Fbounded b f -> f = 1%R :>R -> Fulp b radix precision f = powerRZ radix (Zsucc (- precision)). intros f H H' H1. replace (Zsucc (- precision)) with (0 + Zsucc (- precision))%Z; [ idtac | ring ]. apply Fulp_pow; auto with real zarith arith. rewrite H1; rewrite Rabs_R1; auto with real zarith arith. Qed. (** Result to complete cases of Theorem 6.8 defined p. 92 *) Theorem FulpRinv_div : forall P (f u : float) (n : Z), RoundedModeP b radix P -> Fbounded b f -> Fbounded b u -> P (/ f)%R u -> Rabs f = powerRZ radix n :>R -> (- dExp b + Zpred precision <= n)%Z -> (n <= dExp b + Zsucc (- precision))%Z -> (Fulp b radix precision f * Fulp b radix precision u)%R = Rsqr (powerRZ radix (Zsucc (- precision))). intros P f u n H1 Ff Fu H2 H3 H4 H5. rewrite Fulp_pow with f n; auto. rewrite Fulp_pow with u (- n)%Z; auto. unfold Rsqr in |- *; repeat rewrite <- powerRZ_add; auto with real zarith. replace (n + Zsucc (- precision) + (- n + Zsucc (- precision)))%Z with (Zsucc (- precision) + Zsucc (- precision))%Z; auto with real; ring. replace (- n + Zsucc (- precision))%Z with (- (n + - Zsucc (- precision)))%Z; [ auto with zarith | ring ]. cut (ProjectorP b radix P); [ unfold ProjectorP in |- *; intros H' | apply RoundedProjector; auto ]. apply sym_eq; apply trans_eq with (FtoRradix (Float 1 (- n))). unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. case (Rle_or_lt 0 f); intros H6. rewrite Rabs_right; [ unfold FtoRradix in |- *; apply H' | apply Rle_ge; auto ]. repeat (split; simpl in |- *; auto with zarith). rewrite pGivesBound; replace 1%Z with (Zpower_nat radix 0); auto with zarith arith. replace (FtoR radix (Float 1 (- n))) with (/ FtoRradix f)%R; auto. rewrite <- (Rabs_right (FtoRradix f)); [ idtac | apply Rle_ge; auto ]. rewrite H3; rewrite Rinv_powerRZ; auto with zarith real. unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. unfold FtoRradix in |- *; apply RleRoundedR0 with b precision P (/ FtoRradix f)%R; auto with real zarith. apply Rlt_le; apply Rinv_0_lt_compat; auto with real. case H6; auto with real. intros H7; absurd (0%R = powerRZ radix n); auto with real zarith. rewrite <- Rabs_R0; rewrite H7; auto. rewrite Faux.Rabsolu_left1. replace (FtoRradix u) with (- Float 1 (- n))%R; [ ring | idtac ]. unfold FtoRradix in |- *; rewrite <- Fopp_correct; apply H'; auto. repeat (split; simpl in |- *; auto with zarith). rewrite pGivesBound; replace 1%Z with (Zpower_nat radix 0); auto with zarith arith. replace (FtoR radix (Fopp (Float 1 (- n)))) with (/ FtoRradix f)%R; auto. rewrite <- (Ropp_involutive (FtoRradix f)); rewrite <- (Rabs_left (FtoRradix f)); auto. rewrite <- Ropp_inv_permute; [ idtac | apply Rabs_no_R0; auto with real ]. rewrite H3; rewrite Rinv_powerRZ; auto with zarith real. rewrite Fopp_correct; unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. unfold FtoRradix in |- *; apply RleRoundedLessR0 with b precision P (/ FtoRradix f)%R; auto with real zarith. apply Zplus_le_reg_r with (Zpred precision); auto with zarith. Qed. Theorem boundedNorMinGivesExp2 : forall (x : Z) (p : float), Fbounded b p -> (- dExp b <= x)%Z -> (Float (nNormMin radix precision) x <= Rabs p)%R -> (Rabs p <= Float (pPred (vNum b)) x)%R -> Fexp (Fnormalize radix b precision p) = x :>Z. intros x p H1 H2 H3 H4. case (Rle_or_lt 0 p); intros H5. apply boundedNorMinGivesExp; auto with arith; fold FtoRradix in |- *; rewrite <- (Rabs_right (FtoRradix p)); auto with real. rewrite <- (Fopp_Fopp p); rewrite Fnormalize_Fopp; auto with arith. apply trans_eq with (Fexp (Fnormalize radix b precision (Fopp p))); auto with float. apply boundedNorMinGivesExp; auto with arith float; rewrite Fopp_correct; rewrite <- Rabs_left; auto with real. Qed. (** Theorem 6.9 defined p. 93, used for example p. 121 and p. 131 *) Theorem FulpRinv_div_not : forall P (f u : float), RoundedModeP b radix P -> Fbounded b f -> Fbounded b u -> f <> 0%R :>R -> P (/ f)%R u -> (forall n : Z, Rabs f <> powerRZ radix n :>R) -> Fnormal radix b f -> (- dExp b <= 1 + (- Fexp f + (- precision + - precision)))%Z -> (radix * (Fulp b radix precision f * Fulp b radix precision u))%R = Rsqr (powerRZ radix (Zsucc (- precision))). intros P f u H1 Ff Fu H0 H2 H3 Nf H'; unfold Fulp in |- *. rewrite FcanonicFnormalizeEq; auto with arith; [ idtac | left; auto ]. pattern (IZR radix) at 1 in |- *; replace (IZR radix) with (powerRZ radix 1); auto with real. unfold Rsqr in |- *; repeat rewrite <- powerRZ_add; auto with zarith real. replace (1 + (Fexp f + Fexp (Fnormalize radix b precision u)))%Z with (Zsucc (- precision) + Zsucc (- precision))%Z; auto with real. replace (Fexp (Fnormalize radix b precision u)) with (1 + (- Fexp f + (- precision + - precision)))%Z. unfold Zsucc in |- *; ring; auto with zarith. apply sym_eq; apply boundedNorMinGivesExp2; auto with zarith arith float real. unfold FtoRradix in |- *; apply RoundAbsMonotonel with b precision P (/ FtoRradix f)%R; auto. split; auto with zarith float. simpl in |- *. rewrite Zabs_eq; auto with zarith float. apply ZltNormMinVnum; auto with arith. unfold nNormMin in |- *; auto with zarith arith. apply Rle_trans with (powerRZ radix (- Fexp f + - precision)). unfold nNormMin in |- *. unfold FtoRradix, FtoR in |- *. replace (Fnum (Float (Zpower_nat radix (pred precision)) (1 + (- Fexp f + (- precision + - precision))))) with (Zpower_nat radix (pred precision)); auto. replace (Fexp (Float (Zpower_nat radix (pred precision)) (1 + (- Fexp f + (- precision + - precision))))) with (1 + (- Fexp f + (- precision + - precision)))%Z; auto. rewrite Zpower_nat_Z_powerRZ; auto. rewrite <- powerRZ_add; auto with zarith real. replace (pred precision + (1 + (- Fexp f + (- precision + - precision))))%Z with (- Fexp f + - precision)%Z; auto with real. replace (Z_of_nat (pred precision)) with (Zpred precision); [ unfold Zpred in |- *; ring | idtac ]. apply sym_eq; apply inj_pred; auto with arith. replace (- Fexp f + - precision)%Z with (- (Fexp f + precision))%Z; [ idtac | ring ]. rewrite <- Rinv_powerRZ; auto with real zarith. rewrite Rabs_Rinv; auto. apply Rle_Rinv; auto with real. apply Rabs_pos_lt; auto. unfold FtoRradix in |- *; rewrite <- Fabs_correct; auto with zarith. unfold Fabs, FtoR in |- *; simpl in |- *; rewrite powerRZ_add; auto with real zarith. rewrite Rmult_comm; apply Rmult_le_compat_l; auto with real zarith float. apply Rle_trans with (IZR (Zpos (vNum b))); auto with real zarith float. right; rewrite pGivesBound; auto with real zarith float. apply Zpower_nat_Z_powerRZ. unfold FtoRradix in |- *; apply RoundAbsMonotoner with b precision P (/ FtoRradix f)%R; auto. split; auto with zarith float. simpl in |- *. rewrite Zabs_eq; auto with zarith float. unfold pPred in |- *. auto with zarith. auto with zarith arith float. unfold pPred in |- *. auto with zarith arith float. apply Rle_trans with (/ (Zsucc (nNormMin radix precision) * powerRZ radix (Fexp f)))%R. rewrite Rabs_Rinv; auto. apply Rle_Rinv; auto with real. apply Rmult_lt_0_compat; auto with real zarith float. unfold nNormMin in |- *; auto with real zarith float. unfold FtoRradix in |- *; rewrite <- Fabs_correct; auto with zarith. unfold Fabs, FtoR in |- *; simpl in |- *. apply Rmult_le_compat_r; auto with real zarith. elim Nf; intros H'1 H'2. apply Rle_IZR. apply Zlt_le_succ. case (Zle_lt_or_eq (nNormMin radix precision) (Zabs (Fnum f))); auto with zarith. apply Zmult_le_reg_r with radix; auto with zarith. replace (nNormMin radix precision * radix)%Z with (Zpos (vNum b)). replace (Zabs (Fnum f) * radix)%Z with (Zabs (radix * Fnum f)); auto. rewrite Zabs_Zmult; auto with zarith. rewrite Zabs_eq; auto with zarith. rewrite Zmult_comm; rewrite pGivesBound; unfold nNormMin in |- *; auto with zarith arith. replace precision with (S (pred precision)); auto with zarith arith. intros H'3. absurd (Rabs (FtoRradix f) = powerRZ radix (pred precision + Fexp f) :>R). apply H3; auto. unfold FtoRradix in |- *; rewrite <- Fabs_correct; auto with zarith. unfold FtoR, Fabs in |- *; simpl in |- *. rewrite powerRZ_add; auto with real zarith. rewrite <- H'3; unfold nNormMin in |- *; auto with zarith real. rewrite Zpower_nat_Z_powerRZ; auto with real. unfold FtoR in |- *. replace (Fnum (Float (pPred (vNum b)) (1 + (- Fexp f + (- precision + - precision))))) with (pPred (vNum b)); auto. replace (Fexp (Float (pPred (vNum b)) (1 + (- Fexp f + (- precision + - precision))))) with (1 + (- Fexp f + (- precision + - precision)))%Z; auto. cut (Zsucc (nNormMin radix precision) <> 0%R :>R); [ intros H'1 | unfold nNormMin in |- *; auto with real zarith arith ]. rewrite Rinv_mult_distr; auto with real zarith. rewrite Rinv_powerRZ; auto with real zarith. replace (1 + (- Fexp f + (- precision + - precision)))%Z with (- Fexp f + (1 + (- precision + - precision)))%Z; [ idtac | ring ]. rewrite powerRZ_add; auto with real zarith. rewrite Rmult_comm with (r1 := powerRZ radix (- Fexp f)). rewrite <- Rmult_assoc. apply Rmult_le_compat_r; auto with real zarith. apply Rmult_le_reg_l with (IZR (Zsucc (nNormMin radix precision))); auto with real zarith. unfold nNormMin in |- *; auto with real zarith arith. rewrite Rinv_r; auto. unfold Zsucc in |- *; rewrite plus_IZR. unfold nNormMin in |- *; rewrite Zpower_nat_Z_powerRZ. unfold pPred in |- *. unfold Zpred in |- *; rewrite plus_IZR. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ. replace (IZR 1) with 1%R; auto with real. replace (IZR (-1)) with (-1)%R; auto with real. ring_simplify. repeat rewrite <- powerRZ_add; auto with zarith real. replace (Z_of_nat (pred precision)) with (Zpred precision); [ unfold Zpred in |- * | apply sym_eq; apply inj_pred; auto with arith ]. ring_simplify (precision + -1 + precision + (1 + (- precision + - precision)))%Z. ring_simplify (precision + -1 + (1 + (- precision + - precision)))%Z. ring_simplify (precision + (1 + (- precision + - precision)))%Z. apply Rplus_le_reg_l with (-1)%R. ring_simplify (-1 + 1)%R. replace (powerRZ radix 0) with 1%R; auto. ring_simplify. apply Rle_trans with (powerRZ radix (- precision) + - powerRZ radix (1 + (- precision + - precision)))%R. apply Rplus_le_reg_l with (powerRZ radix (1 + (- precision + - precision))). ring_simplify. auto with real zarith arith. unfold Rminus;apply Rplus_le_compat_r. replace (-1*precision)%Z with (-precision)%Z; auto with zarith. rewrite powerRZ_add; auto with real zarith. apply Rle_trans with ((radix + -1) * powerRZ radix (- precision))%R; [ idtac | simpl in |- *; right; ring ]. apply Rle_trans with (1 * powerRZ radix (- precision))%R; auto with real. apply Rmult_le_compat_r; auto with real zarith. apply Rplus_le_reg_l with 1%R. ring_simplify (1 + (radix + -1))%R; auto with real arith zarith. replace 2%R with (IZR 2); auto with zarith real. Qed. End FulpRinv.Float8.4/FnElem/FmaErr.v0000644000423700002640000022704712032774527014577 0ustar sboldotoccataRequire Export AllFloat. Require Export Veltkamp. Section GenericA. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 3 <= p. Hypothesis Evenradix: (Even radix). Variable a b e x y:float. Hypothesis eLea: (Rabs e <= /2*Fulp bo radix p a)%R. Hypothesis eLeb: (Rabs e <= /2*Fulp bo radix p b)%R. Hypothesis xDef: Closest bo radix (a+b)%R x. Hypothesis yDef: Closest bo radix (a+b+e)%R y. Hypothesis Nx: Fnormal radix bo x. Hypothesis Ny: Fnormal radix bo y. Hypothesis Cb: Fcanonic radix bo b. Hypothesis Ca: Fcanonic radix bo a. Hypothesis Fexpb: (- dExp bo < Fexp b)%Z. Let Unmoins := (1 - (powerRZ radix (Zsucc (-p)))/2)%R. Let Unplus := (1 + (powerRZ radix (Zsucc (-p)))/2)%R. Lemma UnMoinsPos: (0 < Unmoins)%R. unfold Unmoins. assert (powerRZ radix (Zsucc (-p)) / 2 < 1)%R; auto with real. apply Rmult_lt_reg_l with 2%R; auto with real. apply Rle_lt_trans with (powerRZ radix (Zsucc (-p))); [right; field; auto with real| ring_simplify (2*1)%R]. apply Rle_lt_trans with (powerRZ radix (Zsucc (-1))); unfold Zpred; auto with real zarith. Qed. Lemma ClosestRoundeLeNormal: forall (z : R) (f : float), Closest bo radix z f -> Fnormal radix bo f -> (Rabs f <= (Rabs z) / Unmoins)%R. intros. generalize UnMoinsPos; intros U1. apply Rmult_le_reg_l with Unmoins; auto with real. apply Rle_trans with (Rabs z);[idtac|right; field; auto with real]. apply Rplus_le_reg_l with (-Rabs z+(1-Unmoins)*Rabs f)%R. apply Rle_trans with (Rabs f-Rabs z)%R;[right; ring|idtac]. apply Rle_trans with (Rabs (f-z));[apply Rabs_triang_inv|idtac]. replace (f-z)%R with (-(z-f))%R;[rewrite Rabs_Ropp|ring]. apply Rle_trans with (Rabs (f) * (/ S 1 * powerRZ radix (Zsucc (- p))))%R. unfold FtoRradix; apply ClosestErrorBoundNormal with bo; auto with zarith. rewrite FcanonicFnormalizeEq; auto with zarith; left; auto. unfold Unmoins, Rdiv; right; simpl;ring. Qed. Lemma ClosestRoundeGeNormal: forall (z : R) (f : float), Closest bo radix z f -> Fnormal radix bo f -> (Rabs z <= (Rabs f) * Unplus)%R. intros. apply Rplus_le_reg_l with (-(Rabs f))%R. apply Rle_trans with (Rabs z-Rabs f)%R;[right; ring|idtac]. apply Rle_trans with (Rabs (z-f));[apply Rabs_triang_inv|idtac]. apply Rle_trans with (Rabs (f) * (/ S 1 * powerRZ radix (Zsucc (- p))))%R. unfold FtoRradix; apply ClosestErrorBoundNormal with bo; auto with zarith. rewrite FcanonicFnormalizeEq; auto with zarith; left; auto. unfold Unplus; simpl; unfold Rdiv; right; ring. Qed. Lemma abeLeab: (Rabs b <= Rabs a)%R -> (2*powerRZ radix (Fexp b) <= Rabs (a+b))%R -> (Rabs (a+b) <= Rabs (a+b+e) *4/3)%R. intros. assert (0 <3)%R; [apply Rlt_trans with 2%R; auto with real|idtac]. assert (0 <4)%R; [apply Rlt_trans with 3%R; auto with real|idtac]. apply Rlt_le_trans with (3+1)%R; auto with real; right; ring. apply Rmult_le_reg_l with (3/4)%R; auto with real. unfold Rdiv; apply Rmult_lt_0_compat; auto with real. apply Rle_trans with (Rabs (a + b + e));[idtac|right; field; auto with real]. apply Rplus_le_reg_l with (/4*Rabs (a + b))%R. apply Rle_trans with (Rabs (a+b));[right; field; auto with real|idtac]. pattern (a+b)%R at 1; replace (a+b)%R with ((a+b+e)+(-e))%R;[idtac|ring]. apply Rle_trans with (Rabs (a+b+e)+ Rabs (-e))%R;[apply Rabs_triang|idtac]. rewrite Rplus_comm; apply Rplus_le_compat_r. rewrite Rabs_Ropp; apply Rle_trans with (1:=eLeb). apply Rmult_le_reg_l with 4%R; auto with real. apply Rle_trans with (Rabs (a+b));[idtac|right; field; auto with real]. apply Rle_trans with (2:=H0). unfold Fulp; rewrite FcanonicFnormalizeEq; auto with zarith. right; field; auto with real. Qed. Lemma xLe2y_aux1: (Rabs b <= Rabs a)%R -> (powerRZ radix (Fexp b) = Rabs (a+b))%R -> (Rabs x <= 2*Rabs y)%R. intros. apply Rle_trans with (Rabs (a+b));[right|idtac]. rewrite <- H0; unfold FtoRradix; rewrite <- Fabs_correct; auto. apply trans_eq with (FtoRradix (Float 1 (Fexp b))); [apply sym_eq |unfold FtoRradix, FtoR; simpl; ring]. apply RoundedModeProjectorIdemEq with (P:=(Closest bo radix)) (3:=pGivesBound); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. split; simpl. apply vNumbMoreThanOne with radix p; auto with zarith. assert (Fbounded bo b); auto with zarith float. apply FcanonicBound with radix; auto. replace (FtoR radix (Float 1 (Fexp b))) with (Rabs (a+b)). apply ClosestFabs with p; auto with zarith. rewrite <- H0; unfold FtoR; simpl; ring. rewrite <- H0; apply Rmult_le_reg_l with (/2)%R; auto with real. apply Rle_trans with (Rabs y);[idtac|right; field; auto with real]. elim Evenradix; intros n Hn. apply Rle_trans with (FtoRradix (Float n ((Fexp b)-1))). right; unfold FtoRradix, FtoR; simpl. unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl. ring_simplify (radix*1)%R; rewrite Hn; rewrite mult_IZR; simpl; field; auto with real zarith. unfold FtoRradix; apply RoundAbsMonotonel with bo p (Closest bo radix) (a+b+e)%R; auto with real zarith. apply ClosestRoundedModeP with p; auto with zarith. split; simpl; auto with zarith. rewrite pGivesBound; apply Zlt_trans with (Zpower_nat radix 1); auto with zarith. unfold Zpower_nat; simpl; rewrite Zabs_eq; auto with zarith. replace (a+b+e)%R with ((a+b)-(-e))%R;[idtac|ring]. apply Rle_trans with (Rabs (a+b)-Rabs (-e))%R;[idtac|apply Rabs_triang_inv]. apply Rle_trans with (powerRZ radix (Fexp b)-/2*(powerRZ radix (Fexp b)))%R. right; unfold FtoRradix, FtoR; simpl. unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl. ring_simplify (radix*1)%R; rewrite Hn; repeat rewrite mult_IZR; simpl; field; auto with real zarith. unfold Rminus; apply Rplus_le_compat; auto with real. apply Ropp_le_contravar; rewrite Rabs_Ropp. apply Rle_trans with (1:=eLeb); right. unfold Fulp; rewrite FcanonicFnormalizeEq; auto with zarith real. Qed. Lemma xLe2y_aux2 : (Rabs b <= Rabs a)%R -> (Rabs x <= 2*Rabs y)%R. intros. assert ((a+b=0)%R \/ (powerRZ radix (Fexp b) = Rabs (a+b))%R \/ (2*powerRZ radix (Fexp b) <= Rabs (a+b))%R). unfold FtoRradix; rewrite <- Fplus_correct; auto. rewrite <- Fabs_correct; auto. unfold FtoR. replace (Fexp (Fabs (Fplus radix a b))) with (Fexp (Fplus radix a b)); auto with zarith. replace (Fexp (Fplus radix a b)) with (Fexp b). case (Zle_lt_or_eq 0 (Zabs (Fnum (Fplus radix a b)))); auto with zarith. intros; case (Zle_lt_or_eq 1 (Zabs (Fnum (Fplus radix a b)))); auto with zarith. right; right. apply Rmult_le_compat_r; auto with real zarith. replace 2%R with (IZR 2); auto with zarith real. apply Rle_IZR; generalize H1; unfold Fabs; simpl; auto with zarith. intros; right; left. generalize H1; unfold Fabs; simpl; auto with zarith real. intros H2; rewrite <- H2; simpl; ring. left; replace (Fnum (Fplus radix a b)) with 0%Z;[simpl; ring|auto with zarith]. case (Z_eq_dec 0 (Fnum (Fplus radix a b))); auto with zarith; intros. assert (0 < Zabs (Fnum (Fplus radix a b)))%Z; auto with zarith. apply Zlt_le_trans with (Zabs_nat (Fnum (Fplus radix a b))); auto with zarith. assert (0 < Zabs_nat (Fnum (Fplus radix a b)))%nat; auto with zarith. apply absolu_lt_nz; auto. rewrite Zabs_absolu; auto with zarith. apply sym_eq; unfold Fplus; simpl; apply Zmin_le2. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. case H0;intros H1;[idtac|case H1; clear H1; intros H1]; clear H0. replace (FtoRradix x) with 0%R. rewrite Rabs_R0; apply Rmult_le_pos; auto with real. apply trans_eq with (FtoRradix (Float 0 (-(dExp bo)))); [unfold FtoRradix, FtoR; simpl; ring|idtac]. apply RoundedModeProjectorIdemEq with (P:=(Closest bo radix)) (3:=pGivesBound); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. split; simpl; auto with zarith. replace (FtoR radix (Float 0 (- dExp bo))) with (a+b)%R; auto. rewrite H1; unfold FtoR; simpl; ring. apply xLe2y_aux1; auto. generalize UnMoinsPos; intros U1. apply Rle_trans with ((Rabs (a+b))/Unmoins)%R. apply ClosestRoundeLeNormal; auto. apply Rmult_le_reg_l with Unmoins; auto with real. apply Rle_trans with (Rabs (a+b));[right; field; auto with real|idtac]. apply Rle_trans with (Rabs (a + b + e) * 4 / 3)%R. apply abeLeab; auto. assert (0 <3)%R; [apply Rlt_trans with 2%R; auto with real|idtac]. assert (0 <4)%R; [apply Rlt_trans with 3%R; auto with real|idtac]. apply Rlt_le_trans with (3+1)%R; auto with real; right; ring. apply Rmult_le_reg_l with (3/4)%R; [unfold Rdiv; apply Rmult_lt_0_compat; auto with real|idtac]. apply Rle_trans with (Rabs (a+b+e));[right; field; auto with real|idtac]. apply Rle_trans with ((Rabs y)*Unplus)%R. apply ClosestRoundeGeNormal; auto. apply Rle_trans with (Rabs y *(3/4*2*Unmoins))%R;[idtac|right; ring]. apply Rmult_le_compat_l; auto with real. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (3*Unmoins)%R;[idtac|right; field; auto with real]. unfold Unplus, Unmoins. apply Rplus_le_reg_l with (-2+3* (powerRZ radix (Zsucc (- p)) / 2))%R. ring_simplify. apply Rle_trans with (powerRZ radix 0);[idtac|simpl; auto with real]. apply Rle_trans with (powerRZ radix (3-p)); [idtac|apply Rle_powerRZ; auto with zarith real]. apply Rle_trans with ((5/2)*(powerRZ radix (Zsucc (-p))))%R;[right; field; auto with real|idtac]. apply Rle_trans with ((radix*radix)*(powerRZ radix (Zsucc (- p))))%R. apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with 4%R; auto with real zarith. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (IZR 5);[simpl; right; field; auto with real|idtac]. apply Rle_trans with (IZR 8); [auto with real zarith|simpl; right; ring]. apply Rmult_le_compat; auto with real zarith; replace 2%R with (IZR 2); auto with real zarith. unfold Zsucc, Zminus; repeat rewrite powerRZ_add; auto with real zarith. simpl; right; ring. Qed. Lemma yLe2x_aux : (Rabs b <= Rabs a)%R -> ~(FtoRradix x=0)%R -> (Rabs y <= 2*Rabs x)%R. intros. assert ((a+b=0)%R \/ (powerRZ radix (Fexp b) <= Rabs (a+b))%R). unfold FtoRradix; rewrite <- Fplus_correct; auto. rewrite <- Fabs_correct; auto. unfold FtoR. replace (Fexp (Fabs (Fplus radix a b))) with (Fexp (Fplus radix a b)); auto with zarith. replace (Fexp (Fplus radix a b)) with (Fexp b). case (Zle_lt_or_eq 0 (Zabs (Fnum (Fplus radix a b)))); auto with zarith. intros; right. apply Rle_trans with (1%Z*(powerRZ radix (Fexp b)))%R;[right; simpl; ring|idtac]. apply Rmult_le_compat_r; auto with real zarith. intros; left; replace (Fnum (Fplus radix a b)) with 0%Z;[simpl; ring|auto with zarith]. case (Z_eq_dec 0 (Fnum (Fplus radix a b))); auto with zarith; intros. assert (0 < Zabs (Fnum (Fplus radix a b)))%Z; auto with zarith. apply Zlt_le_trans with (Zabs_nat (Fnum (Fplus radix a b))); auto with zarith. assert (0 < Zabs_nat (Fnum (Fplus radix a b)))%nat; auto with zarith. apply absolu_lt_nz; auto. rewrite Zabs_absolu; auto with zarith. apply sym_eq; unfold Fplus; simpl; apply Zmin_le2. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. case H1;intros H2; clear H1. absurd (FtoRradix x=0)%R; auto with real. apply sym_eq; apply trans_eq with (FtoRradix (Float 0 (-(dExp bo)))); [unfold FtoRradix, FtoR; simpl; ring|idtac]. apply RoundedModeProjectorIdemEq with (P:=(Closest bo radix)) (3:=pGivesBound); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. split; simpl; auto with zarith. replace (FtoR radix (Float 0 (- dExp bo))) with (a+b)%R; auto. rewrite H2; unfold FtoR; simpl; ring. generalize UnMoinsPos; intros U1. apply Rle_trans with ((Rabs (a+b+e))/Unmoins)%R. apply ClosestRoundeLeNormal; auto. apply Rmult_le_reg_l with Unmoins; auto with real. apply Rle_trans with (Rabs (a+b+e));[right; field; auto with real|idtac]. apply Rle_trans with (Rabs (a + b) * 3 / 2)%R. apply Rle_trans with (Rabs (a+b)+Rabs e)%R;[apply Rabs_triang|idtac]. apply Rle_trans with (Rabs (a + b) + Rabs (a + b) /2)%R; [apply Rplus_le_compat_l|right; field; auto with real]. apply Rle_trans with (1:=eLeb); unfold Rdiv; rewrite Rmult_comm. apply Rmult_le_compat_r; auto with real. unfold Fulp; rewrite FcanonicFnormalizeEq; auto with zarith real. assert (0 <3)%R; [apply Rlt_trans with 2%R; auto with real|idtac]. apply Rmult_le_reg_l with (2/3)%R; [unfold Rdiv; apply Rmult_lt_0_compat; auto with real|idtac]. apply Rle_trans with (Rabs (a+b));[right; field; apply prod_neq_R0; auto with real|idtac]. apply Rle_trans with ((Rabs x)*Unplus)%R. apply ClosestRoundeGeNormal; auto. apply Rle_trans with (Rabs x *(2/3*2*Unmoins))%R;[idtac|right; ring]. apply Rmult_le_compat_l; auto with real. apply Rmult_le_reg_l with 3%R; auto with real. apply Rle_trans with (4*Unmoins)%R;[idtac|right; field; auto with real]. unfold Unplus, Unmoins. apply Rplus_le_reg_l with (-3+4* (powerRZ radix (Zsucc (- p)) / 2))%R. ring_simplify. apply Rle_trans with (powerRZ radix 0);[idtac|simpl; auto with real]. apply Rle_trans with (powerRZ radix (3-p)); [idtac|apply Rle_powerRZ; auto with zarith real]. apply Rle_trans with ((7/2)*(powerRZ radix (Zsucc (-p))))%R;[right; field; auto with real|idtac]. apply Rle_trans with ((radix*radix)*(powerRZ radix (Zsucc (- p))))%R. apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with 4%R; auto with real zarith. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (IZR 7);[simpl; right; field; auto with real|idtac]. apply Rle_trans with (IZR 8); [auto with real zarith|simpl; right; ring]. apply Rmult_le_compat; auto with real zarith; replace 2%R with (IZR 2); auto with real zarith. unfold Zsucc, Zminus; repeat rewrite powerRZ_add; auto with real zarith. simpl; right; ring. Qed. End GenericA. Section GenericB. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 3 <= p. Hypothesis Evenradix: (Even radix). Variable a b e x y:float. Hypothesis eLea: (Rabs e <= /2*Fulp bo radix p a)%R. Hypothesis eLeb: (Rabs e <= /2*Fulp bo radix p b)%R. Hypothesis xDef: Closest bo radix (a+b)%R x. Hypothesis yDef: Closest bo radix (a+b+e)%R y. Hypothesis Nx: Fnormal radix bo x. Hypothesis Ny: Fnormal radix bo y. Hypothesis Cb: Fcanonic radix bo b. Hypothesis Ca: Fcanonic radix bo a. Hypothesis Fexpb: (- dExp bo < Fexp b)%Z. Hypothesis Fexpa: (- dExp bo < Fexp a)%Z. Hypothesis dsd: ((0<= y)%R -> (0<= x)%R) /\ ((y <= 0)%R -> (x <= 0)%R). Lemma xLe2y : (Rabs x <= 2*Rabs y)%R. case (Rle_or_lt (Rabs b) (Rabs a)); intros. unfold FtoRradix; apply xLe2y_aux2 with bo p a b e; auto. unfold FtoRradix; apply xLe2y_aux2 with bo p b a e; auto with real; fold FtoRradix. rewrite Rplus_comm; auto. replace (b+a+e)%R with (a+b+e)%R; auto; ring. Qed. Lemma yLe2x: ~(FtoRradix x=0)%R -> (Rabs y <= 2*Rabs x)%R. case (Rle_or_lt (Rabs b) (Rabs a)); intros. unfold FtoRradix; apply yLe2x_aux with bo p a b e; auto. unfold FtoRradix; apply yLe2x_aux with bo p b a e; auto with real; fold FtoRradix. rewrite Rplus_comm; auto. replace (b+a+e)%R with (a+b+e)%R; auto; ring. Qed. Lemma Subexact: exists v:float, (FtoRradix v=x-y)%R /\ (Fbounded bo v) /\ (Fexp v=Zmin (Fexp x) (Fexp y))%Z. case (Req_dec (FtoRradix x) 0); intros. absurd (FtoRradix x =0)%R; auto with real. assert (~ is_Fzero x). apply FnormalNotZero with radix bo; auto. unfold is_Fzero in H0. unfold FtoRradix, FtoR; apply prod_neq_R0; auto with real zarith. case (Rle_or_lt 0 y); intros S. exists (Fminus radix x y); split. unfold FtoRradix; rewrite Fminus_correct; auto with real zarith. split;[idtac|simpl; auto with zarith]. apply Sterbenz; auto with zarith float; fold FtoRradix. elim Nx; auto. elim Ny; auto. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (FtoRradix y);[simpl; right; field; auto with real|idtac]. rewrite <- (Rabs_right y);[idtac|apply Rle_ge; auto]. rewrite <- (Rabs_right x). apply yLe2x; auto. elim dsd; intros I1 I2; apply Rle_ge; apply I1; auto. rewrite <- (Rabs_right y);[idtac|apply Rle_ge; auto]. rewrite <- (Rabs_right x). simpl; apply xLe2y; auto. elim dsd; intros I1 I2; apply Rle_ge; apply I1; auto. exists (Fopp (Fminus radix (Fopp x) (Fopp y))); split. unfold FtoRradix; rewrite Fopp_correct; rewrite Fminus_correct; auto with real zarith. rewrite Fopp_correct;rewrite Fopp_correct; ring. split;[idtac|simpl; auto with zarith]. apply oppBounded. apply Sterbenz; auto with zarith float; fold FtoRradix. apply oppBounded; elim Nx; auto. apply oppBounded; elim Ny; auto. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (FtoRradix (Fopp y));[simpl; right; field; auto with real|idtac]. unfold FtoRradix; repeat rewrite Fopp_correct; fold FtoRradix. rewrite <- (Rabs_left1 y); auto with real. rewrite <- (Rabs_left1 x). apply yLe2x; auto. elim dsd; intros I1 I2; apply I2; auto with real. unfold FtoRradix; repeat rewrite Fopp_correct; fold FtoRradix. rewrite <- (Rabs_left1 y); auto with real. rewrite <- (Rabs_left1 x). simpl; apply xLe2y; auto. elim dsd; intros I1 I2; apply I2; auto with real. Qed. End GenericB. Section GenericC. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 1 < p. Hypothesis Evenradix: (Even radix). Lemma powerRZSumRle:forall (e1 e2:Z), (e2<= e1)%Z -> (powerRZ radix e1 + powerRZ radix e2 <= powerRZ radix (e1+1))%R. intros; clear p pGivesBound precisionGreaterThanOne. 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 LSB_Pred: forall x y:float, (Rabs x < Rabs y)%R -> (LSB radix x <= LSB radix y)%Z -> (Rabs x <= Rabs y - powerRZ radix (LSB radix x))%R. intros. assert (exists nx:Z, (Rabs x=nx*powerRZ radix (LSB radix x))%R). unfold FtoRradix; rewrite <- Fabs_correct; auto. elim LSB_rep_min with radix (Fabs x); auto. intros nx H1; exists nx; rewrite H1. rewrite <- LSB_abs; auto. assert (exists ny:Z, (Rabs y=ny*powerRZ radix (LSB radix x))%R). unfold FtoRradix; rewrite <- Fabs_correct; auto. elim LSB_rep_min with radix (Fabs y); auto. intros ny1 H2; exists (ny1*Zpower_nat radix (Zabs_nat (LSB radix y - LSB radix x)))%Z; rewrite H2. rewrite <- LSB_abs; auto; rewrite mult_IZR; unfold FtoR; simpl; unfold FtoR; simpl. rewrite Zpower_nat_Z_powerRZ. rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with real zarith. replace (Zabs_nat (LSB radix y - LSB radix x)+LSB radix x)%Z with (LSB radix y); auto with real. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. apply Rplus_le_reg_l with (powerRZ radix (LSB radix x)-Rabs x)%R. ring_simplify. elim H1; intros nx H1'; elim H2; intros ny H2'; rewrite H1'; rewrite H2'. apply Rle_trans with ((IZR 1)*powerRZ radix (LSB radix x))%R;[simpl; right; ring|idtac]. apply Rle_trans with ((ny-nx)*powerRZ radix (LSB radix x))%R;[idtac|simpl; right; ring]. apply Rmult_le_compat_r; auto with real zarith. assert (ny-nx=(ny-nx)%Z)%R. unfold Zminus; rewrite plus_IZR; rewrite Ropp_Ropp_IZR; auto with real zarith. rewrite H3; assert (1 <= ny - nx)%Z; auto with real zarith. assert (0 < ny - nx)%Z; auto with real zarith. apply Zlt_Rlt; rewrite <- H3; simpl. apply Rplus_lt_reg_r with nx. ring_simplify. apply Rmult_lt_reg_l with ( powerRZ radix (LSB radix x)); auto with real zarith. rewrite Rmult_comm; rewrite <- H1'; rewrite Rmult_comm; rewrite <- H2'; auto. Qed. Variables x1 x2 y f:float. Hypothesis x1Def: Closest bo radix (x1+x2)%R x1. Hypothesis fDef : Closest bo radix (x1+x2+y)%R f. Hypothesis yLe: (MSB radix y < LSB radix x2)%Z. Hypothesis Nx1: Fnormal radix bo x1. Hypothesis x1Pos: (0 < x1)%R. Hypothesis x2NonZero: ~(FtoRradix x2 =0)%R. Hypothesis x1Exp: (-dExp bo < Fexp x1)%Z. Lemma Midpoint_aux_aux: (FtoRradix x1= f) \/ (exists v:float, (FtoRradix v=x2)%R /\ (Fexp x1 -2 <= Fexp v)%Z). case (Z_eq_dec (Fnum x1) (nNormMin radix p)); intros H1. case (Rle_or_lt 0 x2); intros G. assert (Rabs x2 <= powerRZ radix (Fexp x1)/2)%R. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (powerRZ radix (Fexp x1));[idtac|right; simpl; field; auto with real]. replace (FtoRradix x2) with ((x1+x2) -x1)%R;[idtac|ring]. apply Rle_trans with (Fulp bo radix p x1). unfold FtoRradix; apply ClosestUlp; auto with zarith. unfold Fulp; rewrite FcanonicFnormalizeEq; auto with zarith real; left; auto. case H; clear H; intros H. assert (Rabs (x2 + y) < powerRZ radix (Fexp x1) / 2)%R. apply Rle_lt_trans with (Rabs x2+Rabs y)%R;[apply Rabs_triang|idtac]. apply Rplus_lt_reg_r with (-Rabs y)%R. ring_simplify (- Rabs y + (Rabs x2 + Rabs y))%R. elim Evenradix; intros n Hn. assert (powerRZ radix (Fexp x1) / 2 = Float n (Fexp x1 -1))%R. unfold FtoRradix, FtoR; simpl; unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl. repeat (rewrite Hn;rewrite mult_IZR); simpl; field; auto with real zarith. apply Rle_lt_trans with (Rabs (Float n (Fexp x1 - 1)) - powerRZ radix (LSB radix x2))%R. apply LSB_Pred; auto. rewrite (Rabs_right (Float n (Fexp x1 - 1))); auto with real. rewrite <- H0; auto. apply Rle_ge; unfold FtoRradix; apply LeFnumZERO; simpl; auto with real zarith. apply Zle_trans with (MSB radix x2). apply LSB_le_MSB; auto with zarith. Contradict x2NonZero. unfold FtoRradix; apply is_Fzero_rep1; auto. apply Zle_trans with (Fexp x1-1)%Z. 2: apply Zle_trans with (Fexp ((Float n (Fexp x1 - 1)))); auto with zarith. 2: apply Fexp_le_LSB. assert (MSB radix x2 < Fexp x1)%Z; auto with zarith. apply Zlt_powerRZ with radix; auto with real. apply Rle_lt_trans with (FtoR radix (Float (S 0) (MSB radix x2))); [right; unfold FtoR; simpl; ring|idtac]. apply Rle_lt_trans with (FtoR radix (Fabs x2)). apply MSB_le_abs; auto. Contradict x2NonZero. unfold FtoRradix; apply is_Fzero_rep1; auto. rewrite Fabs_correct; auto; fold FtoRradix. apply Rlt_le_trans with (1:=H). unfold Rdiv; apply Rle_trans with ( (powerRZ radix (Fexp x1)*1))%R; auto with real zarith. apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (/1)%R; auto with real. rewrite (Rabs_right (Float n (Fexp x1 - 1))); auto with real. 2: apply Rle_ge; unfold FtoRradix; apply LeFnumZERO; simpl; auto with real zarith. rewrite <- H0; unfold Rminus; rewrite Rplus_comm. apply Rplus_lt_compat_r; apply Ropp_lt_contravar. unfold FtoRradix; rewrite <- Fabs_correct; auto. apply Rlt_le_trans with (FtoR radix (Float (S 0) (Zsucc (MSB radix y))))%R. apply abs_lt_MSB; auto. unfold FtoR; simpl; ring_simplify (1 * powerRZ radix (Zsucc (MSB radix y)))%R. apply Rle_powerRZ; auto with real zarith. assert (powerRZ radix (Fexp x1 + p - 1) <= x1)%R. apply Rle_trans with (((nNormMin radix p))*(powerRZ radix (Fexp x1)))%R. unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. replace (Fexp x1 + p - 1)%Z with (Fexp x1 + pred p)%Z. rewrite powerRZ_add; auto with real zarith; right;ring. rewrite inj_pred; unfold Zpred; auto with zarith. unfold FtoRradix, FtoR; apply Rmult_le_compat_r; auto with real zarith. left; unfold FtoRradix. apply ImplyClosestStrict with bo p (x1+x2+y)%R (Fexp x1); auto with zarith. elim x1Def; auto. left; auto. replace (x1+x2+y)%R with (x1+(x2+y))%R;[idtac|ring]. apply Rle_trans with ((powerRZ radix (Fexp x1 + p - 1) + 0))%R;[right; ring|idtac]. apply Rplus_le_compat; auto. apply Rplus_le_reg_l with (-y)%R. ring_simplify. apply Rle_trans with (Rabs (-y));[apply RRle_abs|rewrite Rabs_Ropp]. rewrite <- (Rabs_right x2); auto with real. case (Req_dec y 0); intros. rewrite H3; rewrite Rabs_R0; auto with real. case (Rle_or_lt (Rabs y) (Rabs x2)); auto. intros I; absurd (MSB radix y < LSB radix x2)%Z; auto. apply Zle_not_lt. apply Zle_trans with (MSB radix x2). apply LSB_le_MSB; auto with zarith. Contradict x2NonZero. unfold FtoRradix; apply is_Fzero_rep1; auto. apply MSB_monotone; auto with zarith real. Contradict x2NonZero. unfold FtoRradix; apply is_Fzero_rep1; auto. Contradict H3. unfold FtoRradix; apply is_Fzero_rep1; auto. repeat rewrite Fabs_correct; auto with real zarith. fold FtoRradix; replace (x1+x2+y-x1)%R with (x2+y)%R; auto with real; ring. right; elim Evenradix; intros n Hn. exists (Float n (Fexp x1-1)); split;[idtac|simpl; auto with zarith]. apply trans_eq with (Rabs x2);[rewrite H|idtac]. unfold FtoRradix, FtoR; simpl; unfold Zminus; rewrite powerRZ_add; auto with real zarith. simpl; ring_simplify (radix*1)%R; rewrite Hn; rewrite mult_IZR; simpl; field; auto with real zarith. rewrite Rabs_right; auto with real. assert (Rabs x2 <= powerRZ radix (Fexp x1-1)/2)%R. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (powerRZ radix (Fexp x1-1));[idtac|right; simpl; field; auto with real]. assert (FPred bo radix p x1 - (x1 + x2) = -(powerRZ radix (Fexp x1-1)-Rabs x2))%R. apply trans_eq with (-(Fminus radix x1 (FPred bo radix p x1) - Rabs x2))%R. rewrite (Rabs_left x2); auto with real. unfold FtoRradix; rewrite Fminus_correct; auto with zarith; ring. unfold FtoRradix; rewrite FPredDiff3; auto with zarith. unfold FtoR, Zpred,Zminus; simpl;ring. apply Rplus_le_reg_l with (-(Rabs x2))%R. ring_simplify (- Rabs x2 + 2 * Rabs x2)%R. apply Rle_trans with (Rabs ((FPred bo radix p x1)-(x1+x2)))%R. pattern (FtoRradix x2) at 1; replace (FtoRradix x2) with (-(x1-(x1+x2)))%R;[rewrite Rabs_Ropp|ring]. elim x1Def; intros Y1 Y2; unfold FtoRradix; apply Y2; auto. apply FBoundedPred; auto with zarith. rewrite H; rewrite Rabs_Ropp. rewrite Rabs_right. right; ring. apply Rle_ge; apply Rplus_le_reg_l with (Rabs x2). ring_simplify. case (Rle_or_lt (Rabs x2) (powerRZ radix (Fexp x1 - 1))); auto; intros. absurd (Rabs x2 <= Rabs (FPred bo radix p x1 - (x1 + x2)))%R. rewrite H; rewrite Rabs_Ropp; apply Rlt_not_le. rewrite Rabs_left; auto with real. apply Rplus_lt_reg_r with (-Rabs x2+powerRZ radix (Fexp x1-1))%R. ring_simplify; auto with real zarith. pattern (FtoRradix x2) at 1; replace (FtoRradix x2) with (-(x1-(x1+x2)))%R;[rewrite Rabs_Ropp|ring]. elim x1Def; intros Y1 Y2; unfold FtoRradix; apply Y2; auto. apply FBoundedPred; auto with zarith. case H; clear H; intros H. assert (Rabs (x2 + y) < powerRZ radix (Fexp x1-1) / 2)%R. apply Rle_lt_trans with (Rabs x2+Rabs y)%R;[apply Rabs_triang|idtac]. apply Rplus_lt_reg_r with (-Rabs y)%R. ring_simplify (- Rabs y + (Rabs x2 + Rabs y))%R. elim Evenradix; intros n Hn. assert (powerRZ radix (Fexp x1-1) / 2 = Float n (Fexp x1 -2))%R. unfold FtoRradix, FtoR; simpl; unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith; simpl. repeat (rewrite Hn; rewrite mult_IZR);simpl; field; auto with real zarith. apply Rle_lt_trans with (Rabs (Float n (Fexp x1 - 2)) - powerRZ radix (LSB radix x2))%R. apply LSB_Pred; auto. rewrite (Rabs_right (Float n (Fexp x1 - 2))); auto with real. rewrite <- H0; auto. apply Rle_ge; unfold FtoRradix; apply LeFnumZERO; simpl; auto with real zarith. apply Zle_trans with (MSB radix x2). apply LSB_le_MSB; auto with zarith. Contradict x2NonZero. unfold FtoRradix; apply is_Fzero_rep1; auto. apply Zle_trans with (Fexp x1-2)%Z. 2: apply Zle_trans with (Fexp ((Float n (Fexp x1 - 2)))); auto with zarith. 2: apply Fexp_le_LSB. assert (MSB radix x2 < Fexp x1-1)%Z; auto with zarith. apply Zlt_powerRZ with radix; auto with real. apply Rle_lt_trans with (FtoR radix (Float (S 0) (MSB radix x2))); [right; unfold FtoR; simpl; ring|idtac]. apply Rle_lt_trans with (FtoR radix (Fabs x2)). apply MSB_le_abs; auto. Contradict x2NonZero. unfold FtoRradix; apply is_Fzero_rep1; auto. rewrite Fabs_correct; auto; fold FtoRradix. apply Rlt_le_trans with (1:=H). unfold Rdiv; apply Rle_trans with ( (powerRZ radix (Fexp x1-1)*1))%R; auto with real zarith. apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (/1)%R; auto with real. rewrite (Rabs_right (Float n (Fexp x1 - 2))); auto with real. 2: apply Rle_ge; unfold FtoRradix; apply LeFnumZERO; simpl; auto with real zarith. rewrite <- H0; unfold Rminus; rewrite Rplus_comm. apply Rplus_lt_compat_r; apply Ropp_lt_contravar. unfold FtoRradix; rewrite <- Fabs_correct; auto. apply Rlt_le_trans with (FtoR radix (Float (S 0) (Zsucc (MSB radix y))))%R. apply abs_lt_MSB; auto. unfold FtoR; simpl; ring_simplify (1 * powerRZ radix (Zsucc (MSB radix y)))%R. apply Rle_powerRZ; auto with real zarith. assert (powerRZ radix (Fexp x1 + p - 1) = x1)%R. unfold FtoRradix, FtoR; replace (Fexp x1+p-1)%Z with (Fexp x1+pred p)%Z. rewrite powerRZ_add; auto with real zarith. rewrite H1; unfold nNormMin; rewrite Zpower_nat_Z_powerRZ; auto with real zarith. rewrite inj_pred; auto with zarith; unfold Zpred; ring. left; unfold FtoRradix. apply ImplyClosestStrict with bo p (x1+x2+y)%R (Fexp x1-1)%Z; auto with zarith. elim x1Def; auto. left; auto. replace (x1+x2+y)%R with (x1+(x2+y))%R;[idtac|ring]. apply Rle_trans with ((powerRZ radix (Fexp x1 + p - 1) + -((powerRZ radix (Fexp x1-1))/2)))%R. apply Rplus_le_reg_l with ((powerRZ radix (Fexp x1-1))/2)%R. ring_simplify. apply Rle_trans with (powerRZ radix (Fexp x1 - 1 + p - 1)+powerRZ radix (Fexp x1 - 1))%R. rewrite Rplus_comm; apply Rplus_le_compat_l. apply Rle_trans with (powerRZ radix (Fexp x1 - 1) *1)%R; [unfold Rdiv; apply Rmult_le_compat_l; auto with real zarith|right; ring]. apply Rle_trans with (/1)%R; auto with real. apply Rle_trans with (powerRZ radix ((Fexp x1 - 1 + p - 1)+1)). apply powerRZSumRle; auto with zarith. apply Rle_powerRZ; auto with real zarith. apply Rplus_le_compat; auto with real. apply Rle_trans with (-(-(x2+y)))%R;[apply Ropp_le_contravar|right; ring]. apply Rle_trans with (Rabs (-(x2+y)));[apply RRle_abs|rewrite Rabs_Ropp; auto with real]. fold FtoRradix; rewrite <- H2; apply Rle_powerRZ; auto with zarith real. fold FtoRradix; replace (x1+x2+y-x1)%R with (x2+y)%R; auto with real; ring. right; elim Evenradix; intros n Hn. exists (Float (-n) (Fexp x1-2)); split;[idtac|simpl; auto with zarith]. apply trans_eq with (-(Rabs x2))%R;[rewrite H|idtac]. unfold FtoRradix, FtoR; simpl; unfold Zminus; rewrite powerRZ_add; auto with real zarith. rewrite powerRZ_add; auto with real zarith;rewrite Ropp_Ropp_IZR. simpl; ring_simplify (radix*1)%R; rewrite Hn; rewrite mult_IZR; simpl; field; auto with real. repeat apply prod_neq_R0; auto with real zarith. rewrite Rabs_left; auto with real. assert (Rabs x2 <= powerRZ radix (Fexp x1)/2)%R. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (powerRZ radix (Fexp x1));[idtac|right; simpl; field; auto with real]. replace (FtoRradix x2) with ((x1+x2) -x1)%R;[idtac|ring]. apply Rle_trans with (Fulp bo radix p x1). unfold FtoRradix; apply ClosestUlp; auto with zarith. unfold Fulp; rewrite FcanonicFnormalizeEq; auto with zarith real; left; auto. case H; clear H; intros H. assert (Rabs (x2 + y) < powerRZ radix (Fexp x1) / 2)%R. apply Rle_lt_trans with (Rabs x2+Rabs y)%R;[apply Rabs_triang|idtac]. apply Rplus_lt_reg_r with (-Rabs y)%R. ring_simplify (- Rabs y + (Rabs x2 + Rabs y))%R. elim Evenradix; intros n Hn. assert (powerRZ radix (Fexp x1) / 2 = Float n (Fexp x1 -1))%R. unfold FtoRradix, FtoR; simpl; unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl. repeat (rewrite Hn; rewrite mult_IZR); simpl; field; auto with real zarith. apply Rle_lt_trans with (Rabs (Float n (Fexp x1 - 1)) - powerRZ radix (LSB radix x2))%R. apply LSB_Pred; auto. rewrite (Rabs_right (Float n (Fexp x1 - 1))); auto with real. rewrite <- H0; auto. apply Rle_ge; unfold FtoRradix; apply LeFnumZERO; simpl; auto with real zarith. apply Zle_trans with (MSB radix x2). apply LSB_le_MSB; auto with zarith. Contradict x2NonZero. unfold FtoRradix; apply is_Fzero_rep1; auto. apply Zle_trans with (Fexp x1-1)%Z. 2: apply Zle_trans with (Fexp ((Float n (Fexp x1 - 1)))); auto with zarith. 2: apply Fexp_le_LSB. assert (MSB radix x2 < Fexp x1)%Z; auto with zarith. apply Zlt_powerRZ with radix; auto with real. apply Rle_lt_trans with (FtoR radix (Float (S 0) (MSB radix x2))); [right; unfold FtoR; simpl; ring|idtac]. apply Rle_lt_trans with (FtoR radix (Fabs x2)). apply MSB_le_abs; auto. Contradict x2NonZero. unfold FtoRradix; apply is_Fzero_rep1; auto. rewrite Fabs_correct; auto; fold FtoRradix. apply Rlt_le_trans with (1:=H). unfold Rdiv; apply Rle_trans with ( (powerRZ radix (Fexp x1)*1))%R; auto with real zarith. apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (/1)%R; auto with real. rewrite (Rabs_right (Float n (Fexp x1 - 1))); auto with real. 2: apply Rle_ge; unfold FtoRradix; apply LeFnumZERO; simpl; auto with real zarith. rewrite <- H0; unfold Rminus; rewrite Rplus_comm. apply Rplus_lt_compat_r; apply Ropp_lt_contravar. unfold FtoRradix; rewrite <- Fabs_correct; auto. apply Rlt_le_trans with (FtoR radix (Float (S 0) (Zsucc (MSB radix y))))%R. apply abs_lt_MSB; auto. unfold FtoR; simpl; ring_simplify (1 * powerRZ radix (Zsucc (MSB radix y)))%R. apply Rle_powerRZ; auto with real zarith. assert (powerRZ radix (Fexp x1 + p - 1) +powerRZ radix (Fexp x1) <= x1)%R. apply Rle_trans with (((nNormMin radix p)+1)*(powerRZ radix (Fexp x1)))%R. unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. replace (Fexp x1 + p - 1)%Z with (Fexp x1 + pred p)%Z. rewrite powerRZ_add; auto with real zarith; right;ring. rewrite inj_pred; unfold Zpred; auto with zarith. unfold FtoRradix, FtoR; apply Rmult_le_compat_r; auto with real zarith. replace 1%R with (IZR 1); auto with zarith; rewrite <- plus_IZR. assert (nNormMin radix p + 1 <= Fnum x1)%Z; auto with real zarith. assert (nNormMin radix p <= Fnum x1)%Z; auto with real zarith. elim Nx1; intros. apply Zmult_le_reg_r with radix; auto with zarith. rewrite Zmult_comm; rewrite <- PosNormMin with radix bo p; auto with zarith. apply Zle_trans with (1:=H3). rewrite Zabs_eq; auto with zarith. assert (0 <= Fnum x1)%Z; auto with zarith. apply LeR0Fnum with radix; auto with real zarith. left; unfold FtoRradix. apply ImplyClosestStrict with bo p (x1+x2+y)%R (Fexp x1); auto with zarith. elim x1Def; auto. left; auto. replace (x1+x2+y)%R with (x1+(x2+y))%R;[idtac|ring]. apply Rle_trans with ((powerRZ radix (Fexp x1 + p - 1) + powerRZ radix (Fexp x1)) +-powerRZ radix (Fexp x1))%R;[right; ring|idtac]. apply Rplus_le_compat; auto. rewrite <- (Ropp_involutive (x2+y)); apply Ropp_le_contravar. apply Rle_trans with (Rabs (-(x2+y))); [apply RRle_abs|rewrite Rabs_Ropp]. apply Rle_trans with (powerRZ radix (Fexp x1) / 2)%R; auto with real. apply Rle_trans with (powerRZ radix (Fexp x1) *1)%R; auto with real. unfold Rdiv; apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (/1)%R; auto with real. fold FtoRradix; apply Rle_trans with (2:=H2); auto with real zarith. apply Rle_trans with (powerRZ radix (Fexp x1 + p - 1)+0)%R; auto with real zarith. elim Nx1; intros G1 G2; elim G1; auto. fold FtoRradix; replace (x1+x2+y-x1)%R with (x2+y)%R; auto with real; ring. right; elim Evenradix; intros n Hn. case (Rle_or_lt 0%R x2); intros. exists (Float n (Fexp x1-1)); split;[idtac|simpl; auto with zarith]. apply trans_eq with (Rabs x2);[rewrite H|idtac]. unfold FtoRradix, FtoR; simpl; unfold Zminus; rewrite powerRZ_add; auto with real zarith. simpl; ring_simplify (radix*1)%R; rewrite Hn; rewrite mult_IZR; simpl; field; auto with real zarith. rewrite Rabs_right; auto with real. exists (Float (-n) (Fexp x1-1)); split;[idtac|simpl; auto with zarith]. apply trans_eq with (-(Rabs x2))%R;[rewrite H|idtac]. unfold FtoRradix, FtoR; simpl; unfold Zminus; rewrite powerRZ_add; auto with real zarith. rewrite Ropp_Ropp_IZR; simpl; ring_simplify (radix*1)%R; rewrite Hn; rewrite mult_IZR; simpl; field; auto with real zarith. rewrite Rabs_left; auto with real. Qed. End GenericC. Section GenericD. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 1 < p. Hypothesis Evenradix: (Even radix). Variables x1 x2 y f:float. Hypothesis x1Def: Closest bo radix (x1+x2)%R x1. Hypothesis fDef : Closest bo radix (x1+x2+y)%R f. Hypothesis yLe: (MSB radix y < LSB radix x2)%Z. Hypothesis Nx1: Fnormal radix bo x1. Hypothesis x2NonZero: ~(FtoRradix x2 =0)%R. Hypothesis x1Exp: (-dExp bo < Fexp x1)%Z. Lemma Midpoint_aux: (FtoRradix x1= f) \/ (exists v:float, (FtoRradix v=x2)%R /\ (Fexp x1 -2 <= Fexp v)%Z). case (Rle_or_lt 0 x1); intros H. case H; clear H; intros H. unfold FtoRradix; apply Midpoint_aux_aux with bo p y; auto. absurd (FtoRradix x1 =0)%R; auto with real. assert (~ is_Fzero x1). apply FnormalNotZero with radix bo; auto. unfold is_Fzero in H0. unfold FtoRradix, FtoR; apply prod_neq_R0; auto with real zarith. elim Midpoint_aux_aux with bo radix p (Fopp x1) (Fopp x2) (Fopp y) (Fopp f); auto. repeat rewrite Fopp_correct; fold FtoRradix; intros; left; auto with real. apply Rmult_eq_reg_l with (-1)%R; auto with real. apply trans_eq with (-x1)%R; [ring| apply trans_eq with (1:=H0);ring]. intros T; elim T; intros v T'; elim T'; intros; clear T T'. right; exists (Fopp v); split. unfold FtoRradix; rewrite Fopp_correct; rewrite H0; rewrite Fopp_correct; ring. simpl; apply Zle_trans with (2:=H1); simpl; auto with zarith. replace (FtoR radix (Fopp x1) + FtoR radix (Fopp x2))%R with (-(x1+x2))%R. apply ClosestOpp; auto. repeat rewrite Fopp_correct; unfold FtoRradix; ring. replace (FtoR radix (Fopp x1) + FtoR radix (Fopp x2)+ FtoR radix (Fopp y))%R with (-(x1+x2+y))%R. apply ClosestOpp; auto. repeat rewrite Fopp_correct; unfold FtoRradix; ring. rewrite <- MSB_opp; rewrite <- LSB_opp; auto. apply FnormalFop; auto. rewrite Fopp_correct; auto with real. rewrite Fopp_correct; auto with real. Qed. End GenericD. Section Be2Zero. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 3 <= p. Hypothesis Evenradix: (Even radix). Theorem TwoSumProp: forall (a b x y:float), (Fbounded bo a) -> (Closest bo radix (a+b)%R x) -> (FtoRradix y=a+b-x)%R -> (Rabs y <= Rabs b)%R. intros. elim H0; fold FtoRradix; intros. rewrite <- (Rabs_Ropp y); rewrite <- (Rabs_Ropp b). replace (-y)%R with (x-(a+b))%R;[idtac|rewrite H1; ring]. replace (-b)%R with (a-(a+b))%R;[idtac|ring]. apply H3; auto. Qed. Variable a x y r1 u1 u2 al1 al2 be1 be2 gat ga :float. Hypothesis Fa : Fbounded bo a. Hypothesis Fx : Fbounded bo x. Hypothesis Fy : Fbounded bo y. Hypothesis Nbe1: Fnormal radix bo be1. Hypothesis Nr1 : Fnormal radix bo r1. Hypothesis Cal1: Fcanonic radix bo al1. Hypothesis Cu1 : Fcanonic radix bo u1. Hypothesis Exp1: (- dExp bo < Fexp al1)%Z. Hypothesis Exp2: (- dExp bo < Fexp u1)%Z. Hypothesis r1Def: (Closest bo radix (a*x+y)%R r1). Hypothesis u1Def: (Closest bo radix (a*x)%R u1). Hypothesis u2Def: (FtoRradix u2=a*x-u1)%R. Hypothesis al1Def:(Closest bo radix (y+u2)%R al1). Hypothesis al2Def:(FtoRradix al2=y+u2-al1)%R. Hypothesis be1Def:(Closest bo radix (u1+al1)%R be1). Hypothesis be2Def:(FtoRradix be2=u1+al1-be1)%R. Hypothesis gatDef:(Closest bo radix (be1-r1)%R gat). Hypothesis gaDef: (Closest bo radix (gat+be2)%R ga). Lemma gatCorrect: exists v:float, (FtoRradix v=be1-r1)%R /\ (Fbounded bo v) /\ (Fexp v=Zmin (Fexp be1) (Fexp r1))%Z. unfold FtoRradix; apply Subexact with p u1 al1 al2; auto. apply Rle_trans with (Rabs u2). apply TwoSumProp with y al1; auto. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix p u1);[idtac|simpl; right; field; auto with real]. rewrite u2Def; unfold FtoRradix; apply ClosestUlp; auto with zarith. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix p al1);[idtac|simpl; right; field; auto with real]. fold FtoRradix; rewrite al2Def; unfold FtoRradix; apply ClosestUlp; auto with zarith. fold FtoRradix; replace (u1+al1+al2)%R with (a*x+y)%R; auto. rewrite al2Def; rewrite u2Def; ring. case (Rle_or_lt 0 (a*x+y))%R; intros I1. fold FtoRradix; split; intros I2. unfold FtoRradix; apply RleRoundedR0 with bo p (Closest bo radix) (u1+al1)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply Rplus_le_reg_l with (-u1)%R. ring_simplify. unfold FtoRradix; rewrite <- Fopp_correct. apply RleBoundRoundl with bo p (Closest bo radix) (y + u2)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply oppBounded; elim u1Def; auto. rewrite Fopp_correct; fold FtoRradix; apply Rplus_le_reg_l with (FtoRradix u1). ring_simplify (u1+-u1)%R; apply Rle_trans with (1:=I1). right; rewrite u2Def; ring. absurd (FtoRradix r1 =0)%R. assert (~ is_Fzero r1). apply FnormalNotZero with radix bo; auto. unfold is_Fzero in H. unfold FtoRradix, FtoR; apply prod_neq_R0; auto with real zarith. assert (I3: (0<= r1)%R); auto with real. unfold FtoRradix; apply RleRoundedR0 with bo p (Closest bo radix) (a*x+y)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; split; intros I2. absurd (FtoRradix r1 =0)%R. assert (~ is_Fzero r1). apply FnormalNotZero with radix bo; auto. unfold is_Fzero in H. unfold FtoRradix, FtoR; apply prod_neq_R0; auto with real zarith. assert (I3: (r1 <= 0)%R); auto with real. unfold FtoRradix; apply RleRoundedLessR0 with bo p (Closest bo radix) (a*x+y)%R; auto with zarith real. apply ClosestRoundedModeP with p; auto with zarith. unfold FtoRradix; apply RleRoundedLessR0 with bo p (Closest bo radix) (u1+al1)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply Rplus_le_reg_l with (-u1)%R. ring_simplify. unfold FtoRradix; rewrite <- Fopp_correct. apply RleBoundRoundr with bo p (Closest bo radix) (y + u2)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply oppBounded; elim u1Def; auto. rewrite Fopp_correct; fold FtoRradix; apply Rplus_le_reg_l with (FtoRradix u1). ring_simplify (u1+-u1)%R; apply Rle_trans with (a*x+y)%R; auto with real. right; rewrite u2Def; ring. Qed. Hypothesis Be2Zero: (FtoRradix be2=0)%R. Theorem FmaErr_aux1: (a*x+y=r1+ga+al2)%R. generalize gatCorrect; intros H. replace (FtoRradix ga) with (FtoRradix gat). replace (FtoRradix gat) with (be1-r1)%R. rewrite al2Def; rewrite u2Def. apply trans_eq with (a * x + y-0)%R;[ring|rewrite <- Be2Zero]. rewrite be2Def; ring. elim H; intros v H'; elim H'; intros H1 H''; elim H''; intros H2 H3; rewrite <- H1. unfold FtoRradix. apply RoundedModeProjectorIdemEq with (P:=(Closest bo radix)) (3:=pGivesBound); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; rewrite H1; auto. unfold FtoRradix. apply RoundedModeProjectorIdemEq with (P:=(Closest bo radix)) (3:=pGivesBound); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. elim gatDef; auto. fold FtoRradix; replace (FtoRradix gat) with (gat+be2)%R; auto with real. rewrite Be2Zero; ring. Qed. End Be2Zero. Section Be2NonZero. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 3 <= p. Hypothesis Evenradix: (Even radix). Variable P: R -> float -> Prop. Hypothesis P1: forall (r:R) (f:float), (P r f) -> (Closest bo radix r f). Hypothesis P2: forall (r1 r2:R) (f1 f2:float), (P r1 f1) -> (P r2 f2) -> (r1=r2)%R -> (FtoRradix f1=f2)%R. Variable a x y r1 u1 u2 al1 al2 be1 be2 gat ga :float. Hypothesis Fa : Fbounded bo a. Hypothesis Fx : Fbounded bo x. Hypothesis Fy : Fbounded bo y. Hypothesis Nbe1: Fnormal radix bo be1. Hypothesis Nr1 : Fnormal radix bo r1. Hypothesis Cal1: Fcanonic radix bo al1. Hypothesis Cu1 : Fcanonic radix bo u1. Hypothesis Exp1: (- dExp bo < Fexp al1)%Z. Hypothesis Exp2: (- dExp bo < Fexp u1)%Z. Hypothesis Exp3: (- dExp bo+1 < Fexp be1)%Z. Hypothesis r1Def: (Closest bo radix (a*x+y)%R r1). Hypothesis u1Def: (Closest bo radix (a*x)%R u1). Hypothesis u2Def: (FtoRradix u2=a*x-u1)%R. Hypothesis al1Def:(Closest bo radix (y+u2)%R al1). Hypothesis al2Def:(FtoRradix al2=y+u2-al1)%R. Hypothesis be1Def:(Closest bo radix (u1+al1)%R be1). Hypothesis be2Def:(FtoRradix be2=u1+al1-be1)%R. Hypothesis gatDef:(Closest bo radix (be1-r1)%R gat). Hypothesis gaDef: (Closest bo radix (gat+be2)%R ga). Hypothesis be2Bounded: Fbounded bo be2. Hypothesis r1DefE: (P (a*x+y)%R r1). Hypothesis be1DefE:(P (u1+al1)%R be1). Lemma Expr1 : (Fexp r1 <= Fexp be1+1)%Z. assert (radix*be1=(Float (Fnum be1) (Fexp be1+1)))%R. unfold FtoRradix, FtoR; simpl; rewrite powerRZ_add; auto with real zarith; simpl; ring. apply Zle_trans with (Fexp (Float (Fnum be1) (Fexp be1+1))); auto with zarith. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. left; auto. elim Nbe1; intros J1 J2; elim J1; intros J3 J4. left; split;[split|idtac]; simpl; auto with zarith. fold FtoRradix; rewrite <- H. rewrite Rabs_mult; rewrite (Rabs_right radix). 2: apply Rle_ge; auto with real zarith. apply Rle_trans with (2*Rabs be1)%R. 2: apply Rmult_le_compat_r; auto with real. 2: apply Rle_trans with (IZR 2); auto with real zarith. unfold FtoRradix; apply yLe2x with bo p u1 al1 al2; auto with real. apply Rle_trans with (Rabs u2). unfold FtoRradix; apply TwoSumProp with bo y al1; auto. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix p u1);[idtac|simpl; right; field; auto with real]. rewrite u2Def; unfold FtoRradix; apply ClosestUlp; auto with zarith. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix p al1);[idtac|simpl; right; field; auto with real]. fold FtoRradix; rewrite al2Def; unfold FtoRradix; apply ClosestUlp; auto with zarith. fold FtoRradix; replace (u1+al1+al2)%R with (a*x+y)%R; auto. rewrite al2Def; rewrite u2Def; ring. assert (~ is_Fzero be1). apply FnormalNotZero with radix bo; auto. unfold is_Fzero in H0. unfold FtoR; apply prod_neq_R0; auto with real zarith. Qed. Lemma Expbe1: (Fexp be1 <= Fexp r1+1)%Z. assert (radix*r1=(Float (Fnum r1) (Fexp r1+1)))%R. unfold FtoRradix, FtoR; simpl; rewrite powerRZ_add; auto with real zarith; simpl; ring. apply Zle_trans with (Fexp (Float (Fnum r1) (Fexp r1+1))); auto with zarith. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. left; auto. elim Nr1; intros J1 J2; elim J1; intros J3 J4. left; split;[split|idtac]; simpl; auto with zarith. fold FtoRradix; rewrite <- H. rewrite Rabs_mult; rewrite (Rabs_right radix). 2: apply Rle_ge; auto with real zarith. apply Rle_trans with (2*Rabs r1)%R. 2: apply Rmult_le_compat_r; auto with real. 2: apply Rle_trans with (IZR 2); auto with real zarith. unfold FtoRradix; apply xLe2y with bo p u1 al1 al2; auto with real. apply Rle_trans with (Rabs u2). unfold FtoRradix; apply TwoSumProp with bo y al1; auto. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix p u1);[idtac|simpl; right; field; auto with real]. rewrite u2Def; unfold FtoRradix; apply ClosestUlp; auto with zarith. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix p al1);[idtac|simpl; right; field; auto with real]. fold FtoRradix; rewrite al2Def; unfold FtoRradix; apply ClosestUlp; auto with zarith. fold FtoRradix; replace (u1+al1+al2)%R with (a*x+y)%R; auto. rewrite al2Def; rewrite u2Def; ring. Qed. Theorem BoundedL: forall (r:R) (x0:float) (e:Z), (e <=Fexp x0)%Z -> (-dExp bo <= e)%Z -> (FtoRradix x0=r)%R -> (Rabs r < powerRZ radix (e+p))%R -> (exists x':float, (FtoRradix x'=r) /\ (Fbounded bo x') /\ Fexp x'=e). intros. exists (Float (Fnum x0*Zpower_nat radix (Zabs_nat (Fexp x0 -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 x0 - e) + e)%Z with (Fexp x0); 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 x0 - 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 x0))). 2: apply Rle_ge; auto with real zarith. apply Rle_trans with (Rabs (Fnum x0) * (powerRZ radix e *powerRZ radix (Fexp x0 - e)))%R;[right; ring|idtac]. rewrite <- powerRZ_add; auto with real zarith. ring_simplify (e+(Fexp x0-e))%Z; auto with real. Qed. Lemma Zmin_Zlt : forall z1 z2 z3 : Z, (z1 < z2)%Z -> (z1 < z3)%Z -> (z1 < Zmin z2 z3)%Z. intros; unfold Zmin. case (z2 ?= z3)%Z; auto. Qed. Hypothesis Be2NonZero: ~(FtoRradix be2=0)%R. Lemma be2MuchSmaller: ~(FtoRradix al2=0)%R -> ~(FtoRradix u2=0)%R -> (MSB radix al2 < LSB radix be2)%Z. intros. assert (FtoRradix be2 = (Fminus radix (Fplus radix u1 al1) be1))%R. rewrite be2Def; unfold FtoRradix; rewrite Fminus_correct; auto; rewrite Fplus_correct; auto; ring. rewrite LSB_comp with radix be2 (Fminus radix (Fplus radix u1 al1) be1); auto with zarith. 2: Contradict Be2NonZero. 2: unfold FtoRradix; apply is_Fzero_rep1; auto. apply Zlt_le_trans with (Zmin (LSB radix (Fplus radix u1 al1)) (LSB radix be1)). 2: apply LSBMinus; auto. 2: Contradict Be2NonZero. 2: rewrite H1; unfold FtoRradix; apply is_Fzero_rep1; auto. apply Zmin_Zlt. apply Zlt_le_trans with (Zmin (LSB radix u1 ) (LSB radix al1)). 2: apply LSBPlus; auto. apply Zmin_Zlt. apply Zle_lt_trans with (MSB radix u2). apply MSB_monotone; auto. Contradict H; unfold FtoRradix; apply is_Fzero_rep1; auto. Contradict H0; unfold FtoRradix; apply is_Fzero_rep1; auto. repeat rewrite Fabs_correct; auto. apply TwoSumProp with bo y al1; auto. rewrite MSB_comp with radix u2 (Fminus radix (Fmult a x) u1); auto with zarith. apply MSBroundLSB with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. rewrite Fmult_correct; auto with real. Contradict H0. apply trans_eq with (FtoRradix (Fminus radix (Fmult a x) u1)). rewrite u2Def; unfold FtoRradix; rewrite Fminus_correct; auto; rewrite Fmult_correct; auto; ring. unfold FtoRradix; apply is_Fzero_rep1; auto. Contradict H0; unfold FtoRradix; apply is_Fzero_rep1; auto. fold FtoRradix; rewrite u2Def; unfold FtoRradix; rewrite Fminus_correct; auto; rewrite Fmult_correct; auto; ring. rewrite MSB_comp with radix al2 (Fminus radix (Fplus radix y u2) al1); auto with zarith. apply MSBroundLSB with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. rewrite Fplus_correct; auto with real. Contradict H. apply trans_eq with (FtoRradix (Fminus radix (Fplus radix y u2) al1)). rewrite al2Def; unfold FtoRradix; rewrite Fminus_correct; auto; rewrite Fplus_correct; auto; ring. unfold FtoRradix; apply is_Fzero_rep1; auto. Contradict H; unfold FtoRradix; apply is_Fzero_rep1; auto. fold FtoRradix; rewrite al2Def; unfold FtoRradix; rewrite Fminus_correct; auto; rewrite Fplus_correct; auto; ring. cut (~(u1+al1=0)%R). intros I; Contradict I. unfold FtoRradix; rewrite <- Fplus_correct; auto; apply is_Fzero_rep1; auto. Contradict Be2NonZero. rewrite be2Def; rewrite Be2NonZero. assert (FtoRradix be1=0)%R; auto with real. rewrite <- FzeroisReallyZero with radix (-(dExp bo))%Z. unfold FtoRradix; apply sym_eq. apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply FboundedFzero. rewrite FzeroisReallyZero; rewrite <- Be2NonZero; auto. apply Zlt_powerRZ with radix; auto with real zarith. apply Rle_lt_trans with (FtoR radix (Float (S 0) (MSB radix al2))); [unfold FtoR; simpl; right; ring|idtac]. apply Rle_lt_trans with (FtoR radix (Fabs al2));[apply MSB_le_abs; auto with zarith|idtac]. Contradict H; unfold FtoRradix; apply is_Fzero_rep1; auto. rewrite Fabs_correct; auto; fold FtoRradix. apply Rlt_le_trans with (powerRZ radix (Fexp be1)). 2: apply Rle_powerRZ; auto with real zarith. 2: apply Fexp_le_LSB; auto. apply Rlt_le_trans with (powerRZ radix (Zmin (Fexp u1) (Fexp al1))). cut (Rabs al2 < powerRZ radix (Fexp u1))%R;[intros I1|idtac]. cut (Rabs al2 < powerRZ radix (Fexp al1))%R;[intros I2|idtac]. unfold Zmin; case (Fexp u1 ?= Fexp al1)%Z; auto with real zarith. rewrite al2Def; apply Rlt_le_trans with (Fulp bo radix p al1). unfold FtoRradix; apply RoundedModeUlp with (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. unfold Fulp; rewrite FcanonicFnormalizeEq; auto with zarith real; left; auto. apply Rle_lt_trans with (Rabs u2). unfold FtoRradix; apply TwoSumProp with bo y al1; auto. rewrite u2Def; apply Rlt_le_trans with (Fulp bo radix p u1). unfold FtoRradix; apply RoundedModeUlp with (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. unfold Fulp; rewrite FcanonicFnormalizeEq; auto with zarith real; left; auto. apply Rle_powerRZ; auto with real zarith. apply Zlt_le_weak. case (Zle_or_lt (Fexp be1) (Zmin (Fexp u1) (Fexp al1))); auto. intros; Contradict Be2NonZero. rewrite be2Def. assert (FtoRradix be1=u1+al1)%R; auto with real. unfold FtoRradix; apply plusExact1 with bo p; auto with zarith float. elim u1Def; auto. elim al1Def; auto. Qed. Lemma gaCorrect: exists v:float, (FtoRradix v=be1-r1+be2)%R /\ (Fbounded bo v). elim gatCorrect with bo radix p a x y r1 u1 u2 al1 al2 be1; auto. intros v T; elim T; intros H1 T'; elim T'; intros H2 H3; clear T T'. case (Req_dec al2 0); intros Z1. exists be2; split; auto. cut (FtoRradix be1=r1)%R. intros T; rewrite T; ring. apply P2 with (u1+al1)%R (a*x+y)%R; auto. apply trans_eq with (u1+al1+al2)%R;[rewrite Z1; ring|rewrite al2Def; rewrite u2Def; ring]. case (Req_dec u2 0); intros Z2. Contradict Z1. rewrite al2Def; rewrite Z2. cut (FtoRradix y=al1);[intros I; rewrite I; ring|idtac]. apply RoundedModeProjectorIdemEq with (P:=(Closest bo radix)) (3:=pGivesBound); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. replace (FtoR radix y) with (y+u2)%R; auto with real. rewrite Z2; unfold FtoRradix; ring. elim Midpoint_aux with bo radix p be1 be2 al2 r1; auto with zarith. 3: fold FtoRradix; replace (be1+be2)%R with (u1+al1)%R; auto. 3: rewrite be2Def; ring. 3: fold FtoRradix; replace (be1+be2+al2)%R with (a*x+y)%R; auto. 3: rewrite al2Def; rewrite u2Def; rewrite be2Def; ring. 3: apply be2MuchSmaller; auto. fold FtoRradix; intros; exists be2; split; auto. rewrite H; ring. intros T'; elim T'; intros v' T; elim T; intros; clear T T'. elim BoundedL with (be1 - r1 + be2)%R (Fplus radix v v') (Fexp be1 - 2)%Z. intros v'' T; elim T; intros H4 T'; elim T'; intros; clear T T'. exists v''; split; auto. simpl; apply Zmin_Zle; auto. rewrite H3; apply Zmin_Zle; auto with zarith. generalize Expbe1; auto with zarith. auto with zarith. unfold FtoRradix; rewrite Fplus_correct; auto; rewrite H; rewrite H1; ring. replace (be1-r1+be2)%R with (((a*x+y)-r1)+-al2)%R. 2: rewrite al2Def; rewrite u2Def; rewrite be2Def; ring. apply Rle_lt_trans with (Rabs (a * x + y - r1) + Rabs(- al2))%R; [apply Rabs_triang|rewrite Rabs_Ropp]. apply Rle_lt_trans with ((powerRZ radix (Fexp be1+1))/2+(powerRZ radix (Fexp be1))/2)%R; [apply Rplus_le_compat|idtac]. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix p r1). unfold FtoRradix; apply ClosestUlp; auto with zarith. unfold Fulp; rewrite FcanonicFnormalizeEq; auto with zarith;[idtac|left; auto]. apply Rle_trans with (powerRZ radix (Fexp be1 + 1)); [apply Rle_powerRZ; auto with real zarith|right; simpl; field; auto with real]. apply Expr1. apply Rle_trans with (Rabs be2). assert (MSB radix al2 < LSB radix be2)%Z. apply be2MuchSmaller; auto. unfold FtoRradix; repeat rewrite <- Fabs_correct; auto. apply Rle_trans with (FtoR radix (Float (S 0) (Zsucc (MSB radix al2))))%R. apply Rlt_le; apply abs_lt_MSB; auto. apply Rle_trans with (FtoR radix (Float (S 0) (LSB radix be2))). unfold FtoR; simpl; apply Rmult_le_compat_l; auto with real. apply Rle_powerRZ; auto with real zarith. apply LSB_le_abs; auto. Contradict Be2NonZero; unfold FtoRradix; apply is_Fzero_rep1; auto. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix p be1). rewrite be2Def; unfold FtoRradix; apply ClosestUlp; auto with zarith. unfold Fulp; rewrite FcanonicFnormalizeEq; auto with zarith;[idtac|left; auto]. right; simpl; field; auto with real. apply Rlt_le_trans with (powerRZ radix (Fexp be1 + 1)); [idtac|apply Rle_powerRZ; auto with real zarith]. apply Rlt_le_trans with (powerRZ radix (Fexp be1 + 1) / 2 + powerRZ radix (Fexp be1+1) / 2)%R; [apply Rplus_lt_compat_l|right; field; auto with real]. unfold Rdiv; apply Rmult_lt_compat_r; auto with real. apply Rlt_powerRZ; auto with real zarith. Qed. Theorem FmaErr_aux2: (a*x+y=r1+ga+al2)%R. elim gatCorrect with bo radix p a x y r1 u1 u2 al1 al2 be1; auto. intros v1 T; elim T; intros H1 T'; elim T'; intros H2 H3; clear T T'. elim gaCorrect; intros v2 T; elim T; intros H4 H5; clear T. replace (FtoRradix ga) with (FtoRradix v2). rewrite H4; rewrite be2Def; rewrite al2Def; rewrite u2Def; ring. unfold FtoRradix; apply RoundedModeProjectorIdemEq with (P:=(Closest bo radix)) (3:=pGivesBound); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. replace (FtoR radix v2) with (gat+be2)%R; auto. fold FtoRradix; rewrite H4; assert (FtoRradix gat=be1-r1)%R; auto with real. unfold FtoRradix; rewrite <- H1. apply sym_eq; apply RoundedModeProjectorIdemEq with (P:=(Closest bo radix)) (3:=pGivesBound); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. rewrite H1; auto with real. Qed. End Be2NonZero. Section Final. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 3 <= p. Hypothesis Evenradix: (Even radix). Variable P: R -> float -> Prop. Hypothesis P1: forall (r:R) (f:float), (P r f) -> (Closest bo radix r f). Hypothesis P2: forall (r1 r2:R) (f1 f2:float), (P r1 f1) -> (P r2 f2) -> (r1=r2)%R -> (FtoRradix f1=f2)%R. Variable a x y r1 u1 u2 al1 al2 be1 be2 gat ga :float. Hypothesis Fa : Fbounded bo a. Hypothesis Fx : Fbounded bo x. Hypothesis Fy : Fbounded bo y. Hypothesis Nbe1: Fnormal radix bo be1. Hypothesis Nr1 : Fnormal radix bo r1. Hypothesis Cal1: Fcanonic radix bo al1. Hypothesis Cu1 : Fcanonic radix bo u1. Hypothesis Exp1: (- dExp bo < Fexp al1)%Z. Hypothesis Exp2: (- dExp bo < Fexp u1)%Z. Hypothesis Exp3: (- dExp bo+1 < Fexp be1)%Z. Hypothesis r1Def: (Closest bo radix (a*x+y)%R r1). Hypothesis u1Def: (Closest bo radix (a*x)%R u1). Hypothesis u2Def: (FtoRradix u2=a*x-u1)%R. Hypothesis al1Def:(Closest bo radix (y+u2)%R al1). Hypothesis al2Def:(FtoRradix al2=y+u2-al1)%R. Hypothesis be1Def:(Closest bo radix (u1+al1)%R be1). Hypothesis be2Def:(FtoRradix be2=u1+al1-be1)%R. Hypothesis gatDef:(Closest bo radix (be1-r1)%R gat). Hypothesis gaDef: (Closest bo radix (gat+be2)%R ga). Hypothesis be2Bounded: Fbounded bo be2. Hypothesis r1DefE: (P (a*x+y)%R r1). Hypothesis be1DefE:(P (u1+al1)%R be1). Theorem FmaErr_aux: (a*x+y=r1+ga+al2)%R. case (Req_dec be2 0); intros. unfold FtoRradix; apply FmaErr_aux1 with bo p u1 u2 al1 be1 be2 gat; auto. unfold FtoRradix; apply FmaErr_aux2 with bo p P u1 u2 al1 be1 be2 gat; auto. Qed. End Final. Section Final2. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 3 <= p. Hypothesis Evenradix: (Even radix). Lemma ClosestZero1: forall (r:R) (f g:float), (Closest bo radix r f) -> (FtoRradix f=0)%R -> (r=g)%R -> (-dExp bo <= Fexp g)%Z -> (r=0)%R. intros. case (Req_dec r 0); auto; intros. absurd (powerRZ radix (-(dExp bo)) <= Rabs f)%R; auto. apply Rlt_not_le; rewrite H0; rewrite Rabs_R0; auto with real zarith. apply Rle_trans with (FtoRradix (Float 1 (-(dExp bo)))). right; unfold FtoRradix, FtoR; simpl; ring. unfold FtoRradix; apply RoundAbsMonotonel with bo p (Closest bo radix) r; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. split; simpl; auto with zarith. rewrite pGivesBound; apply Zle_lt_trans with (Zpower_nat radix 0); auto with zarith. rewrite H1; unfold FtoRradix; rewrite <- Fabs_correct; auto. unfold FtoR; simpl; apply Rmult_le_compat; auto with real zarith. replace 1%R with (IZR 1); auto with real zarith. assert (1 <= Zabs (Fnum g))%Z; auto with zarith real. case (Zle_lt_or_eq 0 (Zabs (Fnum g))); auto with zarith; intros. absurd (Rabs r=0)%R. apply Rabs_no_R0; auto. rewrite H1; unfold FtoRradix; rewrite <- Fabs_correct; auto; unfold FtoR; simpl. rewrite <- H4; simpl; ring. apply Rle_powerRZ; auto with real zarith. Qed. Lemma ClosestZero2: forall (r:R) (x:float), (Closest bo 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 bo p (Closest bo radix) r; auto with real. apply ClosestRoundedModeP with p; auto with zarith. unfold FtoRradix; apply RleRoundedR0 with bo p (Closest bo radix) r; auto with real. apply ClosestRoundedModeP with p; auto with zarith. Qed. Lemma LeExpRound:forall f g:float, Closest bo radix f g -> exists g':float, Fbounded bo g' /\ FtoRradix g'=g /\ (Fexp f <= Fexp g')%Z. intros. case (Zle_or_lt (Fexp f) (Fexp g)); intros. exists g; split; auto. elim H; auto. elim RoundedModeRep with bo radix p (Closest bo radix) f g; auto with zarith. 2: apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; intros n H1. exists (Float n (Fexp f)). elim H; intros H2 T; clear T. split; split; simpl; auto with zarith real . apply Zle_lt_trans with (Zabs (Fnum g)); auto with zarith float. apply Zle_Rle. apply Rmult_le_reg_l with (powerRZ radix (Fexp g)); auto with real zarith. apply Rle_trans with (Rabs g);[idtac| unfold FtoRradix; rewrite <- Fabs_correct; auto; unfold FtoR; simpl; right; ring]. rewrite H1; unfold FtoRradix; rewrite <- Fabs_correct; auto; unfold FtoR; simpl. rewrite Rmult_comm; apply Rmult_le_compat_l; auto with real zarith. apply Zle_trans with (Fexp g); auto with zarith float. Qed. Lemma LeExpRound2:forall (n:Z) (f g:float), Closest bo radix f g -> (n <= Fexp f)%Z -> exists g':float, Fbounded bo g' /\ FtoRradix g'=g /\ (n <= Fexp g')%Z. intros. elim LeExpRound with f g; auto. intros g' T; elim T; intros T1 T2; elim T2; intros T3 T4; clear T T2. exists g'; split; auto; split; auto with zarith. Qed. Variable P: R -> float -> Prop. Hypothesis P1: forall (r:R) (f:float), (P r f) -> (Closest bo radix r f). Hypothesis P2: forall (r1 r2:R) (f1 f2:float), (P r1 f1) -> (P r2 f2) -> (r1=r2)%R -> (FtoRradix f1=f2)%R. Variable a x y r1 u1 u2 al1 al2 be1 be2 gat ga :float. Hypothesis Fa : Fbounded bo a. Hypothesis Fx : Fbounded bo x. Hypothesis Fy : Fbounded bo y. Hypothesis Nbe1: Fcanonic radix bo be1. Hypothesis Nr1 : Fcanonic radix bo r1. Hypothesis Cal1: Fcanonic radix bo al1. Hypothesis Cu1 : Fcanonic radix bo u1. Hypothesis Exp1: (- dExp bo < Fexp al1)%Z \/ (FtoRradix al1=0)%R. Hypothesis Exp2: (- dExp bo < Fexp u1)%Z \/ (FtoRradix u1=0)%R. Hypothesis Exp3: (- dExp bo+1 < Fexp be1)%Z\/ (FtoRradix be1=0)%R. Hypothesis Exp4: (Fnormal radix bo r1) \/ (FtoRradix r1=0)%R. Hypothesis Exp5: (-dExp bo <= Fexp a+Fexp x)%Z. Hypothesis u1Def: (Closest bo radix (a*x)%R u1). Hypothesis u2Def: (FtoRradix u2=a*x-u1)%R. Hypothesis al1Def:(Closest bo radix (y+u2)%R al1). Hypothesis al2Def:(FtoRradix al2=y+u2-al1)%R. Hypothesis be2Def:(FtoRradix be2=u1+al1-be1)%R. Hypothesis gatDef:(Closest bo radix (be1-r1)%R gat). Hypothesis gaDef: (Closest bo radix (gat+be2)%R ga). Hypothesis r1DefE: (P (a*x+y)%R r1). Hypothesis be1DefE:(P (u1+al1)%R be1). Theorem FmaErr: (a*x+y=r1+ga+al2)%R. case Exp1; intros I1. case Exp2; intros I2. case Exp3; intros I3. case Exp4; intros I4. elim errorBoundedPlus with bo radix p u1 al1 be1; auto with zarith. 2: elim u1Def; auto. 2: elim al1Def; auto. fold FtoRradix; intros be2' T; elim T; intros J1 T'; elim T'; intros J2 J3; clear T T'. unfold FtoRradix; apply FmaErr_aux with bo p P u1 u2 al1 be1 be2' gat; auto. elim Nbe1; intros; auto. elim H; intros T1 T2; elim T2; intros T3 T4; Contradict T3; auto with zarith. fold FtoRradix; rewrite J1; rewrite <- be2Def; auto. assert (a*x+y=0)%R. apply ClosestZero1 with r1 (Fplus radix (Fmult a x) y); auto. unfold FtoRradix; rewrite Fplus_correct; auto; rewrite Fmult_correct; auto with real zarith. simpl; apply Zmin_Zle; auto with zarith. elim Fy; auto. rewrite H. assert (FtoRradix r1=0)%R. apply ClosestZero2 with (a*x+y)%R; auto; elim r1DefE; auto. assert (FtoRradix u1= (Fopp y))%R. unfold FtoRradix; apply sym_eq; apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply oppBounded; auto. replace (FtoR radix (Fopp y)) with (a*x)%R; auto. rewrite Fopp_correct; fold FtoRradix; auto with real. apply Rplus_eq_reg_l with y; rewrite Rplus_comm; rewrite H; ring. assert (FtoRradix u2=0)%R. rewrite u2Def; rewrite H1; unfold FtoRradix; rewrite Fopp_correct; fold FtoRradix. rewrite <- H; ring. assert (FtoRradix al1= y)%R. unfold FtoRradix; apply sym_eq; apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. replace (FtoR radix y) with (y+u2)%R; auto with real. rewrite H2; auto with real. assert (FtoRradix al2=0)%R. rewrite al2Def; rewrite H2; rewrite H3; ring. assert (FtoRradix be1=0)%R. apply ClosestZero2 with (u1+al1)%R; auto. rewrite H3; rewrite H1; unfold FtoRradix; rewrite Fopp_correct; ring. assert (FtoRradix be2=0)%R. rewrite be2Def; rewrite H1; rewrite H3; rewrite H5; unfold FtoRradix; rewrite Fopp_correct; ring. assert (FtoRradix gat=0)%R. apply ClosestZero2 with (be1-r1)%R; auto. rewrite H5; rewrite H0; ring. assert (FtoRradix ga=0)%R. apply ClosestZero2 with (gat+be2)%R; auto. rewrite H7; rewrite H6; ring. rewrite H0; rewrite H8; rewrite H4; ring. assert (u1 + al1=0)%R. apply ClosestZero1 with be1 (Fplus radix u1 al1); auto. unfold FtoRradix; rewrite Fplus_correct; auto. simpl; apply Zmin_Zle. elim u1Def; intros T1 T2; elim T1; auto. elim al1Def; intros T1 T2; elim T1; auto. assert (FtoRradix be2=0)%R. rewrite be2Def; rewrite I3; rewrite H; ring. assert (FtoRradix gat= (Fopp r1))%R. unfold FtoRradix; apply sym_eq; apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply oppBounded; auto. assert (T:(Closest bo radix (a*x+y)%R r1)); auto; elim T; auto. replace (FtoR radix (Fopp r1)) with (be1-r1)%R; auto. rewrite I3; rewrite Fopp_correct; fold FtoRradix; auto with real. assert (FtoRradix ga= gat)%R. unfold FtoRradix; apply sym_eq; apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. elim gatDef; auto. replace (FtoR radix gat) with (gat+be2)%R; auto. rewrite H0; auto with real. apply sym_eq; apply trans_eq with (FtoRradix al2). rewrite H2; rewrite H1; unfold FtoRradix; rewrite Fopp_correct; ring. rewrite al2Def; rewrite u2Def. apply trans_eq with (y+a*x-(u1+al1))%R;[idtac|rewrite H]; ring. assert (a*x=0)%R. apply ClosestZero1 with u1 (Fmult a x); auto. unfold FtoRradix; rewrite Fmult_correct; auto. assert (FtoRradix r1=y). unfold FtoRradix; apply sym_eq; apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. replace (FtoR radix y) with (a*x+y)%R;[idtac|rewrite H]; auto with real. assert (FtoRradix u2=0)%R. rewrite u2Def; rewrite I2; rewrite H; ring. assert (FtoRradix al1=y). unfold FtoRradix; apply sym_eq; apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. replace (FtoR radix y) with (y+u2)%R;[idtac|rewrite H1]; auto with real. assert (FtoRradix al2=0)%R. rewrite al2Def; rewrite H1; rewrite H2; ring. assert (FtoRradix be1=y). unfold FtoRradix; apply sym_eq; apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. replace (FtoR radix y) with (u1+al1)%R;[idtac|rewrite I2; rewrite H2]; auto with real. assert (FtoRradix gat=0). apply ClosestZero2 with (be1-r1)%R; auto. rewrite H4; rewrite H0; ring. assert (FtoRradix ga=0). apply ClosestZero2 with (gat+be2)%R; auto. rewrite be2Def;rewrite H5; rewrite I2; rewrite H2; rewrite H4; simpl; ring. rewrite H; rewrite H0; rewrite H6; rewrite H3;simpl; ring. assert (y + u2=0)%R. elim errorBoundedMult with bo radix p (Closest bo radix) a x u1; auto with zarith. fold FtoRradix; intros u2' T; elim T; intros H1 T'; elim T'; intros H2 H3; clear T T'. apply ClosestZero1 with al1 (Fplus radix y u2'); auto. unfold FtoRradix; rewrite Fplus_correct; auto; fold FtoRradix; rewrite H1; rewrite u2Def; ring. simpl; apply Zmin_Zle; auto with zarith float. apply ClosestRoundedModeP with p; auto with zarith. assert (FtoRradix be1=u1). unfold FtoRradix; apply sym_eq; apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. elim u1Def; auto. replace (FtoR radix u1) with (u1+al1)%R;[idtac|rewrite I1]; auto with real. assert (FtoRradix r1=u1). unfold FtoRradix; apply sym_eq; apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. elim u1Def; auto. replace (FtoR radix u1) with (a*x+y)%R;[idtac|idtac]; auto with real. fold FtoRradix; apply trans_eq with (u1+(y+u2))%R;[rewrite u2Def| rewrite H]; ring. assert (FtoRradix gat=0)%R. apply ClosestZero2 with (be1-r1)%R; auto; rewrite H0; rewrite H1; auto with real. assert (FtoRradix ga=0)%R. apply ClosestZero2 with (gat+be2)%R; auto. rewrite H2; rewrite be2Def; rewrite I1; rewrite H0; ring. rewrite H1; rewrite H3; rewrite al2Def; rewrite u2Def; rewrite I1; ring. Qed. Theorem Fma_FTS: (exists ga_e:float, exists al2_e:float, (FtoRradix ga_e=ga)%R /\ (FtoRradix al2_e=al2)%R /\ (Fbounded bo ga_e) /\ (Fbounded bo al2_e) /\ (Fexp al2_e <= Fexp ga_e)%Z). elim errorBoundedMult with bo radix p (Closest bo radix) a x u1; auto with zarith. 2:apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; intros u2' T; elim T; intros E1 T'; elim T'; intros E2 E3; clear T T'. elim errorBoundedPlus with bo radix p y u2' al1; auto with zarith. 2: fold FtoRradix; rewrite E1; rewrite <- u2Def; auto. rewrite E3; intros al2' T; elim T; intros F1 T'; elim T'; intros F2 F3; clear T T'. elim LeExpRound2 with (Zmin (Fexp y) (Fexp a+Fexp x)) (Fplus radix y u2') al1; auto. 2: unfold FtoRradix; rewrite Fplus_correct; auto; fold FtoRradix; rewrite E1; rewrite <- u2Def; auto. 2:simpl; rewrite E3; auto with zarith. intros al1' T; elim T; intros U1 T'; elim T'; intros U2 U3; clear T T'. elim LeExpRound2 with (Zmin (Fexp y) (Fexp a+Fexp x)) (Fmult a x) u1; auto with zarith. 2: unfold FtoRradix; rewrite Fmult_correct; auto. intros u1' T; elim T; intros U4 T'; elim T'; intros U5 U6; clear T T'. elim LeExpRound2 with (Zmin (Fexp y) (Fexp a+Fexp x)) (Fplus radix (Fmult a x) y) r1; auto with zarith. 2: unfold FtoRradix; rewrite Fplus_correct; auto; rewrite Fmult_correct; auto. 2: simpl; rewrite Zmin_sym; auto with zarith. intros r1' T; elim T; intros U7 T'; elim T'; intros U8 U9; clear T T'. elim LeExpRound2 with (Zmin (Fexp y) (Fexp a+Fexp x)) (Fplus radix u1' al1') be1; auto with zarith. 2: unfold FtoRradix; rewrite Fplus_correct; auto; fold FtoRradix; rewrite U5; rewrite U2; auto. 2: simpl; apply Zmin_Zle; auto with zarith. intros be1' T; elim T; intros V1 T'; elim T'; intros V2 V3; clear T T'. elim errorBoundedPlus with bo radix p u1' al1' be1; auto with zarith. 2: fold FtoRradix; rewrite U5; rewrite U2; auto. fold FtoRradix; intros be2' T; elim T; intros V4 T'; elim T'; intros V5 V6; clear T T'. elim LeExpRound2 with (Zmin (Fexp y) (Fexp a+Fexp x)) (Fminus radix be1' r1') gat; auto with zarith. 2: unfold FtoRradix; rewrite Fminus_correct; auto; fold FtoRradix; rewrite V2; rewrite U8; auto. 2: simpl; apply Zmin_Zle; auto with zarith. intros gat' T; elim T; intros V7 T'; elim T'; intros V8 V9; clear T T'. elim LeExpRound2 with (Zmin (Fexp y) (Fexp a+Fexp x)) (Fplus radix gat' be2') ga; auto with zarith. 2: unfold FtoRradix; rewrite Fplus_correct; auto; fold FtoRradix; rewrite V8; rewrite V4; rewrite U5; rewrite U2; rewrite <- be2Def; auto. 2: simpl; apply Zmin_Zle; auto with zarith. 2: rewrite V6; apply Zmin_Zle; auto with zarith. intros ga' T; elim T; intros W1 T'; elim T'; intros W2 W3; clear T T'. exists ga'; exists al2'; split; auto; split. unfold FtoRradix; rewrite F1; fold FtoRradix. rewrite E1; rewrite al2Def; rewrite u2Def; ring. split; auto; split; auto with zarith. Qed. End Final2. Section Final_Even. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 3 <= p. Hypothesis Evenradix: (Even radix). Variable a x y r1 u1 u2 al1 al2 be1 be2 gat ga :float. Hypothesis Fa : Fbounded bo a. Hypothesis Fx : Fbounded bo x. Hypothesis Fy : Fbounded bo y. Hypothesis Nbe1: Fcanonic radix bo be1. Hypothesis Nr1 : Fcanonic radix bo r1. Hypothesis Cal1: Fcanonic radix bo al1. Hypothesis Cu1 : Fcanonic radix bo u1. Hypothesis Exp1: (- dExp bo < Fexp al1)%Z \/ (FtoRradix al1=0)%R. Hypothesis Exp2: (- dExp bo < Fexp u1)%Z \/ (FtoRradix u1=0)%R. Hypothesis Exp3: (- dExp bo+1 < Fexp be1)%Z\/ (FtoRradix be1=0)%R. Hypothesis Exp4: (Fnormal radix bo r1) \/ (FtoRradix r1=0)%R. Hypothesis Exp5: (-dExp bo <= Fexp a+Fexp x)%Z. Hypothesis u1Def: (Closest bo radix (a*x)%R u1). Hypothesis u2Def: (FtoRradix u2=a*x-u1)%R. Hypothesis al1Def:(Closest bo radix (y+u2)%R al1). Hypothesis al2Def:(FtoRradix al2=y+u2-al1)%R. Hypothesis be2Def:(FtoRradix be2=u1+al1-be1)%R. Hypothesis gatDef:(Closest bo radix (be1-r1)%R gat). Hypothesis gaDef: (Closest bo radix (gat+be2)%R ga). Hypothesis r1DefE: (EvenClosest bo radix p (a*x+y)%R r1). Hypothesis be1DefE:(EvenClosest bo radix p (u1+al1)%R be1). Theorem FmaErr_Even: (a*x+y=r1+ga+al2)%R. unfold FtoRradix; apply FmaErr with bo p (EvenClosest bo radix p) u1 u2 al1 be1 be2 gat; auto. intros r f T; elim T; auto. intros; generalize EvenClosestUniqueP; unfold UniqueP; intros. apply H2 with bo p r2; auto with zarith real. rewrite <- H1; auto. Qed. Theorem Fma_FTS_Even: (exists ga_e:float, exists al2_e:float, (FtoRradix ga_e=ga)%R /\ (FtoRradix al2_e=al2)%R /\ (Fbounded bo ga_e) /\ (Fbounded bo al2_e) /\ (Fexp al2_e <= Fexp ga_e)%Z). unfold FtoRradix; apply Fma_FTS with p (EvenClosest bo radix p) a x y r1 u1 u2 al1 be1 be2 gat; auto. intros r f T; elim T; auto. Qed. End Final_Even. Float8.4/FnElem/FmaErr2.v0000644000423700002640000025152612032774527014660 0ustar sboldotoccataRequire Export AllFloat. Require Export Veltkamp. Section GenericAA. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 1 < p. Hypothesis Evenradix: (Even radix). Lemma ClosestZero1: forall (r:R) (f g:float), (Closest bo radix r f) -> (FtoRradix f=0)%R -> (r=g)%R -> (-dExp bo <= Fexp g)%Z -> (r=0)%R. intros. case (Req_dec r 0); auto; intros. absurd (powerRZ radix (-(dExp bo)) <= Rabs f)%R; auto. apply Rlt_not_le; rewrite H0; rewrite Rabs_R0; auto with real zarith. apply Rle_trans with (FtoRradix (Float 1 (-(dExp bo)))). right; unfold FtoRradix, FtoR; simpl; ring. unfold FtoRradix; apply RoundAbsMonotonel with bo p (Closest bo radix) r; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. split; simpl; auto with zarith. rewrite pGivesBound; apply Zle_lt_trans with (Zpower_nat radix 0); auto with zarith. rewrite H1; unfold FtoRradix; rewrite <- Fabs_correct; auto. unfold FtoR; simpl; apply Rmult_le_compat; auto with real zarith. replace 1%R with (IZR 1); auto with real zarith. assert (1 <= Zabs (Fnum g))%Z; auto with zarith real. case (Zle_lt_or_eq 0 (Zabs (Fnum g))); auto with zarith; intros. absurd (Rabs r=0)%R. apply Rabs_no_R0; auto. rewrite H1; unfold FtoRradix; rewrite <- Fabs_correct; auto; unfold FtoR; simpl. rewrite <- H4; simpl; ring. apply Rle_powerRZ; auto with real zarith. Qed. Lemma ClosestZero2: forall (r:R) (x:float), (Closest bo 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 bo p (Closest bo radix) r; auto with real. apply ClosestRoundedModeP with p; auto with zarith. unfold FtoRradix; apply RleRoundedR0 with bo p (Closest bo radix) r; auto with real. apply ClosestRoundedModeP with p; auto with zarith. Qed. End GenericAA. Section GenericA. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 1 < p. Variable a b e x y:float. Hypothesis eLea: (Rabs e <= /2*Fulp bo radix p a)%R. Hypothesis eLeb: (Rabs e <= /2*Fulp bo radix p b)%R. Hypothesis xDef: Closest bo radix (a+b)%R x. Hypothesis yDef: Closest bo radix (a+b+e)%R y. Hypothesis Nx: Fcanonic radix bo x. Hypothesis Ny: Fcanonic radix bo y. Hypothesis Cb: Fcanonic radix bo b. Hypothesis Ca: Fcanonic radix bo a. Hypothesis Fe: Fbounded bo e. (* Added Hyp -- let us hope this will be ok... *) Let Unmoins := (1 - (powerRZ radix (Zsucc (-p)))/2)%R. Let Unplus := (1 + (powerRZ radix (Zsucc (-p)))/2)%R. Lemma UnMoinsPos: (0 < Unmoins)%R. unfold Unmoins. assert (powerRZ radix (Zsucc (-p)) / 2 < 1)%R; auto with real. apply Rmult_lt_reg_l with 2%R; auto with real. apply Rle_lt_trans with (powerRZ radix (Zsucc (-p))); [right; field; auto with real| ring_simplify (2*1)%R]. apply Rle_lt_trans with (powerRZ radix (Zsucc (-1))); unfold Zpred; auto with real zarith. Qed. Lemma ClosestRoundeLeNormal: forall (z : R) (f : float), Closest bo radix z f -> Fnormal radix bo f -> (Rabs f <= (Rabs z) / Unmoins)%R. intros. generalize UnMoinsPos; intros U1. apply Rmult_le_reg_l with Unmoins; auto with real. apply Rle_trans with (Rabs z);[idtac|right; field; auto with real]. apply Rplus_le_reg_l with (-Rabs z+(1-Unmoins)*Rabs f)%R. apply Rle_trans with (Rabs f-Rabs z)%R;[right; ring|idtac]. apply Rle_trans with (Rabs (f-z));[apply Rabs_triang_inv|idtac]. replace (f-z)%R with (-(z-f))%R;[rewrite Rabs_Ropp|ring]. apply Rle_trans with (Rabs (f) * (/ S 1 * powerRZ radix (Zsucc (- p))))%R. unfold FtoRradix; apply ClosestErrorBoundNormal with bo; auto with zarith. rewrite FcanonicFnormalizeEq; auto with zarith; left; auto. unfold Unmoins, Rdiv; right; simpl;ring. Qed. Lemma ClosestRoundeGeNormal: forall (z : R) (f : float), Closest bo radix z f -> Fnormal radix bo f -> (Rabs z <= (Rabs f) * Unplus)%R. intros. apply Rplus_le_reg_l with (-(Rabs f))%R. apply Rle_trans with (Rabs z-Rabs f)%R;[right; ring|idtac]. apply Rle_trans with (Rabs (z-f));[apply Rabs_triang_inv|idtac]. apply Rle_trans with (Rabs (f) * (/ S 1 * powerRZ radix (Zsucc (- p))))%R. unfold FtoRradix; apply ClosestErrorBoundNormal with bo; auto with zarith. rewrite FcanonicFnormalizeEq; auto with zarith; left; auto. unfold Unplus; simpl; unfold Rdiv; right; ring. Qed. Theorem Exact1 : forall q r : float, Closest bo radix (FtoR radix q) r -> (Fexp r <= (Fexp q))%Z -> (FtoRradix r = q)%R. intros. cut (2%nat * Rabs (FtoR radix q - FtoR radix r) <= Float 1%nat (Fexp r))%R. 2: apply Rle_trans with (Fulp bo radix p r); auto. 2: apply (ClosestUlp bo radix p); auto with zarith. 2: unfold FtoRradix in |- *; apply FulpLe; auto. 2: apply RoundedModeBounded with (radix := radix) (P := Closest bo radix) (r := q); auto. 2: apply ClosestRoundedModeP with (precision := p); auto. intros H1. cut (exists z:Z, (r-q=z*powerRZ radix (Fexp r))%R /\ (2*Zabs z <= 1)%Z). intros (z,(H2,H3)). assert (Zabs z=0)%Z; auto with zarith. assert (0 <= Zabs z)%Z;[apply Zabs_pos|idtac]; auto with zarith. assert (z=0)%Z. generalize H4; unfold Zabs; case z; intros; auto with zarith; discriminate. apply Rplus_eq_reg_l with (-q)%R. apply trans_eq with (r-q)%R;[ring|rewrite H2]. rewrite H5; simpl; ring. exists (Fnum (Fminus radix r q)). assert ((r - q)%R = (Fnum (Fminus radix r q) * powerRZ radix (Fexp r))%R). unfold FtoRradix; rewrite <- Fminus_correct; auto. unfold FtoR; replace (Fexp r) with (Fexp (Fminus radix r q)); auto. unfold Fminus, Fopp, Fplus; simpl. apply Zmin_le1; auto. split; auto; apply le_IZR. apply Rmult_le_reg_l with (powerRZ radix (Fexp r)); auto with real zarith. apply Rle_trans with (FtoRradix (Float 1%nat (Fexp r))). 2: unfold FtoRradix, FtoR; simpl;right; ring. apply Rle_trans with (2:=H1). fold FtoRradix; replace (q-r)%R with (-(r-q))%R by ring. rewrite Rabs_Ropp; rewrite H2; rewrite Rabs_mult. rewrite Rabs_Zabs. rewrite Rabs_right;[simpl (INR 2); right|apply Rle_ge; auto with real zarith]. rewrite mult_IZR; simpl (IZR 2); ring. Qed. Lemma ClosestRoundeLeNormalSub: forall (z : R) (f : float), Closest bo radix z f -> (exists f:float, (FtoR radix f=z) /\ (- dExp bo <= Fexp f)%Z) -> (Rabs (FtoR radix f) <= Rabs z / (1 - powerRZ radix (Zsucc (- p)) / 2))%R. assert ( forall (z : R) (f : float), (Fcanonic radix bo f) -> Closest bo radix z f -> (exists u:float, (FtoR radix u=z) /\ (- dExp bo <= Fexp u)%Z) -> (Rabs (FtoR radix f) <= Rabs z / (1 - powerRZ radix (Zsucc (- p)) / 2))%R). intros. case H; clear H; intros H. apply ClosestRoundeLeNormal; auto. replace (FtoR radix f) with z. apply Rle_trans with (Rabs z /1)%R;[right; field; auto with real|idtac]. apply Rmult_le_compat_l; auto with real. apply Rle_Rinv; auto with real. apply UnMoinsPos; auto with zarith real. apply Rplus_le_reg_l with (-1+powerRZ radix (Zsucc (- p)) / 2)%R; ring_simplify. unfold Rdiv; apply Rmult_le_pos; auto with real zarith. elim H1; intros u (H3,H4). rewrite <- H3; apply sym_eq; apply Exact1; auto. rewrite H3; auto. elim H; intros H5 (H6,H7); auto with zarith. intros. rewrite <- FnormalizeCorrect with radix bo p f; auto with zarith. apply H; auto. apply FnormalizeCanonic; auto with zarith. elim H0; auto. apply (ClosestCompatible bo radix z z f); auto with zarith. rewrite FnormalizeCorrect; auto. apply FnormalizeBounded; auto with zarith float. elim H0; auto. Qed. Lemma ClosestRoundeGeNormalSub: forall (z : R) (f : float), Closest bo radix z f -> (exists f:float, (FtoR radix f=z) /\ (- dExp bo <= Fexp f)%Z) -> (Rabs z <= Rabs (FtoR radix f) * (1 + powerRZ radix (Zsucc (- p)) / 2))%R. assert ( forall (z : R) (f : float), (Fcanonic radix bo f) -> Closest bo radix z f -> (exists u:float, (FtoR radix u=z) /\ (- dExp bo <= Fexp u)%Z) -> (Rabs z <= Rabs (FtoR radix f) * (1 + powerRZ radix (Zsucc (- p)) / 2))%R). intros. case H; clear H; intros H. apply ClosestRoundeGeNormal; auto. replace (FtoR radix f) with z. apply Rle_trans with (Rabs z *1)%R;[right; field; auto with real|idtac]. apply Rmult_le_compat_l; auto with real. apply Rplus_le_reg_l with (-1)%R; ring_simplify. unfold Rdiv; apply Rmult_le_pos; auto with real zarith. elim H1; intros u (H3,H4). rewrite <- H3; apply sym_eq; apply Exact1; auto. rewrite H3; auto. elim H; intros H5 (H6,H7); auto with zarith. intros. rewrite <- FnormalizeCorrect with radix bo p f; auto with zarith. apply H; auto. apply FnormalizeCanonic; auto with zarith. elim H0; auto. apply (ClosestCompatible bo radix z z f); auto with zarith. rewrite FnormalizeCorrect; auto. apply FnormalizeBounded; auto with zarith float. elim H0; auto. Qed. Hypothesis Evenradix: (Even radix). Lemma abeLeab: (Rabs b <= Rabs a)%R -> (2*powerRZ radix (Fexp b) <= Rabs (a+b))%R -> (Rabs (a+b) <= Rabs (a+b+e) *4/3)%R. intros. assert (0 <3)%R; [apply Rlt_trans with 2%R; auto with real|idtac]. assert (0 <4)%R; [apply Rlt_trans with 3%R; auto with real|idtac]. apply Rlt_le_trans with (3+1)%R; auto with real; right; ring. apply Rmult_le_reg_l with (3/4)%R; auto with real. unfold Rdiv; apply Rmult_lt_0_compat; auto with real. apply Rle_trans with (Rabs (a + b + e));[idtac|right; field; auto with real]. apply Rplus_le_reg_l with (/4*Rabs (a + b))%R. apply Rle_trans with (Rabs (a+b));[right; field; auto with real|idtac]. pattern (a+b)%R at 1; replace (a+b)%R with ((a+b+e)+(-e))%R;[idtac|ring]. apply Rle_trans with (Rabs (a+b+e)+ Rabs (-e))%R;[apply Rabs_triang|idtac]. rewrite Rplus_comm; apply Rplus_le_compat_r. rewrite Rabs_Ropp; apply Rle_trans with (1:=eLeb). apply Rmult_le_reg_l with 4%R; auto with real. apply Rle_trans with (Rabs (a+b));[idtac|right; field; auto with real]. apply Rle_trans with (2:=H0). unfold Fulp; rewrite FcanonicFnormalizeEq; auto with zarith. right; field; auto with real. Qed. Lemma xLe2y_aux1: (Rabs b <= Rabs a)%R -> (powerRZ radix (Fexp b) = Rabs (a+b))%R -> (Rabs x <= 2*Rabs y)%R. intros. case (Req_dec y 0); intros L. assert (a+b+e=0)%R. apply ClosestZero1 with bo radix p y (Fplus radix (Fplus radix a b) e); auto with zarith. repeat rewrite Fplus_correct; auto with zarith; ring. unfold Fplus; simpl; repeat apply Zmin_Zle; auto with float. assert (Fbounded bo a); try apply FcanonicBound with radix; auto with zarith float. assert (Fbounded bo b); try apply FcanonicBound with radix; auto with zarith float. assert (exists n:Z, (a+b = n*powerRZ radix (Fexp b))%R). exists (Fnum (Fplus radix a b)). unfold FtoRradix; rewrite <- Fplus_correct; auto with zarith. unfold FtoR; replace (Fexp (Fplus radix a b)) with (Fexp b); auto. unfold Fplus; simpl; apply sym_eq; apply Zmin_le2; auto. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. elim H2; clear H2; intros n H2. case (Z_eq_dec n 0); intros H3. rewrite L; replace (FtoRradix x) with 0%R. rewrite Rabs_R0; auto with real. apply sym_eq; apply ClosestZero2 with bo p (a+b)%R; auto. rewrite H2; rewrite H3; simpl; ring. Contradict eLeb; apply Rlt_not_le. apply Rlt_le_trans with (1*Fulp bo radix p b)%R. apply Rmult_lt_compat_r. unfold Fulp; auto with real zarith. apply Rlt_le_trans with (/1)%R; auto with real. rewrite CanonicFulp; auto with zarith. apply Rle_trans with (1%Z * powerRZ radix (Fexp b))%R. right; unfold FtoR; simpl; ring. apply Rle_trans with (Rabs n * powerRZ radix (Fexp b))%R. apply Rmult_le_compat_r; auto with real zarith. rewrite Rabs_Zabs; apply Rle_IZR. unfold Zabs; generalize H3; case n; intros; auto with zarith. replace (FtoRradix e) with (-(a+b))%R. rewrite Rabs_Ropp; rewrite H2; rewrite Rabs_mult. rewrite (Rabs_right (powerRZ radix (Fexp b))); try apply Rle_ge; auto with real zarith. apply Rplus_eq_reg_l with (a+b)%R; rewrite H1; auto with real. apply Rle_trans with (Rabs (a+b));[right|idtac]. rewrite <- H0; unfold FtoRradix; rewrite <- Fabs_correct; auto. apply trans_eq with (FtoRradix (Float 1 (Fexp b))); [apply sym_eq |unfold FtoRradix, FtoR; simpl; ring]. apply RoundedModeProjectorIdemEq with (P:=(Closest bo radix)) (3:=pGivesBound); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. split; simpl. apply vNumbMoreThanOne with radix p; auto with zarith. assert (Fbounded bo b); auto with zarith float. apply FcanonicBound with radix; auto. replace (FtoR radix (Float 1 (Fexp b))) with (Rabs (a+b)). apply ClosestFabs with p; auto with zarith. rewrite <- H0; unfold FtoR; simpl; ring. rewrite <- H0; apply Rmult_le_reg_l with (/2)%R; auto with real. apply Rle_trans with (Rabs y);[idtac|right; field; auto with real]. case (Zle_lt_or_eq (-(dExp bo)) (Fexp b)). assert (Fbounded bo b); try apply FcanonicBound with radix; auto with zarith float. intros LL; elim Evenradix; intros n Hn. apply Rle_trans with (FtoRradix (Float n ((Fexp b)-1))). right; unfold FtoRradix, FtoR; simpl. unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl. ring_simplify (radix*1)%R; rewrite Hn; rewrite mult_IZR; simpl; field; auto with real zarith. unfold FtoRradix; apply RoundAbsMonotonel with bo p (Closest bo radix) (a+b+e)%R; auto with real zarith. apply ClosestRoundedModeP with p; auto with zarith. split; simpl; auto with zarith. rewrite pGivesBound; apply Zlt_trans with (Zpower_nat radix 1); auto with zarith. unfold Zpower_nat; simpl; rewrite Zabs_eq; auto with zarith. replace (a+b+e)%R with ((a+b)-(-e))%R;[idtac|ring]. apply Rle_trans with (Rabs (a+b)-Rabs (-e))%R;[idtac|apply Rabs_triang_inv]. apply Rle_trans with (powerRZ radix (Fexp b)-/2*(powerRZ radix (Fexp b)))%R. right; unfold FtoRradix, FtoR; simpl. unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl. ring_simplify (radix*1)%R; rewrite Hn; repeat rewrite mult_IZR; simpl; field; auto with real zarith. unfold Rminus; apply Rplus_le_compat; auto with real. apply Ropp_le_contravar; rewrite Rabs_Ropp. apply Rle_trans with (1:=eLeb); right. unfold Fulp; rewrite FcanonicFnormalizeEq; auto with zarith real. intros LL; rewrite <- LL. unfold FtoRradix; rewrite <- Fabs_correct; auto. unfold FtoR, Fabs; simpl. apply Rmult_le_compat; auto with real zarith. apply Rle_trans with (IZR 1). simpl; apply Rle_trans with (/1)%R; auto with real zarith. apply Rle_IZR. generalize L; unfold FtoRradix, FtoR; case (Fnum y); intros; auto with real zarith. Contradict L0; simpl; ring. apply Rle_powerRZ; auto with real zarith. assert (Fbounded bo y); try apply FcanonicBound with radix; auto with zarith float. Qed. Lemma xLe2y_aux2 : (3 <= p) -> (Rabs b <= Rabs a)%R -> (Rabs x <= 2*Rabs y)%R. intros MM; intros. assert ((a+b=0)%R \/ (powerRZ radix (Fexp b) = Rabs (a+b))%R \/ (2*powerRZ radix (Fexp b) <= Rabs (a+b))%R). unfold FtoRradix; rewrite <- Fplus_correct; auto. rewrite <- Fabs_correct; auto. unfold FtoR. replace (Fexp (Fabs (Fplus radix a b))) with (Fexp (Fplus radix a b)); auto with zarith. replace (Fexp (Fplus radix a b)) with (Fexp b). case (Zle_lt_or_eq 0 (Zabs (Fnum (Fplus radix a b)))); auto with zarith. intros; case (Zle_lt_or_eq 1 (Zabs (Fnum (Fplus radix a b)))); auto with zarith. right; right. apply Rmult_le_compat_r; auto with real zarith. replace 2%R with (IZR 2); auto with zarith real. apply Rle_IZR; generalize H1; unfold Fabs; simpl; auto with zarith. intros; right; left. generalize H1; unfold Fabs; simpl; auto with zarith real. intros H2; rewrite <- H2; simpl; ring. left; replace (Fnum (Fplus radix a b)) with 0%Z;[simpl; ring|auto with zarith]. case (Z_eq_dec 0 (Fnum (Fplus radix a b))); auto with zarith; intros. assert (0 < Zabs (Fnum (Fplus radix a b)))%Z; auto with zarith. apply Zlt_le_trans with (Zabs_nat (Fnum (Fplus radix a b))); auto with zarith. assert (0 < Zabs_nat (Fnum (Fplus radix a b)))%nat; auto with zarith. apply absolu_lt_nz; auto. rewrite Zabs_absolu; auto with zarith. apply sym_eq; unfold Fplus; simpl; apply Zmin_le2. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. case H0;intros H1;[idtac|case H1; clear H1; intros H1]; clear H0. replace (FtoRradix x) with 0%R. rewrite Rabs_R0; apply Rmult_le_pos; auto with real. apply trans_eq with (FtoRradix (Float 0 (-(dExp bo)))); [unfold FtoRradix, FtoR; simpl; ring|idtac]. apply RoundedModeProjectorIdemEq with (P:=(Closest bo radix)) (3:=pGivesBound); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. split; simpl; auto with zarith. replace (FtoR radix (Float 0 (- dExp bo))) with (a+b)%R; auto. rewrite H1; unfold FtoR; simpl; ring. apply xLe2y_aux1; auto. generalize UnMoinsPos; intros U1. apply Rle_trans with ((Rabs (a+b))/Unmoins)%R. apply ClosestRoundeLeNormalSub; auto. exists (Fplus radix a b); split. rewrite Fplus_correct; auto with zarith. unfold Fplus; simpl; apply Zmin_Zle. assert (Fbounded bo a); try apply FcanonicBound with radix; auto with zarith float. assert (Fbounded bo b); try apply FcanonicBound with radix; auto with zarith float. apply Rmult_le_reg_l with Unmoins; auto with real. apply Rle_trans with (Rabs (a+b));[right; field; auto with real|idtac]. apply Rle_trans with (Rabs (a + b + e) * 4 / 3)%R. apply abeLeab; auto. assert (0 <3)%R; [apply Rlt_trans with 2%R; auto with real|idtac]. assert (0 <4)%R; [apply Rlt_trans with 3%R; auto with real|idtac]. apply Rlt_le_trans with (3+1)%R; auto with real; right; ring. apply Rmult_le_reg_l with (3/4)%R; [unfold Rdiv; apply Rmult_lt_0_compat; auto with real|idtac]. apply Rle_trans with (Rabs (a+b+e));[right; field; auto with real|idtac]. apply Rle_trans with ((Rabs y)*Unplus)%R. apply ClosestRoundeGeNormalSub; auto. exists (Fplus radix (Fplus radix a b) e); split. repeat rewrite Fplus_correct; auto with zarith real. unfold Fplus; simpl; repeat apply Zmin_Zle. assert (Fbounded bo a); try apply FcanonicBound with radix; auto with zarith float. assert (Fbounded bo b); try apply FcanonicBound with radix; auto with zarith float. elim Fe; auto. apply Rle_trans with (Rabs y *(3/4*2*Unmoins))%R;[idtac|right; ring]. apply Rmult_le_compat_l; auto with real. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (3*Unmoins)%R;[idtac|right; field; auto with real]. unfold Unplus, Unmoins. apply Rplus_le_reg_l with (-2+3* (powerRZ radix (Zsucc (- p)) / 2))%R. ring_simplify. apply Rle_trans with (powerRZ radix 0);[idtac|simpl; auto with real]. apply Rle_trans with (powerRZ radix (3-p)); [idtac|apply Rle_powerRZ; auto with zarith real]. apply Rle_trans with ((5/2)*(powerRZ radix (Zsucc (-p))))%R;[right; field; auto with real|idtac]. apply Rle_trans with ((radix*radix)*(powerRZ radix (Zsucc (- p))))%R. apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with 4%R; auto with real zarith. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (IZR 5);[simpl; right; field; auto with real|idtac]. apply Rle_trans with (IZR 8); [auto with real zarith|simpl; right; ring]. apply Rmult_le_compat; auto with real zarith; replace 2%R with (IZR 2); auto with real zarith. unfold Zsucc, Zminus; repeat rewrite powerRZ_add; auto with real zarith. simpl; right; ring. Qed. Lemma yLe2x_aux : (3 <= p) -> (Rabs b <= Rabs a)%R -> ~(FtoRradix x=0)%R -> (Rabs y <= 2*Rabs x)%R. intros MM; intros. assert ((a+b=0)%R \/ (powerRZ radix (Fexp b) <= Rabs (a+b))%R). unfold FtoRradix; rewrite <- Fplus_correct; auto. rewrite <- Fabs_correct; auto. unfold FtoR. replace (Fexp (Fabs (Fplus radix a b))) with (Fexp (Fplus radix a b)); auto with zarith. replace (Fexp (Fplus radix a b)) with (Fexp b). case (Zle_lt_or_eq 0 (Zabs (Fnum (Fplus radix a b)))); auto with zarith. intros; right. apply Rle_trans with (1%Z*(powerRZ radix (Fexp b)))%R;[right; simpl; ring|idtac]. apply Rmult_le_compat_r; auto with real zarith. intros; left; replace (Fnum (Fplus radix a b)) with 0%Z;[simpl; ring|auto with zarith]. case (Z_eq_dec 0 (Fnum (Fplus radix a b))); auto with zarith; intros. assert (0 < Zabs (Fnum (Fplus radix a b)))%Z; auto with zarith. apply Zlt_le_trans with (Zabs_nat (Fnum (Fplus radix a b))); auto with zarith. assert (0 < Zabs_nat (Fnum (Fplus radix a b)))%nat; auto with zarith. apply absolu_lt_nz; auto. rewrite Zabs_absolu; auto with zarith. apply sym_eq; unfold Fplus; simpl; apply Zmin_le2. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. case H1;intros H2; clear H1. absurd (FtoRradix x=0)%R; auto with real. apply sym_eq; apply trans_eq with (FtoRradix (Float 0 (-(dExp bo)))); [unfold FtoRradix, FtoR; simpl; ring|idtac]. apply RoundedModeProjectorIdemEq with (P:=(Closest bo radix)) (3:=pGivesBound); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. split; simpl; auto with zarith. replace (FtoR radix (Float 0 (- dExp bo))) with (a+b)%R; auto. rewrite H2; unfold FtoR; simpl; ring. generalize UnMoinsPos; intros U1. apply Rle_trans with ((Rabs (a+b+e))/Unmoins)%R. apply ClosestRoundeLeNormalSub; auto. exists (Fplus radix (Fplus radix a b) e); split. repeat rewrite Fplus_correct; auto with zarith real. unfold Fplus; simpl; repeat apply Zmin_Zle. assert (Fbounded bo a); try apply FcanonicBound with radix; auto with zarith float. assert (Fbounded bo b); try apply FcanonicBound with radix; auto with zarith float. elim Fe; auto. apply Rmult_le_reg_l with Unmoins; auto with real. apply Rle_trans with (Rabs (a+b+e));[right; field; auto with real|idtac]. apply Rle_trans with (Rabs (a + b) * 3 / 2)%R. apply Rle_trans with (Rabs (a+b)+Rabs e)%R;[apply Rabs_triang|idtac]. apply Rle_trans with (Rabs (a + b) + Rabs (a + b) /2)%R; [apply Rplus_le_compat_l|right; field; auto with real]. apply Rle_trans with (1:=eLeb); unfold Rdiv; rewrite Rmult_comm. apply Rmult_le_compat_r; auto with real. unfold Fulp; rewrite FcanonicFnormalizeEq; auto with zarith real. assert (0 <3)%R; [apply Rlt_trans with 2%R; auto with real|idtac]. apply Rmult_le_reg_l with (2/3)%R; [unfold Rdiv; apply Rmult_lt_0_compat; auto with real|idtac]. apply Rle_trans with (Rabs (a+b));[right; field; apply prod_neq_R0; auto with real|idtac]. apply Rle_trans with ((Rabs x)*Unplus)%R. apply ClosestRoundeGeNormalSub; auto. exists (Fplus radix a b); split. rewrite Fplus_correct; auto with zarith. unfold Fplus; simpl; apply Zmin_Zle. assert (Fbounded bo a); try apply FcanonicBound with radix; auto with zarith float. assert (Fbounded bo b); try apply FcanonicBound with radix; auto with zarith float. apply Rle_trans with (Rabs x *(2/3*2*Unmoins))%R;[idtac|right; ring]. apply Rmult_le_compat_l; auto with real. apply Rmult_le_reg_l with 3%R; auto with real. apply Rle_trans with (4*Unmoins)%R;[idtac|right; field; auto with real]. unfold Unplus, Unmoins. apply Rplus_le_reg_l with (-3+4* (powerRZ radix (Zsucc (- p)) / 2))%R. ring_simplify. apply Rle_trans with (powerRZ radix 0);[idtac|simpl; auto with real]. apply Rle_trans with (powerRZ radix (3-p)); [idtac|apply Rle_powerRZ; auto with zarith real]. apply Rle_trans with ((7/2)*(powerRZ radix (Zsucc (-p))))%R;[right; field; auto with real|idtac]. apply Rle_trans with ((radix*radix)*(powerRZ radix (Zsucc (- p))))%R. apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with 4%R; auto with real zarith. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (IZR 7);[simpl; right; field; auto with real|idtac]. apply Rle_trans with (IZR 8); [auto with real zarith|simpl; right; ring]. apply Rmult_le_compat; auto with real zarith; replace 2%R with (IZR 2); auto with real zarith. unfold Zsucc, Zminus; repeat rewrite powerRZ_add; auto with real zarith. simpl; right; ring. Qed. End GenericA. Section GenericB. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 3 <= p. Hypothesis Evenradix: (Even radix). Variable a b e x y:float. Hypothesis eLea: (Rabs e <= /2*Fulp bo radix p a)%R. Hypothesis eLeb: (Rabs e <= /2*Fulp bo radix p b)%R. Hypothesis xDef: Closest bo radix (a+b)%R x. Hypothesis yDef: Closest bo radix (a+b+e)%R y. Hypothesis Nx: Fcanonic radix bo x. Hypothesis Ny: Fcanonic radix bo y. Hypothesis Cb: Fcanonic radix bo b. Hypothesis Ca: Fcanonic radix bo a. Hypothesis Fe: Fbounded bo e. Lemma xLe2y : (Rabs x <= 2*Rabs y)%R. case (Rle_or_lt (Rabs b) (Rabs a)); intros. unfold FtoRradix; apply xLe2y_aux2 with bo p a b e; auto with zarith. unfold FtoRradix; apply xLe2y_aux2 with bo p b a e; auto with real; fold FtoRradix. rewrite Rplus_comm; auto. replace (b+a+e)%R with (a+b+e)%R; auto; ring. Qed. Lemma yLe2x: ~(FtoRradix x=0)%R -> (Rabs y <= 2*Rabs x)%R. case (Rle_or_lt (Rabs b) (Rabs a)); intros. unfold FtoRradix; apply yLe2x_aux with bo p a b e; auto with zarith. unfold FtoRradix; apply yLe2x_aux with bo p b a e; auto with real; fold FtoRradix. rewrite Rplus_comm; auto. replace (b+a+e)%R with (a+b+e)%R; auto; ring. Qed. Hypothesis dsd: ((0<= y)%R -> (0<= x)%R) /\ ((y <= 0)%R -> (x <= 0)%R). Lemma Subexact: ~(FtoRradix x=0)%R -> exists v:float, (FtoRradix v=x-y)%R /\ (Fbounded bo v) /\ (Fexp v=Zmin (Fexp x) (Fexp y))%Z. intros. case (Rle_or_lt 0 y); intros S. exists (Fminus radix x y); split. unfold FtoRradix; rewrite Fminus_correct; auto with real zarith. split;[idtac|simpl; auto with zarith]. apply Sterbenz; auto with zarith float; fold FtoRradix. apply FcanonicBound with radix; auto. apply FcanonicBound with radix; auto. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (FtoRradix y);[simpl; right; field; auto with real|idtac]. rewrite <- (Rabs_right y);[idtac|apply Rle_ge; auto]. rewrite <- (Rabs_right x). apply yLe2x; auto. elim dsd; intros I1 I2; apply Rle_ge; apply I1; auto. rewrite <- (Rabs_right y);[idtac|apply Rle_ge; auto]. rewrite <- (Rabs_right x). simpl; apply xLe2y; auto. elim dsd; intros I1 I2; apply Rle_ge; apply I1; auto. exists (Fopp (Fminus radix (Fopp x) (Fopp y))); split. unfold FtoRradix; rewrite Fopp_correct; rewrite Fminus_correct; auto with real zarith. rewrite Fopp_correct;rewrite Fopp_correct; ring. split;[idtac|simpl; auto with zarith]. apply oppBounded. apply Sterbenz; auto with zarith float; fold FtoRradix. apply oppBounded; apply FcanonicBound with radix; auto. apply oppBounded; apply FcanonicBound with radix; auto. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (FtoRradix (Fopp y));[simpl; right; field; auto with real|idtac]. unfold FtoRradix; repeat rewrite Fopp_correct; fold FtoRradix. rewrite <- (Rabs_left1 y); auto with real. rewrite <- (Rabs_left1 x). apply yLe2x; auto. elim dsd; intros I1 I2; apply I2; auto with real. unfold FtoRradix; repeat rewrite Fopp_correct; fold FtoRradix. rewrite <- (Rabs_left1 y); auto with real. rewrite <- (Rabs_left1 x). simpl; apply xLe2y; auto. elim dsd; intros I1 I2; apply I2; auto with real. Qed. End GenericB. Section GenericC. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 1 < p. Hypothesis Evenradix: (Even radix). 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 LSB_Pred: forall x y:float, (Rabs x < Rabs y)%R -> (LSB radix x <= LSB radix y)%Z -> (Rabs x <= Rabs y - powerRZ radix (LSB radix x))%R. intros. assert (exists nx:Z, (Rabs x=nx*powerRZ radix (LSB radix x))%R). unfold FtoRradix; rewrite <- Fabs_correct; auto. elim LSB_rep_min with radix (Fabs x); auto. intros nx H1; exists nx; rewrite H1. rewrite <- LSB_abs; auto. assert (exists ny:Z, (Rabs y=ny*powerRZ radix (LSB radix x))%R). unfold FtoRradix; rewrite <- Fabs_correct; auto. elim LSB_rep_min with radix (Fabs y); auto. intros ny1 H2; exists (ny1*Zpower_nat radix (Zabs_nat (LSB radix y - LSB radix x)))%Z; rewrite H2. rewrite <- LSB_abs; auto; rewrite mult_IZR; unfold FtoR; simpl; unfold FtoR; simpl. rewrite Zpower_nat_Z_powerRZ. rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with real zarith. replace (Zabs_nat (LSB radix y - LSB radix x)+LSB radix x)%Z with (LSB radix y); auto with real. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. apply Rplus_le_reg_l with (powerRZ radix (LSB radix x)-Rabs x)%R. ring_simplify. elim H1; intros nx H1'; elim H2; intros ny H2'; rewrite H1'; rewrite H2'. apply Rle_trans with ((IZR 1)*powerRZ radix (LSB radix x))%R;[simpl; right; ring|idtac]. apply Rle_trans with ((ny-nx)*powerRZ radix (LSB radix x))%R;[idtac|simpl; right; ring]. apply Rmult_le_compat_r; auto with real zarith. assert (ny-nx=(ny-nx)%Z)%R. unfold Zminus; rewrite plus_IZR; rewrite Ropp_Ropp_IZR; auto with real zarith. rewrite H3; assert (1 <= ny - nx)%Z; auto with real zarith. assert (0 < ny - nx)%Z; auto with real zarith. apply Zlt_Rlt; rewrite <- H3; simpl. apply Rplus_lt_reg_r with nx. ring_simplify. apply Rmult_lt_reg_l with ( powerRZ radix (LSB radix x)); auto with real zarith. rewrite Rmult_comm; rewrite <- H1'; rewrite Rmult_comm; rewrite <- H2'; auto. Qed. Variables x1 x2 y f:float. Hypothesis x1Def: Closest bo radix (x1+x2)%R x1. Hypothesis fDef : Closest bo radix (x1+x2+y)%R f. Hypothesis yLe: (MSB radix y < LSB radix x2)%Z. Hypothesis Nx1: Fcanonic radix bo x1. Hypothesis x1Pos: (0 <= x1)%R. Hypothesis x2NonZero: ~(FtoRradix x2 =0)%R. Hypothesis x2Exp: (- dExp bo <= Fexp x2)%Z. Lemma Midpoint_aux_aux: (FtoRradix x1= f) \/ (exists v:float, (FtoRradix v=x2)%R /\ (Fexp x1 -2 <= Fexp v)%Z /\ (Fbounded bo v)). elim Evenradix; intros n Hn. assert (Hnn: (Zabs n < Zpos (vNum bo))%Z). rewrite pGivesBound; apply Zle_lt_trans with (Zpower_nat radix 1); auto with zarith. rewrite Zabs_eq; auto with zarith. unfold Zpower_nat; simpl; auto with zarith. case (Zle_lt_or_eq (-(dExp bo)) (Fexp x1)). elim x1Def; intros (T1,T2) T3; auto. intros P. case (Z_eq_dec (Fnum x1) (nNormMin radix p)); intros H1. case (Rle_or_lt 0 x2); intros G. assert (Rabs x2 <= powerRZ radix (Fexp x1)/2)%R. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (powerRZ radix (Fexp x1));[idtac|right; simpl; field; auto with real]. replace (FtoRradix x2) with ((x1+x2) -x1)%R;[idtac|ring]. apply Rle_trans with (Fulp bo radix p x1). unfold FtoRradix; apply ClosestUlp; auto with zarith. unfold Fulp; rewrite FcanonicFnormalizeEq; auto with zarith real; left; auto. case H; clear H; intros H. assert (Rabs (x2 + y) < powerRZ radix (Fexp x1) / 2)%R. apply Rle_lt_trans with (Rabs x2+Rabs y)%R;[apply Rabs_triang|idtac]. apply Rplus_lt_reg_r with (-Rabs y)%R. ring_simplify (- Rabs y + (Rabs x2 + Rabs y))%R. assert (powerRZ radix (Fexp x1) / 2 = Float n (Fexp x1 -1))%R. unfold FtoRradix, FtoR; simpl; unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl. repeat (rewrite Hn;rewrite mult_IZR); simpl; field; auto with real zarith. apply Rle_lt_trans with (Rabs (Float n (Fexp x1 - 1)) - powerRZ radix (LSB radix x2))%R. apply LSB_Pred; auto. rewrite (Rabs_right (Float n (Fexp x1 - 1))); auto with real. rewrite <- H0; auto. apply Rle_ge; unfold FtoRradix; apply LeFnumZERO; simpl; auto with real zarith. apply Zle_trans with (MSB radix x2). apply LSB_le_MSB; auto with zarith. Contradict x2NonZero. unfold FtoRradix; apply is_Fzero_rep1; auto. apply Zle_trans with (Fexp x1-1)%Z. 2: apply Zle_trans with (Fexp ((Float n (Fexp x1 - 1)))); auto with zarith. 2: apply Fexp_le_LSB. assert (MSB radix x2 < Fexp x1)%Z; auto with zarith. apply Zlt_powerRZ with radix; auto with real. apply Rle_lt_trans with (FtoR radix (Float (S 0) (MSB radix x2))); [right; unfold FtoR; simpl; ring|idtac]. apply Rle_lt_trans with (FtoR radix (Fabs x2)). apply MSB_le_abs; auto. Contradict x2NonZero. unfold FtoRradix; apply is_Fzero_rep1; auto. rewrite Fabs_correct; auto; fold FtoRradix. apply Rlt_le_trans with (1:=H). unfold Rdiv; apply Rle_trans with ( (powerRZ radix (Fexp x1)*1))%R; auto with real zarith. apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (/1)%R; auto with real. rewrite (Rabs_right (Float n (Fexp x1 - 1))); auto with real. 2: apply Rle_ge; unfold FtoRradix; apply LeFnumZERO; simpl; auto with real zarith. rewrite <- H0; unfold Rminus; rewrite Rplus_comm. apply Rplus_lt_compat_r; apply Ropp_lt_contravar. unfold FtoRradix; rewrite <- Fabs_correct; auto. apply Rlt_le_trans with (FtoR radix (Float (S 0) (Zsucc (MSB radix y))))%R. apply abs_lt_MSB; auto. unfold FtoR; simpl; ring_simplify (1 * powerRZ radix (Zsucc (MSB radix y)))%R. apply Rle_powerRZ; auto with real zarith. assert (powerRZ radix (Fexp x1 + p - 1) <= x1)%R. apply Rle_trans with (((nNormMin radix p))*(powerRZ radix (Fexp x1)))%R. unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. replace (Fexp x1 + p - 1)%Z with (Fexp x1 + pred p)%Z. rewrite powerRZ_add; auto with real zarith; right;ring. rewrite inj_pred; unfold Zpred; auto with zarith. unfold FtoRradix, FtoR; apply Rmult_le_compat_r; auto with real zarith. left; unfold FtoRradix. apply ImplyClosestStrict with bo p (x1+x2+y)%R (Fexp x1); auto with zarith. elim x1Def; auto. replace (x1+x2+y)%R with (x1+(x2+y))%R;[idtac|ring]. apply Rle_trans with ((powerRZ radix (Fexp x1 + p - 1) + 0))%R;[right; ring|idtac]. apply Rplus_le_compat; auto. apply Rplus_le_reg_l with (-y)%R. ring_simplify. apply Rle_trans with (Rabs (-y));[apply RRle_abs|rewrite Rabs_Ropp]. rewrite <- (Rabs_right x2); auto with real. case (Req_dec y 0); intros. rewrite H3; rewrite Rabs_R0; auto with real. case (Rle_or_lt (Rabs y) (Rabs x2)); auto. intros I; absurd (MSB radix y < LSB radix x2)%Z; auto. apply Zle_not_lt. apply Zle_trans with (MSB radix x2). apply LSB_le_MSB; auto with zarith. Contradict x2NonZero. unfold FtoRradix; apply is_Fzero_rep1; auto. apply MSB_monotone; auto with zarith real. Contradict x2NonZero. unfold FtoRradix; apply is_Fzero_rep1; auto. Contradict H3. unfold FtoRradix; apply is_Fzero_rep1; auto. repeat rewrite Fabs_correct; auto with real zarith. assert (Fbounded bo x1);[apply FcanonicBound with radix|idtac]; auto with zarith float. fold FtoRradix; replace (x1+x2+y-x1)%R with (x2+y)%R; auto with real; ring. right; exists (Float n (Fexp x1-1)); split. apply trans_eq with (Rabs x2);[rewrite H|idtac]. unfold FtoRradix, FtoR; simpl; unfold Zminus; rewrite powerRZ_add; auto with real zarith. simpl; ring_simplify (radix*1)%R; rewrite Hn; rewrite mult_IZR; simpl; field; auto with real zarith. rewrite Rabs_right; auto with real. split; simpl; auto with zarith. split; simpl; auto with zarith. assert (Rabs x2 <= powerRZ radix (Fexp x1-1)/2)%R. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (powerRZ radix (Fexp x1-1));[idtac|right; simpl; field; auto with real]. assert (FPred bo radix p x1 - (x1 + x2) = -(powerRZ radix (Fexp x1-1)-Rabs x2))%R. apply trans_eq with (-(Fminus radix x1 (FPred bo radix p x1) - Rabs x2))%R. rewrite (Rabs_left x2); auto with real. unfold FtoRradix; rewrite Fminus_correct; auto with zarith; ring. unfold FtoRradix; rewrite FPredDiff3; auto with zarith. unfold FtoR, Zpred,Zminus; simpl;ring. apply Rplus_le_reg_l with (-(Rabs x2))%R. ring_simplify (- Rabs x2 + 2 * Rabs x2)%R. apply Rle_trans with (Rabs ((FPred bo radix p x1)-(x1+x2)))%R. pattern (FtoRradix x2) at 1; replace (FtoRradix x2) with (-(x1-(x1+x2)))%R;[rewrite Rabs_Ropp|ring]. elim x1Def; intros Y1 Y2; unfold FtoRradix; apply Y2; auto. apply FBoundedPred; auto with zarith. rewrite H; rewrite Rabs_Ropp. rewrite Rabs_right. right; ring. apply Rle_ge; apply Rplus_le_reg_l with (Rabs x2). ring_simplify. case (Rle_or_lt (Rabs x2) (powerRZ radix (Fexp x1 - 1))); auto; intros. absurd (Rabs x2 <= Rabs (FPred bo radix p x1 - (x1 + x2)))%R. rewrite H; rewrite Rabs_Ropp; apply Rlt_not_le. rewrite Rabs_left; auto with real. apply Rplus_lt_reg_r with (-Rabs x2+powerRZ radix (Fexp x1-1))%R. ring_simplify; auto with real zarith. pattern (FtoRradix x2) at 1; replace (FtoRradix x2) with (-(x1-(x1+x2)))%R;[rewrite Rabs_Ropp|ring]. elim x1Def; intros Y1 Y2; unfold FtoRradix; apply Y2; auto. apply FBoundedPred; auto with zarith. case H; clear H; intros H. assert (Rabs (x2 + y) < powerRZ radix (Fexp x1-1) / 2)%R. apply Rle_lt_trans with (Rabs x2+Rabs y)%R;[apply Rabs_triang|idtac]. apply Rplus_lt_reg_r with (-Rabs y)%R. ring_simplify (- Rabs y + (Rabs x2 + Rabs y))%R. assert (powerRZ radix (Fexp x1-1) / 2 = Float n (Fexp x1 -2))%R. unfold FtoRradix, FtoR; simpl; unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith; simpl. repeat (rewrite Hn; rewrite mult_IZR);simpl; field; auto with real zarith. apply Rle_lt_trans with (Rabs (Float n (Fexp x1 - 2)) - powerRZ radix (LSB radix x2))%R. apply LSB_Pred; auto. rewrite (Rabs_right (Float n (Fexp x1 - 2))); auto with real. rewrite <- H0; auto. apply Rle_ge; unfold FtoRradix; apply LeFnumZERO; simpl; auto with real zarith. apply Zle_trans with (MSB radix x2). apply LSB_le_MSB; auto with zarith. Contradict x2NonZero. unfold FtoRradix; apply is_Fzero_rep1; auto. apply Zle_trans with (Fexp x1-2)%Z. 2: apply Zle_trans with (Fexp ((Float n (Fexp x1 - 2)))); auto with zarith. 2: apply Fexp_le_LSB. assert (MSB radix x2 < Fexp x1-1)%Z; auto with zarith. apply Zlt_powerRZ with radix; auto with real. apply Rle_lt_trans with (FtoR radix (Float (S 0) (MSB radix x2))); [right; unfold FtoR; simpl; ring|idtac]. apply Rle_lt_trans with (FtoR radix (Fabs x2)). apply MSB_le_abs; auto. Contradict x2NonZero. unfold FtoRradix; apply is_Fzero_rep1; auto. rewrite Fabs_correct; auto; fold FtoRradix. apply Rlt_le_trans with (1:=H). unfold Rdiv; apply Rle_trans with ( (powerRZ radix (Fexp x1-1)*1))%R; auto with real zarith. apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (/1)%R; auto with real. rewrite (Rabs_right (Float n (Fexp x1 - 2))); auto with real. 2: apply Rle_ge; unfold FtoRradix; apply LeFnumZERO; simpl; auto with real zarith. rewrite <- H0; unfold Rminus; rewrite Rplus_comm. apply Rplus_lt_compat_r; apply Ropp_lt_contravar. unfold FtoRradix; rewrite <- Fabs_correct; auto. apply Rlt_le_trans with (FtoR radix (Float (S 0) (Zsucc (MSB radix y))))%R. apply abs_lt_MSB; auto. unfold FtoR; simpl; ring_simplify (1 * powerRZ radix (Zsucc (MSB radix y)))%R. apply Rle_powerRZ; auto with real zarith. assert (powerRZ radix (Fexp x1 + p - 1) = x1)%R. unfold FtoRradix, FtoR; replace (Fexp x1+p-1)%Z with (Fexp x1+pred p)%Z. rewrite powerRZ_add; auto with real zarith. rewrite H1; unfold nNormMin; rewrite Zpower_nat_Z_powerRZ; auto with real zarith. rewrite inj_pred; auto with zarith; unfold Zpred; ring. left; unfold FtoRradix. apply ImplyClosestStrict with bo p (x1+x2+y)%R (Fexp x1-1)%Z; auto with zarith. elim x1Def; auto. replace (x1+x2+y)%R with (x1+(x2+y))%R;[idtac|ring]. apply Rle_trans with ((powerRZ radix (Fexp x1 + p - 1) + -((powerRZ radix (Fexp x1-1))/2)))%R. apply Rplus_le_reg_l with ((powerRZ radix (Fexp x1-1))/2)%R. ring_simplify. apply Rle_trans with (powerRZ radix (Fexp x1 - 1 + p - 1)+powerRZ radix (Fexp x1 - 1))%R. rewrite Rplus_comm; apply Rplus_le_compat_l. apply Rle_trans with (powerRZ radix (Fexp x1 - 1) *1)%R; [unfold Rdiv; apply Rmult_le_compat_l; auto with real zarith|right; ring]. apply Rle_trans with (/1)%R; auto with real. apply Rle_trans with (powerRZ radix ((Fexp x1 - 1 + p - 1)+1)). apply powerRZSumRle; auto with zarith. apply Rle_powerRZ; auto with real zarith. apply Rplus_le_compat; auto with real. apply Rle_trans with (-(-(x2+y)))%R;[apply Ropp_le_contravar|right; ring]. apply Rle_trans with (Rabs (-(x2+y)));[apply RRle_abs|rewrite Rabs_Ropp; auto with real]. fold FtoRradix; rewrite <- H2; apply Rle_powerRZ; auto with zarith real. fold FtoRradix; replace (x1+x2+y-x1)%R with (x2+y)%R; auto with real; ring. right; exists (Float (-n) (Fexp x1-2)); split;[idtac|split; simpl; auto with zarith]. apply trans_eq with (-(Rabs x2))%R;[rewrite H|idtac]. unfold FtoRradix, FtoR; simpl; unfold Zminus; rewrite powerRZ_add; auto with real zarith. rewrite powerRZ_add; auto with real zarith;rewrite Ropp_Ropp_IZR. simpl; ring_simplify (radix*1)%R; rewrite Hn; rewrite mult_IZR; simpl; field; auto with real. repeat apply prod_neq_R0; auto with real zarith. rewrite Rabs_left; auto with real. split; simpl. rewrite Zabs_Zopp; auto. assert (MSB radix x2 < Fexp x1-1)%Z; auto with zarith. apply Zlt_powerRZ with radix; auto with real. apply Rle_lt_trans with (FtoR radix (Float (S 0) (MSB radix x2))); [right; unfold FtoR; simpl; ring|idtac]. apply Rle_lt_trans with (FtoR radix (Fabs x2)). apply MSB_le_abs; auto. Contradict x2NonZero. unfold FtoRradix; apply is_Fzero_rep1; auto. rewrite Fabs_correct; auto; fold FtoRradix. rewrite H. unfold Rdiv; apply Rlt_le_trans with ( (powerRZ radix (Fexp x1-1)*1))%R; auto with real zarith. apply Rmult_lt_compat_l; auto with real zarith. apply Rlt_le_trans with (/1)%R; auto with real. apply Zle_trans with (1:=x2Exp). apply Zle_trans with (MSB radix x2); auto with zarith. apply Fexp_le_MSB; auto. Contradict x2NonZero. unfold FtoRradix; apply is_Fzero_rep1; auto. assert (Rabs x2 <= powerRZ radix (Fexp x1)/2)%R. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (powerRZ radix (Fexp x1));[idtac|right; simpl; field; auto with real]. replace (FtoRradix x2) with ((x1+x2) -x1)%R;[idtac|ring]. apply Rle_trans with (Fulp bo radix p x1). unfold FtoRradix; apply ClosestUlp; auto with zarith. unfold Fulp; rewrite FcanonicFnormalizeEq; auto with zarith real; left; auto. case H; clear H; intros H. assert (Rabs (x2 + y) < powerRZ radix (Fexp x1) / 2)%R. apply Rle_lt_trans with (Rabs x2+Rabs y)%R;[apply Rabs_triang|idtac]. apply Rplus_lt_reg_r with (-Rabs y)%R. ring_simplify (- Rabs y + (Rabs x2 + Rabs y))%R. assert (powerRZ radix (Fexp x1) / 2 = Float n (Fexp x1 -1))%R. unfold FtoRradix, FtoR; simpl; unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl. repeat (rewrite Hn; rewrite mult_IZR); simpl; field; auto with real zarith. apply Rle_lt_trans with (Rabs (Float n (Fexp x1 - 1)) - powerRZ radix (LSB radix x2))%R. apply LSB_Pred; auto. rewrite (Rabs_right (Float n (Fexp x1 - 1))); auto with real. rewrite <- H0; auto. apply Rle_ge; unfold FtoRradix; apply LeFnumZERO; simpl; auto with real zarith. apply Zle_trans with (MSB radix x2). apply LSB_le_MSB; auto with zarith. Contradict x2NonZero. unfold FtoRradix; apply is_Fzero_rep1; auto. apply Zle_trans with (Fexp x1-1)%Z. 2: apply Zle_trans with (Fexp ((Float n (Fexp x1 - 1)))); auto with zarith. 2: apply Fexp_le_LSB. assert (MSB radix x2 < Fexp x1)%Z; auto with zarith. apply Zlt_powerRZ with radix; auto with real. apply Rle_lt_trans with (FtoR radix (Float (S 0) (MSB radix x2))); [right; unfold FtoR; simpl; ring|idtac]. apply Rle_lt_trans with (FtoR radix (Fabs x2)). apply MSB_le_abs; auto. Contradict x2NonZero. unfold FtoRradix; apply is_Fzero_rep1; auto. rewrite Fabs_correct; auto; fold FtoRradix. apply Rlt_le_trans with (1:=H). unfold Rdiv; apply Rle_trans with ( (powerRZ radix (Fexp x1)*1))%R; auto with real zarith. apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (/1)%R; auto with real. rewrite (Rabs_right (Float n (Fexp x1 - 1))); auto with real. 2: apply Rle_ge; unfold FtoRradix; apply LeFnumZERO; simpl; auto with real zarith. rewrite <- H0; unfold Rminus; rewrite Rplus_comm. apply Rplus_lt_compat_r; apply Ropp_lt_contravar. unfold FtoRradix; rewrite <- Fabs_correct; auto. apply Rlt_le_trans with (FtoR radix (Float (S 0) (Zsucc (MSB radix y))))%R. apply abs_lt_MSB; auto. unfold FtoR; simpl; ring_simplify (1 * powerRZ radix (Zsucc (MSB radix y)))%R. apply Rle_powerRZ; auto with real zarith. assert (powerRZ radix (Fexp x1 + p - 1) +powerRZ radix (Fexp x1) <= x1)%R. apply Rle_trans with (((nNormMin radix p)+1)*(powerRZ radix (Fexp x1)))%R. unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. replace (Fexp x1 + p - 1)%Z with (Fexp x1 + pred p)%Z. rewrite powerRZ_add; auto with real zarith; right;ring. rewrite inj_pred; unfold Zpred; auto with zarith. unfold FtoRradix, FtoR; apply Rmult_le_compat_r; auto with real zarith. replace 1%R with (IZR 1); auto with zarith; rewrite <- plus_IZR. assert (nNormMin radix p + 1 <= Fnum x1)%Z; auto with real zarith. assert (nNormMin radix p <= Fnum x1)%Z; auto with real zarith. case Nx1; intros L; elim L; intros. apply Zmult_le_reg_r with radix; auto with zarith. rewrite Zmult_comm; rewrite <- PosNormMin with radix bo p; auto with zarith. apply Zle_trans with (1:=H3). rewrite Zabs_eq; auto with zarith. assert (0 <= Fnum x1)%Z; auto with zarith. apply LeR0Fnum with radix; auto with real zarith. elim H3; intros T1 T2; Contradict P; auto with zarith. left; unfold FtoRradix. apply ImplyClosestStrict with bo p (x1+x2+y)%R (Fexp x1); auto with zarith. elim x1Def; auto. replace (x1+x2+y)%R with (x1+(x2+y))%R;[idtac|ring]. apply Rle_trans with ((powerRZ radix (Fexp x1 + p - 1) + powerRZ radix (Fexp x1)) +-powerRZ radix (Fexp x1))%R;[right; ring|idtac]. apply Rplus_le_compat; auto. rewrite <- (Ropp_involutive (x2+y)); apply Ropp_le_contravar. apply Rle_trans with (Rabs (-(x2+y))); [apply RRle_abs|rewrite Rabs_Ropp]. apply Rle_trans with (powerRZ radix (Fexp x1) / 2)%R; auto with real. apply Rle_trans with (powerRZ radix (Fexp x1) *1)%R; auto with real. unfold Rdiv; apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (/1)%R; auto with real. fold FtoRradix; apply Rle_trans with (2:=H2); auto with real zarith. apply Rle_trans with (powerRZ radix (Fexp x1 + p - 1)+0)%R; auto with real zarith. fold FtoRradix; replace (x1+x2+y-x1)%R with (x2+y)%R; auto with real; ring. right. case (Rle_or_lt 0%R x2); intros. exists (Float n (Fexp x1-1)); split;[idtac|simpl; auto with zarith]. apply trans_eq with (Rabs x2);[rewrite H|idtac]. unfold FtoRradix, FtoR; simpl; unfold Zminus; rewrite powerRZ_add; auto with real zarith. simpl; ring_simplify (radix*1)%R; rewrite Hn; rewrite mult_IZR; simpl; field; auto with real zarith. rewrite Rabs_right; auto with real. repeat split; simpl; auto with zarith. exists (Float (-n) (Fexp x1-1)); split;[idtac|simpl; auto with zarith]. apply trans_eq with (-(Rabs x2))%R;[rewrite H|idtac]. unfold FtoRradix, FtoR; simpl; unfold Zminus; rewrite powerRZ_add; auto with real zarith. rewrite Ropp_Ropp_IZR; simpl; ring_simplify (radix*1)%R; rewrite Hn; rewrite mult_IZR; simpl; field; auto with real zarith. rewrite Rabs_left; auto with real. repeat split; simpl; auto with zarith. rewrite Zabs_Zopp; auto. intros MM. Contradict x2NonZero. cut (x1+x2=x1)%R;[intros K|idtac]. apply Rplus_eq_reg_l with (FtoRradix x1); rewrite K; auto with real. unfold FtoRradix; rewrite <- Fplus_correct; auto with zarith. apply sym_eq; apply Exact1 with bo p; auto. rewrite Fplus_correct; auto with zarith real. rewrite <- MM; unfold Fplus; simpl; apply Zmin_Zle; auto with zarith. Qed. End GenericC. Section GenericD. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 1 < p. Hypothesis Evenradix: (Even radix). Variables x1 x2 y f:float. Hypothesis x1Def: Closest bo radix (x1+x2)%R x1. Hypothesis fDef : Closest bo radix (x1+x2+y)%R f. Hypothesis yLe: (MSB radix y < LSB radix x2)%Z. Hypothesis Nx1: Fcanonic radix bo x1. Hypothesis x2NonZero: ~(FtoRradix x2 =0)%R. Hypothesis x2Exp: (- dExp bo <= Fexp x2)%Z. Lemma Midpoint_aux: (FtoRradix x1= f) \/ (exists v:float, (FtoRradix v=x2)%R /\ (Fexp x1 -2 <= Fexp v)%Z /\ Fbounded bo v). case (Rle_or_lt 0 x1); intros H. unfold FtoRradix; apply Midpoint_aux_aux with p y; auto. elim Midpoint_aux_aux with bo radix p (Fopp x1) (Fopp x2) (Fopp y) (Fopp f); auto. repeat rewrite Fopp_correct; fold FtoRradix; intros; left; auto with real. apply Rmult_eq_reg_l with (-1)%R; auto with real. apply trans_eq with (-x1)%R; [ring| apply trans_eq with (1:=H0);ring]. intros T; elim T; intros v T'; elim T'; intros H0 (H1,K); clear T T'. right; exists (Fopp v); split. unfold FtoRradix; rewrite Fopp_correct; rewrite H0; rewrite Fopp_correct; ring. split. simpl; apply Zle_trans with (2:=H1); simpl; auto with zarith. apply oppBounded; auto. replace (FtoR radix (Fopp x1) + FtoR radix (Fopp x2))%R with (-(x1+x2))%R. apply ClosestOpp; auto. repeat rewrite Fopp_correct; unfold FtoRradix; ring. replace (FtoR radix (Fopp x1) + FtoR radix (Fopp x2)+ FtoR radix (Fopp y))%R with (-(x1+x2+y))%R. apply ClosestOpp; auto. repeat rewrite Fopp_correct; unfold FtoRradix; ring. rewrite <- MSB_opp; rewrite <- LSB_opp; auto. apply FcanonicFopp; auto. rewrite Fopp_correct; auto with real. rewrite Fopp_correct; auto with real. Qed. End GenericD. Section Be2Zero. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 3 <= p. Hypothesis Evenradix: (Even radix). Theorem TwoSumProp: forall (a b x y:float), (Fbounded bo a) -> (Closest bo radix (a+b)%R x) -> (FtoRradix y=a+b-x)%R -> (Rabs y <= Rabs b)%R. intros. elim H0; fold FtoRradix; intros. rewrite <- (Rabs_Ropp y); rewrite <- (Rabs_Ropp b). replace (-y)%R with (x-(a+b))%R;[idtac|rewrite H1; ring]. replace (-b)%R with (a-(a+b))%R;[idtac|ring]. apply H3; auto. Qed. Variable a x y r1 u1 u2 al1 al2 be1 be2 gat ga :float. Hypothesis Fa : Fbounded bo a. Hypothesis Fx : Fbounded bo x. Hypothesis Fy : Fbounded bo y. Hypothesis Nbe1: Fcanonic radix bo be1. Hypothesis Nr1 : Fcanonic radix bo r1. Hypothesis Cal1: Fcanonic radix bo al1. Hypothesis Cu1 : Fcanonic radix bo u1. Hypothesis Fal2 : Fbounded bo al2. Hypothesis r1Def: (Closest bo radix (a*x+y)%R r1). Hypothesis u1Def: (Closest bo radix (a*x)%R u1). Hypothesis u2Def: (FtoRradix u2=a*x-u1)%R. Hypothesis al1Def:(Closest bo radix (y+u2)%R al1). Hypothesis al2Def:(FtoRradix al2=y+u2-al1)%R. Hypothesis be1Def:(Closest bo radix (u1+al1)%R be1). Hypothesis be2Def:(FtoRradix be2=u1+al1-be1)%R. Hypothesis gatDef:(Closest bo radix (be1-r1)%R gat). Hypothesis gaDef: (Closest bo radix (gat+be2)%R ga). Lemma gatCorrect: (~(FtoRradix r1=0))%R -> (~(FtoRradix be1=0))%R -> exists v:float, (FtoRradix v=be1-r1)%R /\ (Fbounded bo v) /\ (Fexp v=Zmin (Fexp be1) (Fexp r1))%Z. intros MM MN. unfold FtoRradix; apply Subexact with p u1 al1 al2; auto. apply Rle_trans with (Rabs u2). apply TwoSumProp with y al1; auto. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix p u1);[idtac|simpl; right; field; auto with real]. rewrite u2Def; unfold FtoRradix; apply ClosestUlp; auto with zarith. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix p al1);[idtac|simpl; right; field; auto with real]. fold FtoRradix; rewrite al2Def; unfold FtoRradix; apply ClosestUlp; auto with zarith. fold FtoRradix; replace (u1+al1+al2)%R with (a*x+y)%R; auto. rewrite al2Def; rewrite u2Def; ring. case (Rle_or_lt 0 (a*x+y))%R; intros I1. fold FtoRradix; split; intros I2. unfold FtoRradix; apply RleRoundedR0 with bo p (Closest bo radix) (u1+al1)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply Rplus_le_reg_l with (-u1)%R. ring_simplify. unfold FtoRradix; rewrite <- Fopp_correct. apply RleBoundRoundl with bo p (Closest bo radix) (y + u2)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply oppBounded; elim u1Def; auto. rewrite Fopp_correct; fold FtoRradix; apply Rplus_le_reg_l with (FtoRradix u1). ring_simplify (u1+-u1)%R; apply Rle_trans with (1:=I1). right; rewrite u2Def; ring. absurd (FtoRradix r1 =0)%R; auto. assert (I3: (0<= r1)%R); auto with real. unfold FtoRradix; apply RleRoundedR0 with bo p (Closest bo radix) (a*x+y)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; split; intros I2. absurd (FtoRradix r1 =0)%R; auto. assert (I3: (r1 <= 0)%R); auto with real. unfold FtoRradix; apply RleRoundedLessR0 with bo p (Closest bo radix) (a*x+y)%R; auto with zarith real. apply ClosestRoundedModeP with p; auto with zarith. unfold FtoRradix; apply RleRoundedLessR0 with bo p (Closest bo radix) (u1+al1)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply Rplus_le_reg_l with (-u1)%R. ring_simplify. unfold FtoRradix; rewrite <- Fopp_correct. apply RleBoundRoundr with bo p (Closest bo radix) (y + u2)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply oppBounded; elim u1Def; auto. rewrite Fopp_correct; fold FtoRradix; apply Rplus_le_reg_l with (FtoRradix u1). ring_simplify (u1+-u1)%R; apply Rle_trans with (a*x+y)%R; auto with real. right; rewrite u2Def; ring. Qed. Hypothesis Be2Zero: (FtoRradix be2=0)%R. Theorem FmaErr_aux1: (FtoRradix r1 <> 0)%R -> FtoRradix be1 <> 0%R -> (a*x+y=r1+ga+al2)%R. intros MM MN. generalize gatCorrect; intros H. replace (FtoRradix ga) with (FtoRradix gat). replace (FtoRradix gat) with (be1-r1)%R. rewrite al2Def; rewrite u2Def. apply trans_eq with (a * x + y-0)%R;[ring|rewrite <- Be2Zero]. rewrite be2Def; ring. elim H; auto; intros v H'; elim H'; intros H1 H''; elim H''; intros H2 H3; rewrite <- H1. unfold FtoRradix. apply RoundedModeProjectorIdemEq with (P:=(Closest bo radix)) (3:=pGivesBound); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; rewrite H1; auto. unfold FtoRradix. apply RoundedModeProjectorIdemEq with (P:=(Closest bo radix)) (3:=pGivesBound); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. elim gatDef; auto. fold FtoRradix; replace (FtoRradix gat) with (gat+be2)%R; auto with real. rewrite Be2Zero; ring. Qed. End Be2Zero. Section Be2NonZero. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 3 <= p. Hypothesis Evenradix: (Even radix). Variable P: R -> float -> Prop. Hypothesis P1: forall (r:R) (f:float), (P r f) -> (Closest bo radix r f). Hypothesis P2: forall (r1 r2:R) (f1 f2:float), (P r1 f1) -> (P r2 f2) -> (r1=r2)%R -> (FtoRradix f1=f2)%R. Variable a x y r1 u1 u2 al1 al2 be1 be2 gat ga :float. Hypothesis Fa : Fbounded bo a. Hypothesis Fx : Fbounded bo x. Hypothesis Fy : Fbounded bo y. Hypothesis Nbe1: Fcanonic radix bo be1. Hypothesis Nr1 : Fcanonic radix bo r1. Hypothesis Cal1: Fcanonic radix bo al1. Hypothesis Cu1 : Fcanonic radix bo u1. Hypothesis r1Def: (Closest bo radix (a*x+y)%R r1). Hypothesis u1Def: (Closest bo radix (a*x)%R u1). Hypothesis u2Def: (FtoRradix u2=a*x-u1)%R. Hypothesis al1Def:(Closest bo radix (y+u2)%R al1). Hypothesis al2Def:(FtoRradix al2=y+u2-al1)%R. Hypothesis be1Def:(Closest bo radix (u1+al1)%R be1). Hypothesis be2Def:(FtoRradix be2=u1+al1-be1)%R. Hypothesis gatDef:(Closest bo radix (be1-r1)%R gat). Hypothesis gaDef: (Closest bo radix (gat+be2)%R ga). Hypothesis be2Bounded: Fbounded bo be2. Hypothesis al2Bounded: Fbounded bo al2. Hypothesis r1DefE: (P (a*x+y)%R r1). Hypothesis be1DefE:(P (u1+al1)%R be1). Lemma Expr1 : (FtoRradix be1 <> 0)%R -> (Fexp r1 <= Fexp be1+1)%Z. intros MM. cut (Rabs r1 <= 2 * Rabs be1)%R; try intros L. case Nbe1; clear Nbe1; intros Nbe1. assert (radix*be1=(Float (Fnum be1) (Fexp be1+1)))%R. unfold FtoRradix, FtoR; simpl; rewrite powerRZ_add; auto with real zarith; simpl; ring. apply Zle_trans with (Fexp (Float (Fnum be1) (Fexp be1+1))); auto with zarith. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. elim Nbe1; intros J1 J2; elim J1; intros J3 J4. left; split;[split|idtac]; simpl; auto with zarith. fold FtoRradix; rewrite <- H. rewrite Rabs_mult; rewrite (Rabs_right radix). 2: apply Rle_ge; auto with real zarith. apply Rle_trans with (2*Rabs be1)%R; auto. apply Rmult_le_compat_r; auto with real. apply Rle_trans with (IZR 2); auto with real zarith. elim Nbe1; intros T1 (T2,T3); rewrite T2. apply Zle_trans with (Fexp (Float (nNormMin radix p) (-dExp bo+1))); auto with zarith. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. left; split;[split|idtac]; simpl; auto with zarith float. rewrite Zabs_eq; auto with zarith float. apply ZltNormMinVnum; auto with zarith. apply Zlt_le_weak; apply nNormPos; auto with zarith. rewrite <- PosNormMin with radix bo p; auto with zarith float. fold FtoRradix; apply Rle_trans with (1:=L). unfold FtoRradix;rewrite <- Fabs_correct; auto with zarith. apply Rle_trans with (2*FtoR radix (firstNormalPos radix bo p))%R. apply Rmult_le_compat_l; auto with real. left; apply FsubnormalLtFirstNormalPos; auto with zarith. apply FsubnormFabs; auto. rewrite Fabs_correct; auto with real zarith. rewrite Rabs_right. unfold firstNormalPos, FtoR; simpl. rewrite powerRZ_add; auto with real zarith. apply Rle_trans with (nNormMin radix p * (powerRZ radix (- dExp bo) * 2))%R;[right; ring|idtac]. repeat apply Rmult_le_compat_l; auto with real zarith. unfold nNormMin; auto with real zarith. simpl; ring_simplify; apply Rle_trans with (IZR 2); auto with real zarith. apply Rle_ge; apply LeFnumZERO; simpl; unfold nNormMin; auto with zarith float. unfold FtoRradix; apply yLe2x with bo p u1 al1 al2; auto with real. apply Rle_trans with (Rabs u2). unfold FtoRradix; apply TwoSumProp with bo y al1; auto. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix p u1);[idtac|simpl; right; field; auto with real]. rewrite u2Def; unfold FtoRradix; apply ClosestUlp; auto with zarith. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix p al1);[idtac|simpl; right; field; auto with real]. fold FtoRradix; rewrite al2Def; unfold FtoRradix; apply ClosestUlp; auto with zarith. fold FtoRradix; replace (u1+al1+al2)%R with (a*x+y)%R; auto. rewrite al2Def; rewrite u2Def; ring. Qed. Lemma Expbe1: (Fexp be1 <= Fexp r1+1)%Z. cut (Rabs be1 <= 2 * Rabs r1)%R; try intros L. case Nr1; clear Nr1; intros Nr1. assert (radix*r1=(Float (Fnum r1) (Fexp r1+1)))%R. unfold FtoRradix, FtoR; simpl; rewrite powerRZ_add; auto with real zarith; simpl; ring. apply Zle_trans with (Fexp (Float (Fnum r1) (Fexp r1+1))); auto with zarith. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. elim Nr1; intros J1 J2; elim J1; intros J3 J4. left; split;[split|idtac]; simpl; auto with zarith. fold FtoRradix; rewrite <- H. rewrite Rabs_mult; rewrite (Rabs_right radix). 2: apply Rle_ge; auto with real zarith. apply Rle_trans with (2*Rabs r1)%R; auto. apply Rmult_le_compat_r; auto with real. apply Rle_trans with (IZR 2); auto with real zarith. elim Nr1; intros T1 (T2,T3); rewrite T2. apply Zle_trans with (Fexp (Float (nNormMin radix p) (-dExp bo+1))); auto with zarith. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. left; split;[split|idtac]; simpl; auto with zarith float. rewrite Zabs_eq; auto with zarith float. apply ZltNormMinVnum; auto with zarith. apply Zlt_le_weak; apply nNormPos; auto with zarith. rewrite <- PosNormMin with radix bo p; auto with zarith float. fold FtoRradix; apply Rle_trans with (1:=L). unfold FtoRradix;rewrite <- Fabs_correct; auto with zarith. apply Rle_trans with (2*FtoR radix (firstNormalPos radix bo p))%R. apply Rmult_le_compat_l; auto with real. left; apply FsubnormalLtFirstNormalPos; auto with zarith. apply FsubnormFabs; auto. rewrite Fabs_correct; auto with real zarith. rewrite Rabs_right. unfold firstNormalPos, FtoR; simpl. rewrite powerRZ_add; auto with real zarith. apply Rle_trans with (nNormMin radix p * (powerRZ radix (- dExp bo) * 2))%R;[right; ring|idtac]. repeat apply Rmult_le_compat_l; auto with real zarith. unfold nNormMin; auto with real zarith. simpl; ring_simplify; apply Rle_trans with (IZR 2); auto with real zarith. apply Rle_ge; apply LeFnumZERO; simpl; unfold nNormMin; auto with zarith float. unfold FtoRradix; apply xLe2y with bo p u1 al1 al2; auto with real. apply Rle_trans with (Rabs u2). unfold FtoRradix; apply TwoSumProp with bo y al1; auto. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix p u1);[idtac|simpl; right; field; auto with real]. rewrite u2Def; unfold FtoRradix; apply ClosestUlp; auto with zarith. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix p al1);[idtac|simpl; right; field; auto with real]. fold FtoRradix; rewrite al2Def; unfold FtoRradix; apply ClosestUlp; auto with zarith. fold FtoRradix; replace (u1+al1+al2)%R with (a*x+y)%R; auto. rewrite al2Def; rewrite u2Def; ring. Qed. Theorem BoundedL: forall (r:R) (x0:float) (e:Z), (e <=Fexp x0)%Z -> (-dExp bo <= e)%Z -> (FtoRradix x0=r)%R -> (Rabs r < powerRZ radix (e+p))%R -> (exists x':float, (FtoRradix x'=r) /\ (Fbounded bo x') /\ Fexp x'=e). intros. exists (Float (Fnum x0*Zpower_nat radix (Zabs_nat (Fexp x0 -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 x0 - e) + e)%Z with (Fexp x0); 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 x0 - 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 x0))). 2: apply Rle_ge; auto with real zarith. apply Rle_trans with (Rabs (Fnum x0) * (powerRZ radix e *powerRZ radix (Fexp x0 - e)))%R;[right; ring|idtac]. rewrite <- powerRZ_add; auto with real zarith. ring_simplify (e+(Fexp x0-e))%Z; auto with real. Qed. Lemma Zmin_Zlt : forall z1 z2 z3 : Z, (z1 < z2)%Z -> (z1 < z3)%Z -> (z1 < Zmin z2 z3)%Z. intros; unfold Zmin. case (z2 ?= z3)%Z; auto. Qed. Hypothesis Be2NonZero: ~(FtoRradix be2=0)%R. Lemma be2MuchSmaller: ~(FtoRradix al2=0)%R -> ~(FtoRradix u2=0)%R -> (MSB radix al2 < LSB radix be2)%Z. intros. assert (FtoRradix be2 = (Fminus radix (Fplus radix u1 al1) be1))%R. rewrite be2Def; unfold FtoRradix; rewrite Fminus_correct; auto; rewrite Fplus_correct; auto; ring. rewrite LSB_comp with radix be2 (Fminus radix (Fplus radix u1 al1) be1); auto with zarith. 2: Contradict Be2NonZero. 2: unfold FtoRradix; apply is_Fzero_rep1; auto. apply Zlt_le_trans with (Zmin (LSB radix (Fplus radix u1 al1)) (LSB radix be1)). 2: apply LSBMinus; auto. 2: Contradict Be2NonZero. 2: rewrite H1; unfold FtoRradix; apply is_Fzero_rep1; auto. apply Zmin_Zlt. apply Zlt_le_trans with (Zmin (LSB radix u1 ) (LSB radix al1)). 2: apply LSBPlus; auto. apply Zmin_Zlt. apply Zle_lt_trans with (MSB radix u2). apply MSB_monotone; auto. Contradict H; unfold FtoRradix; apply is_Fzero_rep1; auto. Contradict H0; unfold FtoRradix; apply is_Fzero_rep1; auto. repeat rewrite Fabs_correct; auto. apply TwoSumProp with bo y al1; auto. rewrite MSB_comp with radix u2 (Fminus radix (Fmult a x) u1); auto with zarith. apply MSBroundLSB with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. rewrite Fmult_correct; auto with real. Contradict H0. apply trans_eq with (FtoRradix (Fminus radix (Fmult a x) u1)). rewrite u2Def; unfold FtoRradix; rewrite Fminus_correct; auto; rewrite Fmult_correct; auto; ring. unfold FtoRradix; apply is_Fzero_rep1; auto. Contradict H0; unfold FtoRradix; apply is_Fzero_rep1; auto. fold FtoRradix; rewrite u2Def; unfold FtoRradix; rewrite Fminus_correct; auto; rewrite Fmult_correct; auto; ring. rewrite MSB_comp with radix al2 (Fminus radix (Fplus radix y u2) al1); auto with zarith. apply MSBroundLSB with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. rewrite Fplus_correct; auto with real. Contradict H. apply trans_eq with (FtoRradix (Fminus radix (Fplus radix y u2) al1)). rewrite al2Def; unfold FtoRradix; rewrite Fminus_correct; auto; rewrite Fplus_correct; auto; ring. unfold FtoRradix; apply is_Fzero_rep1; auto. Contradict H; unfold FtoRradix; apply is_Fzero_rep1; auto. fold FtoRradix; rewrite al2Def; unfold FtoRradix; rewrite Fminus_correct; auto; rewrite Fplus_correct; auto; ring. cut (~(u1+al1=0)%R). intros I; Contradict I. unfold FtoRradix; rewrite <- Fplus_correct; auto; apply is_Fzero_rep1; auto. Contradict Be2NonZero. rewrite be2Def; rewrite Be2NonZero. assert (FtoRradix be1=0)%R; auto with real. rewrite <- FzeroisReallyZero with radix (-(dExp bo))%Z. unfold FtoRradix; apply sym_eq. apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply FboundedFzero. rewrite FzeroisReallyZero; rewrite <- Be2NonZero; auto. apply Zlt_powerRZ with radix; auto with real zarith. apply Rle_lt_trans with (FtoR radix (Float (S 0) (MSB radix al2))); [unfold FtoR; simpl; right; ring|idtac]. apply Rle_lt_trans with (FtoR radix (Fabs al2));[apply MSB_le_abs; auto with zarith|idtac]. Contradict H; unfold FtoRradix; apply is_Fzero_rep1; auto. rewrite Fabs_correct; auto; fold FtoRradix. apply Rlt_le_trans with (powerRZ radix (Fexp be1)). 2: apply Rle_powerRZ; auto with real zarith. 2: apply Fexp_le_LSB; auto. apply Rlt_le_trans with (powerRZ radix (Zmin (Fexp u1) (Fexp al1))). cut (Rabs al2 < powerRZ radix (Fexp u1))%R;[intros I1|idtac]. cut (Rabs al2 < powerRZ radix (Fexp al1))%R;[intros I2|idtac]. unfold Zmin; case (Fexp u1 ?= Fexp al1)%Z; auto with real zarith. rewrite al2Def; apply Rlt_le_trans with (Fulp bo radix p al1). unfold FtoRradix; apply RoundedModeUlp with (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. unfold Fulp; rewrite FcanonicFnormalizeEq; auto with zarith real; left; auto. apply Rle_lt_trans with (Rabs u2). unfold FtoRradix; apply TwoSumProp with bo y al1; auto. rewrite u2Def; apply Rlt_le_trans with (Fulp bo radix p u1). unfold FtoRradix; apply RoundedModeUlp with (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. unfold Fulp; rewrite FcanonicFnormalizeEq; auto with zarith real; left; auto. apply Rle_powerRZ; auto with real zarith. apply Zlt_le_weak. case (Zle_or_lt (Fexp be1) (Zmin (Fexp u1) (Fexp al1))); auto. intros; Contradict Be2NonZero. rewrite be2Def. assert (FtoRradix be1=u1+al1)%R; auto with real. unfold FtoRradix; apply plusExact1 with bo p; auto with zarith float. elim u1Def; auto. elim al1Def; auto. Qed. Lemma gaCorrect: (FtoRradix be1 <> 0)%R -> (FtoRradix r1 <> 0)%R -> exists v:float, (FtoRradix v=be1-r1+be2)%R /\ (Fbounded bo v). intros MM MN. elim gatCorrect with bo radix p a x y r1 u1 u2 al1 al2 be1; auto. intros v T; elim T; intros H1 T'; elim T'; intros H2 H3; clear T T'. case (Req_dec al2 0); intros Z1. exists be2; split; auto. cut (FtoRradix be1=r1)%R. intros T; rewrite T; ring. apply P2 with (u1+al1)%R (a*x+y)%R; auto. apply trans_eq with (u1+al1+al2)%R;[rewrite Z1; ring|rewrite al2Def; rewrite u2Def; ring]. case (Req_dec u2 0); intros Z2. Contradict Z1. rewrite al2Def; rewrite Z2. cut (FtoRradix y=al1);[intros I; rewrite I; ring|idtac]. apply RoundedModeProjectorIdemEq with (P:=(Closest bo radix)) (3:=pGivesBound); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. replace (FtoR radix y) with (y+u2)%R; auto with real. rewrite Z2; unfold FtoRradix; ring. elim Midpoint_aux with bo radix p be1 be2 al2 r1; auto with zarith. 3: fold FtoRradix; replace (be1+be2)%R with (u1+al1)%R; auto. 3: rewrite be2Def; ring. 3: fold FtoRradix; replace (be1+be2+al2)%R with (a*x+y)%R; auto. 3: rewrite al2Def; rewrite u2Def; rewrite be2Def; ring. 3: apply be2MuchSmaller; auto. fold FtoRradix; intros; exists be2; split; auto. rewrite H; ring. intros T'; elim T'; intros v' T; elim T; intros H (H0,K); clear T T'. elim BoundedL with (be1 - r1 + be2)%R (Fplus radix v v') (Zmax (-(dExp bo)) (Fexp be1 - 2))%Z. intros v'' T; elim T; intros H4 T'; elim T'; intros; clear T T'. exists v''; split; auto. case (Zle_or_lt (-(dExp bo)) (Fexp be1-2)); intros K'. rewrite Zmax_le2; auto. simpl; apply Zmin_Zle; auto. rewrite H3; apply Zmin_Zle; auto with zarith. generalize Expbe1; auto with zarith. rewrite Zmax_le1; auto with zarith. simpl; apply Zmin_Zle; auto with zarith float. apply ZmaxLe1. unfold FtoRradix; rewrite Fplus_correct; auto; rewrite H; rewrite H1; ring. apply Rlt_le_trans with (powerRZ radix ( (Fexp be1 - 2) + p))%R. replace (be1-r1+be2)%R with (((a*x+y)-r1)+-al2)%R. 2: rewrite al2Def; rewrite u2Def; rewrite be2Def; ring. apply Rle_lt_trans with (Rabs (a * x + y - r1) + Rabs(- al2))%R; [apply Rabs_triang|rewrite Rabs_Ropp]. apply Rle_lt_trans with ((powerRZ radix (Fexp be1+1))/2+(powerRZ radix (Fexp be1))/2)%R; [apply Rplus_le_compat|idtac]. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix p r1). unfold FtoRradix; apply ClosestUlp; auto with zarith. unfold Fulp; rewrite FcanonicFnormalizeEq; auto with zarith. apply Rle_trans with (powerRZ radix (Fexp be1 + 1)); [apply Rle_powerRZ; auto with real zarith|right; simpl; field; auto with real]. apply Expr1; auto. apply Rle_trans with (Rabs be2). assert (MSB radix al2 < LSB radix be2)%Z. apply be2MuchSmaller; auto. unfold FtoRradix; repeat rewrite <- Fabs_correct; auto. apply Rle_trans with (FtoR radix (Float (S 0) (Zsucc (MSB radix al2))))%R. apply Rlt_le; apply abs_lt_MSB; auto. apply Rle_trans with (FtoR radix (Float (S 0) (LSB radix be2))). unfold FtoR; simpl; apply Rmult_le_compat_l; auto with real. apply Rle_powerRZ; auto with real zarith. apply LSB_le_abs; auto. Contradict Be2NonZero; unfold FtoRradix; apply is_Fzero_rep1; auto. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix p be1). rewrite be2Def; unfold FtoRradix; apply ClosestUlp; auto with zarith. unfold Fulp; rewrite FcanonicFnormalizeEq; auto with zarith. right; simpl; field; auto with real. apply Rlt_le_trans with (powerRZ radix (Fexp be1 + 1)); [idtac|apply Rle_powerRZ; auto with real zarith]. apply Rlt_le_trans with (powerRZ radix (Fexp be1 + 1) / 2 + powerRZ radix (Fexp be1+1) / 2)%R; [apply Rplus_lt_compat_l|right; field; auto with real]. unfold Rdiv; apply Rmult_lt_compat_r; auto with real. apply Rlt_powerRZ; auto with real zarith. apply Rle_powerRZ; auto with real zarith. elim be2Bounded; auto. Qed. Theorem FmaErr_aux2: (FtoRradix be1 <> 0)%R -> (FtoRradix r1 <> 0)%R -> (a*x+y=r1+ga+al2)%R. intros MM MN. elim gatCorrect with bo radix p a x y r1 u1 u2 al1 al2 be1; auto. intros v1 T; elim T; intros H1 T'; elim T'; intros H2 H3; clear T T'. elim gaCorrect; auto; intros v2 T; elim T; intros H4 H5; clear T. replace (FtoRradix ga) with (FtoRradix v2). rewrite H4; rewrite be2Def; rewrite al2Def; rewrite u2Def; ring. unfold FtoRradix; apply RoundedModeProjectorIdemEq with (P:=(Closest bo radix)) (3:=pGivesBound); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. replace (FtoR radix v2) with (gat+be2)%R; auto. fold FtoRradix; rewrite H4; assert (FtoRradix gat=be1-r1)%R; auto with real. unfold FtoRradix; rewrite <- H1. apply sym_eq; apply RoundedModeProjectorIdemEq with (P:=(Closest bo radix)) (3:=pGivesBound); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. rewrite H1; auto with real. Qed. End Be2NonZero. Section Final. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 3 <= p. Hypothesis Evenradix: (Even radix). Variable P: R -> float -> Prop. Hypothesis P1: forall (r:R) (f:float), (P r f) -> (Closest bo radix r f). Hypothesis P2: forall (r1 r2:R) (f1 f2:float), (P r1 f1) -> (P r2 f2) -> (r1=r2)%R -> (FtoRradix f1=f2)%R. Variable a x y r1 u1 u2 al1 al2 be1 be2 gat ga :float. Hypothesis Fa : Fbounded bo a. Hypothesis Fx : Fbounded bo x. Hypothesis Fy : Fbounded bo y. Hypothesis Nbe1: Fcanonic radix bo be1. Hypothesis Nr1 : Fcanonic radix bo r1. Hypothesis Cal1: Fcanonic radix bo al1. Hypothesis Cu1 : Fcanonic radix bo u1. Hypothesis r1Def: (Closest bo radix (a*x+y)%R r1). Hypothesis u1Def: (Closest bo radix (a*x)%R u1). Hypothesis u2Def: (FtoRradix u2=a*x-u1)%R. Hypothesis al1Def:(Closest bo radix (y+u2)%R al1). Hypothesis al2Def:(FtoRradix al2=y+u2-al1)%R. Hypothesis be1Def:(Closest bo radix (u1+al1)%R be1). Hypothesis be2Def:(FtoRradix be2=u1+al1-be1)%R. Hypothesis gatDef:(Closest bo radix (be1-r1)%R gat). Hypothesis gaDef: (Closest bo radix (gat+be2)%R ga). Hypothesis be2Bounded: Fbounded bo be2. Hypothesis al2Bounded: Fbounded bo al2. Hypothesis r1DefE: (P (a*x+y)%R r1). Hypothesis be1DefE:(P (u1+al1)%R be1). Hypothesis be1NonZero: (FtoRradix be1 <> 0)%R. Hypothesis r1NonZero: (FtoRradix r1 <> 0)%R. Theorem FmaErr_aux: (a*x+y=r1+ga+al2)%R. case (Req_dec be2 0); intros. unfold FtoRradix; apply FmaErr_aux1 with bo p u1 u2 al1 be1 be2 gat; auto. unfold FtoRradix; apply FmaErr_aux2 with bo p P u1 u2 al1 be1 be2 gat; auto. Qed. End Final. Section Final2. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 3 <= p. Hypothesis Evenradix: (Even radix). Lemma LeExpRound:forall f g:float, Closest bo radix f g -> exists g':float, Fbounded bo g' /\ FtoRradix g'=g /\ (Fexp f <= Fexp g')%Z. intros. case (Zle_or_lt (Fexp f) (Fexp g)); intros. exists g; split; auto. elim H; auto. elim RoundedModeRep with bo radix p (Closest bo radix) f g; auto with zarith. 2: apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; intros n H1. exists (Float n (Fexp f)). elim H; intros H2 T; clear T. split; split; simpl; auto with zarith real . apply Zle_lt_trans with (Zabs (Fnum g)); auto with zarith float. apply Zle_Rle. apply Rmult_le_reg_l with (powerRZ radix (Fexp g)); auto with real zarith. apply Rle_trans with (Rabs g);[idtac| unfold FtoRradix; rewrite <- Fabs_correct; auto; unfold FtoR; simpl; right; ring]. rewrite H1; unfold FtoRradix; rewrite <- Fabs_correct; auto; unfold FtoR; simpl. rewrite Rmult_comm; apply Rmult_le_compat_l; auto with real zarith. apply Zle_trans with (Fexp g); auto with zarith float. Qed. Lemma LeExpRound2:forall (n:Z) (f g:float), Closest bo radix f g -> (n <= Fexp f)%Z -> exists g':float, Fbounded bo g' /\ FtoRradix g'=g /\ (n <= Fexp g')%Z. intros. elim LeExpRound with f g; auto. intros g' T; elim T; intros T1 T2; elim T2; intros T3 T4; clear T T2. exists g'; split; auto; split; auto with zarith. Qed. Variable P: R -> float -> Prop. Hypothesis P1: forall (r:R) (f:float), (P r f) -> (Closest bo radix r f). Hypothesis P2: forall (r1 r2:R) (f1 f2:float), (P r1 f1) -> (P r2 f2) -> (r1=r2)%R -> (FtoRradix f1=f2)%R. Variable a x y r1 u1 u2 al1 al2 be1 be2 gat ga :float. Hypothesis Fa : Fbounded bo a. Hypothesis Fx : Fbounded bo x. Hypothesis Fy : Fbounded bo y. Hypothesis Nbe1: Fcanonic radix bo be1. Hypothesis Nr1 : Fcanonic radix bo r1. Hypothesis Cal1: Fcanonic radix bo al1. Hypothesis Cu1 : Fcanonic radix bo u1. Hypothesis Exp5: (-dExp bo <= Fexp a+Fexp x)%Z. Hypothesis u1Def: (Closest bo radix (a*x)%R u1). Hypothesis u2Def: (FtoRradix u2=a*x-u1)%R. Hypothesis al1Def:(Closest bo radix (y+u2)%R al1). Hypothesis al2Def:(FtoRradix al2=y+u2-al1)%R. Hypothesis be2Def:(FtoRradix be2=u1+al1-be1)%R. Hypothesis gatDef:(Closest bo radix (be1-r1)%R gat). Hypothesis gaDef: (Closest bo radix (gat+be2)%R ga). Hypothesis r1DefE: (P (a*x+y)%R r1). Hypothesis be1DefE:(P (u1+al1)%R be1). Theorem FmaErr: (a*x+y=r1+ga+al2)%R. case (Req_dec be1 0); intros I3. assert (u1 + al1=0)%R. apply ClosestZero1 with bo radix p be1 (Fplus radix u1 al1); auto with zarith. unfold FtoRradix; rewrite Fplus_correct; auto. simpl; apply Zmin_Zle. elim u1Def; intros T1 T2; elim T1; auto. elim al1Def; intros T1 T2; elim T1; auto. assert (FtoRradix be2=0)%R. rewrite be2Def; rewrite I3; rewrite H; ring. assert (FtoRradix gat= (Fopp r1))%R. unfold FtoRradix; apply sym_eq; apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply oppBounded; auto. assert (T:(Closest bo radix (a*x+y)%R r1)); auto; elim T; auto. replace (FtoR radix (Fopp r1)) with (be1-r1)%R; auto. rewrite I3; rewrite Fopp_correct; fold FtoRradix; auto with real. assert (FtoRradix ga= gat)%R. unfold FtoRradix; apply sym_eq; apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. elim gatDef; auto. replace (FtoR radix gat) with (gat+be2)%R; auto. rewrite H0; auto with real. apply sym_eq; apply trans_eq with (FtoRradix al2). rewrite H2; rewrite H1; unfold FtoRradix; rewrite Fopp_correct; ring. rewrite al2Def; rewrite u2Def. apply trans_eq with (y+a*x-(u1+al1))%R;[idtac|rewrite H]; ring. case (Req_dec r1 0); intros I4. assert (a*x+y=0)%R. apply ClosestZero1 with bo radix p r1 (Fplus radix (Fmult a x) y); auto with zarith. unfold FtoRradix; rewrite Fplus_correct; auto; rewrite Fmult_correct; auto with real zarith. simpl; apply Zmin_Zle; auto with zarith. elim Fy; auto. rewrite H. assert (FtoRradix u1= (Fopp y))%R. unfold FtoRradix; apply sym_eq; apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply oppBounded; auto. replace (FtoR radix (Fopp y)) with (a*x)%R; auto. rewrite Fopp_correct; fold FtoRradix; auto with real. apply Rplus_eq_reg_l with y; rewrite Rplus_comm; rewrite H; ring. assert (FtoRradix u2=0)%R. rewrite u2Def; rewrite H0; unfold FtoRradix; rewrite Fopp_correct; fold FtoRradix. rewrite <- H; ring. assert (FtoRradix al1= y)%R. unfold FtoRradix; apply sym_eq; apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. replace (FtoR radix y) with (y+u2)%R; auto with real. rewrite H1; auto with real. assert (FtoRradix al2=0)%R. rewrite al2Def; rewrite H1; rewrite H2; ring. assert (FtoRradix be1=0)%R. apply ClosestZero2 with bo p (u1+al1)%R; auto with zarith. rewrite H2; rewrite H0; unfold FtoRradix; rewrite Fopp_correct; ring. assert (FtoRradix be2=0)%R. rewrite be2Def; rewrite H0; rewrite H2; rewrite H4; unfold FtoRradix; rewrite Fopp_correct; ring. assert (FtoRradix gat=0)%R. apply ClosestZero2 with bo p (be1-r1)%R; auto with zarith. rewrite H4; rewrite I4; ring. assert (FtoRradix ga=0)%R. apply ClosestZero2 with bo p (gat+be2)%R; auto with zarith. rewrite H6; rewrite H5; ring. rewrite I4; rewrite H7; rewrite H3; ring. elim errorBoundedPlus with bo radix p u1 al1 be1; auto with zarith. 2: elim u1Def; auto. 2: elim al1Def; auto. fold FtoRradix; intros be2' T; elim T; intros J1 T'; elim T'; intros J2 J3; clear T T'. elim errorBoundedMult with bo radix p (Closest bo radix) a x u1; auto with zarith. 2: apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; intros u2' (L1,(L2,L3)). elim errorBoundedPlus with bo radix p y u2' al1; auto with zarith. 2: fold FtoRradix; rewrite L1; rewrite <- u2Def; auto. fold FtoRradix; intros al2' T; elim T; intros B1 T'; elim T'; intros B2 B3; clear T T'. rewrite al2Def; rewrite u2Def; rewrite <- L1; rewrite <- B1. unfold FtoRradix; apply FmaErr_aux with bo p P u1 u2 al1 be1 be2' gat; auto. fold FtoRradix; rewrite B1; rewrite L1; rewrite u2Def; auto. fold FtoRradix; rewrite J1; rewrite <- be2Def; auto. Qed. Theorem Fma_FTS: (exists ga_e:float, exists al2_e:float, (FtoRradix ga_e=ga)%R /\ (FtoRradix al2_e=al2)%R /\ (Fbounded bo ga_e) /\ (Fbounded bo al2_e) /\ (Fexp al2_e <= Fexp ga_e)%Z). elim errorBoundedMult with bo radix p (Closest bo radix) a x u1; auto with zarith. 2:apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; intros u2' T; elim T; intros E1 T'; elim T'; intros E2 E3; clear T T'. elim errorBoundedPlus with bo radix p y u2' al1; auto with zarith. 2: fold FtoRradix; rewrite E1; rewrite <- u2Def; auto. rewrite E3; intros al2' T; elim T; intros F1 T'; elim T'; intros F2 F3; clear T T'. elim LeExpRound2 with (Zmin (Fexp y) (Fexp a+Fexp x)) (Fplus radix y u2') al1; auto. 2: unfold FtoRradix; rewrite Fplus_correct; auto; fold FtoRradix; rewrite E1; rewrite <- u2Def; auto. 2:simpl; rewrite E3; auto with zarith. intros al1' T; elim T; intros U1 T'; elim T'; intros U2 U3; clear T T'. elim LeExpRound2 with (Zmin (Fexp y) (Fexp a+Fexp x)) (Fmult a x) u1; auto with zarith. 2: unfold FtoRradix; rewrite Fmult_correct; auto. intros u1' T; elim T; intros U4 T'; elim T'; intros U5 U6; clear T T'. elim LeExpRound2 with (Zmin (Fexp y) (Fexp a+Fexp x)) (Fplus radix (Fmult a x) y) r1; auto with zarith. 2: unfold FtoRradix; rewrite Fplus_correct; auto; rewrite Fmult_correct; auto. 2: simpl; rewrite Zmin_sym; auto with zarith. intros r1' T; elim T; intros U7 T'; elim T'; intros U8 U9; clear T T'. elim LeExpRound2 with (Zmin (Fexp y) (Fexp a+Fexp x)) (Fplus radix u1' al1') be1; auto with zarith. 2: unfold FtoRradix; rewrite Fplus_correct; auto; fold FtoRradix; rewrite U5; rewrite U2; auto. 2: simpl; apply Zmin_Zle; auto with zarith. intros be1' T; elim T; intros V1 T'; elim T'; intros V2 V3; clear T T'. elim errorBoundedPlus with bo radix p u1' al1' be1; auto with zarith. 2: fold FtoRradix; rewrite U5; rewrite U2; auto. fold FtoRradix; intros be2' T; elim T; intros V4 T'; elim T'; intros V5 V6; clear T T'. elim LeExpRound2 with (Zmin (Fexp y) (Fexp a+Fexp x)) (Fminus radix be1' r1') gat; auto with zarith. 2: unfold FtoRradix; rewrite Fminus_correct; auto; fold FtoRradix; rewrite V2; rewrite U8; auto. 2: simpl; apply Zmin_Zle; auto with zarith. intros gat' T; elim T; intros V7 T'; elim T'; intros V8 V9; clear T T'. elim LeExpRound2 with (Zmin (Fexp y) (Fexp a+Fexp x)) (Fplus radix gat' be2') ga; auto with zarith. 2: unfold FtoRradix; rewrite Fplus_correct; auto; fold FtoRradix; rewrite V8; rewrite V4; rewrite U5; rewrite U2; rewrite <- be2Def; auto. 2: simpl; apply Zmin_Zle; auto with zarith. 2: rewrite V6; apply Zmin_Zle; auto with zarith. intros ga' T; elim T; intros W1 T'; elim T'; intros W2 W3; clear T T'. exists ga'; exists al2'; split; auto; split. unfold FtoRradix; rewrite F1; fold FtoRradix. rewrite E1; rewrite al2Def; rewrite u2Def; ring. split; auto; split; auto with zarith. Qed. End Final2. Section Final_Even. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 3 <= p. Hypothesis Evenradix: (Even radix). Variable a x y r1 u1 u2 al1 al2 be1 be2 gat ga :float. Hypothesis Fa : Fbounded bo a. Hypothesis Fx : Fbounded bo x. Hypothesis Fy : Fbounded bo y. Hypothesis Nbe1: Fcanonic radix bo be1. Hypothesis Nr1 : Fcanonic radix bo r1. Hypothesis Cal1: Fcanonic radix bo al1. Hypothesis Cu1 : Fcanonic radix bo u1. Hypothesis Exp5: (-dExp bo <= Fexp a+Fexp x)%Z. Hypothesis u1Def: (Closest bo radix (a*x)%R u1). Hypothesis u2Def: (FtoRradix u2=a*x-u1)%R. Hypothesis al1Def:(Closest bo radix (y+u2)%R al1). Hypothesis al2Def:(FtoRradix al2=y+u2-al1)%R. Hypothesis be2Def:(FtoRradix be2=u1+al1-be1)%R. Hypothesis gatDef:(Closest bo radix (be1-r1)%R gat). Hypothesis gaDef: (Closest bo radix (gat+be2)%R ga). Hypothesis r1DefE: (EvenClosest bo radix p (a*x+y)%R r1). Hypothesis be1DefE:(EvenClosest bo radix p (u1+al1)%R be1). Theorem FmaErr_Even: (a*x+y=r1+ga+al2)%R. unfold FtoRradix; apply FmaErr with bo p (EvenClosest bo radix p) u1 u2 al1 be1 be2 gat; auto. intros r f T; elim T; auto. intros; generalize EvenClosestUniqueP; unfold UniqueP; intros. apply H2 with bo p r2; auto with zarith real. rewrite <- H1; auto. Qed. Theorem Fma_FTS_Even: (exists ga_e:float, exists al2_e:float, (FtoRradix ga_e=ga)%R /\ (FtoRradix al2_e=al2)%R /\ (Fbounded bo ga_e) /\ (Fbounded bo al2_e) /\ (Fexp al2_e <= Fexp ga_e)%Z). unfold FtoRradix; apply Fma_FTS with p (EvenClosest bo radix p) a x y r1 u1 u2 al1 be1 be2 gat; auto. intros r f T; elim T; auto. Qed. End Final_Even. Float8.4/FnElem/FmaErrApprox.v0000644000423700002640000017770112032774527015772 0ustar sboldotoccataRequire Export AllFloat. Require Export Veltkamp. Require Export FmaErr. Section tBounded. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 3 <= p. Variables a x b ph pl uh z:float. Hypothesis Fb: Fbounded bo b. Hypothesis Fa: Fbounded bo a. Hypothesis Fx: Fbounded bo x. Hypothesis Cb: Fcanonic radix bo b. Hypothesis Nph: Fnormal radix bo ph. Hypothesis Nz: Fnormal radix bo z. Hypothesis Nuh: Fnormal radix bo uh. Hypothesis Exp1: (- dExp bo <= Fexp a+Fexp x)%Z. Hypothesis zDef : Closest bo radix (a*x+b)%R z. Hypothesis phDef: Closest bo radix (a*x)%R ph. Hypothesis plDef: (FtoRradix pl=a*x-ph)%R. Hypothesis uhDef: Closest bo radix (ph+b)%R uh. Hypothesis Posit: (0 <= a*x+b)%R. Lemma zPos: (0 <= z)%R. unfold FtoRradix; apply RleRoundedR0 with bo p (Closest bo radix) (a*x+b)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. Qed. Lemma uhPos: (0 <= uh)%R. unfold FtoRradix; apply RleRoundedR0 with bo p (Closest bo radix) (ph+b)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply Rplus_le_reg_l with (-b)%R. ring_simplify. unfold FtoRradix; rewrite <- Fopp_correct; auto. apply RleBoundRoundl with bo p (Closest bo radix) (a*x)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply oppBounded; auto. rewrite Fopp_correct; auto; fold FtoRradix; apply Rplus_le_reg_l with b. apply Rle_trans with 0%R; auto with real; rewrite Rplus_comm; auto. Qed. Theorem tBounded_aux: exists v:float, Fbounded bo v /\ (FtoRradix v=uh-z)%R. case (Req_dec (ph+b)%R 0);intros H1. exists (Fopp z); split. apply oppBounded; elim zDef; auto. unfold FtoRradix; rewrite Fopp_correct; replace (FtoR radix uh) with 0%R;[ring|idtac]. apply trans_eq with (FtoR radix (Fzero (-(dExp bo)))). rewrite FzeroisReallyZero; auto. apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply FboundedFzero. rewrite FzeroisReallyZero; rewrite <- H1; auto. case (Rle_or_lt (Rabs pl) (/4*Rabs (ph+b))); intros H2. exists (Fminus radix uh z). split;[idtac|unfold FtoRradix; apply Fminus_correct; auto]. apply Sterbenz; auto. elim uhDef; auto. elim zDef; auto. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (FtoR radix z);[right; simpl; field; auto with real|idtac]. rewrite <- (Rabs_right (FtoR radix z)). 2: apply Rle_ge; generalize zPos; auto with real. apply Rle_trans with (Rabs (a*x+b) / (1 - powerRZ radix (Zsucc (- p)) / 2))%R. apply ClosestRoundeLeNormal with bo; auto with zarith. assert (0 < 1 - powerRZ radix (Zsucc (- p)) / 2)%R. apply UnMoinsPos; auto with zarith. apply Rmult_le_reg_l with (1 - powerRZ radix (Zsucc (- p)) / 2)%R; auto with real. apply Rle_trans with (Rabs (a*x+b));[right; field; auto with real|idtac]. assert (0 < 2 - powerRZ radix (Zsucc (- p)))%R; auto with real. replace (2 - powerRZ radix (Zsucc (- p)))%R with (2*(1 - powerRZ radix (Zsucc (- p)) / 2))%R; auto with real. replace 0%R with (2*0)%R; auto with real. field; auto with real. replace (a*x+b)%R with ((ph+b)+pl)%R;[idtac|rewrite plDef; ring]. apply Rle_trans with (Rabs (ph+b)+Rabs pl)%R;[apply Rabs_triang|idtac]. apply Rle_trans with (Rabs (ph+b)+/ 4 * Rabs (ph + b))%R;auto with real. assert (0 < 4)%R;[apply Rmult_lt_0_compat; auto with real|idtac]. apply Rle_trans with (5/4*(Rabs (ph+b)))%R;[right; field; auto with real|idtac]. apply Rle_trans with (5/4*(Rabs (FtoR radix uh) * (1 + powerRZ radix (Zsucc (- p)) / 2)))%R. apply Rmult_le_compat_l. apply Rlt_le; unfold Rdiv;apply Rmult_lt_0_compat; auto with real. apply Rlt_trans with 4%R; auto with real. apply Rlt_le_trans with (4+1)%R; auto with real. apply ClosestRoundeGeNormal with bo; auto with zarith. fold FtoRradix; apply Rle_trans with ((5/4*(1 + powerRZ radix (Zsucc (- p)) / 2))*Rabs uh)%R; [right; ring|idtac]. rewrite <- Rmult_assoc with (r3:=uh). pattern (FtoRradix uh) at 2; rewrite <- (Rabs_right uh). 2: apply Rle_ge; generalize uhPos; auto with real. apply Rmult_le_compat_r; auto with real. apply Rmult_le_reg_l with 8%R; [apply Rmult_lt_0_compat; auto with real|idtac]. apply Rle_trans with (10+5*powerRZ radix (Zsucc (- p)))%R;[right; field; auto with real|idtac]. apply Rle_trans with (16-8*powerRZ radix (Zsucc (- p)))%R;[idtac|right; field; auto with real]. apply Rplus_le_reg_l with (-10+8* powerRZ radix (Zsucc (- p)))%R. ring_simplify. apply Rle_trans with (13* /4)%R. apply Rmult_le_compat_l; auto with real. apply Rle_trans with (12+1)%R; auto with real. apply Rle_trans with 12%R; auto with real. apply Rlt_le; apply Rmult_lt_0_compat; auto with real; apply Rmult_lt_0_compat; auto with real. apply Rlt_trans with 2%R; auto with real. apply Rle_trans with (powerRZ radix (Zsucc (- 3))); unfold Zsucc; auto with zarith real. apply Rle_powerRZ; auto with real zarith. simpl; ring_simplify (radix*1)%R; auto with real zarith. apply Rle_Rinv; auto with real. replace 2%R with (IZR 2); auto with real zarith. apply Rmult_le_reg_l with 4%R; auto with real. apply Rle_trans with 13%R;[right; field; auto with real|idtac]. replace 13%R with (IZR 13); auto with real zarith. apply Rle_trans with (IZR 24); auto with real zarith. simpl; right; ring. simpl; ring. simpl; fold FtoRradix. rewrite <- (Rabs_right z);[idtac|apply Rle_ge; generalize zPos; auto with real]. rewrite <- (Rabs_right uh);[idtac|apply Rle_ge; generalize uhPos; auto with real]. assert (0 < 1 - powerRZ radix (Zsucc (- p)) / 2)%R. apply UnMoinsPos; auto with zarith. assert (0 < 4)%R;[apply Rmult_lt_0_compat; auto with real|idtac]. assert (0 < 3)%R;[apply Rlt_trans with 2%R; auto with real|idtac]. apply Rle_trans with (Rabs (ph+b) / (1 - powerRZ radix (Zsucc (- p)) / 2))%R. unfold FtoRradix; apply ClosestRoundeLeNormal with bo; auto with zarith. apply Rmult_le_reg_l with (1 - powerRZ radix (Zsucc (- p)) / 2)%R; auto with real. apply Rle_trans with (Rabs (ph+b));[right; field; auto with real|idtac]. replace (2 - powerRZ radix (Zsucc (- p)))%R with (2* (1 - powerRZ radix (Zsucc (- p)) / 2))%R;[idtac|field]. apply prod_neq_R0; auto with real. apply Rle_trans with ((4/3)*(Rabs (a*x+b)))%R. apply Rmult_le_reg_l with (3/4)%R. unfold Rdiv; apply Rmult_lt_0_compat; auto with real. apply Rplus_le_reg_l with (/4*Rabs (ph + b))%R. apply Rle_trans with (Rabs (ph+b));[right; field; auto with real|idtac]. apply Rle_trans with (/4*Rabs (ph+b)+Rabs (a*x+b))%R;[idtac|right; field; auto with real]. pattern (ph+b)%R at 1; replace (ph+b)%R with (-(pl)+(a*x+b))%R;[idtac|rewrite plDef; ring]. apply Rle_trans with (Rabs (-pl)+Rabs (a*x+b))%R; [apply Rabs_triang|rewrite Rabs_Ropp; auto with real]. apply Rle_trans with (4/3*(Rabs z * (1 + powerRZ radix (Zsucc (- p)) / 2)))%R. apply Rmult_le_compat_l; auto with real. apply Rlt_le; unfold Rdiv; apply Rmult_lt_0_compat; auto with real. unfold FtoRradix; apply ClosestRoundeGeNormal with bo; auto with zarith. apply Rle_trans with ((4 / 3 * (1 + powerRZ radix (Zsucc (- p)) / 2))*(Rabs z))%R; [right; ring|idtac]. rewrite <- Rmult_assoc with (r3:=Rabs z). apply Rmult_le_compat_r; auto with real. apply Rmult_le_reg_l with 6%R; [apply Rmult_lt_0_compat; auto with real|idtac]. apply Rle_trans with (8+4*powerRZ radix (Zsucc (- p)))%R;[right; field; auto with real|idtac]. apply Rle_trans with (12-6*powerRZ radix (Zsucc (- p)))%R;[idtac|right; field; auto with real]. apply Rplus_le_reg_l with (-8+6* powerRZ radix (Zsucc (- p)))%R. ring_simplify. apply Rle_trans with (10* /4)%R. apply Rmult_le_compat_l; auto with real. apply Rlt_le; apply Rmult_lt_0_compat; auto with real. apply Rlt_le_trans with (4+1)%R; auto with real. apply Rle_trans with (powerRZ radix (Zsucc (- 3))); unfold Zsucc; auto with zarith real. apply Rle_powerRZ; auto with real zarith. simpl; ring_simplify (radix*1)%R; auto with real zarith. apply Rle_Rinv; auto with real. replace 2%R with (IZR 2); auto with real zarith. apply Rmult_le_reg_l with 4%R; auto with real. apply Rle_trans with 10%R;[right; field; auto with real|idtac]. replace 10%R with (IZR 10); auto with real zarith. apply Rle_trans with (IZR 16); auto with real zarith. simpl; right; ring. simpl; ring. assert (K:(Fexp a+Fexp x < Fexp ph)%Z). elim errorBoundedMult with bo radix p (Closest bo radix) a x ph; auto with zarith. 2: apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; intros pl' T; elim T; intros H3 T'; elim T'; intros H4 H5; clear T T'. rewrite <- H5. apply ClosestErrorExpStrict with bo radix p (a*x)%R; auto with zarith. elim phDef; auto. fold FtoRradix; Contradict H2. apply Rle_not_lt; rewrite plDef; rewrite <- H3; rewrite H2. rewrite Rabs_R0; apply Rle_trans with (/4*0)%R; auto with real. apply Rmult_le_compat_l; auto with real. assert (0 < 4)%R; auto with real; apply Rmult_lt_0_compat; auto with real. assert (K':(-dExp bo < Fexp ph)%Z); auto with zarith. assert (Rabs (ph+b) < 2* powerRZ radix (Fexp ph))%R. apply Rmult_lt_reg_l with (/4)%R; auto with real. assert (0 < 4)%R; auto with real; apply Rmult_lt_0_compat; auto with real. apply Rlt_le_trans with (1:=H2). apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix p ph). rewrite plDef; unfold FtoRradix; apply ClosestUlp; auto with zarith. rewrite CanonicFulp; auto with zarith. unfold FtoR; right; simpl; field; auto with real. left; auto. assert (Fexp ph -1 <= Fexp b)%Z. apply Zle_trans with (Fexp (Float (Zpos (vNum bo)-2*radix) (Fexp ph -1))); [simpl; auto with zarith|idtac]. assert (0 < Zpos (vNum bo)-2*radix )%Z. assert (2*radix < Zpos (vNum bo))%Z; auto with zarith. rewrite pGivesBound; apply Zle_lt_trans with (Zpower_nat radix 2); auto with zarith. unfold Zpower_nat; simpl ( nat_iter 2 (Z.mul radix) 1)%Z; auto with zarith. ring_simplify (radix*1)%Z; apply Zmult_le_compat_r; auto with zarith. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. left; split;[split|idtac]; auto with zarith. apply Zle_lt_trans with (Zabs (Zpos (vNum bo) - 2 * radix)); auto with zarith. rewrite Zabs_eq; auto with zarith. simpl; auto with zarith. apply Zle_trans with (Zabs (radix * (Zpos (vNum bo) - 2 * radix))); auto with zarith. rewrite Zabs_Zmult; repeat rewrite Zabs_eq; auto with zarith. apply Zle_trans with (2* (Zpos (vNum bo) - 2 * radix))%Z; auto with zarith. apply Zplus_le_reg_l with (4*radix)%Z. apply Zle_trans with (Zpos (vNum bo)+ Zpos (vNum bo))%Z; auto with zarith. assert (4*radix <= Zpos (vNum bo))%Z; auto with zarith. rewrite pGivesBound; apply Zle_trans with (Zpower_nat radix 3); auto with zarith. unfold Zpower_nat; simpl (nat_iter 3 (Z.mul radix) 1)%Z; auto with zarith. ring_simplify (radix*1)%Z; rewrite Zmult_assoc; apply Zmult_le_compat_r; auto with zarith. apply Zle_trans with (2*radix)%Z; auto with zarith. fold FtoRradix; apply Rplus_le_reg_l with (2*powerRZ radix (Fexp ph))%R. apply Rle_trans with (Rabs (ph + b)+Rabs b)%R; auto with real. apply Rle_trans with (Rabs ph). 2: pattern (FtoRradix ph) at 1; replace (FtoRradix ph) with ((ph+b)+-b)%R;[idtac|ring]. 2:apply Rle_trans with (Rabs (ph + b) + Rabs (-b))%R; [apply Rabs_triang| rewrite Rabs_Ropp; auto with real]. unfold FtoRradix; repeat rewrite <- Fabs_correct; auto. unfold FtoR, Fabs. simpl (Fexp (Float (Zpos (vNum bo) - 2 * radix) (Fexp ph - 1))). simpl (Fexp (Float (Zabs (Fnum (Float (Zpos (vNum bo) - 2 * radix) (Fexp ph - 1)))) (Fexp ph - 1))). replace (Fnum (Float (Zabs (Fnum (Float (Zpos (vNum bo) - 2 * radix) (Fexp ph - 1)))) (Fexp ph - 1))) with (Zabs (Zpos (vNum bo) - 2 * radix)); auto with zarith. simpl (Fnum (Float (Zabs (Fnum ph)) (Fexp ph))). simpl (Fexp (Float (Zabs (Fnum ph)) (Fexp ph))). apply Rle_trans with ((2+ ( Zabs (Zpos (vNum bo) - 2 * radix))/radix)*powerRZ radix (Fexp ph))%R. unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl; ring_simplify (radix*1)%R. right; field; auto with real zarith. apply Rmult_le_compat_r; auto with real zarith. apply Rmult_le_reg_l with radix; auto with real zarith. apply Rle_trans with (IZR (Zpos (vNum bo))). rewrite Zabs_eq; auto with zarith. unfold Zminus; rewrite plus_IZR; rewrite Ropp_Ropp_IZR; rewrite mult_IZR. right; simpl; field; auto with real zarith. elim Nph; intros. apply Rle_trans with (IZR (Zabs (radix * Fnum ph))); auto with real zarith. right; rewrite Zabs_Zmult; rewrite mult_IZR; rewrite Zabs_eq; auto with zarith real. assert (exists uh':float, (FtoRradix uh'=ph+b)%R /\ (Fbounded bo uh') /\ (Fexp uh'=Fexp ph-1)%Z). unfold FtoRradix; apply BoundedL with p (Fplus radix ph b); auto with zarith float. simpl; apply Zmin_Zle; auto with zarith. apply Fplus_correct; auto with zarith. fold FtoRradix; apply Rlt_le_trans with (1:=H). apply Rle_trans with (powerRZ radix (Fexp ph+1)); [rewrite powerRZ_add; auto with real zarith; simpl|apply Rle_powerRZ; auto with real zarith]. ring_simplify (radix*1)%R; rewrite Rmult_comm; apply Rmult_le_compat_l; auto with real zarith. replace 2%R with (IZR 2); auto with real zarith. elim H3; clear H3; intros uh' T; elim T; intros H5 T'; elim T'; intros H6 H7; clear T T'. assert (FtoRradix uh=uh'). unfold FtoRradix; apply sym_eq. apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; rewrite H5; auto. elim errorBoundedMult with bo radix p (Closest bo radix) a x ph; auto with zarith. 2: apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; intros pl' T; elim T; intros H8 T'; elim T'; intros H9 H10; clear T T'. elim LeExpRound2 with bo radix p (Fexp a+Fexp x)%Z (Fplus radix (Fplus radix ph pl') b) z; auto with zarith. 2: rewrite Fplus_correct; auto with zarith;rewrite Fplus_correct; auto with zarith. 2: fold FtoRradix; rewrite H8. 2: ring_simplify (ph + (a * x - ph) + b)%R; auto with real. 2: simpl; apply Zmin_Zle; auto with zarith. 2: apply Zmin_Zle; auto with zarith. fold FtoRradix; intros z' T; elim T; intros H15 T'; elim T'; intros H16 H17; clear T T'. cut ( exists v : float, (FtoRradix v = uh - z)%R /\ Fbounded bo v /\ (Fexp v=Fexp a+Fexp x)%Z). intros T; elim T; intros v T1; elim T1; intros T2 T3; elim T3; intros; exists v; split; auto. unfold FtoRradix; apply BoundedL with p (Fminus radix uh' z'); auto. simpl; apply Zmin_Zle; auto with zarith. rewrite Fminus_correct; auto with zarith; fold FtoRradix; rewrite <- H3; rewrite H16; auto with real. apply Rlt_le_trans with (powerRZ radix (Fexp ph)); [idtac|apply Rle_powerRZ; auto with real zarith]. fold FtoRradix; rewrite H3; rewrite H5. replace (ph+b-z)%R with ((a*x+b-z)+-pl)%R;[idtac|rewrite plDef; ring]. apply Rle_lt_trans with (Rabs (a*x+b-z)+Rabs (-pl))%R;[apply Rabs_triang|rewrite Rabs_Ropp]. apply Rmult_lt_reg_l with (INR 2); auto with real zarith. apply Rle_lt_trans with (S 1 * Rabs (a * x + b - z) + S 1*Rabs pl)%R;[right; ring|idtac]. apply Rlt_le_trans with (powerRZ radix (Fexp ph)+powerRZ radix (Fexp ph))%R; [idtac|simpl;right; ring]. cut (S 1 * Rabs (a * x + b - z) < powerRZ radix (Fexp ph))%R;[intros I1|idtac]. cut (S 1 * Rabs (pl) <= powerRZ radix (Fexp ph))%R;[intros I2; auto with real|idtac]. apply Rle_trans with (Fulp bo radix p ph). rewrite plDef; unfold FtoRradix; apply ClosestUlp; auto with zarith. rewrite CanonicFulp; auto with zarith real. right; unfold FtoR; simpl; ring. left; auto. apply Rle_lt_trans with (Fulp bo radix p z). unfold FtoRradix; apply ClosestUlp; auto with zarith. rewrite CanonicFulp; auto with zarith real. 2: left; auto. unfold FtoR; simpl; ring_simplify (1*powerRZ radix (Fexp z))%R. apply Rlt_powerRZ; auto with real zarith. apply Zle_lt_trans with (Fexp ph-1)%Z; auto with zarith. assert (Fbounded bo (Float (3*radix) (Fexp ph-1))). split; [idtac|simpl; auto with zarith]. apply Zle_lt_trans with (Zabs (3*radix)); auto with zarith. rewrite Zabs_Zmult; repeat rewrite Zabs_eq; auto with zarith. rewrite pGivesBound; apply Zlt_le_trans with (Zpower_nat radix 3); auto with zarith. unfold Zpower_nat; simpl (nat_iter 3 (Z.mul radix) 1)%Z. rewrite Zmult_comm; ring_simplify (radix*1)%Z; apply Zmult_lt_compat_l; auto with zarith. apply Zlt_le_trans with (2*2)%Z; auto with zarith. apply Zle_trans with (2*radix)%Z; auto with zarith. apply Zle_trans with (Fexp (Float (3*radix) (Fexp ph-1))); auto with zarith. apply Zle_trans with (Fexp (Fnormalize radix bo p (Float (3*radix) (Fexp ph-1)))). apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. left; auto. apply FnormalizeCanonic; auto with zarith. rewrite FnormalizeCorrect; auto. apply Rle_trans with (FtoR radix (Float (3 * radix) (Fexp ph - 1))); [idtac|rewrite <- Fabs_correct; auto; unfold FtoR]. 2: simpl; rewrite Zabs_eq; auto with zarith real. 2: apply Zle_trans with (3*radix)%Z; auto with zarith. apply RoundAbsMonotoner with bo p (Closest bo radix) (a*x+b)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. replace (a*x+b)%R with ((ph+b)+pl)%R;[idtac|rewrite plDef; ring]. apply Rle_trans with (Rabs (ph+b)+Rabs pl)%R;[apply Rabs_triang|idtac]. apply Rle_trans with (2 * powerRZ radix (Fexp ph)+/2*powerRZ radix (Fexp ph))%R; [apply Rplus_le_compat; auto with real|idtac]. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix p ph). rewrite plDef; unfold FtoRradix; apply ClosestUlp; auto with zarith. rewrite CanonicFulp; auto with zarith. unfold FtoR; right; simpl; field; auto with real. left; auto. apply Rle_trans with ((2+/2)*powerRZ radix (Fexp ph))%R;[right; ring|idtac]. apply Rle_trans with (3*powerRZ radix (Fexp ph))%R; [idtac|right; unfold FtoR; simpl; unfold Zminus; rewrite powerRZ_add; auto with real zarith]. 2: simpl; ring_simplify (radix*1)%R. 2: replace (IZR (match radix with | Z0 => 0%Z | Zpos y' => Zpos ((y' + xO y')) | Zneg y' => Zneg ((y' + xO y')) end)) with (3*radix)%R;[field; auto with real zarith|idtac]. 2: apply trans_eq with (IZR (3*radix)); auto with real zarith; rewrite mult_IZR; simpl; ring. apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (2+1)%R; auto with real. apply Rplus_le_compat_l; apply Rle_trans with (/1)%R; auto with real. apply FcanonicLeastExp with radix bo p; auto with zarith. rewrite FnormalizeCorrect; auto with real zarith. apply FnormalizeCanonic; auto with zarith. assert (0 < pPred (vNum bo))%Z. apply pPredMoreThanOne with radix p; auto with zarith. assert (Fbounded bo (Float (pPred (vNum bo)) (Fexp a+Fexp x+p))). split; simpl; auto with zarith. rewrite Zabs_eq;[unfold pPred|idtac]; auto with zarith. apply Zle_trans with (Fexp (Float (pPred (vNum bo)) (Fexp a+Fexp x+p))); auto with zarith. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. left; auto. left; split; auto. simpl; rewrite Zabs_Zmult; repeat rewrite Zabs_eq; auto with zarith. apply Zle_trans with (2* pPred (vNum bo))%Z; auto with zarith. unfold pPred, Zpred; apply Zplus_le_reg_l with 2%Z. apply Zle_trans with (Zpos (vNum bo) + Zpos (vNum bo))%Z; auto with zarith. assert (2 <= Zpos (vNum bo))%Z; auto with zarith. rewrite pGivesBound; apply Zle_trans with (Zpower_nat radix 1); auto with zarith. unfold Zpower_nat; simpl; auto with zarith. apply Rle_trans with (FtoR radix (Float (pPred (vNum bo)) (Fexp a + Fexp x + p))). 2: right; rewrite <- Fabs_correct; auto; unfold FtoR; simpl; rewrite Zabs_eq; auto with real zarith. apply RoundAbsMonotoner with bo p (Closest bo radix) (a*x)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. rewrite Rabs_mult; unfold FtoRradix; repeat rewrite <- Fabs_correct; auto. unfold FtoR; simpl; repeat rewrite powerRZ_add; auto with real zarith. apply Rle_trans with (Zabs (Fnum a) * (powerRZ radix (Fexp a) * powerRZ radix (Fexp x) * Zabs (Fnum x)))%R;[right; ring|idtac]. apply Rmult_le_compat; auto with real zarith. apply Rle_trans with (0*Zabs (Fnum x))%R; auto with real. apply Rmult_le_compat_r; auto with real zarith. apply Rlt_le; apply Rmult_lt_0_compat; auto with real zarith. elim Fa; intros; unfold pPred; auto with real zarith. apply Rmult_le_compat_l; auto with real zarith. apply Rlt_le; apply Rmult_lt_0_compat; auto with real zarith. apply Rle_trans with (IZR (Zpos (vNum bo))). elim Fx; intros; auto with real zarith. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; auto with real. Qed. End tBounded. Section tBounded2. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 3 <= p. Variables a x b ph pl uh z:float. Hypothesis Fb: Fbounded bo b. Hypothesis Fa: Fbounded bo a. Hypothesis Fx: Fbounded bo x. Hypothesis Cb: Fcanonic radix bo b. Hypothesis Nph: Fnormal radix bo ph \/ (FtoRradix ph=0). Hypothesis Nz: Fnormal radix bo z \/ (FtoRradix z =0). Hypothesis Nuh: Fnormal radix bo uh \/ (FtoRradix uh=0). Hypothesis Exp1: (- dExp bo <= Fexp a+Fexp x)%Z. Hypothesis zDef : Closest bo radix (a*x+b)%R z. Hypothesis phDef: Closest bo radix (a*x)%R ph. Hypothesis plDef: (FtoRradix pl=a*x-ph)%R. Hypothesis uhDef: Closest bo radix (ph+b)%R uh. Theorem tBounded: exists v:float, Fbounded bo v /\ (FtoRradix v=uh-z)%R. case Nuh; intros I1. case Nz; intros I2. case Nph; intros I3. case (Rle_or_lt 0 (a*x+b)); intros H. unfold FtoRradix; apply tBounded_aux with p a x b ph pl; auto. elim tBounded_aux with bo radix p (Fopp a) x (Fopp b) (Fopp ph) (Fopp pl) (Fopp uh) (Fopp z); auto with zarith float. fold FtoRradix; intros v T; elim T; intros; clear T. exists (Fopp v); split;[apply oppBounded; auto|idtac]. unfold FtoRradix; rewrite Fopp_correct; fold FtoRradix; rewrite H1; unfold FtoRradix; repeat rewrite Fopp_correct; ring. apply FnormalFop; auto. apply FnormalFop; auto. apply FnormalFop; auto. replace (FtoR radix (Fopp a) * FtoR radix x + FtoR radix (Fopp b))%R with (-(a*x+b))%R; [apply ClosestOpp; auto|repeat rewrite Fopp_correct; fold FtoRradix;ring]. replace (FtoR radix (Fopp a) * FtoR radix x )%R with (-(a*x))%R; [apply ClosestOpp; auto|unfold FtoRradix; repeat rewrite Fopp_correct; ring]. repeat rewrite Fopp_correct; fold FtoRradix; rewrite plDef; ring. replace (FtoR radix (Fopp ph) + FtoR radix (Fopp b) )%R with (-(ph+b))%R; [apply ClosestOpp; auto|unfold FtoRradix; repeat rewrite Fopp_correct; ring]. apply Rle_trans with (-(a*x+b))%R; auto with real. right; unfold FtoRradix; repeat rewrite Fopp_correct; ring. assert (a*x=0)%R. apply ClosestZero1 with bo radix p ph (Fmult a x); auto with zarith. rewrite Fmult_correct; fold FtoRradix; auto. exists (Fzero (-(dExp bo))); split. apply FboundedFzero; auto. unfold FtoRradix; rewrite FzeroisReallyZero; fold FtoRradix. replace (FtoRradix uh) with (FtoRradix b). replace (FtoRradix z) with (FtoRradix b);[ring|idtac]. unfold FtoRradix; apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. replace (FtoR radix b) with (a*x+b)%R; auto; rewrite H; auto with real. unfold FtoRradix; apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. replace (FtoR radix b) with (ph+b)%R; auto; rewrite I3; auto with real. exists uh; split. elim uhDef; auto. rewrite I2; simpl; ring. exists (Fopp z); split. apply oppBounded; elim zDef; auto. rewrite I1; unfold FtoRradix; rewrite Fopp_correct; fold FtoRradix;simpl ; ring. Qed. End tBounded2. Section uhExact. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 3 <= p. Variables a x b ph pl uh ul z t v w:float. Hypothesis Fb: Fbounded bo b. Hypothesis Fa: Fbounded bo a. Hypothesis Fx: Fbounded bo x. Hypothesis Cb: Fcanonic radix bo b. Hypothesis Nph: Fnormal radix bo ph \/ (FtoRradix ph=0). Hypothesis Nuh: Fnormal radix bo uh \/ (FtoRradix uh=0). Hypothesis Nz: Fnormal radix bo z \/ (FtoRradix z=0). Hypothesis Nw: Fnormal radix bo w \/ (FtoRradix w=0). Hypothesis Fpl: Fbounded bo pl. Hypothesis Exp1: (- dExp bo <= Fexp a+Fexp x)%Z. Hypothesis zDef : Closest bo radix (a*x+b)%R z. Hypothesis phDef: Closest bo radix (a*x)%R ph. Hypothesis plDef: (FtoRradix pl=a*x-ph)%R. Hypothesis uhDef: Closest bo radix (ph+b)%R uh. Hypothesis ulDef: (FtoRradix ul=ph+b-uh)%R. Hypothesis tDef : Closest bo radix (uh-z)%R t. Hypothesis vDef : Closest bo radix (pl+ul)%R v. Hypothesis wDef : Closest bo radix (t+v)%R w. Hypothesis Case1:(FtoRradix ul=0)%R. Theorem ErrFmaApprox_1_aux: Fnormal radix bo z -> Fnormal radix bo w -> (Rabs (z+w-(a*x+b)) <= (3*radix/2+/2)*powerRZ radix (2-2*p)*Rabs z)%R. intros M1 M2. apply Rle_trans with (3*powerRZ radix (2-2*p)*Rabs z)%R. assert (FtoRradix t=uh-z)%R. elim tBounded with bo radix p a x b ph pl uh z; auto. fold FtoRradix; intros t' T; elim T; intros T1 T2; clear T. rewrite <- T2; unfold FtoRradix; apply sym_eq. apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; rewrite T2; auto. assert (Rabs (z + w - (a * x + b)) <= (Fulp bo radix p w))%R. replace (z + w - (a * x + b))%R with (-((t+v)-w))%R. 2: rewrite H; replace (a*x)%R with (a*x-0)%R; auto with real; rewrite <- Case1. 2: rewrite ulDef; replace (FtoRradix v) with (FtoRradix pl). 2: rewrite plDef; ring. 2: unfold FtoRradix; apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. 2: apply ClosestRoundedModeP with p; auto with zarith. 2: replace (FtoR radix pl) with (pl+ul)%R; auto;fold FtoRradix; rewrite Case1; auto with real. rewrite Rabs_Ropp; apply Rlt_le; unfold FtoRradix. apply RoundedModeUlp with (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply Rle_trans with (1:=H0). apply Rle_trans with (Rabs (FtoR radix w) * powerRZ radix (Zsucc (- p)))%R. apply FulpLe2; auto with zarith. elim M2; auto. rewrite FcanonicFnormalizeEq; auto with zarith. left; auto. fold FtoRradix; apply Rle_trans with ((3*(powerRZ radix (Zsucc (-p))*Rabs z))* powerRZ radix (Zsucc (- p)))%R. 2: unfold Zsucc; replace (2-2*p)%Z with (1+1+-p+-p)%Z; auto with zarith. 2: repeat rewrite powerRZ_add; auto with real zarith; right; ring. apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (3*Fulp bo radix p z)%R. 2: apply Rmult_le_compat_l; auto with real zarith. 2: apply Rle_trans with (IZR 3); auto with real zarith; right; simpl; ring. 2: rewrite Rmult_comm; unfold FtoRradix; apply FulpLe2; auto with zarith. 2: elim M1; auto. 2: rewrite FcanonicFnormalizeEq; auto with zarith; left; auto. assert (0 < 1- powerRZ radix (Zsucc (- p)))%R. assert (powerRZ radix (Zsucc (- p)) < 1)%R; auto with real. apply Rlt_le_trans with (powerRZ radix (Zsucc (-1))); unfold Zsucc; auto with zarith real. apply Rmult_le_reg_l with (1- powerRZ radix (Zsucc (- p)))%R; auto with real. apply Rle_trans with (Fulp bo radix p z). apply Rplus_le_reg_l with (powerRZ radix (Zsucc (- p))*Rabs w)%R. apply Rle_trans with (Rabs w);[right; ring|idtac]. pattern (FtoRradix w) at 1; replace (FtoRradix w) with ((z+w-(a*x+b))+((a*x+b)-z))%R; [idtac|ring]. apply Rle_trans with (Rabs (z+w-(a*x+b))+Rabs (((a*x+b)-z)))%R; [apply Rabs_triang|idtac]. apply Rplus_le_compat. apply Rle_trans with (1:=H0). rewrite Rmult_comm; unfold FtoRradix; apply FulpLe2; auto with zarith. elim M2; auto. rewrite FcanonicFnormalizeEq; auto with zarith; left; auto. apply Rlt_le; unfold FtoRradix. apply RoundedModeUlp with (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply Rle_trans with (1*Fulp bo radix p z)%R; auto with real. unfold Fulp; rewrite <- Rmult_assoc; apply Rmult_le_compat_r; auto with real zarith. apply Rplus_le_reg_l with (-1+3*powerRZ radix (Zsucc (- p)))%R. apply Rle_trans with (3 * powerRZ radix (Zsucc (- p)))%R;[right; ring|idtac]. ring_simplify ( -1 + 3 * powerRZ radix (Zsucc (- p)) + (1 - powerRZ radix (Zsucc (- p))) * 3)%R. apply Rle_trans with (powerRZ radix 0); auto with real zarith. apply Rle_trans with (powerRZ radix (2+Zsucc (-p))); auto with real zarith. 2: unfold Zsucc; apply Rle_powerRZ; auto with real zarith. rewrite powerRZ_add; auto with real zarith; simpl. apply Rmult_le_compat_r; auto with real zarith. ring_simplify (radix*1)%R; apply Rle_trans with 4%R; auto with real zarith. apply Rle_trans with (3+1)%R; auto with real; right; ring. apply Rmult_le_compat; auto with real zarith; replace 2%R with (IZR 2); auto with real zarith. apply Rmult_le_compat_r; auto with real. apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (3 * radix / 2)%R; auto with real. apply Rmult_le_reg_l with (IZR 2); auto with real zarith. apply Rle_trans with (radix*3)%R;[apply Rmult_le_compat_r; auto with real zarith| right; simpl; field; auto with real]. apply Rle_trans with (2+1)%R; auto with real. apply Rle_trans with (3 * radix / 2+0)%R; auto with real. Qed. Theorem ErrFmaApprox_1: (Rabs (z+w-(a*x+b)) <= (3*radix/2+/2)*powerRZ radix (2-2*p)*Rabs z)%R. case Nz; intros I1. case Nw; intros I2. apply ErrFmaApprox_1_aux; auto. replace (z+w-(a*x+b))%R with 0%R. rewrite Rabs_R0; apply Rle_trans with (0*Rabs z)%R; [right; ring|apply Rmult_le_compat_r; auto with real]. apply Rlt_le; apply Rmult_lt_0_compat; auto with real zarith. apply Rle_lt_trans with (0+0)%R; auto with real; apply Rplus_lt_compat; auto with real. unfold Rdiv;repeat apply Rmult_lt_0_compat; auto with real zarith. apply Rlt_le_trans with (2+1)%R; auto with real. apply sym_eq; apply trans_eq with (z+w-uh-(pl+ul))%R;[rewrite plDef; rewrite ulDef; ring|idtac]. rewrite I2; rewrite Case1; simpl. ring_simplify. assert (FtoRradix t=uh-z)%R. elim tBounded with bo radix p a x b ph pl uh z; auto with zarith. fold FtoRradix; intros t' T; elim T; intros; clear T. rewrite <- H0; unfold FtoRradix; apply sym_eq. apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; rewrite H0; auto. cut (FtoRradix pl=-t)%R;[intros K; rewrite K; rewrite H; ring|idtac]. apply trans_eq with (FtoRradix v). unfold FtoRradix;apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. replace (FtoR radix pl) with (pl+ul)%R; auto; rewrite Case1; auto with real. assert (t+v=0)%R; auto with real. apply ClosestZero1 with bo radix p w (Fplus radix t v); auto with zarith. rewrite Fplus_correct; fold FtoRradix; auto with real. simpl; apply Zmin_Zle. elim tDef; intros J1 J2; elim J1; auto. elim vDef; intros J1 J2; elim J1; auto. apply Rplus_eq_reg_l with t; rewrite H0; auto with real. replace (z+w-(a*x+b))%R with 0%R. rewrite Rabs_R0; apply Rle_trans with (0*Rabs z)%R; [right; ring|apply Rmult_le_compat_r; auto with real]. apply Rlt_le; apply Rmult_lt_0_compat; auto with real zarith. apply Rle_lt_trans with (0+0)%R; auto with real; apply Rplus_lt_compat; auto with real. unfold Rdiv;repeat apply Rmult_lt_0_compat; auto with real zarith. apply Rlt_le_trans with (2+1)%R; auto with real. assert (a*x+b=0)%R. apply ClosestZero1 with bo radix p z (Fplus radix (Fmult a x) b); auto with zarith. rewrite Fplus_correct; auto; rewrite Fmult_correct; fold FtoRradix; auto with real. simpl; apply Zmin_Zle; auto with zarith float. rewrite I1; rewrite H; simpl; ring_simplify. apply sym_eq; unfold FtoRradix; apply ClosestZero2 with bo p (t+v)%R; auto. cut (FtoRradix uh=0);[intros M1|idtac]. replace (FtoRradix t) with 0%R. replace (FtoRradix v) with 0%R;[ring|idtac]. apply sym_eq; unfold FtoRradix; apply ClosestZero2 with bo p (pl+ul)%R; auto. rewrite plDef; rewrite ulDef. apply trans_eq with ((a*x+b)-uh)%R;[ring|rewrite H; rewrite M1; simpl; ring]. apply sym_eq; unfold FtoRradix; apply ClosestZero2 with bo p (uh-z)%R; auto. rewrite M1; rewrite I1; ring. unfold FtoRradix; apply ClosestZero2 with bo p (ph+b)%R; auto. replace (FtoRradix ph) with (FtoRradix (Fopp b));[unfold FtoRradix; rewrite Fopp_correct; ring|idtac]. unfold FtoRradix;apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply oppBounded; auto. replace (FtoR radix (Fopp b)) with (a*x)%R; auto. apply Rplus_eq_reg_l with (FtoRradix b); rewrite Rplus_comm; rewrite H; rewrite Fopp_correct;auto with real. Qed. End uhExact. Section uhInexact. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 4 <= p. Lemma RleRoundedAbs: forall (f:float) (r:R), (Closest bo radix r f) -> (Fnormal radix bo f) -> (-(dExp bo) < Fexp f)%Z -> ((powerRZ radix (p - 1) + - / (2 * radix)) * powerRZ radix (Fexp f) <= Rabs r)%R. intros f r H H0 H'0. assert (exists f':float, f'=(Float (nNormMin radix p) (Fexp f))). exists (Float (nNormMin radix p) (Fexp f)); auto. elim H1; clear H1; intros f' H1. assert (Fbounded bo f'). rewrite H1; split; simpl; auto with zarith float. rewrite Zabs_eq. apply ZltNormMinVnum; auto with zarith. apply Zlt_le_weak; apply nNormPos; auto. assert (Fnormal radix bo f'). split; auto. rewrite H1; simpl; rewrite <- PosNormMin with radix bo p; auto with zarith. assert (f' <= Fabs f)%R. rewrite H1; unfold FtoRradix, FtoR; simpl. apply Rmult_le_compat_r; auto with real zarith. assert (nNormMin radix p <= Zabs (Fnum f))%Z; auto with real zarith. apply pNormal_absolu_min with bo; auto with zarith. apply Rle_trans with (f'-powerRZ radix (Zpred (Fexp f))/2)%R. right; rewrite H1; unfold FtoRradix, FtoR, Zpred, Zminus; simpl. rewrite powerRZ_add with (n:=Fexp f); auto with real zarith; simpl; ring_simplify (radix*1)%R. replace (IZR (nNormMin radix p)) with (powerRZ radix (p + -1)). field; auto with real zarith. repeat apply prod_neq_R0; auto with real zarith. unfold nNormMin; rewrite Zpower_nat_Z_powerRZ; rewrite inj_pred; auto with real zarith. case (Rle_or_lt (f' - powerRZ radix (Zpred (Fexp f)) / 2) (Rabs r)); auto; intros I. absurd (Rabs (Fabs f - Rabs r) <= Rabs ((FPred bo radix p f') - Rabs r))%R. 2: assert (K: (Closest bo radix (Rabs r) (Fabs f))). 2: apply ClosestFabs with p; auto with zarith. 2: elim K; intros K1 K2; unfold FtoRradix; apply K2; auto. 2: apply FBoundedPred; auto with zarith. apply Rlt_not_le. rewrite Rabs_left1. rewrite Rabs_right with (Fabs f - Rabs r)%R. apply Rplus_lt_reg_r with (Rabs r+(FPred bo radix p f'))%R. ring_simplify. apply Rlt_le_trans with (2*(f' - powerRZ radix (Zpred (Fexp f)) / 2))%R. apply Rmult_lt_compat_l; auto with real. apply Rle_trans with (f'+ FPred bo radix p f')%R; auto with real. apply Rle_trans with (2*f'- powerRZ radix (Zpred (Fexp f)))%R; [right; field; auto with real|idtac]. apply Rplus_le_reg_l with (-f'- FPred bo radix p f'+ powerRZ radix (Zpred (Fexp f)))%R. ring_simplify. right; apply trans_eq with (FtoRradix (Fminus radix f' (FPred bo radix p f'))). unfold FtoRradix; rewrite Fminus_correct; auto with real zarith. unfold FtoRradix; rewrite FPredDiff3; auto with zarith. rewrite H1; simpl; unfold FtoR; simpl; ring. rewrite H1; auto. rewrite H1; auto with zarith. rewrite Rplus_comm; auto with real. apply Rle_ge. assert (Rabs r < Fabs f)%R; auto with real. apply Rlt_le_trans with (1:=I). apply Rle_trans with (Fabs f-0)%R; auto with real; unfold Rminus; apply Rplus_le_compat; auto with real zarith. apply Ropp_le_contravar; unfold Rdiv; apply Rlt_le; apply Rmult_lt_0_compat; auto with real zarith. assert ((FPred bo radix p f' <= Rabs r))%R; auto with real. 2: apply Rle_trans with (Rabs r-Rabs r)%R; unfold Rminus; auto with real. case (Rle_or_lt (FPred bo radix p f') (Rabs r)); auto; intros I'. absurd (FPred bo radix p f' < f')%R. 2: unfold FtoRradix; apply FPredLt; auto with zarith. apply Rle_not_lt. apply Rle_trans with (1:=H4). unfold FtoRradix; rewrite Fabs_correct; auto. apply RoundAbsMonotoner with bo p (Closest bo radix) r; auto with zarith real. apply ClosestRoundedModeP with p; auto with zarith. apply FBoundedPred; auto with zarith. Qed. Variables a x b ph pl uh ul z t v w:float. Hypothesis Fb: Fbounded bo b. Hypothesis Fa: Fbounded bo a. Hypothesis Fx: Fbounded bo x. Hypothesis Cb: Fcanonic radix bo b. Hypothesis Nph: Fnormal radix bo ph. Hypothesis Nuh: Fnormal radix bo uh. Hypothesis Nz: Fnormal radix bo z. Hypothesis Nw: Fnormal radix bo w. Hypothesis Nv: Fnormal radix bo v. Hypothesis Exp1: (- dExp bo <= Fexp a+Fexp x)%Z. Hypothesis zDef : Closest bo radix (a*x+b)%R z. Hypothesis phDef: Closest bo radix (a*x)%R ph. Hypothesis plDef: (FtoRradix pl=a*x-ph)%R. Hypothesis uhDef: Closest bo radix (ph+b)%R uh. Hypothesis ulDef: (FtoRradix ul=ph+b-uh)%R. Hypothesis tDef : Closest bo radix (uh-z)%R t. Hypothesis vDef : Closest bo radix (pl+ul)%R v. Hypothesis wDef : Closest bo radix (t+v)%R w. Hypothesis Case2: ~(FtoRradix ul=0)%R. Lemma LeExp1: (Fexp ph <= Fexp uh+1)%Z. case (Zle_or_lt (Fexp ph) (Fexp uh+1)); auto with zarith; intros. absurd (FtoRradix ul=0); auto with real. rewrite ulDef; assert (FtoRradix uh=ph+b)%R; auto with real. unfold FtoRradix; apply plusExact2 with bo p; auto with real zarith. left; auto. Qed. Lemma LeExp2: (Fexp uh <= Fexp z+1)%Z. assert (Rabs (uh-z) <= (1+radix)* Fulp bo radix p uh + Fulp bo radix p z)%R. replace (uh-z)%R with (-(ph+b-uh)+-(a*x-ph)+(a*x+b-z))%R;[idtac|ring]. apply Rle_trans with (1:=Rabs_triang (-(ph+b-uh)+-(a*x-ph)) (a*x+b-z)). apply Rplus_le_compat. apply Rle_trans with (1:=Rabs_triang (-(ph+b-uh)) (-(a*x-ph))). apply Rle_trans with (Fulp bo radix p uh+radix*Fulp bo radix p uh)%R; [apply Rplus_le_compat|right; ring]. rewrite Rabs_Ropp; apply Rlt_le; unfold FtoRradix. apply RoundedModeUlp with (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply Rle_trans with (Fulp bo radix p ph). rewrite Rabs_Ropp; apply Rlt_le; unfold FtoRradix. apply RoundedModeUlp with (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. unfold Fulp; repeat rewrite FcanonicFnormalizeEq; auto with zarith. 2: left; auto. 2: left; auto. apply Rle_trans with (powerRZ radix (Fexp uh+1)); [apply Rle_powerRZ; auto with real zarith; generalize LeExp1; auto with zarith| rewrite powerRZ_add; auto with real zarith; simpl; right;ring]. apply Rlt_le; unfold FtoRradix. apply RoundedModeUlp with (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply Zle_trans with (Fexp (Float (Fnum z) (Fexp z+1))); auto with zarith. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. left; auto. elim Nz; intros A1 A2; elim A1; intros. left; split;[split|idtac];simpl; auto with zarith. fold FtoRradix; apply Rle_trans with (radix*Rabs z)%R. 2: unfold FtoRradix; repeat rewrite <- Fabs_correct; auto; unfold FtoR; simpl. 2: rewrite powerRZ_add; auto with real zarith; simpl; right; ring. apply Rmult_le_reg_l with (1-(1+radix)*powerRZ radix (Zsucc (-p)))%R. assert ((1+radix) * powerRZ radix (Zsucc (-p)) < 1)%R; auto with real. apply Rlt_le_trans with ((radix*radix)*powerRZ radix (Zsucc (-p)))%R; [apply Rmult_lt_compat_r; auto with real zarith|idtac]. apply Rlt_le_trans with (radix+radix)%R; auto with real. apply Rle_trans with (2*radix)%R; [right; ring|apply Rmult_le_compat_r; auto with real zarith]. replace 2%R with (IZR 2); auto with real zarith. apply Rle_trans with (powerRZ radix (2+Zsucc (-p))); [right; rewrite powerRZ_add; auto with real zarith; simpl; ring|idtac]. apply Rle_trans with (powerRZ radix 0); auto with real zarith. apply Rle_trans with (Rabs uh-(1+radix)*(Rabs uh*powerRZ radix (Zsucc (-p))))%R; [right; ring|idtac]. apply Rle_trans with (Rabs uh-(1+radix)*Fulp bo radix p uh)%R; [unfold Rminus;apply Rplus_le_compat_l|idtac]. apply Ropp_le_contravar; apply Rmult_le_compat_l; auto with real. apply Rle_trans with (1+0)%R; auto with real. apply Rle_trans with 1%R; auto with real. unfold FtoRradix; apply FulpLe2; auto with zarith. elim uhDef; auto. rewrite FcanonicFnormalizeEq; auto with zarith; left; auto. apply Rle_trans with (Rabs z+Fulp bo radix p z)%R. apply Rplus_le_reg_l with (-Rabs z+ (1+radix) * Fulp bo radix p uh)%R. ring_simplify. apply Rle_trans with (Rabs uh - Rabs z)%R;[right; ring|idtac]. apply Rle_trans with (Rabs (uh-z));[apply Rabs_triang_inv|idtac]. apply Rle_trans with (1:=H); right; ring. apply Rle_trans with (Rabs z+(Rabs z*powerRZ radix (Zsucc (-p))))%R; [apply Rplus_le_compat_l|idtac]. unfold FtoRradix; apply FulpLe2; auto with zarith. elim zDef; auto. rewrite FcanonicFnormalizeEq; auto with zarith; left; auto. rewrite <- Rmult_assoc. apply Rle_trans with ((1+ powerRZ radix (Zsucc (- p)))*Rabs z)%R; [right; ring|apply Rmult_le_compat_r; auto with real]. apply Rplus_le_reg_l with (-1+(1+radix)*radix*powerRZ radix (Zsucc (- p)))%R. apply Rle_trans with ((1+radix+radix*radix)*powerRZ radix (Zsucc (- p)))%R;[right; ring|idtac]. apply Rle_trans with (radix-1)%R;[idtac|right; ring]. apply Rle_trans with ((radix*radix*radix)*powerRZ radix (Zsucc (-p)))%R; [apply Rmult_le_compat_r; auto with real zarith|idtac]. apply Rle_trans with (radix+radix+radix*radix)%R; auto with real. apply Rle_trans with ((2+radix)*radix)%R; [right; ring|apply Rmult_le_compat_r; auto with real zarith]. apply Rle_trans with (radix+radix)%R; auto with real. replace 2%R with (IZR 2); auto with real zarith. apply Rle_trans with (2*radix)%R; [right; ring|apply Rmult_le_compat_r; auto with real zarith]. replace 2%R with (IZR 2); auto with real zarith. apply Rle_trans with (powerRZ radix (3+Zsucc (-p))); [right; rewrite powerRZ_add; auto with real zarith; simpl; ring|idtac]. apply Rle_trans with (powerRZ radix 0); auto with real zarith. unfold Zsucc; apply Rle_powerRZ; auto with real zarith. assert (2 <= radix)%R; auto with real. replace 2%R with (IZR 2); auto with real zarith. simpl; apply Rplus_le_reg_l with 1%R; auto with real. ring_simplify (1 + (radix - 1))%R; auto with real. Qed. Lemma LeExp3: (Fexp ph = Fexp uh+1)%Z -> (Fexp uh = Fexp z+1)%Z -> False. intros. absurd (powerRZ radix (p+Fexp z) <= Rabs z)%R. apply Rlt_not_le. unfold FtoRradix; rewrite <- Fabs_correct; auto; unfold FtoR; simpl. rewrite powerRZ_add; auto with real zarith; apply Rmult_lt_compat_r; auto with real zarith. elim Nz; intros A1 A2; elim A1; intros. apply Rlt_le_trans with (IZR (Zpos (vNum bo))); auto with zarith real. right; rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; auto with real. apply Rle_trans with (FtoRradix (Float 1 (p+Fexp z))). right; unfold FtoRradix, FtoR; simpl; ring. unfold FtoRradix; apply RoundAbsMonotonel with bo p (Closest bo radix) (a*x+b)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. elim Nz; intros A1 A2; elim A1; intros; split; simpl; auto with zarith float. apply vNumbMoreThanOne with radix p; auto with zarith. apply Rle_trans with (powerRZ radix (p+Fexp z));[right; unfold FtoRradix, FtoR; simpl; ring|idtac]. replace (a*x+b)%R with (a*x-(-b))%R;[idtac|ring]. apply Rle_trans with (Rabs (a*x)-Rabs (-b))%R;[rewrite Rabs_Ropp|apply Rabs_triang_inv]. apply Rle_trans with ((powerRZ radix (p-1) -/(2*radix))*powerRZ radix (Fexp ph) -(powerRZ radix p-1)*powerRZ radix (Fexp b))%R. apply Rle_trans with ((powerRZ radix (p-1) -/(2*radix))*powerRZ radix (Fexp z+2) -(powerRZ radix p-1)*powerRZ radix (Fexp z))%R. apply Rle_trans with ((powerRZ radix (p + 1) - radix/ 2 ) * powerRZ radix (Fexp z) - (powerRZ radix p-1) * powerRZ radix (Fexp z))%R; [idtac|unfold Rminus; apply Rplus_le_compat_r]. rewrite powerRZ_add; auto with real zarith. apply Rle_trans with ((powerRZ radix (p + 1) - radix / 2-powerRZ radix p+1)* powerRZ radix (Fexp z))%R;[apply Rmult_le_compat_r; auto with real zarith|right; ring]. case (Zle_lt_or_eq 2 radix); auto with zarith; intros I. assert (3 <= radix)%Z; auto with zarith. assert (3 <= radix)%R; auto with real zarith. replace 3%R with (IZR 3); auto with real zarith; simpl; ring. apply Rplus_le_reg_l with (radix/2-1-powerRZ radix p)%R. ring_simplify. unfold Rminus; rewrite Rplus_comm. apply Rle_trans with (0+radix/2)%R; auto with real. apply Rle_trans with (0+radix*1)%R; unfold Rdiv; auto with real. apply Rplus_le_compat_l; apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (/1)%R; auto with real. apply Rle_trans with (powerRZ radix 1);[simpl; right; ring|idtac]. apply Rle_trans with (powerRZ radix p);auto with real zarith. apply Rle_trans with (- 2*powerRZ radix p + powerRZ radix p * (3))%R; [right; ring|auto with real]. rewrite powerRZ_add; auto with real zarith. apply Rplus_le_compat_l; apply Rmult_le_compat_l; auto with real zarith. simpl; ring_simplify (radix*1)%R; auto with real. right; rewrite <- I; rewrite powerRZ_add; auto with real zarith; simpl. field; auto with real. unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith; simpl. ring_simplify (radix*1)%R; right; field; auto with real. repeat apply prod_neq_R0; auto with real zarith. unfold Rminus; apply Rplus_le_compat. replace (Fexp ph) with (Fexp z+2)%Z; auto with real zarith. apply Ropp_le_contravar; apply Rmult_le_compat_l. assert (1 <= powerRZ radix p)%R; auto with real. apply Rle_trans with (powerRZ radix 0); auto with real zarith. apply Rplus_le_reg_l with 1%R. ring_simplify (1+0)%R; apply Rle_trans with (1:=H1); right; ring. apply Rle_powerRZ; auto with real zarith. apply Zle_trans with (Fexp uh -1)%Z; auto with zarith. case (Zle_or_lt (Fexp b) (Fexp uh-1)); auto with zarith; intros. absurd (FtoRradix ul=0); auto with real. elim errorBoundedPlus with bo radix p ph b uh; auto with zarith. 2: elim phDef; auto. fold FtoRradix; intros ul' T; elim T; intros H2 T'; elim T'; intros; clear T T'. rewrite ulDef; rewrite <- H2. absurd (Fexp uh < Fexp uh)%Z; auto with zarith. apply Zle_lt_trans with (Fexp ul'); auto with zarith. rewrite H4; apply Zmin_Zle; auto with zarith. apply ClosestErrorExpStrict with bo radix p (ph+b)%R; auto with zarith. elim uhDef; auto. fold FtoRradix; rewrite H2; rewrite <- ulDef; auto with real. unfold Rminus; apply Rplus_le_compat. apply RleRoundedAbs; auto. assert (-dExp bo <= Fexp uh)%Z; auto with zarith. elim uhDef; intros I1 I2; elim I1; auto. apply Ropp_le_contravar; unfold FtoRradix; rewrite <- Fabs_correct; auto. unfold FtoR; simpl; apply Rmult_le_compat_r; auto with real zarith. elim Fb; intros. apply Rle_trans with (Zpred (Zpos (vNum bo))); auto with real zarith. right; unfold Zpred, Zminus; rewrite plus_IZR; rewrite pGivesBound; simpl. rewrite Zpower_nat_Z_powerRZ; auto with real. Qed. Lemma LeExp: (powerRZ radix (Fexp ph)+powerRZ radix (Fexp uh) <= 2*powerRZ radix (Fexp z+1))%R. apply Rle_trans with (powerRZ radix (Fexp z + 1)+ powerRZ radix (Fexp z + 1))%R;[idtac|right; ring]. apply Rplus_le_compat; apply Rle_powerRZ; auto with real zarith. generalize LeExp1; generalize LeExp2; generalize LeExp3; intros. case (Zle_lt_or_eq _ _ H0); intros; auto with zarith. generalize LeExp1; generalize LeExp2; generalize LeExp3; intros; auto. Qed. Lemma vLe_aux: (Rabs (pl+ul) <= powerRZ radix (Fexp z)*radix)%R. apply Rle_trans with (powerRZ radix (Fexp z+1)); [idtac|rewrite powerRZ_add; auto with real zarith; simpl; right; ring]. apply Rle_trans with (Rabs pl+Rabs ul)%R;[apply Rabs_triang|idtac]. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (powerRZ radix (Fexp ph)+powerRZ radix (Fexp uh))%R; [idtac|apply LeExp]. apply Rle_trans with (INR 2*Rabs pl+INR 2*Rabs ul)%R;[simpl; right; ring|idtac]. apply Rplus_le_compat. apply Rle_trans with (Fulp bo radix p ph). rewrite plDef; unfold FtoRradix; apply ClosestUlp; auto with zarith. rewrite CanonicFulp; auto with zarith;[unfold FtoR; simpl; right; ring|left; auto]. apply Rle_trans with (Fulp bo radix p uh). rewrite ulDef; unfold FtoRradix; apply ClosestUlp; auto with zarith. rewrite CanonicFulp; auto with zarith;[unfold FtoR; simpl; right; ring|left; auto]. Qed. Lemma vLe: (Rabs v <= powerRZ radix (Fexp z)*radix)%R. assert (powerRZ radix (Fexp z) * radix=Float radix (Fexp z))%R. unfold FtoRradix, FtoR; simpl; ring. rewrite H. unfold FtoRradix; apply RoundAbsMonotoner with bo p (Closest bo radix) (pl+ul)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. elim zDef; intros I1 I2; elim I1; intros; split; simpl; auto with zarith. rewrite Zabs_eq; auto with zarith. apply Zlt_trans with (pPred (vNum bo)); [apply pPredMoreThanRadix with p|unfold pPred]; auto with zarith. fold FtoRradix; rewrite <- H; apply vLe_aux. Qed. Lemma tLe: (Rabs t <= powerRZ radix (Fexp z)*(radix+1))%R. replace (FtoRradix t) with (uh-z)%R. replace (uh-z)%R with ((a*x+b-z)+(-(a*x-ph)+-((ph+b)-uh)))%R;[idtac|ring]. apply Rle_trans with (Rabs (a*x+b-z)+Rabs ( - (a * x - ph) + - (ph + b - uh)))%R; [apply Rabs_triang|idtac]. apply Rle_trans with (powerRZ radix (Fexp z)+powerRZ radix (Fexp z)*radix)%R;[idtac|right; ring]. apply Rplus_le_compat. apply Rle_trans with (Fulp bo radix p z). apply Rlt_le; unfold FtoRradix; apply RoundedModeUlp with (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. rewrite CanonicFulp; auto with zarith;[unfold FtoR; simpl; right; ring|left; auto]. apply Rle_trans with (powerRZ radix (Fexp z+1)); [idtac|rewrite powerRZ_add; auto with real zarith; simpl; right; ring]. apply Rle_trans with (Rabs (-(a*x-ph))+Rabs (-(ph+b-uh)))%R;[apply Rabs_triang|idtac]. rewrite Rabs_Ropp; rewrite Rabs_Ropp. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (powerRZ radix (Fexp ph)+powerRZ radix (Fexp uh))%R; [idtac|apply LeExp]. apply Rle_trans with (INR 2*Rabs (a*x-ph)+INR 2*Rabs (ph+b-uh))%R;[simpl; right; ring|idtac]. apply Rplus_le_compat. apply Rle_trans with (Fulp bo radix p ph). unfold FtoRradix; apply ClosestUlp; auto with zarith. rewrite CanonicFulp; auto with zarith;[unfold FtoR; simpl; right; ring|left; auto]. apply Rle_trans with (Fulp bo radix p uh). unfold FtoRradix; apply ClosestUlp; auto with zarith. rewrite CanonicFulp; auto with zarith;[unfold FtoR; simpl; right; ring|left; auto]. elim tBounded with bo radix p a x b ph pl uh z; auto with zarith. fold FtoRradix; intros t' T; elim T; intros; clear T. rewrite <- H0; unfold FtoRradix. apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; rewrite H0; auto. Qed. Lemma wLe: (Rabs w <= powerRZ radix (Fexp z)*(2*radix+1))%R. assert (powerRZ radix (Fexp z) * (2*radix+1)=Float (2*radix+1) (Fexp z))%R. apply trans_eq with (powerRZ radix (Fexp z) * (2 * radix + 1)%Z)%R. rewrite plus_IZR; rewrite mult_IZR; simpl; ring. unfold FtoRradix, FtoR; simpl; ring. rewrite H. unfold FtoRradix; apply RoundAbsMonotoner with bo p (Closest bo radix) (t+v)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. elim zDef; intros I1 I2; elim I1; intros; split; [idtac|simpl; auto with zarith]. apply Zle_lt_trans with (Zabs (2*radix+1)); auto with zarith. rewrite Zabs_eq; auto with zarith. apply Zlt_le_trans with (2*radix+radix)%Z; auto with zarith. apply Zle_trans with (3*radix)%Z; auto with zarith. rewrite pGivesBound; apply Zle_trans with (Zpower_nat radix 3); auto with zarith. unfold Zpower_nat; simpl ( nat_iter 3 (Z.mul radix) 1)%Z. rewrite Zmult_comm; apply Zmult_le_compat_l; auto with zarith. ring_simplify (radix*1)%Z; apply Zle_trans with (2*2)%Z; auto with zarith. apply Zmult_le_compat; auto with zarith. fold FtoRradix; rewrite <- H. apply Rle_trans with (Rabs t+Rabs v)%R;[apply Rabs_triang|idtac]. generalize tLe; generalize vLe; intros. apply Rle_trans with ( powerRZ radix (Fexp z) * (radix + 1)+powerRZ radix (Fexp z) * radix)%R; [auto with real|right; ring]. Qed. Theorem ErrFmaApprox_2_aux:(Rabs (z+w-(a*x+b)) <= (3*radix/2+/2)*powerRZ radix (2-2*p)*Rabs z)%R. replace (z+w-(a*x+b))%R with ((t-(uh-z))+-(t+v-w)+-(pl+ul-v))%R; [idtac|rewrite ulDef; rewrite plDef; ring]. pattern (FtoRradix t) at 1; replace (FtoRradix t) with (uh-z)%R. 2: elim tBounded with bo radix p a x b ph pl uh z; auto with zarith. 2: fold FtoRradix; intros t' T; elim T; intros; clear T. 2: rewrite <- H0; unfold FtoRradix. 2: apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. 2: apply ClosestRoundedModeP with p; auto with zarith. 2: fold FtoRradix; rewrite H0; auto. replace (uh - z - (uh - z) + - (t + v - w) + - (pl + ul - v))%R with (-((t + v - w)+(pl + ul - v)))%R;[rewrite Rabs_Ropp|ring]. apply Rle_trans with (Rabs (t+v-w)+Rabs (pl+ul-v))%R;[apply Rabs_triang|idtac]. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (INR 2*Rabs (t + v - w) + INR 2*Rabs (pl + ul - v))%R;[right; simpl; ring|idtac]. apply Rle_trans with ((Fulp bo radix p w)+(Fulp bo radix p v))%R. apply Rplus_le_compat; unfold FtoRradix; apply ClosestUlp; auto with zarith. apply Rle_trans with (Rabs w*powerRZ radix (Zsucc (-p))+Rabs v*powerRZ radix (Zsucc (-p)))%R. apply Rplus_le_compat; unfold FtoRradix; apply FulpLe2; auto with zarith. elim wDef; auto. rewrite FcanonicFnormalizeEq; auto with zarith; left; auto. elim vDef; auto. rewrite FcanonicFnormalizeEq; auto with zarith; left; auto. apply Rle_trans with (powerRZ radix (Zsucc (-p))*(Rabs w+Rabs v))%R;[right; ring|idtac]. generalize wLe; generalize vLe; intros. apply Rle_trans with (powerRZ radix (Zsucc (-p))*(powerRZ radix (Fexp z) * (2 * radix + 1) + powerRZ radix (Fexp z) *radix))%R; [apply Rmult_le_compat_l; auto with real zarith|idtac]. apply Rle_trans with ((3*radix+1)*(powerRZ radix (Zsucc (- p))*(powerRZ radix (Fexp z))))%R; [right; ring|idtac]. apply Rle_trans with ((3 * radix + 1) * (powerRZ radix (2- 2*p) *Rabs z))%R; [idtac|right; field; auto with real]. apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (0+1)%R; auto with real. assert (0 < 3*radix)%R; auto with real. apply Rmult_lt_0_compat; auto with real zarith. apply Rlt_le_trans with (2+1)%R;auto with real. replace (2-2*p)%Z with (Zsucc (-p)+Zsucc (-p))%Z;[idtac|unfold Zsucc; ring]. rewrite powerRZ_add; auto with real zarith. rewrite Rmult_assoc; apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (Fulp bo radix p z). unfold Fulp;rewrite FcanonicFnormalizeEq; auto with zarith real; left; auto. unfold FtoRradix; rewrite Rmult_comm; apply FulpLe2; auto with zarith. elim zDef; auto. rewrite FcanonicFnormalizeEq; auto with zarith real; left; auto. Qed. End uhInexact. Section uhInexact2. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 4 <= p. Variables a x b ph pl uh ul z t v w:float. Hypothesis Fb: Fbounded bo b. Hypothesis Fa: Fbounded bo a. Hypothesis Fx: Fbounded bo x. Hypothesis Cb: Fcanonic radix bo b. Hypothesis Nph: Fnormal radix bo ph \/ (FtoRradix ph=0). Hypothesis Nuh: Fnormal radix bo uh \/ (FtoRradix uh=0). Hypothesis Nz: Fnormal radix bo z \/ (FtoRradix z =0). Hypothesis Nw: Fnormal radix bo w \/ (FtoRradix w =0). Hypothesis Nv: Fnormal radix bo v \/ (FtoRradix v =0). Hypothesis Exp1: (- dExp bo <= Fexp a+Fexp x)%Z. Hypothesis zDef : Closest bo radix (a*x+b)%R z. Hypothesis phDef: Closest bo radix (a*x)%R ph. Hypothesis plDef: (FtoRradix pl=a*x-ph)%R. Hypothesis uhDef: Closest bo radix (ph+b)%R uh. Hypothesis ulDef: (FtoRradix ul=ph+b-uh)%R. Hypothesis tDef : Closest bo radix (uh-z)%R t. Hypothesis vDef : Closest bo radix (pl+ul)%R v. Hypothesis wDef : Closest bo radix (t+v)%R w. Hypothesis Case2: ~(FtoRradix ul=0)%R. Theorem ErrFmaApprox_2:(Rabs (z+w-(a*x+b)) <= (3*radix/2+/2)*powerRZ radix (2-2*p)*Rabs z)%R. case Nv; intros I5. case Nz; intros I3. case Nph; intros I1. case Nuh; intros I2. case Nw; intros I4. unfold FtoRradix; apply ErrFmaApprox_2_aux with bo ph pl uh ul t v; auto. (*w=0 -> eps <= v-ul-pl=/2 ulp(v)=radix/2*beta^e_z *) replace (z + w - (a * x + b))%R with (-(ul+pl-v))%R. apply Rmult_le_reg_l with (INR 2); auto with real zarith; rewrite Rabs_Ropp. apply Rle_trans with (Fulp bo radix p v). unfold FtoRradix; apply ClosestUlp; auto with zarith. rewrite Rplus_comm; auto with real. apply Rle_trans with (Rabs v * powerRZ radix (Zsucc (- p)))%R; [unfold FtoRradix; apply FulpLe2; auto with zarith|idtac]. elim vDef; auto. rewrite FcanonicFnormalizeEq; auto with zarith; left; auto. assert (Rabs v <= powerRZ radix (Fexp z) * radix)%R. unfold FtoRradix; apply vLe with bo p a x b ph pl uh ul; auto. apply Rle_trans with ((powerRZ radix (Fexp z) * radix)* powerRZ radix (Zsucc (- p)))%R; [apply Rmult_le_compat_r; auto with real zarith|idtac]. apply Rle_trans with ((Rabs z * powerRZ radix (Zsucc (- p)))* radix * powerRZ radix (Zsucc (- p)))%R. apply Rmult_le_compat_r; auto with real zarith. apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (Fulp bo radix p z). unfold Fulp; rewrite FcanonicFnormalizeEq; auto with zarith real; left; auto. unfold FtoRradix; apply FulpLe2; auto with zarith. elim zDef; auto. rewrite FcanonicFnormalizeEq; auto with zarith real; left; auto. apply Rle_trans with (radix*powerRZ radix (2 - 2 * p) * Rabs z)%R. replace (2-2*p)%Z with (1+1-p-p)%Z;[idtac|ring]. unfold Zsucc, Zminus; repeat rewrite powerRZ_add; auto with real zarith; simpl. ring_simplify (radix*1)%R; right; ring. rewrite <- Rmult_assoc; apply Rmult_le_compat_r; auto with real. rewrite <- Rmult_assoc; apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (3*radix+1)%R;[idtac|right; simpl; field; auto with real]. apply Rle_trans with (1*radix+0)%R;[right; ring|apply Rplus_le_compat; auto with real zarith]. apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (2+1)%R; auto with real. apply Rle_trans with 2%R; auto with real. rewrite ulDef; rewrite plDef. assert (t+v=0)%R. apply ClosestZero1 with bo radix p w (Fplus radix t v); auto with zarith. rewrite Fplus_correct; fold FtoRradix; auto. simpl; apply Zmin_Zle; auto with zarith float. elim tDef; intros Y1 Y2; elim Y1; auto. elim vDef; intros Y1 Y2; elim Y1; auto. cut (uh-z=t)%R;[intros H'|idtac]. rewrite I4; simpl; rewrite <- H; rewrite <- H'; ring. elim tBounded with bo radix p a x b ph pl uh z; auto with zarith. fold FtoRradix; intros t' T; elim T; intros; clear T. rewrite <- H1; unfold FtoRradix. apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; rewrite H1; auto. (* uh=0 -> ul=0 *) assert (ph+b=0)%R. apply ClosestZero1 with bo radix p uh (Fplus radix ph b); auto with zarith. rewrite Fplus_correct; fold FtoRradix; auto. simpl; apply Zmin_Zle; auto with zarith float. elim phDef; intros Y1 Y2; elim Y1; auto. absurd (FtoRradix ul=0)%R; auto. rewrite ulDef; rewrite I2; rewrite H; simpl; ring. (*ph=0 -> uh=b et ul=0 *) absurd (FtoRradix ul=0)%R; auto. rewrite ulDef; rewrite I1. cut (FtoRradix b=uh)%R; [intros Y; rewrite Y; simpl; ring|idtac]. unfold FtoRradix; apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. replace (FtoR radix b) with (ph+b)%R; auto; rewrite I1; auto with real. (*z=0 -> ax=-b -> ph=-b -> uh=0 *) assert (FtoRradix uh=0)%R. unfold FtoRradix; apply ClosestZero2 with bo p (ph+b)%R; auto with real zarith. cut (FtoRradix ph= (Fopp b)); [intros I;rewrite I; unfold FtoRradix; rewrite Fopp_correct; ring|idtac]. unfold FtoRradix; apply sym_eq. apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply oppBounded; auto. replace (FtoR radix (Fopp b)) with (a*x)%R; auto. rewrite Fopp_correct; fold FtoRradix; assert (a*x+b=0)%R; auto with real. apply ClosestZero1 with bo radix p z (Fplus radix (Fmult a x) b); auto with zarith. rewrite Fplus_correct; auto; rewrite Fmult_correct; fold FtoRradix; auto. simpl; apply Zmin_Zle; auto with zarith float. apply Rplus_eq_reg_l with (FtoRradix b); rewrite Rplus_comm; rewrite H;ring. assert (ph+b=0)%R. apply ClosestZero1 with bo radix p uh (Fplus radix ph b); auto with zarith. rewrite Fplus_correct; fold FtoRradix; auto. simpl; apply Zmin_Zle; auto with zarith float. elim phDef; intros Y1 Y2; elim Y1; auto. absurd (FtoRradix ul=0)%R; auto. rewrite ulDef; rewrite H0; rewrite H; ring. (*v=0 -> z+w-ax-b=0 *) replace (z+w-(a*x+b))%R with 0%R. rewrite Rabs_R0; apply Rle_trans with (0*Rabs z)%R; [right; ring|apply Rmult_le_compat_r; auto with real]. apply Rlt_le; apply Rmult_lt_0_compat; auto with real zarith. apply Rle_lt_trans with (0+0)%R; auto with real; apply Rplus_lt_compat; auto with real. unfold Rdiv;repeat apply Rmult_lt_0_compat; auto with real zarith. apply Rlt_le_trans with (2+1)%R; auto with real. apply sym_eq; apply trans_eq with (z+w-uh-(pl+ul))%R;[rewrite plDef; rewrite ulDef; ring|idtac]. assert (pl+ul=0)%R. elim errorBoundedPlus with bo radix p ph b uh; auto with zarith. 2: elim phDef; auto. fold FtoRradix; intros pl' T; elim T; intros Y1 T'; elim T'; intros Y2 Y3; clear T T'. elim errorBoundedMult with bo radix p (Closest bo radix) a x ph; auto with zarith. 2: apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; intros ul' T; elim T; intros Y1' T'; elim T'; intros Y2' Y3'; clear T T'. apply ClosestZero1 with bo radix p v (Fplus radix pl' ul'); auto with zarith. rewrite Fplus_correct; fold FtoRradix; auto. rewrite ulDef; rewrite plDef; rewrite Y1; rewrite Y1'; ring. simpl; apply Zmin_Zle; auto with zarith float. rewrite H. replace (FtoRradix w) with (FtoRradix t). replace (FtoRradix t) with (uh-z)%R; [ring|idtac]. elim tBounded with bo radix p a x b ph pl uh z; auto with zarith. fold FtoRradix; intros t' T; elim T; intros; clear T. rewrite <- H1; unfold FtoRradix. apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; rewrite H1; auto. unfold FtoRradix; apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. elim tDef; auto. replace (FtoR radix t) with (t+v)%R; auto; rewrite I5; auto with real. Qed. End uhInexact2. Section Total. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 4 <= p. Variables a x b ph pl uh ul z t v w:float. Hypothesis Fb: Fbounded bo b. Hypothesis Fa: Fbounded bo a. Hypothesis Fx: Fbounded bo x. Hypothesis Nph: Fnormal radix bo ph \/ (FtoRradix ph=0). Hypothesis Nuh: Fnormal radix bo uh \/ (FtoRradix uh=0). Hypothesis Nz: Fnormal radix bo z \/ (FtoRradix z =0). Hypothesis Nw: Fnormal radix bo w \/ (FtoRradix w =0). Hypothesis Nv: Fnormal radix bo v \/ (FtoRradix v =0). Hypothesis Exp1: (- dExp bo <= Fexp a+Fexp x)%Z. Hypothesis zDef : Closest bo radix (a*x+b)%R z. Hypothesis phDef: Closest bo radix (a*x)%R ph. Hypothesis plDef: (FtoRradix pl=a*x-ph)%R. Hypothesis uhDef: Closest bo radix (ph+b)%R uh. Hypothesis ulDef: (FtoRradix ul=ph+b-uh)%R. Hypothesis tDef : Closest bo radix (uh-z)%R t. Hypothesis vDef : Closest bo radix (pl+ul)%R v. Hypothesis wDef : Closest bo radix (t+v)%R w. Theorem ErrFmaApprox:(Rabs (z+w-(a*x+b)) <= (3*radix/2+/2)*powerRZ radix (2-2*p)*Rabs z)%R. case (Req_dec ul 0); intros. elim errorBoundedMult with bo radix p (Closest bo radix) a x ph; auto with zarith. 2: apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; intros pl' T; elim T; intros M1 T'; elim T'; intros M2 M3; clear T T'. unfold FtoRradix; rewrite <- FnormalizeCorrect with radix bo p b; auto. apply ErrFmaApprox_1 with bo ph pl' uh ul t v; auto with zarith; try rewrite FnormalizeCorrect; auto with real. apply FnormalizeBounded; auto with zarith. apply FnormalizeCanonic; auto with zarith. fold FtoRradix; rewrite M1; rewrite <- plDef; auto. unfold FtoRradix; rewrite <- FnormalizeCorrect with radix bo p b; auto. apply ErrFmaApprox_2 with bo ph pl uh ul t v; auto; try rewrite FnormalizeCorrect; auto with real. apply FnormalizeBounded; auto with zarith. apply FnormalizeCanonic; auto with zarith. Qed. End Total. Float8.4/FnElem/FmaErrApprox2.v0000644000423700002640000021614012032774527016043 0ustar sboldotoccataRequire Export AllFloat. Require Export Veltkamp. Require Export FmaErr. Section RoundSubnormal. 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 Exact1 : forall q r : float, Closest b radix (FtoR radix q) r -> (Fexp r <= (Fexp q))%Z -> (FtoRradix r = q)%R. intros. cut (2%nat * Rabs (FtoR radix q - FtoR radix r) <= Float 1%nat (Fexp r))%R. 2: apply Rle_trans with (Fulp b radix p r); auto. 2: apply (ClosestUlp b radix p); auto. 2: unfold FtoRradix in |- *; apply FulpLe; auto. 2: apply RoundedModeBounded with (radix := radix) (P := Closest b radix) (r := q); auto. 2: apply ClosestRoundedModeP with (precision := p); auto. intros H1. cut (exists z:Z, (r-q=z*powerRZ radix (Fexp r))%R /\ (2*Zabs z <= 1)%Z). intros (z,(H2,H3)). assert (Zabs z=0)%Z; auto with zarith. assert (0 <= Zabs z)%Z;[apply Zabs_pos|idtac]; auto with zarith. assert (z=0)%Z. generalize H4; unfold Zabs; case z; intros; auto with zarith; discriminate. apply Rplus_eq_reg_l with (-q)%R. apply trans_eq with (r-q)%R;[ring|rewrite H2]. rewrite H5; simpl; ring. exists (Fnum (Fminus radix r q)). assert ((r - q)%R = (Fnum (Fminus radix r q) * powerRZ radix (Fexp r))%R). unfold FtoRradix; rewrite <- Fminus_correct; auto. unfold FtoR; replace (Fexp r) with (Fexp (Fminus radix r q)); auto. unfold Fminus, Fopp, Fplus; simpl. apply Zmin_le1; auto. split; auto; apply le_IZR. apply Rmult_le_reg_l with (powerRZ radix (Fexp r)); auto with real zarith. apply Rle_trans with (FtoRradix (Float 1%nat (Fexp r))). 2: unfold FtoRradix, FtoR; simpl;right; ring. apply Rle_trans with (2:=H1). fold FtoRradix; replace (q-r)%R with (-(r-q))%R by ring. rewrite Rabs_Ropp; rewrite H2; rewrite Rabs_mult. rewrite Rabs_Zabs. rewrite Rabs_right;[simpl (INR 2); right|apply Rle_ge; auto with real zarith]. rewrite mult_IZR; simpl (IZR 2); ring. Qed. Lemma ClosestRoundeLeNormalSub: forall (z : R) (f : float), 3 <= p -> Closest b radix z f -> (exists f:float, (FtoR radix f=z) /\ (- dExp b <= Fexp f)%Z) -> (Rabs (FtoR radix f) <= Rabs z / (1 - powerRZ radix (Zsucc (- p)) / 2))%R. assert ( forall (z : R) (f : float), 3 <= p -> (Fcanonic radix b f) -> Closest b radix z f -> (exists u:float, (FtoR radix u=z) /\ (- dExp b <= Fexp u)%Z) -> (Rabs (FtoR radix f) <= Rabs z / (1 - powerRZ radix (Zsucc (- p)) / 2))%R). intros. case H0; clear H0; intros H0. apply ClosestRoundeLeNormal with b; auto. replace (FtoR radix f) with z. apply Rle_trans with (Rabs z /1)%R;[right; field; auto with real|idtac]. apply Rmult_le_compat_l; auto with real. apply Rle_Rinv; auto with real. apply UnMoinsPos; auto with zarith real. apply Rplus_le_reg_l with (-1+powerRZ radix (Zsucc (- p)) / 2)%R; ring_simplify. unfold Rdiv; apply Rmult_le_pos; auto with real zarith. elim H2; intros u (H3,H4). rewrite <- H3; apply sym_eq; apply Exact1; auto. rewrite H3; auto. elim H0; intros H5 (H6,H7); auto with zarith. intros. rewrite <- FnormalizeCorrect with radix b p f; auto with zarith. apply H; auto. apply FnormalizeCanonic; auto with zarith. elim H1; auto. apply (ClosestCompatible b radix z z f); auto with zarith. rewrite FnormalizeCorrect; auto. apply FnormalizeBounded; auto with zarith float. elim H1; auto. Qed. Lemma ClosestRoundeGeNormalSub: forall (z : R) (f : float), 3 <= p -> Closest b radix z f -> (exists f:float, (FtoR radix f=z) /\ (- dExp b <= Fexp f)%Z) -> (Rabs z <= Rabs (FtoR radix f) * (1 + powerRZ radix (Zsucc (- p)) / 2))%R. assert ( forall (z : R) (f : float), 3 <= p -> (Fcanonic radix b f) -> Closest b radix z f -> (exists u:float, (FtoR radix u=z) /\ (- dExp b <= Fexp u)%Z) -> (Rabs z <= Rabs (FtoR radix f) * (1 + powerRZ radix (Zsucc (- p)) / 2))%R). intros. case H0; clear H0; intros H0. apply ClosestRoundeGeNormal with b; auto. replace (FtoR radix f) with z. apply Rle_trans with (Rabs z *1)%R;[right; field; auto with real|idtac]. apply Rmult_le_compat_l; auto with real. apply Rplus_le_reg_l with (-1)%R; ring_simplify. unfold Rdiv; apply Rmult_le_pos; auto with real zarith. elim H2; intros u (H3,H4). rewrite <- H3; apply sym_eq; apply Exact1; auto. rewrite H3; auto. elim H0; intros H5 (H6,H7); auto with zarith. intros. rewrite <- FnormalizeCorrect with radix b p f; auto with zarith. apply H; auto. apply FnormalizeCanonic; auto with zarith. elim H1; auto. apply (ClosestCompatible b radix z z f); auto with zarith. rewrite FnormalizeCorrect; auto. apply FnormalizeBounded; auto with zarith float. elim H1; auto. Qed. End RoundSubnormal. Section tBounded. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 3 <= p. Variables a x b ph pl uh z:float. Hypothesis Fb: Fbounded bo b. Hypothesis Fa: Fbounded bo a. Hypothesis Fx: Fbounded bo x. Hypothesis Cb: Fcanonic radix bo b. Hypothesis Cph: Fcanonic radix bo ph. Hypothesis Cz: Fcanonic radix bo z. (* Hypothesis Nph: Fnormal radix bo ph. Hypothesis Nz: Fnormal radix bo z. Hypothesis Nuh: Fnormal radix bo uh.*) Hypothesis Exp1: (- dExp bo <= Fexp a+Fexp x)%Z. Hypothesis zDef : Closest bo radix (a*x+b)%R z. Hypothesis phDef: Closest bo radix (a*x)%R ph. Hypothesis plDef: (FtoRradix pl=a*x-ph)%R. Hypothesis uhDef: Closest bo radix (ph+b)%R uh. Hypothesis Posit: (0 <= a*x+b)%R. Lemma zPos: (0 <= z)%R. unfold FtoRradix; apply RleRoundedR0 with bo p (Closest bo radix) (a*x+b)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. Qed. Lemma uhPos: (0 <= uh)%R. unfold FtoRradix; apply RleRoundedR0 with bo p (Closest bo radix) (ph+b)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply Rplus_le_reg_l with (-b)%R. ring_simplify. unfold FtoRradix; rewrite <- Fopp_correct; auto. apply RleBoundRoundl with bo p (Closest bo radix) (a*x)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply oppBounded; auto. rewrite Fopp_correct; auto; fold FtoRradix; apply Rplus_le_reg_l with b. apply Rle_trans with 0%R; auto with real; rewrite Rplus_comm; auto. Qed. Theorem tBounded_aux: exists v:float, Fbounded bo v /\ (FtoRradix v=uh-z)%R. case (Req_dec (ph+b)%R 0);intros H1. exists (Fopp z); split. apply oppBounded; elim zDef; auto. unfold FtoRradix; rewrite Fopp_correct; replace (FtoR radix uh) with 0%R;[ring|idtac]. apply trans_eq with (FtoR radix (Fzero (-(dExp bo)))). rewrite FzeroisReallyZero; auto. apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply FboundedFzero. rewrite FzeroisReallyZero; rewrite <- H1; auto. case (Rle_or_lt (Rabs pl) (/4*Rabs (ph+b))); intros H2. exists (Fminus radix uh z). split;[idtac|unfold FtoRradix; apply Fminus_correct; auto]. apply Sterbenz; auto. elim uhDef; auto. elim zDef; auto. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (FtoR radix z);[right; simpl; field; auto with real|idtac]. rewrite <- (Rabs_right (FtoR radix z)). 2: apply Rle_ge; generalize zPos; auto with real. apply Rle_trans with (Rabs (a*x+b) / (1 - powerRZ radix (Zsucc (- p)) / 2))%R. apply ClosestRoundeLeNormalSub with bo; auto with zarith. exists (Fplus radix (Fmult a x) b); split. rewrite Fplus_correct; auto with zarith; rewrite Fmult_correct; auto. unfold Fmult, Fplus; simpl. apply Zmin_Zle; auto. elim Fb; auto. assert (0 < 1 - powerRZ radix (Zsucc (- p)) / 2)%R. apply UnMoinsPos; auto with zarith. apply Rmult_le_reg_l with (1 - powerRZ radix (Zsucc (- p)) / 2)%R; auto with real. apply Rle_trans with (Rabs (a*x+b));[right; field; auto with real|idtac]. assert (0 < 2 - powerRZ radix (Zsucc (- p)))%R; auto with real. replace (2 - powerRZ radix (Zsucc (- p)))%R with (2*(1 - powerRZ radix (Zsucc (- p)) / 2))%R; auto with real. replace 0%R with (2*0)%R; auto with real. field; auto with real. replace (a*x+b)%R with ((ph+b)+pl)%R;[idtac|rewrite plDef; ring]. apply Rle_trans with (Rabs (ph+b)+Rabs pl)%R;[apply Rabs_triang|idtac]. apply Rle_trans with (Rabs (ph+b)+/ 4 * Rabs (ph + b))%R;auto with real. assert (0 < 4)%R;[apply Rmult_lt_0_compat; auto with real|idtac]. apply Rle_trans with (5/4*(Rabs (ph+b)))%R;[right; field; auto with real|idtac]. apply Rle_trans with (5/4*(Rabs (FtoR radix uh) * (1 + powerRZ radix (Zsucc (- p)) / 2)))%R. apply Rmult_le_compat_l. apply Rlt_le; unfold Rdiv;apply Rmult_lt_0_compat; auto with real. apply Rlt_trans with 4%R; auto with real. apply Rlt_le_trans with (4+1)%R; auto with real. apply ClosestRoundeGeNormalSub with bo; auto with zarith. exists (Fplus radix ph b); split. rewrite Fplus_correct; auto with zarith real. unfold Fplus; simpl; apply Zmin_Zle; auto with zarith float. elim phDef; intros (T1,T2) T3; auto. fold FtoRradix; apply Rle_trans with ((5/4*(1 + powerRZ radix (Zsucc (- p)) / 2))*Rabs uh)%R; [right; ring|idtac]. rewrite <- Rmult_assoc with (r3:=uh). pattern (FtoRradix uh) at 2; rewrite <- (Rabs_right uh). 2: apply Rle_ge; generalize uhPos; auto with real. apply Rmult_le_compat_r; auto with real. apply Rmult_le_reg_l with 8%R; [apply Rmult_lt_0_compat; auto with real|idtac]. apply Rle_trans with (10+5*powerRZ radix (Zsucc (- p)))%R;[right; field; auto with real|idtac]. apply Rle_trans with (16-8*powerRZ radix (Zsucc (- p)))%R;[idtac|right; field; auto with real]. apply Rplus_le_reg_l with (-10+8* powerRZ radix (Zsucc (- p)))%R. ring_simplify. apply Rle_trans with (13* /4)%R. apply Rmult_le_compat_l; auto with real. apply Rle_trans with (12+1)%R; auto with real. apply Rle_trans with 12%R; auto with real. apply Rlt_le; apply Rmult_lt_0_compat; auto with real; apply Rmult_lt_0_compat; auto with real. apply Rlt_trans with 2%R; auto with real. apply Rle_trans with (powerRZ radix (Zsucc (- 3))); unfold Zsucc; auto with zarith real. apply Rle_powerRZ; auto with real zarith. simpl; ring_simplify (radix*1)%R; auto with real zarith. apply Rle_Rinv; auto with real. replace 2%R with (IZR 2); auto with real zarith. apply Rmult_le_reg_l with 4%R; auto with real. apply Rle_trans with 13%R;[right; field; auto with real|idtac]. replace 13%R with (IZR 13); auto with real zarith. apply Rle_trans with (IZR 24); auto with real zarith. simpl; right; ring. simpl; ring. simpl; fold FtoRradix. rewrite <- (Rabs_right z);[idtac|apply Rle_ge; generalize zPos; auto with real]. rewrite <- (Rabs_right uh);[idtac|apply Rle_ge; generalize uhPos; auto with real]. assert (0 < 1 - powerRZ radix (Zsucc (- p)) / 2)%R. apply UnMoinsPos; auto with zarith. assert (0 < 4)%R;[apply Rmult_lt_0_compat; auto with real|idtac]. assert (0 < 3)%R;[apply Rlt_trans with 2%R; auto with real|idtac]. apply Rle_trans with (Rabs (ph+b) / (1 - powerRZ radix (Zsucc (- p)) / 2))%R. unfold FtoRradix; apply ClosestRoundeLeNormalSub with bo; auto with zarith. exists (Fplus radix ph b); split. rewrite Fplus_correct; auto with real zarith. unfold Fplus; simpl; apply Zmin_Zle; auto with zarith float. elim phDef; intros (T1,T2) T3; auto. apply Rmult_le_reg_l with (1 - powerRZ radix (Zsucc (- p)) / 2)%R; auto with real. apply Rle_trans with (Rabs (ph+b));[right; field; auto with real|idtac]. replace (2 - powerRZ radix (Zsucc (- p)))%R with (2* (1 - powerRZ radix (Zsucc (- p)) / 2))%R;[idtac|field]. apply prod_neq_R0; auto with real. apply Rle_trans with ((4/3)*(Rabs (a*x+b)))%R. apply Rmult_le_reg_l with (3/4)%R. unfold Rdiv; apply Rmult_lt_0_compat; auto with real. apply Rplus_le_reg_l with (/4*Rabs (ph + b))%R. apply Rle_trans with (Rabs (ph+b));[right; field; auto with real|idtac]. apply Rle_trans with (/4*Rabs (ph+b)+Rabs (a*x+b))%R;[idtac|right; field; auto with real]. pattern (ph+b)%R at 1; replace (ph+b)%R with (-(pl)+(a*x+b))%R;[idtac|rewrite plDef; ring]. apply Rle_trans with (Rabs (-pl)+Rabs (a*x+b))%R; [apply Rabs_triang|rewrite Rabs_Ropp; auto with real]. apply Rle_trans with (4/3*(Rabs z * (1 + powerRZ radix (Zsucc (- p)) / 2)))%R. apply Rmult_le_compat_l; auto with real. apply Rlt_le; unfold Rdiv; apply Rmult_lt_0_compat; auto with real. unfold FtoRradix; apply ClosestRoundeGeNormalSub with bo; auto with zarith. exists (Fplus radix (Fmult a x) b); split. rewrite Fplus_correct; try rewrite Fmult_correct; auto with zarith real. unfold Fplus, Fmult; simpl; apply Zmin_Zle; auto with zarith float. apply Rle_trans with ((4 / 3 * (1 + powerRZ radix (Zsucc (- p)) / 2))*(Rabs z))%R; [right; ring|idtac]. rewrite <- Rmult_assoc with (r3:=Rabs z). apply Rmult_le_compat_r; auto with real. apply Rmult_le_reg_l with 6%R; [apply Rmult_lt_0_compat; auto with real|idtac]. apply Rle_trans with (8+4*powerRZ radix (Zsucc (- p)))%R;[right; field; auto with real|idtac]. apply Rle_trans with (12-6*powerRZ radix (Zsucc (- p)))%R;[idtac|right; field; auto with real]. apply Rplus_le_reg_l with (-8+6* powerRZ radix (Zsucc (- p)))%R. ring_simplify. apply Rle_trans with (10* /4)%R. apply Rmult_le_compat_l; auto with real. apply Rlt_le; apply Rmult_lt_0_compat; auto with real. apply Rlt_le_trans with (4+1)%R; auto with real. apply Rle_trans with (powerRZ radix (Zsucc (- 3))); unfold Zsucc; auto with zarith real. apply Rle_powerRZ; auto with real zarith. simpl; ring_simplify (radix*1)%R; auto with real zarith. apply Rle_Rinv; auto with real. replace 2%R with (IZR 2); auto with real zarith. apply Rmult_le_reg_l with 4%R; auto with real. apply Rle_trans with 10%R;[right; field; auto with real|idtac]. replace 10%R with (IZR 10); auto with real zarith. apply Rle_trans with (IZR 16); auto with real zarith. simpl; right; ring. simpl; ring. assert (K:(Fexp a+Fexp x < Fexp ph)%Z). elim errorBoundedMult with bo radix p (Closest bo radix) a x ph; auto with zarith. 2: apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; intros pl' T; elim T; intros H3 T'; elim T'; intros H4 H5; clear T T'. rewrite <- H5. apply ClosestErrorExpStrict with bo radix p (a*x)%R; auto with zarith. elim phDef; auto. fold FtoRradix; Contradict H2. apply Rle_not_lt; rewrite plDef; rewrite <- H3; rewrite H2. rewrite Rabs_R0; apply Rle_trans with (/4*0)%R; auto with real. apply Rmult_le_compat_l; auto with real. assert (0 < 4)%R; auto with real; apply Rmult_lt_0_compat; auto with real. assert (K':(-dExp bo < Fexp ph)%Z); auto with zarith. assert (Rabs (ph+b) < 2* powerRZ radix (Fexp ph))%R. apply Rmult_lt_reg_l with (/4)%R; auto with real. assert (0 < 4)%R; auto with real; apply Rmult_lt_0_compat; auto with real. apply Rlt_le_trans with (1:=H2). apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix p ph). rewrite plDef; unfold FtoRradix; apply ClosestUlp; auto with zarith. rewrite CanonicFulp; auto with zarith. unfold FtoR; right; simpl; field; auto with real. assert (Fexp ph -1 <= Fexp b)%Z. apply Zle_trans with (Fexp (Float (Zpos (vNum bo)-2*radix) (Fexp ph -1))); [simpl; auto with zarith|idtac]. assert (0 < Zpos (vNum bo)-2*radix )%Z. assert (2*radix < Zpos (vNum bo))%Z; auto with zarith. rewrite pGivesBound; apply Zle_lt_trans with (Zpower_nat radix 2); auto with zarith. unfold Zpower_nat; simpl (nat_iter 2 (Z.mul radix) 1)%Z; auto with zarith. ring_simplify (radix*1)%Z; apply Zmult_le_compat_r; auto with zarith. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. left; split;[split|idtac]; auto with zarith. apply Zle_lt_trans with (Zabs (Zpos (vNum bo) - 2 * radix)); auto with zarith. rewrite Zabs_eq; auto with zarith. simpl; auto with zarith. apply Zle_trans with (Zabs (radix * (Zpos (vNum bo) - 2 * radix))); auto with zarith. rewrite Zabs_Zmult; repeat rewrite Zabs_eq; auto with zarith. apply Zle_trans with (2* (Zpos (vNum bo) - 2 * radix))%Z; auto with zarith. apply Zplus_le_reg_l with (4*radix)%Z. apply Zle_trans with (Zpos (vNum bo)+ Zpos (vNum bo))%Z; auto with zarith. assert (4*radix <= Zpos (vNum bo))%Z; auto with zarith. rewrite pGivesBound; apply Zle_trans with (Zpower_nat radix 3); auto with zarith. unfold Zpower_nat; simpl (nat_iter 3 (Z.mul radix) 1)%Z; auto with zarith. ring_simplify (radix*1)%Z; rewrite Zmult_assoc; apply Zmult_le_compat_r; auto with zarith. apply Zle_trans with (2*radix)%Z; auto with zarith. fold FtoRradix; apply Rplus_le_reg_l with (2*powerRZ radix (Fexp ph))%R. apply Rle_trans with (Rabs (ph + b)+Rabs b)%R; auto with real. apply Rle_trans with (Rabs ph). 2: pattern (FtoRradix ph) at 1; replace (FtoRradix ph) with ((ph+b)+-b)%R;[idtac|ring]. 2:apply Rle_trans with (Rabs (ph + b) + Rabs (-b))%R; [apply Rabs_triang| rewrite Rabs_Ropp; auto with real]. unfold FtoRradix; repeat rewrite <- Fabs_correct; auto. unfold FtoR, Fabs. simpl (Fexp (Float (Zpos (vNum bo) - 2 * radix) (Fexp ph - 1))). simpl (Fexp (Float (Zabs (Fnum (Float (Zpos (vNum bo) - 2 * radix) (Fexp ph - 1)))) (Fexp ph - 1))). replace (Fnum (Float (Zabs (Fnum (Float (Zpos (vNum bo) - 2 * radix) (Fexp ph - 1)))) (Fexp ph - 1))) with (Zabs (Zpos (vNum bo) - 2 * radix)); auto with zarith. simpl (Fnum (Float (Zabs (Fnum ph)) (Fexp ph))). simpl (Fexp (Float (Zabs (Fnum ph)) (Fexp ph))). apply Rle_trans with ((2+ ( Zabs (Zpos (vNum bo) - 2 * radix))/radix)*powerRZ radix (Fexp ph))%R. unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl; ring_simplify (radix*1)%R. right; field; auto with real zarith. apply Rmult_le_compat_r; auto with real zarith. apply Rmult_le_reg_l with radix; auto with real zarith. apply Rle_trans with (IZR (Zpos (vNum bo))). rewrite Zabs_eq; auto with zarith. unfold Zminus; rewrite plus_IZR; rewrite Ropp_Ropp_IZR; rewrite mult_IZR. right; simpl; field; auto with real zarith. case Cph; intros Nph. elim Nph; intros. apply Rle_trans with (IZR (Zabs (radix * Fnum ph))); auto with real zarith. right; rewrite Zabs_Zmult; rewrite mult_IZR; rewrite Zabs_eq; auto with zarith real. elim Nph; intros T1 (T2,T3). Contradict K'; auto with zarith. assert (exists uh':float, (FtoRradix uh'=ph+b)%R /\ (Fbounded bo uh') /\ (Fexp uh'=Fexp ph-1)%Z). unfold FtoRradix; apply BoundedL with p (Fplus radix ph b); auto with zarith float. simpl; apply Zmin_Zle; auto with zarith. apply Fplus_correct; auto with zarith. fold FtoRradix; apply Rlt_le_trans with (1:=H). apply Rle_trans with (powerRZ radix (Fexp ph+1)); [rewrite powerRZ_add; auto with real zarith; simpl|apply Rle_powerRZ; auto with real zarith]. ring_simplify (radix*1)%R; rewrite Rmult_comm; apply Rmult_le_compat_l; auto with real zarith. replace 2%R with (IZR 2); auto with real zarith. elim H3; clear H3; intros uh' T; elim T; intros H5 T'; elim T'; intros H6 H7; clear T T'. assert (FtoRradix uh=uh'). unfold FtoRradix; apply sym_eq. apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; rewrite H5; auto. elim errorBoundedMult with bo radix p (Closest bo radix) a x ph; auto with zarith. 2: apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; intros pl' T; elim T; intros H8 T'; elim T'; intros H9 H10; clear T T'. elim LeExpRound2 with bo radix p (Fexp a+Fexp x)%Z (Fplus radix (Fplus radix ph pl') b) z; auto with zarith. 2: rewrite Fplus_correct; auto with zarith;rewrite Fplus_correct; auto with zarith. 2: fold FtoRradix; rewrite H8. 2: ring_simplify (ph + (a * x - ph) + b)%R; auto with real. 2: simpl; apply Zmin_Zle; auto with zarith. 2: apply Zmin_Zle; auto with zarith. fold FtoRradix; intros z' T; elim T; intros H15 T'; elim T'; intros H16 H17; clear T T'. cut ( exists v : float, (FtoRradix v = uh - z)%R /\ Fbounded bo v /\ (Fexp v=Fexp a+Fexp x)%Z). intros T; elim T; intros v T1; elim T1; intros T2 T3; elim T3; intros; exists v; split; auto. unfold FtoRradix; apply BoundedL with p (Fminus radix uh' z'); auto. simpl; apply Zmin_Zle; auto with zarith. rewrite Fminus_correct; auto with zarith; fold FtoRradix; rewrite <- H3; rewrite H16; auto with real. apply Rlt_le_trans with (powerRZ radix (Fexp ph)); [idtac|apply Rle_powerRZ; auto with real zarith]. fold FtoRradix; rewrite H3; rewrite H5. replace (ph+b-z)%R with ((a*x+b-z)+-pl)%R;[idtac|rewrite plDef; ring]. apply Rle_lt_trans with (Rabs (a*x+b-z)+Rabs (-pl))%R;[apply Rabs_triang|rewrite Rabs_Ropp]. apply Rmult_lt_reg_l with (INR 2); auto with real zarith. apply Rle_lt_trans with (S 1 * Rabs (a * x + b - z) + S 1*Rabs pl)%R;[right; ring|idtac]. apply Rlt_le_trans with (powerRZ radix (Fexp ph)+powerRZ radix (Fexp ph))%R; [idtac|simpl;right; ring]. cut (S 1 * Rabs (a * x + b - z) < powerRZ radix (Fexp ph))%R;[intros I1|idtac]. cut (S 1 * Rabs (pl) <= powerRZ radix (Fexp ph))%R;[intros I2; auto with real|idtac]. apply Rle_trans with (Fulp bo radix p ph). rewrite plDef; unfold FtoRradix; apply ClosestUlp; auto with zarith. rewrite CanonicFulp; auto with zarith real. right; unfold FtoR; simpl; ring. apply Rle_lt_trans with (Fulp bo radix p z). unfold FtoRradix; apply ClosestUlp; auto with zarith. rewrite CanonicFulp; auto with zarith real. unfold FtoR; simpl; ring_simplify (1*powerRZ radix (Fexp z))%R. apply Rlt_powerRZ; auto with real zarith. apply Zle_lt_trans with (Fexp ph-1)%Z; auto with zarith. assert (Fbounded bo (Float (3*radix) (Fexp ph-1))). split; [idtac|simpl; auto with zarith]. apply Zle_lt_trans with (Zabs (3*radix)); auto with zarith. rewrite Zabs_Zmult; repeat rewrite Zabs_eq; auto with zarith. rewrite pGivesBound; apply Zlt_le_trans with (Zpower_nat radix 3); auto with zarith. unfold Zpower_nat; simpl (nat_iter 3 (Z.mul radix) 1)%Z. rewrite Zmult_comm; ring_simplify (radix*1)%Z; apply Zmult_lt_compat_l; auto with zarith. apply Zlt_le_trans with (2*2)%Z; auto with zarith. apply Zle_trans with (2*radix)%Z; auto with zarith. apply Zle_trans with (Fexp (Float (3*radix) (Fexp ph-1))); auto with zarith. apply Zle_trans with (Fexp (Fnormalize radix bo p (Float (3*radix) (Fexp ph-1)))). apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. apply FnormalizeCanonic; auto with zarith. rewrite FnormalizeCorrect; auto. apply Rle_trans with (FtoR radix (Float (3 * radix) (Fexp ph - 1))); [idtac|rewrite <- Fabs_correct; auto; unfold FtoR]. 2: simpl; rewrite Zabs_eq; auto with zarith real. 2: apply Zle_trans with (3*radix)%Z; auto with zarith. apply RoundAbsMonotoner with bo p (Closest bo radix) (a*x+b)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. replace (a*x+b)%R with ((ph+b)+pl)%R;[idtac|rewrite plDef; ring]. apply Rle_trans with (Rabs (ph+b)+Rabs pl)%R;[apply Rabs_triang|idtac]. apply Rle_trans with (2 * powerRZ radix (Fexp ph)+/2*powerRZ radix (Fexp ph))%R; [apply Rplus_le_compat; auto with real|idtac]. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix p ph). rewrite plDef; unfold FtoRradix; apply ClosestUlp; auto with zarith. rewrite CanonicFulp; auto with zarith. unfold FtoR; right; simpl; field; auto with real. apply Rle_trans with ((2+/2)*powerRZ radix (Fexp ph))%R;[right; ring|idtac]. apply Rle_trans with (3*powerRZ radix (Fexp ph))%R; [idtac|right; unfold FtoR; simpl; unfold Zminus; rewrite powerRZ_add; auto with real zarith]. 2: simpl; ring_simplify (radix*1)%R. 2: replace (IZR (match radix with | Z0 => 0%Z | Zpos y' => Zpos ((y' + xO y')) | Zneg y' => Zneg ((y' + xO y')) end)) with (3*radix)%R;[field; auto with real zarith|idtac]. 2: apply trans_eq with (IZR (3*radix)); auto with real zarith; rewrite mult_IZR; simpl; ring. apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (2+1)%R; auto with real. apply Rplus_le_compat_l; apply Rle_trans with (/1)%R; auto with real. apply FcanonicLeastExp with radix bo p; auto with zarith. rewrite FnormalizeCorrect; auto with real zarith. apply FnormalizeCanonic; auto with zarith. assert (0 < pPred (vNum bo))%Z. apply pPredMoreThanOne with radix p; auto with zarith. assert (Fbounded bo (Float (pPred (vNum bo)) (Fexp a+Fexp x+p))). split; simpl; auto with zarith. rewrite Zabs_eq;[unfold pPred|idtac]; auto with zarith. apply Zle_trans with (Fexp (Float (pPred (vNum bo)) (Fexp a+Fexp x+p))); auto with zarith. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. left; split; auto. simpl; rewrite Zabs_Zmult; repeat rewrite Zabs_eq; auto with zarith. apply Zle_trans with (2* pPred (vNum bo))%Z; auto with zarith. unfold pPred, Zpred; apply Zplus_le_reg_l with 2%Z. apply Zle_trans with (Zpos (vNum bo) + Zpos (vNum bo))%Z; auto with zarith. assert (2 <= Zpos (vNum bo))%Z; auto with zarith. rewrite pGivesBound; apply Zle_trans with (Zpower_nat radix 1); auto with zarith. unfold Zpower_nat; simpl; auto with zarith. apply Rle_trans with (FtoR radix (Float (pPred (vNum bo)) (Fexp a + Fexp x + p))). 2: right; rewrite <- Fabs_correct; auto; unfold FtoR; simpl; rewrite Zabs_eq; auto with real zarith. apply RoundAbsMonotoner with bo p (Closest bo radix) (a*x)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. rewrite Rabs_mult; unfold FtoRradix; repeat rewrite <- Fabs_correct; auto. unfold FtoR; simpl; repeat rewrite powerRZ_add; auto with real zarith. apply Rle_trans with (Zabs (Fnum a) * (powerRZ radix (Fexp a) * powerRZ radix (Fexp x) * Zabs (Fnum x)))%R;[right; ring|idtac]. apply Rmult_le_compat; auto with real zarith. apply Rle_trans with (0*Zabs (Fnum x))%R; auto with real. apply Rmult_le_compat_r; auto with real zarith. apply Rlt_le; apply Rmult_lt_0_compat; auto with real zarith. elim Fa; intros; unfold pPred; auto with real zarith. apply Rmult_le_compat_l; auto with real zarith. apply Rlt_le; apply Rmult_lt_0_compat; auto with real zarith. apply Rle_trans with (IZR (Zpos (vNum bo))). elim Fx; intros; auto with real zarith. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; auto with real. Qed. End tBounded. Section tBounded2. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 3 <= p. Variables a x b ph pl uh z:float. Hypothesis Fb: Fbounded bo b. Hypothesis Fa: Fbounded bo a. Hypothesis Fx: Fbounded bo x. Hypothesis Cb: Fcanonic radix bo b. Hypothesis Nph: Fcanonic radix bo ph. Hypothesis Nz: Fcanonic radix bo z. Hypothesis Exp1: (- dExp bo <= Fexp a+Fexp x)%Z. Hypothesis zDef : Closest bo radix (a*x+b)%R z. Hypothesis phDef: Closest bo radix (a*x)%R ph. Hypothesis plDef: (FtoRradix pl=a*x-ph)%R. Hypothesis uhDef: Closest bo radix (ph+b)%R uh. Theorem tBounded: exists v:float, Fbounded bo v /\ (FtoRradix v=uh-z)%R. case (Rle_or_lt 0 (a*x+b)); intros H. unfold FtoRradix; apply tBounded_aux with p a x b ph pl; auto. elim tBounded_aux with bo radix p (Fopp a) x (Fopp b) (Fopp ph) (Fopp pl) (Fopp uh) (Fopp z); auto with zarith float. fold FtoRradix; intros v T; elim T; intros; clear T. exists (Fopp v); split;[apply oppBounded; auto|idtac]. unfold FtoRradix; rewrite Fopp_correct; fold FtoRradix; rewrite H1; unfold FtoRradix; repeat rewrite Fopp_correct; ring. replace (FtoR radix (Fopp a) * FtoR radix x + FtoR radix (Fopp b))%R with (-(a*x+b))%R; [apply ClosestOpp; auto|repeat rewrite Fopp_correct; fold FtoRradix;ring]. replace (FtoR radix (Fopp a) * FtoR radix x )%R with (-(a*x))%R; [apply ClosestOpp; auto|unfold FtoRradix; repeat rewrite Fopp_correct; ring]. repeat rewrite Fopp_correct; fold FtoRradix; rewrite plDef; ring. replace (FtoR radix (Fopp ph) + FtoR radix (Fopp b) )%R with (-(ph+b))%R; [apply ClosestOpp; auto|unfold FtoRradix; repeat rewrite Fopp_correct; ring]. apply Rle_trans with (-(a*x+b))%R; auto with real. right; unfold FtoRradix; repeat rewrite Fopp_correct; ring. Qed. End tBounded2. Section uhExact. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 3 <= p. Variables a x b ph pl uh ul z t v w:float. Hypothesis Fb: Fbounded bo b. Hypothesis Fa: Fbounded bo a. Hypothesis Fx: Fbounded bo x. Hypothesis Cb: Fcanonic radix bo b. Hypothesis Nph: Fcanonic radix bo ph. Hypothesis Nz: Fcanonic radix bo z. Hypothesis Nw: Fcanonic radix bo w. Hypothesis Fpl: Fbounded bo pl. Hypothesis Exp1: (- dExp bo <= Fexp a+Fexp x)%Z. Hypothesis zDef : Closest bo radix (a*x+b)%R z. Hypothesis phDef: Closest bo radix (a*x)%R ph. Hypothesis plDef: (FtoRradix pl=a*x-ph)%R. Hypothesis uhDef: Closest bo radix (ph+b)%R uh. Hypothesis ulDef: (FtoRradix ul=ph+b-uh)%R. Hypothesis tDef : Closest bo radix (uh-z)%R t. Hypothesis vDef : Closest bo radix (pl+ul)%R v. Hypothesis wDef : Closest bo radix (t+v)%R w. Hypothesis Case1:(FtoRradix ul=0)%R. Theorem ErrFmaApprox_1_aux: Fnormal radix bo z -> Fnormal radix bo w -> (Rabs (z+w-(a*x+b)) <= (3*radix/2+/2)*powerRZ radix (2-2*p)*Rabs z)%R. intros M1 M2. apply Rle_trans with (3*powerRZ radix (2-2*p)*Rabs z)%R. assert (FtoRradix t=uh-z)%R. elim tBounded with bo radix p a x b ph pl uh z; auto. fold FtoRradix; intros t' T; elim T; intros T1 T2; clear T. rewrite <- T2; unfold FtoRradix; apply sym_eq. apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; rewrite T2; auto. assert (Rabs (z + w - (a * x + b)) <= (Fulp bo radix p w))%R. replace (z + w - (a * x + b))%R with (-((t+v)-w))%R. 2: rewrite H; replace (a*x)%R with (a*x-0)%R; auto with real; rewrite <- Case1. 2: rewrite ulDef; replace (FtoRradix v) with (FtoRradix pl). 2: rewrite plDef; ring. 2: unfold FtoRradix; apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. 2: apply ClosestRoundedModeP with p; auto with zarith. 2: replace (FtoR radix pl) with (pl+ul)%R; auto;fold FtoRradix; rewrite Case1; auto with real. rewrite Rabs_Ropp; apply Rlt_le; unfold FtoRradix. apply RoundedModeUlp with (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply Rle_trans with (1:=H0). apply Rle_trans with (Rabs (FtoR radix w) * powerRZ radix (Zsucc (- p)))%R. apply FulpLe2; auto with zarith. elim M2; auto. rewrite FcanonicFnormalizeEq; auto with zarith. fold FtoRradix; apply Rle_trans with ((3*(powerRZ radix (Zsucc (-p))*Rabs z))* powerRZ radix (Zsucc (- p)))%R. 2: unfold Zsucc; replace (2-2*p)%Z with (1+1+-p+-p)%Z; auto with zarith. 2: repeat rewrite powerRZ_add; auto with real zarith; right; ring. apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (3*Fulp bo radix p z)%R. 2: apply Rmult_le_compat_l; auto with real zarith. 2: apply Rle_trans with (IZR 3); auto with real zarith; right; simpl; ring. 2: rewrite Rmult_comm; unfold FtoRradix; apply FulpLe2; auto with zarith. 2: elim M1; auto. 2: rewrite FcanonicFnormalizeEq; auto with zarith; left; auto. assert (0 < 1- powerRZ radix (Zsucc (- p)))%R. assert (powerRZ radix (Zsucc (- p)) < 1)%R; auto with real. apply Rlt_le_trans with (powerRZ radix (Zsucc (-1))); unfold Zsucc; auto with zarith real. apply Rmult_le_reg_l with (1- powerRZ radix (Zsucc (- p)))%R; auto with real. apply Rle_trans with (Fulp bo radix p z). apply Rplus_le_reg_l with (powerRZ radix (Zsucc (- p))*Rabs w)%R. apply Rle_trans with (Rabs w);[right; ring|idtac]. pattern (FtoRradix w) at 1; replace (FtoRradix w) with ((z+w-(a*x+b))+((a*x+b)-z))%R; [idtac|ring]. apply Rle_trans with (Rabs (z+w-(a*x+b))+Rabs (((a*x+b)-z)))%R; [apply Rabs_triang|idtac]. apply Rplus_le_compat. apply Rle_trans with (1:=H0). rewrite Rmult_comm; unfold FtoRradix; apply FulpLe2; auto with zarith. elim M2; auto. rewrite FcanonicFnormalizeEq; auto with zarith; left; auto. apply Rlt_le; unfold FtoRradix. apply RoundedModeUlp with (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply Rle_trans with (1*Fulp bo radix p z)%R; auto with real. unfold Fulp; rewrite <- Rmult_assoc; apply Rmult_le_compat_r; auto with real zarith. apply Rplus_le_reg_l with (-1+3*powerRZ radix (Zsucc (- p)))%R. apply Rle_trans with (3 * powerRZ radix (Zsucc (- p)))%R;[right; ring|idtac]. ring_simplify ( -1 + 3 * powerRZ radix (Zsucc (- p)) + (1 - powerRZ radix (Zsucc (- p))) * 3)%R. apply Rle_trans with (powerRZ radix 0); auto with real zarith. apply Rle_trans with (powerRZ radix (2+Zsucc (-p))); auto with real zarith. 2: unfold Zsucc; apply Rle_powerRZ; auto with real zarith. rewrite powerRZ_add; auto with real zarith; simpl. apply Rmult_le_compat_r; auto with real zarith. ring_simplify (radix*1)%R; apply Rle_trans with 4%R; auto with real zarith. apply Rle_trans with (3+1)%R; auto with real; right; ring. apply Rmult_le_compat; auto with real zarith; replace 2%R with (IZR 2); auto with real zarith. apply Rmult_le_compat_r; auto with real. apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (3 * radix / 2)%R; auto with real. apply Rmult_le_reg_l with (IZR 2); auto with real zarith. apply Rle_trans with (radix*3)%R;[apply Rmult_le_compat_r; auto with real zarith| right; simpl; field; auto with real]. apply Rle_trans with (2+1)%R; auto with real. apply Rle_trans with (3 * radix / 2+0)%R; auto with real. Qed. Theorem ErrFmaApprox_1: (Rabs (z+w-(a*x+b)) <= (3*radix/2+/2)*powerRZ radix (2-2*p)*Rabs z)%R. case Nz; intros I1. case Nw; intros I2. apply ErrFmaApprox_1_aux; auto. replace (z+w-(a*x+b))%R with 0%R. rewrite Rabs_R0; apply Rle_trans with (0*Rabs z)%R; [right; ring|apply Rmult_le_compat_r; auto with real]. apply Rlt_le; apply Rmult_lt_0_compat; auto with real zarith. apply Rle_lt_trans with (0+0)%R; auto with real; apply Rplus_lt_compat; auto with real. unfold Rdiv;repeat apply Rmult_lt_0_compat; auto with real zarith. apply Rlt_le_trans with (2+1)%R; auto with real. apply sym_eq; apply trans_eq with (z+w-uh-(pl+ul))%R;[rewrite plDef; rewrite ulDef; ring|idtac]. rewrite Case1; simpl. ring_simplify. assert (FtoRradix t=uh-z)%R. elim tBounded with bo radix p a x b ph pl uh z; auto with zarith. fold FtoRradix; intros t' T; elim T; intros; clear T. rewrite <- H0; unfold FtoRradix; apply sym_eq. apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; rewrite H0; auto. assert (FtoRradix w=t+v)%R. unfold FtoRradix; rewrite <- Fplus_correct; auto; apply Exact1 with bo p; auto with zarith. rewrite Fplus_correct; auto with real zarith. elim I2; intros T1 (T2,T3); rewrite T2. unfold Fplus; simpl; apply Zmin_Zle; auto with zarith float. elim tDef; intros (N1,N2) N3; auto. elim vDef; intros (N1,N2) N3; auto. rewrite H0; rewrite H. cut (FtoRradix pl=v)%R;[intros K; rewrite K; ring |idtac]. unfold FtoRradix;apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. replace (FtoR radix pl) with (pl+ul)%R; auto; rewrite Case1; auto with real. replace (z+w-(a*x+b))%R with 0%R. rewrite Rabs_R0; apply Rle_trans with (0*Rabs z)%R; [right; ring|apply Rmult_le_compat_r; auto with real]. apply Rlt_le; apply Rmult_lt_0_compat; auto with real zarith. apply Rle_lt_trans with (0+0)%R; auto with real; apply Rplus_lt_compat; auto with real. unfold Rdiv;repeat apply Rmult_lt_0_compat; auto with real zarith. apply Rlt_le_trans with (2+1)%R; auto with real. assert (a*x+b=z)%R. unfold FtoRradix; rewrite <- Fmult_correct; try rewrite <- Fplus_correct; auto with zarith. apply sym_eq; apply Exact1 with bo p; auto with zarith. rewrite Fplus_correct; auto; rewrite Fmult_correct; fold FtoRradix; auto with real. elim I1; intros T1 (T2,T3); rewrite T2. simpl; apply Zmin_Zle; auto with zarith float. rewrite H; ring_simplify. apply sym_eq; unfold FtoRradix; apply ClosestZero2 with bo p (t+v)%R; auto. assert (FtoRradix t=uh-z)%R. elim tBounded with bo radix p a x b ph pl uh z; auto with zarith. fold FtoRradix; intros t' T; elim T; intros; clear T. rewrite <- H1; unfold FtoRradix; apply sym_eq. apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; rewrite H1; auto. rewrite H0; replace (FtoRradix uh) with (ph+b-ul)%R. 2: rewrite ulDef; ring. cut (FtoRradix pl=v)%R;[intros K; rewrite <- K |idtac]. 2: unfold FtoRradix;apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. 2: apply ClosestRoundedModeP with p; auto with zarith. 2: replace (FtoR radix pl) with (pl+ul)%R; auto; rewrite Case1; auto with real. rewrite Case1; rewrite plDef; ring_simplify. cut (FtoRradix z=a*x+b)%R;[intros K'; rewrite K'; ring|idtac]. unfold FtoRradix; rewrite <- Fmult_correct; try rewrite <- Fplus_correct; auto with zarith. apply Exact1 with bo p; auto with zarith. rewrite Fplus_correct; auto; rewrite Fmult_correct; fold FtoRradix; auto with real. elim I1; intros T1 (T2,T3); rewrite T2. simpl; apply Zmin_Zle; auto with zarith float. Qed. End uhExact. Section uhInexact. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 4 <= p. Lemma RleRoundedAbs: forall (f:float) (r:R), (Closest bo radix r f) -> (Fcanonic radix bo f) -> (-(dExp bo) < Fexp f)%Z -> ((powerRZ radix (p - 1) + - / (2 * radix)) * powerRZ radix (Fexp f) <= Rabs r)%R. intros f r H H0C H'0. assert (H0:(Fnormal radix bo f)). case H0C; auto; intros. elim H0; intros T1 (T2,T3). Contradict H'0; auto with zarith. assert (exists f':float, f'=(Float (nNormMin radix p) (Fexp f))). exists (Float (nNormMin radix p) (Fexp f)); auto. elim H1; clear H1; intros f' H1. assert (Fbounded bo f'). rewrite H1; split; simpl; auto with zarith float. rewrite Zabs_eq. apply ZltNormMinVnum; auto with zarith. apply Zlt_le_weak; apply nNormPos; auto. assert (Fnormal radix bo f'). split; auto. rewrite H1; simpl; rewrite <- PosNormMin with radix bo p; auto with zarith. assert (f' <= Fabs f)%R. rewrite H1; unfold FtoRradix, FtoR; simpl. apply Rmult_le_compat_r; auto with real zarith. assert (nNormMin radix p <= Zabs (Fnum f))%Z; auto with real zarith. apply pNormal_absolu_min with bo; auto with zarith. apply Rle_trans with (f'-powerRZ radix (Zpred (Fexp f))/2)%R. right; rewrite H1; unfold FtoRradix, FtoR, Zpred, Zminus; simpl. rewrite powerRZ_add with (n:=Fexp f); auto with real zarith; simpl; ring_simplify (radix*1)%R. replace (IZR (nNormMin radix p)) with (powerRZ radix (p + -1)). field; auto with real zarith. repeat apply prod_neq_R0; auto with real zarith. unfold nNormMin; rewrite Zpower_nat_Z_powerRZ; rewrite inj_pred; auto with real zarith. case (Rle_or_lt (f' - powerRZ radix (Zpred (Fexp f)) / 2) (Rabs r)); auto; intros I. absurd (Rabs (Fabs f - Rabs r) <= Rabs ((FPred bo radix p f') - Rabs r))%R. 2: assert (K: (Closest bo radix (Rabs r) (Fabs f))). 2: apply ClosestFabs with p; auto with zarith. 2: elim K; intros K1 K2; unfold FtoRradix; apply K2; auto. 2: apply FBoundedPred; auto with zarith. apply Rlt_not_le. rewrite Rabs_left1. rewrite Rabs_right with (Fabs f - Rabs r)%R. apply Rplus_lt_reg_r with (Rabs r+(FPred bo radix p f'))%R. ring_simplify. apply Rlt_le_trans with (2*(f' - powerRZ radix (Zpred (Fexp f)) / 2))%R. apply Rmult_lt_compat_l; auto with real. apply Rle_trans with (f'+ FPred bo radix p f')%R; auto with real. apply Rle_trans with (2*f'- powerRZ radix (Zpred (Fexp f)))%R; [right; field; auto with real|idtac]. apply Rplus_le_reg_l with (-f'- FPred bo radix p f'+ powerRZ radix (Zpred (Fexp f)))%R. ring_simplify. right; apply trans_eq with (FtoRradix (Fminus radix f' (FPred bo radix p f'))). unfold FtoRradix; rewrite Fminus_correct; auto with real zarith. unfold FtoRradix; rewrite FPredDiff3; auto with zarith. rewrite H1; simpl; unfold FtoR; simpl; ring. rewrite H1; auto. rewrite H1; auto with zarith. rewrite Rplus_comm; auto with real. apply Rle_ge. assert (Rabs r < Fabs f)%R; auto with real. apply Rlt_le_trans with (1:=I). apply Rle_trans with (Fabs f-0)%R; auto with real; unfold Rminus; apply Rplus_le_compat; auto with real zarith. apply Ropp_le_contravar; unfold Rdiv; apply Rlt_le; apply Rmult_lt_0_compat; auto with real zarith. assert ((FPred bo radix p f' <= Rabs r))%R; auto with real. 2: apply Rle_trans with (Rabs r-Rabs r)%R; unfold Rminus; auto with real. case (Rle_or_lt (FPred bo radix p f') (Rabs r)); auto; intros I'. absurd (FPred bo radix p f' < f')%R. 2: unfold FtoRradix; apply FPredLt; auto with zarith. apply Rle_not_lt. apply Rle_trans with (1:=H4). unfold FtoRradix; rewrite Fabs_correct; auto. apply RoundAbsMonotoner with bo p (Closest bo radix) r; auto with zarith real. apply ClosestRoundedModeP with p; auto with zarith. apply FBoundedPred; auto with zarith. Qed. Variables a x b ph pl uh ul z t v w:float. Hypothesis Fb: Fbounded bo b. Hypothesis Fa: Fbounded bo a. Hypothesis Fx: Fbounded bo x. Hypothesis Cb: Fcanonic radix bo b. Hypothesis Nph: Fcanonic radix bo ph. Hypothesis Nuh: Fcanonic radix bo uh. Hypothesis Nz: Fnormal radix bo z. Hypothesis Nw: Fcanonic radix bo w. Hypothesis Nv: Fcanonic radix bo v. Hypothesis Exp1: (- dExp bo <= Fexp a+Fexp x)%Z. Hypothesis zDef : Closest bo radix (a*x+b)%R z. Hypothesis phDef: Closest bo radix (a*x)%R ph. Hypothesis plDef: (FtoRradix pl=a*x-ph)%R. Hypothesis uhDef: Closest bo radix (ph+b)%R uh. Hypothesis ulDef: (FtoRradix ul=ph+b-uh)%R. Hypothesis tDef : Closest bo radix (uh-z)%R t. Hypothesis vDef : Closest bo radix (pl+ul)%R v. Hypothesis wDef : Closest bo radix (t+v)%R w. Hypothesis Fpl: Fbounded bo pl. Hypothesis Ful: Fbounded bo ul. Hypothesis Case2: ~(FtoRradix ul=0)%R. Lemma uhNormal: Fnormal radix bo uh. case Nuh; auto; intros. Contradict Case2. rewrite ulDef. cut (FtoRradix uh=ph+b)%R;[intros K; rewrite K; ring|idtac]. unfold FtoRradix; rewrite <- Fplus_correct; auto. apply Exact1 with bo p; auto with zarith. rewrite Fplus_correct; auto with zarith real. elim H; intros T1 (T2,T3); rewrite T2. unfold Fplus; simpl; apply Zmin_Zle; auto with zarith float. elim phDef; intros (T1',T2') T3'; auto. Qed. Lemma LeExp1: (Fexp ph <= Fexp uh+1)%Z. case (Zle_or_lt (Fexp ph) (Fexp uh+1)); auto with zarith; intros. absurd (FtoRradix ul=0); auto with real. rewrite ulDef; assert (FtoRradix uh=ph+b)%R; auto with real. unfold FtoRradix; apply plusExact2 with bo p; auto with real zarith. Qed. Lemma LeExp2: (Fexp uh <= Fexp z+1)%Z. assert (Rabs (uh-z) <= (1+radix)* Fulp bo radix p uh + Fulp bo radix p z)%R. replace (uh-z)%R with (-(ph+b-uh)+-(a*x-ph)+(a*x+b-z))%R;[idtac|ring]. apply Rle_trans with (1:=Rabs_triang (-(ph+b-uh)+-(a*x-ph)) (a*x+b-z)). apply Rplus_le_compat. apply Rle_trans with (1:=Rabs_triang (-(ph+b-uh)) (-(a*x-ph))). apply Rle_trans with (Fulp bo radix p uh+radix*Fulp bo radix p uh)%R; [apply Rplus_le_compat|right; ring]. rewrite Rabs_Ropp; apply Rlt_le; unfold FtoRradix. apply RoundedModeUlp with (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply Rle_trans with (Fulp bo radix p ph). rewrite Rabs_Ropp; apply Rlt_le; unfold FtoRradix. apply RoundedModeUlp with (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. unfold Fulp; repeat rewrite FcanonicFnormalizeEq; auto with zarith. apply Rle_trans with (powerRZ radix (Fexp uh+1)); [apply Rle_powerRZ; auto with real zarith; generalize LeExp1; auto with zarith| rewrite powerRZ_add; auto with real zarith; simpl; right;ring]. apply Rlt_le; unfold FtoRradix. apply RoundedModeUlp with (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply Zle_trans with (Fexp (Float (Fnum z) (Fexp z+1))); auto with zarith. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. elim Nz; intros A1 A2; elim A1; intros. left; split;[split|idtac];simpl; auto with zarith. fold FtoRradix; apply Rle_trans with (radix*Rabs z)%R. 2: unfold FtoRradix; repeat rewrite <- Fabs_correct; auto; unfold FtoR; simpl. 2: rewrite powerRZ_add; auto with real zarith; simpl; right; ring. apply Rmult_le_reg_l with (1-(1+radix)*powerRZ radix (Zsucc (-p)))%R. assert ((1+radix) * powerRZ radix (Zsucc (-p)) < 1)%R; auto with real. apply Rlt_le_trans with ((radix*radix)*powerRZ radix (Zsucc (-p)))%R; [apply Rmult_lt_compat_r; auto with real zarith|idtac]. apply Rlt_le_trans with (radix+radix)%R; auto with real. apply Rle_trans with (2*radix)%R; [right; ring|apply Rmult_le_compat_r; auto with real zarith]. replace 2%R with (IZR 2); auto with real zarith. apply Rle_trans with (powerRZ radix (2+Zsucc (-p))); [right; rewrite powerRZ_add; auto with real zarith; simpl; ring|idtac]. apply Rle_trans with (powerRZ radix 0); auto with real zarith. apply Rle_trans with (Rabs uh-(1+radix)*(Rabs uh*powerRZ radix (Zsucc (-p))))%R; [right; ring|idtac]. apply Rle_trans with (Rabs uh-(1+radix)*Fulp bo radix p uh)%R; [unfold Rminus;apply Rplus_le_compat_l|idtac]. apply Ropp_le_contravar; apply Rmult_le_compat_l; auto with real. apply Rle_trans with (1+0)%R; auto with real. apply Rle_trans with 1%R; auto with real. unfold FtoRradix; apply FulpLe2; auto with zarith. elim uhDef; auto. rewrite FcanonicFnormalizeEq; auto with zarith. apply uhNormal. apply Rle_trans with (Rabs z+Fulp bo radix p z)%R. apply Rplus_le_reg_l with (-Rabs z+ (1+radix) * Fulp bo radix p uh)%R. ring_simplify. apply Rle_trans with (Rabs uh - Rabs z)%R;[right; ring|idtac]. apply Rle_trans with (Rabs (uh-z));[apply Rabs_triang_inv|idtac]. apply Rle_trans with (1:=H); right; ring. apply Rle_trans with (Rabs z+(Rabs z*powerRZ radix (Zsucc (-p))))%R; [apply Rplus_le_compat_l|idtac]. unfold FtoRradix; apply FulpLe2; auto with zarith. elim zDef; auto. rewrite FcanonicFnormalizeEq; auto with zarith; left; auto. rewrite <- Rmult_assoc. apply Rle_trans with ((1+ powerRZ radix (Zsucc (- p)))*Rabs z)%R; [right; ring|apply Rmult_le_compat_r; auto with real]. apply Rplus_le_reg_l with (-1+(1+radix)*radix*powerRZ radix (Zsucc (- p)))%R. apply Rle_trans with ((1+radix+radix*radix)*powerRZ radix (Zsucc (- p)))%R;[right; ring|idtac]. apply Rle_trans with (radix-1)%R;[idtac|right; ring]. apply Rle_trans with ((radix*radix*radix)*powerRZ radix (Zsucc (-p)))%R; [apply Rmult_le_compat_r; auto with real zarith|idtac]. apply Rle_trans with (radix+radix+radix*radix)%R; auto with real. apply Rle_trans with ((2+radix)*radix)%R; [right; ring|apply Rmult_le_compat_r; auto with real zarith]. apply Rle_trans with (radix+radix)%R; auto with real. replace 2%R with (IZR 2); auto with real zarith. apply Rle_trans with (2*radix)%R; [right; ring|apply Rmult_le_compat_r; auto with real zarith]. replace 2%R with (IZR 2); auto with real zarith. apply Rle_trans with (powerRZ radix (3+Zsucc (-p))); [right; rewrite powerRZ_add; auto with real zarith; simpl; ring|idtac]. apply Rle_trans with (powerRZ radix 0); auto with real zarith. unfold Zsucc; apply Rle_powerRZ; auto with real zarith. assert (2 <= radix)%R; auto with real. replace 2%R with (IZR 2); auto with real zarith. simpl; apply Rplus_le_reg_l with 1%R; auto with real. ring_simplify (1 + (radix - 1))%R; auto with real. Qed. Lemma LeExp3: (Fexp ph = Fexp uh+1)%Z -> (Fexp uh = Fexp z+1)%Z -> False. intros. absurd (powerRZ radix (p+Fexp z) <= Rabs z)%R. apply Rlt_not_le. unfold FtoRradix; rewrite <- Fabs_correct; auto; unfold FtoR; simpl. rewrite powerRZ_add; auto with real zarith; apply Rmult_lt_compat_r; auto with real zarith. elim Nz; intros A1 A2; elim A1; intros. apply Rlt_le_trans with (IZR (Zpos (vNum bo))); auto with zarith real. right; rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; auto with real. apply Rle_trans with (FtoRradix (Float 1 (p+Fexp z))). right; unfold FtoRradix, FtoR; simpl; ring. unfold FtoRradix; apply RoundAbsMonotonel with bo p (Closest bo radix) (a*x+b)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. elim Nz; intros A1 A2; elim A1; intros; split; simpl; auto with zarith float. apply vNumbMoreThanOne with radix p; auto with zarith. apply Rle_trans with (powerRZ radix (p+Fexp z));[right; unfold FtoRradix, FtoR; simpl; ring|idtac]. replace (a*x+b)%R with (a*x-(-b))%R;[idtac|ring]. apply Rle_trans with (Rabs (a*x)-Rabs (-b))%R;[rewrite Rabs_Ropp|apply Rabs_triang_inv]. apply Rle_trans with ((powerRZ radix (p-1) -/(2*radix))*powerRZ radix (Fexp ph) -(powerRZ radix p-1)*powerRZ radix (Fexp b))%R. apply Rle_trans with ((powerRZ radix (p-1) -/(2*radix))*powerRZ radix (Fexp z+2) -(powerRZ radix p-1)*powerRZ radix (Fexp z))%R. apply Rle_trans with ((powerRZ radix (p + 1) - radix/ 2 ) * powerRZ radix (Fexp z) - (powerRZ radix p-1) * powerRZ radix (Fexp z))%R; [idtac|unfold Rminus; apply Rplus_le_compat_r]. rewrite powerRZ_add; auto with real zarith. apply Rle_trans with ((powerRZ radix (p + 1) - radix / 2-powerRZ radix p+1)* powerRZ radix (Fexp z))%R;[apply Rmult_le_compat_r; auto with real zarith|right; ring]. case (Zle_lt_or_eq 2 radix); auto with zarith; intros I. assert (3 <= radix)%Z; auto with zarith. assert (3 <= radix)%R; auto with real zarith. replace 3%R with (IZR 3); auto with real zarith; simpl; ring. apply Rplus_le_reg_l with (radix/2-1-powerRZ radix p)%R. ring_simplify. unfold Rminus; rewrite Rplus_comm. apply Rle_trans with (0+radix/2)%R; auto with real. apply Rle_trans with (0+radix*1)%R; unfold Rdiv; auto with real. apply Rplus_le_compat_l; apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (/1)%R; auto with real. apply Rle_trans with (powerRZ radix 1);[simpl; right; ring|idtac]. apply Rle_trans with (powerRZ radix p);auto with real zarith. apply Rle_trans with (- 2*powerRZ radix p + powerRZ radix p * (3))%R; [right; ring|auto with real]. rewrite powerRZ_add; auto with real zarith. apply Rplus_le_compat_l; apply Rmult_le_compat_l; auto with real zarith. simpl; ring_simplify (radix*1)%R; auto with real. right; rewrite <- I; rewrite powerRZ_add; auto with real zarith; simpl. field; auto with real. unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith; simpl. ring_simplify (radix*1)%R; right; field; auto with real. repeat apply prod_neq_R0; auto with real zarith. unfold Rminus; apply Rplus_le_compat. replace (Fexp ph) with (Fexp z+2)%Z; auto with real zarith. apply Ropp_le_contravar; apply Rmult_le_compat_l. assert (1 <= powerRZ radix p)%R; auto with real. apply Rle_trans with (powerRZ radix 0); auto with real zarith. apply Rplus_le_reg_l with 1%R. ring_simplify (1+0)%R; apply Rle_trans with (1:=H1); right; ring. apply Rle_powerRZ; auto with real zarith. apply Zle_trans with (Fexp uh -1)%Z; auto with zarith. case (Zle_or_lt (Fexp b) (Fexp uh-1)); auto with zarith; intros. absurd (FtoRradix ul=0); auto with real. elim errorBoundedPlus with bo radix p ph b uh; auto with zarith. 2: elim phDef; auto. fold FtoRradix; intros ul' T; elim T; intros H2 T'; elim T'; intros; clear T T'. rewrite ulDef; rewrite <- H2. absurd (Fexp uh < Fexp uh)%Z; auto with zarith. apply Zle_lt_trans with (Fexp ul'); auto with zarith. rewrite H4; apply Zmin_Zle; auto with zarith. apply ClosestErrorExpStrict with bo radix p (ph+b)%R; auto with zarith. elim uhDef; auto. fold FtoRradix; rewrite H2; rewrite <- ulDef; auto with real. unfold Rminus; apply Rplus_le_compat. apply RleRoundedAbs; auto. assert (-dExp bo <= Fexp uh)%Z; auto with zarith. elim uhDef; intros I1 I2; elim I1; auto. apply Ropp_le_contravar; unfold FtoRradix; rewrite <- Fabs_correct; auto. unfold FtoR; simpl; apply Rmult_le_compat_r; auto with real zarith. elim Fb; intros. apply Rle_trans with (Zpred (Zpos (vNum bo))); auto with real zarith. right; unfold Zpred, Zminus; rewrite plus_IZR; rewrite pGivesBound; simpl. rewrite Zpower_nat_Z_powerRZ; auto with real. Qed. Lemma LeExp: (powerRZ radix (Fexp ph)+powerRZ radix (Fexp uh) <= 2*powerRZ radix (Fexp z+1))%R. apply Rle_trans with (powerRZ radix (Fexp z + 1)+ powerRZ radix (Fexp z + 1))%R;[idtac|right; ring]. apply Rplus_le_compat; apply Rle_powerRZ; auto with real zarith. generalize LeExp1; generalize LeExp2; generalize LeExp3; intros. case (Zle_lt_or_eq _ _ H0); intros; auto with zarith. generalize LeExp1; generalize LeExp2; generalize LeExp3; intros; auto. Qed. Lemma vLe_aux: (Rabs (pl+ul) <= powerRZ radix (Fexp z)*radix)%R. apply Rle_trans with (powerRZ radix (Fexp z+1)); [idtac|rewrite powerRZ_add; auto with real zarith; simpl; right; ring]. apply Rle_trans with (Rabs pl+Rabs ul)%R;[apply Rabs_triang|idtac]. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (powerRZ radix (Fexp ph)+powerRZ radix (Fexp uh))%R; [idtac|apply LeExp]. apply Rle_trans with (INR 2*Rabs pl+INR 2*Rabs ul)%R;[simpl; right; ring|idtac]. apply Rplus_le_compat. apply Rle_trans with (Fulp bo radix p ph). rewrite plDef; unfold FtoRradix; apply ClosestUlp; auto with zarith. rewrite CanonicFulp; auto with zarith;unfold FtoR; simpl; right; ring. apply Rle_trans with (Fulp bo radix p uh). rewrite ulDef; unfold FtoRradix; apply ClosestUlp; auto with zarith. rewrite CanonicFulp; auto with zarith;unfold FtoR; simpl; right; ring. Qed. Lemma vLe: (Rabs v <= powerRZ radix (Fexp z)*radix)%R. assert (powerRZ radix (Fexp z) * radix=Float radix (Fexp z))%R. unfold FtoRradix, FtoR; simpl; ring. rewrite H. unfold FtoRradix; apply RoundAbsMonotoner with bo p (Closest bo radix) (pl+ul)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. elim zDef; intros I1 I2; elim I1; intros; split; simpl; auto with zarith. rewrite Zabs_eq; auto with zarith. apply Zlt_trans with (pPred (vNum bo)); [apply pPredMoreThanRadix with p|unfold pPred]; auto with zarith. fold FtoRradix; rewrite <- H; apply vLe_aux. Qed. Lemma tLe: (Rabs t <= powerRZ radix (Fexp z)*(radix+1))%R. replace (FtoRradix t) with (uh-z)%R. replace (uh-z)%R with ((a*x+b-z)+(-(a*x-ph)+-((ph+b)-uh)))%R;[idtac|ring]. apply Rle_trans with (Rabs (a*x+b-z)+Rabs ( - (a * x - ph) + - (ph + b - uh)))%R; [apply Rabs_triang|idtac]. apply Rle_trans with (powerRZ radix (Fexp z)+powerRZ radix (Fexp z)*radix)%R;[idtac|right; ring]. apply Rplus_le_compat. apply Rle_trans with (Fulp bo radix p z). apply Rlt_le; unfold FtoRradix; apply RoundedModeUlp with (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. rewrite CanonicFulp; auto with zarith;[unfold FtoR; simpl; right; ring|left; auto]. apply Rle_trans with (powerRZ radix (Fexp z+1)); [idtac|rewrite powerRZ_add; auto with real zarith; simpl; right; ring]. apply Rle_trans with (Rabs (-(a*x-ph))+Rabs (-(ph+b-uh)))%R;[apply Rabs_triang|idtac]. rewrite Rabs_Ropp; rewrite Rabs_Ropp. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (powerRZ radix (Fexp ph)+powerRZ radix (Fexp uh))%R; [idtac|apply LeExp]. apply Rle_trans with (INR 2*Rabs (a*x-ph)+INR 2*Rabs (ph+b-uh))%R;[simpl; right; ring|idtac]. apply Rplus_le_compat. apply Rle_trans with (Fulp bo radix p ph). unfold FtoRradix; apply ClosestUlp; auto with zarith. rewrite CanonicFulp; auto with zarith;unfold FtoR; simpl; right; ring. apply Rle_trans with (Fulp bo radix p uh). unfold FtoRradix; apply ClosestUlp; auto with zarith. rewrite CanonicFulp; auto with zarith;unfold FtoR; simpl; right; ring. elim tBounded with bo radix p a x b ph pl uh z; auto with zarith. fold FtoRradix; intros t' T; elim T; intros; clear T. rewrite <- H0; unfold FtoRradix. apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; rewrite H0; auto. left; auto. Qed. Lemma wLe: (Rabs w <= powerRZ radix (Fexp z)*(2*radix+1))%R. assert (powerRZ radix (Fexp z) * (2*radix+1)=Float (2*radix+1) (Fexp z))%R. apply trans_eq with (powerRZ radix (Fexp z) * (2 * radix + 1)%Z)%R. rewrite plus_IZR; rewrite mult_IZR; simpl; ring. unfold FtoRradix, FtoR; simpl; ring. rewrite H. unfold FtoRradix; apply RoundAbsMonotoner with bo p (Closest bo radix) (t+v)%R; auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. elim zDef; intros I1 I2; elim I1; intros; split; [idtac|simpl; auto with zarith]. apply Zle_lt_trans with (Zabs (2*radix+1)); auto with zarith. rewrite Zabs_eq; auto with zarith. apply Zlt_le_trans with (2*radix+radix)%Z; auto with zarith. apply Zle_trans with (3*radix)%Z; auto with zarith. rewrite pGivesBound; apply Zle_trans with (Zpower_nat radix 3); auto with zarith. unfold Zpower_nat; simpl (nat_iter 3 (Z.mul radix) 1)%Z. rewrite Zmult_comm; apply Zmult_le_compat_l; auto with zarith. ring_simplify (radix*1)%Z; apply Zle_trans with (2*2)%Z; auto with zarith. apply Zmult_le_compat; auto with zarith. fold FtoRradix; rewrite <- H. apply Rle_trans with (Rabs t+Rabs v)%R;[apply Rabs_triang|idtac]. generalize tLe; generalize vLe; intros. apply Rle_trans with ( powerRZ radix (Fexp z) * (radix + 1)+powerRZ radix (Fexp z) * radix)%R; [auto with real|right; ring]. Qed. Theorem ErrFmaApprox_2_aux:(Rabs (z+w-(a*x+b)) <= (3*radix/2+/2)*powerRZ radix (2-2*p)*Rabs z)%R. replace (z+w-(a*x+b))%R with ((t-(uh-z))+-(t+v-w)+-(pl+ul-v))%R; [idtac|rewrite ulDef; rewrite plDef; ring]. pattern (FtoRradix t) at 1; replace (FtoRradix t) with (uh-z)%R. 2: elim tBounded with bo radix p a x b ph pl uh z; auto with zarith. 2: fold FtoRradix; intros t' T; elim T; intros; clear T. 2: rewrite <- H0; unfold FtoRradix. 2: apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. 2: apply ClosestRoundedModeP with p; auto with zarith. 2: fold FtoRradix; rewrite H0; auto. 2: left; auto. replace (uh - z - (uh - z) + - (t + v - w) + - (pl + ul - v))%R with (-((t + v - w)+(pl + ul - v)))%R;[rewrite Rabs_Ropp|ring]. apply Rle_trans with (Rabs (t+v-w)+Rabs (pl+ul-v))%R;[apply Rabs_triang|idtac]. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (INR 2*Rabs (t + v - w) + INR 2*Rabs (pl + ul - v))%R;[right; simpl; ring|idtac]. case Nw; intros Nw'. case Nv; intros Nv'. apply Rle_trans with ((Fulp bo radix p w)+(Fulp bo radix p v))%R. apply Rplus_le_compat; unfold FtoRradix; apply ClosestUlp; auto with zarith. apply Rle_trans with (Rabs w*powerRZ radix (Zsucc (-p))+Rabs v*powerRZ radix (Zsucc (-p)))%R. apply Rplus_le_compat; unfold FtoRradix; apply FulpLe2; auto with zarith. elim wDef; auto. rewrite FcanonicFnormalizeEq; auto with zarith. elim vDef; auto. rewrite FcanonicFnormalizeEq; auto with zarith. apply Rle_trans with (powerRZ radix (Zsucc (-p))*(Rabs w+Rabs v))%R;[right; ring|idtac]. generalize wLe; generalize vLe; intros. apply Rle_trans with (powerRZ radix (Zsucc (-p))*(powerRZ radix (Fexp z) * (2 * radix + 1) + powerRZ radix (Fexp z) *radix))%R; [apply Rmult_le_compat_l; auto with real zarith|idtac]. apply Rle_trans with ((3*radix+1)*(powerRZ radix (Zsucc (- p))*(powerRZ radix (Fexp z))))%R; [right; ring|idtac]. apply Rle_trans with ((3 * radix + 1) * (powerRZ radix (2- 2*p) *Rabs z))%R; [idtac|right; field; auto with real]. apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (0+1)%R; auto with real. assert (0 < 3*radix)%R; auto with real. apply Rmult_lt_0_compat; auto with real zarith. apply Rlt_le_trans with (2+1)%R;auto with real. replace (2-2*p)%Z with (Zsucc (-p)+Zsucc (-p))%Z;[idtac|unfold Zsucc; ring]. rewrite powerRZ_add; auto with real zarith. rewrite Rmult_assoc; apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (Fulp bo radix p z). unfold Fulp;rewrite FcanonicFnormalizeEq; auto with zarith real; left; auto. unfold FtoRradix; rewrite Rmult_comm; apply FulpLe2; auto with zarith. elim zDef; auto. rewrite FcanonicFnormalizeEq; auto with zarith real; left; auto. apply Rle_trans with (2%nat * Rabs (t + v - w))%R. replace (pl+ul-v)%R with 0%R. rewrite Rabs_R0; right; ring. cut (FtoRradix v=pl+ul)%R;[intros K; rewrite K; ring|idtac]. unfold FtoRradix; rewrite <- Fplus_correct; auto. apply Exact1 with bo p; auto with zarith. rewrite Fplus_correct; auto with zarith real. elim Nv'; intros T1 (T2,T3); rewrite T2. unfold Fplus; simpl; apply Zmin_Zle; auto with zarith float. apply Rle_trans with (Fulp bo radix p w). unfold FtoRradix; apply ClosestUlp; auto with zarith. apply Rle_trans with (Rabs w*powerRZ radix (Zsucc (-p)))%R. unfold FtoRradix; apply FulpLe2; auto with zarith. elim wDef; auto. rewrite FcanonicFnormalizeEq; auto with zarith. apply Rle_trans with (powerRZ radix (Zsucc (-p))*Rabs w)%R;[right; ring|idtac]. generalize wLe; intros. apply Rle_trans with (powerRZ radix (Zsucc (-p))*(powerRZ radix (Fexp z) * (2 * radix + 1)))%R; [apply Rmult_le_compat_l; auto with real zarith|idtac]. apply Rle_trans with ((3*radix+1)*(powerRZ radix (Zsucc (- p))*(powerRZ radix (Fexp z))))%R. apply Rle_trans with ((2 * radix + 1) * (powerRZ radix (Zsucc (- p)) * powerRZ radix (Fexp z)))%R; [right; ring|idtac]. apply Rmult_le_compat_r; auto with real zarith. apply Rmult_le_pos; auto with real zarith. apply Rle_trans with ((3 * radix + 1) * (powerRZ radix (2- 2*p) *Rabs z))%R; [idtac|right; field; auto with real]. apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (0+1)%R; auto with real. assert (0 < 3*radix)%R; auto with real. apply Rmult_lt_0_compat; auto with real zarith. apply Rlt_le_trans with (2+1)%R;auto with real. replace (2-2*p)%Z with (Zsucc (-p)+Zsucc (-p))%Z;[idtac|unfold Zsucc; ring]. rewrite powerRZ_add; auto with real zarith. rewrite Rmult_assoc; apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (Fulp bo radix p z). unfold Fulp;rewrite FcanonicFnormalizeEq; auto with zarith real; left; auto. unfold FtoRradix; rewrite Rmult_comm; apply FulpLe2; auto with zarith. elim zDef; auto. rewrite FcanonicFnormalizeEq; auto with zarith real; left; auto. apply Rle_trans with (2%nat * Rabs (pl + ul - v))%R. replace (t+v-w)%R with 0%R. rewrite Rabs_R0; right; ring. cut (FtoRradix w=t+v)%R;[intros K; rewrite K; ring|idtac]. unfold FtoRradix; rewrite <- Fplus_correct; auto. apply Exact1 with bo p; auto with zarith. rewrite Fplus_correct; auto with zarith real. elim Nw'; intros T1 (T2,T3); rewrite T2. unfold Fplus; simpl; apply Zmin_Zle; auto with zarith float. elim tDef; intros (T1',T2') T3'; auto. elim vDef; intros (T1',T2') T3'; auto. case Nv; intros Nv'. apply Rle_trans with (Fulp bo radix p v). unfold FtoRradix; apply ClosestUlp; auto with zarith. apply Rle_trans with (Rabs v*powerRZ radix (Zsucc (-p)))%R. unfold FtoRradix; apply FulpLe2; auto with zarith. elim vDef; auto. rewrite FcanonicFnormalizeEq; auto with zarith. apply Rle_trans with (powerRZ radix (Zsucc (-p))*Rabs v)%R;[right; ring|idtac]. generalize vLe; intros. apply Rle_trans with (powerRZ radix (Zsucc (-p))*(powerRZ radix (Fexp z) * (radix)))%R; [apply Rmult_le_compat_l; auto with real zarith|idtac]. apply Rle_trans with ((3*radix+1)*(powerRZ radix (Zsucc (- p))*(powerRZ radix (Fexp z))))%R. apply Rle_trans with ((radix) * (powerRZ radix (Zsucc (- p)) * powerRZ radix (Fexp z)))%R; [right; ring|idtac]. apply Rmult_le_compat_r; auto with real zarith. apply Rmult_le_pos; auto with real zarith. apply Rle_trans with (1*radix+0)%R; [right; ring|idtac]. apply Rplus_le_compat; auto with real zarith. apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with 2%R; auto with real. apply Rle_trans with ((3 * radix + 1) * (powerRZ radix (2- 2*p) *Rabs z))%R; [idtac|right; field; auto with real]. apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (0+1)%R; auto with real. assert (0 < 3*radix)%R; auto with real. apply Rmult_lt_0_compat; auto with real zarith. apply Rlt_le_trans with (2+1)%R;auto with real. replace (2-2*p)%Z with (Zsucc (-p)+Zsucc (-p))%Z;[idtac|unfold Zsucc; ring]. rewrite powerRZ_add; auto with real zarith. rewrite Rmult_assoc; apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (Fulp bo radix p z). unfold Fulp;rewrite FcanonicFnormalizeEq; auto with zarith real; left; auto. unfold FtoRradix; rewrite Rmult_comm; apply FulpLe2; auto with zarith. elim zDef; auto. rewrite FcanonicFnormalizeEq; auto with zarith real; left; auto. replace (pl+ul-v)%R with 0%R. apply Rle_trans with 0%R. rewrite Rabs_R0; right; ring. repeat apply Rmult_le_pos; auto with real zarith. apply Rle_trans with (0+0)%R; try apply Rplus_le_compat;auto with real. unfold Rdiv; repeat apply Rmult_le_pos; auto with real zarith. apply Rle_trans with 2%R; auto with real. cut (FtoRradix v=pl+ul)%R;[intros K; rewrite K; ring|idtac]. unfold FtoRradix; rewrite <- Fplus_correct; auto. apply Exact1 with bo p; auto with zarith. rewrite Fplus_correct; auto with zarith real. elim Nv'; intros T1 (T2,T3); rewrite T2. unfold Fplus; simpl; apply Zmin_Zle; auto with zarith float. Qed. End uhInexact. Section uhInexact2. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 4 <= p. Variables a x b ph pl uh ul z t v w:float. Hypothesis Fb: Fbounded bo b. Hypothesis Fa: Fbounded bo a. Hypothesis Fx: Fbounded bo x. Hypothesis Cb: Fcanonic radix bo b. Hypothesis Nph: Fcanonic radix bo ph. Hypothesis Nuh: Fcanonic radix bo uh. Hypothesis Nz: Fcanonic radix bo z. Hypothesis Nw: Fcanonic radix bo w. Hypothesis Nv: Fcanonic radix bo v. Hypothesis Exp1: (- dExp bo <= Fexp a+Fexp x)%Z. Hypothesis zDef : Closest bo radix (a*x+b)%R z. Hypothesis phDef: Closest bo radix (a*x)%R ph. Hypothesis plDef: (FtoRradix pl=a*x-ph)%R. Hypothesis uhDef: Closest bo radix (ph+b)%R uh. Hypothesis ulDef: (FtoRradix ul=ph+b-uh)%R. Hypothesis tDef : Closest bo radix (uh-z)%R t. Hypothesis vDef : Closest bo radix (pl+ul)%R v. Hypothesis wDef : Closest bo radix (t+v)%R w. Hypothesis Fpl: Fbounded bo pl. Hypothesis Ful: Fbounded bo ul. Hypothesis Case2: ~(FtoRradix ul=0)%R. Theorem ErrFmaApprox_2:(Rabs (z+w-(a*x+b)) <= (3*radix/2+/2)*powerRZ radix (2-2*p)*Rabs z)%R. case Nz; intros I. unfold FtoRradix; apply ErrFmaApprox_2_aux with bo ph pl uh ul t v; auto. replace (z+w-(a*x+b))%R with 0%R. rewrite Rabs_R0; apply Rle_trans with (0*Rabs z)%R; [right; ring|apply Rmult_le_compat_r; auto with real]. apply Rlt_le; apply Rmult_lt_0_compat; auto with real zarith. apply Rle_lt_trans with (0+0)%R; auto with real; apply Rplus_lt_compat; auto with real. unfold Rdiv;repeat apply Rmult_lt_0_compat; auto with real zarith. apply Rlt_le_trans with (2+1)%R; auto with real. assert (FtoRradix z=a*x+b)%R. unfold FtoRradix; rewrite <- Fmult_correct; try rewrite <- Fplus_correct; auto with zarith. apply Exact1 with bo p; auto with zarith. rewrite Fplus_correct; try rewrite Fmult_correct; auto with zarith real. elim I; intros T1 (T2,T3); rewrite T2. unfold Fplus, Fminus; simpl; apply Zmin_Zle; auto with zarith float. rewrite H; ring_simplify. apply sym_eq; apply ClosestZero2 with bo p (t+v)%R; auto with zarith. assert (FtoRradix t=uh-z)%R. elim tBounded with bo radix p a x b ph pl uh z; auto with zarith. fold FtoRradix; intros t' T; elim T; intros; clear T. rewrite <- H1; unfold FtoRradix; apply sym_eq. apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; rewrite H1; auto. cut (FtoRradix v=-t)%R;[intros K; rewrite K; ring|idtac]. unfold FtoRradix; rewrite <- Fopp_correct; apply sym_eq. apply RoundedModeProjectorIdemEq with bo p (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. apply oppBounded; elim tDef; auto. replace (FtoR radix (Fopp t)) with (pl+ul)%R; auto. rewrite Fopp_correct; fold FtoRradix. rewrite plDef; rewrite ulDef; rewrite H0; rewrite H; ring. Qed. End uhInexact2. Section Total. Variable bo : 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 bo) = Zpower_nat radix p. Hypothesis precisionGreaterThanOne : 4 <= p. Variables a x b ph pl uh ul z t v w:float. Hypothesis Fb: Fbounded bo b. Hypothesis Fa: Fbounded bo a. Hypothesis Fx: Fbounded bo x. Hypothesis zDef : Closest bo radix (a*x+b)%R z. Hypothesis phDef: Closest bo radix (a*x)%R ph. Hypothesis plDef: (FtoRradix pl=a*x-ph)%R. Hypothesis uhDef: Closest bo radix (ph+b)%R uh. Hypothesis ulDef: (FtoRradix ul=ph+b-uh)%R. Hypothesis tDef : Closest bo radix (uh-z)%R t. Hypothesis vDef : Closest bo radix (pl+ul)%R v. Hypothesis wDef : Closest bo radix (t+v)%R w. Hypothesis Exp1: (- dExp bo <= Fexp a+Fexp x)%Z. Theorem ErrFmaApprox:(Rabs (z+w-(a*x+b)) <= (3*radix/2+/2)*powerRZ radix (2-2*p)*Rabs z)%R. elim errorBoundedMult with bo radix p (Closest bo radix) a x ph; auto with zarith. 2: apply ClosestRoundedModeP with p; auto with zarith. fold FtoRradix; intros pl' T; elim T; intros M1 T'; elim T'; intros M2 M3; clear T T'. unfold FtoRradix; rewrite <- FnormalizeCorrect with radix bo p b; auto. unfold FtoRradix; rewrite <- FnormalizeCorrect with radix bo p z; auto. unfold FtoRradix; rewrite <- FnormalizeCorrect with radix bo p w; auto. case (Req_dec ul 0); intros. apply ErrFmaApprox_1 with bo (Fnormalize radix bo p ph) pl' uh ul t v; auto with zarith; try rewrite FnormalizeCorrect; try apply FnormalizeCanonic; auto with zarith real. apply FnormalizeBounded; auto with zarith. elim phDef; auto. elim zDef; auto. elim wDef; auto. apply (ClosestCompatible bo radix (a*x+b)%R (a*x+b)%R z); auto with zarith. rewrite FnormalizeCorrect; auto with zarith. apply FnormalizeBounded; auto with zarith; elim zDef; auto. apply (ClosestCompatible bo radix (a*x)%R (a*x)%R ph); auto with zarith. rewrite FnormalizeCorrect; auto with zarith. apply FnormalizeBounded; auto with zarith; elim phDef; auto. rewrite FnormalizeCorrect; auto with zarith real. rewrite FnormalizeCorrect; auto with zarith real. fold FtoRradix; rewrite M1; rewrite <- plDef; auto. apply (ClosestCompatible bo radix (t+v)%R (t+v)%R w); auto with zarith. rewrite FnormalizeCorrect; auto with zarith. apply FnormalizeBounded; auto with zarith; elim wDef; auto. elim errorBoundedPlus with bo radix p ph b uh; auto with zarith. 2: elim phDef; auto. fold FtoRradix; intros ul' (M4,(M5,M6)). apply ErrFmaApprox_2 with bo (Fnormalize radix bo p ph) pl' (Fnormalize radix bo p uh) ul' t (Fnormalize radix bo p v); auto; try rewrite FnormalizeCorrect; try apply FnormalizeCanonic; auto with real zarith float. elim phDef; auto. elim uhDef; auto. elim zDef; auto. elim wDef; auto. elim vDef; auto. apply (ClosestCompatible bo radix (a*x+b)%R (a*x+b)%R z); auto with zarith. rewrite FnormalizeCorrect; auto with zarith. apply FnormalizeBounded; auto with zarith; elim zDef; auto. apply (ClosestCompatible bo radix (a*x)%R (a*x)%R ph); auto with zarith. rewrite FnormalizeCorrect; auto with zarith. apply FnormalizeBounded; auto with zarith; elim phDef; auto. apply (ClosestCompatible bo radix (ph+b)%R (ph+(Fnormalize radix bo p b))%R uh); auto with zarith. unfold FtoRradix; rewrite FnormalizeCorrect; auto with zarith. rewrite FnormalizeCorrect; auto with zarith. apply FnormalizeBounded; auto with zarith; elim uhDef; auto. repeat rewrite FnormalizeCorrect; auto with zarith real. rewrite FnormalizeCorrect; auto with zarith real. apply (ClosestCompatible bo radix (pl+ul)%R (pl'+ul')%R v); auto with zarith. rewrite M1; rewrite plDef; rewrite M4; rewrite ulDef; auto. rewrite FnormalizeCorrect; auto with zarith. apply FnormalizeBounded; auto with zarith; elim vDef; auto. apply (ClosestCompatible bo radix (t+v)%R (t+v)%R w); auto with zarith. rewrite FnormalizeCorrect; auto with zarith. apply FnormalizeBounded; auto with zarith; elim wDef; auto. fold FtoRradix; rewrite M4; rewrite <- ulDef; auto. Qed. End Total. Float8.4/FnElem/MinOrMax.v0000644000423700002640000002322412032774527015104 0ustar sboldotoccata(**************************************************************************** IEEE754 : MinOrMax Sylvie Boldo ****************************************************************************) Require Export AllFloat. Section MinOrMax_def. Variable radix : Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Variable b : Fbound. Variable precision : nat. Hypothesis radixMoreThanOne : (1 < radix)%Z. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Definition MinOrMax (z : R) (f : float) := isMin b radix z f \/ isMax b radix z f. Theorem MinOrMax_Rlt : forall (z : R) (p : float), 1 < precision -> Zpos (vNum b) = Zpower_nat radix precision -> MinOrMax z p -> (Rabs (z - p) < Fulp b radix precision p)%R. intros z p H'1 H'2 H; case H; intros H1. unfold FtoRradix in |- *; apply RoundedModeUlp with (P := isMin b radix); auto with zarith. apply MinRoundedModeP with precision; auto with zarith. unfold FtoRradix in |- *; apply RoundedModeUlp with (P := isMax b radix); auto with zarith. apply MaxRoundedModeP with precision; auto with zarith. Qed. Theorem MinOrMax_Fopp : forall (x : R) (f : float), MinOrMax (- x) (Fopp f) -> MinOrMax x f. unfold MinOrMax in |- *; intros x f H. rewrite <- (Ropp_involutive x); rewrite <- (Fopp_Fopp f). case H; intros H1. right; apply MinOppMax; auto. left; apply MaxOppMin; auto. Qed. Theorem MinOrMax1 : forall (z : R) (p : float), Fbounded b p -> Fcanonic radix b p -> (0 < p)%R -> (Rabs (z - p) < Fulp b radix precision (FPred b radix precision p))%R -> MinOrMax z p. intros z p Hp Hcan Hblop. case (Rcase_abs (z - p)); intros H1; [ rewrite Rabs_left | rewrite Rabs_right ]; auto; intros H. right; unfold isMax in |- *. split; auto; split. fold FtoRradix in |- *; apply Rplus_le_reg_l with (- p)%R. ring_simplify (- p + p)%R; rewrite Rplus_comm; auto with real. intros f Hf H2. replace (FtoR radix f) with (FtoR radix (Fnormalize radix b precision f)); [ idtac | apply FnormalizeCorrect; auto with zarith arith ]. replace p with (FSucc b radix precision (FPred b radix precision p)); [ idtac | apply FSucPred; auto with zarith arith ]. apply FSuccProp; auto with zarith arith. apply FPredCanonic; auto with arith zarith. apply FnormalizeCanonic; auto with arith zarith. apply Rlt_le_trans with z. 2: rewrite FnormalizeCorrect; auto with arith zarith. apply Rle_lt_trans with (p - Fulp b radix precision (FPred b radix precision p))%R. 2: apply Ropp_lt_cancel. 2: apply Rplus_lt_reg_r with (FtoRradix p). 2: ring_simplify. 2: apply Rle_lt_trans with (2 := H); right; ring. replace (FtoRradix p) with (FPred b radix precision p + Fulp b radix precision (FPred b radix precision p))%R; [ right; fold FtoRradix; ring | unfold FtoRradix in |- *; apply FpredUlpPos; auto with zarith arith ]. left; unfold isMin in |- *. split; auto; split. fold FtoRradix in |- *; apply Rplus_le_reg_l with (- p)%R. ring_simplify (- p + p)%R; rewrite Rplus_comm; auto with real. intros f Hf H2. replace (FtoR radix f) with (FtoR radix (Fnormalize radix b precision f)); [ idtac | apply FnormalizeCorrect; auto with zarith arith ]. replace p with (FPred b radix precision (FSucc b radix precision p)); [ idtac | apply FPredSuc; auto with zarith arith ]. apply FPredProp; auto with zarith arith. apply FnormalizeCanonic; auto with arith zarith. apply FSuccCanonic; auto with arith zarith. apply Rle_lt_trans with z. rewrite FnormalizeCorrect; auto with arith zarith. apply Rlt_le_trans with (p + Fulp b radix precision (FPred b radix precision p))%R. apply Rplus_lt_reg_r with (- FtoRradix p)%R. ring_simplify. apply Rle_lt_trans with (2 := H); right; ring. apply Rle_trans with (FtoRradix p + Fulp b radix precision p)%R; [ apply Rplus_le_compat_l | idtac ]. apply LeFulpPos; auto with arith zarith. apply FBoundedPred; auto with arith zarith. unfold FtoRradix in |- *; apply R0RltRlePred; auto with arith zarith. apply Rlt_le; unfold FtoRradix in |- *; apply FPredLt; auto with arith zarith. pattern p at -3 in |- *; replace p with (FPred b radix precision (FSucc b radix precision p)); [ idtac | apply FPredSuc; auto with zarith arith ]. unfold FtoRradix in |- *; rewrite FpredUlpPos with (x := FSucc b radix precision p); auto with zarith arith real. apply FSuccCanonic; auto with zarith arith. apply Rlt_trans with (FtoRradix p); auto with float real. unfold FtoRradix in |- *; apply FSuccLt; auto with zarith float real. Qed. Theorem MinOrMax2 : forall (z : R) (p : float), Fbounded b p -> Fcanonic radix b p -> (0 < p)%R -> (Rabs (z - p) < Fulp b radix precision p)%R -> (p <= z)%R -> MinOrMax z p. intros z p Hp1 Hp2 H H1 H2. unfold MinOrMax in |- *; left; unfold isMin in |- *. split; auto; split; auto. intros f Hf H3. replace (FtoR radix f) with (FtoR radix (Fnormalize radix b precision f)); [ idtac | apply FnormalizeCorrect; auto with zarith arith ]. replace p with (FPred b radix precision (FSucc b radix precision p)); [ idtac | apply FPredSuc; auto with zarith arith ]. apply FPredProp; auto with zarith arith. apply FnormalizeCanonic; auto with arith zarith. apply FSuccCanonic; auto with arith zarith. apply Rle_lt_trans with z. rewrite FnormalizeCorrect; auto with arith zarith. apply Rlt_le_trans with (FtoRradix p + Fulp b radix precision p)%R. apply Rplus_lt_reg_r with (- FtoRradix p)%R. ring_simplify. apply Rle_lt_trans with (2 := H1); right. rewrite Rabs_right; try ring. apply Rle_ge; apply Rplus_le_reg_l with (FtoRradix p); auto with real. ring_simplify; auto with real. pattern p at -3 in |- *; replace p with (FPred b radix precision (FSucc b radix precision p)); [ idtac | apply FPredSuc; auto with zarith arith ]. unfold FtoRradix in |- *; rewrite FpredUlpPos with (x := FSucc b radix precision p); auto with zarith arith real. apply FSuccCanonic; auto with zarith arith. apply Rlt_trans with (FtoRradix p); auto with float real. unfold FtoRradix in |- *; apply FSuccLt; auto with zarith float real. Qed. Theorem MinOrMax3_aux : forall (z : R) (p : float), Fbounded b p -> Fcanonic radix b p -> 0%R = p -> (z <= 0)%R -> (- z < Fulp b radix precision (FPred b radix precision p))%R -> MinOrMax z p. intros z p Hp Hcan Hzero H. right; unfold isMax in |- *. fold FtoRradix in |- *; rewrite <- Hzero. split; auto; split; auto with real. intros f Hf H2. unfold FtoRradix in |- *; replace (FtoR radix f) with (FtoR radix (Fnormalize radix b precision f)); [ idtac | apply FnormalizeCorrect; auto with zarith arith ]. cut (Fcanonic radix b (Fzero (- dExp b))); [ intros H3 | idtac ]. 2: right; repeat (split; simpl in |- *; auto with zarith). 2: ring_simplify (radix * 0)%Z; rewrite Zabs_eq; auto with zarith. cut (p = Fzero (- dExp b)); [ intros H4 | idtac ]. 2: apply FcanonicUnique with (radix := radix) (precision := precision) (b := b); auto with zarith. 2: fold FtoRradix in |- *; rewrite <- Hzero; auto with float real. 2: unfold FtoRradix in |- *; apply sym_eq; apply FzeroisZero. cut (0 < pPred (vNum b))%Z; [ intros V | apply pPredMoreThanOne with radix precision; auto with zarith ]. cut (1 < Zpos (vNum b))%Z; [ intros V' | apply vNumbMoreThanOne with radix precision; auto with zarith ]. replace 0%R with (FtoR radix (FSucc b radix precision (FPred b radix precision (Fzero (- dExp b))))). apply FSuccProp; auto with zarith arith. apply FPredCanonic; auto with arith zarith. apply FnormalizeCanonic; auto with arith zarith. apply Rlt_le_trans with z. 2: rewrite FnormalizeCorrect; auto with arith zarith. apply Ropp_lt_cancel; apply Rlt_le_trans with (1 := H0). rewrite H4; right. rewrite FPredSimpl4; simpl in |- *; auto with zarith. 2: unfold nNormMin in |- *; auto with zarith. unfold Fulp in |- *. replace (Fnormalize radix b precision (Float (-1) (- dExp b))) with (Float (-1) (- dExp b)); [ unfold FtoRradix, FtoR in |- *; simpl in |- *; ring | idtac ]. apply FcanonicUnique with (radix := radix) (precision := precision) (b := b); auto with zarith. right; repeat (split; simpl in |- *; auto with zarith). rewrite pGivesBound. rewrite <- Zabs_Zopp; rewrite Zabs_eq; auto with zarith. replace (- (radix * -1))%Z with (Zpower_nat radix 1); auto with arith zarith. unfold Zpower_nat in |- *; simpl in |- *; ring. apply FnormalizeCanonic; auto with zarith. repeat (split; simpl in |- *; auto with zarith). apply sym_eq; apply FnormalizeCorrect; auto with zarith. rewrite FPredSimpl4; simpl in |- *; auto with zarith. rewrite FSuccSimpl4; simpl in |- *; auto with zarith. simpl in |- *; unfold FtoR in |- *; simpl in |- *; ring. unfold nNormMin in |- *. replace (-1)%Z with (- Zpower_nat radix (pred 1))%Z; auto with zarith arith. unfold nNormMin in |- *; auto with zarith arith. Qed. Theorem MinOrMax3 : forall (z : R) (p : float), Fbounded b p -> Fcanonic radix b p -> 0%R = p -> (Rabs (z - p) < Fulp b radix precision (FPred b radix precision p))%R -> MinOrMax z p. intros z p Hp Hcan Hzero. replace (z - FtoRradix p)%R with z; [ idtac | rewrite <- Hzero; ring ]. case (Rcase_abs z); intros H1; [ rewrite Rabs_left | rewrite Rabs_right ]; auto; intros H. apply MinOrMax3_aux; auto with real. apply MinOrMax_Fopp. apply MinOrMax3_aux; auto with real float. unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real. rewrite Ropp_involutive. replace (Fopp p) with p; auto. apply floatEq; auto; simpl in |- *. cut (is_Fzero p); [ unfold is_Fzero in |- *; intros H2; repeat rewrite H2 | apply is_Fzero_rep2 with radix ]; auto with zarith real float. Qed. End MinOrMax_def.Float8.4/Others/0000755000423700002640000000000012032777406013315 5ustar sboldotoccataFloat8.4/Others/AlgoPredSucc.v0000644000423700002640000037274212032774527016037 0ustar sboldotoccataRequire Import AllFloat. Require Import Veltkamp. Section AFZ. Variable b : Fbound. Variable radix : Z. Variable precision : nat. Coercion Local FtoRradix := FtoR radix. Hypothesis radixMoreThanOne : (1 < radix)%Z. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Definition AFZClosest (r : R) (p : float) := Closest b radix r p /\ ((Rabs r <= Rabs p)%R \/ (forall q : float, Closest b radix r q -> q = p :>R)). Theorem AFZClosestTotal : TotalP AFZClosest. red in |- *; intros r. case MinEx with (r := r) (3 := pGivesBound); auto with arith. intros min H'. case MaxEx with (r := r) (3 := pGivesBound); auto with arith. intros max H'0. cut (min <= r)%R; [ intros Rl1 | apply isMin_inv1 with (1 := H'); auto ]. cut (r <= max)%R; [ intros Rl2 | apply isMax_inv1 with (1 := H'0) ]. case (Rle_or_lt (r - min) (max - r)); intros H'1. case H'1; intros H'2; auto. exists min; split. apply ClosestMin with (max := max); auto. replace (2%nat * r)%R with (r + r)%R; [ idtac | simpl in |- *; ring ]. apply Rminus_le; auto. fold FtoRradix; replace (r + r - (min + max))%R with (r - min - (max - r))%R; [ idtac | simpl in |- *; ring ]. apply Rle_minus; auto. right; intros q H'3. apply ClosestMinEq with (r := r) (max := max) (b:=b) ; auto. fold FtoRradix; replace (2%nat * r)%R with (r + r)%R; [ idtac | simpl in |- *; ring ]. apply Rminus_lt; auto. replace (r + r - (min + max))%R with (r - min - (max - r))%R; [ idtac | simpl in |- *; ring ]. apply Rlt_minus; auto. case (Rle_or_lt (Rabs r) (Rabs min)); intros G. exists min; split; auto. apply ClosestMin with (max := max); auto. fold FtoRradix; replace (2%nat * r)%R with (r + r)%R; [ idtac | simpl in |- *; ring ]. apply Rminus_le; auto. replace (r + r - (min + max))%R with (r - min - (max - r))%R; [ idtac | simpl in |- *; ring ]. apply Rle_minus; auto. exists max; split; auto. apply ClosestMax with (min := min); auto. fold FtoRradix; replace (2%nat * r)%R with (r + r)%R; [ idtac | simpl in |- *; ring ]. apply Rminus_le; auto. replace (min + max - (r + r))%R with (max - r - (r - min))%R; [ idtac | simpl in |- *; ring ]. apply Rle_minus; auto. rewrite H'2; auto with real. case (Rle_or_lt 0 r); intros M. left; repeat rewrite Rabs_right; try apply Rle_ge; auto with real. apply Rle_trans with (1:=M); auto. absurd ((Rabs min < Rabs r)%R); auto. apply Rle_not_lt. repeat rewrite Rabs_left1; auto with real. apply Rle_trans with (1:=Rl1); auto with real. exists max; split; auto. apply ClosestMax with (min := min); auto. replace (2%nat * r)%R with (r + r)%R; [ idtac | simpl in |- *; ring ]. apply Rminus_le; auto. fold FtoRradix; replace (min + max - (r + r))%R with (max - r - (r - min))%R; [ idtac | simpl in |- *; ring ]. apply Rle_minus; auto with real. right; intros q H'2. apply ClosestMaxEq with (r := r) (min := min) (b:=b); auto. replace (2%nat * r)%R with (r + r)%R; [ idtac | simpl in |- *; ring ]. apply Rminus_lt; auto. fold FtoRradix; replace (min + max - (r + r))%R with (max - r - (r - min))%R; [ idtac | simpl in |- *; ring ]. apply Rlt_minus; auto. Qed. Theorem AFZClosestCompatible : CompatibleP b radix AFZClosest. red in |- *; simpl in |- *. intros r1 r2 p q H' H'0 H'1 H'2; red in |- *. inversion H'. split. apply (ClosestCompatible b radix r1 r2 p q); auto. case H0; intros H1. left. rewrite <- H'0; fold FtoRradix in H'1; rewrite <- H'1; auto. right; intros q0 H'3. unfold FtoRradix in |- *; rewrite <- H'1; auto. apply H1; auto. apply (ClosestCompatible b radix r2 r1 q0 q0); auto. case H'3; auto. Qed. Theorem AFZClosestMinOrMax : MinOrMaxP b radix AFZClosest. red in |- *; intros r p H'; case (ClosestMinOrMax b radix r p); auto. case H'; auto. Qed. Theorem AFZClosestMonotone : MonotoneP radix AFZClosest. red in |- *; simpl in |- *; intros p q p' q' H' H'0 H'1. apply (ClosestMonotone b radix p q); auto; case H'0; case H'1; auto. Qed. Theorem AFZClosestRoundedModeP : RoundedModeP b radix AFZClosest. red in |- *; split. exact AFZClosestTotal. split. exact AFZClosestCompatible. split. exact AFZClosestMinOrMax. exact AFZClosestMonotone. Qed. Theorem AFZClosestUniqueP : UniqueP radix AFZClosest. red in |- *; simpl in |- *. intros r p q H' H'0. inversion H'; inversion H'0; case H0; case H2; auto. intros H'1 H'2; case (AFZClosestMinOrMax r p); case (AFZClosestMinOrMax r q); auto. intros H'3 H'4; apply (MinUniqueP b radix r); auto. intros H'3 H'4; case (Req_dec p q); auto; intros H'5. Contradict H'1; auto. apply Rlt_not_le. cut (p <= r)%R; [ intros Rl1 | apply isMin_inv1 with (1 := H'4); auto ]. cut (r <= q)%R; [ intros Rl2 | apply isMax_inv1 with (1 := H'3) ]. assert (FtoRradix p=r -> False). intros; Contradict H'5. apply (RoundedProjector b radix _ (MaxRoundedModeP _ _ _ radixMoreThanOne precisionGreaterThanOne pGivesBound)); auto. case H'4; auto. fold FtoRradix; rewrite H3; auto. case (Rle_or_lt 0 r); intros G. absurd ( (Rabs r <= Rabs p)%R); auto. apply Rlt_not_le; repeat rewrite Rabs_right; try apply Rle_ge; auto with real. case Rl1; auto. intros; absurd False; auto; apply H3; auto. apply RleMinR0 with b precision r; auto with real zarith. repeat rewrite Rabs_left1; auto with real. case Rl2; auto with real. intros; Contradict H'5; apply sym_eq. apply (RoundedProjector b radix _ (MinRoundedModeP _ _ _ radixMoreThanOne precisionGreaterThanOne pGivesBound)); auto. case H'3; auto. fold FtoRradix; rewrite <- H4; auto. apply RleMaxR0 with b precision r; auto with real zarith. intros H'3 H'4; case (Req_dec p q); auto; intros H'5. Contradict H'1; auto. apply Rlt_not_le. cut (q <= r)%R; [ intros Rl1 | apply isMin_inv1 with (1 := H'3); auto ]. cut (r <= p)%R; [ intros Rl2 | apply isMax_inv1 with (1 := H'4) ]. case (Rle_or_lt 0 r); intros G. repeat rewrite Rabs_right; try apply Rle_ge; auto with real. case Rl1; auto with real. intros; Contradict H'5; apply sym_eq. apply (RoundedProjector b radix _ (MaxRoundedModeP _ _ _ radixMoreThanOne precisionGreaterThanOne pGivesBound)); auto. case H'3; auto. fold FtoRradix; rewrite H3; auto. apply RleMinR0 with b precision r; auto with real zarith. absurd ( (Rabs r <= Rabs p)%R); auto. apply Rlt_not_le; repeat rewrite Rabs_left1; auto with real. case Rl2; auto with real. intros; Contradict H'5. apply (RoundedProjector b radix _ (MinRoundedModeP _ _ _ radixMoreThanOne precisionGreaterThanOne pGivesBound)); auto. case H'4; auto. fold FtoRradix; rewrite <- H3; auto. apply RleMaxR0 with b precision r; auto with real zarith. intros H'3 H'4; apply (MaxUniqueP b radix r); auto. intros H'1 H'2; apply sym_eq; auto. Qed. Theorem AFZClosestSymmetric : SymmetricP AFZClosest. red in |- *; intros r p H'; case H'; clear H'. intros H' H'0; case H'0; clear H'0; intros H'0. split; auto. apply (ClosestSymmetric b radix r p); auto. left. unfold FtoRradix; rewrite Fopp_correct; auto with zarith. repeat rewrite Rabs_Ropp; auto with real. split; auto. apply (ClosestSymmetric b radix r p); auto. right. intros q H'1. cut (Fopp q = p :>R). intros H'2; unfold FtoRradix in |- *; rewrite Fopp_correct. unfold FtoRradix in H'2; rewrite <- H'2. rewrite Fopp_correct; ring. apply H'0; auto. replace r with (- - r)%R; [ idtac | ring ]. apply (ClosestSymmetric b radix (- r)%R q); auto. Qed. End AFZ. Section Closest2. Variable b : Fbound. Variable prec : nat. Variable radix:Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Hypothesis radixMoreThanOne : (1 < radix)%Z. Hypothesis precisionGreaterThan : 1 < prec. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix prec. Lemma ClosestClosestPredSucc: forall (f g:float) (r:R), (Closest b radix r f) -> (Closest b radix r g) -> (FtoRradix f=g) \/ (FtoRradix f=FNPred b radix prec g) \/ (FtoRradix f=FNSucc b radix prec g). intros. elim H; intros Bf T; elim H0; intros Bg T'; clear T T'. case (ClosestMinOrMax b radix r f); auto; intros T1; case (ClosestMinOrMax b radix r g); auto; intros T2. left; unfold FtoRradix; apply (MinUniqueP b radix r); auto. assert (f <= g)%R. elim T1; elim T2; intros; apply Rle_trans with r; intuition. case H1; auto; intros. right; left; unfold FtoRradix. rewrite <- FnormalizeCorrect with radix b prec f; auto with zarith. rewrite <- FPredSuc with b radix prec (Fnormalize radix b prec f); auto with zarith. 2: apply FnormalizeCanonic; auto with zarith. unfold FNPred. replace (FSucc b radix prec (Fnormalize radix b prec f)) with (Fnormalize radix b prec g); auto. apply FcanonicUnique with radix b prec; auto with zarith float. unfold FtoRradix; apply (MaxUniqueP b radix r); auto. apply (MaxCompatible b radix r r g); auto with real zarith float. rewrite FnormalizeCorrect; auto with zarith real. apply MinMax; auto with zarith. fold FtoRradix; Contradict H2. replace (FtoRradix f) with (FtoRradix g); auto with real. apply sym_eq; apply RoundedModeProjectorIdemEq with b prec (Closest b radix); auto with zarith. eapply ClosestRoundedModeP; eauto. fold FtoRradix; rewrite <- H2; auto. assert (g <= f)%R. elim T1; elim T2; intros; apply Rle_trans with r; intuition. case H1; auto; intros. right; right; unfold FtoRradix. unfold FtoRradix; apply (MaxUniqueP b radix r); auto. apply MinMax; auto with zarith. fold FtoRradix; Contradict H2. replace (FtoRradix f) with (FtoRradix g); auto with real. apply RoundedModeProjectorIdemEq with b prec (Closest b radix); auto with zarith. eapply ClosestRoundedModeP; eauto. fold FtoRradix; rewrite <- H2; auto. left; unfold FtoRradix; apply (MaxUniqueP b radix r); auto. Qed. Lemma ClosestStrictMonotone2l: forall (r1 r2 : R) (f1 f2 : float), Closest b radix r1 f1 -> (Fcanonic radix b f2) -> (Rabs (r2 - f2) < Rabs (r2 - FSucc b radix prec f2))%R -> (Rabs (r2 - f2) < Rabs (r2 - FPred b radix prec f2))%R -> (r2 <= r1)%R -> (FtoRradix f2 <= FtoRradix f1)%R. intros. assert (Closest b radix r2 f2). apply ClosestSuccPred with prec; auto with real. eapply FcanonicBound; eauto. case H3; intros. generalize ClosestMonotone; unfold MonotoneP; intros T. unfold FtoRradix; apply T with b r2 r1; auto. case (ClosestClosestPredSucc f1 f2 r1); auto with real. rewrite <- H5; auto. intros K; case K; intros. absurd ( (Rabs (r2 - f2) < Rabs (r2 - f1)))%R. apply Rle_not_lt. rewrite <- Rabs_Ropp with (r2-f1)%R; rewrite <- Rabs_Ropp with (r2-f2)%R. replace (-(r2-f1))%R with (f1-r2)%R by ring. replace (-(r2-f2))%R with (f2-r2)%R by ring. rewrite H5. elim H; intros T1 T2; apply T2; auto. elim H4; auto. rewrite H6; unfold FNPred. rewrite FcanonicFnormalizeEq; auto with zarith real. rewrite H6; left; apply FNSuccLt; auto with zarith. Qed. Lemma ClosestStrictMonotone2r: forall (r1 r2 : R) (f1 f2 : float), Closest b radix r1 f1 -> (Fcanonic radix b f2) -> (Rabs (r2 - f2) < Rabs (r2 - FSucc b radix prec f2))%R -> (Rabs (r2 - f2) < Rabs (r2 - FPred b radix prec f2))%R -> (r1 <= r2)%R -> (FtoRradix f1 <= FtoRradix f2)%R. intros. assert (Closest b radix r2 f2). apply ClosestSuccPred with prec; auto with real. eapply FcanonicBound; eauto. case H3; intros. generalize ClosestMonotone; unfold MonotoneP; intros T. unfold FtoRradix; apply T with b r1 r2; auto. case (ClosestClosestPredSucc f1 f2 r1); auto with real. rewrite H5; auto. intros K; case K; intros. rewrite H6; left; apply FNPredLt; auto with zarith. absurd ( (Rabs (r2 - f2) < Rabs (r2 - f1)))%R. apply Rle_not_lt. rewrite <- Rabs_Ropp with (r2-f1)%R; rewrite <- Rabs_Ropp with (r2-f2)%R. replace (-(r2-f1))%R with (f1-r2)%R by ring. replace (-(r2-f2))%R with (f2-r2)%R by ring. rewrite <- H5. elim H; intros T1 T2; apply T2; auto. elim H4; auto. rewrite H6; unfold FNSucc. rewrite FcanonicFnormalizeEq; auto with zarith real. Qed. Lemma ClosestStrictEq: forall (r : R) (f1 f2 : float), Closest b radix r f1 -> (Fcanonic radix b f2) -> (Rabs (r - f2) < Rabs (r - FSucc b radix prec f2))%R -> (Rabs (r - f2) < Rabs (r - FPred b radix prec f2))%R -> (FtoRradix f1 = FtoRradix f2)%R. intros. assert (FtoRradix f1 <= f2)%R. apply ClosestStrictMonotone2r with r r; auto with real. assert (FtoRradix f2 <= f1)%R; auto with real. apply ClosestStrictMonotone2l with r r; auto with real. Qed. End Closest2. Section PredComput. Variable b : Fbound. Variable prec : nat. Variable radix radixH : Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Hypothesis radixMoreThanOne : (1 < radix)%Z. Hypothesis precisionGreaterThan : 3 <= prec. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix prec. Hypotheses ReasonnableFormat: (2*prec-1 <= dExp b)%Z. Hypotheses radixEven: (radix=2*radixH)%Z. Lemma radixHPos: (0 < radixH)%Z. apply Zmult_lt_reg_r with 2%Z; auto with zarith. Qed. Hint Resolve radixHPos. Lemma RoundedToZero_aux: forall (c:float) (r:R), (Fcanonic radix b c) -> (0 <= r)%R -> (r < /2 * powerRZ radix (-dExp b))%R -> (Closest b radix r c) -> (FtoRradix c=0)%R. intros. assert (0 <= c)%R. unfold FtoRradix; apply RleRoundedR0 with b prec (Closest b radix) r; auto with real zarith. apply ClosestRoundedModeP with prec; auto with zarith. case H3; auto; clear H3; intros H3. elim H2; intros. absurd (Rabs (c-r) <= Rabs r)%R. apply Rlt_not_le. apply Rlt_le_trans with (Rabs c -Rabs r)%R;[idtac|apply Rabs_triang_inv]. repeat rewrite Rabs_right; try apply Rle_ge; auto with real. apply Rplus_lt_reg_r with r. replace (r+r)%R with (2*r)%R;[idtac| ring]. apply Rlt_le_trans with (2*(/ 2 * powerRZ radix (- dExp b)))%R. apply Rmult_lt_compat_l; auto with real. apply Rle_trans with (powerRZ radix (- dExp b)). right; simpl; field; auto with real. apply Rle_trans with c;[idtac|right; ring]. apply Rle_trans with (FSucc b radix prec (Float 0 (-(dExp b)))). right; rewrite FSuccSimpl4; auto with zarith. unfold FtoRradix, FtoR, Zsucc; simpl; ring. simpl; assert (0 < pPred (vNum b))%Z; auto with zarith. apply pPredMoreThanOne with radix prec; auto with zarith. simpl; assert (0 < nNormMin radix prec)%Z; auto with zarith. unfold nNormMin; auto with zarith. unfold FtoRradix; apply FSuccProp; auto with zarith. right; split; split; simpl; auto with zarith. replace (radix*0)%Z with 0%Z; simpl; auto with zarith. apply Rle_lt_trans with 0%R; auto with real zarith. unfold FtoR; simpl; right; ring. rewrite <- (Rabs_Ropp r). replace (-r)%R with (FtoRradix (Float 0 (-(dExp b)))-r)%R. apply H5. split; simpl; auto with zarith. unfold FtoRradix, FtoR; simpl; ring. Qed. Lemma RoundedToZero_aux2: forall (c:float) (r:R), (Fcanonic radix b c) -> (Rabs r < /2 * powerRZ radix (-dExp b))%R -> (Closest b radix r c) -> (FtoRradix c=0)%R. intros. case (Rle_or_lt 0 r); intros. apply RoundedToZero_aux with r; auto. rewrite <- (Rabs_right r); try apply Rle_ge; auto. apply Rmult_eq_reg_l with (-1)%R; auto with real. apply trans_eq with 0%R;[idtac|ring]. apply trans_eq with (FtoRradix (Fopp c)). unfold FtoRradix; rewrite Fopp_correct; ring. apply RoundedToZero_aux with (-r)%R; auto with real. apply FcanonicFopp; auto. rewrite <- (Rabs_left r); auto with real. apply ClosestOpp; auto. Qed. Lemma RoundedToZero: forall (c:float) (r:R), (Rabs r < /2 * powerRZ radix (-dExp b))%R -> (Closest b radix r c) -> (FtoRradix c=0)%R. intros. unfold FtoRradix; rewrite <- FnormalizeCorrect with radix b prec c; auto with zarith. fold FtoRradix; apply RoundedToZero_aux2 with r; auto. apply FnormalizeCanonic; auto with zarith. elim H0; auto. generalize ClosestCompatible; unfold CompatibleP. intros T; apply T with r c; auto with zarith float. rewrite FnormalizeCorrect; auto with zarith real. apply FnormalizeBounded; auto with zarith. elim H0; auto. Qed. Definition u:= powerRZ radix (-prec). Definition phi:=(u*(radixH+radix*u))%R. Definition eta:= powerRZ radix (-(dExp b)). Lemma phi_Pos: (0 < phi)%R. unfold phi,u. apply Rle_lt_trans with (powerRZ radix (- prec)*0)%R; auto with real. apply Rmult_lt_compat_l; auto with real zarith. apply Rle_lt_trans with (0+radix*0)%R; [right; ring|idtac]. apply Rplus_lt_compat; auto with real zarith. Qed. Lemma phi_bounded_aux: (Zabs (radixH*nNormMin radix prec + 1) < Zpos (vNum b))%Z. assert (0 < nNormMin radix prec+1)%Z. apply Zlt_le_trans with (0+1)%Z; unfold nNormMin; auto with zarith. rewrite Zabs_eq; auto with zarith. rewrite pGivesBound; unfold nNormMin. apply Zlt_le_trans with (radixH*Zpower_nat radix (pred prec)+radixH*Zpower_nat radix (pred prec))%Z; auto with zarith. apply Zplus_lt_compat_l. apply Zle_lt_trans with (radixH*1)%Z; auto with zarith. apply Zle_lt_trans with (radixH*Zpower_nat radix 0)%Z; auto with zarith. apply Zmult_lt_compat_l; auto with zarith. apply Zle_trans with ((2*radixH)*Zpower_nat radix (pred prec))%Z. apply Zeq_le; ring. replace (2*radixH)%Z with (Zpower_nat radix 1). rewrite <- Zpower_nat_is_exp; auto with zarith. rewrite <- radixEven;unfold Zpower_nat;simpl; auto with zarith. Qed. Lemma phi_bounded: (exists f:float, Fbounded b f /\ (FtoRradix f=phi)). exists (Float (radixH*nNormMin radix prec+1) (-(2*prec-1))); split. split. apply Zle_lt_trans with (Zabs (radixH*nNormMin radix prec+1))%Z; auto with zarith. apply phi_bounded_aux. apply Zle_trans with (-(2*prec-1))%Z; auto with zarith. unfold FtoRradix, FtoR, pPred, phi, u. replace (IZR (Fnum (Float (radixH*nNormMin radix prec + 1) (- (2 * prec - 1))))) with (radixH*powerRZ radix (prec-1) +1)%R. replace (Fexp (Float (radixH*nNormMin radix prec + 1) (- (2 * prec - 1)))) with (-(2*prec-1))%Z; auto with zarith. apply trans_eq with (radixH*((powerRZ radix (prec-1)*powerRZ radix (- (2 * prec-1)))) + powerRZ radix (- (2 * prec-1)))%R;[ring|idtac]. apply trans_eq with (radixH*powerRZ radix (- prec) + radix * (powerRZ radix (- prec) * powerRZ radix (- prec)))%R;[idtac|ring]. repeat rewrite <- powerRZ_add; auto with real zarith. replace (prec -1+ - (2 * prec-1))%Z with (-prec)%Z; auto with zarith. pattern (IZR radix) at 4; replace (IZR radix) with (powerRZ radix 1); auto with zarith. rewrite <- powerRZ_add; auto with real zarith. replace (1+(- prec + - prec))%Z with (-(2*prec-1))%Z; auto with zarith real. simpl; auto with real. apply trans_eq with (IZR (radixH*nNormMin radix prec+1)); auto with zarith real. rewrite plus_IZR; rewrite mult_IZR; unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. rewrite inj_pred; auto with zarith. Qed. Lemma GepetaGeExp: forall (c:float), Fcanonic radix b c -> (powerRZ radix (prec-dExp b) <= c)%R -> (-dExp b < Fexp c)%Z. intros. assert (-(dExp b)+1 <= Fexp c)%Z; auto with zarith. apply Zle_trans with (Fexp (Float (nNormMin radix prec) (-(dExp b)+1))); auto with zarith. apply Fcanonic_Rle_Zle with radix b prec; auto with zarith. left; split; try split; simpl; auto with zarith. rewrite Zabs_eq. apply ZltNormMinVnum; auto with zarith. apply Zlt_le_weak; apply nNormPos; auto with zarith. rewrite PosNormMin with radix b prec; auto with zarith. apply Rle_trans with (powerRZ radix (prec - dExp b)). rewrite <- Fabs_correct; auto with zarith. unfold FtoR, Fabs; simpl. unfold nNormMin; rewrite Zabs_eq; auto with zarith. rewrite Zpower_nat_Z_powerRZ. rewrite <- powerRZ_add; auto with real zarith. replace (pred prec + (- dExp b + 1))%Z with (prec - dExp b)%Z; auto with real. rewrite inj_pred; unfold Zpred; auto with zarith. fold FtoRradix; rewrite Rabs_right; auto. apply Rle_ge; apply Rle_trans with (2:=H0); auto with real zarith. Qed. Lemma GepetaIsNormal: forall (c:float), Fcanonic radix b c -> (powerRZ radix (prec-dExp b) <= c)%R -> Fnormal radix b c. intros. case H; intros; auto. absurd (-dExp b < Fexp c)%Z. elim H1; intros H2 (H3,H4); rewrite H3; auto with zarith. apply GepetaGeExp; auto. Qed. Lemma predSmallOnes: forall (c:float), Fcanonic radix b c -> (Rabs c < powerRZ radix (prec-dExp b))%R -> (FtoRradix (FPred b radix prec c) = c-eta)%R. intros. assert (Fexp c = (-dExp b))%Z. case (Zle_lt_or_eq (-(dExp b)) (Fexp c)); auto with zarith. assert (Fbounded b c); auto with zarith float. apply FcanonicBound with radix; auto with zarith. intros; absurd (Rabs c < Rabs c)%R; auto with real. apply Rlt_le_trans with (1:=H0). replace (prec-dExp b)%Z with ((prec-1)+(-dExp b+1))%Z;[idtac|ring]. rewrite powerRZ_add; auto with real zarith. unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith. unfold FtoR, Fabs; simpl. apply Rmult_le_compat; auto with real zarith. apply Rle_trans with (IZR (nNormMin radix prec)). unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. apply Rle_powerRZ; auto with real zarith. rewrite inj_pred; auto with zarith. apply Rle_IZR. apply pNormal_absolu_min with b; auto with zarith. case H; auto; intros H2; elim H2; intros H3 (H4,H5). absurd (-dExp b (powerRZ radix (prec-dExp b) <= c)%R -> (Fnum c=nNormMin radix prec) -> (FtoRradix (FPred b radix prec c) = c-powerRZ radix (Fexp c-1))%R. intros c Cc; intros. rewrite FPredSimpl2; auto with zarith. unfold FtoRradix, FtoR; simpl; rewrite H0; simpl. unfold pPred, Zpred; rewrite plus_IZR. rewrite Rmult_plus_distr_r; unfold Rminus. replace (Zpos (vNum b) * powerRZ radix (Fexp c + -1))%R with (nNormMin radix prec * powerRZ radix (Fexp c))%R. replace ((-1)%Z * powerRZ radix (Fexp c + -1))%R with (- powerRZ radix (Fexp c - 1))%R; auto with real. unfold Zminus; simpl; ring. unfold nNormMin; rewrite pGivesBound. repeat rewrite Zpower_nat_Z_powerRZ. repeat rewrite <- powerRZ_add; auto with real zarith. replace (pred prec + Fexp c)%Z with (prec + (Fexp c + -1))%Z; auto. rewrite inj_pred; unfold Zpred; auto with zarith. assert (-dExp b < Fexp c)%Z; auto with zarith. apply GepetaGeExp; auto. Qed. Lemma predNormal2: forall (c:float), Fcanonic radix b c -> (powerRZ radix (prec-dExp b) <= c)%R -> (Fnum c <> nNormMin radix prec) -> (FtoRradix (FPred b radix prec c) = c-powerRZ radix (Fexp c))%R. intros. rewrite FPredSimpl4; auto with zarith. unfold FtoRradix, FtoR, Zpred; simpl. rewrite plus_IZR; simpl; ring. assert (-pPred (vNum b) < Fnum c)%Z; auto with zarith float. apply Zlt_le_trans with 0%Z. assert (0 < pPred (vNum b))%Z; auto with zarith float. apply pPredMoreThanOne with radix prec; auto with zarith. apply LeR0Fnum with radix ; auto with real zarith. fold FtoRradix; apply Rle_trans with (2:=H0); auto with real zarith. Qed. Lemma succNormal: forall (c:float), Fcanonic radix b c -> (0 <= c)%R -> (FtoRradix (FSucc b radix prec c) = c+powerRZ radix (Fexp c))%R. intros. apply Rplus_eq_reg_l with (-c)%R. apply trans_eq with (FtoRradix (Fminus radix (FSucc b radix prec c) c)). unfold FtoRradix; rewrite Fminus_correct; auto with real zarith; ring. unfold FtoRradix; rewrite FSuccDiff1; auto with zarith. unfold FtoR; simpl; ring. unfold nNormMin. assert (-(Zpower_nat radix (pred prec)) < Fnum c)%Z; auto with zarith. apply Zlt_le_trans with (-0)%Z; auto with zarith. simpl; apply LeR0Fnum with radix; auto with real zarith. Qed. Lemma eGe: forall (c c' e:float), Fcanonic radix b c -> (0 <= c)%R -> Closest b radix (phi*c) c' -> Closest b radix (c'+eta) e -> (powerRZ radix (Fexp c)/2 < e)%R. intros. case (Zle_or_lt (-dExp b) (Fexp c -prec)); intros. assert (powerRZ radix (prec - dExp b) <= c)%R. unfold FtoRradix, FtoR; simpl. apply Rle_trans with (1*powerRZ radix (prec - dExp b))%R; auto with real. apply Rmult_le_compat; auto with real zarith. apply Rle_trans with (IZR 1); auto with real zarith. apply Rle_IZR. apply Zle_trans with (nNormMin radix prec); auto with zarith float. assert (0 < nNormMin radix prec)%Z; auto with zarith. apply nNormPos; auto with zarith. rewrite <- (Zabs_eq (Fnum c)). apply pNormal_absolu_min with b; auto with zarith real. case H; auto; intros M. elim M; intros M1 (M2,M3). absurd (- dExp b <= Fexp c - prec)%Z; auto. rewrite M2; auto with zarith. apply LeR0Fnum with radix; auto with real zarith. apply Rle_powerRZ; auto with real zarith. apply Rlt_le_trans with c'. apply Rlt_le_trans with (Float (radixH*nNormMin radix prec + 1) (Fexp c -prec)). unfold FtoRradix, FtoR; simpl. unfold Zminus; rewrite powerRZ_add; auto with real zarith. apply Rlt_le_trans with (powerRZ radix (Fexp c) * ((radixH*nNormMin radix prec + 1)%Z* powerRZ radix (- prec)))%R;[idtac|right; ring]. unfold Rdiv; apply Rmult_lt_compat_l; auto with real zarith. rewrite plus_IZR; rewrite mult_IZR; unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. rewrite Rmult_plus_distr_r. replace (radixH*powerRZ radix (pred prec) * powerRZ radix (- prec))%R with (/2)%R. apply Rle_lt_trans with (/2+0)%R; auto with real zarith. apply Rplus_lt_compat_l; simpl. apply Rlt_le_trans with (powerRZ radix (- prec)); auto with real zarith. rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with real zarith. replace (pred prec + - prec)%Z with (-1)%Z. simpl; rewrite radixEven; rewrite mult_IZR; simpl; field; auto with real zarith. rewrite inj_pred; unfold Zpred; auto with zarith. unfold FtoRradix; apply RleBoundRoundl with b prec (Closest b radix) (phi*c)%R; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl; auto with zarith. apply phi_bounded_aux. unfold FtoRradix, FtoR; simpl. unfold Zminus; rewrite powerRZ_add; auto with real zarith. apply Rle_trans with (powerRZ radix (- prec)* ((radixH*nNormMin radix prec + 1)%Z*powerRZ radix (Fexp c)))%R;[right; ring|idtac]. unfold phi. apply Rle_trans with (powerRZ radix (-prec)* (((radixH + radix * u)*Fnum c)*powerRZ radix (Fexp c)))%R;[idtac|unfold phi,u; simpl; right;ring]. apply Rmult_le_compat_l; auto with real zarith. apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with ((radixH + radix * u) * nNormMin radix prec)%R. rewrite plus_IZR; rewrite mult_IZR; rewrite Rmult_plus_distr_r. apply Rplus_le_compat; auto with real. unfold u; simpl; unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. pattern (IZR radix) at 1; replace (IZR radix) with (powerRZ radix 1). repeat rewrite <- powerRZ_add; auto with real zarith. replace (1 + - prec + pred prec)%Z with 0%Z. simpl; auto with real. rewrite inj_pred; unfold Zpred; auto with zarith. simpl; auto with real. apply Rmult_le_compat_l. unfold u; apply Rle_trans with (0+0)%R; auto with real; apply Rplus_le_compat; auto with real zarith. apply Rmult_le_pos; auto with real zarith. rewrite <- (Zabs_eq (Fnum c)). apply Rle_IZR; apply pNormal_absolu_min with b; auto with zarith real. apply GepetaIsNormal; auto. apply LeR0Fnum with radix; auto with real zarith. unfold FtoRradix; apply RleBoundRoundl with b prec (Closest b radix) (c'+eta)%R; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. elim H1; auto. fold FtoRradix; apply Rle_trans with (c'+0)%R; auto with real zarith. unfold eta; apply Rplus_le_compat_l; auto with real zarith. assert (powerRZ radix (Fexp c) / 2 = (Float radixH (Fexp c -1)))%R. unfold FtoRradix, FtoR; simpl. unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl. rewrite radixEven; rewrite mult_IZR; simpl. field; auto with real zarith. case (Zle_lt_or_eq (-dExp b) (Fexp c)). assert (Fbounded b c); auto with zarith float. apply FcanonicBound with radix; auto with zarith. intros. assert (powerRZ radix (Fexp c) / 2 <= c')%R. rewrite H4. unfold FtoRradix; apply RleBoundRoundl with b prec (Closest b radix) (phi*c)%R; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl; auto with zarith. rewrite Zabs_eq; auto with zarith. rewrite pGivesBound. apply Zlt_le_trans with (Zpower_nat radix 1); auto with zarith. unfold Zpower_nat; simpl; rewrite radixEven; auto with zarith. unfold phi. apply Rle_trans with (u*radixH*c)%R. unfold FtoRradix, FtoR,u; simpl. unfold Zminus; rewrite powerRZ_add; auto with real zarith. apply Rle_trans with (radixH*(powerRZ radix (Fexp c) * (powerRZ radix (- prec) *Fnum c)))%R;[idtac|right; ring]. repeat apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (powerRZ radix (- prec) * nNormMin radix prec)%R. unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. rewrite <- powerRZ_add; auto with real zarith; apply Rle_powerRZ; auto with real zarith. rewrite inj_pred; unfold Zpred; auto with zarith. apply Rmult_le_compat_l; auto with real zarith. rewrite <- (Zabs_eq (Fnum c)). apply Rle_IZR; apply pNormal_absolu_min with b; auto with zarith real. case H; auto; intros M. elim M; intros M1 (M2,M3). Contradict M2; auto with zarith. apply LeR0Fnum with radix; auto with real zarith. apply Rle_trans with (u*(radixH+0*0)*c)%R;[right; ring|idtac]. apply Rmult_le_compat_r; auto. apply Rmult_le_compat_l; unfold u; auto with real zarith. apply Rle_lt_trans with (1:=H6). replace (FtoRradix e) with (c'+eta)%R. unfold eta; apply Rle_lt_trans with (c'+0)%R; auto with real zarith. replace eta with (FtoRradix (Float 1 (-dExp b))). 2: unfold eta, FtoRradix, FtoR; simpl; ring. unfold FtoRradix; rewrite <- Fplus_correct; auto with zarith. apply RoundedModeProjectorIdemEq with b prec (Closest b radix); auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. 2: rewrite Fplus_correct; auto with zarith real. 2: replace (FtoR radix (Float 1 (-dExp b))) with eta; auto with real. 2: unfold eta, FtoRradix, FtoR; simpl; ring. unfold Fplus. simpl (Fexp (Float 1 (- dExp b))); simpl (Fnum (Float 1 (- dExp b))). rewrite Zmin_le2. replace (1 * Zpower_nat radix (Zabs_nat (- dExp b - - dExp b)))%Z with 1%Z. split; simpl; auto with zarith. apply Zlt_Rlt. rewrite <- Rabs_Zabs; rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ. rewrite plus_IZR. apply Rle_lt_trans with (Rabs ((Fnum c' * Zpower_nat radix (Zabs_nat (Fexp c' - - dExp b)))%Z) + Rabs 1%Z)%R. apply Rabs_triang. rewrite mult_IZR; rewrite Zpower_nat_Z_powerRZ. replace (Rabs (IZR 1)) with 1%R. apply Rplus_lt_reg_r with (-1)%R. apply Rle_lt_trans with (Rabs (Fnum c' * powerRZ radix (Zabs_nat (Fexp c' - - dExp b))));[right; ring|idtac]. apply Rmult_lt_reg_l with (powerRZ radix (-dExp b)); auto with real zarith. apply Rle_lt_trans with (Rabs c'). unfold FtoRradix, FtoR; simpl; repeat rewrite Rabs_mult. rewrite (Rabs_right (powerRZ radix (Zabs_nat (Fexp c' - - dExp b)))). rewrite (Rabs_right (powerRZ radix (Fexp c'))). right;apply trans_eq with (Rabs (Fnum c') * ( powerRZ radix (- dExp b) *powerRZ radix (Zabs_nat (Fexp c' - - dExp b))))%R;[ring|idtac]. rewrite <- powerRZ_add; auto with real zarith. replace (- dExp b + Zabs_nat (Fexp c' - - dExp b))%Z with (Fexp c')%Z; auto. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. assert (-dExp b <= Fexp c')%Z; auto with zarith float. elim H1; auto with zarith float. apply Rle_ge; auto with real zarith. apply Rle_ge; auto with real zarith. assert (FtoRradix (Float (radixH*nNormMin radix prec+1) (-dExp b)) = radixH*powerRZ radix (prec-1-dExp b) + powerRZ radix (-dExp b))%R. unfold FtoRradix, FtoR; simpl. rewrite plus_IZR; rewrite mult_IZR; unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. rewrite inj_pred; auto with zarith. apply trans_eq with (radixH*(powerRZ radix (Zpred prec)*powerRZ radix (- dExp b)) + powerRZ radix (- dExp b))%R. simpl; ring. rewrite <- powerRZ_add; auto with zarith real. apply Rle_lt_trans with (Float (radixH*nNormMin radix prec+1) (-dExp b)). unfold FtoRradix; apply RoundAbsMonotoner with b prec (Closest b radix) (phi*c)%R; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl; auto with zarith. apply phi_bounded_aux. fold FtoRradix; rewrite H7. rewrite Rabs_mult; repeat rewrite Rabs_right; try apply Rle_ge; auto with real. 2: left; apply phi_Pos. unfold phi. apply Rle_trans with ((radixH+radix*u)*powerRZ radix (Fexp c))%R. apply Rle_trans with ((radixH + radix * u) *(u*c))%R;[right; ring|idtac]. apply Rmult_le_compat_l. apply Rle_trans with (0+0*0)%R; [right; ring|apply Rplus_le_compat; auto with real zarith]. apply Rmult_le_compat; unfold u; auto with real zarith. unfold FtoRradix, FtoR, u; simpl. apply Rle_trans with (powerRZ radix (- prec) * (powerRZ radix prec * powerRZ radix (Fexp c)))%R. apply Rmult_le_compat_l; auto with real zarith. apply Rmult_le_compat_r; auto with real zarith. rewrite <- Zpower_nat_Z_powerRZ; rewrite <- pGivesBound. apply Rle_IZR. apply Zle_trans with (Zabs (Fnum c)); auto with zarith float. assert (Fbounded b c); [apply FcanonicBound with radix|idtac]; auto with zarith float. repeat rewrite <- powerRZ_add; auto with real zarith. replace ((- prec + (prec + Fexp c)))%Z with (Fexp c); auto with real; ring. apply Rle_trans with ((radixH + radix * u) * powerRZ radix (prec-1-dExp b))%R. apply Rmult_le_compat_l. apply Rle_trans with (0+0*0)%R; [right; ring|unfold u; apply Rplus_le_compat; auto with real zarith]. apply Rle_powerRZ; auto with real zarith. rewrite Rmult_plus_distr_r. apply Rplus_le_compat; auto with real. pattern (IZR radix) at 1; replace (IZR radix) with (powerRZ radix 1);[idtac|simpl; auto with real]. unfold u; repeat rewrite <- powerRZ_add; auto with real zarith. apply Rle_powerRZ; auto with real zarith. rewrite H7. apply Rle_lt_trans with (powerRZ radix (- dExp b) *(powerRZ radix prec / 2+1))%R. rewrite Rmult_plus_distr_l; apply Rplus_le_compat; auto with real. unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith; simpl. replace (IZR radixH) with (radix/2)%R. right; field; auto with real zarith. rewrite radixEven; rewrite mult_IZR; simpl; field; auto with real. apply Rmult_lt_compat_l; auto with real zarith. apply Rplus_lt_reg_r with (1-powerRZ radix prec / 2)%R. apply Rmult_lt_reg_l with 2%R; auto with real. apply Rle_lt_trans with (IZR 2*IZR 2)%R;[simpl; right; ring|idtac]. apply Rlt_le_trans with (powerRZ radix prec)%R;[idtac|right; field; auto with real]. apply Rle_lt_trans with (powerRZ radix 2); auto with real zarith. apply Rle_trans with (radix*radix)%R;[idtac|simpl; right; ring]. apply Rmult_le_compat; auto with real zarith. rewrite Rabs_right; try apply Rle_ge; auto with real. replace (- dExp b - - dExp b)%Z with 0%Z; auto with zarith. elim H1; auto with zarith float. intros. apply Rlt_le_trans with (Float 1 (-(dExp b))). unfold FtoRradix, FtoR; simpl. unfold Rdiv; rewrite Rmult_comm; rewrite H5. apply Rmult_lt_compat_r; auto with real zarith. apply Rlt_le_trans with (/1)%R; auto with real. unfold FtoRradix; apply RleBoundRoundl with b prec (Closest b radix) (c'+eta)%R; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl; auto with zarith float. apply vNumbMoreThanOne with radix prec; auto with zarith. apply Rle_trans with (0+eta)%R. right; unfold eta, FtoR; simpl; ring. apply Rplus_le_compat_r. unfold FtoRradix; apply RleRoundedR0 with b prec (Closest b radix) (phi*c)%R; auto with zarith real float. apply ClosestRoundedModeP with prec; auto with zarith. apply Rmult_le_pos; auto. left; apply phi_Pos. Qed. Lemma Algo1_correct_aux_aux:forall (c cinf:float) (r:R), Fcanonic radix b c -> (0 <= c)%R -> (powerRZ radix (Fexp c)/2 < r)%R -> Closest b radix (c-r) cinf -> (FtoRradix cinf <= FPred b radix prec c)%R. intros. assert (N:Fbounded b c). apply FcanonicBound with radix; auto. generalize ClosestMonotone; unfold MonotoneP; intros. cut (exists f:float, Fbounded b f /\ (FtoRradix f <= FPred b radix prec c)%R /\ Closest b radix (c-powerRZ radix (Fexp c) / 2)%R f). intros (f,(L1,(L2,L3))). apply Rle_trans with (2:=L2). unfold FtoRradix; apply H3 with b (c-r)%R (c-powerRZ radix (Fexp c) / 2)%R; auto; clear H3. unfold Rminus; apply Rplus_lt_compat_l; auto with real. case (Rle_or_lt (powerRZ radix (prec - dExp b)) c); intros. case (Z_eq_dec (Fnum c) (nNormMin radix prec)); intros. cut (exists f:float, Fbounded b f /\ (FtoRradix f = (c-powerRZ radix (Fexp c) / 2))%R). intros (f,(L1,L2)). exists f; split; auto; split. rewrite L2; rewrite predNormal1; auto with real zarith. unfold Zminus; rewrite powerRZ_add; auto with real zarith. unfold Rminus, Rdiv; apply Rplus_le_compat_l. apply Ropp_le_contravar. apply Rmult_le_compat_l; auto with real zarith. simpl; apply Rle_Rinv; auto with real zarith. replace (radix*1)%R with (IZR radix); auto with real; replace 2%R with (IZR 2); auto with real zarith. rewrite <- L2; unfold FtoRradix. apply RoundedModeProjectorIdem with b; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. exists (Float (Zpos (vNum b) -radixH) (Fexp c-1)). split; try split. apply Zle_lt_trans with (Zabs (Zpos (vNum b) - radixH)); auto with zarith. rewrite Zabs_eq; auto with zarith. apply Zplus_le_reg_l with (radixH). ring_simplify. rewrite pGivesBound; apply Zle_trans with (Zpower_nat radix 1); auto with zarith. unfold Zpower_nat;simpl. ring_simplify; rewrite radixEven; auto with zarith. simpl. assert (- dExp b < Fexp c)%Z; auto with zarith. apply GepetaGeExp; auto. unfold FtoRradix, FtoR. replace (Fnum (Float (Zpos (vNum b) - radixH) (Fexp c - 1))) with (Zpos (vNum b) - radixH)%Z; auto. simpl (Fexp (Float (Zpos (vNum b) - radixH) (Fexp c - 1))). unfold Zminus; rewrite plus_IZR. rewrite Ropp_Ropp_IZR. rewrite pGivesBound; rewrite e; unfold nNormMin; repeat rewrite Zpower_nat_Z_powerRZ. rewrite inj_pred; auto with zarith; unfold Zpred. repeat rewrite powerRZ_add; auto with real zarith; simpl. replace (radix*1)%R with (2*radixH)%R. field; auto with real zarith. rewrite radixEven; rewrite mult_IZR; simpl; ring. exists (FPred b radix prec c); split. apply FBoundedPred; auto with zarith. split; auto with real. apply ClosestSuccPred with prec; auto with zarith. apply FBoundedPred; auto with zarith. apply FPredCanonic; auto with zarith. rewrite FSucPred; fold FtoRradix; auto with zarith. replace (c - powerRZ radix (Fexp c) / 2 - c)%R with (-(powerRZ radix (Fexp c)/2))%R;[idtac|ring]. rewrite Rabs_Ropp; rewrite (Rabs_right (powerRZ radix (Fexp c) / 2)). 2: apply Rle_ge; unfold Rdiv; apply Rmult_le_pos; auto with real zarith. rewrite predNormal2; auto. replace (c - powerRZ radix (Fexp c) / 2 - (c - powerRZ radix (Fexp c)))%R with (powerRZ radix (Fexp c) / 2)%R. rewrite Rabs_right; auto with real. apply Rle_ge; unfold Rdiv; apply Rmult_le_pos; auto with real zarith. field; auto with real. rewrite predNormal2; auto with zarith real. replace (c - powerRZ radix (Fexp c) / 2 - (c - powerRZ radix (Fexp c)))%R with (powerRZ radix (Fexp c) / 2)%R. rewrite Rabs_right; auto with real. 2: apply Rle_ge; unfold Rdiv; apply Rmult_le_pos; auto with real zarith. 2: field; auto with real. case (Zle_lt_or_eq (nNormMin radix prec +1) (Fnum c)). assert (nNormMin radix prec <= Fnum c)%Z; auto with zarith. rewrite <- (Zabs_eq (Fnum c)). apply pNormal_absolu_min with b; auto with zarith real. apply GepetaIsNormal; auto. apply LeR0Fnum with radix; auto with real zarith. intros. rewrite predNormal2; auto with zarith real. rewrite FPredSimpl4; auto with zarith. simpl; unfold FtoRradix, FtoR, Zpred; simpl. rewrite plus_IZR. replace (Fnum c * powerRZ radix (Fexp c) - powerRZ radix (Fexp c) / 2 - ((Fnum c + (-1)%Z) * powerRZ radix (Fexp c) - powerRZ radix (Fexp c)))%R with ((3*powerRZ radix (Fexp c)/2))%R. rewrite Rabs_right. apply Rle_trans with (1*powerRZ radix (Fexp c) / 2)%R;auto with real. right; unfold Rdiv; ring. unfold Rdiv; apply Rmult_le_compat_r; auto with real. apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with 2%R; auto with real. unfold Rdiv; apply Rle_ge; repeat apply Rmult_le_pos; auto with real zarith. apply Rle_trans with (IZR 3); auto with real zarith. right; simpl; ring. simpl; field. assert (- pPred (vNum b) < Fnum c)%Z; auto with zarith. apply Zle_lt_trans with (2:=H5). apply Zle_trans with 0%Z; auto with zarith. assert (0 < pPred (vNum b))%Z; auto with zarith. apply pPredMoreThanOne with radix prec; auto with zarith. unfold nNormMin; auto with zarith. apply FPredCanonic; auto with zarith float. case H4; intros. assert (FtoRradix (Float 1 (prec-dExp b))=powerRZ radix (prec - dExp b))%R. unfold FtoRradix, FtoR; simpl; ring. rewrite <- H7. unfold FtoRradix; rewrite <- FnormalizeCorrect with radix b prec (Float 1 (prec-dExp b)); auto. apply FPredProp; auto with zarith. apply FnormalizeCanonic; auto with zarith. split; simpl; auto with zarith float. apply vNumbMoreThanOne with radix prec; auto with zarith. rewrite FnormalizeCorrect; auto with zarith. fold FtoRradix; rewrite H7; auto. assert (c=Float (nNormMin radix prec) (-dExp b+1)). apply FcanonicUnique with radix b prec; auto with zarith real. left; split; try split; simpl; auto with zarith float. rewrite Zabs_eq. apply ZltNormMinVnum; auto with zarith. unfold nNormMin; auto with zarith. rewrite <- PosNormMin with radix b prec; auto with zarith. fold FtoRradix; rewrite <- H6; unfold FtoRradix, FtoR; simpl. unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. rewrite <- powerRZ_add; auto with real zarith. replace (pred prec + (- dExp b + 1))%Z with (prec-dExp b)%Z; auto. rewrite inj_pred; auto with zarith. absurd (Fnum c = nNormMin radix prec)%Z; auto with zarith. rewrite H7; simpl; auto. assert ((nNormMin radix prec < Fnum (FPred b radix prec c)))%Z; auto with zarith. rewrite FPredSimpl4; auto with zarith. simpl; unfold Zpred; auto with zarith. assert (0 < pPred (vNum b))%Z. apply pPredMoreThanOne with radix prec; auto with zarith. assert (0 < Fnum c)%Z; auto with zarith. apply Zle_lt_trans with (2:=H5). unfold nNormMin; auto with zarith. intros. rewrite FPredSimpl4 with (x:=c); auto with zarith. rewrite FPredSimpl2; auto with zarith. simpl. replace (c - powerRZ radix (Fexp c) / 2 - FtoR radix (Float (pPred (vNum b)) (Zpred (Fexp c))))%R with (powerRZ radix (Fexp c)* (/2 +/radix))%R. rewrite Rabs_right; unfold Rdiv. apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (/2+0)%R; auto with real zarith. apply Rle_ge; apply Rmult_le_pos; auto with real zarith. apply Rle_trans with (0+0)%R; auto with real zarith. apply Rplus_le_compat; auto with real zarith. unfold FtoRradix, FtoR; simpl. rewrite <- H5; unfold pPred, Zpred; repeat rewrite plus_IZR; rewrite pGivesBound; simpl. unfold nNormMin; repeat rewrite Zpower_nat_Z_powerRZ. rewrite inj_pred; auto with zarith; unfold Zpred. repeat rewrite powerRZ_add; auto with real zarith; simpl. field; auto with real zarith. rewrite <- H5; simpl; unfold Zpred; auto with zarith. assert (-dExp b < Fexp c)%Z; auto with zarith. apply GepetaGeExp; auto. assert (0 < pPred (vNum b))%Z. apply pPredMoreThanOne with radix prec; auto with zarith. assert (0 < Fnum c)%Z; auto with zarith. rewrite <- H5; unfold nNormMin; auto with zarith. apply Zlt_le_trans with (0+1)%Z; auto with zarith. case (Zle_lt_or_eq (-dExp b) (Fexp c)); auto. assert (Fbounded b c); auto with zarith float. intros; absurd (c < powerRZ radix (prec - dExp b))%R; auto. apply Rle_not_lt. unfold FtoRradix, FtoR; simpl. replace (prec-dExp b)%Z with ((prec-1)+(-dExp b+1))%Z;[idtac| ring]. rewrite powerRZ_add; auto with real zarith. apply Rmult_le_compat; auto with real zarith. apply Rle_trans with (nNormMin radix prec). unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. apply Rle_powerRZ; auto with real zarith. rewrite inj_pred; auto with zarith. rewrite <- (Zabs_eq (Fnum c)). apply Rle_IZR; apply pNormal_absolu_min with b; auto with zarith real. case H; auto. intros L; elim L; intros L1 (L2,L3). Contradict L2; auto with zarith. apply LeR0Fnum with radix; auto with real zarith. apply Rle_powerRZ; auto with zarith real. intros. exists (FPred b radix prec c); split. apply FBoundedPred; auto with zarith. split; auto with real. apply ClosestSuccPred with prec; auto with zarith. apply FBoundedPred; auto with zarith. apply FPredCanonic; auto with zarith. rewrite FSucPred; fold FtoRradix; auto with zarith. replace (c - powerRZ radix (Fexp c) / 2 - c)%R with (-(powerRZ radix (Fexp c)/2))%R;[idtac|ring]. rewrite Rabs_Ropp; rewrite (Rabs_right (powerRZ radix (Fexp c) / 2)). 2: apply Rle_ge; unfold Rdiv; apply Rmult_le_pos; auto with real zarith. rewrite predSmallOnes; auto. unfold eta; replace (-dExp b)%Z with (Fexp c). replace (c - powerRZ radix (Fexp c) / 2 - (c - powerRZ radix (Fexp c)))%R with (powerRZ radix (Fexp c) / 2)%R. rewrite Rabs_right; auto with real. apply Rle_ge; unfold Rdiv; apply Rmult_le_pos; auto with real zarith. field; auto with real. rewrite Rabs_right; try apply Rle_ge; auto with real. repeat rewrite predSmallOnes; auto. unfold eta; rewrite H5. replace (c - powerRZ radix (Fexp c) / 2 - (c - powerRZ radix (Fexp c)))%R with (powerRZ radix (Fexp c) */ 2)%R;[idtac|field]. replace (c - powerRZ radix (Fexp c) / 2 - (c - powerRZ radix (Fexp c) - powerRZ radix (Fexp c)))%R with ((3*powerRZ radix (Fexp c) */ 2))%R;[idtac|field]. repeat rewrite Rabs_right; try apply Rle_ge. apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (1*powerRZ radix (Fexp c))%R; auto with real. apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (IZR 3); auto with real zarith. simpl; right; ring. repeat apply Rmult_le_pos; auto with real zarith. apply Rle_trans with (IZR 3); auto with real zarith. simpl; right; ring. apply Rmult_le_pos; auto with real zarith. rewrite Rabs_right; try apply Rle_ge; auto with real. apply FPredCanonic; auto with zarith. case (Rle_or_lt 0 (c-eta)); intros. rewrite Rabs_right;[idtac|apply Rle_ge; auto with real]. apply Rle_lt_trans with (FtoRradix c); auto with real. apply Rle_trans with (c-0)%R; auto with real. unfold Rminus, eta; auto with real zarith. rewrite Rabs_left; auto. apply Rle_lt_trans with eta. apply Rle_trans with (eta-c)%R;[right; ring|idtac]. apply Rle_trans with (eta-0)%R;[auto with real|right; ring]. unfold Rminus; apply Rplus_le_compat_l; auto with real. unfold eta; apply Rlt_powerRZ; auto with zarith real. rewrite Rabs_right; try apply Rle_ge; auto with real. rewrite Rabs_right; try apply Rle_ge; auto with real. Qed. Lemma Algo1_correct_aux_aux2:forall (c csup:float) (r:R), Fcanonic radix b c -> (0 <= c)%R -> (powerRZ radix (Fexp c)/2 < r)%R -> Closest b radix (c+r) csup -> (FtoRradix (FSucc b radix prec c) <= csup)%R. intros. assert (N:Fbounded b c). apply FcanonicBound with radix; auto. generalize ClosestMonotone; unfold MonotoneP; intros. cut (exists f:float, Fbounded b f /\ (FtoRradix (FSucc b radix prec c) <= f)%R /\ Closest b radix (c+powerRZ radix (Fexp c) / 2)%R f). intros (f,(L1,(L2,L3))). apply Rle_trans with (1:=L2). unfold FtoRradix; apply H3 with b (c+powerRZ radix (Fexp c) / 2)%R (c+r)%R; auto; clear H3. unfold Rminus; apply Rplus_lt_compat_l; auto with real. exists (FSucc b radix prec c); split. apply FBoundedSuc; auto with zarith. split; auto with real. apply ClosestSuccPred with prec; auto with zarith. apply FBoundedSuc; auto with zarith. apply FSuccCanonic; auto with zarith. rewrite succNormal; auto with zarith. replace (c + powerRZ radix (Fexp c) / 2 - (c + powerRZ radix (Fexp c)))%R with (-(powerRZ radix (Fexp c)/2))%R. 2: field. rewrite Rabs_Ropp; rewrite Rabs_right. 2: apply Rle_ge; unfold Rdiv; apply Rmult_le_pos; auto with real zarith. rewrite succNormal; auto with zarith. rewrite succNormal; auto with zarith. replace (c + powerRZ radix (Fexp c) / 2 - (c + powerRZ radix (Fexp c) + powerRZ radix (Fexp (FSucc b radix prec c))))%R with (-(powerRZ radix (Fexp c)/2+powerRZ radix (Fexp (FSucc b radix prec c))))%R. 2: field. rewrite Rabs_Ropp; rewrite Rabs_right. apply Rle_trans with (powerRZ radix (Fexp c) / 2+0)%R; auto with real zarith. apply Rle_ge; apply Rle_trans with (0+0)%R; auto with real. apply Rplus_le_compat; auto with real zarith. unfold Rdiv; apply Rmult_le_pos; auto with real zarith. apply FSuccCanonic; auto with zarith. apply Rle_trans with (1:=H0). left; unfold FtoRradix; apply FSuccLt; auto with zarith. rewrite FPredSuc; fold FtoRradix; auto with zarith. replace (c + powerRZ radix (Fexp c) / 2 - c)%R with ((powerRZ radix (Fexp c)/2))%R;[idtac|ring]. rewrite (Rabs_right (powerRZ radix (Fexp c) / 2)). 2: apply Rle_ge; unfold Rdiv; apply Rmult_le_pos; auto with real zarith. rewrite succNormal; auto. replace (c + powerRZ radix (Fexp c) / 2 - (c + powerRZ radix (Fexp c)))%R with (-(powerRZ radix (Fexp c) / 2))%R. rewrite Rabs_Ropp; rewrite Rabs_right; auto with real. apply Rle_ge; unfold Rdiv; apply Rmult_le_pos; auto with real zarith. field; auto with real. Qed. Lemma Algo1_correct_aux: forall (c c' e cinf csup:float), Fcanonic radix b c -> (0 <= c)%R -> Closest b radix (phi*c) c' -> Closest b radix (c'+eta) e -> Closest b radix (c-e) cinf -> Closest b radix (c+e) csup -> (FtoRradix cinf <= FPred b radix prec c)%R /\ (FtoRradix (FSucc b radix prec c) <= csup)%R . intros c c' e cinf csup Cc Cpos Hc' He Hcinf Hcsup. assert (powerRZ radix (Fexp c)/2 < e)%R. apply eGe with c'; auto. split. apply Algo1_correct_aux_aux with e; auto. apply Algo1_correct_aux_aux2 with e; auto. Qed. Lemma PredSucc_Algo1_correct: forall (c c' e cinf csup:float), Fcanonic radix b c -> Closest b radix (phi*(Rabs c)) c' -> Closest b radix (c'+eta) e -> Closest b radix (c-e) cinf -> Closest b radix (c+e) csup -> (FtoRradix cinf <= FPred b radix prec c)%R /\ (FtoRradix (FSucc b radix prec c) <= csup)%R . intros c c' e cinf csup Cc Hc' He Hcinf Hcsup. case (Rle_or_lt 0 c); intros. apply Algo1_correct_aux with c' e; auto. rewrite <- (Rabs_right c); auto. apply Rle_ge; auto. assert ((Fopp csup <= FPred b radix prec (Fopp c))%R /\ (FSucc b radix prec (Fopp c) <= (Fopp cinf))%R). apply Algo1_correct_aux with c' e; auto. apply FcanonicFopp; auto. unfold FtoRradix; rewrite Fopp_correct; auto with real zarith. replace (FtoRradix (Fopp c)) with (Rabs c); auto. unfold FtoRradix; rewrite Fopp_correct; auto with real zarith. rewrite Rabs_left; auto with real. replace (Fopp c -e)%R with (-(c+e))%R. apply ClosestOpp; auto. unfold FtoRradix; rewrite Fopp_correct; auto with real zarith; ring. replace (Fopp c +e)%R with (-(c-e))%R. apply ClosestOpp; auto. unfold FtoRradix; rewrite Fopp_correct; auto with real zarith; ring. elim H0; intros L1 L2; clear H0; split; apply Ropp_le_cancel. rewrite FPredFopFSucc; auto with zarith. apply Rle_trans with (FSucc b radix prec (Fopp c)). unfold FtoRradix; rewrite Fopp_correct; auto with real zarith. apply Rle_trans with (1:=L2). unfold FtoRradix; rewrite Fopp_correct; auto with real zarith. apply Rle_trans with (Fopp csup). unfold FtoRradix; rewrite Fopp_correct; auto with real zarith. apply Rle_trans with (1:=L1). rewrite FPredFopFSucc; auto with zarith. rewrite Fopp_Fopp. unfold FtoRradix; rewrite Fopp_correct; auto with real zarith. Qed. Hypothesis precisionGreaterThanbis : 4 <= prec. Lemma eLe: forall (c c' e:float), Fcanonic radix b c -> (0 <= c)%R -> Closest b radix (phi*c) c' -> Closest b radix (c'+eta) e -> (-dExp b <= Fexp c-2)%Z -> (e <= powerRZ radix (Fexp c)*(radix/2+powerRZ radix (-2)))%R. intros c c' e H H0 H1 H2 V. assert (Bc:(Fbounded b c));[apply FcanonicBound with radix; auto|idtac]. assert (powerRZ radix (Fexp c) * radix / 2=Float radixH (Fexp c))%R. unfold FtoRradix, FtoR; simpl. pattern radix at 2; rewrite radixEven; rewrite mult_IZR; simpl; field. assert (Fbounded b (Float radixH (Fexp c))). split; simpl. rewrite Zabs_eq; auto with zarith. rewrite pGivesBound; apply Zle_lt_trans with (Zpower_nat radix 1); auto with zarith. apply Zle_trans with radix;[rewrite radixEven| unfold Zpower_nat; simpl]; auto with zarith. elim Bc; auto. assert (powerRZ radix (Fexp c) * radix / 2= Float (radixH*nNormMin radix prec) (Fexp c -prec+1))%R. unfold FtoRradix, FtoR; simpl. rewrite mult_IZR; unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with real zarith. replace (pred prec + (Fexp c - prec + 1))%Z with (Fexp c). rewrite radixEven; rewrite mult_IZR; simpl; field. rewrite inj_pred; auto with zarith. assert ( (-dExp b <= Fexp c -prec+1)%Z -> (Fnormal radix b (Float (radixH*nNormMin radix prec) (Fexp c -prec+1)))). intros I; split; try split; simpl; auto with zarith. rewrite Zabs_eq. unfold nNormMin; rewrite pGivesBound. apply Zlt_le_trans with (radix*Zpower_nat radix (pred prec))%Z; auto with zarith. apply Zmult_gt_0_lt_compat_r; auto with zarith. apply Zlt_gt; auto with zarith. pattern radix at 1; replace radix with (Zpower_nat radix 1). rewrite <- Zpower_nat_is_exp; auto with zarith. unfold Zpower_nat; simpl; auto with zarith. unfold nNormMin; auto with zarith. rewrite Zabs_eq. replace (radix * (radixH * nNormMin radix prec))%Z with (radixH * (radix * nNormMin radix prec))%Z;[idtac| ring]. rewrite <- (PosNormMin radix b prec); auto with zarith. apply Zle_trans with (1*Zpos (vNum b) )%Z; auto with zarith. unfold nNormMin; auto with zarith. assert (powerRZ radix (Fexp c) * radix / 2 = (Float (radixH * nNormMin radix prec) (Fexp c - prec + 1)))%R. unfold FtoRradix, FtoR; simpl. rewrite mult_IZR; unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with real zarith. replace (IZR radixH) with (radix/2)%R. replace (pred prec + (Fexp c - prec + 1))%Z with (Fexp c); [unfold Rdiv; ring|idtac]. rewrite inj_pred; auto with zarith; unfold Zpred; ring. rewrite radixEven; rewrite mult_IZR; simpl; field. assert (c' <= powerRZ radix (Fexp c) * radix / 2)%R. rewrite H3. unfold FtoRradix; rewrite <- FnormalizeCorrect with radix b prec (Float radixH (Fexp c)); auto. generalize ClosestMonotone; unfold MonotoneP; intros T. apply T with b (phi*c)%R (powerRZ radix (Fexp c)*(radixH+powerRZ radix (1-prec) /2))%R; auto; clear T. apply Rle_lt_trans with (phi*((powerRZ radix prec -1)*powerRZ radix (Fexp c)))%R. apply Rmult_le_compat_l. left; apply phi_Pos. unfold FtoRradix, FtoR; simpl; apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (Zpred (Zpos (vNum b))). apply Rle_IZR. assert (Fnum c < (Zpos (vNum b)))%Z; auto with zarith float. apply Zle_lt_trans with (Zabs (Fnum c)); auto with zarith float. unfold Zpred; rewrite plus_IZR; rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ. simpl; right; ring. apply Rle_lt_trans with (powerRZ radix (Fexp c)*(phi*(powerRZ radix prec - 1)))%R;[right; ring|idtac]. apply Rmult_lt_compat_l; auto with real zarith. unfold phi. apply Rle_lt_trans with ((radixH+radix*u)*(1-powerRZ radix (-prec)))%R. right; apply trans_eq with ((radixH + radix * u)* (powerRZ radix prec*u - u))%R;[ring|unfold u]. replace (powerRZ radix prec * powerRZ radix (- prec))%R with 1%R; auto with real. rewrite <- powerRZ_add; auto with real zarith. replace (prec+-prec)%Z with 0%Z; simpl; auto with zarith. apply Rle_lt_trans with (radixH+((radix*u-radixH*powerRZ radix (-prec))-radix*u *powerRZ radix (-prec)))%R;[right; ring|idtac]. apply Rplus_lt_compat_l. replace (IZR radixH) with (radix/2)%R. replace (radix * u - radix/2 * powerRZ radix (- prec))%R with (powerRZ radix (1 - prec) / 2)%R. apply Rlt_le_trans with (powerRZ radix (1 - prec) / 2-0)%R;[idtac|right; ring]. unfold Rminus; apply Rplus_lt_compat_l; apply Ropp_lt_contravar. apply Rle_lt_trans with (radix*u*0)%R;[right; ring|idtac]. unfold u; apply Rmult_lt_compat_l; auto with real zarith. apply Rle_lt_trans with (radix*0)%R;[right; ring|idtac]. apply Rmult_lt_compat_l; auto with real zarith. unfold u, Zminus; rewrite powerRZ_add; auto with real zarith. simpl; field. rewrite radixEven; rewrite mult_IZR; simpl; field; auto with real. apply ClosestSuccPred with prec; auto with zarith real float. rewrite FnormalizeCorrect; auto with zarith. fold FtoRradix; rewrite <- H3. replace (powerRZ radix (Fexp c) * (radixH + powerRZ radix (1 - prec) / 2) - powerRZ radix (Fexp c) * radix / 2)%R with (powerRZ radix (Fexp c)*powerRZ radix (1 - prec) / 2)%R. 2: replace (IZR radixH) with (radix/2)%R;[field|idtac]. 2:rewrite radixEven; rewrite mult_IZR; simpl; field. rewrite Rabs_right. 2: apply Rle_ge; unfold Rdiv; repeat apply Rmult_le_pos; auto with real zarith. rewrite succNormal; auto with zarith float. unfold FtoRradix; rewrite FnormalizeCorrect; auto with zarith. fold FtoRradix; rewrite <- H3. replace (powerRZ radix (Fexp c) * (radixH + powerRZ radix (1 - prec) / 2) - (powerRZ radix (Fexp c) * radix / 2 + powerRZ radix (Fexp (Fnormalize radix b prec (Float radixH (Fexp c))))))%R with (powerRZ radix (Fexp c)*powerRZ radix (1 - prec) / 2 - powerRZ radix (Fexp (Fnormalize radix b prec (Float radixH (Fexp c)))))%R. case (Zle_or_lt (- dExp b) (Fexp c - prec + 1)); intros I. replace (Fnormalize radix b prec (Float radixH (Fexp c))) with (Float (radixH * nNormMin radix prec) (Fexp c - prec + 1)). simpl ((Fexp (Float (radixH * nNormMin radix prec) (Fexp c - prec + 1)))). replace (powerRZ radix (Fexp c) * powerRZ radix (1 - prec) / 2 - powerRZ radix (Fexp c - prec + 1))%R with (-(powerRZ radix (Fexp c) * powerRZ radix (1 - prec) / 2))%R. rewrite Rabs_Ropp. rewrite Rabs_right; auto with real. apply Rle_ge; unfold Rdiv;repeat apply Rmult_le_pos; auto with real zarith. replace (Fexp c - prec + 1)%Z with (Fexp c+(1-prec))%Z;[idtac| ring]. rewrite powerRZ_add; auto with real zarith; field. apply FcanonicUnique with radix b prec; auto with zarith float. left; apply H6; auto. rewrite FnormalizeCorrect; auto with zarith float; fold FtoRradix; rewrite <- H5;auto. rewrite Rabs_left1. apply Rplus_le_reg_l with (powerRZ radix (Fexp c) * powerRZ radix (1 - prec) / 2)%R. apply Rle_trans with (powerRZ radix (Fexp c) * powerRZ radix (1 - prec))%R. right; field. apply Rle_trans with (powerRZ radix (Fexp (Fnormalize radix b prec (Float radixH (Fexp c)))))%R;[idtac|right; ring]. rewrite <- powerRZ_add; auto with real zarith. apply Rle_powerRZ; auto with real zarith. apply Zle_trans with (-dExp b)%Z; auto with zarith. assert (Fbounded b (Fnormalize radix b prec (Float radixH (Fexp c)))); auto with zarith float. apply Rplus_le_reg_l with (powerRZ radix (Fexp (Fnormalize radix b prec (Float radixH (Fexp c))))). ring_simplify. apply Rle_trans with (powerRZ radix (Fexp c) * powerRZ radix (1 - prec))%R. unfold Rdiv; apply Rle_trans with (powerRZ radix (Fexp c) * powerRZ radix (1 - prec) *1)%R;[idtac|right; ring]. apply Rmult_le_compat_l; [apply Rmult_le_pos; auto with real zarith|idtac]. apply Rle_trans with (/1)%R; auto with real. rewrite <- powerRZ_add; auto with real zarith. apply Rle_powerRZ; auto with real zarith. apply Zle_trans with (-dExp b)%Z; auto with zarith. assert (Fbounded b (Fnormalize radix b prec (Float radixH (Fexp c)))); auto with zarith float. replace (IZR radixH) with (radix/2)%R;[field|idtac]. rewrite radixEven; rewrite mult_IZR; simpl; field. unfold FtoRradix; rewrite FnormalizeCorrect; auto with zarith. fold FtoRradix; rewrite <- H3. unfold Rdiv; repeat apply Rmult_le_pos; auto with real zarith. rewrite FnormalizeCorrect; auto with zarith. fold FtoRradix; rewrite <- H3. replace (powerRZ radix (Fexp c) * (radixH + powerRZ radix (1 - prec) / 2) - powerRZ radix (Fexp c) * radix / 2)%R with (powerRZ radix (Fexp c)*powerRZ radix (1 - prec) / 2)%R. 2: replace (IZR radixH) with (radix/2)%R;[field|idtac]. 2:rewrite radixEven; rewrite mult_IZR; simpl; field. rewrite Rabs_right. 2: apply Rle_ge; unfold Rdiv; repeat apply Rmult_le_pos; auto with real zarith. case (Zle_or_lt (- dExp b) (Fexp c - prec + 1)); intros I. replace (Fnormalize radix b prec (Float radixH (Fexp c))) with (Float (radixH * nNormMin radix prec) (Fexp c - prec + 1)). 2: apply FcanonicUnique with radix b prec; auto with zarith float. 2: left; apply H6; auto. 2: rewrite FnormalizeCorrect; auto with zarith float; fold FtoRradix; rewrite <- H5;auto. case (Rle_or_lt (powerRZ radix (prec - dExp b)) (powerRZ radix (Fexp c) * radix / 2)); intros M. case (Z_eq_dec (radixH * nNormMin radix prec) (nNormMin radix prec)); intros N. rewrite predNormal1; auto. rewrite <- H7. simpl ((Fexp (Float (radixH * nNormMin radix prec) (Fexp c - prec + 1)))). replace (powerRZ radix (Fexp c) * (radixH + powerRZ radix (1 - prec) / 2) - (powerRZ radix (Fexp c) * radix / 2 - powerRZ radix (Fexp c - prec + 1 - 1)))%R with ((powerRZ radix (Fexp c) *powerRZ radix (1 - prec)) *(/ 2+/radix))%R. rewrite Rabs_right. unfold Rdiv; apply Rmult_le_compat_l. apply Rmult_le_pos; auto with real zarith. apply Rle_trans with (/2+0)%R; auto with real zarith. apply Rle_ge; repeat apply Rmult_le_pos; auto with real zarith. apply Rle_trans with (0+0)%R; try apply Rplus_le_compat; auto with real zarith. replace (Fexp c - prec + 1-1)%Z with (Fexp c+(1-prec)+(-1))%Z;[idtac|ring]. repeat rewrite powerRZ_add; auto with real zarith. simpl (powerRZ radix (-1)). replace (IZR radixH) with (radix/2)%R;[field; auto with real zarith|idtac]. rewrite radixEven; rewrite mult_IZR; simpl; field. left; auto. rewrite <- H7; auto. rewrite predNormal2; auto. rewrite <- H7. simpl ((Fexp (Float (radixH * nNormMin radix prec) (Fexp c - prec + 1)))). replace (powerRZ radix (Fexp c) * (radixH + powerRZ radix (1 - prec) / 2) - (powerRZ radix (Fexp c) * radix / 2 - powerRZ radix (Fexp c - prec + 1)))%R with ((3*(powerRZ radix (Fexp c) * powerRZ radix (1 - prec)/ 2)))%R. rewrite Rabs_right; auto with real. apply Rle_trans with (1*(powerRZ radix (Fexp c) * powerRZ radix (1 - prec) / 2))%R; [right; ring|apply Rmult_le_compat_r]. unfold Rdiv; repeat apply Rmult_le_pos; auto with real zarith. apply Rle_trans with (IZR 3); auto with real zarith; simpl; right; ring. unfold Rdiv; apply Rle_ge; repeat apply Rmult_le_pos; auto with real zarith. apply Rle_trans with (IZR 3); auto with real zarith; simpl; right; ring. replace (Fexp c - prec + 1)%Z with (Fexp c+(1-prec))%Z;[idtac| ring]. rewrite powerRZ_add; auto with real zarith. replace (IZR radixH) with (radix/2)%R;[field|idtac]. rewrite radixEven; rewrite mult_IZR; simpl; field. left; auto. rewrite <- H7; auto. rewrite predSmallOnes. rewrite <- H7. replace (powerRZ radix (Fexp c) * (radixH + powerRZ radix (1 - prec) / 2) - (powerRZ radix (Fexp c) * radix / 2 - eta))%R with (powerRZ radix (Fexp c) * powerRZ radix (1 - prec) / 2 +eta)%R. rewrite Rabs_right. apply Rle_trans with (powerRZ radix (Fexp c) * powerRZ radix (1 - prec) / 2+0)%R; auto with real. apply Rplus_le_compat_l. unfold eta; auto with real zarith. apply Rle_ge; apply Rle_trans with (0+0)%R; auto with real. apply Rplus_le_compat; try unfold eta; auto with real zarith. unfold Rdiv; repeat apply Rmult_le_pos; auto with real zarith. replace (IZR radixH) with (radix/2)%R;[field|idtac]. rewrite radixEven; rewrite mult_IZR; simpl; field. left; auto. rewrite <- H7; auto. rewrite Rabs_right; auto. apply Rle_ge; unfold Rdiv; repeat apply Rmult_le_pos; auto with real zarith. rewrite predSmallOnes. unfold FtoRradix; rewrite FnormalizeCorrect; auto with zarith. fold FtoRradix; rewrite <- H3. replace (powerRZ radix (Fexp c) * (radixH + powerRZ radix (1 - prec) / 2) - (powerRZ radix (Fexp c) * radix / 2 - eta))%R with (powerRZ radix (Fexp c) * powerRZ radix (1 - prec) / 2 +eta)%R. rewrite Rabs_right. apply Rle_trans with (powerRZ radix (Fexp c) * powerRZ radix (1 - prec) / 2+0)%R; auto with real. apply Rplus_le_compat_l. unfold eta; auto with real zarith. apply Rle_ge; apply Rle_trans with (0+0)%R; auto with real. apply Rplus_le_compat; try unfold eta; auto with real zarith. unfold Rdiv; repeat apply Rmult_le_pos; auto with real zarith. replace (IZR radixH) with (radix/2)%R;[field|idtac]. rewrite radixEven; rewrite mult_IZR; simpl; field. apply FnormalizeCanonic; auto with zarith. unfold FtoRradix; rewrite FnormalizeCorrect; auto with zarith. fold FtoRradix; rewrite <- H3. rewrite Rabs_right. apply Rlt_le_trans with (powerRZ radix (Fexp c+1)). rewrite powerRZ_add; auto with real zarith. unfold Rdiv; rewrite Rmult_assoc; apply Rmult_lt_compat_l; auto with real zarith. simpl; apply Rmult_lt_compat_l; auto with real zarith. apply Rlt_le_trans with (/1)%R; auto with real. apply Rle_powerRZ; auto with real zarith. apply Rle_ge; unfold Rdiv; repeat apply Rmult_le_pos; auto with real zarith. assert (powerRZ radix (Fexp c-1) <= c')%R. apply Rle_trans with (Float 1 (Fexp c -1)). right; unfold FtoRradix, FtoR; simpl; ring. unfold FtoRradix; apply RleBoundRoundl with b prec (Closest b radix) (phi*c)%R; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl; auto with zarith float. apply vNumbMoreThanOne with radix prec; auto with zarith. unfold FtoRradix, FtoR, Zminus; simpl; rewrite powerRZ_add; auto with real zarith. apply Rle_trans with (/radix*powerRZ radix (Fexp c))%R. simpl; right; field; auto with real zarith. rewrite <- Rmult_assoc; apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (phi*nNormMin radix prec)%R. unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. unfold phi, u. apply Rle_trans with (radixH*(powerRZ radix (-prec) *powerRZ radix (pred prec))+radix*(powerRZ radix (-prec) *powerRZ radix (pred prec)*powerRZ radix (-prec)))%R; [idtac|right; ring]. repeat rewrite <- powerRZ_add; auto with real zarith. apply Rle_trans with (/radix+0)%R; auto with real; apply Rplus_le_compat. apply Rle_trans with (1*/radix)%R; auto with real. apply Rmult_le_compat; auto with real zarith. rewrite inj_pred; auto with zarith; unfold Zpred. replace (-prec+(prec+-1))%Z with (-1)%Z;[idtac|ring]. simpl; right; field; auto with real zarith. apply Rmult_le_pos; auto with real zarith. apply Rmult_le_compat_l. left; apply phi_Pos. rewrite <- (Zabs_eq (Fnum c)). apply Rle_IZR. apply pNormal_absolu_min with b; auto with zarith. case H; auto; intros H2'; elim H2'; intros H3' (H4',H5'). absurd (-dExp b Fcanonic radix b c -> (0 <= c)%R -> (Fnum c <> nNormMin radix prec) -> (Fnum c <> nNormMin radix prec+1)%Z -> (r <= 5/4*powerRZ radix (Fexp c))%R -> Closest b radix (c-r) cinf -> (FtoRradix (FPred b radix prec c) <= cinf)%R. intros c cinf r K; intros. assert (Bc:(Fbounded b c));[apply FcanonicBound with radix; auto|idtac]. assert (G1:(0 < 4)%R). apply Rlt_le_trans with (IZR 4); auto with real zarith; simpl; right; ring. assert (G2:(0 < 5)%R). apply Rlt_le_trans with (IZR 5); auto with real zarith; simpl; right; ring. assert (FtoRradix (FPred b radix prec c) = c -powerRZ radix (Fexp c))%R. rewrite FPredSimpl4; auto. unfold FtoRradix, FtoR, Zpred; simpl. rewrite plus_IZR; simpl; ring. assert (-pPred (vNum b) < Fnum c)%Z; auto with zarith float. apply Zlt_le_trans with 0%Z. assert (0 < pPred (vNum b))%Z; auto with zarith float. apply pPredMoreThanOne with radix prec; auto with zarith. apply LeR0Fnum with radix ; auto with real zarith. assert (c - 5 / 4 * powerRZ radix (Fexp c) - FtoR radix (FPred b radix prec c) = (-(/4 * powerRZ radix (Fexp c))))%R. fold FtoRradix; rewrite H5; field. unfold FtoRradix; apply ClosestStrictMonotone2l with b prec (c-r)%R (c-5 / 4 * powerRZ radix (Fexp c))%R; auto with zarith. apply FPredCanonic; auto with zarith. rewrite H6; rewrite Rabs_Ropp. rewrite Rabs_right;[idtac|apply Rle_ge; apply Rmult_le_pos; auto with real zarith]. rewrite FSucPred; auto with zarith; fold FtoRradix. replace (c - 5 / 4 * powerRZ radix (Fexp c) - c)%R with (-(5/4*powerRZ radix (Fexp c)))%R by ring. rewrite Rabs_Ropp; rewrite Rabs_right. apply Rmult_lt_compat_r; auto with real zarith. unfold Rdiv; apply Rle_lt_trans with (1*/4)%R; auto with real. apply Rmult_lt_compat_r; auto with real. apply Rlt_le_trans with (IZR 5); auto with real zarith; simpl; right; ring. apply Rle_ge; unfold Rdiv; repeat apply Rmult_le_pos; auto with real zarith. rewrite H6; rewrite Rabs_Ropp. rewrite Rabs_right;[idtac|apply Rle_ge; apply Rmult_le_pos; auto with real zarith]. assert ((FtoRradix (FPred b radix prec (FPred b radix prec c)) = c-2*powerRZ radix (Fexp c)))%R. assert (FPred b radix prec c = Float (Zpred (Fnum c)) (Fexp c)). rewrite FPredSimpl4; auto with zarith. assert (-pPred (vNum b) < Fnum c)%Z; auto with zarith float. apply Zlt_le_trans with 0%Z. assert (0 < pPred (vNum b))%Z; auto with zarith float. apply pPredMoreThanOne with radix prec; auto with zarith. apply LeR0Fnum with radix ; auto with real zarith. rewrite H7; rewrite FPredSimpl4; auto with zarith. unfold FtoRradix, FtoR; simpl. unfold Zpred; repeat rewrite plus_IZR; simpl; ring. simpl. assert (-pPred (vNum b) < (Zpred (Fnum c)))%Z; auto with zarith float. apply Zlt_le_trans with (Zpred 0)%Z; unfold pPred, Zpred. assert (2 < Zpos (vNum b))%Z; auto with zarith float. rewrite pGivesBound; apply Zle_lt_trans with (Zpower_nat radix 1); auto with zarith. unfold Zpower_nat; simpl; auto with zarith. assert (0 <= Fnum c)%Z; auto with zarith. apply LeR0Fnum with radix ; auto with real zarith. simpl; auto with zarith. fold FtoRradix; rewrite H7. replace (c - 5 / 4 * powerRZ radix (Fexp c) - (c - 2 * powerRZ radix (Fexp c)))%R with ( 3/ 4 * powerRZ radix (Fexp c))%R by field. rewrite Rabs_right; auto with real. apply Rmult_lt_compat_r; auto with real zarith. unfold Rdiv; apply Rle_lt_trans with (1*/4)%R; auto with real. apply Rmult_lt_compat_r; auto with real. apply Rlt_le_trans with (IZR 3); auto with real zarith; simpl; right; ring. apply Rle_ge; unfold Rdiv; repeat apply Rmult_le_pos; auto with real zarith. apply Rle_trans with (IZR 3); auto with real zarith; simpl; right; ring. unfold Rminus; apply Rplus_le_compat_l; auto with real. Qed. Lemma Algo1_correct_r2_aux_aux2:forall (c c' e cinf:float), (radix=2)%Z -> Fcanonic radix b c -> (0 <= c)%R -> (Fnum c = nNormMin radix prec+1)%Z -> (-dExp b <= Fexp c-2)%Z -> Closest b radix (phi*c) c' -> Closest b radix (c'+eta) e -> Closest b radix (c-e) cinf -> (FtoRradix (FPred b radix prec c) <= cinf)%R. intros. assert (Bc:(Fbounded b c));[apply FcanonicBound with radix; auto|idtac]. assert (G1:(0 < 4)%R). apply Rlt_le_trans with (IZR 4); auto with real zarith; simpl; right; ring. assert (G2:(0 < 5)%R). apply Rlt_le_trans with (IZR 5); auto with real zarith; simpl; right; ring. generalize ClosestMonotone; unfold MonotoneP; intros T. unfold FtoRradix; apply T with b (c-5 / 4 * powerRZ radix (Fexp c))%R (c-e)%R; auto. unfold Rminus; apply Rplus_lt_compat_l; auto with real. apply Ropp_lt_contravar. apply Rle_lt_trans with (Float 1 (Fexp c)). apply RleBoundRoundr with b prec (Closest b radix) (c'+eta)%R; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl; auto with zarith float. apply vNumbMoreThanOne with radix prec; auto with zarith. apply Rle_trans with (FtoRradix (Float 3 (Fexp c-2))+powerRZ radix (Fexp c -2))%R. apply Rplus_le_compat. apply RleBoundRoundr with b prec (Closest b radix) (phi*c)%R; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl; auto with zarith float. rewrite pGivesBound; apply Zlt_le_trans with (Zpower_nat radix 2); auto with zarith. unfold Zpower_nat; rewrite H; simpl; auto with zarith. unfold FtoRradix, FtoR; simpl. rewrite H2; unfold phi, u. rewrite plus_IZR; unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. replace radixH with 1%Z; auto with zarith. replace (radix*powerRZ radix (- prec))%R with (powerRZ radix (1-prec)). apply Rle_trans with (powerRZ radix (Fexp c) *(powerRZ radix (-prec)* ((powerRZ radix (pred prec) +1 + powerRZ radix (1 - prec)*powerRZ radix (pred prec) + powerRZ radix (1 - prec)))))%R;[right; simpl; ring|idtac]. rewrite inj_pred; auto with zarith; unfold Zpred. replace (powerRZ radix (1 - prec) * powerRZ radix (prec + -1))%R with 1%R. apply Rle_trans with (powerRZ radix (Fexp c) *(3/4))%R. apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (powerRZ radix (- prec) * powerRZ radix (prec + -1) + (2* powerRZ radix (- prec) + powerRZ radix (- prec)*powerRZ radix (1 - prec)))%R;[right; ring|idtac]. repeat rewrite <- powerRZ_add; auto with real zarith. apply Rle_trans with (/2+/4)%R;[apply Rplus_le_compat|right; field]. replace (- prec + (prec + -1))%Z with (-1)%Z by ring. simpl; rewrite H; simpl; right; field. apply Rle_trans with (2 * powerRZ radix (- 4) + powerRZ radix (- 4))%R. apply Rplus_le_compat. apply Rmult_le_compat_l; auto with real zarith. apply Rle_powerRZ; auto with real zarith. apply Rle_powerRZ; auto with real zarith. rewrite H; simpl; apply Rmult_le_reg_l with (IZR 16); auto with real zarith. apply Rle_trans with (IZR 3);[right; simpl; field|idtac]. apply Rle_trans with (IZR 4);[auto with real zarith|right; simpl; field]. unfold Zminus; rewrite powerRZ_add; auto with real zarith. rewrite H; simpl; right; field. rewrite <- powerRZ_add; auto with real zarith. replace (1 - prec + (prec + -1))%Z with 0%Z by ring; simpl; ring. unfold Zminus; rewrite powerRZ_add; auto with real zarith. unfold eta; apply Rle_powerRZ; auto with real zarith. unfold FtoRradix, FtoR; simpl. unfold Zminus; rewrite powerRZ_add; auto with real zarith. rewrite H; simpl; right; field. unfold FtoRradix, FtoR; simpl; apply Rmult_lt_compat_r; auto with real zarith. apply Rle_lt_trans with (4/4)%R; auto with real. right; field. unfold Rdiv; apply Rmult_lt_compat_r; auto with real. replace 5%R with (IZR 5);[idtac|simpl; ring]. replace 4%R with (IZR 4);[auto with real zarith|simpl; ring]. assert (FtoRradix (FPred b radix prec c) = c -powerRZ radix (Fexp c))%R. rewrite FPredSimpl4; auto. unfold FtoRradix, FtoR, Zpred; simpl. rewrite plus_IZR; simpl; ring. assert (-pPred (vNum b) < Fnum c)%Z; auto with zarith float. apply Zlt_le_trans with 0%Z. assert (0 < pPred (vNum b))%Z; auto with zarith float. apply pPredMoreThanOne with radix prec; auto with zarith. apply LeR0Fnum with radix ; auto with real zarith. rewrite H2; auto with zarith. assert (c - 5 / 4 * powerRZ radix (Fexp c) - FtoR radix (FPred b radix prec c) = (-(/4 * powerRZ radix (Fexp c))))%R. fold FtoRradix; rewrite H7; field. apply ClosestSuccPred with prec; auto with zarith. apply FBoundedPred; auto with zarith. apply FPredCanonic; auto with zarith. rewrite H8; rewrite Rabs_Ropp. rewrite Rabs_right;[idtac|apply Rle_ge; apply Rmult_le_pos; auto with real zarith]. rewrite FSucPred; auto with zarith; fold FtoRradix. replace (c - 5 / 4 * powerRZ radix (Fexp c) - c)%R with (-(5/4*powerRZ radix (Fexp c)))%R by ring. rewrite Rabs_Ropp; rewrite Rabs_right. apply Rmult_le_compat_r; auto with real zarith. unfold Rdiv; apply Rle_trans with (1*/4)%R; auto with real. apply Rmult_le_compat_r; auto with real. apply Rle_trans with (IZR 5); auto with real zarith; simpl; right; ring. apply Rle_ge; unfold Rdiv; repeat apply Rmult_le_pos; auto with real zarith. rewrite H8; rewrite Rabs_Ropp. rewrite Rabs_right;[idtac|apply Rle_ge; apply Rmult_le_pos; auto with real zarith]. assert (FPred b radix prec c=Float (nNormMin radix prec) (Fexp c)). rewrite FPredSimpl4; auto with zarith. replace (Zpred (Fnum c)) with (nNormMin radix prec); auto. rewrite H2; unfold Zpred; ring. assert (-pPred (vNum b) < Fnum c)%Z; auto with zarith float. apply Zlt_le_trans with 0%Z. assert (0 < pPred (vNum b))%Z; auto with zarith float. apply pPredMoreThanOne with radix prec; auto with zarith. apply LeR0Fnum with radix ; auto with real zarith. assert ((FtoRradix (FPred b radix prec (FPred b radix prec c)) = c-3/2*powerRZ radix (Fexp c)))%R. rewrite H9; rewrite FPredSimpl2; auto with zarith. unfold FtoRradix, FtoR; simpl. rewrite H2; unfold pPred, Zpred; repeat rewrite plus_IZR; rewrite pGivesBound. unfold nNormMin; repeat rewrite Zpower_nat_Z_powerRZ; simpl. rewrite inj_pred; auto with zarith; unfold Zpred. repeat rewrite powerRZ_add; auto with real zarith. simpl; rewrite H; simpl; field. simpl; auto with zarith. fold FtoRradix; rewrite H10. replace (c - 5 / 4 * powerRZ radix (Fexp c) - (c - 3/2 * powerRZ radix (Fexp c)))%R with ( / 4 * powerRZ radix (Fexp c))%R by field. rewrite Rabs_right; auto with real. apply Rle_ge; unfold Rdiv; repeat apply Rmult_le_pos; auto with real zarith. Qed. Lemma Algo1_correct_r2_aux_aux3:forall (c c' e cinf:float), (radix=2)%Z -> Fcanonic radix b c -> (0 <= c)%R -> (-dExp b <= Fexp c-3)%Z -> (Fnum c = nNormMin radix prec) -> Closest b radix (phi*c) c' -> Closest b radix (c'+eta) e -> Closest b radix (c-e) cinf -> (prec=4 -> EvenClosest b radix prec (phi*c)%R c' \/ AFZClosest b radix (c-e)%R cinf) -> (FtoRradix (FPred b radix prec c) <= cinf)%R. intros c c' e cinf H H0 H1 H2 H3 H4 H5 H6 MM. assert (FtoRradix (FPred b radix prec c) = (c-/2*powerRZ radix (Fexp c)))%R. rewrite FPredSimpl2; auto with zarith. unfold FtoRradix, FtoR, pPred, Zpred. rewrite pGivesBound; rewrite H3; simpl. rewrite plus_IZR; unfold nNormMin; repeat rewrite Zpower_nat_Z_powerRZ. rewrite inj_pred; auto with zarith; unfold Zpred. repeat rewrite powerRZ_add; auto with real zarith. rewrite H; simpl; field. case (Zle_or_lt (-dExp b) (Fexp c -prec)); intros I. assert (c - / 2 * powerRZ radix (Fexp c) - powerRZ radix (Fexp c + 1 - prec) - FtoR radix (FPred b radix prec c) = (-powerRZ radix (Fexp c + 1 - prec)))%R. fold FtoRradix; rewrite H7; ring. unfold FtoRradix; apply ClosestStrictMonotone2l with b prec (c-e)%R (c-/2*powerRZ radix (Fexp c) - powerRZ radix (Fexp c +1-prec))%R; auto with zarith. apply FPredCanonic; auto with zarith. rewrite H8; rewrite Rabs_Ropp; rewrite Rabs_right. 2: apply Rle_ge; auto with real zarith. rewrite FSucPred; auto with zarith; fold FtoRradix. replace (c - / 2 * powerRZ radix (Fexp c) - powerRZ radix (Fexp c + 1 - prec) - c)%R with (-(/ 2 * powerRZ radix (Fexp c) + powerRZ radix (Fexp c + 1 - prec)))%R by ring. rewrite Rabs_Ropp; rewrite Rabs_right. apply Rle_lt_trans with (0+powerRZ radix (Fexp c + 1 - prec))%R;[right; ring|idtac]. apply Rplus_lt_compat_r; auto with real zarith. apply Rle_lt_trans with (/2*0)%R; try apply Rmult_lt_compat_l; auto with real zarith. apply Rle_ge; apply Rle_trans with (0+0)%R; try apply Rplus_le_compat; auto with real zarith. apply Rmult_le_pos; auto with real zarith. rewrite H8; rewrite Rabs_Ropp; rewrite Rabs_right. 2: apply Rle_ge; auto with real zarith. rewrite FPredSimpl2 with b radix prec c; auto with zarith. rewrite FPredSimpl4; simpl; auto with zarith. replace (FtoR radix (Float (Zpred (pPred (vNum b))) (Zpred (Fexp c)))) with (c-powerRZ radix (Fexp c))%R. replace (c - / 2 * powerRZ radix (Fexp c) - powerRZ radix (Fexp c + 1 - prec) - (c - powerRZ radix (Fexp c)))%R with (/ 2 * powerRZ radix (Fexp c) - powerRZ radix (Fexp c + 1 - prec))%R by field. rewrite Rabs_right. apply Rplus_lt_reg_r with (powerRZ radix (Fexp c + 1 - prec)). apply Rmult_lt_reg_l with 2%R; auto with real. apply Rle_lt_trans with (4*powerRZ radix (Fexp c + 1 - prec))%R;[right; field|idtac]. apply Rle_lt_trans with (powerRZ radix (Fexp c + 3 - prec)). right; unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith. rewrite H; simpl; ring. apply Rlt_le_trans with (powerRZ radix (Fexp c));[idtac|right; field]. apply Rlt_powerRZ; auto with real zarith. apply Rle_ge; apply Rplus_le_reg_l with (powerRZ radix (Fexp c + 1 - prec)). ring_simplify. apply Rle_trans with (powerRZ radix (Fexp c -1)); auto with real zarith. unfold Zminus; rewrite powerRZ_add; auto with real zarith. rewrite H; simpl; right; field. unfold FtoRradix, FtoR; simpl. rewrite H3; unfold pPred; rewrite pGivesBound. unfold nNormMin, Zpred; repeat rewrite plus_IZR. repeat rewrite Zpower_nat_Z_powerRZ; simpl. rewrite inj_pred; auto with zarith; unfold Zpred. repeat rewrite powerRZ_add; auto with real zarith. rewrite H; simpl; field. assert (0 < pPred (vNum b))%Z; auto with zarith. apply pPredMoreThanOne with radix prec; auto with zarith. assert (nNormMin radix prec < pPred (vNum b))%Z; auto with zarith. apply nNormMimLtvNum; auto with zarith. unfold Rminus; rewrite Rplus_assoc; apply Rplus_le_compat_l. apply Rle_trans with (-(/ 2 * powerRZ radix (Fexp c) +powerRZ radix (Fexp c + 1 - prec)))%R;[right; ring|idtac]. apply Ropp_le_contravar. assert (/ 2 * powerRZ radix (Fexp c) + powerRZ radix (Fexp c + 1 - prec) = Float (nNormMin radix prec +2) (Fexp c -prec))%R. unfold FtoRradix, FtoR; simpl. rewrite plus_IZR; unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. rewrite inj_pred; auto with zarith; unfold Zpred, Zminus. repeat rewrite powerRZ_add; auto with real zarith. rewrite H; simpl; rewrite <- Rinv_powerRZ; auto with real zarith. field; auto with real zarith. assert (0 < powerRZ 2 prec)%R; auto with real zarith. rewrite H9; apply RleBoundRoundr with b prec (Closest b radix) (c'+eta)%R; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl; auto with zarith. rewrite Zabs_eq. rewrite PosNormMin with radix b prec; auto with zarith. rewrite H; apply Zlt_le_trans with (nNormMin radix prec + nNormMin radix prec)%Z; auto with zarith. rewrite H; apply Zplus_lt_compat_l. unfold nNormMin; apply Zle_lt_trans with (Zpower_nat 2 1); auto with zarith. apply Zeq_le; rewrite H; ring. unfold nNormMin; auto with zarith. fold FtoRradix; rewrite <- H9. apply Rle_trans with ((/ 2 * powerRZ radix (Fexp c) + powerRZ radix (Fexp c- prec)) + powerRZ radix (Fexp c- prec))%R. 2: unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith. 2: rewrite H; simpl; right; ring. apply Rplus_le_compat. 2: unfold eta; apply Rle_powerRZ; auto with real zarith. assert (/ 2 * powerRZ radix (Fexp c) + powerRZ radix (Fexp c - prec) = Float (nNormMin radix prec+1) (Fexp c-prec))%R. unfold FtoRradix, FtoR; simpl; rewrite plus_IZR. unfold nNormMin; rewrite Zpower_nat_Z_powerRZ; simpl. rewrite inj_pred; auto with zarith; unfold Zpred, Zminus. repeat rewrite powerRZ_add; auto with real zarith. rewrite <- Rinv_powerRZ; auto with real zarith; simpl. rewrite H; simpl; field. assert (0 < powerRZ 2 prec)%R; auto with real zarith. rewrite H10. apply RleBoundRoundr with b prec (Closest b radix) (phi*c)%R; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl; auto with zarith. replace (nNormMin radix prec) with (radixH*nNormMin radix prec)%Z. apply phi_bounded_aux. replace radixH with 1%Z; auto with zarith. fold FtoRradix; rewrite <- H10. unfold phi,u, FtoRradix, FtoR; simpl. rewrite H3; unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. rewrite inj_pred; auto with zarith; unfold Zpred. unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith. rewrite <- Rinv_powerRZ; auto with real zarith; simpl. replace (IZR radixH) with 1%R. rewrite H; simpl; right; field. assert (0 < powerRZ 2 prec)%R; auto with real zarith. replace radixH with 1%Z; auto with real zarith. case (Zle_lt_or_eq (Fexp c) (-dExp b+prec-1)); auto with zarith; intros I'. assert (G1: (0 < 8)%R). apply Rlt_le_trans with (IZR 8); [auto with real zarith|simpl; right; ring]. assert (G2: (0 < 5)%R). apply Rlt_le_trans with (IZR 5); [auto with real zarith|simpl; right; ring]. assert (c - 5/8* powerRZ radix (Fexp c) - FtoR radix (FPred b radix prec c) = (-(/ 8 * powerRZ radix (Fexp c))))%R. fold FtoRradix; rewrite H7; field. unfold FtoRradix; apply ClosestStrictMonotone2l with b prec (c-e)%R (c-5/8*powerRZ radix (Fexp c))%R; auto with zarith. apply FPredCanonic; auto with zarith. rewrite H8; rewrite Rabs_Ropp; rewrite Rabs_right. 2: apply Rle_ge; apply Rmult_le_pos; auto with real zarith. rewrite FSucPred; auto with zarith; fold FtoRradix. replace (c - 5/8* powerRZ radix (Fexp c) - c)%R with (- (5/8*powerRZ radix (Fexp c)))%R by ring. rewrite Rabs_Ropp; rewrite Rabs_right. 2: apply Rle_ge; unfold Rdiv; repeat apply Rmult_le_pos; auto with real zarith. apply Rmult_lt_compat_r; auto with real zarith. apply Rle_lt_trans with (1*/8)%R; [right; ring|unfold Rdiv; apply Rmult_lt_compat_r; auto with real zarith]. apply Rlt_le_trans with (IZR 5)%R; auto with real zarith. right; simpl; ring. rewrite H8; rewrite Rabs_Ropp; rewrite Rabs_right. 2: apply Rle_ge; apply Rmult_le_pos; auto with real zarith. rewrite FPredSimpl2 with b radix prec c; auto with zarith. rewrite FPredSimpl4; simpl; auto with zarith. replace (FtoR radix (Float (Zpred (pPred (vNum b))) (Zpred (Fexp c)))) with (c-powerRZ radix (Fexp c))%R. replace (c - 5/ 8 * powerRZ radix (Fexp c) - (c - powerRZ radix (Fexp c)))%R with (3/ 8 * powerRZ radix (Fexp c))%R by field. rewrite Rabs_right. 2: apply Rle_ge; unfold Rdiv; repeat apply Rmult_le_pos; auto with real zarith. 2: apply Rle_trans with (IZR 3); auto with real zarith; simpl; right; ring. apply Rmult_lt_compat_r; auto with real zarith. apply Rle_lt_trans with (1*/8)%R; [right; ring|unfold Rdiv; apply Rmult_lt_compat_r; auto with real zarith]. apply Rlt_le_trans with (IZR 3)%R; auto with real zarith. right; simpl; ring. unfold FtoRradix, FtoR; simpl. rewrite H3; unfold pPred; rewrite pGivesBound. unfold nNormMin, Zpred; repeat rewrite plus_IZR. repeat rewrite Zpower_nat_Z_powerRZ; simpl. rewrite inj_pred; auto with zarith; unfold Zpred. repeat rewrite powerRZ_add; auto with real zarith. rewrite H; simpl; field. assert (0 < pPred (vNum b))%Z; auto with zarith. apply pPredMoreThanOne with radix prec; auto with zarith. assert (nNormMin radix prec < pPred (vNum b))%Z; auto with zarith. apply nNormMimLtvNum; auto with zarith. unfold Rminus; apply Rplus_le_compat_l; apply Ropp_le_contravar. assert (5 / 8 * powerRZ radix (Fexp c)= Float 5 (Fexp c-3))%R. unfold FtoRradix, FtoR, Zminus; simpl. rewrite powerRZ_add; auto with real zarith. rewrite H; simpl; field. rewrite H9; apply RleBoundRoundr with b prec (Closest b radix) (c'+eta)%R; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl; auto with zarith. rewrite pGivesBound; apply Zlt_le_trans with (Zpower_nat radix 3); auto with zarith. rewrite H; simpl; auto with zarith. fold FtoRradix; rewrite <- H9. apply Rle_trans with (powerRZ radix (Fexp c-1)+ powerRZ radix (Fexp c-3))%R. 2: right; unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith. 2: rewrite H; simpl; field. apply Rplus_le_compat. 2: unfold eta; apply Rle_powerRZ; auto with real zarith. assert (powerRZ radix (Fexp c - 1) = Float (Zpower_nat radix (Zabs_nat (Fexp c-1+dExp b))) (-dExp b))%R. unfold FtoRradix, FtoR; simpl; rewrite Zpower_nat_Z_powerRZ. rewrite <- powerRZ_add; auto with real zarith. replace (Zabs_nat (Fexp c - 1 + dExp b) + - dExp b)%Z with (Fexp c-1)%Z; auto with zarith. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. assert (Fsubnormal radix b (Float (Zpower_nat radix (Zabs_nat (Fexp c - 1 + dExp b))) (- dExp b))). split; try split; simpl; auto with zarith. rewrite Zabs_eq; auto with zarith. rewrite pGivesBound; apply Zpower_nat_monotone_lt; auto with zarith. apply ZleLe. apply Zle_trans with (Zabs_nat (Fexp c - 1 + dExp b)+1)%nat; auto with zarith. rewrite inj_plus; rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. simpl; auto with zarith. rewrite Zabs_eq; auto with zarith. apply Zle_lt_trans with (Zpower_nat radix (1+Zabs_nat (Fexp c - 1 + dExp b))). apply Zeq_le;rewrite Zpower_nat_is_exp; auto with zarith. replace (Zpower_nat radix 1) with radix; auto with zarith. unfold Zpower_nat; simpl; ring. rewrite pGivesBound; apply Zpower_nat_monotone_lt; auto with zarith. apply ZleLe. apply Zle_trans with ((1+Zabs_nat (Fexp c - 1 + dExp b)+1))%nat; auto with zarith. repeat rewrite inj_plus; rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. apply Zle_trans with (Fexp c +dExp b +1)%Z; auto with zarith. replace (Z_of_nat 1) with 1%Z; auto with zarith. rewrite H10. apply ClosestStrictMonotone2r with b prec (phi*c)%R (powerRZ radix (Fexp c -1) + powerRZ radix (Fexp c -prec))%R; auto with zarith. right; auto. fold FtoRradix; rewrite <- H10. ring_simplify (powerRZ radix (Fexp c - 1) + powerRZ radix (Fexp c - prec) - powerRZ radix (Fexp c - 1))%R. rewrite Rabs_right; try (apply Rle_ge; auto with real zarith). rewrite succNormal. 2: right; auto. 2: rewrite <- H10; auto with real zarith. rewrite <- H10; simpl. replace (powerRZ radix (Fexp c - 1) + powerRZ radix (Fexp c - prec) - (powerRZ radix (Fexp c - 1) + powerRZ radix (- dExp b)))%R with ( - (powerRZ radix (- dExp b) - powerRZ radix (Fexp c - prec)))%R by ring. rewrite Rabs_Ropp; rewrite Rabs_right. apply Rplus_lt_reg_r with (powerRZ radix (Fexp c - prec)); ring_simplify. apply Rle_lt_trans with (powerRZ radix (1+(Fexp c - prec))). rewrite powerRZ_add; auto with real zarith. rewrite H; simpl; right; ring. apply Rlt_powerRZ; auto with real zarith. apply Rle_ge; apply Rplus_le_reg_l with (powerRZ radix (Fexp c - prec)); ring_simplify. apply Rle_powerRZ; auto with real zarith. fold FtoRradix; rewrite <- H10. ring_simplify (powerRZ radix (Fexp c - 1) + powerRZ radix (Fexp c - prec) - powerRZ radix (Fexp c - 1))%R. rewrite Rabs_right; try (apply Rle_ge; auto with real zarith). rewrite predSmallOnes; auto with zarith. rewrite <- H10; unfold eta. replace (powerRZ radix (Fexp c - 1) + powerRZ radix (Fexp c - prec) - (powerRZ radix (Fexp c - 1) - powerRZ radix (- dExp b)))%R with (powerRZ radix (- dExp b)+powerRZ radix (Fexp c - prec))%R by ring. rewrite Rabs_right. apply Rle_lt_trans with (0+powerRZ radix (Fexp c - prec))%R; auto with real zarith. apply Rle_ge; apply Rle_trans with (0+0)%R; auto with real. apply Rplus_le_compat; auto with real zarith. right; auto. rewrite <- H10. rewrite Rabs_right; try (apply Rle_ge; auto with real zarith). apply Rlt_powerRZ; auto with real zarith. unfold phi, u, FtoRradix, FtoR; simpl; rewrite H3. replace radixH with 1%Z; auto with zarith. unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. rewrite inj_pred; auto with zarith; unfold Zpred, Zminus. repeat rewrite powerRZ_add; auto with real zarith. rewrite <- Rinv_powerRZ; auto with real zarith. rewrite H; simpl; right; field. assert (0 < powerRZ 2 prec)%R; auto with real zarith. case (Zle_lt_or_eq 4 prec); auto with zarith; intros precBis. assert (c - / 2 * powerRZ radix (Fexp c) - powerRZ radix (1- dExp b) - FtoR radix (FPred b radix prec c) = -powerRZ radix (1- dExp b))%R. fold FtoRradix; rewrite H7; ring. unfold FtoRradix; apply ClosestStrictMonotone2l with b prec (c-e)%R (c-/2*powerRZ radix (Fexp c) - powerRZ radix (1-dExp b))%R; auto with zarith. apply FPredCanonic; auto with zarith. rewrite H8; rewrite Rabs_Ropp; rewrite Rabs_right. 2: apply Rle_ge; auto with real zarith. rewrite FSucPred; auto with zarith; fold FtoRradix. replace (c - / 2 * powerRZ radix (Fexp c) - powerRZ radix (1- dExp b) - c)%R with (-(/2*powerRZ radix (Fexp c) + powerRZ radix (1-dExp b)))%R by ring. rewrite Rabs_Ropp; rewrite Rabs_right. apply Rle_lt_trans with (0+powerRZ radix (1- dExp b))%R; auto with real. apply Rplus_lt_compat_r. apply Rle_lt_trans with (/2*0)%R; auto with real. apply Rmult_lt_compat_l; auto with real zarith. apply Rle_ge; apply Rle_trans with (0+0)%R; auto with real. apply Rplus_le_compat; try apply Rmult_le_pos; auto with real zarith. rewrite H8; rewrite Rabs_Ropp; rewrite Rabs_right. 2: apply Rle_ge; auto with real zarith. rewrite FPredSimpl2 with b radix prec c; auto with zarith. rewrite FPredSimpl4;auto with zarith. simpl (Fnum (Float (pPred (vNum b)) (Zpred (Fexp c)))). simpl (Fexp (Float (pPred (vNum b)) (Zpred (Fexp c)))). replace (FtoR radix (Float (Zpred (pPred (vNum b))) (Zpred (Fexp c)))) with (c-powerRZ radix (Fexp c))%R. replace (c - / 2 * powerRZ radix (Fexp c) - powerRZ radix (1- dExp b) - (c - powerRZ radix (Fexp c)))%R with (/ 2 * powerRZ radix (Fexp c) - powerRZ radix (1- dExp b))%R by field. rewrite Rabs_right. apply Rplus_lt_reg_r with (powerRZ radix (1- dExp b)); ring_simplify. apply Rle_lt_trans with (powerRZ radix (1+(1- dExp b))). rewrite powerRZ_add; auto with real zarith. rewrite H; simpl; right; ring. apply Rlt_le_trans with (powerRZ radix (Fexp c-1)). apply Rlt_powerRZ; auto with real zarith. unfold Zminus; rewrite powerRZ_add; auto with real zarith. rewrite H; simpl; right; field. apply Rle_ge; apply Rplus_le_reg_l with (powerRZ radix (1- dExp b)); ring_simplify. apply Rle_trans with (powerRZ radix (Fexp c-1)). apply Rle_powerRZ; auto with real zarith. unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith. rewrite H; simpl; right; field. unfold FtoRradix, FtoR; simpl. rewrite H3; unfold pPred; rewrite pGivesBound. unfold nNormMin, Zpred; repeat rewrite plus_IZR. repeat rewrite Zpower_nat_Z_powerRZ; simpl. rewrite inj_pred; auto with zarith; unfold Zpred. repeat rewrite powerRZ_add; auto with real zarith. rewrite H; simpl; field. simpl; assert (0 < pPred (vNum b))%Z; auto with zarith. apply pPredMoreThanOne with radix prec; auto with zarith. simpl; assert (nNormMin radix prec < pPred (vNum b))%Z; auto with zarith. apply nNormMimLtvNum; auto with zarith. unfold Rminus; rewrite Rplus_assoc; apply Rplus_le_compat_l. apply Rle_trans with (-(/ 2 * powerRZ radix (Fexp c) +powerRZ radix (1- dExp b)))%R;[right; ring|idtac]. apply Ropp_le_contravar. assert (/ 2 * powerRZ radix (Fexp c) + powerRZ radix (1 - dExp b) = Float (Zpower_nat radix (pred (pred prec)) +2) (-dExp b))%R. unfold FtoRradix, FtoR. simpl (Fnum (Float (Zpower_nat radix (pred (pred prec)) + 2) (- dExp b))). simpl (Fexp (Float (Zpower_nat radix (pred (pred prec)) + 2) (- dExp b))). rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ; rewrite I'. repeat rewrite inj_pred; auto with zarith; unfold Zpred, Zminus. repeat rewrite powerRZ_add; auto with real zarith. rewrite H; simpl; field. rewrite H9; apply RleBoundRoundr with b prec (Closest b radix) (c'+eta)%R; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl; auto with zarith. rewrite Zabs_eq; auto with zarith. rewrite pGivesBound; apply Zlt_le_trans with (Zpower_nat radix (pred prec+1)); auto with zarith. apply Zlt_le_trans with (Zpower_nat radix (pred prec)+Zpower_nat radix (pred prec))%Z; auto with zarith. apply Zplus_lt_compat; auto with zarith. replace 2%Z with (Zpower_nat radix 1); auto with zarith. rewrite H; simpl; auto. rewrite Zpower_nat_is_exp; auto with zarith; rewrite H. replace (Zpower_nat 2 1) with 2%Z; auto with zarith. fold FtoRradix; rewrite <- H9. apply Rle_trans with ( (/2 * powerRZ radix (Fexp c) +powerRZ radix (- dExp b))+powerRZ radix (- dExp b))%R. unfold eta; apply Rplus_le_compat_r. 2: unfold Zminus; rewrite powerRZ_add; auto with real zarith. 2: rewrite H; simpl; right; ring. clear H8 H9. assert ( /2 * powerRZ radix (Fexp c) + powerRZ radix (- dExp b) = Float (Zpower_nat radix (pred (pred prec)) + 1) (- dExp b))%R. unfold FtoRradix, FtoR. simpl (Fnum (Float (Zpower_nat radix (pred (pred prec)) + 1) (- dExp b))). simpl (Fexp (Float (Zpower_nat radix (pred (pred prec)) + 1) (- dExp b))). rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ; rewrite I'. repeat rewrite inj_pred; auto with zarith; unfold Zpred, Zminus. repeat rewrite powerRZ_add; auto with real zarith. rewrite H; simpl; field. rewrite H8. apply RleBoundRoundr with b prec (Closest b radix) (phi*c)%R; auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl; auto with zarith. rewrite Zabs_eq; auto with zarith. rewrite pGivesBound. apply Zle_lt_trans with (Zpower_nat radix (pred prec)+1)%Z. apply Zplus_le_compat_r. apply Zpower_nat_monotone_le; auto with zarith. apply Zlt_le_trans with (Zpower_nat radix (pred prec) +Zpower_nat radix (pred prec))%Z. apply Zplus_lt_compat_l. apply Zle_lt_trans with (Zpower_nat radix 0); auto with zarith. pattern prec at 3; replace prec with (pred prec +1); auto with zarith. rewrite Zpower_nat_is_exp; rewrite H; simpl; auto with zarith. unfold Zpower_nat at 4; simpl; auto with zarith. fold FtoRradix; rewrite <- H8. unfold phi,u, FtoRradix, FtoR; simpl. rewrite H3; rewrite I'; unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. replace radixH with 1%Z; auto with zarith. apply Rle_trans with (powerRZ radix (- prec)*powerRZ radix (pred prec) * powerRZ radix (- dExp b + prec - 1) + radix*(powerRZ radix (- prec)*powerRZ radix (- prec) *powerRZ radix (pred prec) * powerRZ radix (- dExp b + prec - 1)))%R;[simpl; right; ring|idtac]. repeat rewrite <- powerRZ_add; auto with real zarith. apply Rplus_le_compat. apply Rle_trans with (powerRZ radix (-1+((- dExp b + prec - 1)))). apply Rle_powerRZ; auto with real zarith. rewrite inj_pred; auto with zarith; unfold Zpred; auto with zarith. rewrite powerRZ_add; auto with real zarith. rewrite H; simpl; right; field. pattern (IZR radix) at 1; replace (IZR radix) with (powerRZ radix 1); auto with real zarith. 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. (* the one problematic float *) assert (FtoRradix c=powerRZ radix (6-dExp b))%R. unfold FtoRradix, FtoR; rewrite H3; rewrite I'. unfold nNormMin; rewrite Zpower_nat_Z_powerRZ; rewrite <- powerRZ_add; auto with real zarith. replace (pred prec + (- dExp b + prec - 1))%Z with (6 - dExp b)%Z; auto. replace prec with 4%nat; auto with zarith. simpl (pred 4); simpl (Z_of_nat 4); simpl (Z_of_nat 3); auto with zarith. assert (FtoRradix (Float 4 (-dExp b)) = 4*powerRZ radix (-dExp b))%R. unfold FtoRradix, FtoR; simpl; ring. assert (EvenClosest b radix prec (phi * c) c' -> FtoRradix c'=Float 4 (-dExp b))%R. intros; generalize EvenClosestUniqueP; unfold UniqueP; intros T. unfold FtoRradix; apply T with b prec (phi*c)%R; auto with zarith; clear T. assert (Fcanonic radix b (Float 4 (- dExp b))). right; repeat split; simpl; auto with zarith. rewrite pGivesBound; replace 4%Z with (Zpower_nat radix 2); auto with zarith. unfold Zpower_nat; rewrite H; simpl; auto with zarith. rewrite pGivesBound; rewrite H. rewrite Zabs_eq; auto with zarith. replace (2*4)%Z with (Zpower_nat 2 3); auto with zarith. assert (phi * c - FtoR radix (Float 4 (- dExp b)) = powerRZ radix (-1-dExp b))%R. rewrite H8; unfold phi,u. replace radixH with 1%Z; auto with zarith. fold FtoRradix; rewrite H9. rewrite Rmult_plus_distr_l; rewrite Rmult_plus_distr_r. replace (powerRZ radix (- prec) * 1%Z)%R with (powerRZ radix (- prec)); [idtac|simpl; ring]. pattern (IZR radix) at 4; replace (IZR radix) with (powerRZ radix 1); auto with real. repeat rewrite <- powerRZ_add; auto with real zarith. replace (- prec + (6 - dExp b))%Z with (2-dExp b)%Z; auto with zarith. replace (- prec + (1 + - prec) + (6 - dExp b))%Z with (-1-dExp b)%Z; auto with zarith. replace (powerRZ radix (2 - dExp b)) with (4 * powerRZ radix (- dExp b))%R;[ring|idtac]. unfold Zminus; rewrite powerRZ_add; auto with real zarith. rewrite H; simpl; ring. split. apply ClosestSuccPred with prec; auto with zarith. apply FcanonicBound with radix; auto with zarith. rewrite H12. rewrite Rabs_right; [idtac|apply Rle_ge; auto with real zarith]. rewrite succNormal; auto with zarith. replace ((phi * c - (Float 4 (- dExp b) + powerRZ radix (Fexp (Float 4 (- dExp b))))))%R with ((phi * c - FtoR radix (Float 4 (- dExp b))) - powerRZ radix (Fexp (Float 4 (- dExp b))))%R;[rewrite H12|unfold FtoRradix; ring]. simpl (Fexp (Float 4 (- dExp b))). replace (powerRZ radix (-1 - dExp b) - powerRZ radix (- dExp b))%R with (-powerRZ radix (-1 - dExp b))%R. rewrite Rabs_Ropp; rewrite Rabs_right; [idtac|apply Rle_ge]; auto with real zarith. unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith. rewrite H; simpl; field. rewrite H9; repeat apply Rmult_le_pos; auto with real zarith. rewrite H12. rewrite Rabs_right; [idtac|apply Rle_ge; auto with real zarith]. rewrite predSmallOnes; auto. replace ((phi * c - (Float 4 (- dExp b) -eta )))%R with ((phi * c - FtoR radix (Float 4 (- dExp b))) + eta)%R;[rewrite H12|unfold FtoRradix; ring]. unfold eta; rewrite Rabs_right. apply Rle_trans with (powerRZ radix (-1 - dExp b)+0)%R; auto with real zarith. apply Rle_ge; apply Rle_trans with (0+0)%R; try apply Rplus_le_compat; auto with real zarith. replace (FtoRradix (Float 4 (- dExp b))) with (powerRZ radix (2-dExp b)). rewrite Rabs_right; try apply Rle_ge; auto with real zarith. rewrite H9; unfold Zminus; rewrite powerRZ_add; auto with real zarith. rewrite H; simpl; ring. left; unfold FNeven. rewrite FcanonicFnormalizeEq; auto with zarith. unfold Feven; simpl; unfold Even. exists 2%Z; auto with zarith. assert (FtoRradix c' = Float 4 (- dExp b) -> (FPred b radix prec c <= cinf)%R). intros. assert (FtoRradix(Float 5 (- dExp b)) = (5 * powerRZ radix (- dExp b)))%R. unfold FtoRradix, FtoR; simpl; ring. assert (FtoRradix e=Float 5 (- dExp b)). apply sym_eq; apply RoundedModeProjectorIdemEq with b prec (Closest b radix); auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl; auto with zarith. rewrite pGivesBound; apply Zlt_le_trans with (Zpower_nat radix 3); auto with zarith. rewrite H; unfold Zpower_nat; simpl; auto with zarith. replace (FtoR radix (Float 5 (- dExp b))) with (c'+eta)%R; auto. fold FtoRradix; rewrite H12; rewrite H11; rewrite H9; unfold eta; ring. assert (FPred b radix prec c= Float (pPred (vNum b)) (- dExp b +2)). rewrite FPredSimpl2; auto with zarith. replace ((Zpred (Fexp c))) with (-dExp b+2)%Z; auto. rewrite I'; unfold Zpred; rewrite <- precBis; ring. assert (c - e - FtoR radix (FPred b radix prec c)= -powerRZ radix (- dExp b))%R. rewrite predNormal1; auto with zarith. rewrite H13; rewrite H12; rewrite I'. replace (powerRZ radix (- dExp b + prec - 1 - 1)) with (4* powerRZ radix (- dExp b))%R;[ring|idtac]. replace (-dExp b +prec-1-1)%Z with (-dExp b+2)%Z; auto with zarith. rewrite powerRZ_add; auto with real zarith. rewrite H; simpl; ring. rewrite H8; auto with real zarith. right; apply sym_eq; apply ClosestStrictEq with b prec (c-e)%R; auto with zarith. apply FPredCanonic; auto with zarith. rewrite H15; rewrite Rabs_Ropp. rewrite Rabs_right; [idtac|apply Rle_ge; auto with real zarith]. rewrite FSucPred; auto with zarith. fold FtoRradix; replace (c-e-c)%R with (-e)%R by ring. rewrite H13; rewrite H12; rewrite Rabs_Ropp. rewrite Rabs_right; [idtac|apply Rle_ge; apply Rmult_le_pos; auto with real zarith]. apply Rle_lt_trans with (1*powerRZ radix (- dExp b))%R; auto with real. apply Rmult_lt_compat_r; auto with real zarith. replace 5%R with (IZR 5); auto with real zarith; simpl; ring. replace 5%R with (IZR 5); auto with real zarith; simpl; ring. rewrite H15; rewrite Rabs_Ropp. rewrite Rabs_right; [idtac|apply Rle_ge; auto with real zarith]. rewrite H14; rewrite FPredSimpl4; auto with zarith; simpl. replace (FtoR radix (Float (Zpred (pPred (vNum b))) (- dExp b + 2))) with (c-8*powerRZ radix (- dExp b))%R. 2: unfold pPred, Zpred; rewrite pGivesBound. 2: unfold FtoR; simpl. 2: repeat rewrite plus_IZR; simpl; rewrite Zpower_nat_Z_powerRZ. 2: repeat rewrite Rmult_plus_distr_r with (r3:=powerRZ radix (- dExp b + 2)). 2: rewrite <- powerRZ_add; auto with real zarith; rewrite H8. 2: replace (prec + (- dExp b + 2))%Z with (6 - dExp b)%Z; auto with zarith. 2: repeat rewrite powerRZ_add with (m:=2); auto with real zarith. 2: rewrite H; simpl; ring. replace (c - e - (c - 8 * powerRZ radix (- dExp b)))%R with ((3*powerRZ radix (- dExp b)))%R. rewrite Rabs_right; try apply Rle_ge; auto with real zarith. apply Rle_lt_trans with (1*powerRZ radix (- dExp b))%R; auto with real. apply Rmult_lt_compat_r; auto with real zarith. replace 3%R with (IZR 3); auto with real zarith; simpl; ring. apply Rmult_le_pos; auto with real zarith. replace 3%R with (IZR 3); auto with real zarith; simpl; ring. rewrite H13; rewrite H12; ring. assert (0 < pPred (vNum b))%Z; auto with zarith. apply pPredMoreThanOne with radix prec; auto with zarith. assert (nNormMin radix prec < pPred (vNum b))%Z; auto with zarith. apply nNormMimLtvNum; auto with zarith. case MM; auto with zarith. intros. assert (phi*c=9/2*powerRZ radix (-dExp b))%R. rewrite H8; unfold phi,u; rewrite <- precBis. replace (radixH) with 1%Z; auto with zarith. unfold Zminus; rewrite powerRZ_add; auto with real zarith. rewrite H; simpl; field. assert (FtoRradix (Float 5 (- dExp b)) = 5 * powerRZ radix (- dExp b))%R. unfold FtoRradix, FtoR; simpl; ring. assert (Fcanonic radix b (Float 4 (- dExp b))). right; split; split; simpl; auto with zarith. rewrite pGivesBound; rewrite H. replace prec with 4%nat; auto with zarith. rewrite pGivesBound; rewrite H. replace prec with 4%nat; auto with zarith. assert (Fcanonic radix b (Float 5 (- dExp b))). right; split; split; simpl; auto with zarith. rewrite pGivesBound; rewrite H. replace prec with 4%nat; auto with zarith. rewrite pGivesBound; rewrite H. replace prec with 4%nat; auto with zarith. assert (FtoRradix c'= Float 4 (- dExp b) \/ FtoRradix c'= Float 5 (- dExp b))%R. generalize ClosestMinOrMax; unfold MinOrMaxP; intros T. case (T b radix (phi*c)%R c'); auto; clear T. intros; left. apply (MinUniqueP b radix (phi*c)%R); auto. split; auto. apply FcanonicBound with radix; auto. split. fold FtoRradix; rewrite H9; rewrite H13. apply Rmult_le_compat_r; auto with real zarith. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with 9%R;[auto with real|right; field]. apply Rle_trans with (8+1)%R; auto with real. intros. apply Rle_trans with (FtoR radix (FPred b radix prec (Float 5 (- dExp b)))). rewrite <- FnormalizeCorrect with radix b prec f; auto. apply FPredProp; auto with zarith. apply FnormalizeCanonic; auto with zarith. rewrite FnormalizeCorrect; auto with zarith. apply Rle_lt_trans with (1:=H19). fold FtoRradix; rewrite H14; rewrite H13. apply Rmult_lt_compat_r; auto with real zarith. apply Rmult_lt_reg_l with 2%R; auto with real. apply Rle_lt_trans with 9%R;[right; field|idtac]. apply Rlt_le_trans with (9+1)%R; auto with real. right; ring. rewrite predSmallOnes; auto with zarith. fold FtoRradix; rewrite H14; rewrite H9. unfold eta; right; ring. rewrite H14; rewrite Rabs_right. unfold Zminus; rewrite powerRZ_add; auto with real zarith. apply Rmult_lt_compat_r; auto with real zarith. rewrite H; rewrite <- precBis; simpl. apply Rlt_le_trans with (IZR 16); auto with real zarith. apply Rle_lt_trans with (IZR 5); auto with real zarith. right; simpl; ring. right; simpl; ring. apply Rle_ge; apply Rmult_le_pos; auto with real zarith. apply Rle_trans with (IZR 5); auto with real zarith; right; simpl; ring. intros; right. apply (MaxUniqueP b radix (phi*c)%R); auto. split; auto. apply FcanonicBound with radix; auto. split. fold FtoRradix; rewrite H14; rewrite H13. apply Rmult_le_compat_r; auto with real zarith. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with 9%R;[right; field|idtac]. apply Rle_trans with (9+1)%R; auto with real. right; ring. intros. apply Rle_trans with (FtoR radix (FSucc b radix prec (Float 4 (- dExp b)))). rewrite succNormal; auto with zarith. fold FtoRradix; rewrite H9; rewrite H14; simpl; right; ring. rewrite H9; repeat apply Rmult_le_pos; auto with real zarith. rewrite <- FnormalizeCorrect with radix b prec f; auto. apply FSuccProp; auto with zarith. apply FnormalizeCanonic; auto with zarith. rewrite FnormalizeCorrect; auto with zarith. apply Rlt_le_trans with (2:=H19). fold FtoRradix; rewrite H9; rewrite H13. apply Rmult_lt_compat_r; auto with real zarith. apply Rmult_lt_reg_l with 2%R; auto with real. apply Rlt_le_trans with 9%R;[idtac|right; field]. apply Rlt_le_trans with (8+1)%R; auto with real. case H17; auto. intros. assert (FtoRradix e=Float 6 (- dExp b)). apply sym_eq; apply RoundedModeProjectorIdemEq with b prec (Closest b radix); auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl; auto with zarith. rewrite pGivesBound; apply Zlt_le_trans with (Zpower_nat radix 3); auto with zarith. rewrite H; unfold Zpower_nat; simpl; auto with zarith. replace (FtoR radix (Float 6 (- dExp b))) with (c'+eta)%R; auto. rewrite H18; unfold FtoRradix, FtoR; unfold eta; simpl; ring. assert (FPred b radix prec c= Float (pPred (vNum b)) (- dExp b +2)). rewrite FPredSimpl2; auto with zarith. replace ((Zpred (Fexp c))) with (-dExp b+2)%Z; auto. rewrite I'; unfold Zpred; rewrite <- precBis; ring. assert (FtoRradix (Float 6 (- dExp b)) = (6 * powerRZ radix (- dExp b))%R). unfold FtoRradix, FtoR; simpl; ring. assert (c - e - FtoR radix (FPred b radix prec c)= -(2* powerRZ radix (- dExp b)))%R. rewrite predNormal1; auto with zarith. rewrite H19; rewrite H21; rewrite I'. replace (powerRZ radix (- dExp b + prec - 1 - 1)) with (4* powerRZ radix (- dExp b))%R;[ring|idtac]. replace (-dExp b +prec-1-1)%Z with (-dExp b+2)%Z; auto with zarith. rewrite powerRZ_add; auto with real zarith. rewrite H; simpl; ring. rewrite H8; auto with real zarith. generalize AFZClosestUniqueP; unfold UniqueP; intros T. right; unfold FtoRradix; apply T with b prec (c-e)%R; auto with zarith. clear T; split. apply ClosestSuccPred with prec; auto with zarith. apply FBoundedPred; auto with zarith. apply FcanonicBound with radix; auto. apply FPredCanonic; auto with zarith. rewrite H22; rewrite Rabs_Ropp. rewrite Rabs_right; [idtac|apply Rle_ge; apply Rmult_le_pos; auto with real zarith]. rewrite FSucPred; auto with zarith. fold FtoRradix; replace (c-e-c)%R with (-e)%R by ring. rewrite H19; rewrite H21; rewrite Rabs_Ropp. rewrite Rabs_right; [idtac|apply Rle_ge; apply Rmult_le_pos; auto with real zarith]. apply Rmult_le_compat_r; auto with real zarith. replace 6%R with (IZR 6); auto with real zarith. replace 2%R with (IZR 2); auto with real zarith. simpl; ring. replace 6%R with (IZR 6); auto with real zarith; simpl; ring. rewrite H22; rewrite Rabs_Ropp. rewrite Rabs_right; [idtac|apply Rle_ge; apply Rmult_le_pos; auto with real zarith]. rewrite H20; rewrite FPredSimpl4; auto with zarith; simpl. replace (FtoR radix (Float (Zpred (pPred (vNum b))) (- dExp b + 2))) with (c-8*powerRZ radix (- dExp b))%R. 2: unfold pPred, Zpred; rewrite pGivesBound. 2: unfold FtoR; simpl. 2: repeat rewrite plus_IZR; simpl; rewrite Zpower_nat_Z_powerRZ. 2: repeat rewrite Rmult_plus_distr_r with (r3:=powerRZ radix (- dExp b + 2)). 2: rewrite <- powerRZ_add; auto with real zarith; rewrite H8. 2: replace (prec + (- dExp b + 2))%Z with (6 - dExp b)%Z; auto with zarith. 2: repeat rewrite powerRZ_add with (m:=2); auto with real zarith. 2: rewrite H; simpl; ring. replace (c - e - (c - 8 * powerRZ radix (- dExp b)))%R with ((2*powerRZ radix (- dExp b)))%R. rewrite Rabs_right; auto with real; try apply Rle_ge; apply Rmult_le_pos; auto with real zarith. rewrite H19; rewrite H21; ring. assert (0 < pPred (vNum b))%Z; auto with zarith. apply pPredMoreThanOne with radix prec; auto with zarith. assert (nNormMin radix prec < pPred (vNum b))%Z; auto with zarith. apply nNormMimLtvNum; auto with zarith. left; repeat rewrite Rabs_right; try apply Rle_ge. apply Rminus_le; rewrite H22. apply Rle_trans with (-0)%R; auto with real; apply Ropp_le_contravar. apply Rmult_le_pos;auto with real zarith. rewrite H20; apply LeFnumZERO; simpl; auto with zarith. assert (0 < pPred (vNum b))%Z; auto with zarith. apply pPredMoreThanOne with radix prec; auto with zarith. apply Rplus_le_reg_l with e; ring_simplify. rewrite H19; rewrite H21; rewrite H8; unfold Zminus. rewrite powerRZ_add; auto with real zarith. apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (powerRZ radix 3); auto with real zarith. rewrite H; simpl; apply Rle_trans with (IZR 6). right; simpl; ring. apply Rle_trans with (IZR 8); auto with real zarith. right; simpl; ring. Qed. Lemma Algo1_correct_r2_aux_aux4:forall (c csup:float) (r:R), Fcanonic radix b c -> (0 <= c)%R -> (r <= 5/4*powerRZ radix (Fexp c))%R -> Closest b radix (c+r) csup -> (FtoRradix csup <= FSucc b radix prec c)%R. intros c csup r; intros. assert (N:Fbounded b c). apply FcanonicBound with radix; auto. assert (G1:(0 < 4)%R). apply Rlt_le_trans with (IZR 4); auto with real zarith; simpl; right; ring. assert (G2:(0 < 5)%R). apply Rlt_le_trans with (IZR 5); auto with real zarith; simpl; right; ring. assert (c + 5 / 4 * powerRZ radix (Fexp c) - FtoR radix (FSucc b radix prec c) = (/4*powerRZ radix (Fexp c)))%R. rewrite succNormal; auto with zarith; field. apply ClosestStrictMonotone2r with b prec (c+r)%R (c+5/4*powerRZ radix (Fexp c))%R; auto with zarith. apply FSuccCanonic; auto with zarith. rewrite H3. rewrite Rabs_right. 2: apply Rle_ge; unfold Rdiv; apply Rmult_le_pos; auto with real zarith. rewrite succNormal; auto with zarith. rewrite succNormal; auto with zarith. replace (c + 5/4*powerRZ radix (Fexp c) - (c + powerRZ radix (Fexp c) + powerRZ radix (Fexp (FSucc b radix prec c))))%R with ((/4*powerRZ radix (Fexp c)-powerRZ radix (Fexp (FSucc b radix prec c))))%R. 2: field. assert (Fexp (FSucc b radix prec c) = Fexp c \/ (Fexp (FSucc b radix prec c) = Fexp c+1)%Z). unfold FSucc. case (Z_eq_bool (Fnum c) (pPred (vNum b))). right; simpl; unfold Zsucc; auto. generalize (Z_eq_bool_correct (Fnum c) (- nNormMin radix prec)); case (Z_eq_bool (Fnum c) (- nNormMin radix prec)). intros; absurd (0 <= Fnum c)%Z. apply Zlt_not_le; apply Zlt_le_trans with (-0)%Z; auto with zarith. rewrite H4; unfold nNormMin; auto with zarith. apply LeR0Fnum with radix ; auto with real zarith. intros; left; simpl; auto. case H4; intros M; rewrite M. replace (/ 4 * powerRZ radix (Fexp c) - powerRZ radix (Fexp c))%R with (-(3/4*powerRZ radix (Fexp c) ))%R by field. rewrite Rabs_Ropp; rewrite Rabs_right. apply Rmult_lt_compat_r; auto with real zarith. apply Rle_lt_trans with (1*/4)%R; unfold Rdiv; auto with real. apply Rmult_lt_compat_r; auto with real. apply Rlt_le_trans with (IZR 3); auto with real zarith; simpl; right; ring. apply Rle_ge; unfold Rdiv; repeat apply Rmult_le_pos; auto with real zarith. apply Rle_trans with (IZR 3); auto with real zarith; simpl; right; ring. replace (/ 4 * powerRZ radix (Fexp c) - powerRZ radix (Fexp c+1))%R with (-((radix-/4)*powerRZ radix (Fexp c) ))%R. 2: rewrite powerRZ_add; auto with real zarith; simpl; field. rewrite Rabs_Ropp; rewrite Rabs_right. apply Rmult_lt_compat_r; auto with real zarith. apply Rle_lt_trans with (1*/4)%R; unfold Rdiv; auto with real. apply Rlt_le_trans with ((4*radix-1)*/4)%R;[idtac|right; field]. apply Rmult_lt_compat_r; auto with real. apply Rplus_lt_reg_r with 1%R; ring_simplify. apply Rlt_le_trans with (4*1)%R; auto with real zarith. apply Rlt_le_trans with (4)%R; auto with real zarith. apply Rle_lt_trans with (2*1)%R; auto with real zarith. apply Rle_ge; apply Rmult_le_pos; auto with real zarith. apply Rplus_le_reg_l with (/4)%R; ring_simplify. apply Rle_trans with 1%R; auto with real zarith. apply Rle_trans with (/1)%R; auto with real. apply Rle_Rinv; auto with real. apply Rle_trans with (IZR 4); auto with real zarith; simpl; right; ring. apply FSuccCanonic; auto with zarith. apply Rle_trans with (1:=H0). left; unfold FtoRradix; apply FSuccLt; auto with zarith. rewrite H3. rewrite FPredSuc; fold FtoRradix; auto with zarith. replace (c + 5/4*powerRZ radix (Fexp c) - c)%R with (5/4*(powerRZ radix (Fexp c)))%R;[idtac|ring]. rewrite (Rabs_right (5/4*(powerRZ radix (Fexp c) ))). 2: apply Rle_ge; unfold Rdiv;repeat apply Rmult_le_pos; auto with real zarith. rewrite Rabs_right. 2: apply Rle_ge; apply Rmult_le_pos; auto with real zarith. apply Rmult_lt_compat_r; auto with real zarith. apply Rle_lt_trans with (1*/4)%R; auto with real. apply Rmult_lt_compat_r; auto with real zarith. apply Rlt_le_trans with (IZR 5); auto with real zarith; simpl; right; ring. apply Rplus_le_compat_l; auto. Qed. Lemma Algo1_correct_r2_aux1: forall (c c' e cinf csup:float), (radix=2)%Z -> Fcanonic radix b c -> (0 <= c)%R -> (powerRZ radix (prec+1-dExp b) < c)%R -> Closest b radix (phi*c) c' -> Closest b radix (c'+eta) e -> Closest b radix (c-e) cinf -> Closest b radix (c+e) csup -> (prec=4 -> EvenClosest b radix prec (phi*c)%R c' \/ AFZClosest b radix (c-e) cinf) -> (FtoRradix (FPred b radix prec c) <= cinf)%R /\ (FtoRradix csup <= FSucc b radix prec c)%R. intros c c' e cinf csup K Cc Cpos CGe Hc' He Hcinf Hcsup MM. assert (- dExp b +2 <= Fexp c )%Z. apply Zle_trans with (Fexp (Float (nNormMin radix prec) (-dExp b+2))); auto with zarith. apply Fcanonic_Rle_Zle with radix b prec; auto with zarith. left; split; try split; simpl; auto with zarith. unfold nNormMin; rewrite pGivesBound; rewrite Zabs_eq; auto with zarith. rewrite <- (PosNormMin radix b prec); auto with zarith. fold (FtoRradix c). replace (FtoR radix (Float (nNormMin radix prec) (- dExp b + 2))) with (powerRZ radix (prec + 1 - dExp b)). repeat rewrite Rabs_right; try apply Rle_ge; auto with real zarith. unfold FtoR; simpl. unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. rewrite <- powerRZ_add; auto with real zarith. replace (pred prec + (- dExp b + 2))%Z with (prec+1-dExp b)%Z; auto. rewrite inj_pred; unfold Zpred; auto with zarith. assert (e <= 5/4*powerRZ radix (Fexp c))%R. apply Rle_trans with (powerRZ radix (Fexp c) * (radix / 2 + powerRZ radix (-2)))%R. apply eLe with c'; auto with zarith. rewrite K; simpl; right; field. split. 2: apply Algo1_correct_r2_aux_aux4 with e; auto. case (Z_eq_dec (Fnum c) (nNormMin radix prec)); intros L1. apply Algo1_correct_r2_aux_aux3 with c' e; auto. case (Zle_lt_or_eq (- dExp b + 2) (Fexp c)); auto with zarith. intros M. Contradict CGe. replace (FtoRradix c) with (powerRZ radix (prec + 1 - dExp b)); auto with real. unfold FtoRradix, FtoR; simpl; rewrite <- M; rewrite L1. unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. rewrite <- powerRZ_add; auto with real zarith. replace (pred prec + (- dExp b + 2))%Z with (prec+1-dExp b)%Z; auto. rewrite inj_pred; unfold Zpred; auto with zarith. case (Z_eq_dec (Fnum c) (nNormMin radix prec+1)); intros L2. apply Algo1_correct_r2_aux_aux2 with c' e; auto with zarith. apply Algo1_correct_r2_aux_aux1 with e; auto with zarith. Qed. Lemma Algo1_correct_r2_aux2: forall (c c' e cinf csup:float), (radix=2)%Z -> Fcanonic radix b c -> (0 <= c)%R -> (c < powerRZ radix (prec-dExp b-1))%R -> Closest b radix (phi*c) c' -> Closest b radix (c'+eta) e -> Closest b radix (c-e) cinf -> Closest b radix (c+e) csup -> (FtoRradix (FPred b radix prec c) <= cinf)%R /\ (FtoRradix csup <= FSucc b radix prec c)%R. intros. cut (FtoRradix e = eta)%R; [intros P|idtac]. split. right; unfold FtoRradix. apply RoundedModeProjectorIdemEq with b prec (Closest b radix); auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. apply FBoundedPred; auto with zarith. apply FcanonicBound with radix; auto. replace (FtoR radix (FPred b radix prec c))%R with (c-e)%R; auto. fold FtoRradix; rewrite predSmallOnes; auto. rewrite P; auto. rewrite Rabs_right; try apply Rle_ge; auto with real zarith. apply Rlt_le_trans with (1:=H2); auto with real zarith. right; unfold FtoRradix; apply sym_eq. apply RoundedModeProjectorIdemEq with b prec (Closest b radix); auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. apply FBoundedSuc; auto with zarith. apply FcanonicBound with radix; auto. replace (FtoR radix (FSucc b radix prec c))%R with (c+e)%R; auto. fold FtoRradix; rewrite succNormal; auto. rewrite P; unfold eta; replace (Fexp c) with (-dExp b)%Z; auto. case H0; auto; intros J. absurd (FtoRradix (firstNormalPos radix b prec) <= c)%R. apply Rlt_not_le; unfold FtoRradix; rewrite firstNormalPos_eq; auto with zarith. fold FtoRradix; apply Rlt_le_trans with (1:=H2). apply Rle_powerRZ; unfold Zpred; auto with real zarith. apply FnormalLtFirstNormalPos; auto with zarith. elim J; intuition. apply sym_eq; apply trans_eq with (Float 1 (-(dExp b))). unfold eta, FtoRradix, FtoR; simpl; ring. apply RoundedModeProjectorIdemEq with b prec (Closest b radix); auto with zarith. apply ClosestRoundedModeP with prec; auto with zarith. split; simpl; auto with zarith float. apply vNumbMoreThanOne with radix prec; auto with zarith. replace (FtoR radix (Float 1 (- dExp b))) with (c'+eta)%R; auto. replace (FtoRradix c') with 0%R. unfold eta, FtoRradix, FtoR; simpl; ring. apply sym_eq; apply RoundedToZero with (phi*c)%R; auto. rewrite Rabs_mult. repeat rewrite Rabs_right; try apply Rle_ge; auto with real. assert (exists f:float, Fbounded b f /\ (f=Float 1 (prec - dExp b-1)) /\ (FtoRradix f= powerRZ radix (prec - dExp b-1))%R). exists (Float 1 (prec-dExp b-1)). split; try split; simpl; auto with zarith. apply vNumbMoreThanOne with radix prec; auto with zarith. unfold FtoRradix, FtoR; simpl; ring. elim H7; intros f (Bf,(L2,L3)). apply Rle_lt_trans with (phi*(FPred b radix prec (Fnormalize radix b prec f)))%R. apply Rmult_le_compat_l; auto with real. left; apply phi_Pos. apply FPredProp; auto with zarith real. apply FnormalizeCanonic; auto with zarith. rewrite FnormalizeCorrect; auto with zarith. fold FtoRradix; rewrite L3; auto. rewrite predSmallOnes. unfold FtoRradix; rewrite FnormalizeCorrect; auto with zarith. fold FtoRradix; rewrite L3; unfold eta, phi. unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith. replace radixH with 1%Z; auto with zarith. apply Rle_lt_trans with ( (u * (1 + radix * u) * (powerRZ radix prec * powerRZ radix (- (1)) -1 )) * powerRZ radix (-(dExp b)))%R. simpl; right; ring. apply Rmult_lt_compat_r; auto with real zarith. apply Rle_lt_trans with (/radix - powerRZ radix (1-prec-prec))%R. replace (powerRZ radix prec) with (/powerRZ radix (-prec))%R. unfold u; right; unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith. simpl; field; auto with real zarith. rewrite <- Rinv_powerRZ; auto with real zarith. apply Rlt_le_trans with (/radix-0)%R; auto with real zarith. unfold Rminus; apply Rplus_lt_compat_l; auto with real zarith. apply Rle_trans with (/radix)%R; auto with real zarith. apply Rle_Rinv; auto with real zarith. apply Rle_trans with (IZR 2); auto with real zarith. apply FnormalizeCanonic; auto with zarith. unfold FtoRradix; rewrite FnormalizeCorrect; auto with zarith. fold FtoRradix; rewrite L3. rewrite Rabs_right; try apply Rle_ge; auto with real zarith. left; apply phi_Pos. Qed. Lemma Algo1_correct_r2_aux3: forall (c c' e cinf csup:float), (radix=2)%Z -> Fcanonic radix b c -> (Rabs c < powerRZ radix (prec-dExp b-1))%R \/ (powerRZ radix (prec+1-dExp b) < Rabs c)%R -> Closest b radix (phi*(Rabs c)) c' -> Closest b radix (c'+eta) e -> Closest b radix (c-e) cinf -> Closest b radix (c+e) csup -> (prec=4 -> EvenClosest b radix prec (phi*Rabs c)%R c' \/ (AFZClosest b radix (c-e) cinf /\ AFZClosest b radix (c+e) csup)) -> (FtoRradix (FPred b radix prec c) <= cinf)%R /\ (FtoRradix csup <= FSucc b radix prec c)%R. intros c c' e cinf csup K Cc CInt Hc' He Hcinf Hcsup MM. case (Rle_or_lt 0 c); intros. case CInt; intros. apply Algo1_correct_r2_aux2 with c' e; auto. rewrite <- (Rabs_right c); auto. apply Rle_ge; auto. rewrite <- (Rabs_right c); auto. apply Rle_ge; auto. apply Algo1_correct_r2_aux1 with c' e; auto. rewrite <- (Rabs_right c); auto. apply Rle_ge; auto. rewrite <- (Rabs_right c); auto. apply Rle_ge; auto. intros; case MM; auto; intros. left; rewrite <- (Rabs_right c); auto. apply Rle_ge; auto. elim H2; auto. assert ((FPred b radix prec (Fopp c) <= Fopp csup)%R /\ (Fopp cinf <= FSucc b radix prec (Fopp c) )%R). case CInt; intros. apply Algo1_correct_r2_aux2 with c' e; auto. apply FcanonicFopp; auto. unfold FtoRradix; rewrite Fopp_correct; auto with real zarith. replace (FtoRradix (Fopp c)) with (Rabs c); auto. unfold FtoRradix; rewrite Fopp_correct; auto with real zarith. rewrite Rabs_left; auto with real. replace (FtoRradix (Fopp c)) with (Rabs c); auto. unfold FtoRradix; rewrite Fopp_correct; auto with real zarith. rewrite Rabs_left; auto with real. replace (Fopp c -e)%R with (-(c+e))%R. apply ClosestOpp; auto. unfold FtoRradix; rewrite Fopp_correct; auto with real zarith; ring. replace (Fopp c +e)%R with (-(c-e))%R. apply ClosestOpp; auto. unfold FtoRradix; rewrite Fopp_correct; auto with real zarith; ring. apply Algo1_correct_r2_aux1 with c' e; auto. apply FcanonicFopp; auto. unfold FtoRradix; rewrite Fopp_correct; auto with real zarith. replace (FtoRradix (Fopp c)) with (Rabs c); auto. unfold FtoRradix; rewrite Fopp_correct; auto with real zarith. rewrite Rabs_left; auto with real. replace (FtoRradix (Fopp c)) with (Rabs c); auto. unfold FtoRradix; rewrite Fopp_correct; auto with real zarith. rewrite Rabs_left; auto with real. replace (Fopp c -e)%R with (-(c+e))%R. apply ClosestOpp; auto. unfold FtoRradix; rewrite Fopp_correct; auto with real zarith; ring. replace (Fopp c +e)%R with (-(c-e))%R. apply ClosestOpp; auto. unfold FtoRradix; rewrite Fopp_correct; auto with real zarith; ring. intros; case MM; auto; intros. left; replace (FtoRradix (Fopp c)) with (Rabs c); auto. unfold FtoRradix; rewrite Fopp_correct; auto with real zarith. rewrite Rabs_left; auto with real. elim H2; intros. right; replace (Fopp c -e)%R with (-(c+e))%R. apply AFZClosestSymmetric; auto. unfold FtoRradix; rewrite Fopp_correct; auto with real zarith; ring. elim H0; intros L1 L2; clear H0; split; apply Ropp_le_cancel. rewrite FPredFopFSucc; auto with zarith. apply Rle_trans with (FSucc b radix prec (Fopp c)). apply Rle_trans with (2:=L2). unfold FtoRradix; rewrite Fopp_correct; auto with real zarith. unfold FtoRradix; rewrite Fopp_correct; auto with real zarith. apply Rle_trans with (Fopp csup). 2: unfold FtoRradix; rewrite Fopp_correct; auto with real zarith. apply Rle_trans with (2:=L1). rewrite FPredFopFSucc; auto with zarith. rewrite Fopp_Fopp. unfold FtoRradix; rewrite Fopp_correct; auto with real zarith. Qed. Lemma PredSucc_Algo1_correct_r2: forall (c c' e cinf csup:float), (radix=2)%Z -> Fcanonic radix b c -> (Rabs c < powerRZ radix (prec-dExp b-1))%R \/ (powerRZ radix (prec+1-dExp b) < Rabs c)%R -> Closest b radix (phi*(Rabs c)) c' -> Closest b radix (c'+eta) e -> Closest b radix (c-e) cinf -> Closest b radix (c+e) csup -> (prec=4 -> EvenClosest b radix prec (phi*Rabs c)%R c' \/ (AFZClosest b radix (c-e) cinf /\ AFZClosest b radix (c+e) csup)) -> (FtoRradix (FPred b radix prec c) = cinf)%R /\ (FtoRradix csup = FSucc b radix prec c)%R. intros. assert ((FtoRradix (FPred b radix prec c) <= cinf)%R /\ (FtoRradix csup <= FSucc b radix prec c)%R). apply Algo1_correct_r2_aux3 with c' e; auto. assert ((FtoRradix cinf<= (FPred b radix prec c))%R /\ (FtoRradix (FSucc b radix prec c) <= csup)%R). apply PredSucc_Algo1_correct with c' e; auto. elim H7; elim H8; intros; split; auto with real. Qed. End PredComput. Float8.4/Others/DblRndOdd.v0000644000423700002640000014412412032774527015307 0ustar sboldotoccataRequire Export AllFloat. Section plouf. Variable bound : Fbound. Variable radix : Z. Variable precision : nat. Coercion Local FtoRradix := FtoR radix. Hypothesis radixMoreThanOne : (1 < radix)%Z. Hypothesis precisionMoreThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum bound) = Zpower_nat radix precision. Lemma radixNotZero: (0 < radix)%Z. auto with zarith. Qed. Lemma precisionNotZero : ~(precision = (0)). auto with zarith. Qed. Lemma ClosestInfPredExp : forall f : float, forall x : R, Closest bound radix x f -> Fnum f = nNormMin radix precision -> (Fexp f <> -dExp bound)%Z -> (2%nat*f - powerRZ radix (Fexp f - 1) <= 2%nat*x)%R. intros f x Hc Hm He. assert ((Rabs (FtoR radix f - x) <= Rabs (FtoR radix (FPred bound radix precision f) - x))%R). apply (proj2 Hc). apply (FBoundedPred _ _ _ radixMoreThanOne precisionNotZero pGivesBound). exact (proj1 Hc). cut (f - x <= x - FPred bound radix precision f)%R. intro H0. cut (powerRZ radix (Fexp f - 1) = (f - FPred bound radix precision f))%R. intro H1. rewrite H1. clear H1. apply Rplus_le_reg_l with (-x - FPred bound radix precision f)%R. simpl. ring_simplify. apply Rle_trans with (2:=H0); right; ring. rewrite <- (Fminus_correct _ radixNotZero). rewrite (FPredDiff3 _ _ _ radixMoreThanOne precisionNotZero pGivesBound _ Hm He). unfold FtoR, Zpred; simpl; auto with real zarith. apply Rle_trans with (Rabs (f - x))%R. apply RRle_abs. apply Rle_trans with (1 := H). rewrite Rabs_left1. auto with real. case (Rle_or_lt (FPred bound radix precision f) x); intro H0. apply Rplus_le_reg_l with x. ring_simplify. exact H0. assert ((FPred bound radix precision f) < f)%R. apply (FPredLt _ _ _ radixMoreThanOne precisionNotZero pGivesBound). assert (x < f)%R. apply Rlt_trans with (1 := H0) (2 := H1). assert (Rabs (FtoR radix (FPred bound radix precision f) - x) < Rabs (FtoR radix f - x))%R. repeat rewrite Rabs_right; try (apply Rle_ge; auto with real). unfold Rminus. apply Rplus_lt_compat_r. exact H1. absurd (Rabs (f - x) < Rabs (f - x))%R. auto with real. apply Rle_lt_trans with (1 := H) (2 := H3). Qed. End plouf. Section RndOdd. Variable b : Fbound. Variable radix : Z. Variable precision : nat. Coercion Local FtoRradix := FtoR radix. Hypothesis radixMoreThanOne : (1 < radix)%Z. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Definition To_Odd (r : R) (p : float) := Fbounded b p /\ ((r=p) \/ (((isMin b radix r p) \/ (isMax b radix r p)) /\ (FNodd b radix precision p))). Theorem To_OddTotal : TotalP To_Odd. red in |- *; intros r. case MinEx with (r := r) (3 := pGivesBound); auto with arith. intros min H1. case MaxEx with (r := r) (3 := pGivesBound); auto with arith. intros max H2. cut (min <= r)%R; [ intros Rl1 | apply isMin_inv1 with (1 := H1) ]. cut (r <= max)%R; [ intros Rl2 | apply isMax_inv1 with (1 := H2) ]. case H1;intros Fmin tmp; clear tmp. case H2;intros Fmax tmp; clear tmp. case (Req_dec min max); intros H3. exists min; unfold To_Odd; split; [elim H1; auto|idtac]. left; cut (r <= min)%R; auto with real;rewrite H3; auto. case (FNevenOrFNodd b radix precision min). intros H4;exists max; unfold To_Odd; split; [elim H2; auto|idtac]. right; split;[right;auto|idtac]. apply FNoddEq with (f1 := FNSucc b radix precision min); auto. apply FcanonicBound with (radix := radix). apply FNSuccCanonic; auto with arith. apply MaxEq with (b := b) (r := r); auto. apply MinMax; auto with arith. Contradict H3; auto. apply (ProjectMax b radix);auto. rewrite <- H3; auto. apply FNevenSuc;auto. intros H4;exists min; unfold To_Odd; split; auto. Qed. Theorem To_OddCompatible : CompatibleP b radix To_Odd. red in |- *; simpl in |- *. intros r1 r2 p q H H1 H2 H3. unfold To_Odd; split;auto. elim H; intros H4 H5. case H5; intros H6. left; rewrite <- H1; rewrite H6;auto with real. elim H6; clear H5 H6; intros H5 H6. case H5; clear H5; intros H5;right; split. left; apply MinCompatible with (p := p) (r1 := r1);auto. apply FNoddEq with p;auto. right; apply MaxCompatible with (p := p) (r1 := r1);auto. apply FNoddEq with p;auto. Qed. Theorem To_OddMinOrMax : MinOrMaxP b radix To_Odd. red in |- *. intros r p H; elim H; intros H1 H2; case H2; intros H3; clear H2. right. rewrite H3; auto with float zarith. unfold FtoRradix; apply (RoundedModeProjectorIdem b radix (isMax b radix));auto. apply MaxRoundedModeP with precision;auto. elim H3;auto. Qed. Theorem To_OddMonotone : MonotoneP radix To_Odd. red in |- *. intros r1 r2 f1 f2 H1 H2 H3. elim H2; intros B1 tmp;case tmp;intros H4; clear tmp. elim H3; intros B2 tmp;case tmp;intros H5; clear tmp. fold FtoRradix; rewrite <- H5; rewrite <- H4; auto with real. elim H5; intros H6 H7; case H6; clear H5 H6 H7; intros H5. elim H5; intros T1 T2; elim T2; intros T3 T4; clear T1 T2. apply T4; auto; fold FtoRradix;rewrite <- H4; auto with real. elim H5; intros T1 T2; elim T2; intros T3 T4; clear T1 T2. apply Rle_trans with (2:=T3); fold FtoRradix;rewrite <- H4; auto with real. elim H3; intros B2 tmp;case tmp;intros H5; clear tmp. elim H4; intros H6 H7; case H6; clear H4 H6 H7; intros H4. elim H4; intros T1 T2; elim T2; intros T3 T4; clear T1 T2. apply Rle_trans with (1:=T3); fold FtoRradix;rewrite <- H5; auto with real. elim H4; intros T1 T2; elim T2; intros T3 T4; clear T1 T2. apply T4; auto; fold FtoRradix;rewrite <- H5; auto with real. elim H4; clear H4; intros H6 H7; case H6; clear H6; intros H6. elim H5; clear H5; intros H8 H9; case H8; clear H8; intros H8. elim H8; intros T1 T2; elim T2; intros T3 T4; clear T1 T2. apply T4; auto; apply Rle_trans with r1; auto with real. elim H6; intros T1 T2; elim T2; intros T3' T4'; clear T1 T2;auto. elim H6; intros T1 T2; elim T2; intros T3' T4'; clear T1 T2. elim H8; intros T1 T2; elim T2; intros T3 T4; clear T1 T2. apply Rle_trans with r1; auto with real. apply Rle_trans with r2; auto with real. elim H5; clear H5; intros H8 H9; case H8; clear H8; intros H8. rewrite <- FNPredSuc with b radix precision f2;auto with arith. apply FNPredProp; auto with arith. apply FcanonicBound with (radix := radix). apply FNSuccCanonic;auto with arith. cut (FtoR radix f1 <= FtoR radix (FNSucc b radix precision f2))%R. intros T; case T; auto; intros T1. absurd (FNeven b radix precision f1). apply FnOddNEven;auto. apply FNevenEq with (FNSucc b radix precision f2);auto. apply FcanonicBound with (radix := radix). apply FNSuccCanonic;auto with arith. apply FNoddSuc; auto. case MaxEx with (r := r2) (3 := pGivesBound); auto with arith. intros v H10. apply Rle_trans with (FtoR radix v). apply (MonotoneMax b radix) with (p := r1) (q := r2); auto. elim H10; intros T1 T2; elim T2; intros T3 T4; clear T2. apply T4; auto. apply FcanonicBound with (radix := radix). apply FNSuccCanonic;auto with arith. clear T1 T3 T4;elim H8; intros T1 T2; elim T2; intros T3 T4; clear T2. case (Rle_or_lt r2 (FtoR radix (FNSucc b radix precision f2)));auto; intros T. absurd (FtoR radix (FNSucc b radix precision f2) <= FtoR radix f2)%R. apply Rlt_not_le; apply FNSuccLt; auto with arith. apply T4; auto with real. apply FcanonicBound with (radix := radix). apply FNSuccCanonic;auto with arith. apply (MonotoneMax b radix) with (p := r1) (q := r2); auto. Qed. Theorem To_OddRoundedModeP : RoundedModeP b radix To_Odd. split; try exact To_OddTotal. split; try exact To_OddCompatible. split; try exact To_OddMinOrMax. exact To_OddMonotone. Qed. Theorem To_OddUniqueP : UniqueP radix To_Odd. red in |- *; simpl in |- *. intros r p q T1 T2. elim T1; intros B1 tmp1;elim T2; intros B2 tmp2; clear tmp1 tmp2. case (Req_dec p r); intros H. apply RoundedProjector with (b:=b) (radix:=radix) (P:=To_Odd);auto. apply To_OddRoundedModeP. fold FtoRradix; rewrite H; auto. case (Req_dec q r); intros H'. apply sym_eq;apply RoundedProjector with (b:=b) (radix:=radix) (P:=To_Odd);auto. apply To_OddRoundedModeP. fold FtoRradix; rewrite H'; auto. case T1; intros g1 g2; case g2;intros H1;clear g1 g2. absurd ((FtoRradix p)=r)%R; auto with real. case T2; intros g1 g2; case g2;intros H2;clear g1 g2. absurd ((FtoRradix q)=r)%R; auto with real. elim H1; clear H1; intros H3 H4; elim H2; clear H2; intros H1 H2. case H3; case H1 ; clear H1 H3; intros H1 H3. apply (MinUniqueP b radix r); auto. absurd (FNeven b radix precision q). apply FnOddNEven;auto. apply FNevenEq with (FNSucc b radix precision p);auto. apply FcanonicBound with (radix := radix). apply FNSuccCanonic;auto with arith. apply (MaxUniqueP b radix r); auto. apply MinMax; auto with zarith. apply FNoddSuc; auto. absurd (FNeven b radix precision p). apply FnOddNEven;auto. apply FNevenEq with (FNSucc b radix precision q);auto. apply FcanonicBound with (radix := radix). apply FNSuccCanonic;auto with arith. apply (MaxUniqueP b radix r); auto. apply MinMax; auto with zarith. apply FNoddSuc; auto. apply (MaxUniqueP b radix r); auto. Qed. Theorem To_OddSymmetricP : SymmetricP To_Odd. unfold SymmetricP; intros. elim H; intros H1 H2; case H2; intros H3; clear H2. split; auto with float. left; rewrite H3; unfold FtoRradix; rewrite Fopp_correct; auto with real zarith. elim H3; intros H4 H5; case H4; intros H6; clear H3 H4. split; auto with float. split; auto with float. Qed. End RndOdd. Section DblRndOddAux. Variables b be : Fbound. Variables p k : nat. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Hypotheses pGreaterThanOne : (lt (S O) p). Hypotheses kGreaterThanOne : (lt (S O) k). Hypotheses pGivesBound : (Zpos (vNum b)) = (Zpower_nat radix p). Hypotheses pkGivesBounde : (Zpos (vNum be)) = (Zpower_nat radix (plus p k)). Theorem ClosestStrictPred: forall (f:float) (z:R), (Fcanonic radix b f) -> (0 < f)%R -> (-Fulp b radix p (FNPred b radix p f) < 2%nat *(z - f) < Fulp b radix p f)%R -> Closest b radix z f /\ (forall q : float, Closest b radix z q -> FtoR radix q = FtoR radix f). intros f z0 H H'0 T; elim T; intros H1 H0; clear T. assert (H2:Fbounded b f);[apply FcanonicBound with radix ;auto|idtac]. case (Req_dec z0 f); intros H'. rewrite H'; split. unfold FtoRradix; apply (RoundedModeProjectorIdem b radix (Closest b radix));auto. apply ClosestRoundedModeP with p;auto with zarith. intros g H3; apply sym_eq. apply (RoundedProjector b radix (Closest b radix)); auto. apply ClosestRoundedModeP with p;auto with zarith. cut ((FNPred b radix p f) < z0)%R;[intros H3|idtac]. cut (z0 < (FNSucc b radix p f))%R;[intros H4|idtac]. cut (((Rabs (f - z0)) < (Rabs ((FNPred b radix p f) - z0)))%R /\ ((Rabs (f - z0)) < (Rabs ((FNSucc b radix p f) - z0)))%R);[intros (H5,H6)|idtac]. cut (Closest b radix z0 f);[intros H7|idtac]. split;auto. intros g H8. generalize ClosestMinOrMax; unfold MinOrMaxP; intros T. case (T b radix z0 f H7); case (T b radix z0 g H8); clear T; intros. apply (MinUniqueP b radix z0);auto. Contradict H6. apply Rle_not_lt. replace (FtoRradix (FNSucc b radix p f)) with (FtoRradix g). elim H8; intros; unfold FtoRradix;apply H11; auto. apply (MaxUniqueP b radix z0); auto. apply MinMax;auto with zarith. Contradict H5. apply Rle_not_lt. replace (FtoRradix (FNPred b radix p f)) with (FtoRradix g). elim H8; intros; unfold FtoRradix;apply H11; auto. apply (MinUniqueP b radix z0); auto. apply MaxMin;auto with zarith. apply (MaxUniqueP b radix z0); auto. unfold Closest; split; auto. intros g H7. case (Rle_or_lt g f); intros H8. case H8; clear H8; intros H8. assert (g <= (FNPred b radix p f))%R. unfold FtoRradix; apply FNPredProp; auto with zarith. fold FtoRradix;apply Rlt_le; apply Rlt_le_trans with (1:=H5). rewrite Rabs_left1; auto with real. rewrite Rabs_left1; auto with real. apply Rplus_le_reg_l with (-z0)%R. apply Rle_trans with (-(FNPred b radix p f))%R;[right;ring|idtac]. apply Rle_trans with (-g)%R;[auto with real|right;ring]. apply Rle_trans with ((FNPred b radix p f)-z0)%R; auto with real. unfold Rminus; auto with real. fold FtoRradix; rewrite H8; auto with real. assert ((FNSucc b radix p f) <= g)%R. unfold FtoRradix; apply FNSuccProp; auto with zarith. fold FtoRradix;apply Rlt_le; apply Rlt_le_trans with (1:=H6). rewrite Rabs_right; auto with real. rewrite Rabs_right; auto with real. unfold Rminus; auto with real. apply Rle_ge; auto with real. apply Rle_trans with ((FNSucc b radix p f)-z0)%R; auto with real. unfold Rminus; auto with real. apply Rle_ge; auto with real. rewrite (Rabs_left1 (FNPred b radix p f - z0)%R); auto with real. rewrite (Rabs_right (FNSucc b radix p f - z0)%R); auto with real. 2: apply Rle_ge; auto with real. rewrite Ropp_minus_distr. case (Rle_or_lt 0%R (f-z0)%R); intros H5. rewrite Rabs_right; auto with real. split. apply Rplus_lt_reg_r with (z0-2*f+(FNPred b radix p f))%R. ring_simplify. apply Rlt_le_trans with (S 1 * (z0 - f))%R;[idtac|right;simpl;ring]. apply Rle_lt_trans with (2:=H1). unfold FtoRradix; rewrite <- FpredUlpPos with b radix p f; auto with zarith. unfold FNPred;rewrite FcanonicFnormalizeEq; auto with zarith. right;ring. unfold Rminus;apply Rplus_lt_compat_r. unfold FtoRradix; apply FNSuccLt; auto with zarith. rewrite Rabs_left; auto with real. rewrite Ropp_minus_distr. split. unfold Rminus;apply Rplus_lt_compat_l; apply Ropp_lt_contravar. unfold FtoRradix; apply FNPredLt; auto with zarith. apply Rplus_lt_reg_r with (z0-f)%R. ring_simplify. apply Rle_lt_trans with (S 1 * (z0 - f))%R;[right;simpl;ring|idtac]. apply Rlt_le_trans with (1:=H0). unfold FtoRradix; rewrite <- FNSuccUlpPos with b radix p f; auto with zarith real. unfold FtoRradix; rewrite Fminus_correct; auto with zarith; right;ring. apply Rplus_lt_reg_r with (-f)%R. apply Rle_lt_trans with (z0-f)%R;[right;ring|idtac]. apply Rmult_lt_reg_l with (2%nat)%R; auto with real. apply Rlt_le_trans with (1:=H0). apply Rle_trans with (2%nat * (Fulp b radix p f))%R; auto with zarith real. simpl; unfold Fulp; auto with zarith real. unfold FtoRradix; rewrite <- FNSuccUlpPos with b radix p f; auto with zarith real. rewrite Fminus_correct; auto with zarith real; right;ring. apply Rplus_lt_reg_r with (-f)%R. apply Rlt_le_trans with (z0 - f)%R;[idtac|right;simpl;ring]. apply Rmult_lt_reg_l with (2%nat)%R; auto with real. apply Rle_lt_trans with (2:=H1). apply Rle_trans with (-(S 1 * (f - FNPred b radix p f)))%R;[right;ring|idtac]. apply Ropp_le_contravar. apply Rle_trans with (2%nat * (Fulp b radix p (FNPred b radix p f)))%R; auto with zarith real. simpl; unfold Fulp; auto with zarith real. unfold FtoRradix; rewrite <- FpredUlpPos with b radix p f; auto with zarith real. unfold FNPred;rewrite FcanonicFnormalizeEq; auto with zarith. right;ring. Qed. Theorem ClosestStrictPos: forall (f:float) (z:R), (Fcanonic radix b f) -> (0 < f)%R -> Fnum f <> nNormMin radix p -> (2%nat * Rabs (z - f) < Fulp b radix p f)%R -> Closest b radix z f /\ (forall q : float, Closest b radix z q -> FtoR radix q = FtoR radix f). intros f z0 H H'0 H0 H1. apply ClosestStrictPred; auto. replace (Fulp b radix p (FNPred b radix p f)) with (Fulp b radix p f). generalize (Rabs_def2 (S 1 * (z0 - f))%R (Fulp b radix p f)). replace (Rabs (S 1 * (z0 - f)))%R with (S 1 * Rabs (z0 - f))%R. intuition. rewrite Rabs_mult; rewrite (Rabs_right 2%nat);auto with real. repeat rewrite CanonicFulp; try apply FNPredCanonic; auto with zarith. 2: apply FcanonicBound with radix; auto. replace (Fexp (FNPred b radix p f)) with (Fexp f); auto with real. unfold FNPred; rewrite FcanonicFnormalizeEq; auto with zarith. rewrite FPredSimpl4; auto. cut (- pPred (vNum b) < Fnum f)%Z; auto with zarith. apply Zlt_trans with (-0)%Z. cut (0 < pPred (vNum b))%Z; auto with zarith. apply pPredMoreThanOne with radix p; auto with zarith. apply LtR0Fnum with radix; auto with zarith. Qed. Theorem ClosestStrict: forall (f:float) (z0:R), (Fcanonic radix b f) -> Zabs (Fnum f) <> nNormMin radix p -> (2%nat * Rabs (z0 - f) < Fulp b radix p f)%R -> Closest b radix z0 f /\ (forall q : float, Closest b radix z0 q -> FtoR radix q = FtoR radix f). intros. assert (H':(Fbounded b f));[apply FcanonicBound with radix;auto|idtac]. case (Rle_or_lt 0%R f); intros. case H2; clear H2; intros H2. apply ClosestStrictPos;auto. rewrite <- (Zabs_eq (Fnum f)); auto. apply LeR0Fnum with radix; auto with zarith real. cut (forall (g:float), (Fbounded b g) -> (FtoRradix g)<>(FtoRradix f) -> (Rabs (f - z0) < Rabs (g - z0))%R). intros T. split; [unfold Closest|idtac]. split; [apply FcanonicBound with radix; auto|idtac]. intros; case (Req_dec f f0); intros. fold FtoRradix; rewrite H4; auto with real. apply Rlt_le; apply T;auto. intros q H3. case (Req_dec q f); intros H4; auto with real. absurd (Rabs (f - z0) < Rabs (q - z0))%R. apply Rle_not_lt;unfold Closest in H3. elim H3; intros H5 H6;unfold FtoRradix; apply H6; auto. apply T; auto. elim H3; auto. intros g H3 H4. assert (f=(Float 0%Z (-(dExp b))%Z)). apply FcanonicUnique with radix b p; auto with zarith. right; split; auto with zarith. split; auto with zarith. fold FtoRradix; rewrite <- H2; unfold FtoRradix, FtoR; simpl; ring. apply Rmult_lt_reg_l with (2%nat)%R; auto with real. rewrite <- Rabs_Ropp. replace (- (f - z0))%R with (z0-f)%R;[idtac|ring]. apply Rlt_le_trans with (1:=H1). cut (2%nat * (Rabs z0) < (powerRZ radix (- (dExp b))%Z))%R;[intros H6|idtac]. rewrite CanonicFulp; auto with zarith. rewrite H5; unfold FtoR; simpl. apply Rle_trans with (2%nat * (powerRZ 2 (- dExp b)) - (powerRZ 2 (- dExp b)))%R;[right;simpl;ring|idtac]. apply Rle_trans with (2%nat * (Rabs g) - 2%nat * (Rabs z0))%R. unfold Rminus;apply Rplus_le_compat. apply Rmult_le_compat_l; auto with real. case (Rdichotomy f g); auto with real; rewrite <- H2; intros H7. apply Rle_trans with (FSucc b radix p f). rewrite H5; rewrite FSuccSimpl4; simpl; auto with zarith. unfold FtoRradix, FtoR; simpl; right; ring. cut (0 < pPred (vNum b))%Z; auto with zarith. apply pPredMoreThanOne with radix p; auto with zarith. cut (0 < nNormMin radix p)%Z; auto with zarith. apply nNormPos; auto with zarith. rewrite Rabs_right. unfold FtoRradix;rewrite <- FnormalizeCorrect with radix b p g; auto with zarith. unfold FtoRradix; apply FSuccProp; auto with zarith. apply FnormalizeCanonic; auto with zarith. rewrite FnormalizeCorrect; auto with zarith real. fold FtoRradix; rewrite <- H2; auto with real. apply Rle_ge; auto with real. assert (g < 0)%R; auto with real. rewrite Rabs_left; auto with real. rewrite <-(Ropp_involutive (powerRZ 2 (- dExp b))%R). apply Ropp_le_contravar. apply Rle_trans with (FPred b radix p f). unfold FtoRradix;rewrite <- FnormalizeCorrect with radix b p g; auto with zarith. apply FPredProp; auto with zarith. apply FnormalizeCanonic; auto with zarith. rewrite FnormalizeCorrect; auto with zarith real. fold FtoRradix; rewrite <- H2; auto with real. rewrite H5; rewrite FPredSimpl4; simpl; auto with zarith. unfold FtoRradix, FtoR; simpl; right; ring. cut (0 < pPred (vNum b))%Z; auto with zarith. apply pPredMoreThanOne with radix p; auto with zarith. cut (0 < nNormMin radix p)%Z; auto with zarith. apply nNormPos; auto with zarith. apply Ropp_le_contravar; auto with real. apply Rle_trans with (2*((Rabs g)-(Rabs z0)))%R;[right;simpl;ring|idtac]. apply Rmult_le_compat_l; auto with real. apply Rabs_triang_inv. replace z0 with (z0-f)%R;[apply Rlt_le_trans with (1:=H1)|rewrite <- H2;ring]. rewrite CanonicFulp; auto with zarith;rewrite H5; unfold FtoRradix, FtoR; simpl; right;ring. assert (Closest b radix (- z0) (Fopp f) /\ (forall q : float, Closest b radix (- z0) q -> FtoR radix q = FtoR radix (Fopp f))). apply ClosestStrictPos; auto with float zarith. unfold FtoRradix; rewrite Fopp_correct; fold FtoRradix; auto with real. unfold Fopp; simpl;rewrite <- (Zabs_eq (-(Fnum f))%Z). rewrite Zabs_Zopp; auto. cut (Fnum f <= 0)%Z;[idtac|apply R0LeFnum with radix]; auto with real zarith. unfold FtoRradix; rewrite Fopp_correct; fold FtoRradix. replace (- z0 - - f)%R with (-(z0 - f))%R;[rewrite Rabs_Ropp|ring]. apply Rlt_le_trans with (1:=H1);right. unfold Fulp; rewrite Fnormalize_Fopp; auto with real arith. elim H3; intros H4 H5; clear H3. split. replace z0 with (-(-z0))%R;[idtac|ring]. rewrite <- (Fopp_Fopp f). apply ClosestOpp; auto. intros;rewrite <- (Ropp_involutive (FtoR radix q)). rewrite <- (Ropp_involutive (FtoR radix f)). apply Ropp_eq_compat. rewrite <- Fopp_correct;rewrite <- Fopp_correct. apply H5. apply ClosestOpp; auto. Qed. Theorem EvenNormalize:forall (f:float), (Fbounded be f) -> (Even (Fnum f)) -> (FNeven be radix (p+k) f). intros f H1 H2; unfold FNeven, Fnormalize. case (Z_zerop (Fnum f)); intros H3. unfold Feven; simpl; apply EvenO. unfold Fshift, Feven; simpl. apply EvenMult1; auto. Qed. Variables y z v: float. Variables x : R. Hypotheses By : (Fbounded be y). Hypotheses Bz : (Fbounded b z). Hypotheses Bv : (Fbounded b v). Hypotheses Cv : (Fcanonic radix b v). Hypotheses ydef : (To_Odd be radix (plus p k) x y). Hypotheses zdef : (EvenClosest b radix p y z). Hypotheses vdef : (EvenClosest b radix p x v). Hypotheses rangeext: (-(dExp be) <= (Zpred (Zpred (-(dExp b)))))%Z. Hypotheses H:(Fnum v=(nNormMin radix p))%Z. Hypotheses H':(x<>y)%R. Hypotheses H1: (0 <= v)%R. Theorem To_Odd_Even_is_Even_nNormMin: EvenClosest b radix p y v. case H1; clear H1; intros H1. elim (ClosestStrictPred v y); auto with zarith. intros H2 H3; unfold EvenClosest. split; auto. split. rewrite CanonicFulp; auto with zarith. 2: apply FNPredCanonic; auto with zarith. unfold FNPred; rewrite FcanonicFnormalizeEq; auto with zarith. generalize (Zle_lt_or_eq ((-(dExp b)))%Z (Fexp v)); intros H2. case H2; auto with zarith float; clear H2; intros H2. rewrite FPredSimpl2; auto with zarith;simpl. apply Rle_lt_trans with (2*-(powerRZ radix (Zpred (Zpred (Fexp v)))))%R. unfold FtoRradix, FtoR; simpl; unfold Zpred; repeat rewrite powerRZ_add; auto with zarith real. simpl; right;field. apply Rmult_lt_compat_l; auto with real. apply Rplus_lt_reg_r with v. ring_simplify (v+(y-v))%R. assert ((v + - powerRZ radix (Zpred (Zpred (Fexp v))))= (Float ((Zpower_nat radix (p+2))-2)%Z (Zpred (Zpred (Zpred (Fexp v))))))%R. unfold FtoRradix, FtoR; simpl. unfold Zminus; rewrite plus_IZR. rewrite Zpower_nat_Z_powerRZ; rewrite H. unfold nNormMin; simpl. rewrite Zpower_nat_Z_powerRZ; rewrite inj_pred; auto with zarith. rewrite inj_plus. unfold Zpred; repeat rewrite powerRZ_add; auto with zarith real. simpl; field. assert (H'1:(Fbounded be (Float (Zpower_nat radix (p + 2) - 2) (Zpred (Zpred (Zpred (Fexp v))))))). split; simpl. rewrite Zabs_eq; auto with zarith. rewrite pkGivesBounde. apply Zlt_le_trans with (Zpower_nat radix (p + 2)); auto with zarith. apply Zle_trans with (Zpower_nat radix (0 + 2) - 2)%Z; auto with zarith. unfold Zminus; apply Zplus_le_compat_r; auto with zarith. apply Zle_trans with (1:=rangeext); auto with zarith. assert (v + - powerRZ radix (Zpred (Zpred (Fexp v))) <= y)%R. case (Req_dec (v + - powerRZ radix (Zpred (Zpred (Fexp v))))%R x); intros H'2. Contradict H'. rewrite <- H'2; rewrite H0. generalize (To_OddUniqueP be radix (p+k)); unfold UniqueP. intros T; unfold FtoRradix; apply T with x; auto with zarith; clear T. rewrite <- H'2; rewrite H0; unfold FtoRradix;apply RoundedModeProjectorIdem with (P:=(To_Odd be radix (p+k))) (b:=be). apply To_OddRoundedModeP; auto with zarith. exact H'1. rewrite H0. generalize (To_OddMonotone be radix (p+k));unfold MonotoneP; intros T. unfold FtoRradix; apply T with (v +- powerRZ radix (Zpred (Zpred (Fexp v))))%R x; auto with zarith; clear T. cut (v + - powerRZ radix (Zpred (Zpred (Fexp v))) <= x)%R. intros T; case T; auto with real. intros T'; Contradict T'; auto with real. apply Rmult_le_reg_l with 2%nat; auto with real. apply Rle_trans with (S 1 * v - powerRZ radix (Fexp v - 1))%R. right; unfold Zpred, Zminus; repeat rewrite powerRZ_add; auto with zarith real; simpl. field. unfold FtoRradix;apply ClosestInfPredExp with b p; auto with zarith. elim vdef; auto. rewrite H0. unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(To_Odd be radix (p+k))) (b:=be);auto. apply To_OddRoundedModeP; auto with zarith. case H3; auto with real; clear H3; intros H3. elim ydef; intros H4 H5. case H5; intros H6. fold FtoRradix in H6; Contradict H6; auto with real. clear H5; elim H6; intros H7 H8; clear H6 H7. absurd (FNeven be radix (p + k) y). apply FnOddNEven; auto. apply FNevenEq with (Float (Zpower_nat radix (p + 2) - 2)%Z (Zpred (Zpred (Zpred (Fexp v))))); auto with zarith. fold FtoRradix; rewrite <- H3; auto with real. apply EvenNormalize; auto. simpl;unfold Zminus; apply EvenPlus1. replace (p+2) with (S (S p)); [idtac|ring]. apply EvenExp; unfold Even. exists 1%Z; auto with zarith. unfold Even; exists (-1)%Z; auto with zarith. replace (FPred b radix p v) with (FPred b radix p (Float (nNormMin radix p) (- dExp b)%Z)). 2: unfold FPred; rewrite H; rewrite <- H2; auto with zarith. rewrite FPredSimpl3; auto with zarith;simpl. apply Rle_lt_trans with (2*-(powerRZ radix (Zpred (Fexp v))))%R. unfold FtoRradix, FtoR; simpl; unfold Zpred; repeat rewrite powerRZ_add; auto with zarith real. rewrite H2; simpl; right;field. apply Rmult_lt_compat_l; auto with real. apply Rplus_lt_reg_r with v. ring_simplify (v+(y-v))%R. assert ((v + - powerRZ radix (Zpred (Fexp v)))= (Float ((Zpower_nat radix (p+1))-2)%Z (Zpred (Zpred (Fexp v)))))%R. unfold FtoRradix, FtoR; simpl. unfold Zminus; rewrite plus_IZR. rewrite Zpower_nat_Z_powerRZ; rewrite H. unfold nNormMin; simpl. rewrite Zpower_nat_Z_powerRZ; rewrite inj_pred; auto with zarith. rewrite inj_plus. unfold Zpred; repeat rewrite powerRZ_add; auto with zarith real. simpl; field. assert (H'1:(Fbounded be (Float (Zpower_nat radix (p + 1) - 2) (Zpred (Zpred (Fexp v)))))). split; simpl. rewrite Zabs_eq; auto with zarith. rewrite pkGivesBounde. apply Zlt_le_trans with (Zpower_nat radix (p + 1)); auto with zarith. apply Zle_trans with (Zpower_nat radix (0 + 1) - 2)%Z; auto with zarith. unfold Zminus; apply Zplus_le_compat_r; auto with zarith. apply Zle_trans with (1:=rangeext); auto with zarith. assert (v + - powerRZ radix (Zpred (Fexp v)) <= y)%R. rewrite H0. case (Req_dec (v + - powerRZ radix (Zpred (Fexp v)))%R x); intros H'2. Contradict H'. rewrite <- H'2; rewrite H0. generalize (To_OddUniqueP be radix (p+k)); unfold UniqueP. intros T; unfold FtoRradix; apply T with x; auto with zarith; clear T. rewrite <- H'2; rewrite H0; unfold FtoRradix;apply RoundedModeProjectorIdem with (P:=(To_Odd be radix (p+k))) (b:=be). apply To_OddRoundedModeP; auto with zarith. exact H'1. generalize (To_OddMonotone be radix (p+k));unfold MonotoneP; intros T. unfold FtoRradix; apply T with (v +- powerRZ radix (Zpred (Fexp v)))%R x; auto with zarith; clear T. cut (v + - powerRZ radix (Zpred (Fexp v)) <= x)%R; auto with real. intros T; case T; auto with real. intros T'; Contradict T; auto with real. apply Rplus_le_reg_l with (-x+(powerRZ radix (Zpred (Fexp v))))%R. ring_simplify. apply Rle_trans with (Rabs (-x +v))%R;[apply RRle_abs|idtac]. rewrite <- Rabs_Ropp. replace (-(-x+v))%R with (x-v)%R;[idtac|ring]. apply Rmult_le_reg_l with (2%nat)%R; auto with real. apply Rle_trans with (Fulp b radix p v). unfold FtoRradix; apply ClosestUlp; auto with zarith. elim vdef; auto. rewrite CanonicFulp; auto with zarith. right; unfold Zpred, FtoR; simpl; rewrite powerRZ_add; auto with zarith real. simpl; field; auto with real. rewrite H0;unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(To_Odd be radix (p+k))) (b:=be);auto. apply To_OddRoundedModeP; auto with zarith. case H3; auto with real; clear H3; intros H3. elim ydef; intros H4 H5. case H5; intros H6. fold FtoRradix in H6; Contradict H6; auto with real. clear H5; elim H6; intros H7 H8; clear H6 H7. absurd (FNeven be radix (p + k) y). apply FnOddNEven; auto. apply FNevenEq with (Float (Zpower_nat radix (p + 1) - 2)%Z (Zpred (Zpred (Fexp v)))); auto with zarith. fold FtoRradix; rewrite <- H0; auto with real. apply EvenNormalize; auto. simpl;unfold Zminus; apply EvenPlus1. replace (p+1) with (S p); [idtac|ring]. apply EvenExp; unfold Even. exists 1%Z; auto with zarith. unfold Even; exists (-1)%Z; auto with zarith. rewrite CanonicFulp; auto with zarith. apply Rlt_le_trans with (2*(powerRZ radix (Zpred (Fexp v))))%R. 2:unfold FtoRradix, FtoR; simpl; unfold Zpred; repeat rewrite powerRZ_add; auto with zarith real. 2:simpl; right;field. apply Rmult_lt_compat_l; auto with real. apply Rplus_lt_reg_r with v. ring_simplify (v+(y-v))%R. assert ((v + powerRZ radix (Zpred (Fexp v)))= (Float ((Zpower_nat radix (p+1))+2)%Z (Zpred (Zpred (Fexp v)))))%R. unfold FtoRradix, FtoR; simpl. unfold Zminus; rewrite plus_IZR. rewrite Zpower_nat_Z_powerRZ; rewrite H. unfold nNormMin; simpl. rewrite Zpower_nat_Z_powerRZ; rewrite inj_pred; auto with zarith. rewrite inj_plus. unfold Zpred; repeat rewrite powerRZ_add; auto with zarith real. simpl; field. assert (H'1:(Fbounded be (Float (Zpower_nat radix (p + 1) + 2) (Zpred (Zpred (Fexp v)))))). split; simpl. rewrite Zabs_eq; auto with zarith. rewrite pkGivesBounde. apply Zlt_le_trans with (Zpower_nat radix (p + 2)); auto with zarith. apply Zlt_le_trans with (Zpower_nat radix (p + 1) + (Zpower_nat radix (p + 1)))%Z; auto with zarith. apply Zplus_lt_compat_l; replace 2%Z with (Zpower_nat radix (0 + 1))%Z; auto with zarith. repeat rewrite Zpower_nat_is_exp; simpl; apply Zeq_le; ring_simplify. replace (Zpower_nat radix 1) with 2%Z. replace (Zpower_nat radix 2) with 4%Z;[ring|idtac]. unfold Zpower_nat; simpl; ring. unfold Zpower_nat; simpl; ring. apply Zle_trans with (1:=rangeext); auto with zarith. elim Bv; auto with zarith. assert (y <= v + powerRZ radix (Zpred (Fexp v)))%R. rewrite H0. case (Req_dec (v + powerRZ radix (Zpred (Fexp v)))%R x); intros H'2. Contradict H'. rewrite <- H'2; rewrite H0. generalize (To_OddUniqueP be radix (p+k)); unfold UniqueP. intros T; unfold FtoRradix; apply T with x; auto with zarith; clear T. rewrite <- H'2; rewrite H0; unfold FtoRradix;apply RoundedModeProjectorIdem with (P:=(To_Odd be radix (p+k))) (b:=be). apply To_OddRoundedModeP; auto with zarith. exact H'1. generalize (To_OddMonotone be radix (p+k));unfold MonotoneP; intros T. unfold FtoRradix; apply T with x (v + powerRZ radix (Zpred (Fexp v)))%R; auto with zarith; clear T. cut (x <= v + powerRZ radix (Zpred (Fexp v)))%R; auto with real. intros T; case T; auto with real. intros T'; Contradict T; auto with real. apply Rplus_le_reg_l with (-v)%R. ring_simplify (- v + (v + powerRZ radix (Zpred (Fexp v))))%R. apply Rle_trans with (Rabs (-v + x))%R;[apply RRle_abs|idtac]. replace (- v + x)%R with (x-v)%R;[idtac|ring]. apply Rmult_le_reg_l with (2%nat)%R; auto with real. apply Rle_trans with (Fulp b radix p v). unfold FtoRradix; apply ClosestUlp; auto with zarith. elim vdef; auto. rewrite CanonicFulp; auto with zarith. right; unfold Zpred, FtoR; simpl; rewrite powerRZ_add; auto with zarith. simpl; field; auto with real. auto with real. rewrite H0;unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(To_Odd be radix (p+k))) (b:=be);auto. apply To_OddRoundedModeP; auto with zarith. case H2; auto with real; clear H2; intros H3. elim ydef; intros H4 H5. case H5; intros H6. fold FtoRradix in H6; Contradict H6; auto with real. clear H5; elim H6; intros H7 H8; clear H6 H7. absurd (FNeven be radix (p + k) y). apply FnOddNEven; auto. apply FNevenEq with (Float (Zpower_nat radix (p + 1) + 2)%Z (Zpred (Zpred (Fexp v)))); auto with zarith. fold FtoRradix; rewrite <- H0; auto with real. apply EvenNormalize; auto. simpl;unfold Zminus; apply EvenPlus1. replace (p+1) with (S p); [idtac|ring]. apply EvenExp; unfold Even. exists 1%Z; auto with zarith. unfold Even; exists 1%Z; auto with zarith. Contradict H1; unfold FtoRradix, FtoR; rewrite H. apply sym_not_eq;apply Rmult_integral_contrapositive; split; auto with real zarith. unfold nNormMin; auto with zarith real. Qed. End DblRndOddAux. Section DblRndOdd. Variables b be : Fbound. Variables p k : nat. Variables y z v: float. Variables x : R. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Hypotheses pGreaterThanOne : (lt (S O) p). Hypotheses kGreaterThanOne : (lt (S O) k). Hypotheses pGivesBound : (Zpos (vNum b)) = (Zpower_nat radix p). Hypotheses pkGivesBounde : (Zpos (vNum be)) = (Zpower_nat radix (plus p k)). Hypotheses By : (Fbounded be y). Hypotheses Bz : (Fbounded b z). Hypotheses Bv : (Fbounded b v). Hypotheses Cv : (Fcanonic radix b v). Hypotheses ydef : (To_Odd be radix (plus p k) x y). Hypotheses zdef : (EvenClosest b radix p y z). Hypotheses vdef : (EvenClosest b radix p x v). Hypotheses rangeext: (-(dExp be) <= (Zpred (Zpred (-(dExp b)))))%Z. Theorem To_Odd_Even_is_Even: ((FtoRradix v)=(FtoRradix z))%R. case (Z_eq_dec (Zabs (Fnum v)) (nNormMin radix p)); intros H. generalize EvenClosestUniqueP; unfold UniqueP; intros T. unfold FtoRradix; apply T with b p y; auto with zarith; clear T. case (Req_dec x y); intros H'. rewrite <- H'; auto. case (Rle_or_lt 0%R v); intros H1. rewrite Zabs_eq in H. 2: apply LeR0Fnum with radix; auto with real zarith. apply To_Odd_Even_is_Even_nNormMin with be k x; auto. rewrite <- (Ropp_involutive y%R). rewrite <- (Fopp_Fopp v). generalize (EvenClosestSymmetric b radix); unfold SymmetricP. intros T; apply T; clear T; try trivial. unfold FtoRradix;rewrite <- Fopp_correct. apply To_Odd_Even_is_Even_nNormMin with be k (-x)%R; auto with float. generalize To_OddSymmetricP; unfold SymmetricP; intros T;apply T; auto with arith. generalize EvenClosestSymmetric; unfold SymmetricP; intros T;apply T; auto. simpl; rewrite <- (Zabs_eq (-(Fnum v))%Z); auto with zarith. rewrite Zabs_Zopp; auto with zarith. cut (Fnum v <= 0)%Z; auto with zarith. apply R0LeFnum with radix; auto with real zarith. rewrite Fopp_correct; auto with real zarith;fold radix FtoRradix. Contradict H'. rewrite <- Ropp_involutive; rewrite <- H'; auto with real. rewrite Fopp_correct; auto with real zarith. assert (2%nat * Rabs (x - v) <= Fulp b radix p v)%R. unfold FtoRradix; apply ClosestUlp; auto with zarith. elim vdef; auto. case H0; clear H0; intros H1. generalize EvenClosestUniqueP; unfold UniqueP; intros T. unfold FtoRradix; apply T with b p y; auto with zarith; clear T. case (Req_dec x y); intros H'. rewrite <- H'; auto. elim ClosestStrict with (b:=b) (p:=p) (f:=v) (z0:=y) (k:=k); auto. intros H2 H3. unfold EvenClosest. split; auto. assert (Rabs (x - v) < (powerRZ radix (Zpred (Fexp v))))%R. apply Rmult_lt_reg_l with 2%nat; auto with real. apply Rlt_le_trans with (1:=H1);right; unfold Fulp. rewrite FcanonicFnormalizeEq; auto with zarith;simpl. unfold Zpred; rewrite powerRZ_add; auto with zarith real. simpl; field; auto with real. unfold Fulp; rewrite FcanonicFnormalizeEq; auto with zarith. apply Rlt_le_trans with (2%nat * powerRZ radix (Zpred (Fexp v)))%R. apply Rmult_lt_compat_l; auto with real. 2: unfold Zpred; rewrite powerRZ_add; auto with zarith real. 2: right; simpl; field; auto with real. assert (Rabs (y - v) <= powerRZ radix (Zpred (Fexp v)))%R. case (Rle_or_lt x v); intros H2. rewrite Rabs_left1;apply Rplus_le_reg_l with (-v)%R;ring_simplify (- v + - (y - v))%R. apply Rle_trans with (- (v - powerRZ radix (Zpred (Fexp v))))%R;[idtac|right;ring]. apply Ropp_le_contravar. assert ((v - powerRZ radix (Zpred (Fexp v)))=(Float (2*(Zpred (2*(Fnum v))))%Z (Zpred (Zpred (Fexp v)))))%R. apply trans_eq with (2*2*(Fnum v)*(powerRZ radix (Zpred (Zpred (Fexp v))))- 2*powerRZ radix (Zpred(Zpred (Fexp v))))%R. unfold FtoRradix, FtoR; simpl; ring_simplify. unfold Zpred; repeat rewrite powerRZ_add; auto with zarith real; simpl; field; auto with real. unfold FtoRradix, FtoR. apply trans_eq with ((2*(Zpred(2* Fnum v)))%Z *powerRZ radix (Zpred (Zpred (Fexp v))))%R;[idtac|simpl;auto with real]. unfold Zpred;rewrite mult_IZR;rewrite plus_IZR;rewrite mult_IZR;simpl; ring. rewrite H3. generalize (To_OddMonotone be radix (p+k));unfold MonotoneP; intros T. apply T with (v - powerRZ radix (Zpred (Fexp v)))%R x; auto with zarith. apply Rplus_lt_reg_r with (-x+powerRZ radix (Zpred (Fexp v)))%R. ring_simplify. apply Rle_lt_trans with (-(x-v))%R;[right;ring|idtac]. apply Rle_lt_trans with (Rabs (-(x-v)))%R;[apply RRle_abs|rewrite Rabs_Ropp];auto. rewrite H3. unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(To_Odd be radix (p+k))) (b:=be). apply To_OddRoundedModeP; auto with zarith. clear T;split. cut ((Zabs (2 * Zpred (2 * Fnum v))) < Zpos (vNum be))%Z; auto with zarith. rewrite pkGivesBounde;rewrite Zabs_Zmult;rewrite Zabs_eq; auto with zarith; unfold Zpred. apply Zle_lt_trans with (2 * (Zabs (2 * Fnum v) + (Zabs (-1))))%Z; auto with zarith. rewrite Zabs_Zmult;rewrite Zabs_eq; auto with zarith. replace (Zabs (-1))%Z with 1%Z; auto with zarith. apply Zle_lt_trans with (2 * (2 * (Zpred (Zpower_nat radix p)) + 1))%Z. cut (Zabs (Fnum v) <= (Zpred (Zpower_nat radix p)))%Z; auto with zarith float. elim Bv; rewrite pGivesBound; auto with zarith. unfold Zpred;ring_simplify. apply Zlt_le_trans with (4 * Zpower_nat radix p)%Z; auto with zarith. apply Zle_trans with (Zpower_nat radix (p+2))%Z; auto with zarith. rewrite Zpower_nat_is_exp;simpl (Zpower_nat 2); auto with zarith. simpl;apply Zle_trans with (Zpred (Zpred (- dExp b)))%Z; auto with zarith float. apply Rplus_le_reg_l with (v+v)%R. ring_simplify. case H2; intros H3. generalize (To_OddMonotone be radix (p+k));unfold MonotoneP; intros T. apply T with x (v)%R; auto with zarith. unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(To_Odd be radix (p+k))) (b:=be). apply To_OddRoundedModeP; auto with zarith. clear T;split. apply Zlt_le_trans with (Zpos (vNum b))%Z; auto with zarith float. rewrite pkGivesBounde; rewrite pGivesBound; auto with zarith. apply Zle_trans with (- dExp b)%Z; auto with zarith float. right; generalize (To_OddUniqueP be radix (p+k)); unfold UniqueP. intros T; unfold FtoRradix; apply T with x; auto with zarith. rewrite H3; unfold FtoRradix;apply RoundedModeProjectorIdem with (P:=(To_Odd be radix (p+k))) (b:=be). apply To_OddRoundedModeP; auto with zarith. clear T;split. apply Zlt_le_trans with (Zpos (vNum b))%Z; auto with zarith float. rewrite pkGivesBounde; rewrite pGivesBound; auto with zarith. apply Zle_trans with (- dExp b)%Z; auto with zarith float. rewrite Rabs_right;[apply Rplus_le_reg_l with (v)%R;ring_simplify ( v + (y - v))%R|idtac]. assert ((v + powerRZ radix (Zpred (Fexp v)))=(Float (2*(Zsucc (2*(Fnum v))))%Z (Zpred (Zpred (Fexp v)))))%R. apply trans_eq with (2*2*(Fnum v)*(powerRZ radix (Zpred (Zpred (Fexp v))))+ 2*powerRZ radix (Zpred(Zpred (Fexp v))))%R. unfold FtoRradix, FtoR; simpl; ring_simplify. unfold Zpred; repeat rewrite powerRZ_add; auto with zarith real; simpl; field; auto with real. unfold FtoRradix, FtoR. apply trans_eq with ((2*(Zsucc(2* Fnum v)))%Z *powerRZ radix (Zpred (Zpred (Fexp v))))%R;[idtac|simpl;auto with real]. unfold Zsucc;rewrite mult_IZR;rewrite plus_IZR;rewrite mult_IZR;simpl; ring. rewrite H3. generalize (To_OddMonotone be radix (p+k));unfold MonotoneP; intros T. apply T with x (v + powerRZ radix (Zpred (Fexp v)))%R; auto with zarith. apply Rplus_lt_reg_r with (-v)%R. ring_simplify (- v + (v + powerRZ radix (Zpred (Fexp v))))%R. apply Rle_lt_trans with ((x-v))%R;[right;ring|idtac]. apply Rle_lt_trans with (Rabs ((x-v)))%R;[apply RRle_abs|idtac];auto. rewrite H3. unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(To_Odd be radix (p+k))) (b:=be). apply To_OddRoundedModeP; auto with zarith. clear T;split. cut ((Zabs (2 * Zsucc (2 * Fnum v))) < Zpos (vNum be))%Z; auto with zarith. rewrite pkGivesBounde;rewrite Zabs_Zmult;rewrite Zabs_eq; auto with zarith; unfold Zsucc. apply Zle_lt_trans with (2 * (Zabs (2 * Fnum v) + (Zabs (1))))%Z; auto with zarith. rewrite Zabs_Zmult;rewrite Zabs_eq; auto with zarith. replace (Zabs (1))%Z with 1%Z; auto with zarith. apply Zle_lt_trans with (2 * (2 * (Zpred (Zpower_nat radix p)) + 1))%Z. cut (Zabs (Fnum v) <= (Zpred (Zpower_nat radix p)))%Z; auto with zarith float. elim Bv; rewrite pGivesBound; auto with zarith. unfold Zpred;ring_simplify (2 * (2 * (Zpower_nat radix p + -1) + 1))%Z. apply Zlt_le_trans with (4 * Zpower_nat radix p)%Z; auto with zarith. apply Zle_trans with (Zpower_nat radix (p+2))%Z; auto with zarith. rewrite Zpower_nat_is_exp;simpl (Zpower_nat 2); auto with zarith. simpl;apply Zle_trans with (Zpred (Zpred (- dExp b)))%Z; auto with zarith float. apply Rle_ge;apply Rplus_le_reg_l with (v)%R. ring_simplify. generalize (To_OddMonotone be radix (p+k));unfold MonotoneP; intros T. apply T with (v)%R x; auto with zarith. unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(To_Odd be radix (p+k))) (b:=be). apply To_OddRoundedModeP; auto with zarith. clear T;split. apply Zlt_le_trans with (Zpos (vNum b))%Z; auto with zarith float. rewrite pkGivesBounde; rewrite pGivesBound; auto with zarith. apply Zle_trans with (- dExp b)%Z; auto with zarith float. case H2; auto with real. clear H2; intros H2. Contradict H'. elim ydef; intros T1 T2;case T2; auto with real. clear T1 T2; intros T1; elim T1; intros T2 T3. absurd (FNeven be radix (p + k) y). apply FnOddNEven; auto. case (Rle_or_lt (y-v)%R 0%R); intros H3. apply FNevenEq with (Float (2*(Zpred (2*(Fnum v))))%Z (Zpred (Zpred (Fexp v)))); auto with zarith. split. cut ((Zabs (2 * Zpred (2 * Fnum v))) < Zpos (vNum be))%Z; auto with zarith. rewrite pkGivesBounde;rewrite Zabs_Zmult;rewrite Zabs_eq; auto with zarith; unfold Zpred. apply Zle_lt_trans with (2 * (Zabs (2 * Fnum v) + (Zabs (-1))))%Z; auto with zarith. rewrite Zabs_Zmult;rewrite Zabs_eq; auto with zarith. replace (Zabs (-1))%Z with 1%Z; auto with zarith. apply Zle_lt_trans with (2 * (2 * (Zpred (Zpower_nat radix p)) + 1))%Z. cut (Zabs (Fnum v) <= (Zpred (Zpower_nat radix p)))%Z; auto with zarith float. elim Bv; rewrite pGivesBound; auto with zarith. unfold Zpred;ring_simplify (2 * (2 * (Zpower_nat radix p + -1) + 1))%Z. apply Zlt_le_trans with (4 * Zpower_nat radix p)%Z; auto with zarith. apply Zle_trans with (Zpower_nat radix (p+2))%Z; auto with zarith. rewrite Zpower_nat_is_exp;simpl (Zpower_nat 2); auto with zarith. simpl;apply Zle_trans with (Zpred (Zpred (- dExp b)))%Z; auto with zarith float. fold FtoRradix; apply Rplus_eq_reg_l with (-v)%R. apply trans_eq with (-(-(y-v)))%R;[idtac|ring]. rewrite <- (Rabs_left1 (y-v)%R); auto with real. rewrite H2. pattern (FtoRradix v) at 1 in |-*; replace (FtoRradix v) with ((2*2*(Fnum v)*(powerRZ radix (Zpred (Zpred (Fexp v))))))%R. apply trans_eq with (- (4 * Fnum v * powerRZ radix (Zpred (Zpred (Fexp v)))) + ((2 * Zpred (2 * Fnum v)))%Z * (powerRZ radix (Zpred (Zpred (Fexp v)))))%R. unfold FtoRradix, FtoR; simpl; ring. unfold Zpred;rewrite mult_IZR;rewrite plus_IZR;rewrite mult_IZR;simpl; ring_simplify. repeat rewrite powerRZ_add; auto with zarith real; simpl; field; auto with real. unfold Zpred, FtoRradix, FtoR; repeat rewrite powerRZ_add; auto with zarith real; simpl; field; auto with real. apply EvenNormalize. split. cut ((Zabs (2 * Zpred (2 * Fnum v))) < Zpos (vNum be))%Z; auto with zarith. rewrite pkGivesBounde;rewrite Zabs_Zmult;rewrite Zabs_eq; auto with zarith; unfold Zpred. apply Zle_lt_trans with (2 * (Zabs (2 * Fnum v) + (Zabs (-1))))%Z; auto with zarith. rewrite Zabs_Zmult;rewrite Zabs_eq; auto with zarith. replace (Zabs (-1))%Z with 1%Z; auto with zarith. apply Zle_lt_trans with (2 * (2 * (Zpred (Zpower_nat radix p)) + 1))%Z. cut (Zabs (Fnum v) <= (Zpred (Zpower_nat radix p)))%Z; auto with zarith float. elim Bv; rewrite pGivesBound; auto with zarith. unfold Zpred;ring_simplify (2 * (2 * (Zpower_nat radix p + -1) + 1))%Z. apply Zlt_le_trans with (4 * Zpower_nat radix p)%Z; auto with zarith. apply Zle_trans with (Zpower_nat radix (p+2))%Z; auto with zarith. rewrite Zpower_nat_is_exp;simpl (Zpower_nat 2); auto with zarith. simpl;apply Zle_trans with (Zpred (Zpred (- dExp b)))%Z; auto with zarith float. replace (Fnum (Float (2 * Zpred (2 * Fnum v)) (Zpred (Zpred (Fexp v)))))%Z with (2 * Zpred (2 * Fnum v))%Z; auto. apply EvenMult1; auto with zarith. unfold Even; exists 1%Z; auto with zarith. apply FNevenEq with (Float (2*(Zsucc (2*(Fnum v))))%Z (Zpred (Zpred (Fexp v)))); auto with zarith. split. cut ((Zabs (2 * Zsucc (2 * Fnum v))) < Zpos (vNum be))%Z; auto with zarith. rewrite pkGivesBounde;rewrite Zabs_Zmult;rewrite Zabs_eq; auto with zarith; unfold Zsucc. apply Zle_lt_trans with (2 * (Zabs (2 * Fnum v) + (Zabs (1))))%Z; auto with zarith. rewrite Zabs_Zmult;rewrite Zabs_eq; auto with zarith. replace (Zabs (1))%Z with 1%Z; auto with zarith. apply Zle_lt_trans with (2 * (2 * (Zpred (Zpower_nat radix p)) + 1))%Z. cut (Zabs (Fnum v) <= (Zpred (Zpower_nat radix p)))%Z; auto with zarith float. elim Bv; rewrite pGivesBound; auto with zarith. unfold Zpred;ring_simplify (2 * (2 * (Zpower_nat radix p + -1) + 1))%Z. apply Zlt_le_trans with (4 * Zpower_nat radix p)%Z; auto with zarith. apply Zle_trans with (Zpower_nat radix (p+2))%Z; auto with zarith. rewrite Zpower_nat_is_exp;simpl (Zpower_nat 2); auto with zarith. simpl;apply Zle_trans with (Zpred (Zpred (- dExp b)))%Z; auto with zarith float. fold FtoRradix; apply Rplus_eq_reg_l with (-v)%R. apply trans_eq with (((y-v)))%R;[idtac|ring]. rewrite <- (Rabs_right (y-v)%R); auto with real. rewrite H2. pattern (FtoRradix v) at 1 in |-*; replace (FtoRradix v) with ((2*2*(Fnum v)*(powerRZ radix (Zpred (Zpred (Fexp v))))))%R. apply trans_eq with (- (4 * Fnum v * powerRZ radix (Zpred (Zpred (Fexp v)))) + ((2 * Zsucc (2 * Fnum v)))%Z * (powerRZ radix (Zpred (Zpred (Fexp v)))))%R. unfold FtoRradix, FtoR; simpl; ring. unfold Zsucc;rewrite mult_IZR;rewrite plus_IZR;rewrite mult_IZR;simpl; ring_simplify. unfold Zpred;repeat rewrite powerRZ_add; auto with zarith real; simpl; field; auto with real. unfold Zpred, FtoRradix, FtoR; repeat rewrite powerRZ_add; auto with zarith real; simpl; field; auto with real. apply Rle_ge; auto with real. apply EvenNormalize. split. cut ((Zabs (2 * Zsucc (2 * Fnum v))) < Zpos (vNum be))%Z; auto with zarith. rewrite pkGivesBounde;rewrite Zabs_Zmult;rewrite Zabs_eq; auto with zarith; unfold Zsucc. apply Zle_lt_trans with (2 * (Zabs (2 * Fnum v) + (Zabs (1))))%Z; auto with zarith. rewrite Zabs_Zmult;rewrite Zabs_eq; auto with zarith. replace (Zabs (1))%Z with 1%Z; auto with zarith. apply Zle_lt_trans with (2 * (2 * (Zpred (Zpower_nat radix p)) + 1))%Z. cut (Zabs (Fnum v) <= (Zpred (Zpower_nat radix p)))%Z; auto with zarith float. elim Bv; rewrite pGivesBound; auto with zarith. unfold Zpred;ring_simplify (2 * (2 * (Zpower_nat radix p + -1) + 1))%Z. apply Zlt_le_trans with (4 * Zpower_nat radix p)%Z; auto with zarith. apply Zle_trans with (Zpower_nat radix (p+2))%Z; auto with zarith. rewrite Zpower_nat_is_exp;simpl (Zpower_nat 2); auto with zarith. simpl;apply Zle_trans with (Zpred (Zpred (- dExp b)))%Z; auto with zarith float. replace (Fnum (Float (2 * Zsucc (2 * Fnum v)) (Zpred (Zpred (Fexp v)))))%Z with (2 * Zsucc (2 * Fnum v))%Z; auto. apply EvenMult1; auto with zarith. unfold Even; exists 1%Z; auto with zarith. generalize EvenClosestUniqueP; unfold UniqueP; intros T. unfold FtoRradix; apply T with b p y; auto with zarith; clear T. replace (FtoRradix y) with x; auto. cut (exists f : float, (Fbounded be f) /\ (FtoRradix f) = x). intros T; elim T; intros f T1; elim T1; intros H2 H3; clear T T1. rewrite <- H3; unfold FtoRradix. apply RoundedModeProjectorIdemEq with (precision:=p+k) (P:=(To_Odd be radix (p+k))) (b:=be); auto with zarith. apply To_OddRoundedModeP; auto with zarith. fold FtoRradix; rewrite H3; auto. assert (Rabs (x - v) = powerRZ radix (Zpred (Fexp v)))%R. apply trans_eq with (/2 * (2%nat * Rabs (x - v)))%R;[simpl; field; auto with real|idtac]. rewrite H1; unfold Fulp; rewrite FcanonicFnormalizeEq; auto with zarith. unfold Zpred; rewrite powerRZ_add; auto with real zarith; simpl; field. case (Rle_or_lt (x-v)%R 0%R); intros H2. exists (Float (2*(Zpred (2*(Fnum v))))%Z (Zpred (Zpred (Fexp v))));split. split. cut ((Zabs (2 *Zpred (2 * Fnum v))) < Zpos (vNum be))%Z; auto with zarith. rewrite pkGivesBounde;rewrite Zabs_Zmult;rewrite Zabs_eq; auto with zarith; unfold Zpred. apply Zle_lt_trans with (2 * (Zabs (2 * Fnum v) + (Zabs (-1))))%Z; auto with zarith. rewrite Zabs_Zmult;rewrite Zabs_eq; auto with zarith. replace (Zabs (-1))%Z with 1%Z; auto with zarith. apply Zle_lt_trans with (2 * (2 * (Zpred (Zpower_nat radix p)) + 1))%Z. cut (Zabs (Fnum v) <= (Zpred (Zpower_nat radix p)))%Z; auto with zarith float. elim Bv; rewrite pGivesBound; auto with zarith. unfold Zpred;ring_simplify (2 * (2 * (Zpower_nat radix p + -1) + 1))%Z. apply Zlt_le_trans with (4 * Zpower_nat radix p)%Z; auto with zarith. apply Zle_trans with (Zpower_nat radix (p+2))%Z; auto with zarith. rewrite Zpower_nat_is_exp;simpl (Zpower_nat 2); auto with zarith. simpl;apply Zle_trans with (Zpred (Zpred (- dExp b)))%Z; auto with zarith float. fold FtoRradix; apply Rplus_eq_reg_l with (-v)%R. apply trans_eq with (-(-(x-v)))%R;[idtac|ring]. rewrite <- (Rabs_left1 (x-v)%R); auto with real. rewrite H0. pattern (FtoRradix v) at 1 in |-*; replace (FtoRradix v) with ((2*2*(Fnum v)*(powerRZ radix (Zpred (Zpred (Fexp v))))))%R. apply trans_eq with (- (4 * Fnum v * powerRZ radix (Zpred (Zpred (Fexp v)))) + ((2 * Zpred (2 * Fnum v)))%Z * (powerRZ radix (Zpred (Zpred (Fexp v)))))%R. unfold FtoRradix, FtoR; simpl; ring. unfold Zpred;rewrite mult_IZR;rewrite plus_IZR;rewrite mult_IZR;simpl; ring_simplify. repeat rewrite powerRZ_add; auto with zarith real; simpl; field; auto with real. unfold Zpred, FtoRradix, FtoR; repeat rewrite powerRZ_add; auto with zarith real; simpl; field; auto with real. exists (Float (2*(Zsucc (2*(Fnum v))))%Z (Zpred (Zpred (Fexp v))));split. split. cut ((Zabs (2 *Zsucc (2 * Fnum v))) < Zpos (vNum be))%Z; auto with zarith. rewrite pkGivesBounde;rewrite Zabs_Zmult;rewrite Zabs_eq; auto with zarith; unfold Zsucc. apply Zle_lt_trans with (2 * (Zabs (2 * Fnum v) + (Zabs (1))))%Z; auto with zarith. rewrite Zabs_Zmult;rewrite Zabs_eq; auto with zarith. replace (Zabs (1))%Z with 1%Z; auto with zarith. apply Zle_lt_trans with (2 * (2 * (Zpred (Zpower_nat radix p)) + 1))%Z. cut (Zabs (Fnum v) <= (Zpred (Zpower_nat radix p)))%Z; auto with zarith float. elim Bv; rewrite pGivesBound; auto with zarith. unfold Zpred;ring_simplify (2 * (2 * (Zpower_nat radix p + -1) + 1))%Z. apply Zlt_le_trans with (4 * Zpower_nat radix p)%Z; auto with zarith. apply Zle_trans with (Zpower_nat radix (p+2))%Z; auto with zarith. rewrite Zpower_nat_is_exp;simpl (Zpower_nat 2); auto with zarith. simpl;apply Zle_trans with (Zpred (Zpred (- dExp b)))%Z; auto with zarith float. fold FtoRradix; apply Rplus_eq_reg_l with (-v)%R. apply trans_eq with (((x-v)))%R;[idtac|ring]. rewrite <- (Rabs_right (x-v)%R); auto with real. rewrite H0. pattern (FtoRradix v) at 1 in |-*; replace (FtoRradix v) with ((2*2*(Fnum v)*(powerRZ radix (Zpred (Zpred (Fexp v))))))%R. apply trans_eq with (- (4 * Fnum v * powerRZ radix (Zpred (Zpred (Fexp v)))) + ((2 * Zsucc (2 * Fnum v)))%Z * (powerRZ radix (Zpred (Zpred (Fexp v)))))%R. unfold FtoRradix, FtoR; simpl; ring. unfold Zsucc;rewrite mult_IZR;rewrite plus_IZR;rewrite mult_IZR;simpl; ring_simplify. unfold Zpred;repeat rewrite powerRZ_add; auto with zarith real; simpl; field; auto with real. unfold Zpred, FtoRradix, FtoR; repeat rewrite powerRZ_add; auto with zarith real; simpl; field; auto with real. apply Rle_ge; auto with real. Qed. End DblRndOdd. Float8.4/Others/Dekker.v0000644000423700002640000035032712032774527014724 0ustar sboldotoccataRequire 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 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. Float8.4/Others/Divnk.v0000644000423700002640000005163012032774527014565 0ustar sboldotoccataRequire Export AllFloat. Section Divnk. Variables b1 b2 b3 : Fbound. Variables n k : nat. Variables x y z: float. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Hypotheses nGreaterThanOne : (lt (S O) n). Hypotheses kGreaterThanOne : (lt (S O) k). Hypotheses nGivesBound1 : (Zpos (vNum b1)) = (Zpower_nat radix n). Hypotheses kGivesBound2 : (Zpos (vNum b2)) = (Zpower_nat radix k). Hypotheses nkGivesBound3 : (Zpos (vNum b3)) = (Zpower_nat radix (plus n k)). Hypotheses Normz : (Fnormal radix b1 z). Hypotheses Normy : (Fnormal radix b2 y). Hypotheses Normx : (Fnormal radix b3 x). Hypotheses zNonZero: ~((FtoRradix z)=0)%R. Hypotheses Roundy : (Closest b2 radix (Rdiv x z) y). Theorem Divnk_error: (Rabs (x/z-y) <= (powerRZ radix (Zpred (Fexp y))))%R. apply Rmult_le_reg_l with (S (S O)); auto with arith real. apply Rle_trans with (Fulp b2 radix k y). unfold FtoRradix; apply ClosestUlp;auto with zarith. unfold Fulp; rewrite FcanonicFnormalizeEq; auto with zarith. replace (INR (S (S O))) with (powerRZ radix (Zpos xH)); auto with real zarith. rewrite <- powerRZ_add; auto with real zarith; unfold Zpred. ring_simplify (1 + (Fexp y + -1))%Z;auto with real. left;auto. Qed. Theorem Normal_le: forall (b:Fbound) (u:float) (p:nat), (Zpos (vNum b)) = (Zpower_nat radix p) -> (Fnormal radix b u)-> ((Rabs u) <= (((powerRZ radix p)-1)*(powerRZ radix (Fexp u))))%R. intros b u p H1 H2. unfold FtoRradix; rewrite <- Fabs_correct;auto with zarith. unfold Fabs, FtoR;apply Rmult_le_compat_r;auto with real zarith;simpl. elim H2; intros H3 H4;elim H3; intros H5 H6. apply Rle_trans with (Zpred (Zpos (vNum b)));auto with zarith real float. rewrite H1; unfold Zpred; simpl; right. rewrite plus_IZR;simpl;rewrite Zpower_nat_Z_powerRZ;auto with real zarith. Qed. Theorem Normal_ge: forall (b:Fbound) (u:float) (p:nat), (Zpos (vNum b)) = (Zpower_nat radix p) -> (Fnormal radix b u)-> (Rle (powerRZ radix (Zplus (Zpred p) (Fexp u))) (Rabs u)). intros b u p H1 H2. unfold FtoRradix; rewrite <- Fabs_correct;auto with zarith. rewrite powerRZ_add; auto with real zarith. unfold Fabs, FtoR;apply Rmult_le_compat_r;auto with real zarith;simpl. elim H2; intros H3 H4. apply Rmult_le_reg_l with radix; auto with real zarith. apply Rle_trans with (Zpos (vNum b)). replace (IZR radix) with (powerRZ 2%Z 1%Z);[rewrite <- powerRZ_add|simpl];auto with real zarith. replace (1 + Zpred p)%Z with (Z_of_nat p);[right;rewrite H1; rewrite Zpower_nat_Z_powerRZ;auto |unfold Zpred;ring]. apply Rle_trans with (IZR (Zabs (Zmult radix (Fnum u))));auto with zarith real. rewrite Zabs_Zmult;rewrite mult_IZR;auto with real zarith. Qed. Theorem Divnk_FexpyGe: (Zle (Zminus (Fexp x) (Fexp z)) (Fexp y)). cut (Rlt R0 (Rminus (powerRZ radix n) R1));[intros V1|idtac]. 2: apply Rplus_lt_reg_r with R1. 2: ring_simplify. 2: replace 1%R with (powerRZ radix 0%Z); auto with real zarith. cut (Rlt R0 (Rminus (powerRZ radix (Zsucc k)) R1));[intros V2|idtac]. 2: apply Rplus_lt_reg_r with R1. 2: ring_simplify. 2: replace 1%R with (powerRZ radix 0%Z); auto with real zarith. apply Zlt_succ_le. apply Zlt_powerRZ with radix; auto with zarith real. apply Rle_lt_trans with (Rmult R1 (powerRZ radix (Zminus (Fexp x) (Fexp z)))); [right;ring|idtac]. apply Rlt_le_trans with (Rmult (Rdiv (powerRZ radix (Zsucc (Zplus n k))) (Rmult (Rminus (powerRZ radix n) R1) (Rminus (powerRZ radix (Zsucc k)) R1))) (powerRZ radix (Zminus (Fexp x) (Fexp z)))). apply Rmult_lt_compat_r; auto with real zarith. apply Rmult_lt_reg_l with (Rmult (Rminus (powerRZ radix n) R1) (Rminus (powerRZ radix (Zsucc k)) R1)). apply Rmult_lt_0_compat;auto. apply Rlt_le_trans with (powerRZ radix (Zsucc (Zplus n k)));[idtac|right;field;auto with real]. apply Rplus_lt_reg_r with ((powerRZ radix n)+(powerRZ radix (Zsucc k))-(powerRZ radix (Zsucc (Zplus n k))))%R. ring_simplify. rewrite <- powerRZ_add; auto with real zarith. replace (n+(Zsucc k))%Z with (Zsucc (Zplus n k));[idtac|unfold Zsucc;ring]. ring_simplify. apply Rle_lt_trans with (Rplus R0 R1); auto with real zarith. apply Rle_lt_trans with (Rplus (powerRZ radix n) R1);auto with real zarith. apply Rplus_lt_compat_l; apply Rplus_lt_reg_r with (Ropp R1);auto with real. ring_simplify (-1+1)%R;apply Rlt_le_trans with (1:=V2);right;ring. apply Rle_trans with ((Rabs x)/(((powerRZ radix n)- 1)*((powerRZ radix (Zsucc k))- 1))*(powerRZ radix (Zsucc (Zsucc (Zopp (Fexp z))))))%R. unfold Rdiv;rewrite Rmult_comm; rewrite Rmult_comm with (r2:=(powerRZ radix (Zsucc (Zsucc (Zopp (Fexp z))))));rewrite <- Rmult_assoc;rewrite <- Rmult_assoc. apply Rmult_le_compat_r; auto with real. apply Rlt_le; apply Rinv_0_lt_compat; apply Rmult_lt_0_compat;auto with real. apply Rle_trans with ((powerRZ radix (Zsucc (Zsucc (Zopp (Fexp z)))))*(powerRZ radix (Zplus (Zpred (Zplus n k)) (Fexp x))))%R. repeat rewrite <- powerRZ_add;auto with real zarith. replace (Zplus (Zminus (Fexp x) (Fexp z)) (Zsucc (Zplus n k))) with (Zplus (Zsucc (Zsucc (Zopp (Fexp z)))) (Zplus (Zpred (Zplus n k)) (Fexp x)));auto with real. unfold Zsucc, Zpred;ring. apply Rmult_le_compat_l;auto with real zarith. rewrite <- inj_plus; apply Normal_ge with b3;auto. apply Rle_trans with ((Rabs (x/z))/((powerRZ radix (Zsucc k))-1)*(powerRZ radix (Zsucc (Zsucc 0%Z))))%R. unfold Rdiv; rewrite Rabs_mult. repeat rewrite Rmult_assoc; apply Rmult_le_compat_l;auto with real. rewrite Rinv_mult_distr;auto with real. rewrite Rmult_comm;rewrite <- Rmult_assoc. rewrite Rmult_comm with (r2:=(powerRZ radix (Zsucc (Zsucc 0%Z))));rewrite <- Rmult_assoc. apply Rmult_le_compat_r;auto with real. apply Rmult_le_reg_l with (powerRZ radix (Zpred (Zpred (Fexp z))));auto with real zarith. rewrite <- Rmult_assoc; rewrite <- powerRZ_add;auto with real zarith. replace (Zplus (Zpred (Zpred (Fexp z))) (Zsucc (Zsucc (Zopp (Fexp z))))) with 0%Z ;[idtac|unfold Zsucc, Zpred;ring]. rewrite Rmult_comm with (r2:= (powerRZ radix (Zsucc (Zsucc 0%Z)))); rewrite <- Rmult_assoc. rewrite <- powerRZ_add;auto with real zarith. replace (Zplus (Zpred (Zpred (Fexp z))) (Zsucc (Zsucc 0%Z))) with (Fexp z) ;[idtac|unfold Zsucc, Zpred;ring]. apply Rmult_le_reg_l with ((powerRZ radix n)-1)%R;auto with real. apply Rle_trans with R1;[simpl; right; field;auto with real|idtac]. apply Rmult_le_reg_l with (Rabs z);auto with real. cut (Rle R0 (Rabs z));[intros W; case W|idtac];auto with real. intros W'; Contradict W'; apply not_eq_sym ;apply Rabs_no_R0;auto. apply Rle_trans with (Rabs z);[right;ring|idtac]. apply Rle_trans with (((powerRZ radix n)-1)*(powerRZ radix (Fexp z)))%R. apply Normal_le with b1;auto. replace (Rabs (/z))%R with (/(Rabs z))%R. right;field;auto with real. apply Rabs_no_R0;auto. apply Rmult_eq_reg_l with (Rabs z);auto with real. 2:apply Rabs_no_R0;auto. apply trans_eq with R1;[field|rewrite <- Rabs_mult]. apply Rabs_no_R0;auto. replace (z*/z)%R with 1%R;auto with real. rewrite Rabs_right;auto with real;apply Rle_ge;auto with real. apply Rmult_le_reg_l with (((powerRZ radix (Zsucc k))-1)*(powerRZ radix (Zpred (Zpred 0%Z))))%R. apply Rmult_lt_0_compat;auto with real zarith. apply Rle_trans with ((Rabs (x/z)))%R. right;unfold Rdiv. apply trans_eq with ((((powerRZ radix (Zsucc k))-1)*/((powerRZ radix (Zsucc k))-1))* ((powerRZ radix (Zpred (Zpred 0%Z)))*(powerRZ radix (Zsucc (Zsucc 0%Z))))* (Rabs (x*/z)))%R;[ring|idtac]. rewrite Rinv_r;auto with real. rewrite <- powerRZ_add;auto with real zarith. replace (Zplus (Zpred (Zpred 0%Z)) (Zsucc (Zsucc 0%Z))) with 0%Z;[simpl|unfold Zpred, Zsucc];ring. apply Rplus_le_reg_l with (Ropp (Rabs y)). apply Rle_trans with ((Rabs (x/z))-(Rabs y))%R;[right;ring|idtac]. apply Rle_trans with ((Rabs (x/z-y)))%R;[apply Rabs_triang_inv|idtac]. apply Rle_trans with (1:=Divnk_error). apply Rplus_le_reg_l with ((Rabs y)-(powerRZ radix (Zpred (Fexp y))))%R. apply Rle_trans with (Rabs y);[right;ring|idtac]. apply Rle_trans with (Rmult (Rminus (powerRZ radix k) R1) (powerRZ radix (Fexp y))). apply Normal_le with b2;auto. right;ring_simplify. repeat rewrite <- powerRZ_add; auto with real zarith. replace (Zpred (Zpred 0) + Zsucc (Fexp y))%Z with (Zpred (Fexp y));[idtac|unfold Zsucc, Zpred;ring]. replace (Zsucc k + Zpred (Zpred 0) + Zsucc (Fexp y))%Z with (Zplus k (Fexp y));[idtac|unfold Zsucc, Zpred;ring]. replace (powerRZ radix (Fexp y)) with (Rplus (powerRZ radix (Zpred (Fexp y))) (powerRZ radix (Zpred (Fexp y)))); [idtac|pattern (Fexp y) at 3 in |-*;replace (Fexp y) with (Zplus 1%Z (Zpred (Fexp y)))]. ring. rewrite powerRZ_add; auto with zarith real;simpl;ring. unfold Zpred;ring. Qed. Theorem Divnk_FexpyLe: (Zle (Fexp y) (Zplus 2%Z (Zminus (Fexp x) (Fexp z)))). cut (Rlt R0 (Rminus (powerRZ radix k) R1));[intros V1|idtac]. 2: apply Rplus_lt_reg_r with R1. 2: ring_simplify. 2: replace R1 with (powerRZ radix 0%Z); auto with real zarith. apply Zle_n_Zpred;apply Zle_Zpred. apply Zlt_powerRZ with radix; auto with zarith real. apply Rmult_lt_reg_l with ((powerRZ radix k)-1)%R;auto with real. apply Rle_lt_trans with ((powerRZ radix (Zplus (Zpred k) (Fexp y)))-(powerRZ radix (Zpred (Fexp y))))%R. right;ring_simplify. rewrite <- powerRZ_add; auto with real zarith. replace (Zplus (Zpred k) (Fexp y)) with (Zplus k (Zpred (Fexp y)));[idtac|unfold Zpred]; ring. apply Rle_lt_trans with ((Rabs y)-(powerRZ radix (Zpred (Fexp y))))%R. unfold Rminus; apply Rplus_le_compat_r. apply Normal_ge with b2;auto. apply Rle_lt_trans with (Rabs (Rdiv x z)). apply Rplus_le_reg_l with ((powerRZ radix (Zpred (Fexp y)))-(Rabs (x/z)))%R. ring_simplify. apply Rle_trans with ((Rabs y)-(Rabs (x/z)))%R;[right;ring|idtac]. apply Rle_trans with ((Rabs (y-x/z)))%R;[apply Rabs_triang_inv|idtac]. apply Rle_trans with (2:=Divnk_error). replace (y-x/z)%R with (-(x/z-y))%R;[rewrite Rabs_Ropp;auto with real|ring]. unfold Rdiv;rewrite Rabs_mult. apply Rle_lt_trans with ((((powerRZ radix (Zplus n k))-1)*(powerRZ radix (Fexp x)))* /(((powerRZ radix (Zplus (Zpred n) (Fexp z))))))%R. apply Rmult_le_compat;auto with real zarith. rewrite <- inj_plus; apply Normal_le with b3;auto. apply Rle_trans with (Rinv (Rabs z)). right;apply Rmult_eq_reg_l with (Rabs z);auto with real. 2:apply Rabs_no_R0;auto. apply sym_eq;apply trans_eq with R1;[field|rewrite <- Rabs_mult]. apply Rabs_no_R0;auto. replace (z*/z)%R with R1;auto with real. rewrite Rabs_right;auto with real;apply Rle_ge;auto with real. apply Rle_Rinv;auto with real zarith. apply Normal_ge with b1;auto. rewrite Rinv_powerRZ;auto with zarith real. apply Rmult_lt_reg_l with (powerRZ radix (-(Fexp x)+(Fexp z)+n-1)%Z);auto with zarith real. rewrite Rmult_comm; rewrite Rmult_assoc;rewrite <- powerRZ_add; auto with real zarith. rewrite Rmult_assoc;rewrite <- powerRZ_add; auto with real zarith. replace (Zplus (Fexp x) (Zplus (Zopp (Zplus (Zpred n) (Fexp z))) (Zminus (Zplus (Zplus (Zopp (Fexp x)) (Fexp z)) n) (Zpos xH)))) with 0%Z; [idtac|unfold Zsucc, Zpred;ring]. apply Rle_lt_trans with ((powerRZ radix (Zplus n k))-1)%R;[right;simpl;ring|idtac]. rewrite Rmult_comm; rewrite Rmult_assoc. rewrite <- powerRZ_add; auto with real zarith. replace (Zplus (Zplus (Zpos (xO xH)) (Zminus (Fexp x) (Fexp z))) (Zminus (Zplus (Zplus (Zopp (Fexp x)) (Fexp z)) n) (Zpos xH))) with (Zsucc n); [idtac|unfold Zsucc, Zpred;ring]. apply Rlt_le_trans with (Rminus (powerRZ radix (Zplus n k)) R0);auto with real. unfold Rminus; apply Rplus_lt_compat_l;auto with real. apply Rplus_le_reg_l with ((powerRZ radix (Zsucc n))-(powerRZ radix (Zplus n k)))%R. apply Rle_trans with (powerRZ radix (Zsucc n));[right;ring|idtac]. apply Rle_trans with (powerRZ radix (Zplus n k));auto with real zarith. right;ring_simplify. rewrite <- powerRZ_add; auto with real zarith. replace (Zplus (Zsucc n) k) with (Zplus (Zpos xH) (Zplus n k)); [repeat rewrite powerRZ_add; auto with real zarith|unfold Zsucc;ring]. simpl;ring. Qed. Theorem Divnk_FexpyLe2: (Rle (powerRZ radix (Zplus (Zpred k) (Fexp y))) (Rabs (Rdiv x z))) -> (Zle (Fexp y) (Zplus 1%Z (Zminus (Fexp x) (Fexp z)))). intros H. apply Zle_n_Zpred;apply Zle_Zpred. apply Zplus_lt_reg_l with k. apply Zlt_powerRZ with radix; auto with zarith real. replace (Zplus k (Zpred (Fexp y))) with (Zplus (Zpred k) (Fexp y));[idtac|unfold Zpred;ring]. apply Rle_lt_trans with (1:=H). unfold Rdiv;rewrite Rabs_mult. apply Rle_lt_trans with ((Rabs x)*(powerRZ radix (Zopp (Zplus (Zpred n) (Fexp z)))))%R. apply Rmult_le_compat_l;auto with real. apply Rle_trans with (Rinv (Rabs z)). right;apply Rmult_eq_reg_l with (Rabs z);auto with real. 2:apply Rabs_no_R0;auto. apply sym_eq;apply trans_eq with R1;[field|rewrite <- Rabs_mult]. apply Rabs_no_R0;auto. replace (z*/z)%R with R1;auto with real. rewrite Rabs_right;auto with real;apply Rle_ge;auto with real. rewrite <- Rinv_powerRZ;auto with real zarith. apply Rle_Rinv;auto with real zarith. apply Normal_ge with b1;auto. apply Rlt_le_trans with ((powerRZ radix (Zplus (Zplus n k) (Fexp x)))*(powerRZ radix (Zopp (Zplus (Zpred n) (Fexp z)))))%R. apply Rmult_lt_compat_r; auto with real zarith. apply Rle_lt_trans with (Rmult (Rminus (powerRZ radix (plus n k)) R1) (powerRZ radix (Fexp x))). apply Normal_le with b3;auto. rewrite powerRZ_add; auto with real zarith. apply Rmult_lt_compat_r; auto with real zarith. apply Rlt_le_trans with ((powerRZ radix (plus n k))-0)%R. unfold Rminus; apply Rplus_lt_compat_l; auto with real. rewrite inj_plus; auto with real. right; rewrite <- powerRZ_add; auto with real zarith. replace (Zplus (Zplus (Zplus n k) (Fexp x)) (Zopp (Zplus (Zpred n) (Fexp z)))) with (Zplus k (Zplus (Zpos xH) (Zminus (Fexp x) (Fexp z)))); [auto with real|unfold Zpred; ring]. Qed. Theorem Rle_err_pow2: forall (b:Fbound) (p:nat) (r:R) (f:float), (lt (S O) p) -> (Zpos (vNum b)) = (Zpower_nat radix p) -> (Fnormal radix b f) -> ~((Fexp f) = (Zopp (dExp b))) -> ((FtoRradix f)=(powerRZ radix (Zplus (Zpred p) (Fexp f))))%R -> (Rlt r f) -> (Closest b radix r f) -> (Rle (Rabs (Rminus f r)) (powerRZ radix (Zpred (Zpred (Fexp f))))). intros. case (Rle_or_lt (Rabs (Rminus f r)) (powerRZ radix (Zpred (Zpred (Fexp f))))); intros;auto. absurd (Rlt (Rabs (Rminus (FPred b radix p f) r)) (Rabs (Rminus f r))). apply Rle_not_lt. elim H5; intros;unfold FtoRradix;apply H8. apply FBoundedPred;auto with zarith. apply Rle_lt_trans with (2:=H6). rewrite Rabs_left1. apply Rle_trans with ((r-f)+-((FPred b radix p f)-f))%R;[right;ring|idtac]. apply Rle_trans with (-(powerRZ radix (Zpred (Zpred (Fexp f))))+(powerRZ radix (Zpred (Fexp f))))%R. apply Rplus_le_compat. apply Rle_trans with (-(f-r))%R;auto with real. apply Ropp_le_contravar. rewrite <- Rabs_right;auto with real. apply Rle_ge;auto with real. apply Rle_trans with (f-(FPred b radix p f))%R;[right;ring|idtac]. unfold FtoRradix; rewrite <- Fminus_correct;auto with zarith. cut (f=(Float (nNormMin radix p) (Fexp f)));[intros|idtac]. rewrite FPredDiff3;auto with zarith. right; unfold FtoR; simpl;ring. rewrite H7;simpl;auto with zarith. apply FnormalUnique with radix b p; auto with zarith. cut (0 < (nNormMin radix p))%Z;[intros|apply nNormPos;auto with zarith]. repeat split; auto with zarith float. simpl;rewrite Zabs_eq;[apply ZltNormMinVnum|idtac];auto with zarith float. simpl; elim H5;auto with zarith float. rewrite Zabs_eq;auto with zarith float. rewrite PosNormMin with radix b p;simpl;auto with zarith. fold FtoRradix; rewrite H3; unfold FtoRradix, FtoR, nNormMin;simpl. rewrite Zpower_nat_Z_powerRZ; rewrite inj_pred;auto with zarith. rewrite powerRZ_add; auto with real zarith. right; pattern (Zpred (Fexp f)) at 2; replace (Zpred (Fexp f)) with (Zplus (Zpos xH) (Zpred (Zpred (Fexp f))));[idtac|unfold Zpred;ring]. rewrite powerRZ_add;auto with zarith real. simpl;ring. apply Rplus_le_reg_l with r. apply Rle_trans with ((FPred b radix p f))%R;[right;ring|idtac]. apply Rle_trans with r;[idtac|right;ring]. case (ClosestMinOrMax b radix r f);auto;intros. apply Rle_trans with (FtoRradix f);[apply Rlt_le; unfold FtoRradix; apply FPredLt;auto with zarith|idtac]. unfold FtoRradix;elim H7; intros; elim H9; auto with real. case (Rle_or_lt r (FPred b radix p f));auto with real;intros. absurd (Rlt (FPred b radix p f) f). apply Rle_not_lt. elim H7; intros; elim H10; intros. unfold FtoRradix; apply H12; auto. apply FBoundedPred;auto with float zarith. unfold FtoRradix; apply FPredLt;auto with zarith. Qed. Theorem Divnk: ((Fexp y) <> (-(dExp b2)))%Z -> (Rlt (Zabs (Fnum (Fminus radix x (Fmult y z)))) (powerRZ radix n)). intros G. cut ((Fexp (Fminus radix x (Fmult y z)))=(Fexp x)); [intros H1|idtac]. 2:unfold Fminus, Fplus, Fopp, Fmult; simpl. 2:apply Zmin_le1; generalize Divnk_FexpyGe;auto with zarith. apply Rmult_lt_reg_l with (powerRZ radix (Fexp x));auto with zarith real. apply Rle_lt_trans with (Rabs (Rminus x (Rmult y z))). right; unfold FtoRradix; rewrite <- Fmult_correct;auto with zarith. rewrite <- Fminus_correct;auto with zarith;rewrite <- Fabs_correct;auto with zarith. unfold FtoR, Fabs; rewrite H1;simpl;ring. replace (x-y*z)%R with (z*(x/z-y))%R;[idtac|field;auto with real]. rewrite Rabs_mult. case (Rle_or_lt (powerRZ radix (Zplus (Zpred k) (Fexp y))) (Rabs (Rdiv x z))); intros H. apply Rle_lt_trans with ((Rabs z)*(powerRZ radix (Zpred (Fexp y))))%R. apply Rmult_le_compat_l;auto with real;apply Divnk_error. apply Rlt_le_trans with (((powerRZ radix n)*(powerRZ radix (Fexp z)))*(powerRZ radix (Zpred (Fexp y))))%R. apply Rmult_lt_compat_r;auto with real zarith. unfold FtoRradix; rewrite <- Fabs_correct;auto with zarith; unfold Fabs, FtoRradix, FtoR. simpl; apply Rmult_lt_compat_r;auto with real zarith. apply Rlt_le_trans with (Zpos (vNum b1));auto with real zarith. elim Normz; intros V1 V2;elim V1; intros V3 V4;auto with zarith real. rewrite nGivesBound1;right;rewrite Zpower_nat_Z_powerRZ;auto with real zarith. repeat rewrite <- powerRZ_add; auto with real zarith. apply Rle_powerRZ;auto with zarith real. generalize (Divnk_FexpyLe2 H); unfold Zsucc, Zpred; auto with zarith. rewrite <- powerRZ_add; auto with real zarith. cut (Rle R0 ((Rabs (x/z-y)))%R);auto with real; intros H2;case H2. 2: intros W; rewrite <- W; ring_simplify ((Rabs z)*0)%R;auto with real zarith. clear H2; intros H2. apply Rlt_le_trans with ((powerRZ radix (Zplus n (Fexp z)))*(Rabs (x/z-y)))%R. apply Rmult_lt_compat_r; auto with real. apply Rle_lt_trans with (Rmult (Rminus (powerRZ radix n) R1) (powerRZ radix (Fexp z))). apply Normal_le with b1;auto. rewrite powerRZ_add; auto with real zarith. apply Rmult_lt_compat_r; auto with real zarith. apply Rlt_le_trans with ((powerRZ radix n)-0)%R;[idtac|right;ring]. unfold Rminus; apply Rplus_lt_compat_l; auto with real. apply Rmult_le_reg_l with (powerRZ radix (Zopp (Zplus n (Fexp z))));auto with real zarith. rewrite <- Rmult_assoc; repeat rewrite <- powerRZ_add; auto with real zarith. ring_simplify (Zplus (Zopp (Zplus n (Fexp z))) (Zplus n (Fexp z))); ring_simplify (Zplus (Zopp (Zplus n (Fexp z))) (Zplus (Fexp x) n)). apply Rle_trans with ((Rabs (x/z-y)))%R;[right;simpl;ring|idtac]. apply Rle_trans with (powerRZ radix (Zplus (-2)%Z (Fexp y))). 2: apply Rle_powerRZ;auto with real zarith. 2:generalize Divnk_FexpyLe;auto with zarith. replace (Zplus (-2)%Z (Fexp y)) with (Zpred (Zpred (Fexp y)));[idtac|unfold Zpred;ring]. rewrite <- Rabs_Ropp. replace (-(x/z-y))%R with (y-x/z)%R;[idtac|ring]. apply Rle_trans with ((Rabs ((Fabs y)-(Rabs (x/z)))))%R. unfold FtoRradix; rewrite Fabs_correct;auto with zarith; fold FtoRradix. case (Rle_or_lt R0 (x/z)%R);intros. rewrite (Rabs_right (x/z)%R);auto with real. rewrite (Rabs_right (y)%R);auto with real. apply Rle_ge; unfold FtoRradix; apply RleRoundedR0 with b2 k (Closest b2 radix) (x/z)%R;auto with zarith float. apply ClosestRoundedModeP with k;auto with zarith. right;rewrite (Rabs_left (x/z)%R);auto with real. rewrite (Rabs_left1 (y)%R);auto with real. replace (-y- -(x/z))%R with (-(y-x/z))%R;[idtac|ring]. rewrite Rabs_Ropp;auto with real. unfold FtoRradix; apply RleRoundedLessR0 with b2 k (Closest b2 radix) (x/z)%R;auto with zarith float real. apply ClosestRoundedModeP with k;auto with zarith. cut ((Fexp y) = (Fexp (Fabs y)));[intros V2|unfold Fabs;simpl; auto with zarith]. cut ((FtoRradix (Fabs y))=(powerRZ radix (Zplus (Zpred k) (Fexp y))));[intros V1|idtac]. replace (Fexp y) with (Fexp (Fabs y));auto. apply Rle_err_pow2 with b2 k;auto with zarith float. apply FnormalFabs;auto with zarith. rewrite V1;auto with real. apply ClosestFabs with k;auto with zarith. apply Rle_antisym. 2: unfold FtoRradix; rewrite Fabs_correct; auto with zarith; fold FtoRradix. 2: apply Normal_ge with b2;auto. cut ((powerRZ radix (Zplus (Zpred k) (Fexp y)))=(Float (nNormMin radix k) (Fexp y)));[intros|idtac]. rewrite H0;unfold FtoRradix. generalize (ClosestMonotone b2 radix); unfold MonotoneP;intros T. apply T with (Rabs (x/z)%R) (powerRZ radix (Zplus (Zpred k) (Fexp y)));auto. apply ClosestFabs with k;auto with zarith. rewrite H0; unfold FtoRradix; apply RoundedModeProjectorIdem with b2. apply ClosestRoundedModeP with k;auto with zarith. cut (0 < (nNormMin radix k))%Z;[intros|apply nNormPos;auto with zarith]. repeat split; auto with zarith float. simpl;rewrite Zabs_eq;[apply ZltNormMinVnum|idtac];auto with zarith float. simpl; elim Normy;auto with zarith float. unfold FtoRradix, FtoR, nNormMin;simpl. rewrite Zpower_nat_Z_powerRZ; rewrite inj_pred;auto with zarith. rewrite powerRZ_add; auto with zarith real. Qed. End Divnk. Float8.4/Others/FmaEmul.v0000644000423700002640000022234312032774527015041 0ustar sboldotoccataRequire Export DblRndOdd. Require Export FboundI. Require Export MinOrMax. Require Export DoubleRound. Section Prelim. Variable b : Fbound. Variable radix : Z. Variable precision : 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 precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Theorem plusExactSub: forall (P : R -> float -> Prop) (x y r : float), (RoundedModeP b radix P) -> (Fsubnormal radix b x) -> (Fsubnormal radix b y) -> (P (x+y)%R r) -> (FtoRradix r=x+y)%R. intros. unfold FtoRradix; rewrite <- Fplus_correct; auto with zarith; apply sym_eq. apply RoundedModeProjectorIdemEq with b precision P; auto with zarith. elim H1; elim H0; intros. elim H4; elim H6; clear H4 H6; intros. unfold Fplus; simpl; rewrite Zmin_le1; auto with zarith. replace (Fnum x * Zpower_nat radix (Zabs_nat (Fexp x - Fexp x)) + Fnum y * Zpower_nat radix (Zabs_nat (Fexp y - Fexp x)))%Z with (Fnum x+Fnum y)%Z. split; simpl; auto with zarith. apply Zle_lt_trans with ((Zabs (Fnum x)+Zabs (Fnum y)))%Z; auto with zarith. apply Zmult_lt_reg_r with radix; auto with zarith. apply Zle_lt_trans with (Zabs (radix * Fnum x)+(Zabs (radix * Fnum y)))%Z. repeat rewrite Zabs_Zmult; repeat rewrite (Zabs_eq radix); auto with zarith. replace ((Zabs (Fnum x) + Zabs (Fnum y)) * radix)%Z with (radix * Zabs (Fnum x) + radix * Zabs (Fnum y))%Z; auto with zarith; ring. apply Zlt_le_trans with (Zpos (vNum b) * 2)%Z; auto with zarith. rewrite H4; rewrite H7; simpl. ring_simplify (- dExp b - - dExp b)%Z; simpl. unfold Zpower_nat; simpl; ring. rewrite Fplus_correct; auto with real zarith. Qed. End Prelim. Section Sec1. Variable bo : Fbound. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Variable p : nat. Hypotheses pGreaterThanOne : (lt (S O) p). Hypotheses pGivesBound : (Zpos (vNum bo)) = (Zpower_nat radix p). Theorem AddOddEven_aux_aux: forall (x y:float), (5* (Rabs y) <= x)%R -> (0 < x)%R -> (5*(firstNormalPos radix bo p) <= x)%R -> (Fcanonic radix bo y) ->(Fcanonic radix bo x) -> (exists k:nat, exists be:Fbound, exists xy:float, (1 < k) /\ (Zpos (vNum be)) = (Zpower_nat radix (p+k)) /\ (- dExp be <= Zpred (Zpred (- dExp bo)))%Z /\ (FtoRradix xy =x+y)%R /\ (Fnormal radix be xy) /\ (Fexp xy=Fexp y)). intros. cut (forall k:nat, exists bb:Fbound, Zpos (vNum bb) = Zpower_nat radix k /\ (Zsucc (Zsucc (dExp bo)) <= dExp bb)%Z). intros L1. exists ((FNI radix 1 (Zabs_nat (Fnum (Fplus radix x y))))-p+1). elim L1 with (1+FNI radix 1 (Zabs_nat (Fnum (Fplus radix x y)))). intros bb T; elim T; intros; clear T L1. exists bb. exists (Fplus radix x y). cut (1 <= Zabs_nat (Fnum (Fplus radix x y)));[intros L1|idtac]. generalize (FNIMore radix); intros T; lapply T; auto with zarith; clear T; intros T. lapply (T (Zabs_nat (Fnum (Fplus radix x y))) 1); auto with zarith. clear T; intros T; lapply T; auto; clear T; intros L2. cut (Zabs_nat (Fnum (Fplus radix x y)) < radix * (Zpower_nat radix (FNI radix 1 (Zabs_nat (Fnum (Fplus radix x y))))))%Z; [clear L2; intros L2| apply Zlt_le_trans with (1:=L2)]. 2:apply Zmult_le_compat_l; simpl; auto with zarith. generalize (FNILess radix); intros T; lapply T; auto with zarith; clear T; intros T. lapply (T 1 (Zabs_nat (Fnum (Fplus radix x y)))); auto with zarith. clear T; intros T; lapply T; auto; clear T; intros L3. cut (Zpower_nat radix (FNI radix 1 (Zabs_nat (Fnum (Fplus radix x y)))) <= Zabs_nat (Fnum (Fplus radix x y)))%Z; [clear L3; intros L3| apply Zle_trans with (2:=L3)]. 2: simpl; auto with zarith. cut (Fexp (Fplus radix x y) = Fexp y);[intros J1|idtac]. assert (p < FNI radix 1 (Zabs_nat (Fnum (Fplus radix x y)))). case H2; intros J2. apply Zpower_nat_anti_monotone_lt with radix; auto with zarith. apply Zmult_lt_reg_r with radix; auto with zarith. apply Zle_lt_trans with (Zabs_nat (Fnum (Fplus radix x y))) ; auto with zarith. 2: apply Zlt_le_trans with (1:=L2); auto with zarith. apply Zle_Rle; rewrite mult_IZR. apply Rmult_le_reg_l with (powerRZ radix (Fexp (Fplus radix x y))); auto with real zarith. apply Rle_trans with (Rabs (x+y))%R. rewrite J1; apply Rle_trans with (Rabs x -Rabs y)%R. apply Rplus_le_reg_l with (Rabs y). ring_simplify (Rabs y + (Rabs x - Rabs y))%R. apply Rle_trans with (5*Rabs y)%R. apply Rle_trans with ((Rabs y)+4*Rabs y)%R;[apply Rplus_le_compat_l|right; ring]. unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith; unfold Fabs, FtoR. simpl. apply Rle_trans with ((powerRZ 2 (Fexp y))*((2*(Zabs (Fnum y)))*2))%R; [idtac|right; ring]. apply Rmult_le_compat_l; auto with real zarith. apply Rmult_le_compat_r; auto with real zarith. elim J2; intros. rewrite <- pGivesBound; rewrite Zabs_Zmult in H7. rewrite Zabs_eq in H7; auto with real zarith. apply Rle_trans with (IZR (radix * Zabs (Fnum y))); auto with real zarith. rewrite mult_IZR; simpl; auto with zarith real. rewrite Rabs_right with x; [idtac|apply Rle_ge];auto with real. rewrite <- Rabs_Ropp with x. apply Rle_trans with (Rabs (-x-y))%R. apply Rabs_triang_inv. replace (-x-y)%R with (-(x+y))%R; [rewrite Rabs_Ropp;auto with real|ring]. unfold FtoRradix; rewrite <- Fplus_correct; auto with zarith. rewrite <- Fabs_correct; auto with zarith; unfold FtoR, Fabs; simpl; right; ring_simplify. rewrite Zabs_absolu; ring. apply Zpower_nat_anti_monotone_lt with radix; auto with zarith. apply Zmult_lt_reg_r with radix; auto with zarith. apply Zle_lt_trans with (Zabs_nat (Fnum (Fplus radix x y))) ; auto with zarith. 2: apply Zlt_le_trans with (1:=L2); auto with zarith. apply Zle_Rle; rewrite mult_IZR. apply Rmult_le_reg_l with (powerRZ radix (Fexp (Fplus radix x y))); auto with real zarith. apply Rle_trans with (Rabs (x+y))%R. rewrite J1; apply Rle_trans with (Rabs x -Rabs y)%R. apply Rmult_le_reg_l with 5%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 (4+1)%R; auto with real. apply Rle_trans with (4*(5*(firstNormalPos radix bo p)))%R. right; unfold firstNormalPos, nNormMin, FtoRradix, FtoR; simpl. elim J2; intros T1 T2; elim T2; intros T3 T4; rewrite T3. replace (Zpower_nat radix p) with (2*(Zpower_nat radix (pred p)))%Z. rewrite mult_IZR; simpl; ring. pattern p at 2; replace p with (1+pred p); auto with zarith. apply Rle_trans with (4*x)%R; auto with real. apply Rmult_le_compat_l; auto with real. apply Rle_trans with 2%R; auto with real. rewrite (Rabs_right x);[idtac| apply Rle_ge; auto with real]. apply Rplus_le_reg_l with ((5*Rabs y)-4*x)%R. ring_simplify. apply Rle_trans with (2:=H); right; ring. rewrite <- Rabs_Ropp with x. apply Rle_trans with (Rabs (-x-y))%R. apply Rabs_triang_inv. replace (-x-y)%R with (-(x+y))%R; [rewrite Rabs_Ropp;auto with real|ring]. unfold FtoRradix; rewrite <- Fplus_correct; auto with zarith. rewrite <- Fabs_correct; auto with zarith; unfold FtoR, Fabs; simpl; right; ring_simplify. rewrite Zabs_absolu; ring. split; auto with zarith. split;[rewrite H4; auto with zarith|idtac]. split. apply Zle_trans with (-(Zsucc (Zsucc (dExp bo))))%Z; auto with zarith. unfold Zsucc, Zpred; auto with zarith. split;[unfold FtoRradix; rewrite Fplus_correct; auto with real zarith|idtac]. split; auto. split;[split|idtac]. rewrite Zabs_absolu; apply Zlt_le_trans with (1:=L2). rewrite H4; rewrite Zpower_nat_is_exp; auto with zarith. rewrite J1; apply Zle_trans with (-(dExp bo))%Z; auto with zarith. case H2; intros T; elim T; intros T1 T2; elim T1; auto. rewrite H4; rewrite Zpower_nat_is_exp; auto with zarith. rewrite Zabs_Zmult. replace (Zpower_nat radix 1) with (Zabs radix); auto with zarith. apply Zmult_le_compat_l; auto with zarith. rewrite Zabs_absolu; auto. unfold Fplus; simpl. apply Zmin_le2. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. fold FtoRradix; apply Rle_trans with (1*Rabs y)%R;[right; ring|idtac]. apply Rle_trans with (5*Rabs y)%R;[apply Rmult_le_compat_r; auto with real|idtac]. apply Rle_trans with (4+1)%R; auto with real. apply Rle_trans with 2%R; auto with real. apply Rle_trans with 4%R; auto with real. apply Rle_trans with (1:=H); rewrite Rabs_right;[idtac|apply Rle_ge]; auto with real. assert (1 <= Zabs_nat (Fnum (Fplus radix x y)))%Z; auto with zarith. rewrite <- Zabs_absolu. cut (0 < Fnum (Fplus radix x y))%Z; auto with zarith. intros K; rewrite Zabs_eq; auto with zarith. apply LtR0Fnum with radix; auto with zarith. rewrite Fplus_correct; auto with zarith; fold FtoRradix. apply Rplus_lt_reg_r with (-y)%R. ring_simplify. case (Req_dec 0 y); intros K. rewrite <-K; ring_simplify (-0)%R; auto with real. apply Rle_lt_trans with (Rabs (-y))%R; auto with real. apply RRle_abs. rewrite Rabs_Ropp; apply Rlt_le_trans with (2:=H). apply Rle_lt_trans with (1*Rabs y)%R; auto with real. apply Rmult_lt_compat_r. assert (0 <= Rabs y)%R; auto with real. case H6; auto; intros K'. absurd ( Rabs y=0)%R; auto. apply Rabs_no_R0; auto. apply Rlt_le_trans with (4+1)%R;auto with real. apply Rle_lt_trans with 4%R; auto with real. apply Rle_trans with 2%R; auto with real. intros k. exists (Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix k)))) ((Nsucc (Nsucc (dExp bo))))). split; simpl. apply trans_eq with (Z_of_nat (nat_of_P (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix k)))))); auto with zarith. 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 (Zabs_nat (Zpower_nat radix (k))) 0); auto with arith zarith. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. cut (0 < Zabs_nat (Zpower_nat radix k))%Z; auto with zarith. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. case (dExp bo); simpl; auto with zarith. intros; case p0; simpl; auto with zarith. Qed. Theorem AddOddEven_aux: forall (x y f1 f2:float) (z:R), (5* (Rabs y) <= x)%R -> (0 < x)%R -> (5*(firstNormalPos radix bo p) <= x)%R -> (Fcanonic radix bo y) ->(Fcanonic radix bo x) -> (To_Odd bo radix p z y) -> (EvenClosest bo radix p (x+y)%R f1) -> (EvenClosest bo radix p (x+z)%R f2) -> (FtoRradix f1=f2)%R. intros. elim H4; intros. case H8; clear H8; intros H8. generalize EvenClosestUniqueP; unfold UniqueP; intros T. unfold FtoRradix; apply T with bo p (x+z)%R; auto with zarith. rewrite H8; auto with real. elim (AddOddEven_aux_aux x y); auto. intros k T1; elim T1; intros be T2; elim T2; intros xy T3; clear T1 T2. elim T3; intros H8' T4; elim T4; intros H9 T5; elim T5; clear T3 T4 T5. intros H10 T6; elim T6; intros H11 T7; elim T7; intros; clear T6 T7. apply sym_eq. apply trans_eq with (FtoRradix (Fnormalize radix bo p f2)). apply sym_eq; unfold FtoRradix; apply FnormalizeCorrect; auto with zarith. cut (Fbounded bo f2);[intros Ff2|elim H6; intros T1 T2; elim T1; auto]. apply To_Odd_Even_is_Even with bo be p k xy (x+z)%R; auto. elim H12; auto. apply FnormalizeBounded; auto with zarith. apply FnormalizeCanonic; auto with zarith. 2: replace (FtoR 2 xy) with (x+y)%R; auto with real. 2: apply EvenClosestCompatible with (4:=H6); auto with real zarith. 2: apply sym_eq; apply FnormalizeCorrect; auto with zarith. 2: apply FnormalizeBounded; auto with zarith. unfold To_Odd. split;[elim H12; auto|idtac]. right. cut (FNodd be 2 (p + k) xy);[intros Y|idtac]. split; auto. elim H8; intros; case H14; intros. clear H8 H14; elim H16; intros T1 T2; elim T2; clear T1 T2; intros. left; split;[elim H12; auto|split]. fold radix; fold FtoRradix; rewrite H11; auto with real. fold radix; intros f U1 U2. rewrite <- FPredSuc with be radix (p+k) xy; auto with zarith. 2: left; auto. rewrite <- FnormalizeCorrect with radix be (p+k) f; auto with zarith. apply FPredProp; auto with zarith. apply FnormalizeCanonic; auto with zarith. apply FSuccCanonic; auto with zarith; left; auto. rewrite FnormalizeCorrect; auto with zarith. apply Rle_lt_trans with (1:=U2). apply Rplus_lt_reg_r with (-FtoRradix xy)%R. apply Rle_lt_trans with (z-y)%R;[rewrite H11; right; ring|idtac]. apply Rlt_le_trans with (FtoRradix ( Float 1%nat (Fexp y))). apply Rplus_lt_reg_r with (FtoRradix y). apply Rle_lt_trans with z;[right; ring|idtac]. apply Rlt_le_trans with (FSucc bo radix p y). case (Rle_or_lt (FSucc bo radix p y) z); auto; intros U3. absurd ((FSucc bo radix p y <= y))%R. apply Rlt_not_le. unfold FtoRradix; apply FSuccLt; auto with zarith. apply H14; auto. apply FBoundedSuc; auto with zarith. right; apply Rplus_eq_reg_l with (-y)%R. apply trans_eq with (FtoRradix (Fminus radix (FSucc bo radix p y) y)). unfold FtoRradix; rewrite Fminus_correct; auto with zarith; ring. unfold FtoRradix; rewrite FSuccDiff1; auto with zarith. ring. case (Z_eq_dec (Fnum y) (-(nNormMin radix p))%Z); auto; intros K. absurd (FNodd bo radix p y); auto. unfold FNodd; rewrite FcanonicFnormalizeEq; auto with zarith. unfold Fodd; apply EvenNOdd; rewrite K. unfold Even, radix, nNormMin. exists (-(Zpower_nat 2 (pred (pred p))))%Z. apply trans_eq with (-(Zpower_nat 2 (1+(pred (pred p)))))%Z; auto with zarith. replace (1+(pred (pred p))) with (pred p); auto with zarith. rewrite Zpower_nat_is_exp; auto with zarith. replace (Zpower_nat 2 1) with 2%Z; auto with zarith. right; apply trans_eq with (FtoRradix (Fminus radix (FSucc be radix (p+k) xy) xy)). unfold FtoRradix; rewrite FSuccDiff1; auto with zarith real. rewrite H13; auto with real. case (Z_eq_dec (Fnum xy) (-(nNormMin radix (p+k)))%Z); auto; intros K. absurd (FNodd be radix (p+k) xy); auto. unfold FNodd; rewrite FcanonicFnormalizeEq; auto with zarith. 2: left; auto. unfold Fodd; apply EvenNOdd; rewrite K. unfold Even, radix, nNormMin. exists (-(Zpower_nat 2 (pred (pred (p+k)))))%Z. apply trans_eq with (-(Zpower_nat 2 (1+(pred (pred (p+k))))))%Z; auto with zarith. replace (1+(pred (pred (p+k)))) with (pred (p+k)); auto with zarith. rewrite Zpower_nat_is_exp; auto with zarith. replace (Zpower_nat 2 1) with 2%Z; auto with zarith. unfold FtoRradix; rewrite Fminus_correct; auto with zarith; ring. clear H7 H14; elim H16; intros T1 T2; elim T2; clear T1 T2; intros. right; split;[elim H12; auto|split]. fold radix; fold FtoRradix; rewrite H11; auto with real. fold radix; intros f U1 U2. rewrite <- FSucPred with be radix (p+k) xy; auto with zarith. 2: left; auto. rewrite <- FnormalizeCorrect with radix be (p+k) f; auto with zarith. apply FSuccProp; auto with zarith. apply FPredCanonic; auto with zarith; left; auto. apply FnormalizeCanonic; auto with zarith. rewrite FnormalizeCorrect; auto with zarith. apply Rlt_le_trans with (2:=U2). apply Rplus_lt_reg_r with (-FtoRradix xy)%R. apply Rlt_le_trans with (z-y)%R;[idtac|rewrite H11; right; ring]. apply Rle_lt_trans with (-(FtoRradix ( Float 1%nat (Fexp y))))%R. right; apply trans_eq with (-(FtoRradix (Fminus radix xy (FPred be radix (p+k) xy))))%R. unfold FtoRradix; rewrite Fminus_correct; auto with zarith; ring. unfold FtoRradix; rewrite FPredDiff1; auto with zarith real. rewrite H13; auto with real. case (Z_eq_dec (Fnum xy) ((nNormMin radix (p+k)))%Z); auto with zarith; intros K. absurd (FNodd be radix (p+k) xy); auto. unfold FNodd; rewrite FcanonicFnormalizeEq; auto with zarith. 2: left; auto. unfold Fodd; apply EvenNOdd; rewrite K. unfold Even, radix, nNormMin. exists ((Zpower_nat 2 (pred (pred (p+k)))))%Z. apply trans_eq with ((Zpower_nat 2 (1+(pred (pred (p+k))))))%Z; auto with zarith. apply Rplus_lt_reg_r with (FtoRradix y). apply Rlt_le_trans with z;[idtac|right; ring]. apply Rle_lt_trans with (FPred bo radix p y). right; apply Rplus_eq_reg_l with (-y)%R. apply trans_eq with (-(FtoRradix (Fminus radix y (FPred bo radix p y))))%R. unfold FtoRradix; rewrite FPredDiff1; auto with zarith. ring. case (Z_eq_dec (Fnum y) ((nNormMin radix p))%Z); auto; intros K. absurd (FNodd bo radix p y); auto. unfold FNodd; rewrite FcanonicFnormalizeEq; auto with zarith. unfold Fodd; apply EvenNOdd; rewrite K. unfold Even, radix, nNormMin. exists ((Zpower_nat 2 (pred (pred p))))%Z. apply trans_eq with ((Zpower_nat 2 (1+(pred (pred p)))))%Z; auto with zarith. unfold FtoRradix; rewrite Fminus_correct; auto with zarith; ring. case (Rle_or_lt z (FPred bo radix p y)); auto; intros U3. absurd (y <= (FPred bo radix p y))%R. apply Rlt_not_le. unfold FtoRradix; apply FPredLt; auto with zarith. apply H14; auto. apply FBoundedPred; auto with zarith. apply FcanonicBound with radix; auto. elim H8; intros T; clear T;unfold FNodd. rewrite FcanonicFnormalizeEq; auto with zarith. rewrite FcanonicFnormalizeEq; auto with zarith. 2: left; auto. unfold Fodd; unfold Odd; intros T; elim T; intros ny U1. exists (ny+(Fnum x*(Zpower_nat radix (Zabs_nat (Fexp x-Fexp y -1)))))%Z. assert (Fexp (Fplus radix x y)=Fexp y)%Z. unfold Fplus; simpl;apply Zmin_le2. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. fold FtoRradix; apply Rle_trans with (1*Rabs y)%R;[right; ring|idtac]. apply Rle_trans with (5*Rabs y)%R;[apply Rmult_le_compat_r; auto with real|idtac]. apply Rle_trans with (4+1)%R; auto with real. apply Rle_trans with 2%R; auto with real. apply Rle_trans with 4%R; auto with real. apply Rle_trans with (1:=H); rewrite Rabs_right;[idtac|apply Rle_ge]; auto with real. apply trans_eq with (Fnum (Fplus radix x y)). apply eq_IZR. apply Rmult_eq_reg_l with (powerRZ radix (Fexp y)); auto with real zarith. apply trans_eq with (FtoRradix xy); [rewrite <- H13; unfold FtoRradix, FtoR; auto with real|idtac]. rewrite H11; unfold FtoRradix; rewrite <- Fplus_correct; auto with zarith. unfold FtoR; rewrite H14; auto with real. unfold Fplus. replace (Zmin (Fexp x) (Fexp y)) with (Fexp y). replace (Fnum y * Zpower_nat radix (Zabs_nat (Fexp y - Fexp y)))%Z with (Fnum y); auto with zarith. apply trans_eq with (Fnum x * Zpower_nat radix (Zabs_nat (Fexp x - Fexp y)) + Fnum y)%Z; auto with zarith. rewrite U1; ring_simplify. replace (Zabs_nat (Fexp x - Fexp y)) with (1+(Zabs_nat (Fexp x - Fexp y - 1))). rewrite Zpower_nat_is_exp; auto with zarith. replace (Zpower_nat radix 1) with 2%Z; auto with zarith; ring. cut (1 + Zabs_nat (Fexp x - Fexp y - 1) = Zabs_nat (Fexp x - Fexp y))%Z; auto with zarith. cut (0 <= Fexp x-Fexp y -1)%Z;[intros U2|idtac]. repeat rewrite <- Zabs_absolu; repeat rewrite Zabs_eq; auto with zarith. apply Zplus_le_reg_r with (Fexp y+1)%Z. ring_simplify. case H2; intros K. apply Zle_trans with (Fexp (Float (Fnum y) (Fexp y+1)%Z)); auto with zarith. rewrite Zplus_comm; auto with zarith. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. elim K; intros H15 H16; elim H15; intros. left; split;[split|simpl]; auto with zarith. apply Zle_trans with (1:=H18); rewrite Zplus_comm; simpl; auto with zarith. fold FtoRradix; apply Rle_trans with (2*Rabs y)%R. unfold FtoRradix, FtoR; rewrite Zplus_comm; simpl. rewrite powerRZ_add; auto with real zarith. repeat rewrite Rabs_mult. replace (Rabs (powerRZ 2 1)) with 2%R;[right; ring|idtac]. unfold powerRZ; simpl; auto with real. ring_simplify (2*1)%R; rewrite Rabs_right; auto with real; apply Rle_ge; auto with real. apply Rle_trans with (5*Rabs y)%R;[apply Rmult_le_compat_r; auto with real|idtac]. apply Rle_trans with (4+1)%R; auto with real. apply Rle_trans with 4%R; auto with real. apply Rle_trans with (1:=H); rewrite Rabs_right;[idtac|apply Rle_ge]; auto with real. apply Zle_trans with (Fexp (Float (nNormMin radix p) (-(dExp bo)+1))). elim K; intros K1 K2; elim K2; intros K3 K4; rewrite K3. rewrite Zplus_comm; simpl; auto with zarith. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. left; repeat split. simpl; rewrite pGivesBound. rewrite Zabs_eq; auto with zarith. unfold nNormMin in |- *; simpl in |- *; auto with zarith arith. apply Zlt_le_weak; auto with zarith. apply nNormPos; auto with zarith. simpl; auto with zarith. rewrite pGivesBound. pattern p at 1; replace p with (pred p + 1); auto with zarith. rewrite Zabs_Zmult; rewrite Zabs_eq; auto with zarith. rewrite Zabs_eq; auto with zarith. rewrite Zpower_nat_is_exp; auto with zarith. unfold nNormMin in |- *; simpl in |- *; auto with zarith arith. fold FtoRradix; rewrite (Rabs_right x); try apply Rle_ge; auto with real. apply Rle_trans with (2:=H1). rewrite Rabs_right;[idtac| apply Rle_ge; unfold FtoRradix; apply LeFnumZERO; auto with zarith]. 2: simpl; unfold nNormMin; auto with zarith. unfold firstNormalPos, FtoRradix, FtoR; simpl. apply Rle_trans with (nNormMin radix p * (5*powerRZ 2 (- dExp bo)))%R; [apply Rmult_le_compat_l; auto with real zarith|right; ring]. unfold nNormMin; auto with zarith real. rewrite powerRZ_add; auto with real zarith. rewrite Rmult_comm; apply Rmult_le_compat_r; auto with real zarith. simpl; ring_simplify (2*1)%R; apply Rle_trans with 4%R; auto with real. apply Rle_trans with (4+1)%R; auto with real. ring_simplify (Fexp y-Fexp y)%Z; simpl; auto with zarith. unfold Zpower_nat; simpl; auto with zarith. Qed. Theorem AddOddEven_can: forall (x y f1 f2:float) (z:R), (5*(Rabs y) <= Rabs x)%R -> (5*(firstNormalPos radix bo p) <= Rabs x)%R -> Fcanonic radix bo y ->(Fcanonic radix bo x) -> (To_Odd bo radix p z y) -> (EvenClosest bo radix p (x+y)%R f1) -> (EvenClosest bo radix p (x+z)%R f2) -> (FtoRradix f1=f2)%R. intros. case (Rle_or_lt 0%R x). intros T; case T; intros H5'. apply AddOddEven_aux with x y z; auto. rewrite <- (Rabs_right x); auto with real. rewrite <- (Rabs_right x); auto with real. absurd (5 * firstNormalPos radix bo p <= Rabs x)%R; auto. apply Rlt_not_le; rewrite <- H5'. rewrite Rabs_R0. unfold FtoRradix, FtoR, firstNormalPos, nNormMin; simpl. repeat apply Rmult_lt_0_compat; auto with real zarith. apply Rlt_le_trans with (4+1)%R; auto with real. apply Rle_lt_trans with 4%R; auto with real. apply Rle_trans with 2%R; auto with real. intros H5'. apply Rmult_eq_reg_l with (-1)%R; auto with real; ring_simplify. unfold FtoRradix; repeat rewrite <- Fopp_correct; fold FtoRradix. apply AddOddEven_aux with (Fopp x) (Fopp y) (-z)%R. unfold FtoRradix; repeat rewrite Fopp_correct; fold FtoRradix. rewrite Rabs_Ropp; rewrite <- (Rabs_left x); auto with real. unfold FtoRradix; repeat rewrite Fopp_correct; fold FtoRradix; auto with real. unfold FtoRradix; repeat rewrite Fopp_correct; fold FtoRradix; auto with real. rewrite <- (Rabs_left x); auto with real. apply FcanonicFopp; auto. apply FcanonicFopp; auto. generalize To_OddSymmetricP; unfold SymmetricP; intros T; apply T; auto. replace (Fopp x + Fopp y)%R with (-(x+y))%R. generalize EvenClosestSymmetric; unfold SymmetricP; intros T; apply T; auto. unfold FtoRradix; repeat rewrite Fopp_correct; fold FtoRradix; auto with real. replace (Fopp x + -z)%R with (-(x+z))%R. generalize EvenClosestSymmetric; unfold SymmetricP; intros T; apply T; auto. unfold FtoRradix; repeat rewrite Fopp_correct; fold FtoRradix; auto with real. Qed. Theorem AddOddEven: forall (x y f1 f2:float) (z:R), (Fbounded bo x) -> (5*(Rabs y) <= Rabs x)%R -> (5*(firstNormalPos radix bo p) <= Rabs x)%R -> (To_Odd bo radix p z y) -> (EvenClosest bo radix p (x+y)%R f1) -> (EvenClosest bo radix p (x+z)%R f2) -> (FtoRradix f1=f2)%R. intros. apply AddOddEven_can with (Fnormalize radix bo p x) (Fnormalize radix bo p y) z. unfold FtoRradix; repeat rewrite FnormalizeCorrect; auto with real zarith. unfold FtoRradix; rewrite FnormalizeCorrect; auto with real zarith. apply FnormalizeCanonic; auto with zarith; elim H2; auto. apply FnormalizeCanonic; auto with zarith. apply To_OddCompatible with (4:=H2); auto with zarith. rewrite FnormalizeCorrect; auto with real zarith. apply FnormalizeBounded; auto with zarith; elim H2; auto. unfold FtoRradix; repeat rewrite FnormalizeCorrect; auto with real zarith. unfold FtoRradix; rewrite FnormalizeCorrect; auto with real zarith. Qed. Theorem AddOddEven2: forall (x y f1 f2:float) (z:R), (3 < p) -> (6*(Rabs z) <= Rabs x)%R -> (5*(firstNormalPos radix bo p) <= Rabs x)%R -> Fcanonic radix bo y ->(Fcanonic radix bo x) -> (To_Odd bo radix p z y) -> (EvenClosest bo radix p (x+y)%R f1) -> (EvenClosest bo radix p (x+z)%R f2) -> (FtoRradix f1=f2)%R. intros. apply AddOddEven_can with x y z; auto. case H2; intros. apply Rle_trans with (2:=H0). apply Rplus_le_reg_l with (Rabs y-6*Rabs z)%R. apply Rle_trans with (6*(Rabs y -Rabs z))%R;[right; ring|idtac]. assert (0 < 6)%R; auto with real. apply Rlt_le_trans with 2%R; auto with real. apply Rle_trans with 4%R; auto with real. apply Rmult_le_reg_l with (/6)%R; auto with real. apply Rle_trans with (Rabs y - Rabs z)%R;[right; field; auto with real|idtac]. apply Rle_trans with (Rabs (y-z)); [apply Rabs_triang_inv|idtac]. rewrite <- Rabs_Ropp. replace (-(y-z))%R with (z-y)%R;[idtac|ring]. apply Rle_trans with (Fulp bo radix p y). apply Rlt_le; unfold FtoRradix. apply RoundedModeUlp with (To_Odd bo radix p); auto with zarith. apply To_OddRoundedModeP; auto with zarith. apply Rle_trans with (Rabs y * powerRZ radix (Zsucc (- p)))%R. unfold FtoRradix; apply FulpLe2; auto with zarith. elim H7; auto. rewrite FcanonicFnormalizeEq; auto with zarith. apply Rle_trans with ((Rabs y)*/6)%R;[idtac|right; ring]. apply Rmult_le_compat_l; auto with real. apply Rle_trans with (powerRZ radix (Zsucc (-4))); auto with real zarith. apply Rle_powerRZ; auto with zarith real; unfold Zsucc; auto with zarith. unfold Zsucc; simpl. apply Rle_Rinv; auto with real. apply Rle_trans with (6+1)%R; auto with real. apply Rle_trans with (6+2)%R; auto with real. right; ring. apply Rle_trans with (2:=H1). apply Rmult_le_compat_l; auto with real. apply Rle_trans with 2%R; auto with real. apply Rle_trans with 4%R; auto with real. apply Rle_trans with (4+1)%R; auto with real. unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith; apply Rlt_le. apply FsubnormalLtFirstNormalPos; auto with zarith. apply FsubnormFabs; auto with zarith. rewrite Fabs_correct; auto with real zarith. Qed. End Sec1. Section Sec2. Variable bo : Fbound. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Variable p : nat. Hypotheses pGreaterThanOne : (lt (S O) p). Hypotheses pGivesBound : (Zpos (vNum bo)) = (Zpower_nat radix p). Hypotheses pGe : (5 <= p). Variable a b c uh ul th tl v z:float. Hypothesis Fa : Fbounded bo a. Hypothesis Fb : Fbounded bo b. Hypothesis Fc : Fbounded bo c. Hypothesis Fuh: Fbounded bo uh. Hypothesis Ful: Fbounded bo ul. Hypothesis Fth: Fbounded bo th. Hypothesis Ftl: Fbounded bo tl. Hypothesis Fv : Fbounded bo v. Hypothesis Fz : Fbounded bo z. Hypothesis Cth: Fcanonic radix bo th. Hypothesis Cuh: Fcanonic radix bo uh. Hypothesis Ctl: Fcanonic radix bo tl. Hypothesis Cul: Fcanonic radix bo ul. Hypothesis uhDef: (Closest bo radix (a*b)%R uh). Hypothesis ulDef: (FtoRradix ul=a*b-uh)%R. Hypothesis thDef: (Closest bo radix (c+uh)%R th). Hypothesis tlDef: (FtoRradix tl=c+uh-th)%R. Hypothesis vDef: (To_Odd bo radix p (tl+ul)%R v). Hypothesis zDef: (EvenClosest bo radix p (th+v)%R z). Theorem FmaEmulAux: (EvenClosest bo radix p (a*b+c)%R z). case (Req_dec v (tl+ul)); intros Eq1. replace (a*b+c)%R with (th+v)%R; auto with real zarith. rewrite Eq1; rewrite ulDef; rewrite tlDef; ring. generalize EvenClosestTotal; unfold TotalP. intros T; elim T with bo radix p (a*b+c)%R; auto with zarith. clear T; intros z' Hz'. apply EvenClosestCompatible with (4:=Hz'); auto with zarith. apply sym_eq. case (Rle_or_lt (5 *(firstNormalPos 2 bo p)) (Rabs (th)))%R; intros K1. apply AddOddEven with bo p th v (tl+ul)%R; auto with zarith real. fold radix; fold FtoRradix. assert (0 < 5)%R; auto with real. replace 5%R with (INR 5); auto with real zarith. simpl; ring. apply Rmult_le_reg_l with (/5)%R; auto with real. apply Rle_trans with (Rabs v);[right; field; auto with real|idtac]. apply Rle_trans with (2*powerRZ radix (Fexp th))%R. apply Rle_trans with (Float 2%Z (Fexp th)). unfold FtoRradix. apply RoundAbsMonotoner with (precision:=p) (b:=bo) (P:=To_Odd bo radix p) (p:=(tl+ul)%R); auto with zarith real. apply To_OddRoundedModeP; auto with zarith. split; simpl; auto with zarith. rewrite pGivesBound; unfold radix; auto with zarith. apply Zle_lt_trans with (Zpower_nat 2 1); auto with zarith. elim Fth; auto. apply Rle_trans with (1:=Rabs_triang tl ul). apply Rle_trans with (powerRZ radix (Fexp th)+powerRZ radix (Fexp th))%R. apply Rplus_le_compat. apply Rle_trans with (Fulp bo radix p th); [rewrite tlDef|idtac]. unfold FtoRradix; apply Rlt_le; apply RoundedModeUlp with (P:=(Closest bo radix)); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. rewrite CanonicFulp; auto with zarith. unfold FtoR; simpl; right; ring. apply Rle_trans with (powerRZ radix (Fexp uh -1)). apply Rmult_le_reg_l with (INR 2); auto with zarith real. apply Rle_trans with (Fulp bo radix p uh). rewrite ulDef; unfold FtoRradix; apply ClosestUlp; auto with zarith. rewrite CanonicFulp; auto with zarith. replace (INR 2) with (powerRZ radix 1). rewrite <- powerRZ_add; auto with real zarith. ring_simplify (1 + (Fexp uh - 1))%Z; unfold FtoR; simpl; right; ring. simpl; ring. apply Rle_powerRZ; auto with zarith real. case (Zle_or_lt (Fexp uh-1) (Fexp th)); auto with zarith. intros A. assert (Fexp th <= Fexp uh - 2)%Z; auto with zarith. clear A; absurd (FtoRradix tl=0)%R. Contradict Eq1. rewrite Eq1; ring_simplify. unfold FtoRradix; apply sym_eq. apply RoundedModeProjectorIdemEq with bo p (To_Odd bo radix p); auto with zarith. apply To_OddRoundedModeP; auto with zarith. replace (FtoR radix ul) with (tl+ul)%R; auto with real. rewrite Eq1; auto with real. rewrite tlDef. cut (FtoRradix th=c+uh)%R; auto with real. case (Zle_or_lt (Fexp uh) (Fexp c)); intros. unfold FtoRradix; apply plusExact1 with bo p; auto with zarith. rewrite Zmin_le2; auto with zarith. unfold FtoRradix; apply plusExact1 with bo p; auto with zarith. rewrite Zmin_le1; auto with zarith. case (Zle_or_lt (Fexp uh-1) (Fexp c)); intros I1. auto with zarith. cut (Fexp c <= Fexp uh-2)%Z; auto with zarith. clear H1 I1; intros I. absurd (Fexp uh-1 <= Fexp th)%Z; auto with zarith. apply Zle_trans with (Fexp (Float (nNormMin radix p) (Fexp uh -1))). simpl; auto with zarith. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. apply FcanonicNnormMin; auto with zarith. apply Zle_trans with (Fexp th); auto with zarith. elim Fth; auto. rewrite <- Fabs_correct; auto with zarith. replace (Fabs (Float (nNormMin radix p) (Fexp uh - 1))) with (Float (nNormMin radix p) (Fexp uh - 1)). apply RoundAbsMonotonel with (precision:=p) (b:=bo) (P:=Closest bo radix) (p:=(c+uh)%R); auto with zarith real. apply ClosestRoundedModeP with p; auto with zarith. assert (Fnormal radix bo (Float (nNormMin radix p) (Fexp uh - 1))). apply FnormalNnormMin; auto with zarith. apply Zle_trans with (Fexp th); auto with zarith; elim Fth; auto. elim H1; auto. apply Rle_trans with (powerRZ radix (p-2+Fexp uh)). unfold FtoR; simpl; unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. rewrite <- powerRZ_add; auto with zarith real. replace (pred p + (Fexp uh - 1))%Z with (p - 2 + Fexp uh)%Z; auto with real. rewrite inj_pred; auto with zarith; unfold Zpred; ring. apply Rle_trans with (powerRZ radix (p - 1 + Fexp uh) - powerRZ radix (p - 2 + Fexp uh))%R. apply Rplus_le_reg_l with (powerRZ radix (p - 2 + Fexp uh)). apply Rle_trans with (powerRZ radix (p - 1 + Fexp uh));[idtac|right; ring]. apply Rle_trans with (2*(powerRZ radix (p - 2 + Fexp uh)))%R;[right; ring|idtac]. replace 2%R with (powerRZ radix 1);[rewrite <- powerRZ_add|simpl]; auto with real zarith. replace (1 + (p - 2 + Fexp uh))%Z with (p - 1 + Fexp uh)%Z; auto with real; ring. apply Rle_trans with (Rabs uh-Rabs c)%R. unfold Rminus; apply Rplus_le_compat. case Cuh; intros. elim H1; intros H2 H3. unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith. rewrite powerRZ_add; auto with real zarith. unfold 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 (IZR (Zpos (vNum bo))). rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ. unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl; right. field; ring_simplify (2*1)%R; auto with real zarith. apply Rle_trans with (IZR (Zabs (radix * Fnum uh))); auto with real zarith. rewrite Zabs_Zmult; rewrite mult_IZR; repeat rewrite <- Rabs_Zabs. rewrite Rabs_right; auto with real zarith. apply Rle_ge; auto with real zarith. elim H1; intros H2 H3. elim H3; intros H4 H5. absurd (Fexp c <= (- dExp bo) - 2)%Z; auto with zarith. elim Fc; auto with zarith. apply Ropp_le_contravar. unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith. apply Rlt_le; apply Rlt_le_trans with (FtoR radix (Float (Zpos (vNum bo)) (Fexp uh - 2)))%R. apply maxMax;auto with zarith. right; unfold FtoR; rewrite pGivesBound; simpl; rewrite Zpower_nat_Z_powerRZ. rewrite <- powerRZ_add; auto with real zarith. replace (p + (Fexp uh - 2))%Z with (p - 2 + Fexp uh)%Z; auto with real zarith. replace (c+uh)%R with (uh - (-c))%R;[idtac|ring]. rewrite <- (Rabs_Ropp c); apply Rabs_triang_inv. unfold Fabs; simpl. rewrite Zabs_eq; auto with zarith float. apply Zlt_le_weak; apply nNormPos; auto with zarith. unfold FtoR; simpl; right; ring. unfold FtoRradix, FtoR; simpl; right; ring. apply Rmult_le_reg_l with 5%R; auto with real. apply Rle_trans with (10* powerRZ radix (Fexp th))%R;[right; ring|idtac]. apply Rle_trans with (Rabs th);[idtac|right; field; auto with real]. unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith. unfold Fabs, FtoR; simpl; apply Rmult_le_compat_r; auto with real zarith. replace 10%R with (IZR 10); auto with zarith real. apply Rle_IZR. 2: simpl; auto with zarith real; ring. elim Cth; intros H'. elim H'; intros H1 H2. apply Zmult_le_reg_r with radix; auto with zarith. apply Zlt_gt; auto with zarith. apply Zle_trans with (Zpos (vNum bo)). rewrite pGivesBound. apply Zle_trans with (Zpower_nat radix 5); auto with zarith. apply Zle_trans with (1:=H2); rewrite Zabs_Zmult; auto with zarith. absurd (Rabs th < firstNormalPos 2 bo p)%R. apply Rle_not_lt. apply Rle_trans with (2:=K1). apply Rle_trans with (1*(firstNormalPos 2 bo p))%R;[right; ring|idtac]. apply Rmult_le_compat_r; auto with real zarith. unfold firstNormalPos, FtoRradix; apply LeFnumZERO; auto with zarith. simpl; apply Zlt_le_weak; apply nNormPos; auto with zarith. apply Rle_trans with 2%R; auto with real. apply Rle_trans with 4%R; auto with real. apply Rle_trans with (4+1)%R; auto with real. unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith. apply FsubnormalLtFirstNormalPos ; auto with zarith. apply FsubnormFabs; auto with zarith. rewrite Fabs_correct; auto with real zarith. replace (FtoR 2 th + (tl + ul))%R with (a*b+c)%R; auto. fold radix; fold FtoRradix; rewrite tlDef; rewrite ulDef; ring. assert (Fsubnormal radix bo tl). case Ctl; auto; intros. absurd (firstNormalPos 2 bo p <= Rabs tl)%R. apply Rlt_not_le. apply Rlt_le_trans with (Fulp bo radix p th). rewrite tlDef; unfold FtoRradix. apply RoundedModeUlp with (Closest bo radix); auto with zarith. apply ClosestRoundedModeP with p; auto with zarith. rewrite CanonicFulp; auto with zarith. unfold firstNormalPos, FtoRradix, FtoR; simpl. unfold nNormMin; rewrite Zpower_nat_Z_powerRZ. ring_simplify (1 * powerRZ 2 (Fexp th))%R; rewrite <- powerRZ_add; auto with real zarith. apply Rle_powerRZ; auto with real zarith. apply Zle_trans with (Fexp (Float (nNormMin radix p) (-dExp bo+3))). apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. apply FcanonicNnormMin; auto with zarith. apply Rlt_le; apply Rlt_le_trans with (1:=K1). rewrite <- Fabs_correct; auto with zarith;unfold firstNormalPos. unfold Fabs, FtoRradix, FtoR; simpl. rewrite Zabs_eq; auto with zarith float. rewrite powerRZ_add; auto with zarith real. apply Rle_trans with ((powerRZ 2 3) * (nNormMin 2 p * powerRZ 2 (- dExp bo)))%R. apply Rmult_le_compat_r; auto with real zarith. apply Rmult_le_pos; auto with real zarith. generalize nNormPos; auto with real zarith. simpl; auto with real. apply Rle_trans with (5+3)%R; auto with real. apply Rle_trans with (5+0)%R; auto with real. assert (0 <= 3)%R; auto with real. apply Rle_trans with 2%R; auto with real. right; ring. right; simpl;unfold radix;ring. apply Zlt_le_weak; apply nNormPos; auto with real zarith. simpl; rewrite inj_pred; auto with zarith; unfold Zpred; auto with zarith. unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith. apply FnormalLtFirstNormalPos; auto with zarith. apply FnormalFabs; auto with zarith. rewrite Fabs_correct; auto with zarith real. case Cul; intros. absurd (FtoRradix tl=0)%R. Contradict Eq1. rewrite Eq1; ring_simplify. unfold FtoRradix; apply sym_eq. apply RoundedModeProjectorIdemEq with bo p (To_Odd bo radix p); auto with zarith. apply To_OddRoundedModeP; auto with zarith. replace (FtoR radix ul) with (tl+ul)%R; auto with real. rewrite Eq1; auto with real. rewrite tlDef. cut (FtoRradix th=uh+c)%R; auto with real. intros A; rewrite A; ring. unfold FtoRradix; apply plusExact2 with bo p; auto with zarith real. rewrite Rplus_comm; auto with real. cut (Fnormal radix bo th);[intros H1|idtac]. apply Zlt_powerRZ with radix; auto with zarith real. apply Rle_lt_trans with (Rabs th*powerRZ radix (1-p))%R. apply Rmult_le_reg_l with (powerRZ radix (p-1)); auto with real zarith. apply Rle_trans with (Rabs th). unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith. unfold Fabs, FtoR; simpl. apply Rmult_le_compat_r; auto with real zarith. elim H1; intros. apply Rmult_le_reg_l with (IZR radix); auto with zarith real. apply Rle_trans with (Zpos (vNum bo));[rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ|idtac]. unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl; right; field. ring_simplify (2*1)%R; auto with real. apply Rle_trans with (IZR (Zabs (radix * Fnum th))); auto with zarith real. rewrite Zabs_Zmult; rewrite Zabs_eq; auto with zarith; rewrite mult_IZR; auto with real. right; apply trans_eq with (Rabs th * (powerRZ radix (1 - p)* powerRZ radix (p - 1)))%R;[idtac|ring]. rewrite <- powerRZ_add; auto with real zarith. ring_simplify (1 - p + (p - 1))%Z; simpl; ring. apply Rlt_le_trans with ((5 * firstNormalPos 2 bo p)*powerRZ radix (1 - p))%R; auto with real zarith. apply Rle_trans with (firstNormalPos 2 bo p). apply Rle_trans with ((5*powerRZ radix (1 - p))* firstNormalPos 2 bo p)%R;[right; ring|idtac]. apply Rle_trans with (1* firstNormalPos 2 bo p)%R;[idtac|right; ring]. apply Rmult_le_compat_r; auto with real zarith. unfold FtoRradix; apply LeFnumZERO; auto with zarith. unfold firstNormalPos; simpl; auto with zarith. unfold nNormMin; auto with zarith. apply Rle_trans with (powerRZ radix 3 * powerRZ radix (1 - p))%R. apply Rmult_le_compat_r; auto with real zarith; simpl; auto with real. apply Rle_trans with (5+3)%R;[idtac|right; ring]. apply Rle_trans with (5+2)%R; auto with real. apply Rle_trans with (5+1)%R; auto with real. rewrite <- powerRZ_add; auto with real zarith. apply Rle_trans with (powerRZ radix 0); auto with real zarith. apply Rle_trans with (Fabs ul). unfold FtoRradix; apply FnormalLtFirstNormalPos; auto with zarith. apply FnormalFabs; auto with zarith. rewrite Fabs_correct; auto with real zarith. apply Rmult_le_reg_l with (INR 2); auto with real zarith. unfold FtoRradix; rewrite Fabs_correct; auto with zarith. fold FtoRradix; rewrite ulDef; apply Rle_trans with (Fulp bo radix p uh). unfold FtoRradix; apply ClosestUlp; auto with zarith. rewrite CanonicFulp; auto with zarith. right; unfold FtoR; simpl. unfold Zpred, Zminus; rewrite powerRZ_add; auto with real zarith. simpl; field. ring_simplify (2*1)%R; auto with real. case Cth; auto. intros I; assert (FtoRradix tl=0)%R. rewrite tlDef. assert (FtoRradix th=c+uh)%R; auto with real. unfold FtoRradix; apply plusExact1 with bo p; auto with zarith. elim Fc; elim Fuh; intros. elim I; intros I1 I2; elim I2; intros. rewrite H5; apply Zmin_Zle; auto with zarith. absurd (FtoRradix v=tl+ul)%R; auto with real. rewrite H1; ring_simplify. unfold FtoRradix; apply sym_eq. apply RoundedModeProjectorIdemEq with bo p (To_Odd bo radix p); auto with zarith. apply To_OddRoundedModeP; auto with zarith. replace (FtoR radix ul) with (tl+ul)%R; auto with real. rewrite H1; fold FtoRradix; ring. absurd (FtoRradix v = tl + ul)%R; auto with real. unfold FtoRradix; apply plusExactSub with bo p (To_Odd bo radix p); auto with zarith. apply To_OddRoundedModeP; auto with zarith. Qed. End Sec2. Section Sec3. Variable bo : Fbound. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Variable p : nat. Hypotheses pGivesBound : (Zpos (vNum bo)) = (Zpower_nat radix p). Hypotheses pGe : (5 <= p). Variable a b c uh ul th tl v z:float. Hypothesis Fa : Fbounded bo a. Hypothesis Fb : Fbounded bo b. Hypothesis Fc : Fbounded bo c. Hypothesis Ful: Fbounded bo ul. Hypothesis uhDef: (Closest bo radix (a*b)%R uh). Hypothesis ulDef: (FtoRradix ul=a*b-uh)%R. Hypothesis thDef: (Closest bo radix (c+uh)%R th). Hypothesis tlDef: (FtoRradix tl=c+uh-th)%R. Hypothesis vDef: (To_Odd bo radix p (tl+ul)%R v). Hypothesis zDef: (EvenClosest bo radix p (th+v)%R z). Theorem FmaEmul: (EvenClosest bo radix p (a*b+c)%R z). elim errorBoundedPlus with bo radix p c uh th; auto with zarith. 2: elim uhDef; auto. intros tl' T; elim T; intros H1 T'; elim T'; intros H2 H3; clear T T'. apply FmaEmulAux with (Fnormalize radix bo p uh) (Fnormalize radix bo p ul) (Fnormalize radix bo p th) (Fnormalize radix bo p tl') v; auto with zarith. apply FnormalizeBounded; elim uhDef; auto with zarith. apply FnormalizeBounded; auto with zarith. apply FnormalizeBounded; elim thDef; auto with zarith. elim zDef; intros A1 A2; elim A1; auto. apply FnormalizeCanonic; auto with zarith; elim thDef; auto. apply FnormalizeCanonic; auto with zarith; elim uhDef; auto. apply FnormalizeCanonic; auto with zarith. apply FnormalizeCanonic; auto with zarith. apply ClosestCompatible with (1:=uhDef); auto with real. rewrite FnormalizeCorrect; auto with real zarith. apply FnormalizeBounded; elim uhDef; auto with zarith. repeat rewrite FnormalizeCorrect; auto with real zarith. apply ClosestCompatible with (1:=thDef); auto with real. rewrite FnormalizeCorrect; auto with real zarith. rewrite FnormalizeCorrect; auto with real zarith. apply FnormalizeBounded; elim thDef; auto with zarith. repeat rewrite FnormalizeCorrect; auto with real zarith. repeat rewrite FnormalizeCorrect; auto with real zarith. rewrite H1; fold FtoRradix; rewrite <- tlDef; auto. repeat rewrite FnormalizeCorrect; auto with real zarith. Qed. End Sec3. Section Sec4. Variables b be : Fbound. Variables p k : nat. Variables y z v: float. Variables x : R. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Theorem Zpos_eq_eq: forall (a b:positive), (Zpos a=Zpos b) -> a=b. intros f. induction f; intros g. elim g; intros; auto with zarith. replace p0 with f; auto. apply IHf; auto with zarith. repeat rewrite Zpos_xI in H0; auto with zarith. rewrite Zpos_xI in H0. rewrite (Zpos_xO p0) in H0; auto with zarith. absurd (2 * Zpos f + 1 = 2 * Zpos p0)%Z; auto with zarith. absurd (Zpos (xI f) = 1)%Z; auto with zarith. elim g; intros; auto with zarith. rewrite Zpos_xI in H0. rewrite (Zpos_xO f) in H0; auto with zarith. absurd (2 * Zpos f = 2 * Zpos p0 +1)%Z; auto with zarith. replace p0 with f; auto. apply IHf; auto with zarith. rewrite (Zpos_xO f) in H0; rewrite (Zpos_xO p0) in H0; auto with zarith. absurd (Zpos (xO f) = 1)%Z; auto with zarith. elim g; intros; auto with zarith. absurd (1 = Zpos (xI p0))%Z; auto with zarith. absurd (1 = Zpos (xO p0))%Z; auto with zarith. Qed. Hypotheses pGreaterThanOne : (lt (S O) p). Hypotheses kGreaterThanOne : (le O k). Hypotheses pGivesBound : (Zpos (vNum b)) = (Zpower_nat radix p). Hypotheses pkGivesBounde : (Zpos (vNum be)) = (Zpower_nat radix (plus p k)). Hypothesis Cy: (Fcanonic radix be y). Hypothesis Cz: (Fcanonic radix b z). Hypotheses ydef : (To_Odd be radix (plus p k) x y). Hypotheses zdef : (To_Odd b radix p y z). Hypotheses vdef : (To_Odd b radix p x v). Hypotheses rangeext: (-(dExp be) = ( -k-(dExp b)))%Z. Theorem FevenMakesFNeven: forall b:Fbound, forall p:nat, forall f g:float, Zpos (vNum b) = Zpower_nat radix p -> (0 < p) -> Fbounded b g -> Fbounded b f -> Feven g -> FtoRradix g=f -> FNeven b radix p f. intros. unfold FNeven. replace (Fnormalize radix b0 p0 f) with (Fnormalize radix b0 p0 g). elim H2; intros n Hn. unfold Fnormalize, Feven. case (Z_zerop (Fnum g)); intros. simpl; unfold Even; exists 0%Z; auto with zarith. unfold Fshift; simpl. apply EvenMult1; auto. apply FcanonicUnique with radix b0 p0; auto with zarith. apply FnormalizeCanonic; auto with zarith. apply FnormalizeCanonic; auto with zarith. repeat rewrite FnormalizeCorrect; auto with real zarith. Qed. Theorem To_Odd_Odd_is_Odd: ((FtoRradix v)=(FtoRradix z))%R. case (Zle_lt_or_eq 0 k); auto with zarith; intros J1. generalize To_OddUniqueP; unfold UniqueP; intros T. unfold FtoRradix; apply sym_eq; apply T with b p x; auto with zarith. clear T; split; auto. elim zdef; auto. elim zdef; intros; elim ydef; intros. case H0; case H2; clear H H0 H1 H2; fold FtoRradix; intros. left; rewrite H; auto with real. case Cy; intros. absurd (FNeven be radix (p+k) y). apply FnOddNEven; elim H; auto. apply FevenMakesFNeven with (Float (Fnum z*Zpower_nat radix k) (Fexp z-k)); auto with zarith. elim zdef; intros T1 T2; elim T1; clear T1 T2; intros. split; simpl; auto with zarith. rewrite pkGivesBounde; rewrite Zpower_nat_is_exp. rewrite Zabs_Zmult; rewrite (Zabs_eq (Zpower_nat radix k)); auto with zarith. apply Zmult_lt_compat_r; auto with zarith. elim H1; auto. unfold Feven; simpl. apply EvenMult2; auto. unfold Even; exists (Zpower_nat radix (pred k)). pattern k at 1; replace k with (1+pred k); auto with zarith. rewrite H0; unfold FtoRradix, FtoR; simpl. rewrite mult_IZR; rewrite Zpower_nat_Z_powerRZ. rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with real zarith. ring_simplify (k+(Fexp z-k))%Z; auto with real. absurd (FNeven be radix (p+k) y). apply FnOddNEven; elim H; auto. unfold FNeven; rewrite FcanonicFnormalizeEq; auto with zarith. unfold Feven. cut (0 < Fexp z+dExp be)%Z;[intros J2|idtac]. replace (Fnum y) with ((Fnum z)*Zpower_nat radix (Zabs_nat (Fexp z+dExp be)))%Z. apply EvenMult2. replace (Zabs_nat (Fexp z + dExp be)) with (1+Zabs_nat (-1+Fexp z + dExp be)). rewrite Zpower_nat_is_exp. apply EvenMult1; simpl; unfold Even; auto with zarith. unfold Zpower_nat; exists 1%Z; simpl; ring. assert (1 + Zabs_nat (-1 + Fexp z + dExp be) = Zabs_nat (Fexp z + dExp be))%Z; auto with zarith. repeat rewrite <- Zabs_absolu. repeat rewrite Zabs_eq; auto with zarith. apply eq_IZR; rewrite mult_IZR. rewrite Zpower_nat_powerRZ_absolu; auto with zarith. apply trans_eq with (z*powerRZ radix (dExp be))%R. repeat rewrite powerRZ_add; auto with real zarith. unfold FtoRradix, FtoR; ring. rewrite <- H0; elim H1; intros T1 T2; elim T2; intros J3 T4; clear T1 T2 T4. unfold FtoRradix, FtoR; rewrite J3. rewrite Rmult_assoc; rewrite <- powerRZ_add; auto with real zarith. ring_simplify (- dExp be + dExp be)%Z; simpl; auto with real. elim zdef; intros T1 T2; elim T1; intros; auto with zarith. elim H0; intros; rewrite H. right; split; auto. elim H0 ; elim H; clear H0 H; intros. right; split; auto. cut (MinOrMax radix b x z); auto. apply DblRndStable with be (p+k) p y; auto with zarith. rewrite inj_plus; ring_simplify (p+k-p)%Z; auto with zarith. elim ydef; auto. elim zdef; auto. apply trans_eq with (FtoRradix y). generalize To_OddUniqueP; unfold UniqueP; intros T. unfold FtoRradix; apply sym_eq; apply T with b p x; auto with zarith. replace p with (p+k); auto with zarith. replace b with be; auto. clear T; destruct b; destruct be; auto. replace vNum0 with vNum. replace dExp0 with dExp; auto with zarith. generalize rangeext; simpl; rewrite <- J1; auto with zarith. intros; cut (Z_of_N dExp=dExp0)%Z; auto with zarith. unfold Z_of_N; case (dExp);case (dExp0); auto with zarith. intros; absurd (0%Z = Zpos p0)%Z; auto with zarith. intros; absurd (Zpos p0 = 0%Z)%Z; auto with zarith. intros; auto with zarith. replace p0 with p1; auto with zarith. apply Zpos_eq_eq; auto with zarith. generalize pGivesBound; generalize pkGivesBounde; simpl; auto with zarith. replace (p+k) with p; auto with zarith. intros; apply Zpos_eq_eq; auto with zarith. unfold FtoRradix; apply RoundedModeProjectorIdemEq with b p (To_Odd b radix p); auto with zarith. apply To_OddRoundedModeP; auto with zarith. elim ydef; intros. clear H0; elim H; intros. split; auto with zarith. apply Zlt_le_trans with (1:=H0); rewrite pGivesBound ; rewrite pkGivesBounde; auto with zarith. Qed. End Sec4. Section Sec5. Variable bo : Fbound. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Variable p : nat. Hypotheses pGreaterThanOne: (lt (S O) p). Hypotheses pGivesBound : (Zpos (vNum bo)) = (Zpower_nat radix p). Hypotheses dExpBig : (p <= dExp bo)%Z. Theorem AddOddOdd_aux_aux: forall (x y:float), (2* (Rabs y) <= x)%R -> (0 < x)%R -> (2*(firstNormalPos radix bo p) <= x)%R -> (Fcanonic radix bo y) ->(Fcanonic radix bo x) -> (exists k:nat, exists be:Fbound, exists xy:float, (0 <= k) /\ (Zpos (vNum be)) = (Zpower_nat radix (p+k)) /\ (- dExp be = -k - dExp bo)%Z /\ (FtoRradix xy =x+y)%R /\ (Fnormal radix be xy) /\ (Fexp xy=Fexp y)). intros. cut (forall k:nat, exists bb:Fbound, Zpos (vNum bb) = Zpower_nat radix k /\ (- dExp bb = -k +p - dExp bo)%Z). intros L1. exists ((FNI radix 1 (Zabs_nat (Fnum (Fplus radix x y))))+1-p). elim L1 with (1+FNI radix 1 (Zabs_nat (Fnum (Fplus radix x y)))). intros bb T; elim T; intros; clear T L1. exists bb. exists (Fplus radix x y). cut (1 <= Zabs_nat (Fnum (Fplus radix x y)));[intros L1|idtac]. generalize (FNIMore radix); intros T; lapply T; auto with zarith; clear T; intros T. lapply (T (Zabs_nat (Fnum (Fplus radix x y))) 1); auto with zarith. clear T; intros T; lapply T; auto; clear T; intros L2. cut (Zabs_nat (Fnum (Fplus radix x y)) < radix * (Zpower_nat radix (FNI radix 1 (Zabs_nat (Fnum (Fplus radix x y))))))%Z; [clear L2; intros L2| apply Zlt_le_trans with (1:=L2)]. 2:apply Zmult_le_compat_l; simpl; auto with zarith. generalize (FNILess radix); intros T; lapply T; auto with zarith; clear T; intros T. lapply (T 1 (Zabs_nat (Fnum (Fplus radix x y)))); auto with zarith. clear T; intros T; lapply T; auto; clear T; intros L3. cut (Zpower_nat radix (FNI radix 1 (Zabs_nat (Fnum (Fplus radix x y)))) <= Zabs_nat (Fnum (Fplus radix x y)))%Z; [clear L3; intros L3| apply Zle_trans with (2:=L3)]. 2: simpl; auto with zarith. cut (Fexp (Fplus radix x y) = Fexp y);[intros J1|idtac]. assert (p-2 < FNI radix 1 (Zabs_nat (Fnum (Fplus radix x y)))). case H2; intros J2. apply Zpower_nat_anti_monotone_lt with radix; auto with zarith. apply Zmult_lt_reg_r with radix; auto with zarith. apply Zle_lt_trans with (Zabs_nat (Fnum (Fplus radix x y))) ; auto with zarith. 2: apply Zlt_le_trans with (1:=L2); auto with zarith. apply Zle_Rle; rewrite mult_IZR. apply Rmult_le_reg_l with (powerRZ radix (Fexp (Fplus radix x y))); auto with real zarith. apply Rle_trans with (Rabs (x+y))%R. rewrite J1; apply Rle_trans with (Rabs x -Rabs y)%R. apply Rplus_le_reg_l with (Rabs y). ring_simplify (Rabs y + (Rabs x - Rabs y))%R. apply Rle_trans with (2*Rabs y)%R. apply Rle_trans with ((Rabs y)+Rabs y)%R;[apply Rplus_le_compat_l|right; ring]. unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith; unfold Fabs, FtoR. simpl. apply Rle_trans with ((powerRZ 2 (Fexp y)*(Zabs (Fnum y))))%R; [idtac|right; ring]. apply Rmult_le_compat_l; auto with real zarith. elim J2; intros. apply Rmult_le_reg_l with (IZR radix); auto with real zarith. apply Rle_trans with (IZR (Zpower_nat radix p));[right|idtac]. pattern p at 2; replace p with (S (S (p-2))); auto with zarith. rewrite Zpower_nat_S; rewrite Zpower_nat_S. rewrite mult_IZR; rewrite mult_IZR; simpl; ring. rewrite <- pGivesBound; rewrite Zabs_Zmult in H7. rewrite Zabs_eq in H7; auto with real zarith. apply Rle_trans with (IZR (radix * Zabs (Fnum y))); auto with real zarith. rewrite mult_IZR; simpl; auto with zarith real. rewrite Rabs_right with x; [idtac|apply Rle_ge];auto with real. rewrite <- Rabs_Ropp with x. apply Rle_trans with (Rabs (-x-y))%R. apply Rabs_triang_inv. replace (-x-y)%R with (-(x+y))%R; [rewrite Rabs_Ropp;auto with real|ring]. unfold FtoRradix; rewrite <- Fplus_correct; auto with zarith. rewrite <- Fabs_correct; auto with zarith; unfold FtoR, Fabs; simpl; right; ring_simplify. rewrite Zabs_absolu; ring. apply Zpower_nat_anti_monotone_lt with radix; auto with zarith. apply Zmult_lt_reg_r with radix; auto with zarith. apply Zle_lt_trans with (Zabs_nat (Fnum (Fplus radix x y))) ; auto with zarith. 2: apply Zlt_le_trans with (1:=L2); auto with zarith. apply Zle_Rle; rewrite mult_IZR. apply Rmult_le_reg_l with (powerRZ radix (Fexp (Fplus radix x y))); auto with real zarith. apply Rle_trans with (Rabs (x+y))%R. rewrite J1; apply Rle_trans with (Rabs x -Rabs y)%R. apply Rplus_le_reg_l with (Rabs y). ring_simplify (Rabs y + (Rabs x - Rabs y))%R. rewrite (Rabs_right x);[idtac| apply Rle_ge; auto with real]. apply Rle_trans with (2:=H1). apply Rle_trans with (firstNormalPos radix bo p +firstNormalPos radix bo p)%R; [idtac|right; ring]. assert ((Fabs y) <= firstNormalPos radix bo p)%R. apply Rlt_le; unfold FtoRradix. apply FsubnormalLtFirstNormalPos; auto with zarith. apply FsubnormFabs; auto with zarith. rewrite Fabs_correct; auto with real zarith. apply Rplus_le_compat. unfold FtoRradix; rewrite <- Fabs_correct; auto with real zarith. elim J2; intros T1 T2; elim T2; intros T3 T4; rewrite T3. right; unfold firstNormalPos, nNormMin, FtoRradix, FtoR; simpl. replace (pred p) with (S (p-2)); auto with zarith. rewrite Zpower_nat_S; rewrite mult_IZR; simpl; ring. rewrite <- Rabs_Ropp with x. apply Rle_trans with (Rabs (-x-y))%R. apply Rabs_triang_inv. replace (-x-y)%R with (-(x+y))%R; [rewrite Rabs_Ropp;auto with real|ring]. unfold FtoRradix; rewrite <- Fplus_correct; auto with zarith. rewrite <- Fabs_correct; auto with zarith; unfold FtoR, Fabs; simpl; right. rewrite Zabs_absolu; ring. split; auto with zarith. split;[rewrite H4; auto with zarith|idtac]. split. rewrite H5; auto with zarith. rewrite inj_plus; auto with zarith. replace (Z_of_nat (FNI radix 1 (Zabs_nat (Fnum (Fplus radix x y))) + 1 - p)) with ((FNI radix 1 (Zabs_nat (Fnum (Fplus radix x y))) + 1 - p))%Z; auto with zarith. replace 1%Z with (Z_of_nat (S O))%Z; auto with zarith. assert (p+(FNI radix 1 (Zabs_nat (Fnum (Fplus radix x y))) + 1 - p)%Z = (p+(FNI radix 1 (Zabs_nat (Fnum (Fplus radix x y))) + 1 - p)%nat))%Z; auto with zarith. apply trans_eq with (Z_of_nat ((p + ((FNI radix 1 (Zabs_nat (Fnum (Fplus radix x y))) + 1) - p)))); auto with zarith. rewrite <- le_plus_minus; auto with zarith. rewrite inj_plus; auto with zarith. simpl; ring. rewrite inj_plus; auto with zarith. split;[unfold FtoRradix; rewrite Fplus_correct; auto with real zarith|idtac]. split; auto. split;[split|idtac]. rewrite Zabs_absolu; apply Zlt_le_trans with (1:=L2). rewrite H4; rewrite Zpower_nat_is_exp; auto with zarith. rewrite J1; apply Zle_trans with (-(dExp bo))%Z; auto with zarith. rewrite H5; auto with zarith. assert (- (1 + FNI radix 1 (Zabs_nat (Fnum (Fplus radix x y))))%nat + p <= 0)%Z; auto with zarith. rewrite inj_plus; auto with zarith. replace (Z_of_nat (S O)) with 1%Z; auto with zarith. case H2; intros T; elim T; intros T1 T2; elim T1; auto. rewrite H4; rewrite Zpower_nat_is_exp; auto with zarith. rewrite Zabs_Zmult. replace (Zpower_nat radix 1) with (Zabs radix); auto with zarith. apply Zmult_le_compat_l; auto with zarith. rewrite Zabs_absolu; auto. unfold Fplus; simpl. apply Zmin_le2. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. fold FtoRradix; apply Rle_trans with (1*Rabs y)%R;[right; ring|idtac]. apply Rle_trans with (2*Rabs y)%R;[apply Rmult_le_compat_r; auto with real|idtac]. apply Rle_trans with (1:=H); rewrite Rabs_right;[idtac|apply Rle_ge]; auto with real. assert (1 <= Zabs_nat (Fnum (Fplus radix x y)))%Z; auto with zarith. rewrite <- Zabs_absolu. cut (0 < Fnum (Fplus radix x y))%Z; auto with zarith. intros K; rewrite Zabs_eq; auto with zarith. apply LtR0Fnum with radix; auto with zarith. rewrite Fplus_correct; auto with zarith; fold FtoRradix. apply Rplus_lt_reg_r with (-y)%R. ring_simplify. case (Req_dec 0 y); intros K. rewrite <-K; ring_simplify (-0)%R; auto with real. apply Rle_lt_trans with (Rabs (-y))%R; auto with real. apply RRle_abs. rewrite Rabs_Ropp; apply Rlt_le_trans with (2:=H). apply Rle_lt_trans with (1*Rabs y)%R; auto with real. apply Rmult_lt_compat_r; auto with real. assert (0 <= Rabs y)%R; auto with real. case H6; auto; intros K'. absurd ( Rabs y=0)%R; auto. apply Rabs_no_R0; auto. intros k. case (Zle_lt_or_eq 0 (k-p+dExp bo)); auto with zarith; intros. exists (Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix k)))) (Npos (P_of_succ_nat (pred (Zabs_nat (k-p+ (dExp bo))))))). split; simpl. apply trans_eq with (Z_of_nat (nat_of_P (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix k)))))); auto with zarith. 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 (Zabs_nat (Zpower_nat radix (k))) 0); auto with arith zarith. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. cut (0 < Zabs_nat (Zpower_nat radix k))%Z; auto with zarith. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. cut (Zpos (P_of_succ_nat (pred (Zabs_nat (k - p + dExp bo)))) = -(-k+p-dExp bo))%Z; auto with zarith. intros V; apply trans_eq with (-( Zpos(P_of_succ_nat (pred (Zabs_nat (k - p + dExp bo))))))%Z; auto with zarith. apply trans_eq with (k-p+dExp bo)%Z; auto with zarith. apply trans_eq with (Z_of_nat (nat_of_P (P_of_succ_nat (pred (Zabs_nat (k-p+dExp bo)))))); auto with zarith. 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 (Zabs_nat (k-p+dExp bo)) 0); auto with arith zarith. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. cut (0 < Zabs_nat (k-p+dExp bo))%Z; auto with zarith. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. exists (Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix k)))) N0). split; simpl. apply trans_eq with (Z_of_nat (nat_of_P (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix k)))))); auto with zarith. 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 (Zabs_nat (Zpower_nat radix (k))) 0); auto with arith zarith. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. cut (0 < Zabs_nat (Zpower_nat radix k))%Z; auto with zarith. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. auto with zarith. Qed. Theorem AddOddOdd_aux: forall (x y f1 f2:float) (z:R), (2* (Rabs y) <= x)%R -> (0 < x)%R -> (2*(firstNormalPos radix bo p) <= x)%R -> (Fcanonic radix bo y) ->(Fcanonic radix bo x) -> (To_Odd bo radix p z y) -> (To_Odd bo radix p (x+y)%R f1) -> (To_Odd bo radix p (x+z)%R f2) -> (FtoRradix f1=f2)%R. intros. elim H4; intros. case H8; clear H8; intros H8. generalize To_OddUniqueP; unfold UniqueP; intros T. unfold FtoRradix; apply T with bo p (x+z)%R; auto with zarith. rewrite H8; auto with real. elim (AddOddOdd_aux_aux x y); auto. intros k T1; elim T1; intros be T2; elim T2; intros xy T3; clear T1 T2. elim T3; intros H8' T4; elim T4; intros H9 T5; elim T5; clear T3 T4 T5. intros H10 T6; elim T6; intros H11 T7; elim T7; intros; clear T6 T7. apply sym_eq. apply trans_eq with (FtoRradix (Fnormalize radix bo p f1)). 2: unfold FtoRradix; apply FnormalizeCorrect; auto with zarith. cut (Fbounded bo f1);[intros Ff1|elim H5; intros T1 T2; elim T1; auto]. apply To_Odd_Odd_is_Odd with bo be p k xy (x+z)%R; auto. left; auto. apply FnormalizeCanonic; auto with zarith. 2: replace (FtoR 2 xy) with (x+y)%R; auto with real. 2: apply To_OddCompatible with (4:=H5); auto with real zarith. 2: apply sym_eq; apply FnormalizeCorrect; auto with zarith. 2: apply FnormalizeBounded; auto with zarith. unfold To_Odd. split;[elim H12; auto|idtac]. right. cut (FNodd be 2 (p + k) xy);[intros Y|idtac]. split; auto. elim H8; intros; case H14; intros. clear H8 H14; elim H16; intros T1 T2; elim T2; clear T1 T2; intros. left; split;[elim H12; auto|split]. fold radix; fold FtoRradix; rewrite H11; auto with real. fold radix; intros f U1 U2. rewrite <- FPredSuc with be radix (p+k) xy; auto with zarith. 2: left; auto. rewrite <- FnormalizeCorrect with radix be (p+k) f; auto with zarith. apply FPredProp; auto with zarith. apply FnormalizeCanonic; auto with zarith. apply FSuccCanonic; auto with zarith; left; auto. rewrite FnormalizeCorrect; auto with zarith. apply Rle_lt_trans with (1:=U2). apply Rplus_lt_reg_r with (-FtoRradix xy)%R. apply Rle_lt_trans with (z-y)%R;[rewrite H11; right; ring|idtac]. apply Rlt_le_trans with (FtoRradix ( Float 1%nat (Fexp y))). apply Rplus_lt_reg_r with (FtoRradix y). apply Rle_lt_trans with z;[right; ring|idtac]. apply Rlt_le_trans with (FSucc bo radix p y). case (Rle_or_lt (FSucc bo radix p y) z); auto; intros U3. absurd ((FSucc bo radix p y <= y))%R. apply Rlt_not_le. unfold FtoRradix; apply FSuccLt; auto with zarith. apply H14; auto. apply FBoundedSuc; auto with zarith. right; apply Rplus_eq_reg_l with (-y)%R. apply trans_eq with (FtoRradix (Fminus radix (FSucc bo radix p y) y)). unfold FtoRradix; rewrite Fminus_correct; auto with zarith; ring. unfold FtoRradix; rewrite FSuccDiff1; auto with zarith. ring. case (Z_eq_dec (Fnum y) (-(nNormMin radix p))%Z); auto; intros K. absurd (FNodd bo radix p y); auto. unfold FNodd; rewrite FcanonicFnormalizeEq; auto with zarith. unfold Fodd; apply EvenNOdd; rewrite K. unfold Even, radix, nNormMin. exists (-(Zpower_nat 2 (pred (pred p))))%Z. apply trans_eq with (-(Zpower_nat 2 (1+(pred (pred p)))))%Z; auto with zarith. replace (1+(pred (pred p))) with (pred p); auto with zarith. rewrite Zpower_nat_is_exp; auto with zarith. replace (Zpower_nat 2 1) with 2%Z; auto with zarith. right; apply trans_eq with (FtoRradix (Fminus radix (FSucc be radix (p+k) xy) xy)). unfold FtoRradix; rewrite FSuccDiff1; auto with zarith real. rewrite H13; auto with real. case (Z_eq_dec (Fnum xy) (-(nNormMin radix (p+k)))%Z); auto; intros K. absurd (FNodd be radix (p+k) xy); auto. unfold FNodd; rewrite FcanonicFnormalizeEq; auto with zarith. 2: left; auto. unfold Fodd; apply EvenNOdd; rewrite K. unfold Even, radix, nNormMin. exists (-(Zpower_nat 2 (pred (pred (p+k)))))%Z. apply trans_eq with (-(Zpower_nat 2 (1+(pred (pred (p+k))))))%Z; auto with zarith. replace (1+(pred (pred (p+k)))) with (pred (p+k)); auto with zarith. rewrite Zpower_nat_is_exp; auto with zarith. replace (Zpower_nat 2 1) with 2%Z; auto with zarith. unfold FtoRradix; rewrite Fminus_correct; auto with zarith; ring. clear H7 H14; elim H16; intros T1 T2; elim T2; clear T1 T2; intros. right; split;[elim H12; auto|split]. fold radix; fold FtoRradix; rewrite H11; auto with real. fold radix; intros f U1 U2. rewrite <- FSucPred with be radix (p+k) xy; auto with zarith. 2: left; auto. rewrite <- FnormalizeCorrect with radix be (p+k) f; auto with zarith. apply FSuccProp; auto with zarith. apply FPredCanonic; auto with zarith; left; auto. apply FnormalizeCanonic; auto with zarith. rewrite FnormalizeCorrect; auto with zarith. apply Rlt_le_trans with (2:=U2). apply Rplus_lt_reg_r with (-FtoRradix xy)%R. apply Rlt_le_trans with (z-y)%R;[idtac|rewrite H11; right; ring]. apply Rle_lt_trans with (-(FtoRradix ( Float 1%nat (Fexp y))))%R. right; apply trans_eq with (-(FtoRradix (Fminus radix xy (FPred be radix (p+k) xy))))%R. unfold FtoRradix; rewrite Fminus_correct; auto with zarith; ring. unfold FtoRradix; rewrite FPredDiff1; auto with zarith real. rewrite H13; auto with real. case (Z_eq_dec (Fnum xy) ((nNormMin radix (p+k)))%Z); auto with zarith; intros K. absurd (FNodd be radix (p+k) xy); auto. unfold FNodd; rewrite FcanonicFnormalizeEq; auto with zarith. 2: left; auto. unfold Fodd; apply EvenNOdd; rewrite K. unfold Even, radix, nNormMin. exists ((Zpower_nat 2 (pred (pred (p+k)))))%Z. apply trans_eq with ((Zpower_nat 2 (1+(pred (pred (p+k))))))%Z; auto with zarith. apply Rplus_lt_reg_r with (FtoRradix y). apply Rlt_le_trans with z;[idtac|right; ring]. apply Rle_lt_trans with (FPred bo radix p y). right; apply Rplus_eq_reg_l with (-y)%R. apply trans_eq with (-(FtoRradix (Fminus radix y (FPred bo radix p y))))%R. unfold FtoRradix; rewrite FPredDiff1; auto with zarith. ring. case (Z_eq_dec (Fnum y) ((nNormMin radix p))%Z); auto; intros K. absurd (FNodd bo radix p y); auto. unfold FNodd; rewrite FcanonicFnormalizeEq; auto with zarith. unfold Fodd; apply EvenNOdd; rewrite K. unfold Even, radix, nNormMin. exists ((Zpower_nat 2 (pred (pred p))))%Z. apply trans_eq with ((Zpower_nat 2 (1+(pred (pred p)))))%Z; auto with zarith. unfold FtoRradix; rewrite Fminus_correct; auto with zarith; ring. case (Rle_or_lt z (FPred bo radix p y)); auto; intros U3. absurd (y <= (FPred bo radix p y))%R. apply Rlt_not_le. unfold FtoRradix; apply FPredLt; auto with zarith. apply H14; auto. apply FBoundedPred; auto with zarith. apply FcanonicBound with radix; auto. elim H8; intros T; clear T;unfold FNodd. rewrite FcanonicFnormalizeEq; auto with zarith. rewrite FcanonicFnormalizeEq; auto with zarith. 2: left; auto. unfold Fodd; unfold Odd; intros T; elim T; intros ny U1. exists (ny+(Fnum x*(Zpower_nat radix (Zabs_nat (Fexp x-Fexp y -1)))))%Z. assert (Fexp (Fplus radix x y)=Fexp y)%Z. unfold Fplus; simpl;apply Zmin_le2. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. fold FtoRradix; apply Rle_trans with (1*Rabs y)%R;[right; ring|idtac]. apply Rle_trans with (2*Rabs y)%R;[apply Rmult_le_compat_r; auto with real|idtac]. apply Rle_trans with (1:=H); rewrite Rabs_right;[idtac|apply Rle_ge]; auto with real. apply trans_eq with (Fnum (Fplus radix x y)). apply eq_IZR. apply Rmult_eq_reg_l with (powerRZ radix (Fexp y)); auto with real zarith. apply trans_eq with (FtoRradix xy); [rewrite <- H13; unfold FtoRradix, FtoR; auto with real|idtac]. rewrite H11; unfold FtoRradix; rewrite <- Fplus_correct; auto with zarith. unfold FtoR; rewrite H14; auto with real. unfold Fplus. replace (Zmin (Fexp x) (Fexp y)) with (Fexp y). replace (Fnum y * Zpower_nat radix (Zabs_nat (Fexp y - Fexp y)))%Z with (Fnum y); auto with zarith. apply trans_eq with (Fnum x * Zpower_nat radix (Zabs_nat (Fexp x - Fexp y)) + Fnum y)%Z; auto with zarith. rewrite U1; ring_simplify. replace (Zabs_nat (Fexp x - Fexp y)) with (1+(Zabs_nat (Fexp x - Fexp y - 1))). rewrite Zpower_nat_is_exp; auto with zarith. replace (Zpower_nat radix 1) with 2%Z; auto with zarith; ring. cut (1 + Zabs_nat (Fexp x - Fexp y - 1) = Zabs_nat (Fexp x - Fexp y))%Z; auto with zarith. cut (0 <= Fexp x-Fexp y -1)%Z;[intros U2|idtac]. repeat rewrite <- Zabs_absolu; repeat rewrite Zabs_eq; auto with zarith. apply Zplus_le_reg_r with (Fexp y+1)%Z. ring_simplify. case H2; intros K. apply Zle_trans with (Fexp (Float (Fnum y) (Fexp y+1)%Z)); auto with zarith. rewrite Zplus_comm; auto with zarith. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. elim K; intros H15 H16; elim H15; intros. left; split;[split|simpl]; auto with zarith. apply Zle_trans with (1:=H18); rewrite Zplus_comm; simpl; auto with zarith. fold FtoRradix; apply Rle_trans with (2*Rabs y)%R. unfold FtoRradix, FtoR; rewrite Zplus_comm; simpl. rewrite powerRZ_add; auto with real zarith. repeat rewrite Rabs_mult. replace (Rabs (powerRZ 2 1)) with 2%R;[right; ring|idtac]. unfold powerRZ; simpl; auto with real. ring_simplify (2*1)%R; rewrite Rabs_right; auto with real; apply Rle_ge; auto with real. apply Rle_trans with (1:=H); rewrite Rabs_right;[idtac|apply Rle_ge]; auto with real. apply Zle_trans with (Fexp (Float (nNormMin radix p) (-(dExp bo)+1))). elim K; intros K1 K2; elim K2; intros K3 K4; rewrite K3. rewrite Zplus_comm; simpl; auto with zarith. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. left; repeat split. simpl; rewrite pGivesBound. rewrite Zabs_eq; auto with zarith. unfold nNormMin in |- *; simpl in |- *; auto with zarith arith. apply Zlt_le_weak; auto with zarith. apply nNormPos; auto with zarith. simpl; auto with zarith. rewrite pGivesBound. pattern p at 1; replace p with (pred p + 1); auto with zarith. rewrite Zabs_Zmult; rewrite Zabs_eq; auto with zarith. rewrite Zabs_eq; auto with zarith. rewrite Zpower_nat_is_exp; auto with zarith. unfold nNormMin in |- *; simpl in |- *; auto with zarith arith. fold FtoRradix; rewrite (Rabs_right x); try apply Rle_ge; auto with real. apply Rle_trans with (2:=H1). rewrite Rabs_right;[idtac| apply Rle_ge; unfold FtoRradix; apply LeFnumZERO; auto with zarith]. 2: simpl; unfold nNormMin; auto with zarith. unfold firstNormalPos, FtoRradix, FtoR; simpl. rewrite powerRZ_add; auto with real zarith; simpl; right; ring. ring_simplify (Fexp y-Fexp y)%Z; simpl; auto with zarith. unfold Zpower_nat; simpl; auto with zarith. Qed. Theorem AddOddOdd_can: forall (x y f1 f2:float) (z:R), (2*(Rabs y) <= Rabs x)%R -> (2*(firstNormalPos radix bo p) <= Rabs x)%R -> Fcanonic radix bo y ->(Fcanonic radix bo x) -> (To_Odd bo radix p z y) -> (To_Odd bo radix p (x+y)%R f1) -> (To_Odd bo radix p (x+z)%R f2) -> (FtoRradix f1=f2)%R. intros. case (Rle_or_lt 0%R x). intros T; case T; intros H5'. apply AddOddOdd_aux with x y z; auto. rewrite <- (Rabs_right x); auto with real. rewrite <- (Rabs_right x); auto with real. absurd (2 * firstNormalPos radix bo p <= Rabs x)%R; auto. apply Rlt_not_le; rewrite <- H5'. rewrite Rabs_R0. unfold FtoRradix, FtoR, firstNormalPos, nNormMin; simpl. repeat apply Rmult_lt_0_compat; auto with real zarith. intros H5'. apply Rmult_eq_reg_l with (-1)%R; auto with real; ring_simplify. unfold FtoRradix; repeat rewrite <- Fopp_correct; fold FtoRradix. apply AddOddOdd_aux with (Fopp x) (Fopp y) (-z)%R. unfold FtoRradix; repeat rewrite Fopp_correct; fold FtoRradix. rewrite Rabs_Ropp; rewrite <- (Rabs_left x); auto with real. unfold FtoRradix; repeat rewrite Fopp_correct; fold FtoRradix; auto with real. unfold FtoRradix; repeat rewrite Fopp_correct; fold FtoRradix; auto with real. rewrite <- (Rabs_left x); auto with real. apply FcanonicFopp; auto. apply FcanonicFopp; auto. generalize To_OddSymmetricP; unfold SymmetricP; intros T; apply T; auto. replace (Fopp x + Fopp y)%R with (-(x+y))%R. generalize To_OddSymmetricP; unfold SymmetricP; intros T; apply T; auto. unfold FtoRradix; repeat rewrite Fopp_correct; fold FtoRradix; auto with real. replace (Fopp x + -z)%R with (-(x+z))%R. generalize To_OddSymmetricP; unfold SymmetricP; intros T; apply T; auto. unfold FtoRradix; repeat rewrite Fopp_correct; fold FtoRradix; auto with real. Qed. Theorem AddOddOdd: forall (x y f1 f2:float) (z:R), (Fbounded bo x) -> (2*(Rabs y) <= Rabs x)%R -> (2*(firstNormalPos radix bo p) <= Rabs x)%R -> (To_Odd bo radix p z y) -> (To_Odd bo radix p (x+y)%R f1) -> (To_Odd bo radix p (x+z)%R f2) -> (FtoRradix f1=f2)%R. intros. apply AddOddOdd_can with (Fnormalize radix bo p x) (Fnormalize radix bo p y) z. unfold FtoRradix; repeat rewrite FnormalizeCorrect; auto with real zarith. unfold FtoRradix; rewrite FnormalizeCorrect; auto with real zarith. apply FnormalizeCanonic; auto with zarith; elim H2; auto. apply FnormalizeCanonic; auto with zarith. apply To_OddCompatible with (4:=H2); auto with zarith. rewrite FnormalizeCorrect; auto with real zarith. apply FnormalizeBounded; auto with zarith; elim H2; auto. unfold FtoRradix; repeat rewrite FnormalizeCorrect; auto with real zarith. unfold FtoRradix; rewrite FnormalizeCorrect; auto with real zarith. Qed. Theorem AddOddOdd2_can: forall (x y f1 f2:float) (z:R), (2*(Rabs z) <= Rabs x)%R -> (2*(firstNormalPos radix bo p) <= Rabs x)%R -> Fcanonic radix bo y ->(Fcanonic radix bo x) -> (To_Odd bo radix p z y) -> (To_Odd bo radix p (x+y)%R f1) -> (To_Odd bo radix p (x+z)%R f2) -> (FtoRradix f1=f2)%R. intros. apply AddOddOdd_can with x y z; auto. apply Rmult_le_reg_l with (/2)%R; auto with real. apply Rle_trans with (Rabs y);[right; field; auto with real|idtac]. assert (FtoRradix (Fabs (Float (Fnum x) (Zpred (Fexp x)))) = / 2 * Rabs x)%R. unfold FtoRradix; rewrite <- Fabs_correct; auto with zarith. unfold FtoR, Fabs, Zpred, Zminus; simpl. rewrite powerRZ_add; auto with real zarith; simpl. ring_simplify (2*1)%R; ring. rewrite <- H6. unfold FtoRradix; apply RoundAbsMonotoner with bo p (To_Odd bo radix p) z; auto with zarith. apply To_OddRoundedModeP; auto with zarith. assert (Fbounded bo x);[apply FcanonicBound with radix; auto|idtac]. elim H7; intros. apply absFBounded. split; simpl; auto with zarith. assert (Zsucc (-(dExp bo)) <= Fexp x)%Z; auto with zarith. apply Zle_trans with (Fexp (Float (nNormMin radix p) (Zsucc (- dExp bo)))); auto with zarith. apply Fcanonic_Rle_Zle with radix bo p; auto with zarith. apply FcanonicNnormMin; auto with zarith. fold FtoRradix; apply Rle_trans with (2:=H0). rewrite Rabs_right. unfold firstNormalPos, FtoRradix, FtoR; simpl. unfold Zsucc; rewrite powerRZ_add; auto with real zarith; simpl; right; ring. unfold FtoRradix; apply Rle_ge; apply LeFnumZERO; simpl; unfold nNormMin; auto with zarith. fold FtoRradix; rewrite H6; apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (1:=H); right; field; auto with real. Qed. Theorem AddOddOdd2: forall (x y f1 f2:float) (z:R), Fbounded bo x -> (2*(Rabs z) <= Rabs x)%R -> (2*(firstNormalPos radix bo p) <= Rabs x)%R -> To_Odd bo radix p z y -> To_Odd bo radix p (x+y)%R f1 -> To_Odd bo radix p (x+z)%R f2 -> (FtoRradix f1 = f2)%R. intros. apply AddOddOdd2_can with (Fnormalize radix bo p x) (Fnormalize radix bo p y) z. unfold FtoRradix; rewrite FnormalizeCorrect; auto with real zarith. unfold FtoRradix; rewrite FnormalizeCorrect; auto with real zarith. apply FnormalizeCanonic; auto with zarith; elim H2; auto. apply FnormalizeCanonic; auto with zarith. apply To_OddCompatible with (4:=H2); auto with zarith. rewrite FnormalizeCorrect; auto with real zarith. apply FnormalizeBounded; auto with zarith; elim H2; auto. unfold FtoRradix; repeat rewrite FnormalizeCorrect; auto with real zarith. unfold FtoRradix; rewrite FnormalizeCorrect; auto with real zarith. Qed. End Sec5. Float8.4/Others/FminOp.v0000644000423700002640000013637212032774527014711 0ustar sboldotoccataRequire Export AllFloat. Require Export Paux. Theorem oZ1_oZ : forall o, oZ1 o = Z_of_nat (oZ o). intros o; case o; simpl in |- *; auto. intros x; apply sym_equal; apply inject_nat_convert; auto. Qed. Opaque Pdiv. Opaque PdivBound. Definition FindMin (bound base a : positive) (dexp exp : Z) := match PdivBound bound a base with | (q, r, n) => match (exp + Z_of_nat n)%Z with | exp' => match (dexp - exp')%Z with | Zpos e => match q with | Some q1 => match Pdiv q1 (positive_exp base e) with | (q', r') => (Float (oZ1 q') dexp, Fplus (Zpos base) (Float (oZ1 r') exp') (Float (oZ1 r) exp)) end | None => (Float 0 dexp, Float (oZ1 r) exp) end | _ => (Float (oZ1 q) exp', Float (oZ1 r) exp) end end end. Section FminOp. Variable radix : Z. Hypothesis radixMoreThanOne : (1 < radix)%Z. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Coercion Local FtoRradix := FtoR radix. Variable b : Fbound. Variable precision : nat. Hypothesis precisionNotZero : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Let dExp := (- dExp b)%Z. Theorem Zpower_nat_exp : forall (a : positive) (n : nat), exp (nat_of_P a) n = Zpower_nat (Zpos a) n :>Z. intros a n; elim n; simpl in |- *; auto. intros n0 H; rewrite inj_mult; rewrite H. replace (S n0) with (1 + n0); [ rewrite Zpower_nat_is_exp | idtac ]; auto. rewrite Zpower_nat_1; auto. rewrite (inject_nat_convert (Zpos a)); auto. Qed. Definition Z2pos x := match x with | Z0 => 1%positive | Zpos p => p | Zneg p => p end. Theorem Z2pos_correct : forall z : Z, (0 < z)%Z -> Zpos (Z2pos z) = z. intros z; case z; simpl in |- *; auto; unfold Zlt in |- *; simpl in |- *; intros; discriminate. Qed. Theorem FminOp_correct1 : forall a e, Float (Zpos a) e = (fst (FindMin (vNum b) (Z2pos radix) a dExp e) + snd (FindMin (vNum b) (Z2pos radix) a dExp e))%R :>R. cut (1 < nat_of_P (Z2pos radix)); [ intros Z2 | apply lt_Zlt_inv; simpl in |- *; idtac; try rewrite (inject_nat_convert (Zpos (Z2pos radix)) (Z2pos radix)); auto; rewrite Z2pos_correct; auto with zarith ]. intros a e; unfold FindMin in |- *. generalize (PdivBound_correct1 (vNum b) a (Z2pos radix)); case (PdivBound (vNum b) a (Z2pos radix)); simpl in |- *. intros p; case p; simpl in |- *. intros o1 o2 n H1. CaseEq (dExp - (e + n))%Z; simpl in |- *. intros H; unfold FtoRradix in |- *; rewrite <- (FshiftCorrect radix radixMoreThanOne n (Float (oZ1 o1) (e + n))); simpl in |- *; auto. unfold Fshift in |- *; simpl in |- *; auto. replace (e + n - n)%Z with e; [ idtac | auto with zarith ]. unfold FtoR in |- *; simpl in |- *; auto with arith. rewrite <- Rmult_plus_distr_r; rewrite H1; auto. rewrite plus_INR; rewrite INR_IZR_INZ; rewrite inj_mult. rewrite Zpower_nat_exp; simpl in |- *. rewrite Z2pos_correct; auto with zarith. repeat rewrite oZ1_oZ; auto. repeat rewrite <- INR_IZR_INZ; auto. intros p0 H; generalize H1; clear H1; case o1. intros x H1; generalize (Pdiv_correct x (positive_exp (Z2pos radix) p0)); case (Pdiv x (positive_exp (Z2pos radix) p0)). intros q' r'; simpl in |- *. intros (H2, H3). unfold FtoRradix in |- *; rewrite <- (FshiftCorrect radix radixMoreThanOne (Zabs_nat (n + Zpos p0)) (Float (oZ1 q') dExp)); simpl in |- *; auto. rewrite Z2pos_correct; auto with zarith. rewrite Fplus_correct; auto with zarith. rewrite <- (FshiftCorrect radix radixMoreThanOne n (Float (oZ1 r') (e + n))); simpl in |- *; auto. unfold Fshift in |- *; simpl in |- *; auto. replace (dExp - Zabs_nat (n + Zpos p0))%Z with e. replace (e + n - n)%Z with e. unfold FtoR in |- *; simpl in |- *; auto. repeat rewrite <- Rmult_plus_distr_r; rewrite H1; simpl in |- *; auto. rewrite H2. rewrite positive_exp_correct. repeat rewrite oZ1_oZ. rewrite mult_plus_distr_r. rewrite mult_assoc_reverse. rewrite <- expPlus. repeat rewrite plus_INR. repeat (rewrite INR_IZR_INZ; rewrite inj_mult). rewrite plus_comm. repeat rewrite Zpower_nat_exp; simpl in |- *. repeat rewrite Z2pos_correct; auto with zarith. replace (Zabs_nat (n + Zpos p0)) with (n + nat_of_P p0); auto. repeat rewrite <- INR_IZR_INZ; ring. rewrite <- (inject_nat_convert (Zpos p0) p0); auto. rewrite <- inj_plus. apply sym_equal; apply absolu_INR. ring. rewrite <- (inject_nat_convert (Zpos p0) p0); auto. rewrite <- inj_plus. rewrite absolu_INR. rewrite inj_plus. rewrite (inject_nat_convert (Zpos p0) p0); auto. rewrite <- H; ring. auto with arith. auto with arith. unfold FtoRradix, FtoR in |- *; simpl in |- *. intros H1; rewrite H1. rewrite oZ1_oZ; repeat rewrite <- INR_IZR_INZ; ring. apply lt_Zlt_inv; simpl in |- *; idtac; try rewrite (inject_nat_convert (Zpos (Z2pos radix)) (Z2pos radix)); auto; rewrite Z2pos_correct; auto with zarith. intros p0 H; unfold FtoRradix in |- *; rewrite <- (FshiftCorrect radix radixMoreThanOne n (Float (oZ1 o1) (e + n))); simpl in |- *; auto. unfold Fshift in |- *; simpl in |- *; auto. replace (e + n - n)%Z with e; [ idtac | auto with zarith ]. unfold FtoR in |- *; simpl in |- *; auto with arith. rewrite <- Rmult_plus_distr_r; rewrite H1; auto. rewrite plus_INR; rewrite INR_IZR_INZ; rewrite inj_mult. rewrite Zpower_nat_exp; simpl in |- *. repeat rewrite Z2pos_correct; auto with zarith. repeat rewrite oZ1_oZ; auto. repeat rewrite <- INR_IZR_INZ; auto. Qed. Theorem FminOp_correct2 : forall a e, (0 <= snd (FindMin (vNum b) (Z2pos radix) a dExp e))%R. intros a e; unfold FindMin in |- *; case (PdivBound (vNum b) a (Z2pos radix)). intros p; case p; simpl in |- *. intros o1 o2 n; case (dExp - (e + n))%Z; simpl in |- *; auto. unfold FtoRradix, FtoR in |- *; simpl in |- *; auto. replace 0%R with (0 * powerRZ radix e)%R; [ idtac | ring ]. apply Rmult_le_compat_r; auto with real zarith. case o2; simpl in |- *; auto with real. intros p0; case o1; simpl in |- *. intros o1'; case (Pdiv o1' (positive_exp (Z2pos radix) p0)); simpl in |- *; auto. intros o o0. repeat rewrite Z2pos_correct; auto with zarith. unfold FtoRradix in |- *; rewrite Fplus_correct; auto with arith. replace 0%R with (0 + 0)%R; [ idtac | ring ]. apply Rplus_le_compat; unfold FtoR in |- *; simpl in |- *; auto with real. replace 0%R with (0 * powerRZ radix (e + n))%R; [ idtac | ring ]. apply Rmult_le_compat_r; auto with real arith. case o0; simpl in |- *; auto with real. replace 0%R with (0 * powerRZ radix e)%R; [ idtac | ring ]. apply Rmult_le_compat_r; auto with real arith. case o2; simpl in |- *; auto with real. unfold FtoRradix, FtoR in |- *; simpl in |- *; replace 0%R with (0 * powerRZ radix e)%R; [ idtac | ring ]. apply Rmult_le_compat_r; auto with real arith. case o2; simpl in |- *; auto with real. intros o; unfold FtoRradix, FtoR in |- *; simpl in |- *; replace 0%R with (0 * powerRZ radix e)%R; [ idtac | ring ]. apply Rmult_le_compat_r; auto with real arith. case o2; simpl in |- *; auto with real. Qed. Theorem FminOp_correct3 : forall a e, Fbounded b (fst (FindMin (vNum b) (Z2pos radix) a dExp e)). cut (1 < nat_of_P (Z2pos radix)); [ intros Z2 | apply lt_Zlt_inv; simpl in |- *; idtac; try rewrite (inject_nat_convert (Zpos (Z2pos radix)) (Z2pos radix)); auto; rewrite Z2pos_correct; auto with zarith ]. intros a e; unfold FindMin in |- *; generalize (PdivBound_correct2 (vNum b) a (Z2pos radix)); case (PdivBound (vNum b) a (Z2pos radix)). intros p; case p; simpl in |- *. intros o1 o2 n H1. CaseEq (dExp - (e + n))%Z; simpl in |- *. intros H2; repeat (split; simpl in |- *; auto). rewrite Zabs_eq; [ idtac | case o1; simpl in |- *; intros; red in |- *; simpl in |- *; auto; red in |- *; intros; discriminate ]. rewrite oZ1_oZ; rewrite <- (inject_nat_convert (Zpos (vNum b)) (vNum b)); auto with zarith. fold dExp in |- *; auto with zarith. intros p0 H; generalize H1; clear H1; case o1; simpl in |- *. intros x H1; generalize (Pdiv_correct x (positive_exp (Z2pos radix) p0)); case (Pdiv x (positive_exp (Z2pos radix) p0)); simpl in |- *. intros o o0 (H2, H3). repeat (split; simpl in |- *; auto). rewrite oZ1_oZ; rewrite <- (inject_nat_convert (Zpos (vNum b)) (vNum b)); auto with zarith. rewrite Zabs_eq; [ idtac | case o; simpl in |- *; auto with zarith ]. apply inj_lt. apply le_lt_trans with (nat_of_P x); auto. replace (oZ o) with (oZ o * 1 + 0); [ rewrite H2 | ring ]. apply plus_le_compat; auto with arith. fold dExp in |- *; auto with zarith. intros H1; repeat (split; simpl in |- *; auto with zarith). intros p0 H; rewrite oZ1_oZ; repeat (split; simpl in |- *; auto). rewrite Zabs_eq; [ idtac | case o1; simpl in |- *; auto with zarith ]. rewrite <- (inject_nat_convert (Zpos (vNum b)) (vNum b)); auto with zarith. fold dExp in |- *; auto with zarith. replace dExp with (e + n + (dExp - (e + n)))%Z; auto with zarith. pattern (e + n)%Z at 3 in |- *; replace (e + n)%Z with (e + n + 0)%Z. apply Zplus_le_compat; try rewrite H; auto with zarith. auto with zarith. Qed. Theorem FminOp_correct4 : forall a e, snd (FindMin (vNum b) (Z2pos radix) a dExp e) = 0%R :>R \/ Fcanonic radix b (fst (FindMin (vNum b) (Z2pos radix) a dExp e)). intros a e; generalize (FminOp_correct3 a e); unfold FindMin in |- *; generalize (PdivBound_correct2 (vNum b) a (Z2pos radix)); generalize (PdivBound_correct3 (vNum b) a (Z2pos radix)); generalize (PdivBound_correct4 (vNum b) a (Z2pos radix)); case (PdivBound (vNum b) a (Z2pos radix)). cut (1 < nat_of_P (Z2pos radix)); [ intros Z2 | apply lt_Zlt_inv; simpl in |- *; idtac; try rewrite (inject_nat_convert (Zpos (Z2pos radix)) (Z2pos radix)); auto; rewrite Z2pos_correct; auto with zarith ]. intros p; case p; simpl in |- *. intros o1 o2 n H1 H2 H3. CaseEq (dExp - (e + n))%Z; simpl in |- *. intros H4 Fb; right. cut (Fdigit radix (Float (oZ1 o1) (e + n)) <= precision); [ intros Le1 | idtac ]. case (le_lt_or_eq _ _ Le1); intros Le2. right; repeat (split; simpl in |- *; auto). fold dExp in |- *; auto with zarith. case (Z_eq_dec (oZ1 o1) 0); intros Z3. replace (radix * oZ1 o1)%Z with 0%Z; auto with zarith; rewrite Z3; ring. rewrite pGivesBound; rewrite <- (Zabs_eq (Zpower_nat radix precision)); auto with zarith. apply (digit_anti_monotone_lt radix); auto. replace (radix * oZ1 o1)%Z with (oZ1 o1 * Zpower_nat radix 1)%Z; [ idtac | rewrite Zpower_nat_1; ring ]. replace (Zpower_nat radix precision) with (1 * Zpower_nat radix precision)%Z; [ idtac | ring ]. repeat rewrite digitAdd; auto with zarith. rewrite digit1; rewrite (fun x => plus_comm x 1); simpl in |- *; auto with arith. left; repeat (split; simpl in |- *; auto). rewrite Zabs_Zmult; rewrite (Zabs_eq radix); auto with zarith. rewrite (PosNormMin radix b precision); auto with arith; unfold nNormMin in |- *. apply Zle_Zmult_comp_l; auto with zarith. rewrite <- Le2; unfold Fdigit in |- *; simpl in |- *; apply digitLess. Contradict Le2; rewrite Le2; unfold Fdigit in |- *; simpl in |- *; auto with zarith. apply pGivesDigit with (b := b); auto with arith. intros p0 H; generalize H1 H2 H3; clear H1 H2 H3; case o1; simpl in |- *. intros x H1 H2 H3; generalize (Pdiv_correct x (positive_exp (Z2pos radix) p0)); case (Pdiv x (positive_exp (Z2pos radix) p0)); simpl in |- *. intros o o0 H0 Fb; right. cut (Fdigit radix (Float (oZ1 o) dExp) <= precision); [ intros Le1 | idtac ]. case (le_lt_or_eq _ _ Le1); intros Le2. right; repeat (split; simpl in |- *; auto). case (Z_eq_dec (oZ1 o) 0); intros Z3. replace (radix * oZ1 o)%Z with 0%Z; auto with zarith; rewrite Z3; ring. rewrite pGivesBound; rewrite <- (Zabs_eq (Zpower_nat radix precision)); auto with zarith. apply (digit_anti_monotone_lt radix); auto. replace (radix * oZ1 o)%Z with (oZ1 o * Zpower_nat radix 1)%Z; [ idtac | rewrite Zpower_nat_1; ring ]. replace (Zpower_nat radix precision) with (1 * Zpower_nat radix precision)%Z; [ idtac | ring ]. repeat rewrite digitAdd; auto with zarith. rewrite digit1; rewrite (fun x => plus_comm x 1); simpl in |- *; auto with arith. left; repeat (split; simpl in |- *; auto). rewrite Zabs_Zmult; rewrite (Zabs_eq radix); auto with zarith. rewrite (PosNormMin radix b precision); auto with arith; unfold nNormMin in |- *. apply Zle_Zmult_comp_l; auto with zarith. rewrite <- Le2; unfold Fdigit in |- *; simpl in |- *; apply digitLess. Contradict Le2; rewrite Le2; unfold Fdigit in |- *; simpl in |- *; auto with zarith. apply pGivesDigit with (b := b); auto with arith. intros H1 H2 H3; right; right; repeat (split; simpl in |- *; auto with zarith). replace (radix * 0)%Z with 0%Z; [ auto with zarith | ring ]. intros p0 H Fb. case (le_or_lt (nat_of_P (vNum b)) (nat_of_P a)); intros H4. right; left. repeat (split; simpl in |- *; auto). rewrite Zabs_Zmult; repeat rewrite Zabs_eq; auto with zarith. cut (nat_of_P (vNum b) <= (nat_of_P (Z2pos radix) * oZ o1)%nat)%Z; auto with zarith arith. rewrite inj_mult; repeat rewrite (fun x => inject_nat_convert (Zpos x) x); auto. rewrite Z2pos_correct; auto; rewrite oZ1_oZ; auto. apply inj_le; apply (H1 (Zabs_nat (nNormMin radix precision))); auto. apply inject_nat_eq; rewrite inj_mult; repeat rewrite (fun x => inject_nat_convert (Zpos x) x); auto. rewrite Z2pos_correct; auto; rewrite inj_abs; auto with zarith. apply PosNormMin; auto with zarith. unfold nNormMin in |- *; auto with zarith. case o1; simpl in |- *; auto; intros; red in |- *; intros; discriminate. left; unfold FtoRradix, FtoR in |- *; simpl in |- *; ring_simplify. generalize (H2 H4); intros tmp; injection tmp. intros H'1 H'2 H'3; rewrite H'2; simpl in |- *; auto. ring. Qed. Theorem FminOp_correct5 : forall a e, snd (FindMin (vNum b) (Z2pos radix) a dExp e) = 0%R :>R \/ (snd (FindMin (vNum b) (Z2pos radix) a dExp e) < Fulp b radix precision (fst (FindMin (vNum b) (Z2pos radix) a dExp e)))%R. cut (1 < nat_of_P (Z2pos radix)); [ intros Z2 | apply lt_Zlt_inv; simpl in |- *; idtac; try rewrite (inject_nat_convert (Zpos (Z2pos radix)) (Z2pos radix)); auto; rewrite Z2pos_correct; auto with zarith ]. intros a e; case (FminOp_correct4 a e); auto; intros C1. right; unfold Fulp in |- *. rewrite FcanonicFnormalizeEq; auto with arith. unfold FindMin in |- *; generalize (PdivBound_correct (vNum b) a (Z2pos radix)); case (PdivBound (vNum b) a (Z2pos radix)); simpl in |- *. intros p; case p; simpl in |- *. intros o1 o2 n H1. CaseEq (dExp - (e + n))%Z; simpl in |- *. intros H2; case H1. apply lt_Zlt_inv; rewrite (fun x => inject_nat_convert (Zpos x) x); auto; try rewrite Z2pos_correct; auto with zarith. intros tmp ((tmp1, H3), tmp2); rewrite oZ1_oZ; unfold FtoRradix, FtoR in |- *; simpl in |- *. rewrite powerRZ_add; auto with real zarith. rewrite (fun x y => Rmult_comm (powerRZ x y)). apply Rlt_monotony_exp; auto with zarith. rewrite <- Zpower_nat_Z_powerRZ; auto with zarith. rewrite <- (Z2pos_correct radix); try rewrite <- Zpower_nat_exp; auto with real zarith arith. intros p0 H; generalize H1; clear H1; case o1. intros x H1; generalize (Pdiv_correct x (positive_exp (Z2pos radix) p0)); case (Pdiv x (positive_exp (Z2pos radix) p0)). intros q' r'; simpl in |- *. intros (H2, H3). unfold Fplus in |- *; simpl in |- *. replace (Zmin (e + n) e) with e. replace (Zabs_nat (e + n - e)) with n. replace (Zabs_nat (e - e)) with 0. unfold FtoRradix, FtoR in |- *; simpl in |- *. repeat rewrite oZ1_oZ. rewrite Z2pos_correct; auto with zarith. replace dExp with (Zpos p0 + (e + n))%Z. repeat (rewrite powerRZ_add; auto with real arith). replace (powerRZ radix (Zpos p0) * (powerRZ radix e * powerRZ radix n))%R with (powerRZ radix (Zpos p0) * powerRZ radix n * powerRZ radix e)%R; [ idtac | ring ]. apply Rlt_monotony_exp; auto with arith. replace (oZ o2 * Zpower_nat radix 0)%Z with (Z_of_nat (oZ o2)). rewrite <- (inject_nat_convert (Zpos p0) p0); auto. repeat rewrite <- Zpower_nat_Z_powerRZ; auto with zarith. replace radix with (Zpos (Z2pos radix)). repeat rewrite <- Zpower_nat_exp; auto with zarith. rewrite <- Rmult_IZR. apply Rlt_IZR. repeat rewrite <- inj_mult || rewrite <- inj_plus. apply inj_lt. apply lt_le_trans with (oZ r' * exp (nat_of_P (Z2pos radix)) n + exp (nat_of_P (Z2pos radix)) n). case H1; auto with arith; intros tmp1 ((tmp2, H4), tmp3); auto with arith. replace (oZ r' * exp (nat_of_P (Z2pos radix)) n + exp (nat_of_P (Z2pos radix)) n) with (S (oZ r') * exp (nat_of_P (Z2pos radix)) n). apply lte_comp_mult; auto with arith. rewrite positive_exp_correct in H3; auto with arith. simpl in |- *; ring. apply Z2pos_correct; auto. rewrite Zpower_nat_O; idtac; simpl in |- *; auto with zarith. auto with real zarith. auto with real zarith. rewrite <- H; ring. replace (e - e)%Z with 0%Z; simpl in |- *; auto with zarith. replace (e + n - e)%Z with (Z_of_nat n); simpl in |- *; auto with zarith. apply sym_equal; apply absolu_INR. apply sym_equal; apply Zmin_le2; auto with zarith. intros H1; case H1; auto with arith; intros H2 ((H3, H4), H5). rewrite oZ1_oZ; unfold FtoRradix, FtoR in |- *; simpl in |- *; auto. replace dExp with (Zpos p0 + (e + n))%Z. repeat (rewrite powerRZ_add; auto with real arith). replace (powerRZ radix (Zpos p0) * (powerRZ radix e * powerRZ radix n))%R with (powerRZ radix (Zpos p0) * powerRZ radix n * powerRZ radix e)%R; [ idtac | ring ]. apply Rlt_monotony_exp; auto with arith. rewrite <- (inject_nat_convert (Zpos p0) p0); auto with arith. replace radix with (Zpos (Z2pos radix)). repeat rewrite <- Zpower_nat_Z_powerRZ; auto with real zarith. repeat rewrite <- Zpower_nat_exp; auto with zarith. rewrite <- Rmult_IZR. apply Rlt_IZR. rewrite <- inj_mult. apply inj_lt. apply lt_le_trans with (1 * exp (nat_of_P (Z2pos radix)) n). replace (1 * exp (nat_of_P (Z2pos radix)) n) with (exp (nat_of_P (Z2pos radix)) n); auto; ring. apply lte_comp_mult; auto with arith. elim (nat_of_P p0); simpl in |- *; auto with arith. intros n0 H0; replace 1 with (1 * 1); auto with arith. apply Z2pos_correct; auto with zarith. auto with real zarith. auto with real zarith. rewrite <- H; ring. intros p0 H; rewrite oZ1_oZ. case H1; auto with arith; intros H2 ((H3, H4), H5). unfold FtoRradix, FtoR in |- *; simpl in |- *; auto. repeat (rewrite powerRZ_add; auto with real arith). replace (powerRZ radix e * powerRZ radix n)%R with (powerRZ radix n * powerRZ radix e)%R; [ idtac | ring ]. apply Rlt_monotony_exp; auto with arith. replace radix with (Zpos (Z2pos radix)). repeat rewrite <- Zpower_nat_Z_powerRZ; auto with real zarith. repeat rewrite <- Zpower_nat_exp; auto with real zarith arith. apply Z2pos_correct; auto. auto with real zarith arith. Qed. Theorem FminOp_correct6 : forall a e, (0 <= fst (FindMin (vNum b) (Z2pos radix) a dExp e))%R. intros a e; unfold FindMin in |- *; case (PdivBound (vNum b) a (Z2pos radix)). intros p; case p; simpl in |- *. intros o1 o2 n; case (dExp - (e + n))%Z; simpl in |- *; auto. rewrite oZ1_oZ; unfold FtoRradix, FtoR in |- *; simpl in |- *; auto. replace 0%R with (0 * powerRZ radix (e + n))%R; [ idtac | ring ]. apply Rmult_le_compat_r; auto with real zarith. intros p0; case o1; simpl in |- *. intros o1'; case (Pdiv o1' (positive_exp (Z2pos radix) p0)); simpl in |- *; auto. intros o o0; unfold FtoRradix, FtoR in |- *; simpl in |- *. replace 0%R with (0 * powerRZ radix dExp)%R; [ idtac | ring ]. apply Rmult_le_compat_r; auto with real arith. rewrite oZ1_oZ; rewrite <- INR_IZR_INZ; auto with real arith. unfold FtoRradix, FtoR in |- *; simpl in |- *; auto with real arith. intros o0; unfold FtoRradix, FtoR in |- *; simpl in |- *. replace 0%R with (0 * powerRZ radix (e + n))%R; [ idtac | ring ]. apply Rmult_le_compat_r; auto with real arith. rewrite oZ1_oZ; rewrite <- INR_IZR_INZ; auto with real arith. Qed. Theorem FSuccDiffPos : forall x : float, (0 <= x)%R -> Fminus radix (FSucc b radix precision x) x = Float 1%nat (Fexp x) :>R. intros x H. unfold FtoRradix in |- *; apply FSuccDiff1; auto with arith. Contradict H; unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite H. apply Rlt_not_le. replace 0%R with (0 * powerRZ radix (Fexp x))%R; [ idtac | ring ]. apply Rlt_monotony_exp; auto with real arith. generalize (nNormPos _ radixMoreThanOne precision); replace 0%R with (IZR (- 0%nat)); auto with real zarith arith. Qed. Theorem CanonicFulp : forall p : float, Fcanonic radix b p -> Fulp b radix precision p = Float 1%nat (Fexp p). intros p H; unfold Fulp in |- *. rewrite FcanonicFnormalizeEq; auto with arith. unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. Qed. Theorem FSuccUlpPos : forall x : float, Fcanonic radix b x -> (0 <= x)%R -> Fminus radix (FSucc b radix precision x) x = Fulp b radix precision x :>R. intros x H H0; rewrite CanonicFulp; auto. apply FSuccDiffPos; auto. Qed. Theorem FNSuccUlpPos : forall x : float, Fcanonic radix b x -> (0 <= x)%R -> Fminus radix (FNSucc b radix precision x) x = Fulp b radix precision x :>R. intros x H H0. unfold FNSucc in |- *. rewrite FcanonicFnormalizeEq; auto with arith. apply FSuccUlpPos; auto. Qed. Theorem FminOp_correct7 : forall a e, isMin b radix (Float (Zpos a) e) (fst (FindMin (vNum b) (Z2pos radix) a dExp e)). intros a e; apply MinBinade with (precision := precision); auto with arith. apply FminOp_correct3. rewrite FminOp_correct1; fold FtoRradix in |- *; auto with real. apply Rle_trans with (FtoRradix (fst (FindMin (vNum b) (Z2pos radix) a dExp e)) + 0)%R; auto with real. generalize (FminOp_correct2 a e); auto with real. rewrite FminOp_correct1; fold FtoRradix in |- *; auto with real. case (FminOp_correct5 a e); intros H1. rewrite H1; auto with real float. apply Rle_lt_trans with (FtoRradix (fst (FindMin (vNum b) (Z2pos radix) a dExp e))); auto with real. unfold FtoRradix in |- *; apply FNSuccLt; auto with arith. case (FminOp_correct4 a e); intros H2. rewrite H2; auto with real float. apply Rle_lt_trans with (FtoRradix (fst (FindMin (vNum b) (Z2pos radix) a dExp e))); auto with real. unfold FtoRradix in |- *; apply FNSuccLt; auto with arith. cut (forall x y z, (y < z - x)%R -> (x + y < z)%R); [ intros th1; apply th1 | auto with real ]. unfold FtoR in |- *; rewrite <- (Fminus_correct radix); auto with arith. rewrite FNSuccUlpPos; auto with arith. apply FminOp_correct6; auto with arith. intros x y z H; replace z with (x + (z - x))%R; auto with real. Qed. Inductive rResult : Set := | rExact : float -> rResult | rRound : float -> rResult. Definition rFloat o := match o with | rExact e => e | rRound e => e end. Definition rFloor (f : float) := match f with | Float Z0 e => rExact (Float 0 dExp) | Float (Zpos a) e => match FindMin (vNum b) (Z2pos radix) a dExp e with | (r1, Float Z0 _) => rExact r1 | (r1, _) => rRound r1 end | Float (Zneg a) e => match FindMin (vNum b) (Z2pos radix) a dExp e with | (r1, Float Z0 _) => rExact (Fopp r1) | (r1, _) => rRound (Fopp (FSucc b radix precision r1)) end end. Theorem NotR0NotZero : forall f : float, Fnum f <> 0%Z -> f <> 0%R :>R. intros f H; Contradict H; auto with float arith. unfold FtoRradix, FtoR in H; simpl in H. case (Rmult_integral _ _ H); intros H1. 2: Contradict H1; auto with real zarith. apply eq_IZR; simpl in |- *; auto. Qed. Theorem rFloor_correct : forall f : float, isMin b radix f (rFloat (rFloor f)) /\ match rFloor f with | rExact r => r = f :>R | rRound r => r <> f :>R /\ Fcanonic radix b r end. intros f; case f. intros a e; case a; auto. simpl in |- *; split. replace (FtoRradix (Float 0 e)) with (FtoRradix (Float 0 dExp)). unfold FtoRradix in |- *; apply RoundedModeProjectorIdem with (b := b) (P := isMin b radix); auto with float. apply MinRoundedModeP with (precision := precision); auto with arith. repeat (split; simpl in |- *; auto with arith zarith). unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. intros p; generalize (FminOp_correct1 p e); generalize (FminOp_correct4 p e); generalize (FminOp_correct7 p e); simpl in |- *; case (FindMin (vNum b) (Z2pos radix) p dExp e); simpl in |- *; auto. intros f0 f1; case f1; simpl in |- *; auto. intros a'; case a'; simpl in |- *; auto. intros e' H1 H2 H3; split; auto; rewrite H3; unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. intros p' e' H1 H2 H3; split; auto. split; auto. Contradict H3; rewrite H3. apply Rlt_not_eq; auto with real. pattern (FtoRradix (Float (Zpos p) e)) at 1 in |- *; replace (FtoRradix (Float (Zpos p) e)) with (FtoRradix (Float (Zpos p) e) + 0)%R. apply Rplus_lt_compat_l. unfold FtoRradix, FtoR in |- *; simpl in |- *; apply Rmult_lt_0_compat; auto with real arith. ring. case H2; clear H2; auto; intros H2; Contradict H2. apply NotR0NotZero; simpl in |- *; red in |- *; intros; discriminate. intros p' e' H1 H2 H3; split; auto. cut (Float (Zneg p') e' <> 0%R :>R); [ intros Rth1; split | idtac ]. Contradict H3; rewrite H3. apply Rgt_not_eq; auto with real. pattern (FtoRradix (Float (Zpos p) e)) at 1 in |- *; replace (FtoRradix (Float (Zpos p) e)) with (FtoRradix (Float (Zpos p) e) + 0)%R. red in |- *; apply Rplus_lt_compat_l. unfold FtoRradix, FtoR in |- *; simpl in |- *. replace (- nat_of_P p' * powerRZ radix e')%R with (- (nat_of_P p' * powerRZ radix e'))%R; [ idtac | ring ]. replace 0%R with (-0)%R; [ idtac | ring ]. apply Ropp_lt_contravar; apply Rmult_lt_0_compat; auto with real arith. ring. case H2; auto; intros H4; Contradict Rth1; auto. apply NotR0NotZero; simpl in |- *; red in |- *; intros; discriminate. intros p; replace (FtoRradix (Float (Zneg p) e)) with (- FtoRradix (Float (Zpos p) e))%R. 2: rewrite <- (Fopp_correct radix); simpl in |- *; auto. generalize (FminOp_correct1 p e); generalize (FminOp_correct3 p e); generalize (FminOp_correct4 p e); generalize (FminOp_correct5 p e); generalize (FminOp_correct6 p e); generalize (FminOp_correct7 p e); simpl in |- *; case (FindMin (vNum b) (Z2pos radix) p dExp e); simpl in |- *; auto. intros f0 f1; case f1; simpl in |- *; auto. intros a'; case a'; simpl in |- *; auto. intros Fexp H H0 H1 H2 H3 H4; split; auto. apply MaxOppMin; auto. replace (FtoRradix (Float (Zpos p) e)) with (FtoRradix f0). unfold FtoRradix in |- *; apply RoundedModeProjectorIdem with (b := b) (P := isMax b radix); auto with float. apply MaxRoundedModeP with (precision := precision); auto with arith. rewrite H4; unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. rewrite H4; rewrite (Fopp_correct radix); auto with arith; unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. intros p0 Fexp H H0 H1 H2 H3 H4; cut (FtoRradix (Float (Zpos p0) Fexp) <> 0%R :>R); [ intros Neq1; split | idtac ]. apply MaxOppMin; auto. rewrite <- (FcanonicFnormalizeEq _ radixMoreThanOne b precision) with (p := f0); auto with zarith. change (isMax b radix (FtoRradix (Float (Zpos p) e)) (FNSucc b radix precision f0)) in |- *. apply MinMax; auto with arith. rewrite H4. Contradict Neq1. replace 0%R with (FtoR radix f0 - f0)%R; [ rewrite <- Neq1 | fold FtoRradix in |- * ]; ring. case H2; auto; intros H5; Contradict H5; apply NotR0NotZero; simpl in |- *; red in |- *; intros; discriminate. case H2; clear H2; intros H2; [ Contradict Neq1; auto | idtac ]. rewrite H4. split. apply Rlt_not_eq; auto with real. rewrite (Fopp_correct radix); auto with arith. apply Ropp_lt_contravar. cut (forall x y z, (y < z - x)%R -> (x + y < z)%R); [ intros Rt1; apply Rt1 | idtac ]. unfold FtoRradix in |- *; rewrite <- Fminus_correct; auto with arith. fold FtoRradix in |- *; rewrite (FSuccUlpPos f0); auto with arith. case H1; auto; intros H5; Contradict H4; auto. intros x y z H5; replace z with (x + (z - x))%R; auto with real; ring. auto with float arith. apply NotR0NotZero; simpl in |- *; red in |- *; intros; discriminate. intros p0 Fexp H H0 H1 H2 H3 H4; cut (FtoRradix (Float (Zneg p0) Fexp) <> 0%R :>R); [ intros Neq1; split | idtac ]. apply MaxOppMin; auto. rewrite <- (FcanonicFnormalizeEq _ radixMoreThanOne b precision) with (p := f0); auto with zarith. change (isMax b radix (FtoRradix (Float (Zpos p) e)) (FNSucc b radix precision f0)) in |- *. apply MinMax; auto with arith. rewrite H4. Contradict Neq1. replace 0%R with (FtoR radix f0 - f0)%R; [ pattern (FtoR radix f0) at 1 in |- *; rewrite <- Neq1 | fold FtoRradix in |- * ]; ring. case H2; auto; intros H5; Contradict H5; apply NotR0NotZero; simpl in |- *; red in |- *; intros; discriminate. case H2; clear H2; intros H2; [ Contradict Neq1; auto | idtac ]. rewrite H4. split. apply Rlt_not_eq; auto with real. rewrite (Fopp_correct radix); auto with arith. apply Ropp_lt_contravar. cut (forall x y z, (y < z - x)%R -> (x + y < z)%R); [ intros Rt1; apply Rt1 | idtac ]. unfold FtoRradix in |- *; rewrite <- Fminus_correct; auto with arith. fold FtoRradix in |- *; rewrite (FSuccUlpPos f0); auto with arith. case H1; auto; intros H5; Contradict H4; auto. intros x y z H5; replace z with (x + (z - x))%R; auto with real; ring. auto with float arith. apply NotR0NotZero; simpl in |- *; red in |- *; intros; discriminate. Qed. Definition rCeil (f : float) := match rFloor f with | rExact r => rExact r | rRound r => rRound (FSucc b radix precision r) end. Theorem rCeil_correct : forall f : float, isMax b radix f (rFloat (rCeil f)) /\ match rCeil f with | rExact r => r = f :>R | rRound r => r <> f :>R /\ Fcanonic radix b r end. intros f; generalize (rFloor_correct f); unfold rCeil in |- *; case (rFloor f); simpl in |- *. intros r (H1, H2); split; auto. rewrite <- H2. unfold FtoRradix in |- *; apply RoundedModeProjectorIdem with (b := b) (P := isMax b radix); auto with float. apply MaxRoundedModeP with (precision := precision); auto with arith. case H1; auto. intros r (H1, (H2, H3)); split; [ idtac | split ]; auto. rewrite <- (FcanonicFnormalizeEq _ radixMoreThanOne b precision) with (p := r); auto with zarith. change (isMax b radix (FtoRradix f) (FNSucc b radix precision r)) in |- *. apply MinMax; auto with arith. Contradict H2; rewrite <- H2. apply (MinUniqueP b radix) with (1 := H1). rewrite <- H2. unfold FtoRradix in |- *; apply RoundedModeProjectorIdem with (b := b) (P := isMin b radix). apply MinRoundedModeP with (precision := precision); auto with arith. apply FBoundedSuc; auto with arith. apply FcanonicBound with radix; auto. auto with float arith. Qed. Definition rToZero (f : float) := match f with | Float Z0 e => rExact (Float 0 dExp) | Float (Zpos a) e => rFloor f | Float (Zneg a) e => rCeil f end. Theorem rToZero_correct : forall f : float, ToZeroP b radix f (rFloat (rToZero f)) /\ match rToZero f with | rExact r => r = f :>R | rRound r => r <> f :>R /\ Fcanonic radix b r end. intros f; generalize (rFloor_correct f); generalize (rCeil_correct f); unfold rToZero in |- *; case f. intros a e; case a; auto. simpl in |- *; intros H H0; cut (Float 0 dExp = Float 0 e :>R); [ intros T1; split | idtac ]; auto. rewrite <- T1; unfold FtoRradix in |- *; apply RoundedModeProjectorIdem with (b := b) (P := ToZeroP b radix). apply ToZeroRoundedModeP with (precision := precision); auto with arith. repeat (split; simpl in |- *; auto with zarith). unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. intros p; case (rFloor (Float (Zpos p) e)). intros f1 H1 (H2, H3); split; auto. simpl in |- *; rewrite <- H3. unfold FtoRradix in |- *; apply RoundedModeProjectorIdem with (b := b) (P := ToZeroP b radix). apply ToZeroRoundedModeP with (precision := precision); auto with arith. simpl in H2; case H2; auto. intros f1 H1 (H2, H3); split; auto. left; split; auto. apply (LeFnumZERO radix); simpl in |- *; auto with zarith. intros p; case (rCeil (Float (Zneg p) e)). intros f1 (H2, H3) H1; split; auto. simpl in |- *; rewrite <- H3. unfold FtoRradix in |- *; apply RoundedModeProjectorIdem with (b := b) (P := ToZeroP b radix). apply ToZeroRoundedModeP with (precision := precision); auto with arith. simpl in H2; case H2; auto. intros f1 (H2, H3) H1; split; auto. right; split; auto. apply (LeZEROFnum radix); simpl in |- *; auto with zarith. Qed. Definition ZevenP a := match Fnum a with | Z0 => true | Zpos (xO _) => true | Zneg (xO _) => true | _ => false end. Theorem ZevenP_correct : forall a, match ZevenP a with | true => Feven a | false => Fodd a end. intros a; case a; simpl in |- *. intros n e; case n; unfold ZevenP, Feven, Fodd in |- *; simpl in |- *; auto with arith. apply EvenO. intros p; case p; simpl in |- *; simpl in |- *. intros p1; exists (Zpos p1); rewrite Zpos_xI; ring. intros p1; exists (Zpos p1); rewrite Zpos_xO; ring. apply Odd1. cut (forall x, Zneg x = (- Zpos x)%Z); [ intros th1 | simpl in |- *; auto ]. intros p; case p; simpl in |- *; simpl in |- *. intros p1; exists (Zneg p1 + - (1))%Z; repeat rewrite th1; rewrite Zpos_xI; ring. intros p1; exists (Zneg p1); repeat rewrite th1; rewrite Zpos_xO; ring. exists (- (1))%Z; repeat rewrite th1; ring. Qed. Theorem Fcompare_correct : forall f1 f2 : float, match Fcompare radix f1 f2 with | Datatypes.Eq => f1 = f2 :>R | Datatypes.Lt => (f1 < f2)%R | Datatypes.Gt => (f2 < f1)%R end. intros f1 f2; generalize (Feq_bool_correct_t _ radixMoreThanOne f1 f2); generalize (Flt_bool_correct_t _ radixMoreThanOne f1 f2); generalize (Fle_bool_correct_f _ radixMoreThanOne f1 f2); unfold Flt_bool in |- *; unfold Flt_bool, Fle_bool, Feq_bool, Flt, Fle, Feq in |- *; case (Fcompare radix f1 f2); simpl in |- *; auto. Qed. Definition rClosestEvenPos (a : positive) (e : Z) := match FindMin (vNum b) (Z2pos radix) a dExp e with | (r1, Float Z0 _) => rExact r1 | (r1, r2) => match Fcompare radix (Float 1%nat (Fexp r1)) (Float (2%nat * Fnum r2) (Fexp r2)) with | Datatypes.Lt => rRound (FSucc b radix precision r1) | Datatypes.Gt => rRound r1 | Datatypes.Eq => match ZevenP r1 with | true => rRound r1 | false => rRound (FSucc b radix precision r1) end end end. Definition rOp a := match a with | rExact f => rExact (Fopp f) | rRound f => rRound (Fopp f) end. Definition rClosestEven (f : float) := match f with | Float Z0 e => rExact (Float 0 dExp) | Float (Zpos a) e => rClosestEvenPos a e | Float (Zneg a) e => rOp (rClosestEvenPos a e) end. Opaque FindMin. Theorem RleR0Rminus : forall x y, (x <= y)%R -> (0 <= y - x)%R. intros x y; replace 0%R with (x - x)%R; auto with real. unfold Rminus in |- *; auto with real. Qed. Theorem ClosestMin1 : forall (r : R) (min max : float), isMin b radix r min -> isMax b radix r max -> (r - min <= max - r)%R -> Closest b radix r min. intros r min max H H0 H1; (split; auto). case H; auto. intros f1 Hf1. case (ClosestTotal b radix precision) with (r := r); auto with arith. intros f2 Hf2; case (ClosestMinOrMax b radix) with (r := r) (p := f2); auto with arith. intros H2. replace (FtoR radix min) with (FtoRradix f2); auto. case Hf2; auto. apply (MinUniqueP b radix) with (r := r); auto with arith. intros H2. apply Rle_trans with (Rabs (FtoR radix f2 - r)). 2: case Hf2; auto. replace (Rabs (FtoR radix min - r)) with (r - FtoRradix min)%R. replace (Rabs (FtoR radix f2 - r)) with (FtoRradix max - r)%R; auto. replace (FtoRradix max) with (FtoR radix f2). apply sym_eq; apply Rabs_pos_eq; auto. apply RleR0Rminus. case H2; intros H3 (H4, H5); auto. apply (MaxUniqueP b radix) with (r := r); auto with arith. rewrite Rabs_minus_sym. apply sym_eq; apply Rabs_pos_eq; auto. apply RleR0Rminus. case H; intros H3 (H4, H5); auto. Qed. Theorem ClosestMax1 : forall (r : R) (min max : float), isMin b radix r min -> isMax b radix r max -> (max - r <= r - min)%R -> Closest b radix r max. intros r min max H H0 H1; (split; auto). case H0; auto. intros f1 Hf1. case (ClosestTotal b radix precision) with (r := r); auto with arith. intros f2 Hf2; case (ClosestMinOrMax b radix) with (r := r) (p := f2); auto with arith. intros H2. apply Rle_trans with (Rabs (FtoR radix f2 - r)). 2: case Hf2; auto. replace (Rabs (FtoR radix max - r)) with (FtoRradix max - r)%R. replace (Rabs (FtoR radix f2 - r)) with (r - FtoRradix min)%R; auto. replace (FtoRradix min) with (FtoR radix f2). rewrite Rabs_minus_sym. apply sym_eq; apply Rabs_pos_eq; auto. apply RleR0Rminus. case H2; intros H3 (H4, H5); auto. apply (MinUniqueP b radix) with (r := r); auto with arith. apply sym_eq; apply Rabs_pos_eq; auto. apply RleR0Rminus. case H0; intros H3 (H4, H5); auto. intros H2. replace (FtoR radix max) with (FtoRradix f2); auto. case Hf2; auto. apply (MaxUniqueP b radix) with (r := r); auto with arith. Qed. Theorem ClosestMin2 : forall (r : R) (min max f : float), isMin b radix r min -> isMax b radix r max -> (r - min < max - r)%R -> Closest b radix r f -> f = min :>R. intros r min max f H H0 H1 H2. case (ClosestMinOrMax b radix) with (r := r) (p := f); auto with arith; intros H3. apply (MinUniqueP b radix) with (r := r); auto with arith. Contradict H1; apply Rle_not_lt. replace (FtoRradix max - r)%R with (Rabs (max - r)). replace (r - FtoRradix min)%R with (Rabs (FtoRradix min - r)). cut (Fbounded b min); [ intros Fmin | case H; auto ]. replace (FtoRradix max) with (FtoRradix f). case H2; auto. apply (MaxUniqueP b radix) with (r := r); auto with arith. rewrite Rabs_minus_sym. apply Rabs_pos_eq; auto. apply RleR0Rminus. case H; intros H4 (H5, H6); auto. apply Rabs_pos_eq; auto. apply RleR0Rminus. case H0; intros H4 (H5, H6); auto. Qed. Theorem ClosestMax2 : forall (r : R) (min max f : float), isMin b radix r min -> isMax b radix r max -> (max - r < r - min)%R -> Closest b radix r f -> f = max :>R. intros r min max f H H0 H1 H2. case (ClosestMinOrMax b radix) with (r := r) (p := f); auto with arith; intros H3. cut (Fbounded b max); [ intros Fmax | case H0; auto ]. Contradict H1; apply Rle_not_lt. replace (FtoRradix max - r)%R with (Rabs (max - r)). replace (r - FtoRradix min)%R with (Rabs (f - r)). case H2; auto. rewrite Rabs_minus_sym. replace (FtoRradix min) with (FtoRradix f). apply Rabs_pos_eq; auto. apply RleR0Rminus. case H3; intros H4 (H5, H6); auto. apply (MinUniqueP b radix) with (r := r); auto with arith. apply Rabs_pos_eq; auto. apply RleR0Rminus. case H0; intros H4 (H5, H6); auto. apply (MaxUniqueP b radix) with (r := r); auto with arith. Qed. Theorem EvenClosestMin1 : forall (r : R) (min max : float), isMin b radix r min -> isMax b radix r max -> (r - min < max - r)%R -> EvenClosest b radix precision r min. intros r min max H H0 H1; split. apply ClosestMin1 with (2 := H0); auto with real. right; intros q H2; apply ClosestMin2 with (3 := H1); auto. Qed. Theorem EvenClosestMax1 : forall (r : R) (min max : float), isMin b radix r min -> isMax b radix r max -> (max - r < r - min)%R -> EvenClosest b radix precision r max. intros r min max H H0 H1; split. apply ClosestMax1 with (1 := H); auto with real. right; intros q H2; apply ClosestMax2 with (3 := H1); auto. Qed. Theorem EvenClosestMin2 : forall (r : R) (min max : float), isMin b radix r min -> isMax b radix r max -> (r - min)%R = (max - r)%R -> FNeven b radix precision min -> EvenClosest b radix precision r min. intros r min max H H0 H1 H2; split; auto. apply ClosestMin1 with (2 := H0); auto with real. Qed. Theorem EvenClosestMax2 : forall (r : R) (min max : float), isMin b radix r min -> isMax b radix r max -> (max - r)%R = (r - min)%R -> FNeven b radix precision max -> EvenClosest b radix precision r max. intros r min max H H0 H1; split; auto. apply ClosestMax1 with (1 := H); auto with real. Qed. Theorem EqSpeTwice : forall x y z, (2%nat * (x - y))%R = (z - y)%R -> (x - y)%R = (z - x)%R. intros x y z H. replace (x - y)%R with (2%nat * (x - y) - (x - y))%R; [ idtac | simpl in |- *; ring ]. rewrite H; ring. Qed. Theorem RltSpeTwice1 : forall x y z, (2%nat * (x - y) < z - y)%R -> (x - y < z - x)%R. intros x y z H. replace (x - y)%R with (2%nat * (x - y) - (x - y))%R; [ idtac | simpl in |- *; ring ]. replace (z - x)%R with (z - y - (x - y))%R; [ unfold Rminus in |- *; auto with real | ring ]. Qed. Theorem RltSpeTwice2 : forall x y z, (z - y < 2%nat * (x - y))%R -> (z - x < x - y)%R. intros x y z H. replace (x - y)%R with (2%nat * (x - y) - (x - y))%R; [ idtac | simpl in |- *; ring ]. replace (z - x)%R with (z - y - (x - y))%R; [ unfold Rminus in |- *; auto with real | ring ]. Qed. Theorem rClosestEvenPos_correct : forall (a : positive) (e : Z), EvenClosest b radix precision (Float (Zpos a) e) (rFloat (rClosestEvenPos a e)) /\ match rClosestEvenPos a e with | rExact r => r = Float (Zpos a) e :>R | rRound r => r <> Float (Zpos a) e :>R /\ Fcanonic radix b r end. intros a e; unfold rClosestEvenPos in |- *; generalize (FminOp_correct1 a e); generalize (FminOp_correct2 a e); generalize (FminOp_correct3 a e); generalize (FminOp_correct4 a e); generalize (FminOp_correct5 a e); generalize (FminOp_correct6 a e); generalize (FminOp_correct7 a e); simpl in |- *; case (FindMin (vNum b) (Z2pos radix) a dExp e); simpl in |- *; auto. intros f0 f1; case f1; simpl in |- *; auto. intros a'; case a'; simpl in |- *; auto. intros e' H1 H2 H3 H4 H5 H6 H7; split; auto. replace (FtoRradix (Float (Zpos a) e)) with (FtoRradix f0); auto with float arith. unfold FtoRradix in |- *; apply RoundedModeProjectorIdem with (b := b) (P := EvenClosest b radix precision). apply EvenClosestRoundedModeP; auto with arith. case H1; simpl in |- *; auto. rewrite H7; unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. rewrite H7; unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. intros a'' e' H1 H2 H3 H4 H5 H6 H7. cut (FtoRradix (Float (Zpos a'') e') <> 0%R :>R); [ intros NR1 | idtac ]. cut (Float (Zpos a) e <> f0 :>R); [ intros NR | idtac ]. case H4; clear H4; intros H4; [ Contradict NR1; auto | idtac ]. case H3; clear H3; intros H3; [ Contradict NR1; auto | idtac ]. generalize (Fcompare_correct (Float 1 (Fexp f0)) (Float (Zpos (xO a'')) e')); case (Fcompare radix (Float 1 (Fexp f0)) (Float (Zpos (xO a'')) e')). generalize (ZevenP_correct f0); case (ZevenP f0); auto. intros H8 H9; split; [ idtac | split ]; auto. simpl in |- *; apply EvenClosestMin2 with (max := FNSucc b radix precision f0); auto. apply MinMax; auto; auto with arith. apply EqSpeTwice; auto. apply sym_eq. replace (2%nat * (FtoRradix (Float (Zpos a) e) - FtoRradix f0))%R with (FtoRradix (Float 1 (Fexp f0))). rewrite <- (Fminus_correct radix); auto with arith. rewrite FNSuccUlpPos; auto. unfold Fulp in |- *. rewrite FcanonicFnormalizeEq; auto with arith. unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. rewrite H9; rewrite H7; unfold FtoRradix, FtoR in |- *; simpl in |- *. replace (INR (nat_of_P (xO a''))) with (nat_of_P a'' + nat_of_P a'')%R. ring. rewrite <- plus_INR; unfold nat_of_P in |- *; simpl in |- *; rewrite ZL6; auto. unfold FNeven in |- *. rewrite FcanonicFnormalizeEq; auto with arith. intros H8 H9; split; [ idtac | split ]; auto. simpl in |- *; apply EvenClosestMax2 with (min := f0); auto. rewrite <- (FcanonicFnormalizeEq _ radixMoreThanOne b precision) with (p := f0); auto with arith. change (isMax b radix (FtoRradix (Float (Zpos a) e)) (FNSucc b radix precision f0)) in |- *; apply MinMax; auto with arith. apply sym_eq; apply EqSpeTwice; auto. apply sym_eq. replace (2%nat * (FtoRradix (Float (Zpos a) e) - FtoRradix f0))%R with (FtoRradix (Float 1 (Fexp f0))). rewrite <- (Fminus_correct radix); auto with arith. rewrite FSuccUlpPos; auto. unfold Fulp in |- *. rewrite FcanonicFnormalizeEq; auto with arith. unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. rewrite H9; rewrite H7; unfold FtoRradix, FtoR in |- *; simpl in |- *. replace (INR (nat_of_P (xO a''))) with (nat_of_P a'' + nat_of_P a'')%R. ring. rewrite <- plus_INR; unfold nat_of_P in |- *; simpl in |- *; rewrite ZL6; auto. rewrite <- (FcanonicFnormalizeEq _ radixMoreThanOne b precision) with (p := f0); auto with arith. change (FNeven b radix precision (FNSucc b radix precision f0)) in |- *; apply FNoddSuc; auto with arith. unfold FNodd in |- *. rewrite FcanonicFnormalizeEq; auto with arith. apply Rgt_not_eq. red in |- *; rewrite H7. replace (FtoRradix (FSucc b radix precision f0)) with (FtoRradix f0 + (FSucc b radix precision f0 - FtoRradix f0))%R. apply Rplus_lt_compat_l. rewrite <- (Fminus_correct radix); auto with arith. rewrite FSuccUlpPos; auto. ring. auto with float arith. intros H8; split; [ idtac | split ]; auto. simpl in |- *; apply EvenClosestMax1 with (min := f0); auto with float arith. rewrite <- (FcanonicFnormalizeEq _ radixMoreThanOne b precision) with (p := f0); auto with arith. change (isMax b radix (FtoRradix (Float (Zpos a) e)) (FNSucc b radix precision f0)) in |- *; apply MinMax; auto with arith. apply RltSpeTwice2. replace (2%nat * (FtoRradix (Float (Zpos a) e) - FtoRradix f0))%R with (FtoRradix (Float (Zpos (xO a'')) e')). rewrite <- (Fminus_correct radix); auto with arith. rewrite FSuccUlpPos; auto. unfold Fulp in |- *. rewrite FcanonicFnormalizeEq; auto with arith. replace (powerRZ radix (Fexp f0)) with (FtoRradix (Float 1 (Fexp f0))); auto. unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. rewrite H7; unfold FtoRradix, FtoR in |- *; simpl in |- *. replace (INR (nat_of_P (xO a''))) with (nat_of_P a'' + nat_of_P a'')%R. ring. rewrite <- plus_INR; unfold nat_of_P in |- *; simpl in |- *; rewrite ZL6; auto. apply Rgt_not_eq. red in |- *; rewrite H7. replace (FtoRradix (FSucc b radix precision f0)) with (FtoRradix f0 + (FSucc b radix precision f0 - FtoRradix f0))%R. apply Rplus_lt_compat_l. rewrite <- (Fminus_correct radix); auto with arith. rewrite FSuccUlpPos; auto. ring. auto with float arith. intros H8; split; [ idtac | split ]; auto. simpl in |- *; apply EvenClosestMin1 with (max := FNSucc b radix precision f0); auto with float arith. apply RltSpeTwice1. replace (2%nat * (FtoRradix (Float (Zpos a) e) - FtoRradix f0))%R with (FtoRradix (Float (Zpos (xO a'')) e')). rewrite <- (Fminus_correct radix); auto with arith. rewrite FNSuccUlpPos; auto. unfold Fulp in |- *. rewrite FcanonicFnormalizeEq; auto with arith. replace (powerRZ radix (Fexp f0)) with (FtoRradix (Float 1 (Fexp f0))); auto. unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. rewrite H7; unfold FtoRradix, FtoR in |- *; simpl in |- *. replace (INR (nat_of_P (xO a''))) with (nat_of_P a'' + nat_of_P a'')%R. ring. rewrite <- plus_INR; unfold nat_of_P in |- *; simpl in |- *; rewrite ZL6; auto. Contradict NR1; replace 0%R with (Float (Zpos a) e - Float (Zpos a) e)%R; [ idtac | ring ]. pattern (Float (Zpos a) e) at 2 in |- *; rewrite H7; rewrite NR1; ring. apply NotR0NotZero; simpl in |- *; red in |- *; intros; discriminate. intros p Fexp H H0 H1 H2 H3 H4; Contradict H4. apply Rlt_not_le. unfold FtoRradix, FtoR in |- *; simpl in |- *. replace 0%R with (-0 * powerRZ radix Fexp)%R; auto with real arith. Qed. Theorem rClosestEven_correct : forall f : float, EvenClosest b radix precision f (rFloat (rClosestEven f)) /\ match rClosestEven f with | rExact r => r = f :>R | rRound r => r <> f :>R /\ Fcanonic radix b r end. intros f; case f; intros a e; case a; simpl in |- *. split; auto. replace (FtoRradix (Float 0 e)) with (FtoRradix (Float 0 dExp)). unfold FtoRradix in |- *; apply RoundedModeProjectorIdem with (b := b) (P := EvenClosest b radix precision); auto with float arith. repeat (split; simpl in |- *; auto with zarith). unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. intros p; simpl in |- *; apply rClosestEvenPos_correct. intros p; generalize (rClosestEvenPos_correct p e); case (rClosestEvenPos p e); simpl in |- *; auto. intros f1 (H1, H2); replace (Float (Zneg p) e) with (Fopp (Float (Zpos p) e)); try repeat rewrite (Fopp_correct radix); split; auto with real. apply (EvenClosestSymmetric b radix precision); auto with arith. intros f1 (H1, (H2, H3)); replace (Float (Zneg p) e) with (Fopp (Float (Zpos p) e)); try repeat rewrite (Fopp_correct radix); split; [ idtac | split ]; auto with real float. apply (EvenClosestSymmetric b radix precision); auto with arith zarith. fold FtoRradix in |- *; Contradict H2; rewrite <- Ropp_involutive; rewrite <- H2; auto with real. Qed. End FminOp. Transparent Pdiv. Transparent PdivBound. Transparent FindMin. Float8.4/Others/FroundDivSqrt.v0000644000423700002640000014474412032774527016275 0ustar sboldotoccata(**************************************************************************** IEEE754 : FroundDivSqrt Sylvie Boldo ******************************************************************************) Require Export AllFloat. Require Export Classical. Section FroundDiv. Variable b : Fbound. Variable radix : Z. Variable precision : 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 precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. Theorem NearestInteger : forall (r : R) (n : Z), (forall z : Z, (Rabs (n - r) <= Rabs (z - r))%R) -> (Rabs (n - r) <= / 2)%R. intros r n H. case (Rle_or_lt (Rabs (n - r)) (/ 2)); auto; intros H1; Contradict H. apply ex_not_not_all with (U := Z) (P := fun t : Z => (Rabs (n - r) <= Rabs (t - r))%R). generalize H1; case (Rcase_abs (n - r)); intros H2. repeat rewrite Rabs_left; auto; intros H3. 2: repeat rewrite Rabs_right; auto; intros H3. exists (Zsucc n); apply Rlt_not_le. case (Rcase_abs (Zsucc n - r)); intros H4; [ rewrite Rabs_left | rewrite Rabs_right ]; auto. apply Ropp_lt_contravar; unfold Rminus in |- *; apply Rplus_lt_compat_r; auto with zarith real. apply Rlt_trans with (2 := H3); apply Rplus_lt_reg_r with (-1)%R. replace (-1 + (Zsucc n - r))%R with (n - r)%R; [ idtac | unfold Zsucc in |- *; rewrite plus_IZR; simpl in |- *; ring ]. replace (-1 + / 2)%R with (- / 2)%R; [ idtac | field; auto with real ]. apply Ropp_lt_cancel; rewrite Ropp_involutive; auto. exists (Zpred n); apply Rlt_not_le. case (Rcase_abs (Zpred n - r)); intros H4; [ rewrite Rabs_left | rewrite Rabs_right ]; auto. apply Rlt_trans with (2 := H3); apply Ropp_lt_cancel; rewrite Ropp_involutive; auto. apply Rplus_lt_reg_r with 1%R. replace (1 + (Zpred n - r))%R with (n - r)%R; [ idtac | unfold Zpred in |- *; rewrite plus_IZR; simpl in |- *; ring ]. replace (1 + - / 2)%R with (/ 2)%R; [ auto | field; auto with real ]. unfold Rminus in |- *; apply Rplus_lt_compat_r; auto with zarith real. Qed. Theorem errorBoundedModulo_aux : forall (x y : float) (n : Z), Fbounded b x -> Fcanonic radix b x -> Fbounded b y -> Fcanonic radix b y -> FtoRradix y <> 0%R -> (0 < y)%R -> (0 <= x)%R -> (forall z : Z, (Rabs (n - x / y) <= Rabs (z - x / y))%R) -> Fbounded b (Fminus radix x (Fmult (Float n 0) y)). intros x y n Fx Cx Fy Cy Hy Py Px Hn. cut (/ 2 <= 1)%R; [ intros V | idtac ]. 2: pattern 1%R at 3 in |- *; rewrite <- Rinv_1; apply Rle_Rinv; auto with real. case (Zle_or_lt (Fexp y) (Fexp x)); intros H1. split; [ idtac | simpl in |- *; rewrite Zmin_le2; auto with float ]. apply Zlt_Rlt; rewrite <- Faux.Rabsolu_Zabs. replace (IZR (Fnum (Fminus radix x (Fmult (Float n 0) y)))) with (Fminus radix x (Fmult (Float n 0) y) * powerRZ radix (- Fexp (Fminus radix x (Fmult (Float n 0) y))))%R. 2: unfold FtoRradix in |- *; unfold FtoR in |- *; rewrite Rmult_assoc. 2: rewrite <- powerRZ_add; auto with real zarith. 2: ring_simplify (Fexp (Fminus radix x (Fmult (Float n 0) y)) + - Fexp (Fminus radix x (Fmult (Float n 0) y)))%Z; auto with real. simpl in |- *; rewrite Zmin_le2; auto; rewrite Rabs_mult. rewrite (Rabs_right (powerRZ radix (- Fexp y))); [ idtac | apply Rle_ge; auto with real zarith ]. unfold FtoRradix in |- *; rewrite Fminus_correct; auto; rewrite Fmult_correct; auto; fold FtoRradix in |- *. replace (FtoRradix (Float n 0)) with (IZR n); [ idtac | unfold FtoRradix, FtoR in |- *; simpl in |- *; ring ]. replace (FtoRradix x - n * FtoRradix y)%R with (FtoRradix y * (FtoRradix x / FtoRradix y - n))%R; [ idtac| field; auto with real]. rewrite Rabs_mult; apply Rle_lt_trans with (Rabs (FtoRradix y) * 1 * powerRZ radix (- Fexp y))%R. apply Rmult_le_compat_r; auto with real zarith. apply Rmult_le_compat_l; auto with real. rewrite <- Rabs_Ropp; apply Rle_trans with (/ 2)%R; auto. replace (- (FtoRradix x / FtoRradix y - n))%R with (n - x / y)%R; [ idtac | ring ]. apply NearestInteger; auto. unfold FtoRradix in |- *; rewrite <- Fabs_correct; auto with zarith; unfold FtoR in |- *; simpl in |- *. apply Rle_lt_trans with (IZR (Zabs (Fnum y))); [ right | auto with float zarith real ]. ring_simplify;rewrite Rmult_assoc;rewrite <- powerRZ_add; auto with zarith real. ring_simplify ( Fexp y +- Fexp y)%Z; simpl; ring. replace (INR (nat_of_P (vNum b))) with (IZR (Zpos (vNum b))); auto with float zarith real. case (Req_dec n 0); intros H'0. cut (n = 0%Z); [ intros H2 | apply eq_IZR; auto ]. rewrite H2; unfold Fmult, Fminus, Fopp, Fplus in |- *; simpl in |- *; rewrite Zmin_le1; auto with zarith; simpl in |- *; ring_simplify (Fexp x - Fexp x)%Z; simpl in |- *. replace (Zpower_nat radix 0) with 1%Z; [ ring_simplify (Fnum x * 1 + 0)%Z | simpl in |- * ]; auto with float. case (Req_dec n 1); intros H'1. cut (n = 1%Z); [ intros H2 | apply eq_IZR; auto ]. replace (Fmult (Float n 0) y) with y; [ idtac | unfold Fmult in |- *; rewrite H2; auto with float zarith; simpl in |- * ]. 2: apply floatEq; simpl in |- *; auto with zarith float; case (Fnum y); auto with zarith. apply Sterbenz; auto; fold FtoRradix in |- *. apply Rmult_le_reg_l with (/ y)%R; auto with real. apply Rle_trans with (/ 2%nat * (FtoRradix y * / FtoRradix y))%R; [ right; ring | rewrite Rinv_r; auto ]. ring_simplify (/ 2%nat * 1)%R; apply Rplus_le_reg_l with (/ 2%nat + - (/ FtoRradix y * FtoRradix x))%R. ring_simplify (/ 2%nat + - (/ FtoRradix y * FtoRradix x) + / FtoRradix y * FtoRradix x)%R. replace (/ FtoRradix y * FtoRradix x)%R with (FtoRradix x / FtoRradix y)%R; [ idtac | unfold Rdiv in |- *; ring ]. apply Rle_trans with (/ 2%nat + / 2%nat - FtoRradix x / FtoRradix y)%R; [ right; ring | idtac ]. replace (/ 2%nat + / 2%nat)%R with 1%R; [ idtac | simpl; field; auto with real ]. apply Rle_trans with (Rabs (1 - FtoRradix x / FtoRradix y)); [ apply RRle_abs | rewrite <- H'1 ]. apply NearestInteger; auto. apply Rmult_le_reg_l with (/ y)%R; auto with real. apply Rle_trans with (2%nat * (FtoRradix y * / FtoRradix y))%R; [ rewrite Rinv_r; auto | right; ring ]. ring_simplify (2%nat * 1)%R; apply Rplus_le_reg_l with (-1)%R. apply Rle_trans with (- (1 - FtoRradix x / FtoRradix y))%R; [ right; unfold Rdiv in |- *; ring | idtac ]. apply Rle_trans with (Rabs (- (1 - FtoRradix x / FtoRradix y))); [ apply RRle_abs | rewrite <- H'1; rewrite Rabs_Ropp ]. apply Rle_trans with (/ 2)%R; [ apply NearestInteger; auto | rewrite H'1 ]. apply Rle_trans with 1%R; [ auto | simpl in |- *; right; ring ]. cut (n <> 1%Z); [ intros H''1 | Contradict H'1; rewrite H'1; auto with real zarith ]. cut (n <> 0%Z); [ intros H''0 | Contradict H'0; rewrite H'0; auto with real zarith ]. cut (n <= 1)%Z; [ intros H'3 | idtac ]. cut (0 <= n)%Z; [ intros H'2; absurd (IZR n <> 0%Z); auto with zarith | idtac ]. apply Zlt_succ_le; apply lt_IZR; simpl in |- *. apply Rle_lt_trans with (FtoRradix x / FtoRradix y)%R; auto with real. unfold Rdiv in |- *; apply Rmult_le_pos; auto with real. unfold Zsucc in |- *; simpl in |- *; apply Rplus_lt_reg_r with (- n)%R. apply Rle_lt_trans with (- (n - FtoRradix x / FtoRradix y))%R; [ right; ring | idtac ]. apply Rle_lt_trans with (Rabs (- (n - FtoRradix x / FtoRradix y))); [ apply RRle_abs | rewrite Rabs_Ropp ]. apply Rle_lt_trans with (/ 2)%R; [ apply NearestInteger; auto | idtac ]. rewrite plus_IZR; ring_simplify (- n + (n + 1%Z))%R. simpl; pattern 1%R at 3 in |- *; rewrite <- Rinv_1; apply Rinv_lt_contravar; auto with real. ring_simplify (1 * 2)%R; auto with real. apply Zlt_succ_le; apply lt_IZR; simpl in |- *. apply Rlt_le_trans with (n + (1 + - (FtoRradix x / FtoRradix y)))%R. apply Rplus_lt_reg_r with (-1 + - n)%R. ring_simplify. apply Ropp_lt_contravar; apply Rmult_lt_reg_l with (FtoRradix y); auto with real. unfold Rdiv in |- *; rewrite Rmult_comm; rewrite Rmult_assoc; rewrite Rinv_l; auto. ring_simplify. unfold FtoRradix in |- *; apply FcanonicPosFexpRlt with b precision; auto with real arith. apply Rle_trans with (1 + (n - FtoRradix x / FtoRradix y))%R; [ right; ring | apply Rplus_le_compat_l ]. apply Rle_trans with (Rabs (n - FtoRradix x / FtoRradix y)); [ apply RRle_abs | idtac ]. apply Rle_trans with (/ 2)%R; [ apply NearestInteger; auto | auto ]. Qed. Theorem errorBoundedModulo_aux_y : forall (x y : float) (n : Z), Fbounded b x -> Fcanonic radix b x -> Fbounded b y -> Fcanonic radix b y -> FtoRradix y <> 0%R -> (0 <= x)%R -> (forall z : Z, (Rabs (n - x / y) <= Rabs (z - x / y))%R) -> Fbounded b (Fminus radix x (Fmult (Float n 0) y)). intros x y n Fx Cx Fy Cy Hy Px Hn. case (Rle_or_lt 0 y); intros H1. case H1; intros H2. apply errorBoundedModulo_aux; auto. absurd (FtoRradix y = 0%R); auto with real. replace (Fmult (Float n 0) y) with (Fmult (Float (- n) 0) (Fopp y)). 2: unfold Fopp, Fmult in |- *; simpl in |- *; apply floatEq; simpl in |- *; ring. apply errorBoundedModulo_aux; unfold FtoRradix in |- *; repeat rewrite Fopp_correct; fold FtoRradix in |- *; auto with float real. intros z; rewrite Ropp_Ropp_IZR. rewrite <- Rabs_Ropp; rewrite <- (Rabs_Ropp (z - FtoRradix x / - FtoRradix y)). replace (- (- n - FtoRradix x / - FtoRradix y))%R with (n - FtoRradix x / FtoRradix y)%R; [ idtac | unfold Rdiv in |- *; rewrite <- Ropp_inv_permute; auto; ring ]. replace (- (z - FtoRradix x / - FtoRradix y))%R with (- z - FtoRradix x / FtoRradix y)%R; [ idtac | unfold Rdiv in |- *; rewrite <- Ropp_inv_permute; auto; ring ]. rewrite <- Ropp_Ropp_IZR; apply Hn; auto. Qed. Theorem errorBoundedModuloCan : forall (x y : float) (n : Z), Fbounded b x -> Fcanonic radix b x -> Fbounded b y -> Fcanonic radix b y -> FtoRradix y <> 0%R -> (forall z : Z, (Rabs (n - x / y) <= Rabs (z - x / y))%R) -> Fbounded b (Fminus radix x (Fmult (Float n 0) y)). intros x y n Fx Cx Fy Cy Hy Hn. case (Rle_or_lt 0 x); intros H1. apply errorBoundedModulo_aux_y; auto. replace (Fminus radix x (Fmult (Float n 0) y)) with (Fopp (Fminus radix (Fopp x) (Fmult (Float (- n) 0) y))). 2: unfold Fminus, Fopp, Fmult, Fplus in |- *; simpl in |- *; apply floatEq; simpl in |- *; ring. apply oppBounded. apply errorBoundedModulo_aux_y; unfold FtoRradix in |- *; repeat rewrite Fopp_correct; fold FtoRradix in |- *; auto with float real. intros z; rewrite Ropp_Ropp_IZR. rewrite <- Rabs_Ropp; rewrite <- (Rabs_Ropp (z - - FtoRradix x / FtoRradix y)). replace (- (- n - - FtoRradix x / FtoRradix y))%R with (n - FtoRradix x / FtoRradix y)%R; [ idtac | unfold Rdiv in |- *; ring ]. replace (- (z - - FtoRradix x / FtoRradix y))%R with (- z - FtoRradix x / FtoRradix y)%R; [ idtac | unfold Rdiv in |- *; ring ]. rewrite <- Ropp_Ropp_IZR; apply Hn; auto. Qed. Theorem errorBoundedRem : forall (x y : float) (n : Z), (Fbounded b x) -> (Fbounded b y) -> y <> 0 :>R -> (forall z : Z, (Rabs (n - x / y) <= Rabs (z - x / y))%R) -> (Fbounded b (Fminus radix (Fnormalize radix b precision x) (Fmult (Float n 0) (Fnormalize radix b precision y)))). intros x y n Fx Fy Hy Hn. apply errorBoundedModuloCan; auto with float. apply FnormalizeBounded; auto with arith. apply FnormalizeCanonic; auto with arith. apply FnormalizeBounded; auto with arith. apply FnormalizeCanonic; auto with arith. unfold FtoRradix in |- *; rewrite FnormalizeCorrect; auto. unfold FtoRradix in |- *; repeat rewrite FnormalizeCorrect; auto. Qed. Theorem errorBoundedDiv : forall (x y q : float) P, (RoundedModeP b radix P) -> (Fbounded b x) -> (Fbounded b y) -> (Fbounded b q) -> y <> 0 :>R -> (P (x / y)%R q) -> (- dExp b <= Fexp q + Fexp y)%Z -> (Rabs q) <> (powerRZ radix (- dExp b)) \/ ((powerRZ radix (- dExp b)) / 2%nat <= Rabs (x / y))%R -> (Fbounded b (Fminus radix x (Fmult q y))). intros x y q P HP Fx Fy Fq H1 H2 H3 H'. cut (FtoRradix q = Fnormalize radix b precision q); [ intros Hq | apply sym_eq; unfold FtoRradix in |- *; apply FnormalizeCorrect; auto ]. cut (Fcanonic radix b (Fnormalize radix b precision q)); [ intros Cq | apply FnormalizeCanonic; auto with arith ]. cut (FtoRradix y = Fnormalize radix b precision y); [ intros Hy | apply sym_eq; unfold FtoRradix in |- *; apply FnormalizeCorrect; auto ]. cut (Fcanonic radix b (Fnormalize radix b precision y)); [ intros Cy | apply FnormalizeCanonic; auto with arith ]. case (Zle_or_lt (Fexp q + Fexp y) (Fexp x)); intros H4. split; [ idtac | simpl in |- *; rewrite Zmin_le2; auto ]. apply Zlt_Rlt; rewrite <- Faux.Rabsolu_Zabs. replace (IZR (Fnum (Fminus radix x (Fmult q y)))) with (Fminus radix x (Fmult q y) * powerRZ radix (- Fexp (Fminus radix x (Fmult q y))))%R. 2: unfold FtoRradix in |- *; unfold FtoR in |- *; rewrite Rmult_assoc. 2: rewrite <- powerRZ_add; auto with real zarith. 2: ring_simplify (Fexp (Fminus radix x (Fmult q y)) + - Fexp (Fminus radix x (Fmult q y)))%Z; auto with real. simpl in |- *; rewrite Zmin_le2; auto; rewrite Rabs_mult. rewrite (Rabs_right (powerRZ radix (- (Fexp q + Fexp y)))); [ idtac | apply Rle_ge; auto with real zarith ]. unfold FtoRradix in |- *; rewrite Fminus_correct; auto; rewrite Fmult_correct; auto; fold FtoRradix in |- *. replace (FtoRradix x - FtoRradix q * FtoRradix y)%R with (FtoRradix y * (FtoRradix x / FtoRradix y - FtoRradix q))%R; [ rewrite Rabs_mult | idtac ]. 2: field; auto with real. apply Rle_lt_trans with (Rabs (FtoRradix y) * Fulp b radix precision q * powerRZ radix (- (Fexp q + Fexp y)))%R. apply Rmult_le_compat_r; auto with real zarith. apply Rmult_le_compat_l; auto with real. apply Rlt_le; unfold FtoRradix in |- *; apply RoundedModeUlp with P; auto. unfold FtoRradix in |- *; rewrite <- Fabs_correct; auto with zarith; unfold FtoR, Fulp in |- *; simpl in |- *. repeat rewrite Rmult_assoc; repeat rewrite <- powerRZ_add; auto with real zarith. apply Rle_lt_trans with (Zabs (Fnum y) * powerRZ radix 0)%R; [ apply Rmult_le_compat_l; auto with zarith real | idtac ]. ring_simplify (Fexp y + (Fexp (Fnormalize radix b precision q) + - (Fexp q + Fexp y)))%Z; apply Rle_powerRZ; auto with zarith real. apply Zplus_le_reg_l with (Fexp q). ring_simplify. apply FcanonicLeastExp with radix b precision; auto with arith. simpl in |- *; ring_simplify (Zabs (Fnum y) * 1)%R. apply Rlt_le_trans with (IZR (Zpos (vNum b))); auto with float zarith real. case (Req_dec q 0); intros H5. replace (Fminus radix x (Fmult q y)) with x; auto. unfold Fminus, Fmult, Fopp, Fplus in |- *; simpl in |- *; rewrite Zmin_le1; auto with zarith. replace (Fnum q) with 0%Z; ring_simplify (Fexp x - Fexp x)%Z. ring_simplify (- (0 * Fnum y) * Zpower_nat radix (Zabs_nat (Fexp q + Fexp y - Fexp x)))%Z. ring_simplify (Fnum x * Zpower_nat radix (Zabs_nat 0) + 0)%Z. apply floatEq; auto with zarith. replace (Zpower_nat radix (Zabs_nat 0)) with 1%Z; [ ring_simplify (1 * Fnum x)%Z ; simpl| idtac ]; auto with zarith. cut (is_Fzero q); [ unfold is_Fzero in |- * | apply is_Fzero_rep2 with radix ]; auto. case (Zle_or_lt (Zabs (Fnum (Fnormalize radix b precision q))) 1); intros H6. split; [ idtac | simpl in |- *; rewrite Zmin_le1; auto with zarith float ]. apply Zle_lt_trans with (Zabs (Fnum x)); auto with float. apply Zle_Rle; repeat rewrite <- Faux.Rabsolu_Zabs. apply Rmult_le_reg_l with (powerRZ radix (Fexp x)); auto with zarith real. rewrite <- (Rabs_right (powerRZ radix (Fexp x))); [ idtac | apply Rle_ge; auto with zarith real ]. repeat rewrite <- Rabs_mult. replace (powerRZ radix (Fexp x) * Fnum x)%R with (FtoRradix x); [ idtac | unfold FtoRradix, FtoR in |- *; simpl in |- *; ring ]. replace (powerRZ radix (Fexp x) * Fnum (Fminus radix x (Fmult q y)))%R with (FtoRradix (Fminus radix x (Fmult q y))). 2: unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite Zmin_le1; auto with zarith; ring. unfold FtoRradix in |- *; rewrite Fminus_correct; auto; rewrite Fmult_correct; auto; fold FtoRradix in |- *. replace (FtoRradix x - FtoRradix q * FtoRradix y)%R with (FtoRradix y * (FtoRradix x / FtoRradix y - FtoRradix q))%R; [ rewrite Rabs_mult | idtac ]. 2: field; auto with real. cut (0 < Rabs y)%R; [ intros V | idtac ]. 2: cut (0 <= Rabs y)%R; [ intros V'; case V'; intros W | idtac ]; auto with real. 2: Contradict W; apply not_eq_sym; apply Rabs_no_R0; auto. apply Rmult_le_reg_l with (/ Rabs (FtoRradix y))%R; auto with real. rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real. ring_simplify (1 * Rabs (FtoRradix x / FtoRradix y - FtoRradix q))%R. rewrite <- Rabs_Rinv; auto; rewrite <- Rabs_mult. replace (/ FtoRradix y * FtoRradix x)%R with (FtoRradix x / FtoRradix y)%R; [ idtac | unfold Rdiv in |- *; ring ]. cut (forall s t : R, (Rabs t / 2%nat <= Rabs s)%R -> (Rabs s <= 2%nat * Rabs t)%R -> (0 <= s * t)%R -> (Rabs (s - t) <= Rabs s)%R); [ intros W | idtac ]. cut (Fabs (Fnormalize radix b precision q) = Float 1 (- dExp b)); [ intros D | idtac ]. cut (Rabs (FtoRradix q) = powerRZ radix (- dExp b)); [ intros H7 | idtac ]. 2: rewrite Hq; unfold FtoRradix in |- *; rewrite <- Fabs_correct; auto. 2: rewrite D; unfold FtoR in |- *; simpl in |- *; ring. apply W. rewrite H7; case H'; intros H8; auto. absurd (Rabs (FtoRradix q) = powerRZ radix (- dExp b)); auto with real. apply Rle_trans with (Rabs (FtoRradix q) + Fulp b radix precision q)%R. apply Rplus_le_reg_l with (- Rabs (FtoRradix q))%R. ring_simplify. apply Rle_trans with (Rabs (FtoRradix x / FtoRradix y - FtoRradix q)). apply Rle_trans with (Rabs (FtoRradix x / FtoRradix y) - Rabs (FtoRradix q))%R; [ right; ring | apply Rabs_triang_inv ]. apply Rlt_le; unfold FtoRradix in |- *; apply RoundedModeUlp with P; auto. rewrite FulpComp with (b := b) (radix := radix) (precision := precision) (q := Fnormalize radix b precision q); auto with float real zarith. rewrite H7; unfold FtoRradix in |- *; rewrite FulpFabs; auto; fold FtoRradix in |- *; rewrite D; simpl in |- *; right. replace (Fulp b radix precision (Float 1 (- dExp b))) with (powerRZ radix (- dExp b)); [ ring | unfold Fulp in |- * ]. replace (Fnormalize radix b precision (Float 1 (- dExp b))) with (Float 1 (- dExp b)); [ simpl in |- * | idtac ]; auto with float zarith real. cut (Fbounded b (Float 1 (- dExp b))); [ intros tmp | idtac ]. apply FcanonicUnique with radix b precision; auto with float zarith real. right; repeat (split; simpl in |- *; auto with zarith float). ring_simplify (radix * 1)%Z; rewrite Zabs_eq; auto with zarith. replace radix with (Zpower_nat radix 1); [ rewrite pGivesBound | unfold Zpower_nat in |- *; simpl in |- * ]; auto with zarith float. apply sym_eq; apply FnormalizeCorrect; auto. repeat (split; simpl in |- *; auto with zarith float). rewrite pGivesBound; replace 1%Z with (Zpower_nat radix 0); auto with zarith float. case (Rle_or_lt 0 (FtoRradix x / FtoRradix y)); intros H8. apply Rmult_le_pos; auto. unfold FtoRradix in |- *; apply RleRoundedR0 with b precision P (FtoRradix x / FtoRradix y)%R; auto. apply Ropp_le_cancel; rewrite Ropp_0; rewrite <- Ropp_mult_distr_l_reverse. replace 0%R with (- (FtoRradix x / FtoRradix y) * 0)%R; [ apply Rmult_le_compat_l; auto with real | ring ]. unfold FtoRradix in |- *; apply RleRoundedLessR0 with b precision P (FtoRradix x / FtoRradix y)%R; auto with real. apply floatEq; simpl in |- *; auto with zarith. cut (forall z : Z, (0 <= z)%Z -> z <> 0%Z -> (z <= 1)%Z -> z = 1%Z); [ intros X | auto with zarith ]. apply X; auto with zarith. cut (Rabs (FtoRradix q) <> 0%R); [ rewrite Hq; intros H7; Contradict H7 | apply Rabs_no_R0; auto with real ]. unfold FtoRradix in |- *; rewrite <- Fabs_correct; auto. unfold Zabs, FtoR in |- *; simpl in |- *; rewrite H7; simpl; ring. case Cq; intros H; elim H; intros H7 H8; auto with float zarith. absurd (Zpos (vNum b) <= radix)%Z; [ apply Zlt_not_le | apply Zle_trans with (1 := H8) ]. replace radix with (Zpower_nat radix 1); [ rewrite pGivesBound | unfold Zpower_nat in |- *; simpl in |- * ]; auto with zarith float. rewrite Zabs_Zmult; rewrite Zabs_eq; auto with zarith. apply Zle_trans with (radix * 1)%Z; auto with zarith. intros s t H; cut (Rabs t <= 2 * Rabs s)%R; simpl in |- *. case (Rcase_abs t); case (Rcase_abs s); intros H'1 H'2; unfold Rminus in |- *. rewrite (Rabs_left t); auto; rewrite (Rabs_left s); auto; intros H'3 H'4 H'5. case (Rcase_abs (s + - t)); intros H'6. rewrite Rabs_left; auto with real. ring_simplify (- (s + - t))%R; apply Rle_trans with ( - s+0)%R; auto with real. rewrite Rabs_right; auto with real. apply Rplus_le_reg_l with (- s)%R; ring_simplify. apply Rle_trans with (1 := H'3); right; ring. rewrite (Rabs_left t); auto; rewrite (Rabs_right s); auto; intros H'3 H'4 H'5. cut (0 <= s)%R; [ intros H'6; case H'6; intros H'7 | idtac ]; auto with real. Contradict H'5; apply Rlt_not_le; apply Ropp_lt_cancel; rewrite Ropp_0; rewrite Rmult_comm; rewrite <- Ropp_mult_distr_l_reverse. apply Rmult_lt_0_compat; auto with real. rewrite <- H'7; replace (- t)%R with 0%R; auto with real. ring_simplify (0 + 0)%R; rewrite Rabs_R0; auto with real. apply Rle_antisym; auto with real. apply Rle_trans with (1 := H'3); rewrite <- H'7; right; ring. rewrite (Rabs_right t); auto; rewrite (Rabs_left s); auto; intros H'3 H'4 H'5. cut (0 <= t)%R; [ intros H'6; case H'6; intros H'7 | idtac ]; auto with real. Contradict H'5; apply Rlt_not_le; apply Ropp_lt_cancel; rewrite Ropp_0; rewrite <- Ropp_mult_distr_l_reverse. apply Rmult_lt_0_compat; auto with real. rewrite <- H'7; replace s with 0%R; auto with real. ring_simplify (0 + -0)%R; rewrite Rabs_R0; auto with real. apply Rle_antisym; auto with real. apply Ropp_le_cancel; rewrite Ropp_0. replace 0%R with (2 * t)%R; [ auto | rewrite <- H'7; ring ]. rewrite (Rabs_right t); auto; rewrite (Rabs_right s); auto; intros H'3 H'4 H'5. case (Rcase_abs (s + - t)); intros H'6. rewrite Faux.Rabsolu_left1; auto with real. apply Rplus_le_reg_l with s; ring_simplify (s + - (s + - t))%R; auto with real. apply Rle_trans with (1 := H'3); right; ring. rewrite Rabs_right; auto; apply Rle_trans with (s + 0)%R; auto with real. apply Rmult_le_reg_l with (/ 2)%R; auto with real. apply Rle_trans with (Rabs t / 2%nat)%R; [ right; simpl in |- *; unfold Rdiv in |- *; ring | apply Rle_trans with (1 := H) ]. right; rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real. split; [ idtac | simpl in |- *; rewrite Zmin_le1; auto with zarith float ]. apply Zle_lt_trans with (Zabs (Fnum x)); auto with float. apply Zle_Rle; repeat rewrite <- Faux.Rabsolu_Zabs. apply Rmult_le_reg_l with (powerRZ radix (Fexp x)); auto with zarith real. rewrite <- (Rabs_right (powerRZ radix (Fexp x))); [ idtac | apply Rle_ge; auto with zarith real ]. repeat rewrite <- Rabs_mult. replace (powerRZ radix (Fexp x) * Fnum x)%R with (FtoRradix x); [ idtac | unfold FtoRradix, FtoR in |- *; simpl in |- *; ring ]. replace (powerRZ radix (Fexp x) * Fnum (Fminus radix x (Fmult q y)))%R with (FtoRradix (Fminus radix x (Fmult q y))). 2: unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite Zmin_le1; auto with zarith; ring. apply Rle_trans with ((Zabs (Fnum (Fnormalize radix b precision q)) - 1) * Rabs (FtoRradix (Fminus radix x (Fmult q y))))%R. apply Rle_trans with (1 * Rabs (FtoRradix (Fminus radix x (Fmult q y))))%R; [ right; ring | apply Rmult_le_compat_r; auto with real ]. apply Rplus_le_reg_l with 1%R; ring_simplify (1 + (Zabs (Fnum (Fnormalize radix b precision q)) - 1))%R. replace 2%R with (IZR (Zsucc 1)); auto with real zarith. apply Rplus_le_reg_l with (Rabs (FtoRradix (Fminus radix x (Fmult q y)))). ring_simplify. cut (0 < Zabs (Fnum (Fnormalize radix b precision q)))%R; [ intros V | auto with real zarith ]. apply Rmult_le_reg_l with (/ IZR (Zabs (Fnum (Fnormalize radix b precision q))))%R; auto with real. apply Rle_trans with (Rabs (FtoRradix (Fminus radix x (Fmult q y)))). right; rewrite <- Rmult_assoc; rewrite Rmult_comm; rewrite <- Rmult_assoc. rewrite Rinv_r; auto with real. unfold FtoRradix in |- *; rewrite Fminus_correct; auto; rewrite Fmult_correct; auto; fold FtoRradix in |- *. pattern (FtoRradix x - FtoRradix q * FtoRradix y)%R at 1 in |- *. replace (FtoRradix x - FtoRradix q * FtoRradix y)%R with (FtoRradix y * (FtoRradix x / FtoRradix y - FtoRradix q))%R; [ rewrite Rabs_mult | idtac ]. 2: field; auto with real. apply Rle_trans with (Rabs (FtoRradix y) * Fulp b radix precision q)%R. apply Rmult_le_compat_l; auto with real. apply Rlt_le; unfold FtoRradix in |- *; apply RoundedModeUlp with P; auto. pattern (FtoRradix y) at 1 in |- *; replace (FtoRradix y) with ((FtoRradix x - (FtoRradix x - FtoRradix q * FtoRradix y)) * / FtoRradix q)%R; [ idtac | field; auto ]. rewrite Rabs_mult. rewrite Rmult_assoc. replace (Rabs (/ FtoRradix q) * Fulp b radix precision q)%R with (/ Zabs (Fnum (Fnormalize radix b precision q)))%R; [ rewrite Rmult_comm | idtac ]. apply Rmult_le_compat_l; auto with real. replace (FtoRradix x - (FtoRradix x - FtoRradix q * FtoRradix y))%R with (- (FtoRradix x - FtoRradix q * FtoRradix y) + FtoRradix x)%R; [ idtac | ring ]. rewrite <- (Rabs_Ropp (FtoRradix x - FtoRradix q * FtoRradix y)); apply Rabs_triang. rewrite Rabs_Rinv; auto; rewrite Hq; unfold FtoRradix in |- *; rewrite <- Fabs_correct; auto. unfold Fabs, FtoR in |- *; simpl in |- *; rewrite Rinv_mult_distr; auto with real zarith. rewrite Rmult_assoc; unfold Fulp in |- *; rewrite Rinv_l; auto with real zarith. Qed. Theorem errorBoundedDivSimplHyp : forall (x y q : float) P, RoundedModeP b radix P -> Fbounded b x -> Fbounded b y -> Fbounded b q -> FtoRradix y <> 0%R -> P (x / y)%R q -> (- dExp b <= Fexp (Fnormalize radix b precision x) - precision)%Z -> (- dExp b <= Fexp q + Fexp y)%Z. intros x y q P HP Fx Fy Fq Hy Hq H. cut (IZR (Zpos (vNum b)) = powerRZ radix precision); [ intros V | rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; auto ]. cut (Fcanonic radix b (Fnormalize radix b precision x)); [ intros H1; case H1; intros H2 | apply FnormalizeCanonic; auto with arith ]. apply Zle_trans with (1 := H); apply Zlt_succ_le. apply Zplus_lt_reg_l with (-1 + (precision + - Fexp y))%Z; unfold Zsucc in |- *. ring_simplify (-1 + (precision + - Fexp y) + (Fexp q + Fexp y + 1))%Z. replace (-1 + (precision + - Fexp y) + (Fexp (Fnormalize radix b precision x) - precision))%Z with (Zpred precision + Fexp (Fnormalize radix b precision x) + - (precision + Fexp y))%Z; [ idtac | unfold Zpred in |- *; ring ]. apply Zlt_powerRZ with (IZR radix); [ idtac | rewrite powerRZ_add ]; auto with zarith real. apply Rle_lt_trans with (Rabs x * powerRZ radix (- (precision + Fexp y)))%R. apply Rmult_le_compat_r; auto with real zarith. unfold FtoRradix in |- *; rewrite <- FnormalizeCorrect with (precision := precision) (b := b); auto. rewrite <- Fabs_correct; auto with zarith; unfold Fabs, FtoR in |- *; simpl in |- *. rewrite powerRZ_add; auto with zarith real; apply Rmult_le_compat_r; auto with real zarith. elim H2; intros H3 H4; apply Rmult_le_reg_l with (IZR radix); auto with zarith real. apply Rle_trans with (IZR (Zpos (vNum b))); [ rewrite V; right | idtac ]. pattern (IZR radix) at 1 in |- *; replace (IZR radix) with (powerRZ radix 1); [ idtac | simpl in |- *; ring ]. unfold Zpred in |- *; rewrite <- powerRZ_add; [ ring_simplify (1 + (precision + -1))%Z | idtac ]; auto with zarith real. rewrite <- (Rabs_right radix); [ idtac | apply Rle_ge; auto with zarith real ]. rewrite Faux.Rabsolu_Zabs; rewrite <- Rmult_IZR; rewrite <- Zabs_Zmult; auto with real zarith. apply Rle_lt_trans with (Rabs (FtoRradix x) * / Rabs (FtoRradix y))%R. apply Rmult_le_compat_l; auto with real; rewrite powerRZ_Zopp; auto with real zarith. apply Rle_Rinv; auto with real zarith. cut (0 <= Rabs (FtoRradix y))%R; [ intros H3; case H3 | idtac ]; auto with real. intros H4; Contradict H4; apply not_eq_sym; apply Rabs_no_R0; auto. unfold FtoRradix in |- *; rewrite <- Fabs_correct; auto with zarith; unfold Fabs, FtoR in |- *; simpl in |- *. rewrite powerRZ_add; [ apply Rmult_le_compat_r | idtac ]; auto with real zarith float. rewrite <- V; auto with float real. apply Rplus_lt_reg_r with (- Fulp b radix precision q)%R. apply Rlt_le_trans with (Rabs q). apply Rplus_lt_reg_r with (Fulp b radix precision q + - Rabs (FtoRradix q))%R. ring_simplify. rewrite <- Rabs_Rinv; auto; rewrite <- Rabs_mult. rewrite Rmult_comm. apply Rle_lt_trans with (Rabs (/ FtoRradix y * FtoRradix x) - Rabs (FtoRradix q))%R; [right; ring|idtac]. apply Rle_lt_trans with (Rabs (/ FtoRradix y * FtoRradix x - FtoRradix q)); [ apply Rabs_triang_inv | idtac ]. unfold FtoRradix in |- *; apply RoundedModeUlp with P; auto with real. fold FtoRradix in |- *; replace (/ FtoRradix y * FtoRradix x)%R with (FtoRradix x / FtoRradix y)%R; [ auto | unfold Rdiv in |- *; ring ]. apply Rle_trans with (- powerRZ radix (Fexp q) + powerRZ radix (Fexp q + precision))%R. rewrite powerRZ_add; auto with zarith real. unfold FtoRradix in |- *; rewrite <- Fabs_correct; auto with zarith; unfold Fabs, FtoR in |- *; simpl in |- *. apply Rle_trans with ((-1 + powerRZ radix precision) * powerRZ radix (Fexp q))%R; [ apply Rmult_le_compat_r; auto with real zarith | right; ring ]. apply Rle_trans with (IZR (Zpred (Zpos (vNum b)))); auto with real zarith float. unfold Zpred in |- *; rewrite plus_IZR; rewrite Rplus_comm; apply Rplus_le_compat; right; auto with real zarith float. rewrite Zplus_comm; apply Rplus_le_compat_r; apply Ropp_le_contravar; unfold Fulp in |- *; apply Rle_powerRZ; auto with zarith real. apply FcanonicLeastExp with radix b precision; auto with zarith float real. apply sym_eq; apply FnormalizeCorrect; auto. elim H2; intros H3 H4; elim H4; intros H5 H6. absurd (- dExp b <= Fexp (Fnormalize radix b precision x) - precision)%Z; auto with zarith. Qed. Theorem errorBoundedDivClosest : forall x y q : float, Fbounded b x -> Fbounded b y -> Fbounded b q -> FtoRradix y <> 0%R -> Closest b radix (x / y) q -> (- dExp b <= Fexp q + Fexp y)%Z -> Fbounded b (Fminus radix x (Fmult q y)). intros x y q Fx Fy Fq H2 H3 H. apply errorBoundedDiv with (Closest b radix); auto. apply ClosestRoundedModeP with precision; auto. case (Req_dec (Rabs (FtoRradix q)) (powerRZ radix (- dExp b))); intros H4; auto. right. case (Rle_or_lt (powerRZ radix (- dExp b) / 2%nat) (Rabs (FtoRradix x / FtoRradix y))); auto. intros H5; elim H3; intros H6 H7. absurd (powerRZ radix (- dExp b) / 2%nat < powerRZ radix (- dExp b) / 2%nat)%R; auto with real. apply Rle_lt_trans with (2 := H5). apply Rle_trans with (powerRZ radix (- dExp b) + - (powerRZ radix (- dExp b) / 2%nat))%R. unfold Rdiv in |- *; apply Rle_trans with (powerRZ radix (- dExp b) * (1 + - / 2%nat))%R; [ apply Rmult_le_compat_l; auto with real zarith | right; ring; ring ]. right; simpl in |- *; field; auto with real. apply Rle_trans with (Rabs q - Rabs (x / y))%R. unfold Rminus in |- *; rewrite H4; apply Rplus_le_compat_l; apply Ropp_le_contravar; auto with real. apply Rle_trans with (Rabs (FtoRradix q - FtoRradix x / FtoRradix y)); [ apply Rabs_triang_inv | idtac ]. apply Rle_trans with (Rabs (FtoR radix (Fzero (- dExp b)) - FtoRradix x / FtoRradix y)). apply H7; apply FboundedFzero. rewrite FzeroisZero; ring_simplify (0 - FtoRradix x / FtoRradix y)%R. rewrite Rabs_Ropp; auto with real. Qed. Theorem errorBoundedDivToZero : forall x y q : float, Fbounded b x -> Fbounded b y -> Fbounded b q -> FtoRradix y <> 0%R -> ToZeroP b radix (x / y) q -> (- dExp b <= Fexp q + Fexp y)%Z -> Fbounded b (Fminus radix x (Fmult q y)). intros x y q Fx Fy Fq H2 H3 H. apply errorBoundedDiv with (ToZeroP b radix); auto. apply ToZeroRoundedModeP with precision; auto. case (Req_dec (Rabs (FtoRradix q)) (powerRZ radix (- dExp b))); intros H4; auto. right. case H3; intros H'; elim H'; [ unfold isMin in |- * | unfold isMax in |- * ]; intros H5 H6; clear H'; elim H6; intros H7 H8; elim H8; clear H6 H8; fold FtoRradix in |- *; intros H6 H8. apply Rle_trans with (powerRZ radix (- dExp b)); [ unfold Rdiv in |- * | idtac ]. apply Rle_trans with (powerRZ radix (- dExp b) * 1)%R; [ apply Rmult_le_compat_l; auto with real zarith | right; ring ]. rewrite <- Rinv_1; simpl in |- *; apply Rle_Rinv; auto with real. rewrite <- H4; repeat rewrite Rabs_right; auto with real float. apply Rle_ge; unfold FtoRradix in |- *; apply RleRoundedR0 with b precision (ToZeroP b radix) (FtoRradix x / FtoRradix y)%R; auto with float real zarith. apply ToZeroRoundedModeP with precision; auto. apply Rle_trans with (powerRZ radix (- dExp b)); [ unfold Rdiv in |- * | idtac ]. apply Rle_trans with (powerRZ radix (- dExp b) * 1)%R; [ apply Rmult_le_compat_l; auto with real zarith | right; ring ]. rewrite <- Rinv_1; simpl in |- *; apply Rle_Rinv; auto with real. rewrite <- H4; repeat rewrite Faux.Rabsolu_left1; auto with real float. unfold FtoRradix in |- *; apply RleRoundedLessR0 with b precision (ToZeroP b radix) (FtoRradix x / FtoRradix y)%R; auto with float real zarith. apply ToZeroRoundedModeP with precision; auto. Qed. Theorem errorBoundedSqrt : forall x q : float, (Fbounded b x) -> (Fbounded b q) -> (0 <= x)%R -> (Closest b radix (sqrt x) q) -> (- dExp b <= Fexp q + Fexp q)%Z -> (Fbounded b (Fminus radix x (Fmult q q))). intros x q Fx Fq H1 H2 H3. cut (FtoRradix q = Fnormalize radix b precision q); [ intros Hq | apply sym_eq; unfold FtoRradix in |- *; apply FnormalizeCorrect; auto ]. cut (Fcanonic radix b (Fnormalize radix b precision q)); [ intros Cq | apply FnormalizeCanonic; auto with arith ]. cut (0 <= q)%R; [ intros H'1 | idtac ]. 2: unfold FtoRradix in |- *; apply RleRoundedR0 with b precision (Closest b radix) (sqrt x); auto with float zarith real. 2: apply ClosestRoundedModeP with precision; auto. 2: rewrite <- sqrt_0; apply sqrt_le_1; auto with real. cut (Rabs (sqrt x - q) <= Fulp b radix precision q * / 2%nat)%R; [ intros H'2 | idtac ]. 2: apply Rmult_le_reg_l with (INR 2); auto with real arith. 2: apply Rle_trans with (Fulp b radix precision q); [ unfold FtoRradix in |- *; apply ClosestUlp; auto | right ]. 2: apply trans_eq with (Fulp b radix precision q * (2%nat * / 2%nat))%R; [ rewrite Rinv_r; auto with real | idtac ]; ring. case (Zle_or_lt (Fexp q + Fexp q) (Fexp x)); intros H4. split; [ idtac | simpl in |- *; rewrite Zmin_le2; auto ]. apply Zlt_Rlt; rewrite <- Faux.Rabsolu_Zabs. replace (IZR (Fnum (Fminus radix x (Fmult q q)))) with (Fminus radix x (Fmult q q) * powerRZ radix (- Fexp (Fminus radix x (Fmult q q))))%R. 2: unfold FtoRradix in |- *; unfold FtoR in |- *; rewrite Rmult_assoc. 2: rewrite <- powerRZ_add; auto with real zarith. 2: ring_simplify (Fexp (Fminus radix x (Fmult q q)) + - Fexp (Fminus radix x (Fmult q q)))%Z; auto with real. simpl in |- *; rewrite Zmin_le2; auto; rewrite Rabs_mult. rewrite (Rabs_right (powerRZ radix (- (Fexp q + Fexp q)))); [ idtac | apply Rle_ge; auto with real zarith ]. unfold FtoRradix in |- *; rewrite Fminus_correct; auto; rewrite Fmult_correct; auto; fold FtoRradix in |- *. replace (FtoRradix x - FtoRradix q * FtoRradix q)%R with ((sqrt x - q) * (sqrt x + q))%R; [ rewrite Rabs_mult | idtac ]. 2: apply trans_eq with ((sqrt x)*(sqrt x)-q*q)%R; try ring. 2: rewrite sqrt_def; auto with real. apply Rle_lt_trans with (Fulp b radix precision q * / 2%nat * Rabs (sqrt (FtoRradix x) + FtoRradix q) * powerRZ radix (- (Fexp q + Fexp q)))%R. apply Rmult_le_compat_r; auto with real zarith. apply Rle_lt_trans with (Fulp b radix precision q * / 2%nat * (2 * Rabs q + Fulp b radix precision q * / 2%nat) * powerRZ radix (- (Fexp q + Fexp q)))%R. apply Rmult_le_compat_r; auto with real zarith. apply Rmult_le_compat_l; [ unfold Fulp in |- *; auto with real zarith float | idtac ]. apply Rmult_le_pos; auto with real zarith float. replace (sqrt (FtoRradix x) + FtoRradix q)%R with (sqrt (FtoRradix x) - FtoRradix q + 2 * FtoRradix q)%R; [ idtac | ring ]. apply Rle_trans with (Rabs (sqrt (FtoRradix x) - FtoRradix q) + Rabs (2 * FtoRradix q))%R; [ apply Rabs_triang | idtac ]. rewrite Rplus_comm; apply Rplus_le_compat; auto. rewrite Rabs_mult; rewrite Rabs_right; auto with real. apply Rle_ge; auto with real. unfold Fulp in |- *; rewrite Hq. unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite Rabs_mult. rewrite (Rabs_right (powerRZ radix (Fexp (Fnormalize radix b precision q)))); [ idtac | apply Rle_ge; auto with real zarith ]. apply Rle_lt_trans with (powerRZ radix (- (Fexp q + Fexp q)) * (powerRZ radix (Fexp (Fnormalize radix b precision q)) * powerRZ radix (Fexp (Fnormalize radix b precision q))) * (/ 2 * 2 * Rabs (Fnum (Fnormalize radix b precision q)) + / 2 * / 2))%R; [ right; ring | idtac ]. repeat rewrite <- powerRZ_add; auto with zarith real. rewrite Rinv_l; auto with real. apply Rle_lt_trans with (powerRZ radix 0 * (1 * Rabs (Fnum (Fnormalize radix b precision q)) + / 2 * / 2))%R. apply Rmult_le_compat_r; auto with real zarith. replace 0%R with (0 + 0)%R; [ apply Rplus_le_compat; auto with real zarith | ring ]. apply Rmult_le_pos; auto with real zarith. apply Rmult_le_pos; auto with real zarith. apply Rle_powerRZ; auto with real zarith. apply Zplus_le_reg_l with (Fexp q + Fexp q)%Z. ring_simplify. apply Zmult_le_compat_l; auto with zarith. apply FcanonicLeastExp with radix b precision; auto with arith. simpl in |- *; ring_simplify (1 * (1 * Rabs (Fnum (Fnormalize radix b precision q)) + / 2 * / 2))%R; rewrite Faux.Rabsolu_Zabs. apply Rle_lt_trans with (Zpred (Zpos (vNum b))+(/ 2)^2 )%R; auto with real float zarith. apply Rplus_le_compat_r; auto with real float zarith. replace (IZR (Zpred (Zpos (vNum b)))) with (nat_of_P (vNum b) + -1)%R. apply Rle_lt_trans with (-1 + / 2 * / 2 + nat_of_P (vNum b))%R; [ right; ring | idtac ]. apply Rlt_le_trans with (0 + nat_of_P (vNum b))%R; [ apply Rplus_lt_compat_r | right; ring ]. apply Rplus_lt_reg_r with 1%R; ring_simplify. apply Rmult_lt_reg_l with 2%R; auto with real. apply Rle_lt_trans with (/2)%R;[right;field; auto with real|idtac]. ring_simplify (2*1)%R; apply Rmult_lt_reg_l with 2%R; auto with real; rewrite Rinv_r; auto with real. apply Rlt_le_trans with 2%R; auto with real. unfold Zpred in |- *; rewrite plus_IZR; simpl in |- *; auto with real. case (Req_dec x 0); intros H5. cut (is_Fzero x); [ idtac | apply is_Fzero_rep2 with radix; auto ]. cut (is_Fzero q); [ unfold is_Fzero in |- * | apply is_Fzero_rep2 with radix; auto ]. intros H6 H7; unfold Fmult, Fminus, Fopp, Fplus in |- *; simpl in |- *; rewrite H6; rewrite H7; simpl in |- *. rewrite Zmin_le1; auto with zarith. repeat (split; simpl in |- *; auto with zarith float). cut (ProjectorP b radix (Closest b radix)); [ unfold ProjectorP in |- *; intros H6 | apply RoundedProjector; auto with float zarith ]. 2: apply ClosestRoundedModeP with precision; auto. rewrite <- (FzeroisReallyZero radix (- dExp b)). apply sym_eq; apply H6; auto. unfold Fzero in |- *; repeat (split; simpl in |- *; auto with zarith float). replace (FtoR radix (Fzero (- dExp b))) with (sqrt (FtoRradix x)); auto. rewrite H5; rewrite FzeroisReallyZero; apply sqrt_0. case Cq; intros Cq2. split. 2: unfold Fmult, Fminus, Fopp, Fplus in |- *; simpl in |- *; rewrite Zmin_le1; auto with zarith float. apply Zlt_Rlt; rewrite <- Faux.Rabsolu_Zabs. replace (IZR (Fnum (Fminus radix x (Fmult q q)))) with (Fminus radix x (Fmult q q) * powerRZ radix (- Fexp (Fminus radix x (Fmult q q))))%R. 2: unfold FtoRradix in |- *; unfold FtoR in |- *; rewrite Rmult_assoc. 2: rewrite <- powerRZ_add; auto with real zarith. 2: ring_simplify (Fexp (Fminus radix x (Fmult q q)) + - Fexp (Fminus radix x (Fmult q q)))%Z; auto with real. apply Rle_lt_trans with (IZR (Zabs (Fnum x))); [ idtac | auto with float zarith real ]. simpl in |- *; rewrite Zmin_le1; auto with zarith; rewrite Rabs_mult. rewrite (Rabs_right (powerRZ radix (- Fexp x))); [ idtac | apply Rle_ge; auto with real zarith ]. unfold FtoRradix in |- *; rewrite Fminus_correct; auto; rewrite Fmult_correct; auto; fold FtoRradix in |- *. apply Rmult_le_reg_l with (powerRZ radix (Fexp x)); auto with real zarith. apply Rle_trans with (Rabs (FtoRradix x - FtoRradix q * FtoRradix q) * (powerRZ radix (Fexp x) * powerRZ radix (- Fexp x)))%R; [ right; ring | rewrite <- powerRZ_add; auto with real zarith ]. ring_simplify (Fexp x + - Fexp x)%Z; simpl in |- *. ring_simplify (Rabs (FtoRradix x - FtoRradix q * FtoRradix q) * 1)%R. replace (powerRZ radix (Fexp x) * Zabs (Fnum x))%R with (Rabs x); [ idtac | unfold FtoRradix in |- *; rewrite <- Fabs_correct; auto; unfold FtoR in |- *; simpl in |- *; ring ]. cut (forall v w : R, (0 <= v)%R -> (0 <= w)%R -> (w <= 2 * v)%R -> (Rabs (v - w) <= Rabs v)%R); [ intros H6; apply H6; auto with real | idtac ]. apply Rmult_le_pos; auto. cut (0 < 1 - / 2%nat * powerRZ radix (Zsucc (- precision)))%R; [ intros H'3 | idtac ]. 2: apply Rplus_lt_reg_r with (/ 2%nat * powerRZ radix (Zsucc (- precision)))%R. 2: ring_simplify. 2: apply Rlt_trans with (/ 2%nat*powerRZ radix 0 )%R; auto with real zarith. 2: simpl in |- *; ring_simplify ( / 2*1)%R; pattern 1%R at 3 in |- *; rewrite <- Rinv_1; auto with real. apply Rle_trans with (Rsqr (sqrt x * / (1 - / 2%nat * powerRZ radix (Zsucc (- precision))))). fold (Rsqr (FtoRradix q)) in |- *; apply Rsqr_le_abs_1. rewrite Rabs_mult. rewrite (Rabs_right (/ (1 - / 2%nat * powerRZ radix (Zsucc (- precision))))); [ idtac | apply Rle_ge; auto with real ]. apply Rmult_le_reg_l with (1 - / 2%nat * powerRZ radix (Zsucc (- precision)))%R; auto. ring_simplify ((1 - / 2%nat * powerRZ radix (Zsucc (- precision))) * Rabs (FtoRradix q))%R. apply Rle_trans with (Rabs (sqrt (FtoRradix x)) * ((1 - / 2%nat * powerRZ radix (Zsucc (- precision))) * / (1 - / 2%nat * powerRZ radix (Zsucc (- precision)))))%R; [ idtac | right; ring; ring ]. rewrite Rinv_r; auto with real. ring_simplify (Rabs (sqrt (FtoRradix x)) * 1)%R. apply Rle_trans with (- (/ 2%nat * Fulp b radix precision q)+Rabs q)%R. apply Rplus_le_compat_r; repeat rewrite Ropp_mult_distr_l_reverse. apply Ropp_le_contravar. rewrite Rmult_assoc; apply Rmult_le_compat_l; auto with real. unfold FtoRradix in |- *; rewrite Rmult_comm; apply FulpLe2; auto. apply Rplus_le_reg_l with (- Rabs (sqrt (FtoRradix x)) + / 2%nat * Fulp b radix precision q)%R. ring_simplify. apply Rle_trans with (Rabs (q - sqrt (FtoRradix x))). apply Rle_trans with (Rabs q - Rabs (sqrt (FtoRradix x)))%R; [ right; ring | apply Rabs_triang_inv ]. rewrite <- Rabs_Ropp. replace (- (FtoRradix q - sqrt (FtoRradix x)))%R with (sqrt (FtoRradix x) - FtoRradix q)%R; [ apply Rle_trans with (1:=H'2);auto with real| ring ]. rewrite Rsqr_mult; rewrite Rsqr_sqrt; auto. rewrite Rmult_comm; apply Rmult_le_compat_r; auto. cut (0 < 1 - / 2%nat * powerRZ radix (Zsucc (- 2%nat)))%R; [ intros H'4 | idtac ]. 2: apply Rplus_lt_reg_r with (/ 2%nat * powerRZ radix (Zsucc (- 2%nat)))%R. 2: ring_simplify. 2: apply Rlt_trans with (/ 2%nat * powerRZ radix 0 )%R; auto with real zarith. 2: simpl in |- *; ring_simplify ( / 2*1)%R; pattern 1%R at 3 in |- *; rewrite <- Rinv_1; auto with real. apply Rle_trans with (Rsqr (/ (1 - / 2%nat * powerRZ radix (Zsucc (- 2%nat))))). apply Rsqr_le_abs_1. rewrite Rabs_right; [ idtac | apply Rle_ge; auto with real ]. rewrite Rabs_right; [ idtac | apply Rle_ge; auto with real zarith ]. apply Rle_Rinv; auto with real zarith. unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_contravar. apply Rmult_le_compat_l; auto with real zarith. apply Rle_powerRZ; auto with real zarith. apply Rle_trans with (Rsqr (4%nat * / 3%nat)). apply Rsqr_le_abs_1. rewrite Rabs_right; [ idtac | apply Rle_ge; auto with real ]. rewrite Rabs_right; [ idtac | apply Rle_ge; auto with real zarith arith ]. 2: apply Rmult_le_pos; auto with real arith. apply Rle_trans with (/ (3%nat * / 4%nat))%R; [ idtac | right; field; auto with arith real ]. apply Rle_Rinv; auto with real arith. apply Rmult_lt_0_compat; auto with real arith zarith. apply Rle_trans with (1 - / 2%nat * / 2%nat)%R. rewrite <- Rinv_mult_distr; auto with arith real; replace 1%R with (4%nat * / 4%nat)%R; auto with real. simpl in |- *; replace 4%R with (2 + 1 + 1)%R; [ right; ring | ring ]. unfold Rminus in |- *; apply Rplus_le_compat_l; apply Ropp_le_contravar. apply Rmult_le_compat_l; auto with real zarith. unfold powerRZ in |- *; simpl in |- *; ring_simplify (radix * 1)%R. apply Rle_Rinv; auto with real zarith. replace 2%R with (IZR (Zsucc 1)); auto with real zarith. replace (2 + 1 + 1)%R with (INR 4); auto with real. unfold Rsqr in |- *; apply Rmult_le_reg_l with (3%nat * 3%nat)%R; auto with real arith. apply Rmult_lt_0_compat; auto with real arith zarith. apply Rle_trans with (3%nat * / 3%nat * (4%nat * 4%nat * (3%nat * / 3%nat)))%R; [ right; ring | idtac ]. repeat rewrite Rinv_r; auto with real arith zarith. simpl in |- *; ring_simplify. apply Rle_trans with (16+0)%R; auto with real. apply Rle_trans with (16+2)%R; auto with real. right; ring. intros v w Hv Hw Hvw; unfold Rminus in |- *. rewrite (Rabs_right v); [ idtac | apply Rle_ge; auto ]. case (Rcase_abs (v + - w)); intros H'. rewrite Rabs_left; auto with real. apply Rplus_le_reg_l with v; ring_simplify (v + - (v + - w))%R; auto with real. apply Rle_trans with (1 := Hvw); right; ring. rewrite Rabs_right; auto. apply Rle_trans with (v + -0)%R; [ auto with real | right; ring ]. case (Req_dec q 0); intros H6. cut (is_Fzero q); [ unfold is_Fzero in |- * | apply is_Fzero_rep2 with radix; auto ]. intros H7; unfold Fmult, Fminus, Fopp, Fplus in |- *; simpl in |- *; rewrite H7; simpl in |- *. rewrite Zmin_le1; auto with zarith. ring_simplify (Fexp x - Fexp x)%Z; unfold Zpower_nat in |- *; simpl in |- *; auto with zarith float. ring_simplify (Fnum x * 1 + 0)%Z; auto with float. split; [ idtac | simpl in |- *; rewrite Zmin_le1; auto with zarith float ]. apply Zlt_Rlt; rewrite <- Faux.Rabsolu_Zabs. replace (IZR (Fnum (Fminus radix x (Fmult q q)))) with (Fminus radix x (Fmult q q) * powerRZ radix (- Fexp (Fminus radix x (Fmult q q))))%R. 2: unfold FtoRradix in |- *; unfold FtoR in |- *; rewrite Rmult_assoc. 2: rewrite <- powerRZ_add; auto with real zarith. 2: ring_simplify (Fexp (Fminus radix x (Fmult q q)) + - Fexp (Fminus radix x (Fmult q q)))%Z; auto with real. simpl in |- *; rewrite Zmin_le1; auto with zarith float; rewrite Rabs_mult. rewrite (Rabs_right (powerRZ radix (- Fexp x))); [ idtac | apply Rle_ge; auto with real zarith ]. unfold FtoRradix in |- *; rewrite Fminus_correct; auto; rewrite Fmult_correct; auto; fold FtoRradix in |- *. replace (FtoRradix x - FtoRradix q * FtoRradix q)%R with ((sqrt x - q) * (sqrt x + q))%R; [ rewrite Rabs_mult | idtac ]. 2: apply trans_eq with (sqrt x*sqrt x - q * q)%R; try ring. 2: rewrite sqrt_def; auto with real. apply Rle_lt_trans with (Fulp b radix precision q * / 2%nat * Rabs (sqrt (FtoRradix x) + FtoRradix q) * powerRZ radix (- Fexp x))%R. apply Rmult_le_compat_r; auto with real zarith. elim Cq2; intros H7 H8; elim H8; clear H7 H8; intros H7 H8. apply Rle_lt_trans with (Fulp b radix precision q * / 2%nat * (2 * Rabs (sqrt (FtoRradix x)) + Fulp b radix precision q * / 2%nat) * powerRZ radix (- Fexp x))%R. apply Rmult_le_compat_r; auto with real zarith. apply Rmult_le_compat_l; auto with real zarith. apply Rmult_le_pos; unfold Fulp in |- *; auto with arith real. replace (sqrt (FtoRradix x) + FtoRradix q)%R with (FtoRradix q - sqrt (FtoRradix x) + 2 * sqrt (FtoRradix x))%R; [ idtac | ring ]. apply Rle_trans with (Rabs (FtoRradix q - sqrt (FtoRradix x)) + Rabs (2 * sqrt (FtoRradix x)))%R; [ apply Rabs_triang | idtac ]. rewrite Rplus_comm; apply Rplus_le_compat; auto. rewrite Rabs_mult; rewrite Rabs_right; auto with real. apply Rle_ge; auto with real. rewrite <- Rabs_Ropp. replace (- (FtoRradix q - sqrt (FtoRradix x)))%R with (sqrt (FtoRradix x) - FtoRradix q)%R; [ auto | ring ]. unfold Fulp in |- *; rewrite H7. ring_simplify. cut (0 <= Fnum x)%Z; [ intros H'3 | apply LeR0Fnum with radix; auto ]. apply Rle_lt_trans with (/ 2%nat * / 2%nat + Fnum x)%R; [ apply Rplus_le_compat | idtac ]. apply Rle_trans with (powerRZ radix (- dExp b) * powerRZ radix (- dExp b) * powerRZ radix (- Fexp x) * (/ 2%nat * / 2%nat))%R; [ right; ring | rewrite <- powerRZ_add; auto with zarith real ]. rewrite <- powerRZ_add; auto with zarith real. apply Rle_trans with (powerRZ radix 0 * (/ 2%nat * / 2%nat))%R; [ idtac | simpl in |- *; right; ring ]. apply Rmult_le_compat_r; auto with real. apply Rmult_le_pos; auto with real. apply Rle_powerRZ; auto with real zarith float. apply Zplus_le_reg_l with (Fexp x). ring_simplify; auto with float. apply Zle_trans with (- dExp b)%Z; auto with zarith float. cut (0 <= dExp b)%Z; auto with zarith; case (dExp b); auto with zarith. apply Rle_trans with (2 * / 2%nat * (powerRZ radix (- dExp b) * powerRZ radix (- Fexp x) * Rabs (sqrt (FtoRradix x))))%R; [ right; ring | simpl in |- * ]. rewrite Rinv_r; auto with real. ring_simplify. rewrite Rabs_right; [ idtac | apply Rle_ge; apply sqrt_positivity; auto ]. unfold FtoRradix in |- *; unfold FtoR in |- *; simpl in |- *. rewrite sqrt_mult; auto with real float zarith. rewrite <- powerRZ_add; auto with real zarith. rewrite <- (sqrt_def (powerRZ radix (- dExp b + - Fexp x))); auto with zarith real. rewrite <- sqrt_mult; auto with real zarith. rewrite Rmult_comm with (r1:=(sqrt (Fnum x))). rewrite <- Rmult_assoc; rewrite <- sqrt_mult; auto with real zarith. rewrite <- powerRZ_add; auto with real zarith. rewrite <- powerRZ_add; auto with real zarith. apply Rle_trans with (1*sqrt (Fnum x))%R; [ apply Rmult_le_compat_r | idtac ]. apply sqrt_positivity; auto with real zarith. rewrite <- sqrt_1; apply sqrt_le_1; auto with real zarith. replace 1%R with (powerRZ radix 0); [ apply Rle_powerRZ | simpl in |- * ]; auto with real zarith. ring_simplify (Fexp x + (- Fexp x + - dExp b + (- Fexp x + - dExp b)))%Z. apply Zplus_le_reg_l with (Fexp x). ring_simplify. apply Zle_trans with (- dExp b)%Z; auto with zarith float. cut (0<=dExp b)%Z; auto with zarith; case (dExp b); auto with zarith. ring_simplify (1*sqrt (Fnum x) )%R. cut (forall z : R, (0 <= z)%R -> (1 <= z)%R -> (sqrt z <= z)%R); [ intros V | idtac ]. apply V; auto with real float zarith. cut (0%Z <> Fnum x); auto with zarith float real. Contradict H5; unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite <- H5; simpl; ring. intros z V1 V'; case V'; intros V''. apply Rlt_le; apply sqrt_less; auto with real. rewrite <- V''; rewrite sqrt_1; auto with real. apply Rmult_le_pos; auto with real zarith. apply Rle_lt_trans with (/ 2%nat * / 2%nat + (Zpos (vNum b) + -1))%R. apply Rplus_le_compat_l. rewrite <- (Zabs_eq (Fnum x)); auto. apply Rle_trans with (IZR (Zpred (Zpos (vNum b)))); auto with zarith real float. unfold Zpred in |- *; right; auto with zarith real. rewrite plus_IZR; auto with real zarith. simpl in |- *; apply Rplus_lt_reg_r with (1 + - nat_of_P (vNum b))%R. ring_simplify. apply Rmult_lt_reg_l with 2%R; auto with real. apply Rmult_lt_reg_l with 2%R; auto with real. apply Rle_lt_trans with 1%R;[right; field; auto with real|ring_simplify; auto with real]. apply Rlt_le_trans with 2%R; auto with real. Qed. End FroundDiv. Float8.4/Others/PradixE.v0000644000423700002640000010135112032774527015042 0ustar sboldotoccata(**************************************************************************** IEEE754 : PradixE.v Laurent Thery & Laurence Rideau ***************************************************************************** Same as Pradix but without correctness*) Require Export FroundPlus. Section prog. (* Usual hypothesis *) Variable b : Fbound. Variable radix : Z. Variable precision : nat. Coercion Local FtoRradix := FtoR radix. Hypothesis radixMoreThanOne : (1 < radix)%Z. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision. (* An arbitrary rounding mode *) Variable P : R -> float -> Prop. Hypothesis ProundedMode : RoundedModeP b radix P. Let Cp := RoundedModeP_inv2 b radix P ProundedMode. (* The operations + - * and their property *) Variable fplus : float -> float -> float. Variable fminus : float -> float -> float. Variable fmult : float -> float -> float. Hypothesis fplusCorrect : forall p q : float, Fbounded b p -> Fbounded b q -> P (p + q) (fplus p q). Hypothesis fminusCorrect : forall p q : float, Fbounded b p -> Fbounded b q -> P (p - q) (fminus p q). Hypothesis fmultCorrect : forall p q : float, Fbounded b p -> Fbounded b q -> P (p * q) (fmult p q). (* 0,1 et 2 *) Variables f0 f1 f2 : float. Variable f0Bounded : Fbounded b f0. Variable f0Correct : f0 = 0%Z :>R. Variable f1Bounded : Fbounded b f1. Variable f1Correct : f1 = 1%Z :>R. Variable f2Bounded : Fbounded b f2. Variable f2Correct : f2 = 2%Z :>R. (* Properties to conclude for the first loop *) Theorem Loop0 : forall p : float, Fbounded b p -> forall n : Z, (1 <= n)%Z -> (n <= pPred (vNum b))%Z -> p = n :>R -> fplus p f1 = (p + f1)%R :>R. intros p H' n H'0 H'1 H'2. case (FboundNext _ radixMoreThanOne b precision) with (p := Float n 0%nat); auto with arith; fold FtoRradix in |- *. repeat split; simpl in |- *; auto with zarith arith. rewrite Zabs_eq; auto with zarith. rewrite (fun x => Zsucc_pred (Zpos x)); auto with zarith. case (dExp b); auto with zarith. intros x (H'3, H'4). cut ((p + f1)%R = FtoRradix x); [ intros Eq1; rewrite Eq1 | idtac ]. apply sym_eq; apply (RoundedModeProjectorIdemEq b radix precision) with (P := P); auto; fold FtoRradix in |- *. apply Cp with (1 := fplusCorrect _ _ H' f1Bounded); auto. apply RoundedModeBounded with (radix := radix) (P := P) (r := (p + f1)%R); auto. rewrite H'4; rewrite H'2; rewrite f1Correct; unfold FtoRradix, FtoR, Zsucc in |- *; simpl in |- *; rewrite plus_IZR; simpl in |- *; repeat rewrite <- INR_IZR_INZ; ring. Qed. Theorem Loop1 : forall p : float, Fbounded b p -> forall n : Z, (Zpos (vNum b) <= n)%Z -> (n <= radix * pPred (vNum b))%Z -> p = n :>R -> fplus p f1 = p :>R \/ fplus p f1 = (p + radix)%R :>R. intros p H' n H'0 H'1 H'2. replace (IZR radix) with (powerRZ radix 1%nat); [ idtac | simpl in |- *; ring ]. apply (InBinade b radix precision) with (q := f1) (P := P); auto with zarith; fold FtoRradix in |- *. case (dExp b); auto with zarith. rewrite H'2; unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite Rmult_1_r; rewrite <- Rmult_IZR; pattern radix at 2 in |- *; rewrite <- (Zpower_nat_1 radix); try rewrite <- Zpower_nat_is_exp. replace (pred precision + 1) with precision; [ rewrite <- pGivesBound; auto with real | idtac ]. rewrite plus_comm; generalize precisionGreaterThanOne; case precision; simpl in |- *; auto; (intros tmp; Contradict tmp; auto with arith). rewrite H'2; unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite Rmult_1_r; rewrite <- Rmult_IZR; rewrite Zmult_comm; auto with real. rewrite f1Correct; auto with real arith. rewrite f1Correct; replace (powerRZ radix 1%nat) with (IZR radix); auto with real arith. Qed. Theorem Loop2 : forall p : float, Fbounded b p -> forall n : Z, (1 <= n)%Z -> (n <= pPred (vNum b))%Z -> p = n :>R -> fminus (fplus p f1) p = f1 :>R. intros p H' n H'0 H'1 H'2. apply sym_eq; apply (RoundedModeProjectorIdemEq b radix precision) with (P := P); auto. cut (Fbounded b (fplus p f1)); [ intros Fbp | auto ]. apply Cp with (1 := fminusCorrect _ _ Fbp H'); auto. rewrite Loop0 with (n := n); auto. fold FtoRradix in |- *; ring. apply RoundedModeBounded with (radix := radix) (P := P) (r := (fplus p f1 - p)%R); auto. apply RoundedModeBounded with (radix := radix) (P := P) (r := (p + f1)%R); auto. Qed. Theorem Loop3 : forall p : float, Fbounded b p -> forall n : Z, (Zpos (vNum b) <= n)%Z -> (n <= radix * pPred (vNum b))%Z -> p = n :>R -> fminus (fplus p f1) p <> f1 :>R. intros p H' n H'0 H'1 H'2. case (Loop1 p) with (n := n); auto; intros Eq1; red in |- *; intros Eq2. absurd (f1 = f0 :>R). rewrite f1Correct; rewrite f0Correct; auto with real. rewrite <- Eq2. apply sym_eq; apply (RoundedModeProjectorIdemEq b radix precision) with (P := P); auto. cut (Fbounded b (fplus p f1)); [ intros Fbp | auto ]. apply Cp with (1 := fminusCorrect _ _ Fbp H'); auto. rewrite Eq1; fold FtoRradix in |- *; rewrite f0Correct;simpl; ring. apply RoundedModeBounded with (radix := radix) (P := P) (r := (fplus p f1 - p)%R); auto. apply RoundedModeBounded with (radix := radix) (P := P) (r := (p + f1)%R); auto. absurd (f1 = radix :>R). rewrite f1Correct; apply Rlt_not_eq; auto with real zarith. rewrite <- Eq2. replace (IZR radix) with (FtoRradix (Float 1%nat 1%nat)). apply sym_eq; apply (RoundedModeProjectorIdemEq b radix precision) with (P := P); auto. repeat split; simpl in |- *; auto with zarith. apply (vNumbMoreThanOne radix) with (precision := precision); auto with zarith. case (dExp b); auto with zarith. cut (Fbounded b (fplus p f1)); [ intros Fbp | auto ]. apply Cp with (1 := fminusCorrect _ _ Fbp H'); auto. rewrite Eq1; unfold FtoR in |- *; simpl in |- *; ring. apply RoundedModeBounded with (radix := radix) (P := P) (r := (fplus p f1 - p)%R); auto. apply RoundedModeBounded with (radix := radix) (P := P) (r := (p + f1)%R); auto. unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. Qed. Theorem Loop4 : forall p : float, Fbounded b p -> forall n : Z, (1 <= n)%Z -> (n <= pPred (vNum b))%Z -> p = n :>R -> (p < fmult f2 p)%R. intros p H' n H'0 H'1 H'2. case (Zle_or_lt (2 * n) (pPred (vNum b))); intros le1. replace (FtoRradix (fmult f2 p)) with (FtoRradix (Float (2 * n) 0%nat)). replace (FtoRradix p) with (FtoRradix (Float (1 * n) 0%nat)). unfold FtoRradix, FtoR in |- *; apply Rlt_monotony_exp; auto with real zarith. change ((1 * n)%Z < (2 * n)%Z)%R in |- *; apply Rlt_IZR; apply Zmult_gt_0_lt_compat_r; auto with zarith. ring_simplify (1*n)%Z;rewrite H'2; unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. apply (RoundedModeProjectorIdemEq b radix precision) with (P := P); auto. repeat split; auto with zarith. rewrite Zabs_eq; auto. rewrite (Zsucc_pred (Zpos (vNum b))); auto with zarith. change (0 <= 2 * n)%Z in |- *; auto with zarith. simpl in |- *; case (dExp b); auto with zarith. apply Cp with (1 := fmultCorrect _ _ f2Bounded H'); auto. rewrite H'2; rewrite f2Correct; rewrite <- Rmult_IZR; unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. apply RoundedModeBounded with (radix := radix) (P := P) (r := (f2 * p)%R); auto. cut (FtoRradix (Float (nNormMin radix precision) 1%nat) = Zpower_nat radix precision); [ intros Eq1 | unfold FtoRradix, FtoR, nNormMin in |- *; simpl in |- * ]. apply Rlt_le_trans with (FtoRradix (Float (nNormMin radix precision) 1%nat)). rewrite H'2; rewrite Eq1; simpl in |- *. rewrite <- pGivesBound; rewrite (Zsucc_pred (Zpos (vNum b))); auto with real zarith. apply (RleBoundRoundl b radix precision) with (P := P) (r := (f2 * p)%R); auto. repeat split; simpl in |- *; auto with zarith arith. rewrite Zabs_eq; auto with float zarith. apply ZltNormMinVnum; auto with float zarith. apply Zlt_le_weak; apply nNormPos; auto with float zarith. case (dExp b); auto with zarith. fold FtoRradix in |- *; rewrite Eq1. rewrite f2Correct; rewrite H'2; rewrite <- Rmult_IZR. apply Rle_IZR. rewrite <- pGivesBound; rewrite (Zsucc_pred (Zpos (vNum b))); auto with zarith. pattern precision at 2 in |- *; rewrite (S_pred precision 0). 2: apply lt_trans with 1; auto. replace (S (pred precision)) with (pred precision+1)%nat; auto with zarith. rewrite Zpower_nat_is_exp; auto with real zarith. rewrite Zpower_nat_1; rewrite Rmult_IZR; auto with real; ring. Qed. (* Properties to conclude for the second loop *) Theorem BLoop1 : forall p q : float, Fbounded b p -> Fbounded b q -> forall m n : Z, (Zpower_nat radix precision <= m)%Z -> (m <= radix * pPred (vNum b))%Z -> p = m :>R -> (1 <= n)%Z -> (n < radix)%Z -> q = n :>R -> fplus p q = p :>R \/ fplus p q = (p + radix)%R :>R. intros p q H' H'0 m n H'1 H'2 H'3 H'4 H'5 H'6. replace (IZR radix) with (powerRZ radix 1%nat); [ idtac | simpl in |- *; ring ]. apply (InBinade b radix precision) with (P := P) (q := q); fold FtoRradix in |- *; auto with zarith. case (dExp b); auto with zarith. rewrite H'3; unfold FtoRradix, FtoR in |- *; simpl in |- *. rewrite Rmult_1_r; pattern radix at 2 in |- *; rewrite <- (Zpower_nat_1 radix); rewrite <- Rmult_IZR; rewrite <- Zpower_nat_is_exp. replace (pred precision + 1) with (S (pred precision)); [ rewrite <- (S_pred precision 0) | rewrite plus_comm ]; auto with real arith. rewrite H'3; unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite Rmult_1_r; rewrite Rmult_comm; rewrite <- Rmult_IZR; auto with real arith. rewrite H'6; auto with real zarith. rewrite H'6; replace (powerRZ radix 1%nat) with (IZR radix); auto with real zarith. Qed. Theorem BLoop2 : forall p q : float, Fbounded b p -> Fbounded b q -> forall m n : Z, (Zpower_nat radix precision <= m)%Z -> (m <= radix * pPred (vNum b))%Z -> p = m :>R -> (1 <= n)%Z -> (n < radix)%Z -> q = n :>R -> fminus (fplus p q) p <> q :>R. intros p q H' H'0 m n H'1 H'2 H'3 H'4 H'5 H'6. case (BLoop1 p q) with (n := n) (m := m); auto; intros Eq1; red in |- *; intros Eq2. absurd (q = f0 :>R). rewrite H'6; rewrite f0Correct; auto with real zarith. rewrite <- Eq2. apply sym_eq; apply (RoundedModeProjectorIdemEq b radix precision) with (P := P); auto. cut (Fbounded b (fplus p q)); [ intros Fbp | auto ]. apply Cp with (1 := fminusCorrect _ _ Fbp H'); auto. rewrite Eq1; fold FtoRradix in |- *; rewrite f0Correct; simpl; ring. apply RoundedModeBounded with (radix := radix) (P := P) (r := (fplus p q - p)%R); auto. apply RoundedModeBounded with (radix := radix) (P := P) (r := (p + q)%R); auto. absurd (q = radix :>R). rewrite H'6; auto with real zarith. rewrite <- Eq2. replace (IZR radix) with (FtoRradix (Float 1%nat 1%nat)). apply sym_eq; apply (RoundedModeProjectorIdemEq b radix precision) with (P := P); auto. repeat split; simpl in |- *; auto with zarith. apply vNumbMoreThanOne with (radix := radix) (precision := precision); auto with float zarith. case (dExp b); auto with zarith. cut (Fbounded b (fplus p q)); [ intros Fbp | auto ]. apply Cp with (1 := fminusCorrect _ _ Fbp H'); auto. rewrite Eq1; unfold FtoR in |- *; simpl in |- *; ring. apply RoundedModeBounded with (radix := radix) (P := P) (r := (fplus p q - p)%R); auto. apply RoundedModeBounded with (radix := radix) (P := P) (r := (p + q)%R); auto. unfold FtoRradix, FtoR in |- *; simpl in |- *; ring. Qed. Theorem BLoop3 : forall p q : float, Fbounded b p -> Fbounded b q -> forall m : Z, (Zpower_nat radix precision <= m)%Z -> (m <= radix * pPred (vNum b))%Z -> p = m :>R -> q = radix :>R -> fminus (fplus p q) p = q :>R. intros p q H' H'0 m H'1 H'2 H'3 H'4. cut (fplus p q = (p + q)%R :>R); [ intros Eq1 | idtac ]. apply sym_eq; apply (RoundedModeProjectorIdemEq b radix precision) with (P := P); auto. cut (Fbounded b (fplus p q)); [ intros Fbp | auto ]. apply Cp with (1 := fminusCorrect _ _ Fbp H'); auto; fold FtoRradix in |- *. rewrite Eq1; ring. apply RoundedModeBounded with (radix := radix) (P := P) (r := (fplus p q - p)%R); auto. apply RoundedModeBounded with (radix := radix) (P := P) (r := (p + q)%R); auto. case (FboundNext _ radixMoreThanOne b precision) with (p := Fnormalize radix b precision p); auto with arith; fold FtoRradix in |- *. apply FcanonicBound with (radix := radix); auto. apply FnormalizeCanonic with (radix := radix) (precision := precision); auto with arith. intros p' H'5; elim H'5; intros H'6 H'7; clear H'5. cut (Fexp (Fnormalize radix b precision p) = 1%Z); [ intros Eq1 | idtac ]. cut ((p + q)%R = FtoRradix p' :>R); [ intros Eq2 | idtac ]. rewrite Eq2. apply sym_eq; apply (RoundedModeProjectorIdemEq b radix precision) with (P := P); auto. apply Cp with (1 := fplusCorrect _ _ H' H'0); auto; fold FtoRradix in |- *. apply RoundedModeBounded with (radix := radix) (P := P) (r := (p + q)%R); auto. rewrite H'7. rewrite H'4. unfold FtoRradix, FtoR in |- *; simpl in |- *. replace (Zsucc (Fnum (Fnormalize radix b precision p)) * powerRZ radix (Fexp (Fnormalize radix b precision p)))%R with (Fnum (Fnormalize radix b precision p) * powerRZ radix (Fexp (Fnormalize radix b precision p)) + powerRZ radix (Fexp (Fnormalize radix b precision p)))%R. replace (Fnum (Fnormalize radix b precision p) * powerRZ radix (Fexp (Fnormalize radix b precision p)))%R with (FtoRradix (Fnormalize radix b precision p)); auto. rewrite (FnormalizeCorrect radix); auto. rewrite Eq1; unfold FtoR in |- *; simpl in |- *; ring. unfold Zsucc in |- *; simpl in |- *; rewrite plus_IZR; simpl; ring. apply boundedNorMinGivesExp; auto with zarith. case (dExp b); auto with zarith. fold FtoRradix in |- *; rewrite H'3; unfold FtoRradix, FtoR, nNormMin in |- *; simpl in |- *. rewrite Rmult_1_r; pattern radix at 2 in |- *; rewrite <- (Zpower_nat_1 radix); rewrite <- Rmult_IZR; rewrite <- Zpower_nat_is_exp. replace (pred precision + 1) with (S (pred precision)); [ rewrite <- (S_pred precision 0) | rewrite plus_comm ]; auto with real arith. fold FtoRradix in |- *; rewrite H'3; unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite Rmult_1_r; rewrite Rmult_comm; rewrite <- Rmult_IZR; auto with real arith. Qed. Theorem BLoop4 : forall p : float, Fbounded b p -> forall n : Z, (1 <= n)%Z -> (n < radix)%Z -> p = n :>R -> (p < fplus p f1)%R. intros p H' n H'0 H'1 H'2. rewrite Loop0 with (n := n); auto. rewrite H'2; rewrite f1Correct; auto with real zarith. apply Zle_trans with (Zpred radix); auto with zarith. unfold pPred in |- *; apply Zle_Zpred_Zpred. rewrite <- (Zpower_nat_1 radix); rewrite pGivesBound; auto with real zarith. Qed. Lemma Loop6c : forall p b0 : float, Fbounded b p -> forall n : Z, (1 <= n)%Z -> (n <= pPred (vNum b))%Z -> p = n :>R -> Fbounded b b0 /\ b0 = radix :>R -> (p < fmult p b0)%R. intros p b0 H' n H'0 H'1 H'2 H'3. Casec H'3; intros Fbb0 H'3. case (Zle_or_lt (n * radix) (pPred (vNum b))); intros le1. replace (FtoRradix (fmult p b0)) with (FtoRradix (Float (n * radix) 0%nat)). rewrite H'2; unfold FtoRradix, FtoR in |- *; simpl in |- *. rewrite Rmult_1_r; apply Rlt_IZR. pattern n at 1 in |- *; replace n with (n * 1)%Z; auto with zarith. apply Zmult_gt_0_lt_compat_l; auto with zarith. apply (RoundedModeProjectorIdemEq b radix precision) with (P := P); auto. repeat split; simpl in |- *; auto with zarith. rewrite Zabs_eq; auto with zarith. rewrite (Zsucc_pred (Zpos (vNum b))); auto with zarith. case (dExp b); auto with zarith. apply Cp with (1 := fmultCorrect _ _ H' Fbb0); auto. rewrite H'3; rewrite H'2; unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite Rmult_IZR; ring. apply RoundedModeBounded with (radix := radix) (P := P) (r := (p * b0)%R); auto. cut (FtoRradix (Float (nNormMin radix precision) 1%nat) = Zpower_nat radix precision); [ intros Eq1 | unfold FtoRradix, FtoR, nNormMin in |- *; simpl in |- * ]. apply Rlt_le_trans with (FtoRradix (Float (nNormMin radix precision) 1%nat)). rewrite H'2; rewrite Eq1; simpl in |- *. rewrite <- pGivesBound; rewrite (Zsucc_pred (Zpos (vNum b))); fold pPred in |- *; auto with real zarith. apply (RleBoundRoundl b radix precision) with (P := P) (r := (p * b0)%R); auto. repeat split; simpl in |- *; auto with zarith arith. rewrite Zabs_eq; auto with float zarith. apply ZltNormMinVnum; auto with float zarith. apply Zlt_le_weak; apply nNormPos; auto with float zarith. case (dExp b); auto with zarith. fold FtoRradix in |- *; rewrite Eq1; rewrite <- pGivesBound; rewrite H'2; rewrite H'3. rewrite (Zsucc_pred (Zpos (vNum b))); rewrite <- Rmult_IZR; auto with real zarith. rewrite Rmult_1_r; pattern radix at 2 in |- *; rewrite <- (Zpower_nat_1 radix). rewrite <- Rmult_IZR; repeat rewrite <- Zpower_nat_Z_powerRZ; rewrite <- Zpower_nat_is_exp. replace (pred precision + 1) with precision; [ auto | rewrite plus_comm; simpl in |- * ]. generalize precisionGreaterThanOne; case precision; simpl in |- *; auto with arith. intros tmp; Contradict tmp; auto with arith. Qed. Let feq := Feq_bool radix. Theorem Goal1 : forall (x0 : float) (Pre2 : (exists m : Z, (1 <= m)%Z /\ (m <= radix * pPred (vNum b))%Z /\ x0 = m :>R) /\ Fbounded b x0) (Test1 : feq (fminus (fplus x0 f1) x0) f1 = true), Zabs_nat (radix * pPred (vNum b) - Int_part (fmult f2 x0)) < Zabs_nat (radix * pPred (vNum b) - Int_part x0) /\ ex (fun m : Z => (1 <= m)%Z /\ (m <= radix * pPred (vNum b))%Z /\ fmult f2 x0 = m :>R) /\ Fbounded b (fmult f2 x0). intros x0 Pre2 Test1. Casec Pre2; intros Pre2; Casec Pre2; intros vx0 Pre2; Casec Pre2; intros Hv1 Pre2; Casec Pre2; intros Hv2 Hv3 Fb1. cut (ex (fun m : Z => (1 <= m)%Z /\ (m <= radix * pPred (vNum b))%Z /\ FtoRradix (fmult f2 x0) = m :>R)). intros Pre2; Casec Pre2; intros va1 Pre2; Casec Pre2; intros Hv1' Pre2; Casec Pre2; intros Hv2' Hv3'. split. rewrite Hv3'; rewrite Hv3; repeat rewrite Int_part_IZR; apply Zabs.Zabs_nat_lt; split; auto with zarith. unfold Zminus in |- *; apply Zplus_lt_compat_l; auto with zarith; apply Zlt_Zopp. apply Zlt_Rlt. rewrite <- Hv3'; rewrite <- Hv3. apply (Loop4 x0 Fb1 vx0); auto. case (Zle_or_lt (Zpower_nat radix precision) vx0); auto. intros lte1; absurd (fminus (fplus x0 f1) x0 = f1 :>R). apply Loop3 with (n := vx0); auto. rewrite pGivesBound; auto. generalize Feq_bool_correct_t; unfold Feq in |- *. intros H'; apply (H' radix); auto. rewrite <- pGivesBound; unfold pPred in |- *; auto with zarith. split; auto. exists va1; split; auto. apply RoundedModeBounded with (radix := radix) (P := P) (r := (f2 * x0)%R); auto. case (ZroundZ b radix precision) with (P := P) (z := (2 * vx0)%Z) (p := fmult f2 x0); auto. apply Cp with (1 := fmultCorrect _ _ f2Bounded Fb1); auto. rewrite Hv3; rewrite f2Correct; try rewrite Rmult_IZR; auto with real zarith. apply RoundedModeBounded with (radix := radix) (P := P) (r := (f2 * x0)%R); auto. intros x H'; exists x; repeat split; auto. apply Zle_Rle. rewrite <- f1Correct; auto. rewrite <- H'; auto. apply (RleBoundRoundl b radix precision) with (P := P) (r := (f2 * x0)%R); auto. rewrite Hv3; rewrite f2Correct. fold FtoRradix in |- *; rewrite f1Correct. rewrite <- Rmult_IZR; apply Rle_IZR. apply Zle_trans with (1 := Hv1); auto with zarith. cut (Float (pPred (vNum b)) 1%nat = (radix * pPred (vNum b))%Z :>R); [ intros Eq1 | idtac ]. apply Zle_Rle; rewrite <- Eq1; rewrite <- H'. apply (RleBoundRoundr b radix precision) with (P := P) (r := (f2 * x0)%R); auto. repeat split; simpl in |- *; auto with zarith. rewrite Zabs_eq; unfold pPred in |- *; auto with float zarith. case (dExp b); auto with zarith. fold FtoRradix in |- *; rewrite Eq1. rewrite Rmult_IZR; apply Rmult_le_compat; auto. rewrite f2Correct; replace 0%R with (IZR 0); auto with real zarith. rewrite Hv3; replace 0%R with (IZR 0); auto with real zarith. rewrite f2Correct; auto with real zarith. replace 2%Z with (Zsucc 1); auto with real zarith. rewrite Hv3. case (Zle_or_lt vx0 (pPred (vNum b))); auto with real arith. intros H'0; absurd (fminus (fplus x0 f1) x0 = f1 :>R). apply Loop3 with (n := vx0); auto. rewrite (Zsucc_pred (Zpos (vNum b))); auto with zarith. generalize (Feq_bool_correct_t radix); unfold Feq in |- *; intros Eq2; apply Eq2; auto. unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite Rmult_IZR; ring. Qed. Theorem Goal2 : forall (x0 : float) (Pre2 : ex (fun m : Z => (1 <= m)%Z /\ (m <= radix * pPred (vNum b))%Z /\ x0 = m :>R) /\ Fbounded b x0) (Test1 : feq (fminus (fplus x0 f1) x0) f1 = false), ex (fun m : Z => (Zpower_nat radix precision <= m)%Z /\ (m <= radix * pPred (vNum b))%Z /\ x0 = m :>R) /\ Fbounded b x0. intros x0 Pre2 Test1. Casec Pre2; intros Pre2; Casec Pre2; intros vx0 Pre2; Casec Pre2; intros Hv1 Pre2; Casec Pre2; intros Hv2 Hv3 Fb1. split; auto; auto. exists vx0; split; auto. case (Zle_or_lt (Zpower_nat radix precision) vx0); auto with real arith. intros H'0; absurd (fminus (fplus x0 f1) x0 = f1 :>R). generalize (Feq_bool_correct_f radix); unfold Feq in |- *; intros Eq2; apply Eq2; auto. apply Loop2 with (n := vx0); auto. unfold pPred in |- *; rewrite pGivesBound; auto with arith zarith. Qed. Theorem Goal3 : ex (fun m : Z => (1 <= m)%Z /\ (m <= radix * pPred (vNum b))%Z /\ f1 = m :>R) /\ Fbounded b f1. split; auto. exists 1%Z; repeat split; auto with zarith. apply Zle_trans with (radix * 1)%Z; auto with zarith. apply Zle_Zmult_comp_l; auto with zarith. unfold pPred in |- *; apply Zle_Zpred; apply (vNumbMoreThanOne radix) with (precision := precision); auto with zarith. Qed. Theorem Goal4 : forall (x0 y0 : float) (Post3 : ex (fun m : Z => (Zpower_nat radix precision <= m)%Z /\ (m <= radix * pPred (vNum b))%Z /\ x0 = m :>R) /\ Fbounded b x0) (Pre4 : ex (fun m : Z => (1 <= m)%Z /\ (m <= radix)%Z /\ y0 = m :>R) /\ Fbounded b y0) (Test2 : feq (fminus (fplus x0 y0) x0) y0 = false), Zabs_nat (radix - Int_part (fplus y0 f1)) < Zabs_nat (radix - Int_part y0) /\ ex (fun m : Z => (1 <= m)%Z /\ (m <= radix)%Z /\ fplus y0 f1 = m :>R) /\ Fbounded b (fplus y0 f1). intros x0 y0 Post3 Pre4 Test2. elim Post3; intros H'0 H'1; elim H'0; intros vx0 E; elim E; intros Hv1 H'3; elim H'3; intros Hv2 Hv3; clear H'3 E H'0 Post3. elim Pre4; intros H' Hv1'; elim H'; intros vy0 E; elim E; intros Hv2' H'3; elim H'3; intros Hv3' Hv4'; clear H'3 E H' Pre4. cut (ex (fun m : Z => (1 <= m)%Z /\ (m <= radix)%Z /\ fplus y0 f1 = m :>R)); [ intros Ex1 | idtac ]. split; [ idtac | split ]; auto. elim Ex1; intros vb1 E; elim E; intros Hv1'' H'0; elim H'0; intros Hv2'' Hv3''; clear H'0 E Ex1. rewrite Hv4'; rewrite Hv3''; repeat rewrite Int_part_IZR. apply Zabs.Zabs_nat_lt; split; auto with zarith. cut (vy0 < vb1)%Z; auto with zarith. apply Zlt_Rlt; rewrite <- Hv4'; rewrite <- Hv3''. apply (BLoop4 y0 Hv1' vy0); auto. case (Zle_or_lt radix vy0); auto; intros le1. absurd (fminus (fplus x0 y0) x0 = y0 :>R); auto. generalize (Feq_bool_correct_f radix); unfold Feq in |- *; intros Eq2; apply Eq2; auto. apply BLoop3 with (m := vx0); auto with real arith. rewrite Hv4'; apply Rle_antisym; auto with real arith. apply RoundedModeBounded with (radix := radix) (P := P) (r := (y0 + f1)%R); auto. case (Zle_lt_or_eq _ _ Hv3'); intros le1. case (ZroundZ b radix precision) with (P := P) (z := Zsucc vy0) (p := fplus y0 f1); auto. apply Cp with (1 := fplusCorrect _ _ Hv1' f1Bounded); auto. rewrite Hv4'. rewrite f1Correct; simpl in |- *; unfold Zsucc in |- *; rewrite plus_IZR; simpl in |- *; ring. apply RoundedModeBounded with (radix := radix) (P := P) (r := (y0 + f1)%R); auto. intros x H'; exists x; repeat split; auto. apply Zle_Rle. rewrite <- H'; rewrite <- f1Correct; auto. apply (RleBoundRoundl b radix precision) with (P := P) (r := (y0 + f1)%R); auto. fold FtoRradix in |- *; rewrite Hv4'; rewrite f1Correct; auto. rewrite <- plus_IZR; auto with real zarith. apply Zle_Rle. rewrite <- H'. replace (IZR radix) with (FtoRradix (Float 1%nat 1%nat)). apply (RleBoundRoundr b radix precision) with (P := P) (r := (y0 + f1)%R); auto. repeat split; simpl in |- *; auto with zarith. apply (vNumbMoreThanOne radix) with (precision := precision); auto with zarith. case (dExp b); auto with zarith. rewrite Hv4'; rewrite f1Correct; unfold FtoR in |- *; simpl in |- *; rewrite Rmult_1_l; rewrite Rmult_1_r. replace 1%R with (IZR 1); auto with real zarith; rewrite <- plus_IZR; apply Rle_IZR; auto with zarith. unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite Rmult_1_l; rewrite Rmult_1_r; auto. absurd (fminus (fplus x0 y0) x0 = y0 :>R). generalize (Feq_bool_correct_f radix); unfold Feq in |- *; intros Eq2; apply Eq2; auto. apply BLoop3 with (m := vx0); auto with real arith. rewrite Hv4'; rewrite le1; auto with real. Qed. Theorem Goal5_6b : ex (fun m : Z => (1 <= m)%Z /\ (m <= radix)%Z /\ f1 = m :>R) /\ Fbounded b f1. split; [ exists 1%Z; split; [ idtac | split ] | idtac ]; auto with zarith. Qed. Theorem Goal5b : forall (x0 y0 : float) (Post3 : ex (fun m : Z => (Zpower_nat radix precision <= m)%Z /\ (m <= radix * pPred (vNum b))%Z /\ x0 = m :>R) /\ Fbounded b x0) (Pre4 : ex (fun m : Z => (1 <= m)%Z /\ (m <= radix)%Z /\ y0 = m :>R) /\ Fbounded b y0) (Test2 : feq (fminus (fplus x0 y0) x0) y0 = true), Fbounded b y0 /\ y0 = radix :>R. intros x0 y0 Post3 Pre4 Test2. elim Post3; intros H' Hv1; elim H'; intros va0 E; elim E; intros Hv3 H'4; elim H'4; intros Hv4 Hv5; clear H'4 E H' Post3. elim Pre4; intros H' Hv1'; elim H'; intros vb0 E; elim E; intros Hv2' H'2; elim H'2; intros Hv3' Hv4'; clear H'2 E H' Pre4. rewrite Hv4'. case (Zle_lt_or_eq _ _ Hv3'); intros le1. absurd (fminus (fplus x0 y0) x0 = y0 :>R). apply BLoop2 with (n := vb0) (m := va0); auto. generalize (Feq_bool_correct_t radix); unfold Feq in |- *; intros Eq2; apply Eq2; auto. rewrite le1; auto. Qed. Theorem Goal6 : forall (x0 y0 : float) (Post2 : ex (fun m : Z => (Zpower_nat radix precision <= m)%Z /\ (m <= radix * pPred (vNum b))%Z /\ x0 = m :>R) /\ Fbounded b x0) (Post1 : (ex (fun m : Z => (1 <= m)%Z /\ (m <= radix)%Z /\ y0 = m :>R) /\ Fbounded b y0) /\ feq (fminus (fplus x0 y0) x0) y0 = true), y0 = radix :>R. intros x0 y0 Post2 Post1. elim Post1; intros H' Hv1; elim H'; intros H'1 Hv2; elim H'1; intros vy0 E; elim E; intros Hv3 H'4; elim H'4; intros Hv4 Hv5; clear H'4 E H'1 H' Post1. elim Post2; intros H' Hv1'; elim H'; intros vx0 E; elim E; intros Hv2' H'2; elim H'2; intros Hv3' Hv4'; clear H'2 E H' Post2. rewrite Hv5. case (Zle_lt_or_eq _ _ Hv4); intros le1. absurd (fminus (fplus x0 y0) x0 = y0 :>R). apply BLoop2 with (m := vx0) (n := vy0); auto. generalize (Feq_bool_correct_t radix); unfold Feq in |- *; intros Eq2; apply Eq2; auto. rewrite le1; auto. Qed. Theorem Goal7b : forall (y0 x2 : float) (n0 : nat) (Post2 : Fbounded b y0 /\ y0 = radix :>R) (Pre6 : ex (fun m : Z => ((1 <= m)%Z /\ (m <= radix * pPred (vNum b))%Z /\ x2 = m :>R) /\ m = Zpower_nat radix n0) /\ Fbounded b x2) (Test3 : feq (fminus (fplus x2 f1) x2) f1 = true), Zabs_nat (radix * pPred (vNum b) - Int_part (fmult x2 y0)) < Zabs_nat (radix * pPred (vNum b) - Int_part x2) /\ ex (fun m : Z => ((1 <= m)%Z /\ (m <= radix * pPred (vNum b))%Z /\ fmult x2 y0 = m :>R) /\ m = Zpower_nat radix (S n0)) /\ Fbounded b (fmult x2 y0). intros y0 x2 n0 Post2 Pre6 Test3. Casec Pre6; intros Pre6; Casec Pre6; intros va0 Pre6; Casec Pre6; intros Pre6 Hv1'; Casec Pre6; intros Hv1 Pre6; Casec Pre6; intros Hv2 Hv3 Fb1. Casec Post2; intros Fby0 Post2. cut (ex (fun m : Z => ((1 <= m)%Z /\ (m <= radix * pPred (vNum b))%Z /\ FtoRradix (fmult x2 y0) = m :>R) /\ m = Zpower_nat radix (S n0) :>Z)). intros H'; split; [ idtac | split; [ try assumption | idtac ] ]. Casec H'; intros va1 Pre6; Casec Pre6; intros Pre6 H'1; Casec Pre6; intros Hv1'' Pre6; Casec Pre6; intros Hv2' Hv3'. rewrite Hv3; rewrite Hv3'; repeat rewrite Int_part_IZR. apply Zabs.Zabs_nat_lt; split; auto with zarith. rewrite H'1; rewrite Hv1'. unfold Zminus in |- *; auto with zarith. (* Fbounded (fmult x2 y0)).*) apply RoundedModeBounded with (radix := radix) (P := P) (r := (x2 * y0)%R); auto. case (ZroundZ b radix precision) with (P := P) (z := (va0 * radix)%Z) (p := fmult x2 y0); auto. apply Cp with (1 := fmultCorrect _ _ Fb1 Fby0); auto. rewrite Hv3; rewrite Post2; rewrite Rmult_IZR; auto with real arith. apply RoundedModeBounded with (radix := radix) (P := P) (r := (x2 * y0)%R); auto. intros x H'; exists x; repeat split; auto. apply Zle_Rle; rewrite <- f1Correct; rewrite <- H'. apply (RleBoundRoundl b radix precision) with (P := P) (r := (x2 * y0)%R); auto. rewrite Hv3; rewrite Post2; fold FtoRradix in |- *; rewrite f1Correct. rewrite <- Rmult_IZR. apply Rle_IZR; apply Zle_trans with (1 * radix)%Z; auto with zarith. apply Zle_Rle. cut (Float (pPred (vNum b)) 1%nat = (radix * pPred (vNum b))%Z :>R); [ intros Eq1 | idtac ]. rewrite <- Eq1; rewrite <- H'. apply (RleBoundRoundr b radix precision) with (P := P) (r := (x2 * y0)%R); auto. repeat split; simpl in |- *; auto with zarith. rewrite Zabs_eq; unfold pPred in |- *; auto with zarith. case (dExp b); auto with zarith. fold FtoRradix in |- *; rewrite Eq1. rewrite Rmult_IZR; replace (radix * pPred (vNum b))%R with (pPred (vNum b) * radix)%R; auto with real arith. apply Rmult_le_compat; auto with real arith. rewrite Hv3; replace 0%R with (IZR 0); auto with real zarith. rewrite Post2; replace 0%R with (IZR 0); auto with real zarith. rewrite Hv3. case (Zle_or_lt va0 (pPred (vNum b))); auto with real zarith. intros H'0; absurd (fminus (fplus x2 f1) x2 = f1 :>R). apply Loop3 with (n := va0); auto. rewrite (Zsucc_pred (Zpos (vNum b))); auto with zarith. generalize (Feq_bool_correct_t radix); unfold Feq in |- *; intros Eq2; apply Eq2; auto. unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite Rmult_IZR; ring. apply IZR_inv. rewrite <- H'. cut (Zpower_nat radix (S n0) = Float (Fnum x2) (Zsucc (Fexp x2)) :>R); [ intros Eq1; rewrite Eq1 | idtac ]. apply sym_eq; apply (RoundedModeProjectorIdemEq b radix precision) with (P := P); auto. repeat split; simpl in |- *; auto with arith zarith. case Fb1; simpl in |- *; auto. apply Zle_trans with (Fexp x2); auto with zarith. case Fb1; simpl in |- *; auto. apply Cp with (1 := fmultCorrect _ _ Fb1 Fby0); auto. unfold FtoR in |- *; simpl in |- *. rewrite powerRZ_Zs; auto with real zarith. replace (Fnum x2 * (radix * powerRZ radix (Fexp x2)))%R with (Fnum x2 * powerRZ radix (Fexp x2) * radix)%R; auto with real zarith. ring. (* Fbounded (fmult x2 y0)).*) apply RoundedModeBounded with (radix := radix) (P := P) (r := (x2 * y0)%R); auto. unfold FtoRradix, FtoR in |- *; simpl in |- *. replace (S n0) with (n0+1)%nat; auto with zarith. rewrite Zpower_nat_is_exp; rewrite Zpower_nat_1. rewrite <- Hv1'. cut (IZR (va0*radix) = (radix * (Fnum x2 * powerRZ radix (Fexp x2)))%R :>R); [ intros Eq2; rewrite Eq2 | idtac ]. rewrite powerRZ_Zs; auto with real zarith; ring. fold FtoRradix in |- *. rewrite Rmult_IZR. rewrite <- Hv3; auto. unfold FtoRradix, FtoR; ring. Qed. Theorem Goal8b : ex (fun m : Z => ((1 <= m)%Z /\ (m <= radix * pPred (vNum b))%Z /\ f1 = m :>R) /\ m = Zpower_nat radix 0) /\ Fbounded b f1. split; auto. exists 1%Z; repeat split; auto. replace 1%Z with (1 * 1)%Z; auto with zarith. apply Zle_trans with (radix * 1)%Z; auto with zarith. apply Zle_Zmult_comp_l; auto with zarith. unfold pPred in |- *; apply Zle_Zpred. apply vNumbMoreThanOne with (radix := radix) (precision := precision); auto with arith. Qed. Theorem Goal9b : forall (y0 x2 : float) (n0 : nat) (Post2 : Fbounded b y0 /\ y0 = radix :>R) (Post1 : (ex (fun m : Z => ((1 <= m)%Z /\ (m <= radix * pPred (vNum b))%Z /\ x2 = m :>R) /\ m = Zpower_nat radix n0) /\ Fbounded b x2) /\ feq (fminus (fplus x2 f1) x2) f1 = false), y0 = radix :>R /\ n0 = precision. intros y0 x2 n0 Post2 Post1. Casec Post2; intros Fby0 Post2. split; [ try assumption | idtac ]. apply Zpower_nat_anti_eq with (n := radix); auto. Casec Post1; intros Post1 H'0; Casec Post1; intros Post1 H'2; Casec Post1; intros m E; Casec E; intros H'3 H'4; rewrite <- H'4; Casec H'3; intros H' H'1; Casec H'1; intros H'3 H'5. case (Zle_or_lt m (pPred (vNum b))). intros H'1. absurd (feq (fminus (fplus x2 f1) x2) f1 = true :>bool). rewrite H'0; red in |- *; intros; discriminate. unfold feq in |- *; apply Feq_bool_correct_r; auto. unfold Feq in |- *; apply (Loop2 x2) with (n := m); auto with zarith. intros H'1; apply Zle_antisym. rewrite H'4; apply Zpower_nat_monotone_le; auto with zarith. cut (n0 < S precision); auto with arith. apply (Zpower_nat_anti_monotone_lt radix); auto. rewrite <- H'4; auto. apply Zle_lt_trans with (1 := H'3). replace (S precision) with (1+precision); auto with zarith. rewrite Zpower_nat_is_exp; rewrite Zpower_nat_1. rewrite <- pGivesBound; unfold pPred in |- *; apply Zmult_gt_0_lt_compat_l; auto with zarith. rewrite <- pGivesBound; rewrite (Zsucc_pred (Zpos (vNum b))); auto with zarith. Qed. End prog.Float8.4/Others/Veltkamp.v0000644000423700002640000060314412032774527015300 0ustar sboldotoccataRequire Export AllFloat. 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. Theorem FboundedMbound2Pos : (0 < p) -> forall z m : Z, (0 <= m)%Z -> (m <= Zpower_nat radix p)%Z -> (- dExp b <= z)%Z -> exists c : float, Fbounded b c /\ c = (m * powerRZ radix z)%R :>R /\ (z <= Fexp c)%Z. intros C z m H' H'0 H'1; case (Zle_lt_or_eq _ _ H'0); intros H'2. exists (Float m z); split; auto with zarith. repeat split; simpl in |- *; auto with zarith. rewrite Zabs_eq; auto; rewrite pGivesBound; auto. exists (Float 1 (p+z)). split;[split; simpl; auto with zarith|split]. rewrite pGivesBound; apply Zle_lt_trans with (Zpower_nat radix 0); auto with zarith. unfold FtoRradix, FtoR; simpl; rewrite H'2; rewrite Zpower_nat_Z_powerRZ. rewrite powerRZ_add; auto with real zarith. simpl; auto with zarith. Qed. Theorem FboundedMbound2 : (0 < p) -> forall z m : Z, (Zabs m <= Zpower_nat radix p)%Z -> (- dExp b <= z)%Z -> exists c : float, Fbounded b c /\ c = (m * powerRZ radix z)%R :>R /\ (z <= Fexp c)%Z. intros C z m H H0. case (Zle_or_lt 0 m); intros H1. case (FboundedMbound2Pos C z (Zabs m)); auto; try rewrite Zabs_eq; auto. intros f (H2, H3); exists f; split; auto. case (FboundedMbound2Pos C z (Zabs m)); auto; try rewrite Zabs_eq_opp; auto with zarith. intros f (H2, H3); elim H3; intros; exists (Fopp f); split; auto with float. split;[idtac|simpl; auto]. rewrite (Fopp_correct radix); auto with arith; fold FtoRradix in |- *; rewrite H4. rewrite Ropp_Ropp_IZR; ring. Qed. Hypothesis precisionGreaterThanOne : 1 < p. Variable z:R. Variable f:float. Variable e:Z. Hypothesis Bf: Fbounded b f. Hypothesis Cf: Fcanonic radix b f. Hypothesis zGe: (powerRZ radix (e+p-1) <= z)%R. Hypothesis zLe: (z <= powerRZ radix (e+p))%R. Hypothesis fGe: (powerRZ radix (e+p-1) <= f)%R. Hypothesis eGe: (- dExp b <= e)%Z. Theorem ClosestSuccPred: (Fcanonic radix b f) -> (Rabs(z-f) <= Rabs(z-(FSucc b radix p f)))%R -> (Rabs(z-f) <= Rabs(z-(FPred b radix p f)))%R -> Closest b radix z f. intros G; intros; unfold Closest; split; auto. intros g H1; fold FtoRradix. cut ((FPred b radix p f) <= z)%R; [intros T1|idtac]. cut (z <= (FSucc b radix p f))%R; [intros T2|idtac]. case (Rle_or_lt g (FPred b radix p f)); intros. apply Rle_trans with (Rabs (z - f)). rewrite <- Rabs_Ropp; auto with real. replace (- (f - z))%R with (z - f)%R; auto with real. apply Rle_trans with (Rabs (z - FPred b radix p f)); auto with real. rewrite Rabs_right. rewrite Rabs_left1; auto with real. apply Rplus_le_reg_l with (-z)%R. ring_simplify. auto with real. apply Rplus_le_reg_l with z. ring_simplify. apply Rle_trans with (1:=H2); auto with real. apply Rle_ge; auto with real. apply Rplus_le_reg_l with (FPred b radix p f)%R. apply Rle_trans with (FPred b radix p f)%R; auto with real. apply Rle_trans with z; auto with real. cut (f <= g)%R;[intros|idtac]. case H3; intros. cut (FSucc b radix p f <= g)%R;[intros|idtac]. apply Rle_trans with (Rabs (z - f)). rewrite <- Rabs_Ropp; auto with real. replace (- (f - z))%R with (z - f)%R; auto with real. apply Rle_trans with (1:=H). rewrite Rabs_left1. rewrite Rabs_right. apply Rle_trans with ((FSucc b radix p f)-z)%R; auto with real. unfold Rminus; auto with real. apply Rle_ge; apply Rplus_le_reg_l with z. apply Rle_trans with z; auto with real. apply Rle_trans with (FSucc b radix p f)%R; auto with real. apply Rle_trans with g; auto with real. apply Rplus_le_reg_l with (FSucc b radix p f); apply Rle_trans with z; auto with real. apply Rle_trans with (1:=T2); auto with real. apply Rle_trans with (FNSucc b radix p f). right; unfold FNSucc; rewrite FcanonicFnormalizeEq; auto with zarith. unfold FtoRradix; apply FNSuccProp; auto with zarith. rewrite H4; auto with real. replace f with (FNSucc b radix p (FPred b radix p f)). unfold FtoRradix; apply FNSuccProp; auto with zarith. apply FBoundedPred; auto with zarith. unfold FNSucc; rewrite FcanonicFnormalizeEq; auto with zarith. apply FSucPred; auto with zarith. apply FPredCanonic;auto with zarith. case (Rle_or_lt z (FSucc b radix p f)); auto; intros. Contradict H; apply Rlt_not_le. rewrite Rabs_right;[idtac|apply Rle_ge]. rewrite Rabs_right;[idtac|apply Rle_ge]. cut (f < (FSucc b radix p f))%R. intros; unfold Rminus; auto with real. unfold FtoRradix; apply FSuccLt; auto with zarith. apply Rplus_le_reg_l with f. apply Rle_trans with f; auto with real; apply Rle_trans with (FSucc b radix p f). apply Rlt_le; unfold FtoRradix; apply FSuccLt; auto with zarith. apply Rlt_le; apply Rlt_le_trans with (1:=H2); auto with real. apply Rle_trans with (z-z)%R; auto with real; unfold Rminus; auto with real. case (Rle_or_lt (FPred b radix p f) z); auto; intros. Contradict H0; apply Rlt_not_le. cut ((FPred b radix p f) < f)%R. intros; rewrite Rabs_left1. rewrite Rabs_left1. unfold Rminus; auto with real. apply Rplus_le_reg_l with f. apply Rle_trans with z; auto with real; apply Rlt_le. apply Rlt_trans with (1:=H2); apply Rlt_le_trans with (1:=H0); auto with real. apply Rle_trans with (z-z)%R; auto with real; unfold Rminus; auto with real. unfold FtoRradix; apply FPredLt; auto with zarith. Qed. Theorem ImplyClosest: (Rabs(z-f) <= (powerRZ radix e)/2)%R -> Closest b radix z f. intros; apply ClosestSuccPred; auto. apply Rle_trans with (1:=H). apply Rle_trans with (powerRZ radix e - (powerRZ radix e)/2)%R. right; field; auto with real. apply Rle_trans with (Rabs (f - FSucc b radix p f) - Rabs(z-f))%R. unfold Rminus; apply Rplus_le_compat. rewrite <- Rabs_Ropp. replace (- (f + - FSucc b radix p f))%R with (FSucc b radix p f - f)%R;[idtac|ring]. unfold FtoRradix; rewrite <- Fminus_correct; auto;rewrite FSuccDiffPos; auto with real zarith. unfold FtoR; simpl; ring_simplify (1 * powerRZ radix (Fexp f))%R; rewrite Rabs_right. apply Rle_powerRZ; auto with real zarith. replace e with (Fexp (Float (nNormMin radix p) e)); auto. apply Fcanonic_Rle_Zle with radix b p; auto with real zarith float. apply FcanonicNnormMin; auto with zarith. apply Rle_trans with (powerRZ radix (e + p - 1))%R;[right|fold FtoRradix]. unfold nNormMin, FtoR; simpl;rewrite Zpower_nat_Z_powerRZ. rewrite <- powerRZ_add; auto with real zarith. rewrite Rabs_right. replace (pred p+e)%Z with (e+p-1)%Z; auto with real zarith. rewrite inj_pred; unfold Zpred; auto with zarith arith. apply Rle_ge; auto with real zarith. rewrite Rabs_right; auto. apply Rle_ge; apply Rle_trans with (2:=fGe); auto with real zarith. apply Rle_ge; auto with real zarith. apply Rle_trans with (2:=fGe); auto with real zarith. auto with real. rewrite <- Rabs_Ropp with (z-f)%R. apply Rle_trans with (Rabs ((f - FSucc b radix p f) - (-(z - f))))%R. apply Rabs_triang_inv. ring_simplify ((f - FSucc b radix p f - - (z - f)))%R; auto with real. right; unfold Rminus; auto with real. case fGe; intros. cut ((powerRZ radix (e + p - 1) <= FPred b radix p f))%R;[intros|idtac]. apply Rle_trans with (1:=H). apply Rle_trans with (powerRZ radix e - (powerRZ radix e)/2)%R. right; field; auto with real. apply Rle_trans with (Rabs (f - FPred b radix p f) - Rabs(z-f))%R. unfold Rminus; apply Rplus_le_compat. replace ( (f + - FPred b radix p f))%R with (FSucc b radix p (FPred b radix p f) - (FPred b radix p f))%R;[idtac|ring_simplify]. unfold FtoRradix; rewrite <- Fminus_correct; auto;rewrite FSuccDiffPos; auto with real zarith. unfold FtoR; simpl; ring_simplify (1 * powerRZ radix (Fexp (FPred b radix p f)))%R; rewrite Rabs_right. apply Rle_powerRZ; auto with real zarith. replace e with (Fexp (Float (nNormMin radix p) e)); auto. apply Fcanonic_Rle_Zle with radix b p; auto with real zarith float. apply FcanonicNnormMin; auto with zarith. apply Rle_trans with (powerRZ radix (e + p - 1))%R;[right|fold FtoRradix]. unfold nNormMin, FtoR; simpl;rewrite Zpower_nat_Z_powerRZ. rewrite <- powerRZ_add; auto with real zarith. rewrite Rabs_right. replace (pred p+e)%Z with (e+p-1)%Z; auto with real zarith. rewrite inj_pred; unfold Zpred; auto with zarith arith. apply Rle_ge; auto with real zarith. rewrite Rabs_right; auto. apply Rle_ge; apply Rle_trans with (2:=H1); auto with real zarith. apply Rle_ge; auto with real zarith. apply Rle_trans with (2:=H1); auto with real zarith. rewrite FSucPred; auto with zarith. ring. fold Rminus; auto with real. rewrite <- Rabs_Ropp with (z-f)%R. apply Rle_trans with (Rabs ((f - FPred b radix p f) - (-(z - f))))%R. apply Rabs_triang_inv. ring_simplify ((f - FPred b radix p f - - (z - f)))%R. right; unfold Rminus; auto with real. cut ((powerRZ radix (e + p - 1)= (Float (nNormMin radix p) e)))%R. intros T; rewrite T. unfold FtoRradix; apply FPredProp; auto with float zarith. apply FcanonicNnormMin; auto with zarith. fold FtoRradix; rewrite <- T; auto. unfold nNormMin, FtoRradix, FtoR; simpl;rewrite Zpower_nat_Z_powerRZ. rewrite <- powerRZ_add; auto with real zarith. replace (pred p+e)%Z with (e+p-1)%Z; auto with real zarith. rewrite inj_pred; unfold Zpred; auto with zarith arith. cut (FPred b radix p f < f)%R; [intros|unfold FtoRradix; apply FPredLt; auto with zarith]. rewrite Rabs_right. rewrite Rabs_right. unfold Rminus;auto with real zarith float. apply Rle_ge; apply Rle_trans with (z-z)%R; auto with real. right; ring. apply Rle_trans with (z-f)%R; unfold Rminus; auto with real. rewrite <- H0; auto with real. apply Rle_ge; rewrite <- H0; apply Rle_trans with (z-z)%R; unfold Rminus; auto with real. Qed. Theorem ImplyClosestStrict: (Rabs(z-f) < (powerRZ radix e)/2)%R -> (forall g: float, Closest b radix z g -> (FtoRradix f=g)%R ). intros. case (Req_dec (FtoRradix f) (FtoRradix g));auto with real; intros M. cut (Closest b radix z f);[intros|apply ImplyClosest; auto with real]. cut ((FtoRradix g=2*z-f)%R -> False);[intros Y|idtac]. cut (Rabs (g - z) <= Rabs (f - z))%R;[intros Q1|idtac]. 2:elim H0; intros T1 T2; apply T2; auto. cut (Rabs (f - z) <= Rabs (g - z))%R;[intros Q2|idtac]. 2:elim H1; intros T1 T2; apply T2; auto; elim H0; auto. cut (Rabs (f - z) = Rabs (g - z))%R;[intros Q3; clear Q1 Q2|auto with real]. generalize Q3; unfold Rabs; case (Rcase_abs (f - z)%R);case (Rcase_abs (g - z)%R); intros. apply Rplus_eq_reg_l with (-z)%R; rewrite Rplus_comm;fold (Rminus f z); rewrite Rplus_comm;fold (Rminus g z). rewrite <- Ropp_involutive;rewrite <- (Ropp_involutive (f-z)%R);apply Ropp_eq_compat; auto with real. lapply Y;[intros V; Contradict V; auto|idtac]. apply Rplus_eq_reg_l with (-z)%R; apply trans_eq with (g-z)%R; [ring|rewrite <- Q0; ring]. lapply Y;[intros V; Contradict V; auto|idtac]. apply Rplus_eq_reg_l with (-z)%R; apply trans_eq with (g-z)%R; [ring|idtac]. rewrite <- (Ropp_involutive (g-z)%R); rewrite <- Q0; ring. apply Rplus_eq_reg_l with (-z)%R; apply trans_eq with (f-z)%R;[ring|apply trans_eq with (1:=Q0);ring]. intros T; Contradict H;apply Rle_not_lt. replace (z-f)%R with ((g-f)/2)%R;[idtac|rewrite T; field; auto with real]. unfold Rdiv; rewrite Rabs_mult. rewrite (Rabs_right (/2)%R); [idtac|apply Rle_ge;auto with real]. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (Rabs (g - f))%R;[idtac|right;field; auto with real]. unfold FtoRradix; rewrite <- FnormalizeCorrect with radix b p g; auto. rewrite <- Fminus_correct; auto. rewrite <- Fabs_correct; auto. apply Rle_trans with (FtoR radix (Float (S 0) (Fexp (((Fminus radix (Fnormalize radix b p g) f)))))). unfold FtoR; simpl. apply Rle_trans with (powerRZ radix e);[right; field; auto with real|idtac]. apply Rle_trans with (powerRZ radix (Zmin (Fexp (Fnormalize radix b p g)) (Fexp f)))%R;[idtac|right;ring]. apply Rle_powerRZ; auto with zarith real. apply Zmin_Zle. replace e with (Fexp (Float (nNormMin radix p) e)); auto. apply Fcanonic_Rle_Zle with radix b p; auto with real zarith float. apply FcanonicNnormMin; auto with zarith. apply FnormalizeCanonic; auto with zarith; elim H0; auto. apply Rle_trans with (powerRZ radix (e + p - 1))%R;[right|fold FtoRradix]. unfold nNormMin, FtoR; simpl;rewrite Zpower_nat_Z_powerRZ. rewrite <- powerRZ_add; auto with real zarith. rewrite Rabs_right. replace (pred p+e)%Z with (e+p-1)%Z; auto with real zarith. rewrite inj_pred; unfold Zpred; auto with zarith arith. apply Rle_ge; auto with real zarith. cut (powerRZ radix (e + p - 1) <= g)%R;[intros Y|idtac]. unfold FtoRradix;rewrite FnormalizeCorrect; auto with zarith. fold FtoRradix; rewrite Rabs_right; auto. apply Rle_ge; apply Rle_trans with (2:=Y); auto with real zarith. cut ((powerRZ radix (e + p - 1)= (Float (nNormMin radix p) e)))%R. intros U; rewrite U. case zGe; intros T'. generalize ClosestMonotone; unfold MonotoneP; intros. unfold FtoRradix; apply H with b (Float (nNormMin radix p) e) z; auto with zarith real. rewrite <- U; auto. unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(Closest b radix)) (b:=b). apply ClosestRoundedModeP with p; auto. cut (Fcanonic radix b (Float (nNormMin radix p) e));[intros G; elim G; intros G'; elim G'; auto|idtac]. apply FcanonicNnormMin; auto with zarith. right; unfold FtoRradix; apply ClosestIdem with b; auto. cut (Fcanonic radix b (Float (nNormMin radix p) e));[intros G; elim G; intros G'; elim G'; auto|idtac]. apply FcanonicNnormMin; auto with zarith. fold FtoRradix; rewrite <- U; rewrite T'; auto. unfold nNormMin, FtoRradix, FtoR; simpl;rewrite Zpower_nat_Z_powerRZ. rewrite <- powerRZ_add; auto with real zarith. replace (pred p+e)%Z with (e+p-1)%Z; auto with real zarith. rewrite inj_pred; unfold Zpred; auto with zarith arith. replace e with (Fexp (Float (nNormMin radix p) e)); auto. apply Fcanonic_Rle_Zle with radix b p; auto with real zarith float. apply FcanonicNnormMin; auto with zarith. apply Rle_trans with (powerRZ radix (e + p - 1))%R;[right|fold FtoRradix]. unfold nNormMin, FtoR; simpl;rewrite Zpower_nat_Z_powerRZ. rewrite <- powerRZ_add; auto with real zarith. rewrite Rabs_right. replace (pred p+e)%Z with (e+p-1)%Z; auto with real zarith. rewrite inj_pred; unfold Zpred; auto with zarith arith. apply Rle_ge; auto with real zarith. rewrite Rabs_right; auto. apply Rle_ge; apply Rle_trans with (2:=fGe); auto with real zarith. apply RleFexpFabs; auto with zarith. rewrite Fminus_correct; auto; rewrite FnormalizeCorrect; auto. fold FtoRradix; auto with real. Qed. Theorem ImplyClosestStrict2: (Rabs(z-f) < (powerRZ radix e)/2)%R -> (Closest b radix z f) /\ (forall g: float, Closest b radix z g -> (FtoRradix f=g)%R ). intros; split. apply ImplyClosest; auto with real. apply ImplyClosestStrict; auto. Qed. End Generic. Section Generic2. 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 precisionGreaterThanOne : 1 < p. Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix p. Variable z m:R. Variable f h:float. Theorem ClosestImplyEven: (EvenClosest b radix p z f) -> (exists g: float, (z=g+(powerRZ radix (Fexp g))/2)%R /\ (Fcanonic radix b g) /\ (0 <= Fnum g)%Z) -> (FNeven b radix p f). intros H T1; elim T1; intros g T2; elim T2; intros H0 T3; elim T3; intros H1 H2 ; clear T1 T2 T3. cut (Fbounded b g);[intros L|apply FcanonicBound with radix; auto with zarith]. cut (g (EvenClosest b radix p z f) -> (Fcanonic radix b f) -> (0 <= f)%R -> (z=(powerRZ radix (Fexp f))*(m+1/2))%R -> (exists n:Z, IZR n=m) -> (FNeven b radix p f). intros I; intros. elim H3; clear H3; intros n H4. cut (0 <= Fnum f)%Z; [intros|apply LeR0Fnum with radix; auto with real zarith]. case (Zle_lt_or_eq _ _ H3); intros Y1. case (Z_eq_dec (nNormMin radix p) (Fnum f)). intros H5; unfold FNeven; rewrite FcanonicFnormalizeEq; auto with zarith. unfold Feven; rewrite <- H5; unfold nNormMin. replace (pred p) with (S (pred (pred p))); auto with zarith. apply EvenExp; auto with zarith. intros; apply ClosestImplyEven; auto. exists (Float n (Fexp f)). split. rewrite H2; unfold FtoRradix, FtoR; simpl. rewrite H4; field; auto with real. cut (Fnum f -1 <= n)%Z;[intros I1|idtac]. cut (n <= Fnum f)%Z;[intros I2|idtac]. cut (0 <= n)%Z;[intros I3|idtac]. split;[idtac|simpl; auto]. case H0; intros. cut (nNormMin radix p < Fnum f)%Z;[intros K|idtac]. elim H5; intros; elim H6; intros. left; split;[split| idtac]; simpl; auto. apply Zle_lt_trans with (2:=H8); repeat rewrite Zabs_eq; auto with zarith. rewrite Zabs_eq; auto with zarith. rewrite PosNormMin with radix b p; auto with zarith. cut (nNormMin radix p <= Fnum f)%Z; auto with zarith. elim H5; intros. apply Zmult_le_reg_r with radix; auto with zarith. rewrite Zmult_comm; rewrite <- PosNormMin with radix b p; auto with zarith. rewrite Zabs_eq in H7; auto with zarith. rewrite Zmult_comm; auto. elim H5; intros T1 T2; elim T1; elim T2; clear T1 T2; intros. right; split; split; simpl; auto with zarith. rewrite Zabs_eq; auto; apply Zle_lt_trans with (2:=H8); rewrite Zabs_eq; auto. apply Zle_lt_trans with (2:=H7); rewrite Zabs_eq; auto with zarith. rewrite Zabs_eq; auto with zarith. apply Zle_trans with (2:=I1); apply Zplus_le_reg_l with 1%Z. ring_simplify; auto with zarith. apply Zle_Rle. rewrite H4; apply Rplus_le_reg_l with (1/2)%R. rewrite Rplus_comm; apply Rmult_le_reg_l with (powerRZ radix (Fexp f)); auto with real zarith. rewrite <- H2; apply Rplus_le_reg_l with (-f)%R. apply Rle_trans with (z-f)%R;[right;ring|idtac]. apply Rle_trans with (Rabs (z-f))%R;[apply RRle_abs|idtac]. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (powerRZ radix (Fexp f)). unfold FtoRradix; apply ClosestExp with b p; auto with zarith. elim H; auto. unfold FtoRradix, FtoR; simpl; right; field; auto with real. apply Zle_Rle. rewrite H4; apply Rplus_le_reg_l with (1/2)%R. rewrite (Rplus_comm (1/2)%R m); apply Rmult_le_reg_l with (powerRZ radix (Fexp f)); auto with real zarith. rewrite <- H2; apply Rplus_le_reg_l with (-z+(1/2)*(powerRZ radix (Fexp f)))%R. unfold Zminus; rewrite plus_IZR; simpl. apply Rle_trans with (-(z-f))%R;[right;unfold FtoRradix, FtoR; field; auto with real|idtac]. apply Rle_trans with (Rabs (-(z-f)))%R;[apply RRle_abs|idtac]. rewrite Rabs_Ropp; apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (powerRZ radix (Fexp f)). unfold FtoRradix; apply ClosestExp with b p; auto with zarith. elim H; auto. simpl; right; field; auto with real. unfold FNeven; rewrite FcanonicFnormalizeEq; auto with zarith. unfold Feven; rewrite <- Y1; unfold Even; exists 0%Z; auto with zarith. Qed. End Generic2. Section Velt. Variable radix : Z. Variable b : Fbound. Variables s t:nat. Variables p x q hx: float. Let b' := Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (minus t 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 Fx: Fbounded b x. Hypothesis pDef: (Closest b radix (x*((powerRZ radix s)+1))%R p). Hypothesis qDef: (Closest b radix (x-p)%R q). Hypothesis hxDef:(Closest b radix (q+p)%R hx). Hypothesis xPos: (0 < x)%R. Hypothesis Np: Fnormal radix b p. Hypothesis Nq: Fnormal radix b q. Hypothesis Nx: Fnormal radix b x. Lemma p'GivesBound: Zpos (vNum b')=(Zpower_nat radix (minus t s)). unfold b' in |- *; unfold vNum in |- *. apply trans_eq with (Z_of_nat (nat_of_P (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (minus t 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 (minus t s)) = Zpower_nat radix (minus t s)). intros H; pattern (Zpower_nat radix (minus t s)) at 2 in |- *; rewrite <- H. rewrite Zabs_absolu. rewrite <- (S_pred (Zabs_nat (Zpower_nat radix (minus t 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 p'GivesBound2: (powerRZ radix (Zminus t s)=Zpos (vNum b'))%R. rewrite p'GivesBound. rewrite Zpower_nat_Z_powerRZ; auto with zarith. rewrite inj_minus1; auto with zarith. Qed. Lemma pPos: (0 <= p)%R. unfold FtoRradix; apply RleRoundedR0 with b t (Closest b radix) (x * (powerRZ radix s + 1))%R; auto with zarith. apply ClosestRoundedModeP with t; auto with zarith. apply Rmult_le_pos; auto with real. Qed. Lemma qNeg: (q <= 0)%R. unfold FtoRradix; apply RleRoundedLessR0 with b t (Closest b radix) (x -p)%R; auto with zarith. apply ClosestRoundedModeP with t; auto with zarith. apply Rplus_le_reg_l with (p)%R; ring_simplify. generalize ClosestMonotone; unfold MonotoneP; intros. unfold FtoRradix; apply H with b x (x * (powerRZ radix s + 1))%R; auto with zarith real. apply Rplus_lt_reg_r with (-x)%R; ring_simplify. apply Rle_lt_trans with (x*0)%R;[right;ring|apply Rmult_lt_compat_l;auto with real zarith]. unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(Closest b radix)) (b:=b); auto. apply ClosestRoundedModeP with t; auto with zarith. Qed. Lemma RleRRounded: forall (f : float) (z : R), Fnormal radix b f -> Closest b radix z f -> (Rabs z <= (Rabs f)*(1+(powerRZ radix (1-t))/2))%R. intros. replace z with ((z-f)+f)%R;[idtac|ring]. apply Rle_trans with (Rabs(z-f)+Rabs(f))%R;[apply Rabs_triang|idtac]. apply Rplus_le_reg_l with (- Rabs(f))%R. ring_simplify. apply Rmult_le_reg_l with 2%nat; auto with real zarith. apply Rle_trans with (Fulp b radix t f). unfold FtoRradix; apply ClosestUlp; auto with zarith. apply Rle_trans with (Rabs f * powerRZ radix (Zsucc (- t)))%R. unfold FtoRradix; apply FulpLe2; auto with zarith. elim H; auto. rewrite FcanonicFnormalizeEq; auto with zarith; left; auto. unfold Zsucc; replace (-t+1)%Z with (1-t)%Z;[idtac|ring]. simpl; right; field; auto with real. Qed. Lemma hxExact: (FtoRradix hx=p+q)%R. replace (p+q)%R with (FtoRradix (Fminus radix p (Fopp q))). 2: unfold FtoRradix; rewrite Fminus_correct; auto; rewrite Fopp_correct;ring. apply sym_eq; unfold FtoRradix; apply ClosestIdem with b. 2: rewrite Fminus_correct; auto; rewrite Fopp_correct; auto with real. 2: fold FtoRradix; replace (p-(-q))%R with (q+p)%R; auto with real;ring. apply SterbenzAux; auto with zarith float. elim pDef; auto. apply oppBounded; elim qDef; auto. generalize ClosestMonotone; unfold MonotoneP; intros. apply H with b (-(x-p))%R p; auto with zarith real. apply Rplus_lt_reg_r with (x-p)%R. ring_simplify; auto with real. apply ClosestOpp; auto. unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(Closest b radix)) (b:=b). apply ClosestRoundedModeP with t; auto with zarith. elim pDef; auto. apply Rmult_le_reg_l with (1-(1+(powerRZ radix (1-t))/2)/(powerRZ radix s + 1))%R. apply Rmult_lt_reg_l with (2*(powerRZ radix s + 1))%R; auto with real zarith. apply Rmult_lt_0_compat; auto with real zarith. apply Rle_lt_trans with 0%R;[right;ring|idtac]. apply Rlt_le_trans with (2*powerRZ radix s - (powerRZ radix (1- t)))%R;[idtac|right; field; auto with real zarith]. apply Rplus_lt_reg_r with ((powerRZ radix (1-t)))%R. ring_simplify. apply Rle_lt_trans with (powerRZ radix s); auto with real zarith. apply Rle_lt_trans with (powerRZ radix s + 0)%R; auto with real zarith. apply Rlt_le_trans with (powerRZ radix s + powerRZ radix s)%R; auto with real zarith. right; ring. cut (0 < (powerRZ radix s + 1))%R; auto with real zarith. apply Rle_trans with ((FtoR radix (Fopp q))*(1 + (powerRZ radix (1- t))/2))%R. fold FtoRradix; apply Rle_trans with (p-x)%R. apply Rle_trans with (p - (p*(1 + powerRZ radix (1 - t) / 2) / (powerRZ radix s + 1)))%R;[right|unfold Rminus;apply Rplus_le_compat_l]. field; auto with real zarith. cut (0 < (powerRZ radix s + 1))%R; auto with real zarith. apply Ropp_le_contravar. apply Rmult_le_reg_l with (powerRZ radix s + 1)%R; auto with real zarith. apply Rle_trans with ((p * (1 + powerRZ radix (1 - t)/2)))%R;[idtac|right;field]. replace ((powerRZ radix s + 1)* x)%R with (Rabs ((x * (powerRZ radix s + 1))))%R. replace (FtoRradix p) with (Rabs p). apply RleRRounded; auto. apply Rabs_right; apply Rle_ge; apply pPos. rewrite Rabs_right; auto with real; apply Rle_ge; apply Rmult_le_pos; auto with real zarith. cut (0 < (powerRZ radix s + 1))%R; auto with real zarith. replace (p - x)%R with (Rabs (x-p))%R. replace (FtoRradix (Fopp q)) with (Rabs q)%R. apply RleRRounded; auto. rewrite Rabs_left1;[idtac|apply qNeg]. unfold FtoRradix; rewrite Fopp_correct; auto with real. rewrite Rabs_left1; auto with real. apply Rplus_le_reg_l with (p)%R; ring_simplify. generalize ClosestMonotone; unfold MonotoneP; intros. unfold FtoRradix; apply H with b x (x * (powerRZ radix s + 1))%R; auto with zarith real. apply Rplus_lt_reg_r with (-x)%R; ring_simplify. apply Rle_lt_trans with (x*0)%R;[right;ring|apply Rmult_lt_compat_l;auto with real zarith]. unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(Closest b radix)) (b:=b); auto. apply ClosestRoundedModeP with t; auto with zarith. fold FtoRradix;apply Rle_trans with ((Fopp q)*((1 - (1 + powerRZ radix (1 - t) / 2) / (powerRZ radix s + 1)) *S 1))%R;[idtac|right;ring]. apply Rmult_le_compat_l. generalize qNeg; unfold FtoRradix; rewrite Fopp_correct; auto with real. apply Rle_trans with (3/2)%R. apply Rplus_le_reg_l with (-1)%R; ring_simplify ((-1 +(1+powerRZ radix (1 - t) / 2)))%R. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (powerRZ radix (1 - t))%R;[right;field; auto with real|idtac]. apply Rle_trans with (powerRZ radix (0))%R;[idtac|right;simpl;field]; auto with real zarith. apply Rmult_le_reg_l with (/2)%R; auto with real. apply Rplus_le_reg_l with (-3/4+(1 + powerRZ radix (1 - t) / 2) / (powerRZ radix s + 1))%R. apply Rle_trans with ((1 + powerRZ radix (1 - t) / 2) / (powerRZ radix s + 1))%R;[right; field; auto with real|idtac]. cut (0 < powerRZ radix s + 1)%R; auto with real. apply Rmult_le_reg_l with (powerRZ radix s + 1)%R; auto with real zarith. apply Rmult_le_reg_l with 4%R. apply Rlt_trans with 2%R; auto with real;apply Rlt_trans with 3%R; auto with real. replace 4%R with (3+1)%R; auto with real;ring. apply Rle_trans with (4+ 2*(powerRZ radix (1 - t)))%R;[right; field; auto with real zarith|idtac]. cut (0 < (( ((powerRZ radix s + 1)))))%R; auto with real zarith. apply Rle_trans with (powerRZ radix s + 1)%R;[idtac|right;simpl;field;auto with real]. apply Rplus_le_compat. apply Rle_trans with (powerRZ radix 2)%R; [simpl;auto with real zarith|idtac]. ring_simplify (radix * 1)%R; apply Rmult_le_compat; replace 2%R with (IZR 2) ; auto with real zarith arith. apply Rle_powerRZ; auto with zarith real. apply Rle_trans with (powerRZ radix (1+(1 - t)))%R;[rewrite powerRZ_add; auto with real zarith|idtac]. apply Rmult_le_compat_r; simpl; auto with real zarith. ring_simplify (radix*1)%R; apply Rle_trans with (IZR 2); auto with real zarith. apply Rle_trans with (powerRZ radix 0)%R;[idtac|simpl; auto with real]. apply Rle_powerRZ; auto with zarith real. cut (0 < (( ((powerRZ radix s + 1)))))%R; auto with real zarith. Qed. Lemma eqLeep: (Fexp q <= Fexp p)%Z. apply Fcanonic_Rle_Zle with radix b t; auto with zarith. left; auto. left; auto. rewrite Rabs_left1;[idtac|fold FtoRradix; apply qNeg]. rewrite Rabs_right;[idtac|fold FtoRradix; apply Rle_ge; apply pPos]. rewrite <- Fopp_correct. generalize ClosestMonotone; unfold MonotoneP; intros. unfold FtoRradix; apply H with b (-(x-p))%R p; auto with zarith real. apply Rplus_lt_reg_r with (-p)%R; ring_simplify;auto with real. apply ClosestOpp; auto. unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(Closest b radix)) (b:=b); auto. apply ClosestRoundedModeP with t; auto with zarith. elim Np; auto. Qed. Lemma epLe: (Fexp p <=s+1+Fexp x)%Z. apply Zle_trans with (Fexp (Float (Fnum x) (s+1+Fexp x))). 2: simpl; auto with zarith. apply Fcanonic_Rle_Zle with radix b t; auto with zarith. left; auto. elim Nx; intros; left; split; auto with zarith. elim H; intros; split; simpl; auto with zarith. rewrite Rabs_right;[idtac|fold FtoRradix; apply Rle_ge; apply pPos]. rewrite Rabs_right;[idtac|fold FtoRradix; apply Rle_ge]. generalize ClosestMonotone; unfold MonotoneP; intros. unfold FtoRradix; apply H with b (x * (powerRZ radix s + 1))%R (x * (powerRZ radix (s + 1)))%R ; auto with zarith real. apply Rmult_lt_compat_l; auto with real. rewrite powerRZ_add; auto with real zarith; simpl; ring_simplify (radix*1)%R. apply Rlt_le_trans with (powerRZ radix s * 2%Z)%R. apply Rlt_le_trans with (powerRZ radix s+powerRZ radix s)%R. apply Rplus_lt_compat_l; apply Rle_lt_trans with (powerRZ radix 0)%R; auto with real zarith. right; simpl; ring. apply Rmult_le_compat_l; auto with real zarith. replace ((x * powerRZ radix (s + 1)))%R with (FtoRradix (Float (Fnum x) (s + 1 + Fexp x)))%R. unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(Closest b radix)) (b:=b); auto. apply ClosestRoundedModeP with t; auto with zarith. elim Fx; intros; split; simpl; auto with zarith. unfold FtoRradix, FtoR; simpl; ring_simplify. rewrite powerRZ_add; auto with real zarith; ring. apply Rle_trans with (x * powerRZ radix (s + 1))%R; auto with real zarith. apply Rmult_le_pos; auto with real zarith. unfold FtoRradix, FtoR; simpl;right;ring_simplify;repeat rewrite powerRZ_add; auto with real zarith; ring. Qed. Theorem eqLe2: (radix=2)%Z -> (Fexp q <= s+ Fexp x)%Z. intros I. cut (0 < Fnum x)%Z; [intros L|apply LtR0Fnum with radix; auto with real zarith]. cut ( (Fnum x <= Zpower_nat radix t -3)%Z \/ (Fnum x = Zpower_nat radix t -2)%Z \/ (Fnum x = Zpower_nat radix t -1)%Z). intros H; case H; clear H; intros H. cut (exists g:float, (Fnormal radix b g)/\(FtoRradix g=(Fnum x+2)*(powerRZ radix (Fexp x+s)))%R/\ (Fexp g=Fexp x +s)%Z). intros T; elim T; intros g T'; elim T'; intros H1 T''; elim T''; intros H2 H3; clear T T' T''. apply Zle_trans with (Fexp g); auto with zarith. apply Fcanonic_Rle_Zle with radix b t; auto with zarith. left; auto. left; auto. fold FtoRradix; rewrite <- Rabs_Ropp. replace (Rabs (-q))%R with (Rabs ((p-x)+((x-p)-q)))%R;[idtac|ring_simplify ((p-x)+((x-p)-q))%R; auto with real]. apply Rle_trans with (Rabs (p-x)+ Rabs((x-p)-q))%R;[apply Rabs_triang|idtac]. apply Rle_trans with ((p - x)+ /2* (powerRZ radix (Fexp q)))%R;[apply Rplus_le_compat|idtac]. rewrite Rabs_right; auto with real. apply Rle_ge; apply Rplus_le_reg_l with (x)%R; ring_simplify. generalize ClosestMonotone; unfold MonotoneP; intros. unfold FtoRradix; apply H0 with b x (x * (powerRZ radix s + 1))%R; auto with zarith real. apply Rplus_lt_reg_r with (-x)%R; ring_simplify. apply Rle_lt_trans with (x*0)%R;[right;ring|apply Rmult_lt_compat_l;auto with real zarith]. unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(Closest b radix)) (b:=b); auto. apply ClosestRoundedModeP with t; auto with zarith. apply Rmult_le_reg_l with (2%nat); auto with real arith. apply Rle_trans with (powerRZ radix (Fexp q)). unfold FtoRradix; apply ClosestExp with b t; auto with zarith. right; simpl; field; auto with real. apply Rle_trans with ((x * (powerRZ radix s + 1)+/ 2 * powerRZ radix (Fexp p)) - x + / 2 * powerRZ radix (Fexp q))%R. apply Rplus_le_compat_r; unfold Rminus; apply Rplus_le_compat_r. apply Rplus_le_reg_l with (-( x * (powerRZ radix s + 1)))%R. apply Rle_trans with (Rabs ((- (x * (powerRZ radix s + 1)) + p)))%R; [apply RRle_abs|idtac]. rewrite <- Rabs_Ropp. replace (- (- (x * (powerRZ radix s + 1)) + p))%R with ((x * (powerRZ radix s + 1)-p))%R;[idtac|ring]. apply Rle_trans with (/ 2 * powerRZ radix (Fexp p))%R;[idtac|right;ring]. apply Rmult_le_reg_l with (2%nat); auto with real arith. apply Rle_trans with (powerRZ radix (Fexp p)). unfold FtoRradix; apply ClosestExp with b t; auto with zarith. right; simpl; field; auto with real. apply Rle_trans with (x * (powerRZ radix s)+(/ 2 * powerRZ radix (Fexp p)+/ 2 * powerRZ radix (Fexp q)))%R; [right;ring|idtac]. apply Rle_trans with (x * powerRZ radix s + powerRZ radix (Fexp p))%R;[apply Rplus_le_compat_l|idtac]. apply Rle_trans with (/ 2 * powerRZ radix (Fexp p) + / 2 * powerRZ radix (Fexp p))%R; [apply Rplus_le_compat_l|right; field; auto with real]. apply Rmult_le_compat_l; auto with real; apply Rle_powerRZ; auto with real zarith. apply eqLeep. apply Rle_trans with (x * powerRZ radix s + radix * powerRZ radix (s+Fexp x))%R;[apply Rplus_le_compat_l|idtac]. apply Rle_trans with (powerRZ radix (s+1+Fexp x))%R;[apply Rle_powerRZ; auto with real zarith; apply epLe|idtac]. right; repeat rewrite powerRZ_add; auto with real zarith; simpl; ring. right; rewrite H2; rewrite Rabs_mult. rewrite Rabs_right;[idtac|apply Rle_ge; auto with real zarith]. rewrite Rabs_right;[idtac|apply Rle_ge; auto with real zarith]. unfold FtoRradix, FtoR; repeat rewrite powerRZ_add; rewrite I; simpl; auto with real zarith; ring. apply Rle_trans with ((Fnum x)+0)%R; auto with real zarith; ring_simplify ((Fnum x)+0)%R; auto with real zarith. exists (Float (Fnum x +2) (Fexp x + s)). elim Nx; elim Fx; intros. repeat split; simpl; auto with zarith. rewrite Zabs_eq; auto with zarith. rewrite Zabs_eq; auto with zarith. rewrite Zabs_eq in H3; auto with zarith. apply Zle_trans with (1:=H3); auto with zarith. unfold FtoRradix, FtoR; simpl; rewrite plus_IZR; simpl; ring. cut (exists eps:R, (IZR (Fnum x) = (powerRZ radix t - eps))%R /\ ((eps=1)%R \/ (eps=2)%R)). clear H; intros T; elim T; intros eps T'; elim T'; intros H H'; clear T T'. cut (p=Float (Zpower_nat radix (pred t)+ (Zpower_nat radix (Zabs_nat(t-s-1)))-1) (Fexp x+s+1)). intros pEq; cut (FtoRradix p = powerRZ radix (Fexp x)*(powerRZ radix (s+1))*(powerRZ radix (t-1)+(powerRZ radix (t-s-1))-1))%R; [intros pEqR|idtac]. cut (Fnormal radix b (Float ((Zpower_nat radix t - 2)) (Fexp x + s)));[intros|idtac]. cut (FtoRradix (Float ( (Zpower_nat radix t - 2)) (Fexp x + s))=powerRZ radix (Fexp x+s)*(powerRZ radix t-2))%R;[intros|idtac]. cut (((s=2) /\ (eps=2)%R) \/ (((eps=1)%R \/ (2 < s)%Z))). 2: case H'; intros T; auto with real. 2: case (Zle_lt_or_eq 2 s); auto with real zarith. intros T; case T; clear T; intros P. apply Zle_trans with (Fexp (Fopp q));[simpl; auto with zarith|idtac]. cut (Float (Zpower_nat radix t - 2) (Fexp x + s) < p-x)%R;[intros I1|idtac]. cut (p-x < FSucc b radix t (Float (Zpower_nat radix t - 2) (Fexp x + s)) )%R;[intros I2|idtac]. generalize ClosestMinOrMax;unfold MinOrMaxP; intros K. lapply (K b radix (p-x)%R (Fopp q)). 2: replace (p-x)%R with (-(x-p))%R;[apply ClosestOpp; auto|ring]. intros K'; case K'; clear K K'; intros K. replace (Fopp q) with (Float (Zpower_nat radix t - 2) (Fexp x + s));[simpl; auto with zarith|idtac]. apply FcanonicUnique with radix b t; auto with zarith. left; auto. apply FcanonicFopp; left; auto. generalize MinUniqueP; unfold UniqueP; intros M. apply M with b (p-x)%R; auto. apply MinBinade with t; auto with zarith real. elim H0; auto. fold FtoRradix; unfold FNSucc. rewrite FcanonicFnormalizeEq; auto with real zarith. left; auto. replace (Fopp q) with (FSucc b radix t (Float (Zpower_nat radix t - 2) (Fexp x + s))). rewrite FSuccSimpl4; simpl; auto with zarith. unfold pPred; rewrite pGivesBound; unfold Zpred; auto with zarith. unfold nNormMin. cut ((- Zpower_nat radix (pred t)) < (Zpower_nat radix t - 2))%Z; auto with zarith. apply Zlt_le_trans with 0%Z. apply Zlt_Zopp_Inv; simpl; auto with zarith. apply Zlt_le_trans with (Zpower_nat radix (pred t)); auto with zarith. apply Zplus_le_reg_l with 2%Z; apply Zle_trans with (Zpower_nat radix 1). rewrite I; simpl; auto with zarith. apply Zle_trans with (Zpower_nat radix t); auto with zarith. apply FcanonicUnique with radix b t; auto with zarith. apply FSuccCanonic; auto with zarith; left; auto. apply FcanonicFopp; left; auto. generalize MaxUniqueP; unfold UniqueP; intros M. apply M with b (p-x)%R; auto. apply MaxBinade with t; auto with zarith real. apply FBoundedSuc; auto with zarith; elim H0; auto. fold FtoRradix; unfold FNPred. rewrite FcanonicFnormalizeEq; auto with real zarith. rewrite FPredSuc; auto with zarith real. left; auto. apply FSuccCanonic; auto with zarith; left; auto. rewrite FSuccSimpl4; simpl; auto with zarith. 2:unfold pPred; rewrite pGivesBound; unfold Zpred; auto with zarith. 2:unfold nNormMin. 2:cut ((- Zpower_nat radix (pred t)) < (Zpower_nat radix t - 2))%Z; auto with zarith. 2:apply Zlt_le_trans with 0%Z. 2:apply Zlt_Zopp_Inv; simpl; auto with zarith. 2:apply Zlt_le_trans with (Zpower_nat radix (pred t)); auto with zarith. 2:apply Zplus_le_reg_l with 2%Z; apply Zle_trans with (Zpower_nat radix 1). 2:rewrite I; simpl; auto with zarith. 2:apply Zle_trans with (Zpower_nat radix t); auto with zarith. rewrite pEqR; unfold FtoRradix, FtoR; simpl; rewrite H. unfold Zsucc, Zminus; rewrite plus_IZR; rewrite plus_IZR; simpl. rewrite Zpower_nat_Z_powerRZ. elim P; intros; rewrite H3. ring_simplify. repeat rewrite <- powerRZ_add; auto with real zarith. ring_simplify (Fexp x + (s+1)+(t+-1))%Z; ring_simplify (Fexp x + (s + 1) + (t + - s + -1))%Z. ring_simplify. replace (t + (Fexp x+s))%Z with (Fexp x + s + t)%Z;[idtac|ring]. unfold Rminus; rewrite Rplus_assoc;apply Rplus_lt_compat_l. repeat rewrite powerRZ_add; auto with real zarith; simpl; ring_simplify (radix*1)%R. apply Rle_lt_trans with ((powerRZ radix (Fexp x) * (-(powerRZ radix s) * radix + 2)))%R; [right;ring|idtac]. apply Rlt_le_trans with ((powerRZ radix (Fexp x)) * (-(powerRZ radix s)))%R;[apply Rmult_lt_compat_l; auto with real zarith|right;ring]. rewrite I; simpl; apply Rplus_lt_reg_r with (2*(powerRZ 2 s))%R. apply Rle_lt_trans with (powerRZ 2 1);[right; simpl; ring|idtac]. apply Rlt_le_trans with (powerRZ 2 s)%R;[apply Rlt_powerRZ; auto with real zarith|right;ring]. rewrite H1; rewrite pEqR; unfold FtoRradix, FtoR; rewrite H. elim P; intros ; rewrite H3. ring_simplify. repeat rewrite <- powerRZ_add; auto with real zarith. replace (Fexp x + (s + 1)+(t-1))%Z with (t+(Fexp x+s))%Z;[idtac|ring]. replace (Fexp x + (s + 1) + (t - s - 1))%Z with (Fexp x+t)%Z;[idtac|ring]. apply Rlt_le_trans with ((powerRZ radix (Fexp x + s+t) + (powerRZ radix (Fexp x) + (powerRZ radix (Fexp x) + (- powerRZ radix (Fexp x + (s + 1)))))))%R;[unfold Rminus;apply Rplus_lt_compat_l|right]. repeat rewrite powerRZ_add; auto with real zarith; simpl; ring_simplify (radix*1)%R. rewrite I; simpl. apply Rplus_lt_reg_r with ((powerRZ 2 (Fexp x) * powerRZ 2 s) + (powerRZ 2 (Fexp x) * powerRZ 2 s))%R. ring_simplify. apply Rmult_lt_0_compat;auto with real zarith. repeat rewrite powerRZ_add; auto with real zarith; ring. cut (Fopp q=Float ((Zpower_nat radix t-2)) (Fexp x +s)). intros qEq; apply Zle_trans with (Fexp (Fopp q));[simpl; auto with zarith|idtac]. rewrite qEq; simpl; auto with zarith. apply FcanonicUnique with radix b t; auto with zarith. apply FcanonicFopp; left; auto. left; auto. apply sym_eq;apply ImplyClosestStrict with b t (p-x)%R (Fexp x+s)%Z; auto with zarith. elim H0; auto. left; auto. replace (Fexp x + s + t - 1)%Z with (Fexp x + (s+t-1))%Z;[idtac|ring]. rewrite powerRZ_add; auto with real zarith. rewrite pEqR; unfold FtoRradix, FtoR. apply Rle_trans with ( powerRZ radix (Fexp x)*(powerRZ radix (s + 1) * (powerRZ radix (t - 1) + powerRZ radix (t - s - 1) - 1) - Fnum x))%R;[idtac|right;ring]. apply Rmult_le_compat_l; auto with real zarith. rewrite H; ring_simplify. repeat rewrite <- powerRZ_add; auto with real zarith. ring_simplify (s + 1 + (t - s - 1))%Z; ring_simplify (s + 1 + (t- 1))%Z. ring_simplify. apply Rplus_le_reg_l with ( powerRZ radix (s + 1))%R. ring_simplify. apply Rle_trans with (powerRZ radix (s + t - 1)+( (powerRZ radix (s + t - 1))))%R; [apply Rplus_le_compat_r; apply Rle_powerRZ; auto with real zarith|idtac]. apply Rle_trans with (powerRZ radix (s + t))%R;[unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith; rewrite I; simpl; right; field; auto with real zarith|idtac]. apply Rle_trans with (powerRZ radix (s + t) +0)%R;auto with real. case H'; intros T; rewrite T; auto with real. fold FtoRradix; rewrite H1. replace (Fexp x + s + t - 1)%Z with ((Fexp x+s)+(t-1))%Z;[rewrite powerRZ_add; auto with real zarith|ring]. apply Rmult_le_compat_l; auto with real zarith. apply Rplus_le_reg_l with 2%R; apply Rle_trans with (powerRZ radix t);[idtac|right;ring]. apply Rle_trans with ((powerRZ radix (t-1))+(powerRZ radix (t-1)))%R;[apply Rplus_le_compat_r|idtac]. apply Rle_trans with (powerRZ radix 1)%R;[rewrite I; simpl; auto with real|apply Rle_powerRZ; auto with real zarith]. unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith; rewrite I; simpl; right; field. elim Fx; auto with zarith. replace (Fexp x + s - 1)%Z with (Fexp x+(s-1))%Z;[rewrite powerRZ_add; auto with real zarith|ring]. fold FtoRradix; rewrite H1; rewrite pEqR. rewrite powerRZ_add with radix (Fexp x) s; auto with real zarith. unfold FtoRradix, FtoR. replace (powerRZ radix (Fexp x) * powerRZ radix (s + 1) * (powerRZ radix (t - 1) + powerRZ radix (t - s - 1) - 1) - Fnum x * powerRZ radix (Fexp x) - powerRZ radix (Fexp x) * powerRZ radix s * (powerRZ radix t - 2))%R with ((powerRZ radix (Fexp x))*(powerRZ radix (s + 1) * (powerRZ radix (t - 1) + powerRZ radix (t - s - 1) - 1) - Fnum x - powerRZ radix s * (powerRZ radix t - 2)))%R;[idtac|ring]. rewrite Rabs_mult; rewrite Rabs_right. 2: apply Rle_ge; auto with real zarith. apply Rlt_le_trans with (powerRZ radix (Fexp x) * powerRZ radix (s-1))%R. apply Rmult_lt_compat_l; auto with real zarith. ring_simplify ((powerRZ radix (s + 1) * (powerRZ radix (t - 1) + powerRZ radix (t - s - 1) - 1) - Fnum x - powerRZ radix s * (powerRZ radix t - 2)))%R. repeat rewrite <- powerRZ_add; auto with real zarith. ring_simplify (s+1+(t - s - 1))%Z; ring_simplify (s+1+(t - 1))%Z; rewrite H. replace (powerRZ radix (s + 1))%R with (powerRZ radix s + (powerRZ radix s))%R. ring_simplify (powerRZ radix (s + t) + powerRZ radix t - (powerRZ radix s + powerRZ radix s) - (powerRZ radix t - eps) - powerRZ radix (s + t) + 2 * powerRZ radix s)%R. case P; intros. rewrite H2; apply Rle_lt_trans with (powerRZ radix 0)%R;[idtac|apply Rlt_powerRZ; auto with real zarith]. rewrite Rabs_right; simpl; auto with real. apply Rle_ge; auto with real. apply Rle_lt_trans with (powerRZ radix 1)%R;[idtac|apply Rlt_powerRZ; auto with real zarith]. rewrite I; simpl; case H'; intros T; rewrite T; rewrite Rabs_right; auto with real. apply Rle_ge; auto with real. apply Rle_ge; auto with real. rewrite powerRZ_add; auto with real zarith; rewrite I; simpl; ring. right; unfold Zminus; rewrite powerRZ_add; auto with real zarith. simpl; rewrite I; simpl; field; auto with real. replace (p-x)%R with (-(x-p))%R;[apply ClosestOpp; auto|ring]. unfold FtoRradix, FtoR; simpl. unfold Zminus; rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ; simpl; ring. repeat split; simpl; auto with zarith. rewrite pGivesBound; rewrite Zabs_eq; auto with zarith. apply Zplus_le_reg_l with 2%Z; apply Zle_trans with (Zpower_nat radix 1). simpl; rewrite I; auto with zarith. apply Zle_trans with (Zpower_nat radix t); auto with zarith. elim Fx; auto with zarith. rewrite pGivesBound; rewrite Zabs_Zmult. rewrite Zabs_eq; auto with zarith. rewrite Zabs_eq. apply Zplus_le_reg_l with 4%Z; rewrite I. ring_simplify. apply Zle_trans with (Zpower_nat 2 t + Zpower_nat 2 t)%Z;[apply Zplus_le_compat|idtac]; auto with zarith. apply Zle_trans with (Zpower_nat 2 2)%Z;[simpl|idtac]; auto with zarith. apply Zplus_le_reg_l with 2%Z; apply Zle_trans with (Zpower_nat radix 1). simpl; rewrite I; auto with zarith. apply Zle_trans with (Zpower_nat radix t); auto with zarith. rewrite pEq; unfold FtoRradix, FtoR; simpl. unfold Zminus; rewrite plus_IZR; rewrite plus_IZR; simpl. repeat rewrite Zpower_nat_Z_powerRZ; simpl. rewrite inj_pred; auto with zarith; unfold Zpred. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. repeat rewrite powerRZ_add; auto with real zarith; ring. cut (Fnormal radix b (Float (Zpower_nat radix (pred t)+ (Zpower_nat radix (Zabs_nat(t-s-1)))-1) (Fexp x+s+1)));[intros|idtac]. cut (FtoRradix (Float (Zpower_nat radix (pred t)+ (Zpower_nat radix (Zabs_nat(t-s-1)))-1) (Fexp x+s+1)) = powerRZ radix (Fexp x)*(powerRZ radix (s+1))*(powerRZ radix (t-1)+(powerRZ radix (t-s-1))-1))%R. intros; apply FcanonicUnique with radix b t; auto with zarith. left; auto. left; auto. apply sym_eq;apply ImplyClosestStrict with b t (x * (powerRZ radix s + 1))%R (Fexp x+s+1)%Z; auto with zarith. elim H0; auto. left; auto. unfold FtoRradix, FtoR; ring_simplify (Fexp x + s + 1 + t - 1)%Z. repeat rewrite powerRZ_add; auto with real zarith. apply Rle_trans with (powerRZ radix (Fexp x) * (powerRZ radix s * powerRZ radix t))%R;[right;ring|idtac]. apply Rle_trans with (powerRZ radix (Fexp x)*((Fnum x)*(powerRZ radix s + 1)))%R;[idtac|right;ring]. apply Rmult_le_compat_l; auto with real zarith. rewrite H; ring_simplify ((powerRZ radix t - eps) * (powerRZ radix s + 1))%R. apply Rplus_le_reg_l with (- (powerRZ radix s * powerRZ radix t)+(powerRZ radix s * eps)+eps)%R. ring_simplify. replace (Z_of_nat t) with (1+(t-1))%Z;[rewrite powerRZ_add; auto with real zarith|ring]. apply Rle_trans with (powerRZ radix (t - 1)+ powerRZ radix (t - 1))%R;[apply Rplus_le_compat|idtac]; auto with real zarith. apply Rle_trans with (powerRZ radix (s+1))%R; [idtac|apply Rle_powerRZ;auto with real zarith]. rewrite powerRZ_add; auto with real zarith; simpl; apply Rmult_le_compat_l; auto with real zarith. case H'; intros T; rewrite T; rewrite I; auto with real. apply Rle_trans with (powerRZ radix (1))%R; [idtac|apply Rle_powerRZ;auto with real zarith]. simpl; case H'; intros T; rewrite T; rewrite I; auto with real. rewrite I; simpl; right;ring. fold FtoRradix; rewrite H1. replace (Fexp x + s + 1 + t - 1)%Z with (Fexp x + (s+t))%Z;[idtac|ring]. rewrite powerRZ_add with radix (Fexp x) (s+t)%Z; auto with real zarith. rewrite Rmult_assoc; apply Rmult_le_compat_l; auto with real zarith. apply Rplus_le_reg_l with (-(powerRZ radix (s + t)) + powerRZ radix (s + 1))%R. ring_simplify. repeat rewrite <- powerRZ_add; auto with real zarith. ring_simplify (s+1+(t - s - 1))%Z; ring_simplify (s+1+(t - 1))%Z. ring_simplify; apply Rle_powerRZ; auto with real zarith. elim Fx; auto with zarith. fold FtoRradix; rewrite H1. apply Rlt_le_trans with (powerRZ radix (s+Fexp x)). rewrite powerRZ_add with radix s (Fexp x); auto with real zarith. unfold FtoRradix, FtoR. replace (Fnum x * powerRZ radix (Fexp x) * (powerRZ radix s + 1) - powerRZ radix (Fexp x) * powerRZ radix (s + 1) * (powerRZ radix (t - 1) + powerRZ radix (t - s - 1) - 1))%R with ((Fnum x * (powerRZ radix s + 1) - powerRZ radix (s + 1) * (powerRZ radix (t - 1) + powerRZ radix (t - s - 1) - 1)) * (powerRZ radix (Fexp x)))%R;[idtac|ring]. rewrite Rabs_mult; rewrite Rabs_right with (powerRZ radix (Fexp x)). 2:apply Rle_ge; auto with real zarith. apply Rmult_lt_compat_r; auto with real zarith. rewrite H. ring_simplify ((powerRZ radix t - eps) * (powerRZ radix s + 1) - powerRZ radix (s + 1) * (powerRZ radix (t - 1) + powerRZ radix (t - s - 1) - 1))%R. repeat rewrite <- powerRZ_add; auto with real zarith. replace ((s+1+(t-s-1)))%Z with (Z_of_nat t);[idtac|ring]. replace (s+1+(t - 1))%Z with (t+s)%Z;[idtac|ring]. ring_simplify (powerRZ radix (t + s) + powerRZ radix t - eps * powerRZ radix s - eps - powerRZ radix (t+s) - powerRZ radix t + powerRZ radix (s + 1))%R. rewrite powerRZ_add; auto with real zarith; rewrite I; simpl. case H'; intros T; rewrite T. ring_simplify (-1 * powerRZ 2 s - 1 + powerRZ 2 s * (2 * 1))%R. rewrite Rabs_right; [apply Rlt_le_trans with (powerRZ 2 s-0)%R|apply Rle_ge]; auto with real zarith. unfold Rminus;apply Rplus_lt_compat_l; auto with real. apply Rplus_le_reg_l with 1%R; apply Rle_trans with (powerRZ 2 0)%R;[simpl; auto with real|idtac]. apply Rle_trans with (powerRZ 2 s)%R;[apply Rle_powerRZ; auto with real zarith|right;ring]. ring_simplify (-2 * powerRZ 2 s - 2 + powerRZ 2 s * (2 * 1))%R. rewrite Rabs_left1; auto with real. apply Rle_lt_trans with (powerRZ 2 1)%R;[right; simpl; ring|apply Rlt_powerRZ; auto with real zarith]. repeat rewrite powerRZ_add; auto with real zarith. rewrite I; simpl; right; field; auto with real. unfold FtoRradix, FtoR; simpl. unfold Zminus; rewrite plus_IZR; rewrite plus_IZR; simpl. repeat rewrite Zpower_nat_Z_powerRZ; ring_simplify. rewrite inj_pred; auto with zarith; unfold Zpred. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. repeat rewrite powerRZ_add; auto with real zarith; ring. repeat split; simpl; auto with zarith. rewrite Zabs_eq; auto with zarith. rewrite pGivesBound; apply Zlt_le_trans with (Zpower_nat radix (pred t) + Zpower_nat radix (Zabs_nat (t - s - 1)))%Z; auto with zarith. apply Zle_trans with (Zpower_nat radix (pred t)+ Zpower_nat radix (pred t))%Z;[apply Zplus_le_compat_l|idtac]. apply Zpower_nat_monotone_le; auto with zarith. apply ZleLe; rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. rewrite inj_pred; auto with zarith. pattern t at 3 in |-*; replace t with (S (pred t));auto with zarith. unfold Zpower_nat; simpl; rewrite I; auto with zarith. apply Zplus_le_reg_l with 1%Z. apply Zle_trans with (Zpower_nat radix 0)%Z;[simpl; auto with zarith|idtac]. apply Zle_trans with (Zpower_nat radix (pred t)); auto with zarith. apply Zle_trans with (Zpower_nat radix (pred t)+Zpower_nat radix (Zabs_nat (t - s - 1)))%Z; auto with zarith. apply Zle_trans with (Zpower_nat radix (pred t)+0)%Z; auto with zarith. elim Fx; auto with zarith. rewrite pGivesBound; rewrite Zabs_Zmult. rewrite Zabs_eq; auto with zarith. rewrite Zabs_eq. apply Zle_trans with (radix*(Zpower_nat radix (pred t)+0))%Z. pattern t at 1 in |-*; replace t with (S (pred t));auto with zarith. unfold Zpower_nat; simpl; auto with zarith. apply Zmult_le_compat_l; auto with zarith. apply Zplus_le_reg_l with (1-(Zpower_nat radix (pred t)))%Z. ring_simplify. apply Zle_trans with (Zpower_nat radix 0)%Z;[simpl; auto with zarith|idtac]. apply Zpower_nat_monotone_le; auto with zarith. apply Zplus_le_reg_l with 1%Z. apply Zle_trans with (Zpower_nat radix 0)%Z;[simpl; auto with zarith|idtac]. apply Zle_trans with (Zpower_nat radix (pred t)); auto with zarith. apply Zle_trans with (Zpower_nat radix (pred t)+Zpower_nat radix (Zabs_nat (t - s - 1)))%Z; auto with zarith. apply Zle_trans with (Zpower_nat radix (pred t)+0)%Z; auto with zarith. case H; intros. exists 2%R; split; auto with real; rewrite H0. unfold Zminus; rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ; auto with real zarith. exists 1%R; split; auto with real; rewrite H0. unfold Zminus; rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ; auto with real zarith. cut (Fnum x < Zpower_nat radix t )%Z. intros; auto with zarith. case (Zle_or_lt (Fnum x) (Zpower_nat radix t - 3)%Z); intros. auto with zarith. cut (Zpower_nat radix t - 2 <= Fnum x)%Z;[intros|auto with zarith]. case (Zle_lt_or_eq (Zpower_nat radix t - 2)%Z (Fnum x)); intros; auto with zarith. elim Fx; rewrite pGivesBound; rewrite Zabs_eq; intros ;auto with zarith. Qed. Lemma eqLe: (Fexp q <= s+ Fexp x)%Z \/ ((FtoRradix q= - powerRZ radix (t+s+Fexp x))%R /\(Rabs (x - hx) <= (powerRZ radix (s + Fexp x))/2)%R). cut (0 < Fnum x)%Z; [intros L|apply LtR0Fnum with radix; auto with real zarith]. cut ( (Fnum x <= Zpower_nat radix t -radix-1)%Z \/ (Zpower_nat radix t -radix <=Fnum x ))%Z. 2:case (Zle_or_lt (Zpower_nat radix t -radix)%Z (Fnum x));auto with zarith. intros H; case H; clear H; intros H. cut (exists g:float, (Fnormal radix b g)/\(FtoRradix g=(Fnum x+radix)*(powerRZ radix (Fexp x+s)))%R/\ (Fexp g=Fexp x +s)%Z). intros T; elim T; intros g T'; elim T'; intros H1 T''; elim T''; intros H2 H3; clear T T' T''. left. apply Zle_trans with (Fexp g); auto with zarith. apply Fcanonic_Rle_Zle with radix b t; auto with zarith. left; auto. left; auto. fold FtoRradix; rewrite <- Rabs_Ropp. replace (Rabs (-q))%R with (Rabs ((p-x)+((x-p)-q)))%R;[idtac|ring_simplify ((p-x)+((x-p)-q))%R; auto with real]. apply Rle_trans with (Rabs (p-x)+ Rabs((x-p)-q))%R;[apply Rabs_triang|idtac]. apply Rle_trans with ((p - x)+ /2* (powerRZ radix (Fexp q)))%R;[apply Rplus_le_compat|idtac]. rewrite Rabs_right; auto with real. apply Rle_ge; apply Rplus_le_reg_l with (x)%R; ring_simplify. generalize ClosestMonotone; unfold MonotoneP; intros. unfold FtoRradix; apply H0 with b x (x * (powerRZ radix s + 1))%R; auto with zarith real. apply Rplus_lt_reg_r with (-x)%R; ring_simplify. apply Rle_lt_trans with (x*0)%R;[right;ring|apply Rmult_lt_compat_l;auto with real zarith]. unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(Closest b radix)) (b:=b); auto. apply ClosestRoundedModeP with t; auto with zarith. apply Rmult_le_reg_l with (2%nat); auto with real arith. apply Rle_trans with (powerRZ radix (Fexp q)). unfold FtoRradix; apply ClosestExp with b t; auto with zarith. right; simpl; field; auto with real. apply Rle_trans with ((x * (powerRZ radix s + 1)+/ 2 * powerRZ radix (Fexp p)) - x + / 2 * powerRZ radix (Fexp q))%R. apply Rplus_le_compat_r; unfold Rminus; apply Rplus_le_compat_r. apply Rplus_le_reg_l with (-( x * (powerRZ radix s + 1)))%R. apply Rle_trans with (Rabs ((- (x * (powerRZ radix s + 1)) + p)))%R; [apply RRle_abs|idtac]. rewrite <- Rabs_Ropp. replace (- (- (x * (powerRZ radix s + 1)) + p))%R with ((x * (powerRZ radix s + 1)-p))%R;[idtac|ring]. apply Rle_trans with (/ 2 * powerRZ radix (Fexp p))%R;[idtac|right;ring]. apply Rmult_le_reg_l with (2%nat); auto with real arith. apply Rle_trans with (powerRZ radix (Fexp p)). unfold FtoRradix; apply ClosestExp with b t; auto with zarith. right; simpl; field; auto with real. apply Rle_trans with (x * (powerRZ radix s)+(/ 2 * powerRZ radix (Fexp p)+/ 2 * powerRZ radix (Fexp q)))%R; [right;ring|idtac]. apply Rle_trans with (x * powerRZ radix s + powerRZ radix (Fexp p))%R;[apply Rplus_le_compat_l|idtac]. apply Rle_trans with (/ 2 * powerRZ radix (Fexp p) + / 2 * powerRZ radix (Fexp p))%R; [apply Rplus_le_compat_l|right; field; auto with real]. apply Rmult_le_compat_l; auto with real; apply Rle_powerRZ; auto with real zarith. apply eqLeep. apply Rle_trans with (x * powerRZ radix s + radix * powerRZ radix (s+Fexp x))%R;[apply Rplus_le_compat_l|idtac]. apply Rle_trans with (powerRZ radix (s+1+Fexp x))%R;[apply Rle_powerRZ; auto with real zarith; apply epLe|idtac]. right; repeat rewrite powerRZ_add; auto with real zarith; simpl; ring. right; rewrite H2; rewrite Rabs_mult. rewrite Rabs_right;[idtac|apply Rle_ge; auto with real zarith]. rewrite Rabs_right;[idtac|apply Rle_ge; auto with real zarith]. unfold FtoRradix, FtoR; repeat rewrite powerRZ_add; simpl; auto with real zarith; ring. apply Rle_trans with ((Fnum x)+0)%R; auto with real zarith; ring_simplify ((Fnum x)+0)%R; auto with real zarith. exists (Float (Fnum x +radix) (Fexp x + s)). elim Nx; elim Fx; intros. repeat split; simpl; auto with zarith. rewrite Zabs_eq; auto with zarith. rewrite Zabs_eq; auto with zarith. rewrite Zabs_eq in H3; auto with zarith. apply Zle_trans with (1:=H3); auto with zarith. unfold FtoRradix, FtoR; simpl; rewrite plus_IZR; simpl; ring. cut (FtoRradix p <= powerRZ radix (Fexp x+t+s) + powerRZ radix (Fexp x+t))%R;[intros J1|idtac]. cut (- (x - p) < powerRZ radix (Fexp x) * (powerRZ radix (t + s) + radix + 1))%R;[intros J2|idtac]. cut (FtoRradix (Fopp q) <= powerRZ radix (t + s + Fexp x))%R;[intros V|idtac]. case V; auto; intros V'. left; replace (Fexp q) with (Fexp (Fopp q)); [idtac|simpl; auto]. replace (s+Fexp x)%Z with (Fexp (FPred b radix t (Float (nNormMin radix t) (s+1+Fexp x)))). apply Fcanonic_Rle_Zle with radix b t; auto with zarith. apply FcanonicFopp; left; auto. apply FPredCanonic; auto with zarith. apply FcanonicNnormMin; elim Fx; auto with zarith. rewrite Rabs_right. rewrite Rabs_right. apply FPredProp; auto with zarith. apply FcanonicFopp; left; auto. apply FcanonicNnormMin; elim Fx; auto with zarith. fold FtoRradix; apply Rlt_le_trans with (1:=V'). unfold FtoRradix, FtoR, nNormMin; simpl. rewrite Zpower_nat_Z_powerRZ; rewrite <- powerRZ_add; auto with real zarith. replace (pred t +(s+1+Fexp x))%Z with (t+s+Fexp x)%Z; auto with real. rewrite inj_pred; unfold Zpred; auto with zarith. apply Rle_ge; apply R0RltRlePred; auto with zarith. apply LtFnumZERO; auto. simpl; unfold nNormMin; auto with zarith. apply Rle_ge; rewrite Fopp_correct; auto; generalize qNeg; auto with real. rewrite FPredSimpl2; simpl; auto with zarith. elim Fx; auto with zarith. right; split. unfold FtoRradix in V'; rewrite Fopp_correct in V'; auto with real. fold FtoRradix; rewrite <- V'; ring_simplify; auto with real. rewrite hxExact. replace (x-(p+q))%R with ((x-p)- q)%R;[idtac|ring]. case (Rle_or_lt (x-p)%R q). intros. rewrite Rabs_left1. 2: apply Rplus_le_reg_l with (FtoRradix q); ring_simplify (q+0)%R. 2: apply Rle_trans with (2:=H0); right; ring. apply Rle_trans with (q+(p+-x))%R;[right; ring|idtac]. apply Rle_trans with (-(powerRZ radix (t + s + Fexp x)) + ((powerRZ radix (Fexp x + t + s) + powerRZ radix (Fexp x + t))+ -((powerRZ radix t -radix)*powerRZ radix (Fexp x))))%R. apply Rplus_le_compat. rewrite <- V'; unfold FtoRradix; rewrite Fopp_correct; auto with real. apply Rplus_le_compat; auto with real. apply Ropp_le_contravar. unfold FtoRradix, FtoR; apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (IZR (Zpower_nat radix t - radix)); auto with real zarith. unfold Zminus; rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ; rewrite Ropp_Ropp_IZR; auto with real zarith. replace (t+s+Fexp x)%Z with (Fexp x+t+s)%Z; auto with zarith. ring_simplify. pattern (IZR radix) at 4 in |-*; replace (IZR radix) with (powerRZ radix 1); auto with real zarith. repeat rewrite <- powerRZ_add; auto with real zarith. rewrite Zplus_comm. ring_simplify. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (radix*powerRZ radix (1+Fexp x))%R. apply Rmult_le_compat_r; replace 2%R with (IZR 2); auto with real zarith. apply Rle_trans with (powerRZ radix (2+Fexp x)). right; repeat rewrite powerRZ_add; auto with real zarith; simpl; ring. apply Rle_trans with (powerRZ radix (s+Fexp x)). apply Rle_powerRZ; auto with real zarith. right; field; auto with real. intros. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (powerRZ radix (s + Fexp x));[idtac|right; field; auto with real]. apply Rplus_le_reg_l with (-( Rabs (x - p - q)))%R. ring_simplify (- Rabs (x - p - q) + 2 * Rabs (x - p - q))%R. cut (exists qplus:float, (Fbounded b qplus)/\ (qplus-q=powerRZ radix (s+Fexp x))%R /\ qplus=FNSucc b radix t q). intros T; elim T; intros qplus T'; elim T'; intros H1 T''; elim T''; intros; clear T T' T''. apply Rle_trans with (Rabs (x-p-qplus))%R. elim qDef; fold FtoRradix; intros. replace (x-p-q)%R with (-(q-(x-p)))%R;[rewrite Rabs_Ropp|ring]. replace (x-p-qplus)%R with (-(qplus-(x-p)))%R;[rewrite Rabs_Ropp|ring]. apply H5; auto. rewrite Rabs_left1. rewrite Rabs_right. rewrite <- H2; right; ring. apply Rle_ge; apply Rplus_le_reg_l with (FtoRradix q); ring_simplify (q+0)%R. apply Rlt_le; apply Rlt_le_trans with (1:=H0); right; ring. apply Rplus_le_reg_l with (FtoRradix qplus). ring_simplify. cut (isMax b radix (x-p)%R qplus). intros H4; elim H4; intros H5 H6; elim H6; intros H7 H8; auto with real. rewrite H3; apply MinMax; auto with zarith real. generalize ClosestMinOrMax; unfold MinOrMaxP; intros T. case (T b radix (x-p)%R q); auto. clear T; intros W; elim W; intros T1 T2; elim T2; intros H4 H5; clear T1 T2 H5. fold FtoRradix in H4; Contradict H4; auto with real. exists (FNSucc b radix t q); split. apply FcanonicBound with radix; auto. apply FNSuccCanonic; auto with zarith; elim Nq; auto. split; auto. unfold FNSucc; rewrite FcanonicFnormalizeEq; auto with zarith. 2: left; auto. unfold FtoRradix; rewrite <- Fminus_correct; auto. replace q with (Float (-(nNormMin radix t)) (s+1+Fexp x)). rewrite FSuccDiff3; auto with zarith real. unfold FtoR; simpl. replace (Zpred (s+1+Fexp x))%Z with (s+Fexp x)%Z; unfold Zpred; auto with real zarith. simpl; elim Fx; auto with zarith. apply FnormalUnique with radix b t; auto with zarith. replace (Float (- nNormMin radix t) (s + 1 + Fexp x)) with (Fopp (Float (nNormMin radix t) (s + 1 + Fexp x))); [idtac|unfold Fopp; auto with zarith]. apply FnormalFop; auto. apply FnormalNnormMin; auto with zarith; elim Fx; auto with zarith. apply trans_eq with (-(-FtoR radix q))%R; auto with real. rewrite <- Fopp_correct; fold FtoRradix. rewrite V'; unfold FtoRradix, FtoR, nNormMin; simpl. rewrite Ropp_Ropp_IZR; rewrite Zpower_nat_Z_powerRZ. apply trans_eq with (-(powerRZ radix (pred t) * powerRZ radix (s + 1 + Fexp x)))%R; auto with real. rewrite <- powerRZ_add; auto with real zarith. replace ((pred t + (s + 1 + Fexp x)))%Z with (t + s + Fexp x)%Z; auto with real. rewrite inj_pred; auto with zarith; unfold Zpred; ring. apply Rle_trans with (FtoRradix (Float 1%Z (t+s+Fexp x)));[idtac|right; unfold FtoRradix, FtoR; simpl; ring]. generalize ClosestMonotone; unfold MonotoneP; intros. unfold FtoRradix; apply H0 with b (-(x-p))%R ((powerRZ radix (Fexp x))*(powerRZ radix (t+s)+radix+1))%R; auto with zarith real. apply ClosestOpp; auto. clear H0; generalize ClosestCompatible; unfold CompatibleP; intros T. cut (Fbounded b (Float 1 (t + s + Fexp x)));[intros H1|idtac]. 2: split; simpl; elim Fx; intros; auto with zarith. 2: apply vNumbMoreThanOne with radix t; auto with zarith. apply T with (powerRZ radix (Fexp x) * (powerRZ radix (t + s) + radix + 1))%R (Fnormalize radix b t (Float 1 (t + s + Fexp x))); auto with real. 2: rewrite FnormalizeCorrect; auto with zarith. apply ImplyClosest with t (Fexp x+s+1)%Z; auto with zarith. apply FnormalizeBounded; auto with zarith. apply FnormalizeCanonic; auto with zarith. apply Rle_trans with (powerRZ radix (Fexp x) * powerRZ radix (t + s))%R. rewrite <- powerRZ_add; auto with real zarith. replace (Fexp x + s + 1 + t - 1)%Z with (Fexp x + (t + s))%Z; auto with real zarith. apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (powerRZ radix (t + s) +0)%R; auto with real zarith. rewrite Rplus_assoc; apply Rplus_le_compat_l; auto with real zarith. rewrite FnormalizeCorrect; auto with zarith; unfold FtoR; simpl; right. replace (Fexp x + s + 1 + t - 1)%Z with (t + s + Fexp x)%Z; ring. elim Fx; auto with zarith. rewrite FnormalizeCorrect; auto with zarith; unfold FtoR; simpl. replace (powerRZ radix (Fexp x) * (powerRZ radix (t + s) + radix + 1) - 1 * powerRZ radix (t + s + Fexp x))%R with (powerRZ radix (Fexp x) *(radix+1))%R. rewrite Rabs_right. replace (Fexp x+s+1)%Z with (Fexp x+(1+s))%Z;[idtac|ring]. rewrite powerRZ_add; auto with real zarith. apply Rle_trans with (powerRZ radix (Fexp x) * (powerRZ radix (1+s) */ 2))%R;[idtac|right;unfold Rdiv; ring]. apply Rmult_le_compat_l; auto with real zarith. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (powerRZ radix (1+s));[idtac|right; field; auto with real]. rewrite powerRZ_add; auto with real zarith. apply Rmult_le_compat; auto with real zarith. simpl; ring_simplify (radix*1)%R; replace 2%R with (IZR 2); auto with real zarith. apply Rle_trans with (powerRZ radix 2); [idtac|apply Rle_powerRZ; auto with real zarith]. simpl; ring_simplify (radix*1)%R. apply Rle_trans with (radix+radix)%R; auto with real zarith. apply Rle_trans with (2*radix)%R; [right;ring|idtac]. apply Rmult_le_compat_r; auto with real zarith; replace 2%R with (IZR 2); auto with real zarith. apply Rle_ge; apply Rmult_le_pos; auto with real zarith. repeat rewrite powerRZ_add; auto with real zarith; ring. replace (-(x-p))%R with (p+-x)%R by ring. apply Rle_lt_trans with ((powerRZ radix (Fexp x + t + s) + powerRZ radix (Fexp x + t))+ -(powerRZ radix (Fexp x + t) - radix*powerRZ radix (Fexp x)))%R. apply Rplus_le_compat; auto with real. apply Ropp_le_contravar; unfold FtoRradix, FtoR; rewrite powerRZ_add; auto with real zarith. apply Rle_trans with ((powerRZ radix t - radix)*powerRZ radix (Fexp x))%R;[right;ring|idtac]. apply Rmult_le_compat_r; auto with real zarith; rewrite <- Zpower_nat_Z_powerRZ. apply Rle_trans with (IZR ((Zpower_nat radix t - radix))); auto with real zarith. unfold Zminus; rewrite plus_IZR; rewrite Ropp_Ropp_IZR; simpl; auto with real. unfold FtoRradix, FtoR; simpl. apply Rplus_lt_reg_r with (radix * powerRZ radix (Fexp x))%R. ring_simplify. rewrite Rplus_assoc; apply Rplus_lt_compat_l. rewrite <- powerRZ_add; auto with real zarith. replace (Fexp x+(t+s))%Z with (Fexp x +t+s)%Z; auto with zarith real. apply Rle_lt_trans with (powerRZ radix (Fexp x + t + s)+0)%R; auto with real zarith. cut ( powerRZ radix (Fexp x + t + s) + powerRZ radix (Fexp x + t)= Float (Zpower_nat radix (pred t)+Zpower_nat radix (Zabs_nat (t-s-1))) (Fexp x+s+1))%R. cut (Fbounded b (Float (Zpower_nat radix (pred t)+Zpower_nat radix (Zabs_nat (t-s-1))) (Fexp x+s+1))). intros. rewrite H1. generalize ClosestMonotone; unfold MonotoneP; intros. unfold FtoRradix; apply H2 with b (x * (powerRZ radix s + 1))%R (powerRZ radix (Fexp x + t + s) + powerRZ radix (Fexp x + t))%R; auto with zarith real. unfold FtoRradix, FtoR. apply Rlt_le_trans with ((powerRZ radix t * powerRZ radix (Fexp x) * (powerRZ radix s + 1)))%R. apply Rmult_lt_compat_r; auto with real zarith. apply Rmult_lt_compat_r; auto with real zarith. rewrite <- Zpower_nat_Z_powerRZ; rewrite <- pGivesBound; elim Fx; intros. rewrite Zabs_eq in H3; auto with zarith real. right;repeat rewrite powerRZ_add; auto with real zarith; ring. rewrite H1; unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(Closest b radix)) (b:=b); auto. apply ClosestRoundedModeP with t; auto with zarith. split; simpl. rewrite pGivesBound; rewrite Zabs_eq ; auto with zarith. apply Zlt_le_trans with (Zpower_nat radix (pred t) + Zpower_nat radix (pred t))%Z. apply Zplus_lt_compat_l; cut (Zabs_nat (t-s-1) < pred t)%nat; auto with zarith. cut (Zabs_nat (t-s-1) < pred t)%R; auto with zarith arith real. rewrite INR_IZR_INZ; rewrite INR_IZR_INZ. rewrite inj_pred; auto with zarith; rewrite <- Zabs_absolu; rewrite Zabs_eq; unfold Zpred; auto with zarith real. pattern t at 3 in |-*; replace t with (1+(pred t))%nat; auto with zarith. rewrite Zpower_nat_is_exp; replace (Zpower_nat radix 1) with radix; auto with zarith. apply Zle_trans with (2*Zpower_nat radix (pred t))%Z; auto with zarith. unfold Zpower_nat; simpl; auto with zarith. elim Fx; auto with zarith. unfold FtoRradix, FtoR; simpl; rewrite plus_IZR. repeat rewrite Zpower_nat_Z_powerRZ. rewrite Rmult_plus_distr_r. repeat rewrite <- powerRZ_add; auto with real zarith. replace (Zabs_nat (t - s - 1) + (Fexp x + s + 1))%Z with (Fexp x + t)%Z. replace (pred t + (Fexp x + s + 1))%Z with (Fexp x + t + s)%Z; auto with real. rewrite inj_pred; unfold Zpred; auto with zarith. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. Qed. Lemma eqGe: (s+ Fexp x <= Fexp q)%Z. case (Rle_or_lt ((powerRZ radix (Fexp x))*((powerRZ radix (t-1))+radix))%R x);intros H. apply Zle_trans with (Fexp (Float (nNormMin radix t) (s+Fexp x)));[simpl; auto with zarith|idtac]. apply Zle_trans with (Fexp (Fopp q));[idtac|simpl; auto with zarith]. apply Fcanonic_Rle_Zle with radix b t; auto with zarith. apply FcanonicNnormMin; auto with zarith. elim Fx; auto with zarith. apply FcanonicFopp; left; auto. rewrite Fopp_correct; fold FtoRradix; rewrite Rabs_Ropp. replace (FtoRradix q) with ((-(p-x))-((x-p)-q))%R;[idtac|ring]. apply Rle_trans with (2:=Rabs_triang_inv (-(p-x))%R ((x-p)-q)%R). apply Rle_trans with ((x*(powerRZ radix s)-(powerRZ radix (Fexp p))/2)-(powerRZ radix (Fexp q))/2)%R. apply Rle_trans with (((powerRZ radix (Fexp x) * (powerRZ radix (t - 1) + radix))) * powerRZ radix s - powerRZ radix (s+1+Fexp x) / 2 - powerRZ radix (s+1+Fexp x) / 2)%R. unfold nNormMin, FtoRradix, FtoR; simpl;rewrite Zpower_nat_Z_powerRZ. rewrite <- powerRZ_add; auto with real zarith. rewrite Rabs_right. 2:apply Rle_ge; auto with real zarith. replace (pred t+(s+Fexp x))%Z with (t-1+(s+Fexp x))%Z; auto with real zarith. 2:rewrite inj_pred; unfold Zpred; auto with zarith arith. apply Rle_trans with (powerRZ radix (Fexp x) * (powerRZ radix (t - 1) + radix) * powerRZ radix s - powerRZ radix (s + 1 + Fexp x))%R;[idtac|right;field; auto with real]. rewrite Rmult_plus_distr_l. rewrite Rmult_plus_distr_r. pattern (IZR radix) at 6 in |-*; replace (IZR radix) with (powerRZ radix 1)%R; [idtac|simpl; ring]. repeat rewrite <- powerRZ_add; auto with real zarith. replace (Fexp x + (t - 1) + s)%Z with (t - 1 + (s + Fexp x))%Z;[idtac|ring]. replace (s + 1+ Fexp x)%Z with (Fexp x+1+s)%Z;[right|idtac];ring. unfold Rminus; apply Rplus_le_compat. apply Rplus_le_compat. apply Rmult_le_compat_r; auto with real zarith. apply Ropp_le_contravar; unfold Rdiv; apply Rmult_le_compat_r; auto with real. apply Rle_powerRZ; auto with real zarith; apply epLe. apply Ropp_le_contravar; unfold Rdiv; apply Rmult_le_compat_r; auto with real. apply Rle_powerRZ; auto with real zarith. apply Zle_trans with (Fexp p);[apply eqLeep|apply epLe]. unfold Rminus; apply Rplus_le_compat. rewrite Rabs_left1. apply Rplus_le_reg_l with ((powerRZ radix (Fexp p) / 2)+x-p)%R. ring_simplify. apply Rle_trans with ((x * (powerRZ radix s + 1))-p)%R;[right;ring|idtac]. apply Rle_trans with (Rabs ((x * (powerRZ radix s + 1))-p))%R;[apply RRle_abs|idtac]. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (powerRZ radix (Fexp p)). unfold FtoRradix; apply ClosestExp with b t; auto with zarith. simpl; right; field; auto with real. apply Rplus_le_reg_l with (p)%R; ring_simplify. generalize ClosestMonotone; unfold MonotoneP; intros. unfold FtoRradix; apply H0 with b x (x * (powerRZ radix s + 1))%R; auto with zarith real. apply Rplus_lt_reg_r with (-x)%R; ring_simplify. apply Rle_lt_trans with (x*0)%R;[right;ring|apply Rmult_lt_compat_l;auto with real zarith]. unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(Closest b radix)) (b:=b); auto. apply ClosestRoundedModeP with t; auto with zarith. apply Ropp_le_contravar. replace (x + - p + - q)%R with ((x-p)-q)%R;[idtac|ring]. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (powerRZ radix (Fexp q)). unfold FtoRradix; apply ClosestExp with b t; auto with zarith. simpl; right; field; auto with real. case (Rle_or_lt (powerRZ radix (Fexp x) * (powerRZ radix (t - 1) + 1))%R x); intros H'. cut ((powerRZ radix (Fexp x) * ((powerRZ radix (s+t-1))+(powerRZ radix (t-1))+(powerRZ radix s))) <= p)%R;[intros|idtac]. apply Zle_trans with (Fexp (Float (nNormMin radix t) (Fexp x+s)));[simpl;auto with zarith|idtac]. apply Fcanonic_Rle_Zle with radix b t; auto with real zarith float. apply FcanonicNnormMin; auto with zarith; elim Fx; auto with zarith. left; auto. rewrite Rabs_right. rewrite Rabs_left1. rewrite <- Fopp_correct. generalize ClosestMonotone; unfold MonotoneP; intros. unfold FtoRradix; apply H1 with b (Float (nNormMin radix t) (Fexp x + s)) (-(x-p))%R. 2: unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(Closest b radix)) (b:=b); auto. 2:apply ClosestRoundedModeP with t; auto with zarith. 2: apply FcanonicBound with radix; apply FcanonicNnormMin; auto with zarith; elim Fx; auto with zarith. 2: apply ClosestOpp; auto. clear H1; replace (-(x-p))%R with (p+-x)%R by ring. apply Rlt_le_trans with (((powerRZ radix (Fexp x) * (powerRZ radix (s + t - 1) + powerRZ radix (t - 1) + powerRZ radix s)))+ -(powerRZ radix (Fexp x) * (powerRZ radix (t - 1) + radix)))%R; auto with real. 2: apply Rplus_le_compat; auto with real. unfold FtoRradix, FtoR,nNormMin; simpl; rewrite Zpower_nat_Z_powerRZ. repeat rewrite Rmult_plus_distr_l. repeat rewrite <- powerRZ_add; auto with real zarith. replace (pred t + (Fexp x + s))%Z with (Fexp x+(s + t - 1))%Z;[idtac|rewrite inj_pred; unfold Zpred; auto with zarith]. apply Rplus_lt_reg_r with ((radix * powerRZ radix (Fexp x))- (powerRZ radix (Fexp x+(s + t - 1))))%R. ring_simplify. apply Rle_lt_trans with (powerRZ radix (1+Fexp x)); auto with real zarith. rewrite powerRZ_add; auto with real zarith; simpl; right;ring. apply qNeg. apply Rle_ge; apply LeFnumZERO; simpl; auto with zarith float. unfold nNormMin; auto with zarith. cut ( (powerRZ radix (Fexp x) * (powerRZ radix (s + t - 1) + powerRZ radix (t - 1) + powerRZ radix s))= (Float ((Zpower_nat radix (pred t) + Zpower_nat radix (Zabs_nat (t -s-1)) + 1)) ((Fexp x)+s)))%R;[intros V1|idtac]. cut (Fbounded b ( Float ((Zpower_nat radix (pred t) + Zpower_nat radix (Zabs_nat (t -s-1)) + 1))%Z ((Fexp x)+s)));[intros V2|idtac]. rewrite V1. generalize ClosestMonotone; unfold MonotoneP; intros. unfold FtoRradix; apply H0 with b ( (Float (Zpower_nat radix (pred t) + Zpower_nat radix (Zabs_nat (t - s - 1)) + 1) (Fexp x + s))%R) (x * (powerRZ radix s + 1))%R; auto with zarith real. 2: unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(Closest b radix)) (b:=b); auto. 2:apply ClosestRoundedModeP with t; auto with zarith. rewrite <- V1; clear H0 V2 V1. apply Rlt_le_trans with ( (powerRZ radix (Fexp x) * (powerRZ radix (t - 1) + 1) *(powerRZ radix s + 1)))%R. 2: apply Rmult_le_compat_r; auto with real zarith. rewrite Rmult_assoc; apply Rmult_lt_compat_l; auto with real zarith. rewrite Rmult_plus_distr_l; rewrite Rmult_plus_distr_r. rewrite <- powerRZ_add; auto with real zarith. apply Rlt_le_trans with ((powerRZ radix (s + t - 1))+ powerRZ radix (t - 1)+ powerRZ radix s+1)%R . repeat rewrite Rplus_assoc; repeat apply Rplus_lt_compat_l; auto with real zarith. replace (s+t-1)%Z with (t-1+s)%Z; [right; ring|ring]. split; simpl. rewrite pGivesBound; rewrite Zabs_eq; auto with zarith. apply Zlt_le_trans with ((Zpower_nat radix (pred t) + Zpower_nat radix (pred (pred t)) + Zpower_nat radix (pred (pred t))))%Z. repeat rewrite <- Zplus_assoc;apply Zplus_lt_compat_l. cut (Zpower_nat radix (Zabs_nat (t - s - 1)) <= Zpower_nat radix (pred (pred t)))%Z;[intros|idtac]. cut (1 Fcanonic radix b' v -> (Rabs (x-v) <= (powerRZ radix (s+Fexp x)) /2)%R -> (powerRZ radix (t-1+Fexp x) <= v)%R. intros. case (Rle_or_lt (powerRZ radix (t-1)+(powerRZ radix s)/2)%R (Fnum x)); intros W. fold FtoRradix; apply Rplus_le_reg_l with (-v+x-powerRZ radix (t-1+Fexp x))%R. ring_simplify. apply Rle_trans with (x-v)%R; [right; ring|idtac]. apply Rle_trans with (Rabs (x-v))%R;[apply RRle_abs|idtac]. unfold FtoRradix; apply Rle_trans with (1:=H1). unfold FtoR; rewrite powerRZ_add; auto with real zarith; unfold Rdiv. rewrite powerRZ_add; auto with real zarith. apply Rle_trans with (powerRZ radix (Fexp x) * (powerRZ radix s * / 2))%R;[right;ring|idtac]. apply Rle_trans with (powerRZ radix (Fexp x) * (- powerRZ radix (t - 1) + Fnum x))%R;[idtac|right;ring]. apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with ( - powerRZ radix (t - 1) + (powerRZ radix (t - 1) + powerRZ radix s / 2))%R; auto with real zarith. right; unfold Rdiv; ring. cut (exists eps:Z, (FtoRradix x=powerRZ radix (Fexp x)*(powerRZ radix (t-1) + eps))%R /\ (0 <= eps)%Z /\ (eps < (powerRZ radix s)/2)%R). intros T; elim T; intros eps T'; elim T'; intros H3 T''; elim T''; intros H4 H5; clear T T' T''. fold FtoRradix; rewrite H; rewrite hxExact. cut (Fbounded b (Float (Zpower_nat radix (pred t)+Zpower_nat radix (Zabs_nat (t-s-1))+eps) (s+Fexp x))); [intros Yp|idtac]. cut (FtoRradix (Float (Zpower_nat radix (pred t)+Zpower_nat radix (Zabs_nat (t-s-1))+eps) (s+Fexp x)) = powerRZ radix (Fexp x)*(powerRZ radix (t+s-1)+ powerRZ radix (t-1)+eps*powerRZ radix s))%R; [intros Yp'|idtac]. cut (Fbounded b (Float ((Zpower_nat radix (pred t)+eps)) (s+Fexp x))); [intros Yq|idtac]. cut (FtoRradix (Float ((Zpower_nat radix (pred t)+eps)) (s+Fexp x)) = powerRZ radix (Fexp x)*(powerRZ radix (t+s-1)+ eps*powerRZ radix s))%R; [intros Yq'|idtac]. cut (FtoRradix p=(powerRZ radix (Fexp x) * (powerRZ radix (t + s - 1) + powerRZ radix (t - 1) + eps * powerRZ radix s)))%R;[intros YYp|idtac]. cut (FtoRradix (Fopp q)=(powerRZ radix (Fexp x) * (powerRZ radix (t + s - 1) + eps * powerRZ radix s)))%R;[intros YYq|idtac]. replace (FtoRradix q) with (-(-q))%R; [idtac|ring]; unfold FtoRradix; rewrite <- Fopp_correct. fold FtoRradix; rewrite YYp; rewrite YYq; right. repeat rewrite powerRZ_add; auto with real zarith; ring. rewrite <- Yq'. unfold FtoRradix; apply sym_eq. apply ImplyClosestStrict with b t (-(x-p))%R (s+Fexp x)%Z; auto with zarith. left; split; auto. rewrite pGivesBound; rewrite Zabs_Zmult; rewrite Zabs_eq; auto with zarith. simpl; rewrite Zabs_eq; auto with zarith. apply Zle_trans with (radix*((Zpower_nat radix (pred t) + 0)))%Z; auto with zarith. pattern t at 1; replace t with (1+(pred t)); auto with zarith. rewrite Zpower_nat_is_exp. replace (Zpower_nat radix 1) with radix; auto with zarith. unfold Zpower_nat; simpl; auto with zarith. rewrite YYp; rewrite H3. ring_simplify. rewrite <- powerRZ_add; auto with real zarith. replace (Fexp x+(t+s-1))%Z with (s+Fexp x+t-1)%Z;[idtac|ring]. apply Rplus_le_reg_l with ( -(powerRZ radix (s + Fexp x + t - 1))+eps * powerRZ radix (Fexp x))%R. ring_simplify. rewrite Rmult_assoc; apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (powerRZ radix (Fexp x)*1)%R; auto with real; apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (powerRZ radix 0); auto with real zarith. fold FtoRradix; rewrite Yq'. apply Rle_trans with (powerRZ radix (Fexp x) *(powerRZ radix (t + s - 1) + 0))%R. ring_simplify (powerRZ radix (t + s - 1) + 0)%R. rewrite <- powerRZ_add; auto with real zarith. replace (s + Fexp x + t - 1)%Z with (Fexp x+(t + s - 1))%Z; auto with real zarith. apply Rmult_le_compat_l; auto with real zarith. apply Rplus_le_compat_l; apply Rmult_le_pos; auto with real zarith. elim Fx; auto with zarith. fold FtoRradix; rewrite Yq'; rewrite YYp; rewrite H3. ring_simplify ( (- (powerRZ radix (Fexp x) * (powerRZ radix (t - 1) + eps) - powerRZ radix (Fexp x) * (powerRZ radix (t + s - 1) + powerRZ radix (t - 1) + eps * powerRZ radix s)) - powerRZ radix (Fexp x) * (powerRZ radix (t + s - 1) + eps * powerRZ radix s)))%R. rewrite Ropp_mult_distr_l_reverse; rewrite Rabs_Ropp; rewrite Rabs_mult. rewrite Rabs_right;[idtac|apply Rle_ge; auto with real zarith]. rewrite Rabs_right;[idtac|apply Rle_ge; auto with real zarith]. unfold Rdiv; rewrite powerRZ_add; auto with real zarith. apply Rlt_le_trans with ((powerRZ radix s*/2) * powerRZ radix (Fexp x))%R;[idtac|right;ring]. rewrite Rmult_comm; apply Rmult_lt_compat_r; auto with real zarith. apply ClosestOpp; auto. rewrite <- Yp'. unfold FtoRradix; apply sym_eq. apply ImplyClosestStrict with b t (x * (powerRZ radix s + 1))%R (s+Fexp x)%Z; auto with zarith. left; split; auto. rewrite pGivesBound; rewrite Zabs_Zmult; rewrite Zabs_eq; auto with zarith. simpl; rewrite Zabs_eq; auto with zarith. apply Zle_trans with (radix*((Zpower_nat radix (pred t) + 0+0)))%Z; auto with zarith. pattern t at 1; replace t with (1+(pred t)); auto with zarith. rewrite Zpower_nat_is_exp. replace (Zpower_nat radix 1) with radix; auto with zarith. unfold Zpower_nat; simpl; auto with zarith. rewrite H3. apply Rle_trans with (powerRZ radix (Fexp x) * (powerRZ radix (t - 1) + 0) * (powerRZ radix s + 0))%R; auto with real zarith. right; ring_simplify. unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith; ring. apply Rmult_le_compat; auto with real zarith. ring_simplify (powerRZ radix (t - 1) + 0)%R; apply Rmult_le_pos; auto with real zarith. ring_simplify (powerRZ radix s+0)%R; auto with real zarith. fold FtoRradix; rewrite Yp'. apply Rle_trans with (powerRZ radix (Fexp x) *(powerRZ radix (t + s - 1) + 0+0))%R. right; ring_simplify. rewrite <- powerRZ_add; auto with real zarith. replace (s + Fexp x + t - 1)%Z with (Fexp x+(t + s - 1))%Z; auto with real zarith. apply Rmult_le_compat_l; auto with real zarith. repeat rewrite Rplus_assoc. apply Rplus_le_compat_l; apply Rplus_le_compat; auto with real zarith. apply Rmult_le_pos; auto with real zarith. elim Fx; auto with zarith. fold FtoRradix; rewrite Yp';rewrite H3. ring_simplify (powerRZ radix (Fexp x) * (powerRZ radix (t - 1) + eps) * (powerRZ radix s + 1) - powerRZ radix (Fexp x) * (powerRZ radix (t + s - 1) + powerRZ radix (t - 1) + eps * powerRZ radix s))%R. replace (t+s-1)%Z with (s+(t-1))%Z; [rewrite powerRZ_add|idtac]; auto with real zarith. ring_simplify (powerRZ radix (Fexp x) * powerRZ radix (t - 1) * powerRZ radix s + powerRZ radix (Fexp x) * eps - powerRZ radix (Fexp x) * (powerRZ radix s * powerRZ radix (t - 1)))%R. rewrite Rabs_mult. rewrite Rabs_right;[idtac|apply Rle_ge; auto with real zarith]. rewrite Rabs_right;[idtac|apply Rle_ge; auto with real zarith]. unfold Rdiv; rewrite powerRZ_add; auto with real zarith. apply Rlt_le_trans with (powerRZ radix (Fexp x)* (powerRZ radix s*/2))%R;[idtac|right;ring]. apply Rmult_lt_compat_l; auto with real zarith. unfold FtoRradix, FtoR; simpl. rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ; rewrite inj_pred; auto with zarith. unfold Zpred, Zminus; repeat rewrite powerRZ_add; auto with real zarith. simpl; ring. split; simpl. clear Yp'; elim Yp; simpl; intros. rewrite Zabs_eq; auto with zarith. rewrite Zabs_eq in H2; auto with zarith. apply Zle_lt_trans with (2:=H2). rewrite <- Zplus_assoc; apply Zplus_le_compat_l; auto with zarith. apply Zle_trans with (0+eps)%Z; auto with zarith; apply Zplus_le_compat_r; auto with zarith. elim Fx; auto with zarith. unfold FtoRradix, FtoR; simpl. rewrite plus_IZR; rewrite plus_IZR. repeat rewrite Zpower_nat_Z_powerRZ; rewrite inj_pred; auto with zarith. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. unfold Zpred, Zminus; repeat rewrite powerRZ_add; auto with real zarith. rewrite powerRZ_Zopp;auto with real zarith. simpl; field; auto with real zarith. split; simpl. 2: elim Fx; auto with zarith. rewrite Zabs_eq; auto with zarith. rewrite pGivesBound; apply Zlt_Rlt. rewrite plus_IZR;rewrite plus_IZR; repeat rewrite Zpower_nat_Z_powerRZ. rewrite inj_pred; auto with zarith. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. apply Rlt_le_trans with (powerRZ radix (Zpred t) + powerRZ radix (t - s - 1) + powerRZ radix s / 2)%R; auto with real. apply Rle_trans with (powerRZ radix (Zpred t)+powerRZ radix (t-2)+powerRZ radix (t-2))%R. apply Rplus_le_compat. apply Rplus_le_compat_l; auto with real zarith. apply Rle_trans with (powerRZ radix s); auto with real zarith. apply Rmult_le_reg_l with (2%R); auto with real. apply Rle_trans with (powerRZ radix s);[right; field; auto with real|auto with real zarith]. apply Rle_powerRZ; auto with zarith real. replace (Zpred t) with (t-1)%Z;[idtac|unfold Zpred; ring]. apply Rle_trans with (powerRZ radix (t-1)+powerRZ radix (t-1))%R. rewrite Rplus_assoc; apply Rplus_le_compat_l. apply Rle_trans with (2*powerRZ radix (t - 2))%R; [right;ring|idtac]. apply Rle_trans with (radix*powerRZ radix (t - 2))%R; [apply Rmult_le_compat_r; auto with real zarith|idtac]. replace 2%R with (IZR 2); auto with real zarith. replace (t-1)%Z with (1+(t-2))%Z;[rewrite powerRZ_add; simpl|idtac]; auto with real zarith. apply Rle_trans with (2*powerRZ radix (t - 1))%R; [right;ring|idtac]. apply Rle_trans with (radix*powerRZ radix (t - 1))%R; [apply Rmult_le_compat_r; auto with real zarith|idtac]. replace 2%R with (IZR 2); auto with real zarith. pattern (Z_of_nat t)%Z at 2 in |-*; replace (Z_of_nat t)%Z with (1+(t-1))%Z; [rewrite powerRZ_add; simpl|idtac]; auto with real zarith. exists (Fnum x- Zpower_nat radix (pred t))%Z; split. unfold Zminus; rewrite plus_IZR; rewrite Ropp_Ropp_IZR; rewrite Zpower_nat_Z_powerRZ. replace (Z_of_nat (pred t)) with (t+-(1))%Z; [idtac|rewrite inj_pred; auto with zarith]. unfold FtoRradix, FtoR; ring. split. apply Zplus_le_reg_l with (Zpower_nat radix (pred t)). ring_simplify. apply Zmult_le_reg_r with radix; auto with zarith. elim Nx; intros. rewrite Zabs_Zmult in H3. rewrite Zabs_eq in H3; auto with zarith. rewrite Zabs_eq in H3; [idtac|apply LeR0Fnum with radix; auto with zarith real]. rewrite Zmult_comm with (Fnum x) radix. apply Zle_trans with (2:=H3); rewrite pGivesBound. pattern t at 2; replace t with (1+(pred t)); auto with zarith. rewrite Zpower_nat_is_exp. replace ( Zpower_nat radix 1) with radix;[idtac|unfold Zpower_nat; simpl]; auto with zarith. unfold Zminus; rewrite plus_IZR; rewrite Ropp_Ropp_IZR; rewrite Zpower_nat_Z_powerRZ. replace (Z_of_nat (pred t)) with (t-1)%Z; [idtac|rewrite inj_pred; auto with zarith]. apply Rplus_lt_reg_r with (powerRZ radix (t - 1)). apply Rle_lt_trans with (2:=W); right;ring. Qed. Lemma Veltkamp_aux: (Rabs (x-hx) <= (powerRZ radix (s+Fexp x)) /2)%R /\ (exists hx':float, (FtoRradix hx'=hx) /\ (Closest b' radix x hx') /\ (s+Fexp x <= Fexp hx')%Z). generalize p'GivesBound;intros J. cut (powerRZ radix (t - 1 + Fexp x) <= x)%R;[intros xGe|idtac]. 2:rewrite powerRZ_add; auto with real zarith; unfold FtoRradix, FtoR. 2:apply Rmult_le_compat_r; auto with real zarith. 2:apply Rmult_le_reg_l with radix; auto with real zarith. 2:apply Rle_trans with (powerRZ radix t). 2:unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl; right; field; auto with real. 2:ring_simplify (radix*1)%R; auto with real zarith. 2:rewrite <- Zpower_nat_Z_powerRZ; rewrite <- pGivesBound; rewrite <- mult_IZR; elim Nx; intros. 2:rewrite Zabs_Zmult in H0; rewrite Zabs_eq in H0; auto with zarith. 2:rewrite Zabs_eq in H0; auto with zarith real. 2:apply LeR0Fnum with radix; auto with real. cut (Rabs (x - hx) <= (powerRZ radix (s + Fexp x))/2)%R;[intros|idtac]. 2:case eqEqual; intros L. 2:fold FtoRradix; rewrite hxExact. 2:replace (x-(p+q))%R with ((x-p)-q)%R;[apply Rmult_le_reg_l with (INR 2); auto with real zarith|ring]. 2:apply Rle_trans with (powerRZ radix (Fexp q)). 2:unfold FtoRradix; apply ClosestExp with b t; auto with zarith. 2:rewrite L; simpl; right; field; auto with real. 2:elim L; auto. cut (exists v:float, (FtoRradix v=hx)/\(Fcanonic radix b' v)). intros T; elim T; intros v T'; elim T'; intros; clear T T'. split; auto. exists v; split; auto. cut (Fbounded b' v);[intros Fv|apply FcanonicBound with radix; auto]. cut (Rabs (x - FtoR radix v) <= (powerRZ radix (s + Fexp x))/2)%R;[intros|idtac]. 2: fold FtoRradix; rewrite H0; auto with real. split. apply ImplyClosest with (minus t s) (s+Fexp x)%Z; auto with zarith real. replace (s + Fexp x + (t - s)%nat - 1)%Z with ((t-1)+(Fexp x))%Z;[auto with real|rewrite inj_minus1; auto with zarith]. 2:elim Fx; unfold b'; simpl; auto with zarith. replace (s + Fexp x + (t - s)%nat - 1)%Z with ((t-1)+(Fexp x))%Z;[idtac|rewrite inj_minus1; auto with zarith]. fold FtoRradix; apply Veltkamp_aux_aux; auto. assert (s+Fexp x-1 < Fexp v)%Z; auto with zarith. assert (t-1+Fexp x < t-s+Fexp v)%Z; auto with zarith. apply Zlt_powerRZ with radix; auto with real zarith. apply Rle_lt_trans with (FtoRradix v). apply Veltkamp_aux_aux; auto. apply Rle_lt_trans with (1:=RRle_abs v). 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 Fv; intros. apply Rlt_le_trans with (IZR (Zpos (vNum b'))); auto with real zarith. rewrite J; rewrite Zpower_nat_Z_powerRZ; auto with real zarith. rewrite inj_minus1; auto with real zarith. cut (exists c:float, (FtoRradix c=hx) /\ (Fbounded b' c)). intros T; elim T; intros c H'; elim H'; intros. exists (Fnormalize radix b' (t-s) c); split. unfold FtoRradix; rewrite FnormalizeCorrect; auto with real zarith. apply FnormalizeCanonic; auto with zarith. case eqEqual; intros L. generalize FboundedMbound; intros P. elim P with radix b' (t-s) (s+Fexp x)%Z (Fnum (Fplus radix p q)); auto with zarith; clear P. intros v H'; elim H'; intros ; clear H'. exists v; split; auto. rewrite hxExact; unfold FtoRradix; rewrite <- Fplus_correct; auto. rewrite H1; unfold FtoR; replace (s+ Fexp x)%Z with (Fexp (Fplus radix p q)); auto with real. unfold Fplus; simpl. rewrite Zmin_le2;[auto|apply eqLeep]. 2: elim Fx; unfold b'; simpl; auto with zarith. cut ( (Zabs (Fnum (Fplus radix p q)) < ((Zpower_nat radix (t - s))+1)))%Z; auto with zarith. apply Zlt_Rlt. apply Rmult_lt_reg_l with (powerRZ radix (Fexp (Fplus radix p q))); auto with real zarith. apply Rle_lt_trans with (Rabs (Fplus radix p q)). unfold FtoRradix; rewrite <- Fabs_correct; auto. unfold Fabs, FtoR; simpl; auto with real. unfold FtoRradix; rewrite Fplus_correct; auto. fold FtoRradix; rewrite <- hxExact. replace (FtoRradix hx) with (-(x-hx)+x)%R;[idtac|ring]. apply Rle_lt_trans with (Rabs (-(x-hx))+ Rabs(x))%R;[apply Rabs_triang|idtac]. rewrite Rabs_Ropp. apply Rle_lt_trans with ((powerRZ radix (s + Fexp x))/2 + Rabs x)%R; auto with real. apply Rlt_le_trans with ((powerRZ radix (s + Fexp x))/2 + (powerRZ radix (t+Fexp x)))%R. apply Rplus_lt_compat_l. unfold FtoRradix; rewrite <- Fabs_correct; auto; unfold FtoR; simpl. rewrite powerRZ_add; auto with real zarith; apply Rmult_lt_compat_r; auto with real zarith. elim Fx; intros; rewrite <- Zpower_nat_Z_powerRZ; rewrite <- pGivesBound; auto with real zarith. replace (Fexp (Fplus radix p q)) with (s+ Fexp x)%Z. 2:unfold Fplus; simpl. 2:rewrite Zmin_le2;[auto|apply eqLeep]. rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ; simpl. rewrite Rmult_plus_distr_l; rewrite <- powerRZ_add; auto with real zarith. rewrite Rplus_comm; apply Rplus_le_compat. rewrite inj_minus1; auto with real zarith. ring_simplify ((s + Fexp x + (t - s)))%Z; auto with real zarith. rewrite Zplus_comm; auto with real. unfold Rdiv; apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (/1)%R; auto with real. elim L; clear L; intros L1 L2. cut (Fexp q=s+1+Fexp x)%Z;[intros L3|idtac]. 2:cut (q=Float (-(nNormMin radix t)) (s+1+Fexp x));[intros I; rewrite I; simpl; auto|idtac]. 2:apply FnormalUnique with radix b t; auto with zarith. 2:replace (Float (- nNormMin radix t) (s + 1 + Fexp x)) with (Fopp (Float (nNormMin radix t) (s + 1 + Fexp x))); [idtac|unfold Fopp; auto with zarith]. 2:apply FnormalFop; auto. 2:apply FnormalNnormMin; auto with zarith; elim Fx; auto with zarith. 2:fold FtoRradix; rewrite L1; unfold FtoRradix, FtoR, nNormMin; simpl. 2:rewrite Ropp_Ropp_IZR; rewrite Zpower_nat_Z_powerRZ. 2:apply trans_eq with (-(powerRZ radix (pred t) * powerRZ radix (s + 1 + Fexp x)))%R; auto with real. 2:rewrite <- powerRZ_add; auto with real zarith. 2:replace ((pred t + (s + 1 + Fexp x)))%Z with (t + s + Fexp x)%Z; auto with real. 2:rewrite inj_pred; auto with zarith; unfold Zpred; ring. generalize FboundedMbound; intros P. elim P with radix b' (t-s) (Fexp (Fplus radix p q))%Z (Fnum (Fplus radix p q)); auto with zarith; clear P. intros v H'; elim H'; intros ; clear H'. exists v; split; auto. rewrite hxExact; unfold FtoRradix; rewrite <- Fplus_correct; auto. cut ( (Zabs (Fnum (Fplus radix p q)) < ((Zpower_nat radix (t - s))+1)))%Z; auto with zarith. apply Zlt_Rlt. apply Rmult_lt_reg_l with (powerRZ radix (Fexp (Fplus radix p q))); auto with real zarith. apply Rle_lt_trans with (Rabs (Fplus radix p q)). unfold FtoRradix; rewrite <- Fabs_correct; auto. unfold Fabs, FtoR; simpl; auto with real. unfold FtoRradix; rewrite Fplus_correct; auto. fold FtoRradix; rewrite <- hxExact. replace (FtoRradix hx) with (-(x-hx)+x)%R;[idtac|ring]. apply Rle_lt_trans with (Rabs (-(x-hx))+ Rabs(x))%R;[apply Rabs_triang|idtac]. rewrite Rabs_Ropp. apply Rle_lt_trans with ((powerRZ radix (s + Fexp x))/2 + Rabs x)%R; auto with real. apply Rlt_le_trans with ((powerRZ radix (s + Fexp x))/2 + (powerRZ radix (t+Fexp x)))%R. apply Rplus_lt_compat_l. unfold FtoRradix; rewrite <- Fabs_correct; auto; unfold FtoR; simpl. rewrite powerRZ_add; auto with real zarith; apply Rmult_lt_compat_r; auto with real zarith. elim Fx; intros; rewrite <- Zpower_nat_Z_powerRZ; rewrite <- pGivesBound; auto with real zarith. replace (Fexp (Fplus radix p q)) with (s+ 1+Fexp x)%Z. 2:unfold Fplus; simpl. 2:rewrite Zmin_le2;[auto|apply eqLeep]. rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ; simpl. rewrite Rmult_plus_distr_l; rewrite <- powerRZ_add; auto with real zarith. rewrite Rplus_comm; apply Rplus_le_compat. rewrite inj_minus1; auto with real zarith. ring_simplify ((s + Fexp x + (t - s)))%Z; auto with real. unfold Rdiv; apply Rmult_le_compat; auto with real zarith. apply Rle_trans with (/1)%R; auto with real. unfold b', Fplus; simpl. rewrite Zmin_le2;[elim Nq; intros Fq T; elim Fq; auto|apply eqLeep]. Qed. Hypothesis pDefEven: (EvenClosest b radix t (x*((powerRZ radix s)+1))%R p). Hypothesis qDefEven: (EvenClosest b radix t (x-p)%R q). Hypothesis hxDefEven:(EvenClosest b radix t (q+p)%R hx). Lemma VeltkampEven1: (Even radix) ->(exists hx':float, (FtoRradix hx'=hx) /\ (EvenClosest b' radix (t-s) x hx')). intros I. generalize p'GivesBound; intros J. cut (powerRZ radix (t - 1 + Fexp x) <= x)%R;[intros xGe|idtac]. 2:rewrite powerRZ_add; auto with real zarith; unfold FtoRradix, FtoR. 2:apply Rmult_le_compat_r; auto with real zarith. 2:apply Rmult_le_reg_l with radix; auto with real zarith. 2:apply Rle_trans with (powerRZ radix t). 2:unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl; right; field; auto with real. 2:ring_simplify (radix*1)%R; auto with real zarith. 2:rewrite <- Zpower_nat_Z_powerRZ; rewrite <- pGivesBound; rewrite <- mult_IZR; elim Nx; intros. 2:rewrite Zabs_Zmult in H0; rewrite Zabs_eq in H0; auto with zarith. 2:rewrite Zabs_eq in H0; auto with zarith real. 2:apply LeR0Fnum with radix; auto with real. cut (Rabs (x - hx) <= (powerRZ radix (s + Fexp x))/2)%R;[intros|idtac]. 2:case eqEqual; intros L. 2:fold FtoRradix; rewrite hxExact. 2:replace (x-(p+q))%R with ((x-p)-q)%R;[apply Rmult_le_reg_l with (INR 2); auto with real zarith|ring]. 2:apply Rle_trans with (powerRZ radix (Fexp q)). 2:unfold FtoRradix; apply ClosestExp with b t; auto with zarith. 2:rewrite L; simpl; right; field; auto with real. 2:elim L; auto. cut (exists v:float, (FtoRradix v=hx)/\(Fcanonic radix b' v) /\ ((FNeven b' radix (t-s) v) \/ (Fexp v <= s+Fexp x)%Z)). intros T;elim T; intros v T'; elim T'; intros H0 T''; elim T''; intros H1 L; clear T T' T''. exists v; split; auto. cut (Fbounded b' v);[intros Fv|apply FcanonicBound with radix; auto]. cut (Rabs (x - FtoR radix v) <= (powerRZ radix (s + Fexp x))/2)%R;[intros|idtac]. 2: fold FtoRradix; rewrite H0; auto with real. case H2; intros; clear H2. unfold EvenClosest. cut (Closest b' radix x v /\ (forall g : float, Closest b' radix x g -> FtoR radix v = FtoR radix g)). intros T; elim T; split; auto. right; intros; apply sym_eq; auto. apply ImplyClosestStrict2 with (minus t s) (s+Fexp x)%Z; auto with zarith real. replace (s + Fexp x + (t - s)%nat - 1)%Z with ((t-1)+(Fexp x))%Z;[auto with real|rewrite inj_minus1; auto with zarith]. 2:elim Fx; unfold b'; simpl; auto with zarith. replace (s + Fexp x + (t - s)%nat - 1)%Z with ((t-1)+(Fexp x))%Z;[idtac|rewrite inj_minus1; auto with zarith]. fold FtoRradix; apply Veltkamp_aux_aux; auto with real. cut (Closest b' radix x v);[intros|idtac]. 2: apply ImplyClosest with (minus t s) (s+Fexp x)%Z; auto with zarith real. 2: rewrite inj_minus1; auto with zarith real. 2: replace (s + Fexp x + (t - s) - 1)%Z with (t - 1 + Fexp x)%Z; [auto with real|ring]. 2: rewrite inj_minus1; auto with zarith real. 2: replace (s + Fexp x + (t - s) - 1)%Z with (t - 1 + Fexp x)%Z; [auto with real|ring]. 2: fold FtoRradix; apply Veltkamp_aux_aux; auto with real. 2: elim Fx; unfold b'; simpl; auto with zarith. split; auto. left. case L; clear L; intros L; auto. unfold FNeven; rewrite FcanonicFnormalizeEq; auto with zarith. case (Zle_lt_or_eq _ _ L); intros H4; clear L;unfold Feven. cut (exists m:Z, (Fnum v=radix*m)%Z);[intros T; elim T; intros m H5|idtac]. rewrite H5; apply EvenMult1; auto. exists (Fnum p*Zpower_nat radix ((Zabs_nat (Fexp p-Fexp v-1)))+ Fnum q*Zpower_nat radix ((Zabs_nat (Fexp q-Fexp v-1))))%Z. apply eq_IZR. rewrite mult_IZR; rewrite plus_IZR; repeat rewrite mult_IZR. repeat rewrite Zpower_nat_Z_powerRZ. generalize eqGe; generalize eqLeep; intros. repeat rewrite <- Zabs_absolu. repeat rewrite Zabs_eq; auto with zarith. unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith. repeat rewrite powerRZ_Zopp; auto with real zarith;rewrite powerRZ_1. apply Rmult_eq_reg_l with (powerRZ radix (Fexp v)); auto with real zarith. apply trans_eq with (FtoRradix v);[unfold FtoRradix, FtoR; ring|idtac]. rewrite H0; rewrite hxExact; unfold FtoRradix, FtoR; field. auto with real zarith. replace (Fnum v) with (Fnum p*Zpower_nat radix ((Zabs_nat (Fexp p-Fexp v)))+ Fnum q*Zpower_nat radix ((Zabs_nat (Fexp q-Fexp v))))%Z. 2:apply eq_IZR. 2:rewrite plus_IZR; repeat rewrite mult_IZR. 2:repeat rewrite Zpower_nat_Z_powerRZ. 2: generalize eqGe; generalize eqLeep; intros. 2:repeat rewrite <- Zabs_absolu. 2:repeat rewrite Zabs_eq; auto with zarith. 2:unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith. 2:repeat rewrite powerRZ_Zopp; auto with real zarith. 2:apply Rmult_eq_reg_l with (powerRZ radix (Fexp v)); auto with real zarith. 2:apply trans_eq with (FtoRradix v);[idtac|unfold FtoRradix, FtoR; ring]. 2:rewrite H0; rewrite hxExact; unfold FtoRradix, FtoR; field. 2:auto with real zarith. cut (exists eps:R, ((eps=1)%R \/ (eps=-1)%R) /\ (FtoRradix x=v+ eps*(powerRZ radix (s + Fexp x))/2)%R). intros T; elim T; intros eps T'; elim T'; intros Heps1 Heps2; clear T T'. apply EvenPlus1. rewrite H4. cut ((Fexp p=1+s+Fexp x)%Z \/ (Fexp p=s+Fexp x)%Z);[intros T; case T; clear T; intros|idtac]. rewrite H5; ring_simplify (1 + s + Fexp x - (s + Fexp x))%Z. replace (Zpower_nat radix (Zabs_nat 1))%Z with radix%Z. apply EvenMult2; auto. unfold Zpower_nat; simpl; auto with zarith. rewrite H5;ring_simplify ( (s + Fexp x - (s + Fexp x)))%Z. unfold Zpower_nat; simpl;ring_simplify (Fnum p * 1)%Z. cut (FNeven b radix t p). unfold FNeven;rewrite FcanonicFnormalizeEq; auto with zarith. left; auto. apply ClosestImplyEven_int with (x * (powerRZ radix s + 1))%R ((Fnum v)*(powerRZ radix s)+(Fnum v)+eps*(powerRZ radix s)/2+(eps-1)/2)%R; auto with zarith. left; auto. apply pPos. rewrite Heps2; unfold FtoRradix, FtoR; rewrite H4; rewrite H5. unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith; simpl. field; auto with real. elim I; intros rradix I'. cut ((powerRZ radix s)/2=(rradix*Zpower_nat radix (pred s))%Z)%R;[intros K|idtac]. case Heps1; intros T; rewrite T. exists (Fnum v*(Zpower_nat radix s)+Fnum v+rradix*Zpower_nat radix (pred s))%Z. repeat rewrite plus_IZR; rewrite mult_IZR. rewrite <- K. rewrite Zpower_nat_Z_powerRZ; unfold Rdiv; ring. exists (Fnum v*(Zpower_nat radix s)+Fnum v+-(rradix*Zpower_nat radix (pred s))-1)%Z. unfold Zminus; repeat rewrite plus_IZR; rewrite mult_IZR; rewrite Ropp_Ropp_IZR. rewrite <- K. simpl; rewrite Zpower_nat_Z_powerRZ; unfold Rdiv; field; auto with real. rewrite mult_IZR; rewrite Zpower_nat_Z_powerRZ; rewrite inj_pred; auto with zarith. unfold Zpred, Zminus; rewrite powerRZ_add; auto with real zarith; simpl. rewrite I'; rewrite mult_IZR; simpl; field. auto with real zarith. generalize eqLeep; generalize epLe; generalize eqLe; generalize eqGe; intros. cut (s+Fexp x <= Fexp p)%Z; auto with zarith. intros T; case (Zle_lt_or_eq _ _ T); auto with zarith. cut ((Fexp q=1+s+Fexp x)%Z \/ (Fexp q=s+Fexp x)%Z);[intros T; case T; clear T; intros|idtac]. rewrite H4; rewrite H5; ring_simplify (1 + s + Fexp x - (s + Fexp x))%Z. replace (Zpower_nat radix (Zabs_nat 1))%Z with radix%Z. apply EvenMult2; auto. unfold Zpower_nat; simpl; auto with zarith. rewrite H4; rewrite H5;ring_simplify ( (s + Fexp x - (s + Fexp x)))%Z. unfold Zpower_nat; simpl;ring_simplify (Fnum q * 1)%Z. 2: generalize eqLeep; generalize epLe; generalize eqLe; generalize eqGe; intros. 2: case (Zle_lt_or_eq _ _ H5); auto with zarith. cut (FNeven b radix t q). unfold FNeven;rewrite FcanonicFnormalizeEq; auto with zarith. left; auto. replace q with (Fopp (Fopp q)). apply FNevenFop; auto with zarith. apply ClosestImplyEven_int with (-(x-p))%R ((Fnum p)*(powerRZ radix ((Fexp p)-s-(Fexp x)))-(Fnum v)-(eps+1)/2)%R; auto with zarith. generalize EvenClosestSymmetric; unfold SymmetricP; intros; auto with zarith. left; apply FnormalFop; auto. rewrite Fopp_correct; auto; generalize qNeg; auto with real. simpl; rewrite H5. apply trans_eq with ((powerRZ radix (s + Fexp x) * powerRZ radix (Fexp p - s - Fexp x))*Fnum p+ (powerRZ radix (s + Fexp x) * ( - Fnum v - (eps + 1) / 2 + 1 / 2)))%R;[idtac|ring]. rewrite <- powerRZ_add; auto with real zarith; ring_simplify (s + Fexp x + (Fexp p - s - Fexp x))%Z. rewrite Heps2; unfold FtoRradix, FtoR; rewrite H4. unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith; simpl. field; auto with real. case Heps1; intros T; rewrite T. exists (Fnum p*(Zpower_nat radix (Zabs_nat (Fexp p-(s+Fexp x))))-Fnum v-1)%Z. unfold Zminus; repeat rewrite plus_IZR; rewrite mult_IZR; repeat rewrite Ropp_Ropp_IZR; simpl. repeat rewrite Zpower_nat_Z_powerRZ; replace (Z_of_nat (Zabs_nat (Fexp p + - (s + Fexp x)))) with (Fexp p + - s + - Fexp x)%Z;[unfold Rdiv; field; auto with real|idtac]. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. generalize eqLeep; generalize epLe; generalize eqLe; generalize eqGe; intros; auto with zarith. exists (Fnum p*(Zpower_nat radix (Zabs_nat (Fexp p-(s+Fexp x))))-Fnum v)%Z. unfold Zminus; repeat rewrite plus_IZR; rewrite mult_IZR; repeat rewrite Ropp_Ropp_IZR; simpl. repeat rewrite Zpower_nat_Z_powerRZ; replace (Z_of_nat (Zabs_nat (Fexp p + - (s + Fexp x)))) with (Fexp p + - s + - Fexp x)%Z;[unfold Rdiv; field; auto with real|idtac]. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. generalize eqLeep; generalize epLe; generalize eqLe; generalize eqGe; intros; auto with zarith. unfold Fopp; destruct q; simpl; auto with zarith. ring_simplify (-(-Fnum))%Z; auto. fold FtoRradix in H3; case (Rcase_abs (x-v)%R); intros. rewrite Rabs_left in H3; auto. exists (-1)%R; split; auto with real. apply trans_eq with (v + -1 * (powerRZ radix (s + Fexp x) / 2))%R. rewrite <- H3; ring. unfold Rdiv; ring. rewrite Rabs_right in H3; auto. exists (1)%R; split; auto with real. apply trans_eq with (v + 1 * (powerRZ radix (s + Fexp x) / 2))%R. rewrite <- H3; ring. unfold Rdiv; ring. cut (exists v : float, FtoRradix v = hx /\ Fbounded b' v /\ (FNeven b' radix (t - s) v \/ (Fexp v <= s + Fexp x)%Z)). intros T; elim T; intros v T1; elim T1; intros H1 T2; elim T2; intros H2 H3; clear T T1 T2. exists (Fnormalize radix b' (t-s) v). split. rewrite <- H1; unfold FtoRradix; rewrite FnormalizeCorrect; auto with real zarith. split. apply FnormalizeCanonic; auto with zarith. case H3; intros. left; unfold FNeven; unfold FNeven in H0. rewrite FcanonicFnormalizeEq; auto with zarith. apply FnormalizeCanonic; auto with zarith. right; apply Zle_trans with (2:=H0). apply FcanonicLeastExp with radix b' (t-s); auto with zarith. rewrite FnormalizeCorrect; auto with real zarith. apply FnormalizeCanonic; auto with zarith. cut (exists m:Z, (FtoRradix hx=m*powerRZ radix (s+Fexp x))%R /\ ((Zabs m) <= Zpos (vNum b'))%Z ). intros T; elim T; intros m T'; elim T'; intros; clear T T'. case (Zle_lt_or_eq _ _ H1); intros H2. exists (Float m (s+Fexp x)). split;[rewrite H0; unfold FtoRradix, FtoR; simpl; ring|split]. split; simpl; elim Fx; auto with zarith. right; simpl; auto with zarith. exists (Float (nNormMin radix (t-s)) (s+1+Fexp x)). cut (Fcanonic radix b' (Float (nNormMin radix (t-s)) (s+1+Fexp x))). 2: apply FcanonicNnormMin; elim Fx; unfold b'; simpl; auto with zarith. intros H3; split. rewrite H0; unfold FtoRradix, FtoR, nNormMin; simpl. rewrite Zpower_nat_Z_powerRZ; rewrite inj_pred; auto with zarith. rewrite Zabs_eq in H2. rewrite H2; rewrite J;rewrite Zpower_nat_Z_powerRZ. repeat rewrite <- powerRZ_add; auto with real zarith. replace (Zpred (t - s)%nat + (s + 1 + Fexp x))%Z with ((t - s)%nat + (s + Fexp x))%Z; auto with real zarith; unfold Zpred; ring. apply Zle_Rle. apply Rmult_le_reg_l with (powerRZ radix (s + Fexp x)); auto with real zarith. apply Rle_trans with 0%R;[simpl; right; ring|rewrite Rmult_comm]. rewrite <- H0; rewrite hxExact. apply Rplus_le_reg_l with (-q)%R. ring_simplify; unfold FtoRradix; rewrite <- Fopp_correct. generalize ClosestMonotone; unfold MonotoneP; intros. apply H4 with b (-(x-p))%R p; auto with zarith real. apply Rplus_lt_reg_r with (x-p)%R. ring_simplify; auto with real. apply ClosestOpp; auto. unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(Closest b radix)) (b:=b). apply ClosestRoundedModeP with t; auto with zarith. elim pDef; auto. split;[apply FcanonicBound with radix; auto|idtac]. left; unfold FNeven; rewrite FcanonicFnormalizeEq; auto with zarith. unfold Feven, nNormMin; simpl. replace (pred (t-s)) with (S (pred (pred (t-s)))); auto with zarith. apply EvenExp; auto with zarith. exists (Fnum p*Zpower_nat radix ((Zabs_nat (Fexp p-s-Fexp x)))+ Fnum q*Zpower_nat radix ((Zabs_nat (Fexp q-s-Fexp x))))%Z. cut (FtoRradix hx = ((Fnum p * Zpower_nat radix (Zabs_nat (Fexp p - s - Fexp x)) + Fnum q * Zpower_nat radix (Zabs_nat (Fexp q - s - Fexp x)))%Z * powerRZ radix (s + Fexp x)))%R;[intros H'; split; auto|idtac]. cut (Zabs (Fnum p * Zpower_nat radix (Zabs_nat (Fexp p - s - Fexp x)) + Fnum q * Zpower_nat radix (Zabs_nat (Fexp q - s - Fexp x))) < Zpos (vNum b')+1)%Z; auto with zarith. apply Zlt_Rlt. rewrite plus_IZR; simpl (IZR 1). rewrite <- Rabs_Zabs. apply Rmult_lt_reg_l with (powerRZ radix (s + Fexp x)); auto with real zarith. apply Rle_lt_trans with (Rabs ((powerRZ radix (s + Fexp x))*((Fnum p * Zpower_nat radix (Zabs_nat (Fexp p - s - Fexp x)) + Fnum q * Zpower_nat radix (Zabs_nat (Fexp q - s - Fexp x)))%Z)))%R. rewrite Rabs_mult; rewrite (Rabs_right (powerRZ radix (s + Fexp x))); auto with real. apply Rle_ge; auto with real zarith. rewrite Rmult_comm; rewrite <- H'. replace (FtoRradix hx) with (x+(-(x-hx)))%R;[idtac|ring]. apply Rle_lt_trans with (Rabs x+Rabs (-(x-hx)))%R;[apply Rabs_triang|idtac]. rewrite Rabs_Ropp; apply Rlt_le_trans with (powerRZ radix (t+Fexp x)+Rabs (x-hx))%R. apply Rplus_lt_compat_r; unfold FtoRradix; rewrite <- Fabs_correct; auto. unfold FtoR, Fabs; simpl; rewrite powerRZ_add; auto with real zarith. apply Rmult_lt_compat_r; auto with real zarith. elim Fx; intros; rewrite <- Zpower_nat_Z_powerRZ; rewrite <- pGivesBound; auto with real zarith. apply Rle_trans with (powerRZ radix (t + Fexp x)+ powerRZ radix (s + Fexp x) / 2)%R; auto with real. rewrite J; rewrite Zpower_nat_Z_powerRZ; rewrite inj_minus1; auto with zarith. rewrite Rmult_plus_distr_l. apply Rplus_le_compat. rewrite <- powerRZ_add; auto with real zarith. replace (s + Fexp x + (t - s))%Z with (t + Fexp x)%Z by ring; auto with real. unfold Rdiv; apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (/1)%R; auto with real. rewrite plus_IZR; repeat rewrite mult_IZR. repeat rewrite Zpower_nat_Z_powerRZ. generalize eqGe; generalize eqLeep; intros. repeat rewrite <- Zabs_absolu. repeat rewrite Zabs_eq; auto with zarith. rewrite Rmult_plus_distr_r. repeat rewrite Rmult_assoc. repeat rewrite <- powerRZ_add; auto with real zarith. ring_simplify (Fexp p - s - Fexp x + (s + Fexp x))%Z. ring_simplify (Fexp q - s - Fexp x + (s + Fexp x))%Z. rewrite hxExact; unfold FtoRradix, FtoR; ring. Qed. Lemma VeltkampEven2: (Odd radix) -> (exists hx':float, (FtoRradix hx'=hx) /\ (EvenClosest b' radix (t-s) x hx')). intros I. generalize p'GivesBound;intros J. cut (powerRZ radix (t - 1 + Fexp x) <= x)%R;[intros xGe|idtac]. 2:rewrite powerRZ_add; auto with real zarith; unfold FtoRradix, FtoR. 2:apply Rmult_le_compat_r; auto with real zarith. 2:apply Rmult_le_reg_l with radix; auto with real zarith. 2:apply Rle_trans with (powerRZ radix t). 2:unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl; right; field; auto with real. 2:ring_simplify (radix*1)%R; auto with real zarith. 2:rewrite <- Zpower_nat_Z_powerRZ; rewrite <- pGivesBound; rewrite <- mult_IZR; elim Nx; intros. 2:rewrite Zabs_Zmult in H0; rewrite Zabs_eq in H0; auto with zarith. 2:rewrite Zabs_eq in H0; auto with zarith real. 2:apply LeR0Fnum with radix; auto with real. cut (Rabs (x - hx) <= (powerRZ radix (s + Fexp x))/2)%R;[intros|idtac]. 2:case eqEqual; intros L. 2:fold FtoRradix; rewrite hxExact. 2:replace (x-(p+q))%R with ((x-p)-q)%R;[apply Rmult_le_reg_l with (INR 2); auto with real zarith|ring]. 2:apply Rle_trans with (powerRZ radix (Fexp q)). 2:unfold FtoRradix; apply ClosestExp with b t; auto with zarith. 2:rewrite L; simpl; right; field; auto with real. 2:elim L; auto. cut (exists v:float, (FtoRradix v=hx)/\(Fcanonic radix b' v)). intros T; elim T; intros v T'; elim T'; intros; clear T T'. exists v; split; auto. cut (Fbounded b' v);[intros Fv|apply FcanonicBound with radix; auto]. cut (Rabs (x - FtoR radix v) <= (powerRZ radix (s + Fexp x))/2)%R;[intros|idtac]. 2: fold FtoRradix; rewrite H0; auto with real. case H2; intros L. unfold EvenClosest. cut (Closest b' radix x v /\ (forall g : float, Closest b' radix x g -> FtoR radix v = FtoR radix g)). intros T; elim T; split; auto. right; intros; apply sym_eq; auto. apply ImplyClosestStrict2 with (minus t s) (s+Fexp x)%Z; auto with zarith real. replace (s + Fexp x + (t - s)%nat - 1)%Z with ((t-1)+(Fexp x))%Z;[auto with real|rewrite inj_minus1; auto with zarith]. 2:elim Fx; unfold b'; simpl; auto with zarith. replace (s + Fexp x + (t - s)%nat - 1)%Z with ((t-1)+(Fexp x))%Z;[idtac|rewrite inj_minus1; auto with zarith]. fold FtoRradix; apply Veltkamp_aux_aux; auto. absurd (Even (Zpower_nat radix s)). apply OddNEven. elim s. unfold Zpower_nat; simpl; unfold Odd. exists 0%Z; ring. intros n Hrecn. replace (S n)with (1+n); auto with zarith. rewrite Zpower_nat_is_exp. apply OddMult; auto. unfold Zpower_nat; simpl; ring_simplify (radix*1)%Z; auto. replace (Zpower_nat radix s) with (2*(Zabs (Fnum x- Fnum v*Zpower_nat radix (Zabs_nat (Fexp v-Fexp x)))))%Z. apply EvenMult1; unfold Even; exists 1%Z; auto with zarith. apply eq_IZR. rewrite mult_IZR; rewrite <- Rabs_Zabs. unfold Zminus; rewrite plus_IZR; rewrite Ropp_Ropp_IZR. rewrite mult_IZR; repeat rewrite Zpower_nat_Z_powerRZ; simpl. apply Rmult_eq_reg_l with (powerRZ radix (Fexp x)); auto with zarith real. rewrite <- powerRZ_add; auto with real zarith. apply Rmult_eq_reg_l with (/2)%R; auto with real. apply trans_eq with (powerRZ radix (s + Fexp x) / 2)%R. 2: unfold Rdiv; rewrite Zplus_comm; ring. rewrite <- L. apply trans_eq with ((powerRZ radix (Fexp x) * (Rabs (Fnum x +- (Fnum v * powerRZ radix (Zabs_nat (Fexp v +- Fexp x)))))))%R. field; auto with real. rewrite <- (Rabs_right (powerRZ radix (Fexp x)));[idtac|apply Rle_ge; auto with real zarith]. rewrite <- Rabs_mult. replace (x - FtoR radix v)%R with (powerRZ radix (Fexp x) * (Fnum x + -(Fnum v * powerRZ radix (Zabs_nat (Fexp v +- Fexp x)))))%R; auto with real. unfold FtoRradix, FtoR; rewrite Rmult_plus_distr_l. rewrite <- Zabs_absolu; rewrite Zabs_eq. rewrite powerRZ_add; auto with real zarith. rewrite powerRZ_Zopp; auto with real zarith. field; auto with real zarith. apply Zplus_le_reg_l with (Fexp x). ring_simplify. apply Zle_trans with (Fexp (Float (nNormMin radix (t-s)) (Fexp x))); [simpl; auto with zarith|idtac]. apply Fcanonic_Rle_Zle with radix b' (t-s); auto with zarith. apply FcanonicNnormMin; auto with zarith. unfold b'; simpl; elim Fx; auto. cut (powerRZ radix (t - 1 + Fexp x) <= v)%R;[intros H3|idtac]. 2: apply Veltkamp_aux_aux; auto. fold (FtoRradix v);unfold FtoR, nNormMin; simpl. rewrite Zpower_nat_Z_powerRZ; rewrite <- powerRZ_add; auto with real zarith. rewrite Rabs_right;[idtac|apply Rle_ge; auto with real zarith]. rewrite Rabs_right;[idtac|apply Rle_ge; apply Rle_trans with (2:=H3); auto with real zarith]. apply Rle_trans with (2:=H3); apply Rle_powerRZ; auto with real zarith. rewrite inj_pred; unfold Zpred; auto with zarith. rewrite inj_minus1; auto with zarith. cut (exists c:float, (FtoRradix c=hx) /\ (Fbounded b' c)). intros T; elim T; intros c H'; elim H'; intros. exists (Fnormalize radix b' (t-s) c); split. unfold FtoRradix; rewrite FnormalizeCorrect; auto with real zarith. apply FnormalizeCanonic; auto with zarith. case eqEqual; intros L. generalize FboundedMbound; intros P. elim P with radix b' (t-s) (s+Fexp x)%Z (Fnum (Fplus radix p q)); auto with zarith; clear P. intros v H'; elim H'; intros ; clear H'. exists v; split; auto. rewrite hxExact; unfold FtoRradix; rewrite <- Fplus_correct; auto. rewrite H1; unfold FtoR; replace (s+ Fexp x)%Z with (Fexp (Fplus radix p q)); auto with real. unfold Fplus; simpl. rewrite Zmin_le2;[auto|apply eqLeep]. 2: elim Fx; unfold b'; simpl; auto with zarith. cut ( (Zabs (Fnum (Fplus radix p q)) < ((Zpower_nat radix (t - s))+1)))%Z; auto with zarith. apply Zlt_Rlt. apply Rmult_lt_reg_l with (powerRZ radix (Fexp (Fplus radix p q))); auto with real zarith. apply Rle_lt_trans with (Rabs (Fplus radix p q)). unfold FtoRradix; rewrite <- Fabs_correct; auto. unfold Fabs, FtoR; simpl; auto with real. unfold FtoRradix; rewrite Fplus_correct; auto. fold FtoRradix; rewrite <- hxExact. replace (FtoRradix hx) with (-(x-hx)+x)%R;[idtac|ring]. apply Rle_lt_trans with (Rabs (-(x-hx))+ Rabs(x))%R;[apply Rabs_triang|idtac]. rewrite Rabs_Ropp. apply Rle_lt_trans with ((powerRZ radix (s + Fexp x))/2 + Rabs x)%R; auto with real. apply Rlt_le_trans with ((powerRZ radix (s + Fexp x))/2 + (powerRZ radix (t+Fexp x)))%R. apply Rplus_lt_compat_l. unfold FtoRradix; rewrite <- Fabs_correct; auto; unfold FtoR; simpl. rewrite powerRZ_add; auto with real zarith; apply Rmult_lt_compat_r; auto with real zarith. elim Fx; intros; rewrite <- Zpower_nat_Z_powerRZ; rewrite <- pGivesBound; auto with real zarith. replace (Fexp (Fplus radix p q)) with (s+ Fexp x)%Z. 2:unfold Fplus; simpl. 2:rewrite Zmin_le2;[auto|apply eqLeep]. rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ; simpl. rewrite Rmult_plus_distr_l; rewrite <- powerRZ_add; auto with real zarith. rewrite Rplus_comm; apply Rplus_le_compat. rewrite inj_minus1; auto with real zarith. replace ((s + Fexp x + (t - s)))%Z with (t+Fexp x)%Z; auto with real; ring. unfold Rdiv; apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (/1)%R; auto with real. elim L; clear L; intros L1 L2. cut (Fexp q=s+1+Fexp x)%Z;[intros L3|idtac]. 2:cut (q=Float (-(nNormMin radix t)) (s+1+Fexp x));[intros I'; rewrite I'; simpl; auto|idtac]. 2:apply FnormalUnique with radix b t; auto with zarith. 2:replace (Float (- nNormMin radix t) (s + 1 + Fexp x)) with (Fopp (Float (nNormMin radix t) (s + 1 + Fexp x))); [idtac|unfold Fopp; auto with zarith]. 2:apply FnormalFop; auto. 2:apply FnormalNnormMin; auto with zarith; elim Fx; auto with zarith. 2:fold FtoRradix; rewrite L1; unfold FtoRradix, FtoR, nNormMin; simpl. 2:rewrite Ropp_Ropp_IZR; rewrite Zpower_nat_Z_powerRZ. 2:apply trans_eq with (-(powerRZ radix (pred t) * powerRZ radix (s + 1 + Fexp x)))%R; auto with real. 2:rewrite <- powerRZ_add; auto with real zarith. 2:replace ((pred t + (s + 1 + Fexp x)))%Z with (t + s + Fexp x)%Z; auto with real. 2:rewrite inj_pred; auto with zarith; unfold Zpred; ring. generalize FboundedMbound; intros P. elim P with radix b' (t-s) (Fexp (Fplus radix p q))%Z (Fnum (Fplus radix p q)); auto with zarith; clear P. intros v H'; elim H'; intros ; clear H'. exists v; split; auto. rewrite hxExact; unfold FtoRradix; rewrite <- Fplus_correct; auto. cut ( (Zabs (Fnum (Fplus radix p q)) < ((Zpower_nat radix (t - s))+1)))%Z; auto with zarith. apply Zlt_Rlt. apply Rmult_lt_reg_l with (powerRZ radix (Fexp (Fplus radix p q))); auto with real zarith. apply Rle_lt_trans with (Rabs (Fplus radix p q)). unfold FtoRradix; rewrite <- Fabs_correct; auto. unfold Fabs, FtoR; simpl; auto with real. unfold FtoRradix; rewrite Fplus_correct; auto. fold FtoRradix; rewrite <- hxExact. replace (FtoRradix hx) with (-(x-hx)+x)%R;[idtac|ring]. apply Rle_lt_trans with (Rabs (-(x-hx))+ Rabs(x))%R;[apply Rabs_triang|idtac]. rewrite Rabs_Ropp. apply Rle_lt_trans with ((powerRZ radix (s + Fexp x))/2 + Rabs x)%R; auto with real. apply Rlt_le_trans with ((powerRZ radix (s + Fexp x))/2 + (powerRZ radix (t+Fexp x)))%R. apply Rplus_lt_compat_l. unfold FtoRradix; rewrite <- Fabs_correct; auto; unfold FtoR; simpl. rewrite powerRZ_add; auto with real zarith; apply Rmult_lt_compat_r; auto with real zarith. elim Fx; intros; rewrite <- Zpower_nat_Z_powerRZ; rewrite <- pGivesBound; auto with real zarith. replace (Fexp (Fplus radix p q)) with (s+ 1+Fexp x)%Z. 2:unfold Fplus; simpl. 2:rewrite Zmin_le2;[auto|apply eqLeep]. rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ; simpl. rewrite Rmult_plus_distr_l; rewrite <- powerRZ_add; auto with real zarith. rewrite Rplus_comm; apply Rplus_le_compat. rewrite inj_minus1; auto with real zarith. unfold Rdiv; apply Rmult_le_compat; auto with real zarith. apply Rle_trans with (/1)%R; auto with real. unfold b', Fplus; simpl. rewrite Zmin_le2;[elim Nq; intros Fq T; elim Fq; auto|apply eqLeep]. Qed. End Velt. Section VeltN. 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 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. Lemma Veltkamp_pos: forall x p q hx:float, Fnormal radix b x -> Fcanonic radix b p -> Fcanonic radix b q -> (0 < x)%R -> (Closest b radix (x*((powerRZ radix s)+1))%R p) -> (Closest b radix (x-p)%R q) -> (Closest b radix (q+p)%R hx) -> (Rabs (x-hx) <= (powerRZ radix (s+Fexp x)) /2)%R /\ (exists hx':float, (FtoRradix hx'=hx) /\ (Closest b' radix x hx') /\ (s+Fexp x <= Fexp hx')%Z). intros x p q hx Nx Cp Cq; intros. unfold FtoRradix, b'; apply Veltkamp_aux with p q; auto. elim Nx; auto. case Cp; auto; intros T. absurd (p < (firstNormalPos radix b t))%R. apply Rle_not_lt; generalize ClosestMonotone; unfold MonotoneP; intros H3. unfold FtoRradix; apply H3 with b (firstNormalPos radix b t) (x * (powerRZ radix s + 1))%R; auto. apply Rle_lt_trans with x. unfold FtoRradix; apply FnormalLtFirstNormalPos; auto with zarith real. apply Rle_lt_trans with (x*1)%R; auto with real. apply Rmult_lt_compat_l; auto with real zarith. apply Rle_lt_trans with (0+1)%R; auto with real zarith. unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(Closest b radix)) (b:=b). apply ClosestRoundedModeP with t; auto with zarith. generalize firstNormalPosNormal; intros H4. elim H4 with radix b t; auto with zarith. unfold FtoRradix; apply FsubnormalLtFirstNormalPos; auto with zarith. apply pPos with b s t x; auto. rewrite <- Fopp_Fopp; apply FnormalFop. cut (Fcanonic radix b (Fopp q));[intros T'|apply FcanonicFopp; auto]. case T'; auto; intros T. absurd (Fopp q < (firstNormalPos radix b t))%R. apply Rle_not_lt; generalize ClosestMonotone; unfold MonotoneP; intros H3. unfold FtoRradix; apply H3 with b (firstNormalPos radix b t) (-(x-p))%R; auto. apply Rle_lt_trans with x. unfold FtoRradix; apply FnormalLtFirstNormalPos; auto with zarith real. apply Rplus_lt_reg_r with (FtoRradix x). apply Rle_lt_trans with ((IZR 2)*x)%R;[right; simpl; ring| idtac]. apply Rle_lt_trans with (radix*x)%R;auto with real zarith. apply Rlt_le_trans with (radix*(radix*x))%R. apply Rle_lt_trans with (1*(radix*x))%R; auto with real zarith. apply Rmult_lt_compat_r; auto with real zarith. apply Rmult_lt_0_compat; auto with real zarith. apply Rle_trans with (FtoRradix p);[idtac|right; ring]. apply Rle_trans with (FtoRradix (Float (Fnum x) (Fexp x+2))). unfold FtoRradix, FtoR; simpl; rewrite powerRZ_add; simpl; auto with real zarith. right; ring. unfold FtoRradix; apply H3 with b (Float (Fnum x) (Fexp x + 2)) (x * (powerRZ radix s + 1))%R; auto. apply Rle_lt_trans with (x * (powerRZ radix 2))%R. unfold FtoRradix, FtoR; simpl; rewrite powerRZ_add; auto with real zarith. apply Rmult_lt_compat_l; auto with real zarith. apply Rle_lt_trans with (powerRZ radix s+0)%R; auto with real zarith. apply Rle_trans with (powerRZ radix s)%R; auto with real zarith. apply Rle_powerRZ; auto with zarith real. unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(Closest b radix)) (b:=b). apply ClosestRoundedModeP with t; auto with zarith. elim Nx; intros T1 T2; elim T1; intros. split; simpl; auto with zarith. unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(Closest b radix)) (b:=b). apply ClosestRoundedModeP with t; auto with zarith. generalize firstNormalPosNormal; intros H4. elim H4 with radix b t; auto with zarith. apply ClosestOpp; auto. unfold FtoRradix; apply FsubnormalLtFirstNormalPos; auto with zarith. rewrite Fopp_correct; cut (q <= 0)%R; auto with real. unfold FtoRradix; apply qNeg with b s t p x; auto. elim Nx; auto. Qed. Lemma VeltkampN_aux: forall x p q hx:float, Fnormal radix b x -> Fcanonic radix b p -> Fcanonic radix b q -> (Closest b radix (x*((powerRZ radix s)+1))%R p) -> (Closest b radix (x-p)%R q) -> (Closest b radix (q+p)%R hx) -> (Rabs (x-hx) <= (powerRZ radix (s+Fexp x)) /2)%R /\ (exists hx':float, (FtoRradix hx'=hx) /\ (Closest b' radix x hx') /\ (s+Fexp x <= Fexp hx')%Z). intros x p q hx Nx Cp Cq; intros. case (Rle_or_lt 0%R x); intros H2. case H2; clear H2; intros H2. apply Veltkamp_pos with p q; auto. absurd (is_Fzero x). apply FnormalNotZero with radix b; auto. apply is_Fzero_rep2 with radix; auto with real. elim Veltkamp_pos with (Fopp x) (Fopp p) (Fopp q) (Fopp hx). intros H3 T; elim T; intros v T'; elim T'; intros H4 T''; elim T''; intros ; clear T T' T''. split. unfold FtoRradix in H3; repeat rewrite Fopp_correct in H3. rewrite <- Rabs_Ropp. replace (-(x-hx))%R with (-x-(-hx))%R;[unfold FtoRradix; apply Rle_trans with (1:=H3)|ring]. unfold Fopp; auto with real. exists (Fopp v); split. unfold FtoRradix; rewrite Fopp_correct; fold FtoRradix; rewrite H4. unfold FtoRradix; rewrite Fopp_correct; ring. split. replace (FtoRradix x) with (-(Fopp x))%R. apply ClosestOpp; auto. unfold FtoRradix; rewrite Fopp_correct; ring. unfold Fopp; unfold Fopp in H6; auto with zarith. apply FnormalFop; auto. apply FcanonicFopp; auto. apply FcanonicFopp; auto. unfold FtoRradix; rewrite Fopp_correct; auto with real. replace (Fopp x * (powerRZ radix s + 1))%R with (-(x * (powerRZ radix s + 1)))%R. apply ClosestOpp; auto. unfold FtoRradix; rewrite Fopp_correct; ring. replace (Fopp x - Fopp p)%R with (-(x-p))%R;[apply ClosestOpp; auto|idtac]. unfold FtoRradix; repeat rewrite Fopp_correct; ring. replace (Fopp q + Fopp p)%R with (-(q+p))%R;[apply ClosestOpp; auto|idtac]. unfold FtoRradix; repeat rewrite Fopp_correct; ring. Qed. Lemma VeltkampN: forall x p q hx:float, Fnormal radix b x -> (Closest b radix (x*((powerRZ radix s)+1))%R p) -> (Closest b radix (x-p)%R q) -> (Closest b radix (q+p)%R hx) -> (Rabs (x-hx) <= (powerRZ radix (s+Fexp x)) /2)%R /\ (exists hx':float, (FtoRradix hx'=hx) /\ (Closest b' radix x hx') /\ (s+Fexp x <= Fexp hx')%Z). intros. generalize VeltkampN_aux; intros T. elim T with x (Fnormalize radix b t p) (Fnormalize radix b t q) hx; auto; clear T. apply FnormalizeCanonic; auto with zarith; elim H0; auto. apply FnormalizeCanonic; auto with zarith; elim H1; auto. apply ClosestCompatible with (1 := H0); auto. rewrite FnormalizeCorrect; auto with real zarith. apply FnormalizeBounded; auto with zarith; elim H0; auto. apply ClosestCompatible with (1 := H1); auto. unfold FtoRradix; rewrite FnormalizeCorrect; auto with real zarith. rewrite FnormalizeCorrect; auto with real zarith. apply FnormalizeBounded; auto with zarith; elim H1; auto. unfold FtoRradix; repeat rewrite FnormalizeCorrect; auto with real zarith. Qed. Lemma VeltkampEven_pos: forall x p q hx:float, Fnormal radix b x -> Fcanonic radix b p -> Fcanonic radix b q -> (0 < x)%R -> (EvenClosest b radix t (x*((powerRZ radix s)+1))%R p) -> (EvenClosest b radix t (x-p)%R q) -> (EvenClosest b radix t (q+p)%R hx) -> (exists hx':float, (FtoRradix hx'=hx) /\ (EvenClosest b' radix (t-s) x hx')). intros x p q hx Nx Cp Cq; intros. cut (Fnormal radix b q);[intros Nq|idtac]. cut (Fnormal radix b p);[intros Np|idtac]. case (OddEvenDec radix); intros I. elim Nx; elim H0; elim H1; elim H2; intros. unfold FtoRradix, b'; apply VeltkampEven2 with p q; auto with zarith real. elim Nx; elim H0; elim H1; elim H2; intros. unfold FtoRradix, b'; apply VeltkampEven1 with p q; auto with zarith real. case Cp; auto; intros T. absurd (p < (firstNormalPos radix b t))%R. apply Rle_not_lt; generalize EvenClosestMonotone; unfold MonotoneP; intros H3. unfold FtoRradix; apply H3 with b t (firstNormalPos radix b t) (x * (powerRZ radix s + 1))%R; auto. apply Rle_lt_trans with x. unfold FtoRradix; apply FnormalLtFirstNormalPos; auto with zarith real. apply Rle_lt_trans with (x*1)%R; auto with real. apply Rmult_lt_compat_l; auto with real zarith. apply Rle_lt_trans with (0+1)%R; auto with real zarith. unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(EvenClosest b radix t)) (b:=b). apply EvenClosestRoundedModeP; auto with zarith. generalize firstNormalPosNormal; intros H4. elim H4 with radix b t; auto with zarith. unfold FtoRradix; apply FsubnormalLtFirstNormalPos; auto with zarith. apply pPos with b s t x; auto. elim H0; auto. rewrite <- Fopp_Fopp; apply FnormalFop. cut (Fcanonic radix b (Fopp q));[intros T'|apply FcanonicFopp; auto]. case T'; auto; intros T. absurd (Fopp q < (firstNormalPos radix b t))%R. apply Rle_not_lt; generalize EvenClosestMonotone; unfold MonotoneP; intros H3. unfold FtoRradix; apply H3 with b t (firstNormalPos radix b t) (-(x-p))%R; auto. apply Rle_lt_trans with x. unfold FtoRradix; apply FnormalLtFirstNormalPos; auto with zarith real. apply Rplus_lt_reg_r with (FtoRradix x). apply Rle_lt_trans with ((IZR 2)*x)%R;[right; simpl; ring| idtac]. apply Rle_lt_trans with (radix*x)%R;auto with real zarith. apply Rlt_le_trans with (radix*(radix*x))%R. apply Rle_lt_trans with (1*(radix*x))%R; auto with real zarith. apply Rmult_lt_compat_r; auto with real zarith. apply Rmult_lt_0_compat; auto with real zarith. apply Rle_trans with (FtoRradix p);[idtac|right; ring]. apply Rle_trans with (FtoRradix (Float (Fnum x) (Fexp x+2))). unfold FtoRradix, FtoR; simpl; rewrite powerRZ_add; simpl; auto with real zarith. right; ring. unfold FtoRradix; apply H3 with b t (Float (Fnum x) (Fexp x + 2)) (x * (powerRZ radix s + 1))%R; auto. apply Rle_lt_trans with (x * (powerRZ radix 2))%R. unfold FtoRradix, FtoR; simpl; rewrite powerRZ_add; auto with real zarith. apply Rmult_lt_compat_l; auto with real zarith. apply Rle_lt_trans with (powerRZ radix s+0)%R; auto with real zarith. apply Rle_trans with (powerRZ radix s)%R; auto with real zarith. apply Rle_powerRZ; auto with zarith real. unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(EvenClosest b radix t)) (b:=b). apply EvenClosestRoundedModeP; auto with zarith. elim Nx; intros T1 T2; elim T1; intros. split; simpl; auto with zarith. unfold FtoRradix; apply RoundedModeProjectorIdem with (P:=(EvenClosest b radix t)) (b:=b). apply EvenClosestRoundedModeP; auto with zarith. generalize firstNormalPosNormal; intros H4. elim H4 with radix b t; auto with zarith. generalize EvenClosestSymmetric; unfold SymmetricP; intros H4. apply H4; auto with zarith. unfold FtoRradix; apply FsubnormalLtFirstNormalPos; auto with zarith. rewrite Fopp_correct; cut (q <= 0)%R; auto with real. unfold FtoRradix; apply qNeg with b s t p x; auto. elim Nx; auto. elim H0; auto. elim H1; auto. Qed. Lemma VeltkampEvenN_aux: forall x p q hx:float, Fnormal radix b x -> Fcanonic radix b p -> Fcanonic radix b q -> (EvenClosest b radix t (x*((powerRZ radix s)+1))%R p) -> (EvenClosest b radix t (x-p)%R q) -> (EvenClosest b radix t (q+p)%R hx) -> (exists hx':float, (FtoRradix hx'=hx) /\ (EvenClosest b' radix (t-s) x hx')). intros x p q hx Nx Cp Cq; intros. case (Rle_or_lt 0%R x); intros H2. case H2; clear H2; intros H2. apply VeltkampEven_pos with p q; auto. exists (Fzero (-(dExp b'))). split. cut (FtoR radix p=(Fzero (-(dExp b))))%R; [intros I1|idtac]. cut (FtoR radix q=(Fzero (-(dExp b))))%R; [intros I2|idtac]. unfold FtoRradix; apply RoundedModeProjectorIdemEq with b t (EvenClosest b radix t); auto with zarith. apply EvenClosestRoundedModeP; auto with zarith. unfold b'; simpl; apply FboundedFzero. replace (FtoR radix (Fzero (- dExp b'))) with (q+p)%R; auto. unfold FtoRradix; rewrite I1; rewrite I2; unfold FtoRradix. repeat rewrite FzeroisZero; ring. apply sym_eq; unfold FtoRradix; apply RoundedModeProjectorIdemEq with b t (EvenClosest b radix t); auto with zarith. apply EvenClosestRoundedModeP; auto with zarith. apply FboundedFzero. replace (FtoR radix (Fzero (- dExp b))) with (x -p)%R; auto. rewrite <- H2; unfold FtoRradix; rewrite I1; unfold FtoRradix. repeat rewrite FzeroisZero; ring. apply sym_eq; unfold FtoRradix; apply RoundedModeProjectorIdemEq with b t (EvenClosest b radix t); auto with zarith. apply EvenClosestRoundedModeP; auto with zarith. apply FboundedFzero. replace (FtoR radix (Fzero (- dExp b))) with (x * (powerRZ radix s + 1))%R; auto. rewrite <- H2; rewrite FzeroisZero; ring. rewrite <- H2; rewrite <- FzeroisZero with radix b'. apply RoundedModeProjectorIdem with (P:=(EvenClosest b' radix (t-s))) (b:=b'). apply EvenClosestRoundedModeP; auto with zarith. unfold b'; apply p'GivesBound; auto. apply FboundedFzero. elim VeltkampEven_pos with (Fopp x) (Fopp p) (Fopp q) (Fopp hx). intros v T; elim T; intros; clear T. exists (Fopp v); split. unfold FtoRradix; rewrite Fopp_correct; fold FtoRradix; rewrite H3. unfold FtoRradix; rewrite Fopp_correct; ring. replace (FtoRradix x) with (-(Fopp x))%R. apply EvenClosestSymmetric; auto with zarith. unfold FtoRradix; rewrite Fopp_correct; ring. apply FnormalFop; auto. apply FcanonicFopp; auto. apply FcanonicFopp; auto. unfold FtoRradix; rewrite Fopp_correct; auto with real. replace (Fopp x * (powerRZ radix s + 1))%R with (-(x * (powerRZ radix s + 1)))%R. apply EvenClosestSymmetric; auto with zarith. unfold FtoRradix; rewrite Fopp_correct; ring. replace (Fopp x - Fopp p)%R with (-(x-p))%R;[apply EvenClosestSymmetric; auto with zarith|idtac]. unfold FtoRradix; repeat rewrite Fopp_correct; ring. replace (Fopp q + Fopp p)%R with (-(q+p))%R;[apply EvenClosestSymmetric; auto with zarith|idtac]. unfold FtoRradix; repeat rewrite Fopp_correct; ring. Qed. Lemma VeltkampEvenN: forall x p q hx:float, Fnormal radix b x -> (EvenClosest b radix t (x*((powerRZ radix s)+1))%R p) -> (EvenClosest b radix t (x-p)%R q) -> (EvenClosest b radix t (q+p)%R hx) -> (exists hx':float, (FtoRradix hx'=hx) /\ (EvenClosest b' radix (t-s) x hx')). intros. generalize VeltkampEvenN_aux; intros T. elim T with x (Fnormalize radix b t p) (Fnormalize radix b t q) hx; auto; clear T. intros x' T; elim T; intros; exists x'; auto. apply FnormalizeCanonic; auto with zarith; elim H0;intros J1 J2; elim J1; auto. apply FnormalizeCanonic; auto with zarith; elim H1;intros J1 J2; elim J1; auto. apply EvenClosestCompatible with (4 := H0); auto with zarith. rewrite FnormalizeCorrect; auto with real zarith. apply FnormalizeBounded; auto with zarith; elim H0;intros J1 J2; elim J1; auto. apply EvenClosestCompatible with (4 := H1); auto with zarith. unfold FtoRradix; rewrite FnormalizeCorrect; auto with real zarith. rewrite FnormalizeCorrect; auto with real zarith. apply FnormalizeBounded; auto with zarith; elim H1;intros J1 J2; elim J1; auto. unfold FtoRradix; repeat rewrite FnormalizeCorrect; auto with real zarith. Qed. End VeltN. Section VeltS. 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). Definition plusExp (b:Fbound):= Bound (vNum b) (Nplus (dExp b) (Npos (P_of_succ_nat (pred (pred t))))). 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. Lemma bimplybplusNorm: forall f:float, Fbounded b f -> (FtoRradix f <> 0)%R -> (exists g:float, (FtoRradix g=f)%R /\ Fnormal radix (plusExp b) g). intros. exists (Fnormalize radix (plusExp b) t f); split. unfold FtoRradix; rewrite FnormalizeCorrect; auto with zarith. cut (Fcanonic radix (plusExp b) (Fnormalize radix (plusExp b) t f)). intros H1; case H1; auto;intros H2. absurd (Rabs f < (firstNormalPos radix (plusExp b) t))%R. apply Rle_not_lt. unfold firstNormalPos. apply Rle_trans with (powerRZ radix (-(dExp b))). unfold FtoRradix, FtoR, plusExp, nNormMin; simpl. rewrite Zpower_nat_Z_powerRZ; rewrite <- powerRZ_add; auto with real zarith. replace (pred t + - ((dExp b + Npos (P_of_succ_nat (pred (pred t)))))%N)%Z with (-(dExp b))%Z; auto with real. apply trans_eq with (pred t + - (dExp b + (Zpos (P_of_succ_nat (pred (pred t))))))%Z. replace (Zpos (P_of_succ_nat (pred (pred t)))) with (Z_of_nat (nat_of_P (P_of_succ_nat (pred (pred t))))); auto with zarith. rewrite nat_of_P_o_P_of_succ_nat_eq_succ; auto with zarith. replace (S (pred (pred t))) with (pred t); auto with zarith. unfold Z_of_nat; rewrite nat_of_P_o_P_of_succ_nat_eq_succ; auto with zarith. cut (forall (x:N) (y:positive), (x+(Zpos y)=(x +Npos y)%N)%Z). intros T; rewrite <- T; auto with zarith. intros;unfold Nplus. case x; auto with zarith. unfold FtoRradix; rewrite <- Fabs_correct; auto. apply Rle_trans with (1*(powerRZ radix (- dExp b)))%R; auto with real. unfold FtoR; apply Rmult_le_compat; auto with real zarith. unfold Fabs; simpl. cut ((Fnum f=0)%Z \/ (1 <= Zabs (Fnum f))%Z). intros H3; case H3; auto with real zarith. intros H4; absurd (FtoRradix f=0)%R; auto with real. unfold FtoRradix, FtoR; rewrite H4; simpl; ring. case (Zle_or_lt 0%Z (Fnum f)); intros H3. case (Zle_lt_or_eq _ _ H3); auto with zarith; intros H4. right; rewrite Zabs_eq; auto with zarith. right; rewrite <- Zabs_Zopp; rewrite Zabs_eq; auto with zarith. apply Rle_powerRZ; auto with real zarith. unfold Fabs; simpl; elim H; auto. unfold FtoRradix; rewrite <- FnormalizeCorrect with radix (plusExp b) t f; auto. rewrite <- Fabs_correct; auto. apply FsubnormalLtFirstNormalPos; auto with zarith. unfold plusExp; simpl; auto. apply FsubnormFabs; auto. rewrite Fabs_correct; auto with real. apply FnormalizeCanonic; auto with zarith. elim H; split; unfold plusExp; simpl; auto with zarith. cut (forall (x:N) (y:positive), (x+(Zpos y)=(x +Npos y)%N)%Z). intros T; 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 x; auto with zarith. Qed. Lemma Closestbplusb: forall b0:Fbound, forall z:R, forall f:float, (Closest (plusExp b0) radix z f) -> (Fbounded b0 f) -> (Closest b0 radix z f). intros. split; auto. intros g Fg; elim H; intros. apply H2; auto. elim Fg; intros; split; unfold plusExp; auto. 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 b0))%Z; auto with zarith. apply Zle_trans with (-(dExp b0) + 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 b0)+0)%Z; auto with zarith. intros;unfold Nplus. case x; auto with zarith. Qed. Lemma Closestbbplus: forall b0:Fbound, forall n:nat, forall fext f:float, Zpos (vNum b0)=(Zpower_nat radix n) -> (1 < n) -> (-dExp b0 <= Fexp fext)%Z -> (Closest b0 radix fext f) -> (Closest (plusExp b0) radix fext f). intros b0 n fext f K1 K2; intros. elim H0; intros. split. elim H1; intros; split; auto. 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 b0))%Z; auto with zarith. apply Zle_trans with (-(dExp b0) + 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 b0)+0)%Z; auto with zarith. intros;unfold Nplus. case x; auto with zarith. intros g Hg. case (Zle_or_lt (-(dExp b0)) (Fexp g)); intros. apply H2. elim Hg; split; auto with zarith. case (Zle_lt_or_eq (-(dExp b0)) (Fexp (Fnormalize radix b0 n f))). cut (Fbounded b0 (Fnormalize radix b0 n f));[intros T; elim T; auto|idtac]. apply FnormalizeBounded; auto with zarith. intros; apply Rle_trans with ((Fulp b0 radix n f)/2)%R. apply Rmult_le_reg_l with (INR 2); auto with zarith real. apply Rle_trans with (Fulp b0 radix n 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 (n-1+Fexp (Fnormalize radix b0 n f)) - powerRZ radix (-1+ Fexp (Fnormalize radix b0 n f))) - powerRZ radix (n-1-dExp b0))%R; [idtac|unfold Rminus; apply Rplus_le_compat]. apply Rplus_le_reg_l with (powerRZ radix (-1 + Fexp (Fnormalize radix b0 n f))). ring_simplify. apply Rle_trans with (powerRZ radix (Fexp (Fnormalize radix b0 n f))). unfold Fulp, Rdiv; apply Rle_trans with ((/2+/radix)* powerRZ radix (Fexp (Fnormalize radix b0 n 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 b0 n 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; auto with real zarith. replace 2%R with (IZR 2); auto with real zarith. right; ring. apply Rle_trans with (powerRZ radix (n-2+Fexp (Fnormalize radix b0 n f))); [apply Rle_powerRZ; auto with real zarith|idtac]. apply Rle_trans with (1*(powerRZ radix (n - 2 + Fexp (Fnormalize radix b0 n f))))%R; auto with real. apply Rle_trans with ((radix -1)*(powerRZ radix (n - 2 + Fexp (Fnormalize radix b0 n 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 (n - 2+ Fexp (Fnormalize radix b0 n f)) + powerRZ radix (n - 1 + Fexp (Fnormalize radix b0 n f)))%R. right; unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith. simpl; field; auto with real zarith. rewrite Rplus_comm; unfold Rminus;apply Rplus_le_compat_l; apply Ropp_le_contravar; apply Rle_powerRZ; auto with real zarith. cut (powerRZ radix (n - 1 + Fexp (Fnormalize radix b0 n f)) + - powerRZ radix (-1 + Fexp (Fnormalize radix b0 n f))= (Float (pPred (vNum b0)) (-1+Fexp (Fnormalize radix b0 n f))))%R. intros W; rewrite W. 2: unfold FtoRradix, FtoR, pPred. 2: apply trans_eq with (Zpred (Zpos (vNum b0))*powerRZ radix (-1+Fexp (Fnormalize radix b0 n f)))%R;[idtac|simpl; auto with real]. 2: unfold Zpred, Zminus; rewrite plus_IZR. 2: rewrite K1; 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 b0)) (-1 + Fexp (Fnormalize radix b0 n f))) (Rabs fext)); auto with real; intros V. absurd ( Rabs f <= Float (pPred (vNum b0)) (-1 + Fexp (Fnormalize radix b0 n f)))%R. apply Rlt_not_le. apply Rlt_le_trans with (powerRZ radix (n-1+Fexp (Fnormalize radix b0 n f))). rewrite <- W; apply Rlt_le_trans with (powerRZ radix (n - 1 + Fexp (Fnormalize radix b0 n f))+-0)%R; auto with real zarith. right; ring. unfold FtoRradix; rewrite <- FnormalizeCorrect with radix b0 n 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 n). 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 b0 (Fnormalize radix b0 n f));[intros Nf|idtac]. rewrite <- Zpower_nat_Z_powerRZ; rewrite <- K1; rewrite <- mult_IZR; elim Nf; intros. rewrite Zabs_Zmult in H6; rewrite Zabs_eq in H6; auto with zarith real. cut (Fcanonic radix b0 (Fnormalize radix b0 n f));[intros X|apply FnormalizeCanonic; auto with zarith]. case X; auto; intros X'. elim X'; intros H5 H6; elim H6; intros. absurd (-dExp b0 < dExp b0)%Z; auto with zarith. unfold FtoRradix; apply RoundAbsMonotoner with b0 n (Closest b0 radix) fext; auto with real zarith. apply ClosestRoundedModeP with n; auto with zarith. split. apply Zle_lt_trans with (pPred (vNum b0)); auto with zarith. simpl; rewrite Zabs_eq; auto with zarith. apply Zlt_le_weak; apply pPredMoreThanOne with radix n; auto with zarith. unfold pPred; auto with zarith. apply Zle_trans with (Zpred (Fexp (Fnormalize radix b0 n f))); auto with zarith. unfold Zpred; apply Zle_trans with (-1+Fexp (Fnormalize radix b0 n f))%Z;auto with zarith. apply Ropp_le_contravar; rewrite <- Fabs_correct; auto. unfold FtoR, Fabs; simpl. apply Rle_trans with ((powerRZ radix n)*(powerRZ radix (-1-dExp b0)))%R. apply Rmult_le_compat; auto with real zarith. elim Hg; intros; rewrite <- Zpower_nat_Z_powerRZ; 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 b0 n f; auto with zarith. unfold FtoRradix; rewrite <- Fminus_correct; auto. rewrite <- Fabs_correct; auto. unfold FtoR. replace (Fnum (Fabs (Fminus radix (Fnormalize radix b0 n f) fext))) with 0%Z; [simpl; ring|idtac]. apply sym_eq; apply trans_eq with (Zabs (Fnum (Fminus radix (Fnormalize radix b0 n f) fext)));[simpl; auto with zarith|idtac]. cut ( 0 <= Zabs (Fnum (Fminus radix (Fnormalize radix b0 n f) fext)))%Z; auto with real zarith. cut (Zabs (Fnum (Fminus radix (Fnormalize radix b0 n f) fext)) < 1)%Z; auto with real zarith. apply Zlt_Rlt. apply Rmult_lt_reg_l with (powerRZ radix (-(dExp b0))); auto with real zarith. apply Rle_lt_trans with (Rabs (f-fext))%R. unfold FtoRradix; rewrite <- FnormalizeCorrect with radix b0 n f; auto with zarith. rewrite <- Fminus_correct; auto; rewrite <- Fabs_correct; auto. unfold FtoR; simpl. replace (Zmin (Fexp (Fnormalize radix b0 n f)) (Fexp fext)) with (-(dExp b0))%Z; [right; ring|idtac]. rewrite Zmin_le1; auto with zarith. apply Rlt_le_trans with (Fulp b0 radix n 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 b0 radix); auto with zarith real. apply ClosestRoundedModeP with n; auto with zarith. Qed. Lemma EvenClosestbplusb: forall b0:Fbound, forall n:nat, forall fext f:float, Zpos (vNum b0)=(Zpower_nat radix n) -> (1 < n) -> (-dExp b0 <= Fexp fext)%Z -> (EvenClosest (plusExp b0) radix n fext f) -> (Fbounded b0 f) -> (EvenClosest b0 radix n fext f). intros b0 n fext f nGivesB nGe H H0 H1. elim H0; intros. cut (Closest b0 radix fext f);[intros|apply Closestbplusb; auto]. split; auto. cut (Fcanonic radix b0 (Fnormalize radix b0 n f)); [idtac|apply FnormalizeCanonic; auto with zarith]. intros V; case V; clear V; intros H5. case H3; intros H6. left; generalize H6; unfold FNeven. replace (Fnormalize radix (plusExp b0) n f) with (Fnormalize radix b0 n f); auto. apply FcanonicUnique with radix (plusExp b0) n; auto with zarith. elim H5; intros J1 J2; elim J1; intros J3 J4. unfold plusExp; left; split;[split|idtac];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 b0))%Z; auto with zarith. apply Zle_trans with (-(dExp b0) + 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 b0)+0)%Z; auto with zarith. intros;unfold Nplus. case x; auto with zarith. apply FnormalizeCanonic; auto with zarith. elim H0; intros J1 J2; elim J1; auto. repeat rewrite FnormalizeCorrect; auto with real. right; intros; apply H6. apply Closestbbplus with n; auto. right; intros;apply sym_eq. apply RoundedModeProjectorIdemEq with b0 n (Closest b0 radix); auto with zarith. apply ClosestRoundedModeP with n; auto with zarith. replace (FtoR radix f) with (FtoR radix fext); auto with real. apply Rplus_eq_reg_l with (-(FtoR radix f))%R. ring_simplify (- FtoR radix f + FtoR radix f)%R. rewrite <- FnormalizeCorrect with radix b0 n f; auto. apply trans_eq with ((-Fnum (Fnormalize radix b0 n f) + (Fnum fext)*Zpower_nat radix (Zabs_nat (Fexp fext+dExp b0)))%Z * (powerRZ radix (-(dExp b0))))%R. rewrite plus_IZR; rewrite mult_IZR; rewrite Zpower_nat_Z_powerRZ. rewrite Ropp_Ropp_IZR; unfold FtoR. replace (Fexp (Fnormalize radix b0 n f)) with (-(dExp b0))%Z. rewrite Rmult_plus_distr_r; rewrite Rmult_assoc. rewrite <- powerRZ_add; auto with real zarith. replace (Zabs_nat (Fexp fext + dExp b0)+-dExp b0)%Z with (Fexp fext);[ring|idtac]. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. elim H5; intros J1 J2; elim J2; auto. replace (- Fnum (Fnormalize radix b0 n f) + Fnum fext * Zpower_nat radix (Zabs_nat (Fexp fext + dExp b0)))%Z with 0%Z; [simpl; ring|idtac]. cut (Zabs (- Fnum (Fnormalize radix b0 n f) + Fnum fext * Zpower_nat radix (Zabs_nat (Fexp fext + dExp b0))) = Zabs 0)%Z; auto with zarith. intros J; case (Zabs_eq_case _ _ J); auto with zarith. rewrite (Zabs_eq 0%Z); auto with zarith. cut (0 <= (Zabs (- Fnum (Fnormalize radix b0 n f) + Fnum fext * Zpower_nat radix (Zabs_nat (Fexp fext + dExp b0)))))%Z; auto with zarith. cut ((Zabs (- Fnum (Fnormalize radix b0 n f) + Fnum fext * Zpower_nat radix (Zabs_nat (Fexp fext + dExp b0)))) < 1)%Z; auto with zarith. apply Zlt_Rlt. rewrite <- Rabs_Zabs; rewrite plus_IZR; rewrite Ropp_Ropp_IZR. rewrite mult_IZR; rewrite Zpower_nat_Z_powerRZ. apply Rmult_lt_reg_l with (Fulp b0 radix n f); [unfold Fulp; auto with real zarith|idtac]. pattern (Fulp b0 radix n f) at 1; rewrite <- (Rabs_right (Fulp b0 radix n f)). 2: apply Rle_ge; unfold Fulp; auto with real zarith. rewrite <- Rabs_mult. replace (Fulp b0 radix n f * (- Fnum (Fnormalize radix b0 n f) + Fnum fext * powerRZ radix (Zabs_nat (Fexp fext + dExp b0))))%R with (fext -FtoR radix f)%R. apply Rlt_le_trans with ( Fulp b0 radix n f);[idtac|simpl; right; ring]. apply RoundedModeUlp with (Closest b0 radix); auto with zarith. apply ClosestRoundedModeP with n; auto with zarith. rewrite <- FnormalizeCorrect with radix b0 n f; auto. apply Rplus_eq_reg_l with (FtoR radix (Fnormalize radix b0 n f)). unfold Fulp, FtoRradix, FtoR;ring_simplify. apply trans_eq with (Fnum fext * (powerRZ radix (Fexp (Fnormalize radix b0 n f))* powerRZ radix (Zabs_nat (Fexp fext + dExp b0))))%R;[idtac|ring]. rewrite <- powerRZ_add; auto with real zarith. replace (Fexp (Fnormalize radix b0 n f) + Zabs_nat (Fexp fext + dExp b0))%Z with (Fexp fext); auto. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. elim H5; intros J1 J2; elim J2; intros; auto with zarith. Qed. Lemma ClosestClosest: forall b0:Fbound, forall n:nat, forall z:R, forall f1 f2:float, Zpos (vNum b0)=(Zpower_nat radix n) -> (1 < n) -> (Closest b0 radix z f1) -> (Closest b0 radix z f2) -> Fnormal radix b0 f2 -> (Fexp f1 <= Fexp f2 -2)%Z -> False. intros. cut (FtoRradix (Fabs f1) < Fabs f2)%R;[intros|idtac]. absurd (FtoRradix (Fabs f2) = (FNSucc b0 radix n (Fabs f1)))%R. cut (FNSucc b0 radix n (Fabs f1) < (Fabs f2))%R; auto with real. unfold FtoRradix; apply FcanonicPosFexpRlt with b0 n; auto with zarith. apply Rle_trans with (FtoRradix (Fabs f1)). unfold FtoRradix; rewrite Fabs_correct; auto with real. unfold FtoRradix; apply Rlt_le; apply FNSuccLt; auto with zarith. rewrite Fabs_correct; auto with real. apply FNSuccCanonic; auto with zarith. apply absFBounded; elim H1; auto. apply FcanonicFabs; auto; left; auto. cut (Fexp (Fnormalize radix b0 n (Fabs f1)) <= Fexp (Fabs f2) - 2)%Z;[intros|idtac]. unfold FNSucc, FSucc. case (Z_eq_bool (Fnum (Fnormalize radix b0 n (Fabs f1)))); auto with zarith. apply Zle_lt_trans with (Zsucc (Fexp (Fnormalize radix b0 n (Fabs f1)))); auto with zarith. case (Z_eq_bool (Fnum (Fnormalize radix b0 n (Fabs f1))) (- nNormMin radix n)). case (Z_eq_bool (Fexp (Fnormalize radix b0 n (Fabs f1))) (- dExp b0)). apply Zle_lt_trans with (Fexp (Fnormalize radix b0 n (Fabs f1))); auto with zarith. apply Zle_lt_trans with (Zpred (Fexp (Fnormalize radix b0 n (Fabs f1)))); auto with zarith. apply Zle_lt_trans with (Fexp (Fnormalize radix b0 n (Fabs f1))); auto with zarith. apply Zle_trans with (Fexp (Fabs f1));[idtac|unfold Fabs; simpl; auto with zarith]. apply FcanonicLeastExp with radix b0 n; auto with zarith. rewrite FnormalizeCorrect; auto with real. apply absFBounded; elim H1; auto. apply FnormalizeCanonic; auto with zarith. apply absFBounded; elim H1; auto. cut (isMin b0 radix (Rabs z) (Fabs f1));[intros K|idtac]. cut (isMax b0 radix (Rabs z) (Fabs f2));[intros K'|idtac]. apply (MaxUniqueP b0 radix (Rabs z)); auto. apply MinMax; auto with zarith. case (Req_dec (Rabs z) (Fabs f1)); auto with real. intros V; absurd (FtoRradix (Fabs f1) = Fabs f2)%R; auto with real. unfold FtoRradix; apply RoundedModeProjectorIdemEq with b0 n (isMax b0 radix); auto with real zarith. apply MaxRoundedModeP with n; auto with zarith. apply absFBounded; elim H1; auto. fold FtoRradix; rewrite <- V; auto. case (ClosestMinOrMax b0 radix (Rabs z) (Fabs f2)); auto. apply ClosestFabs with n; auto. intros H6. absurd (FtoRradix (Fabs f1)=Fabs f2); auto with real. apply (MinUniqueP b0 radix (Rabs z)); auto. case (ClosestMinOrMax b0 radix (Rabs z) (Fabs f1)); auto. apply ClosestFabs with n; auto. intros H6. case (ClosestMinOrMax b0 radix (Rabs z) (Fabs f2)); auto. apply ClosestFabs with n; auto. intros H7; elim H6; elim H7; intros. elim H9; elim H11; intros. absurd ( (Fabs f2) <= (Fabs f1))%R; auto with real. apply Rle_trans with (Rabs z); auto with real. intros H7; absurd (FtoRradix (Fabs f1)=Fabs f2); auto with real. apply (MaxUniqueP b0 radix (Rabs z)); auto. unfold FtoRradix; rewrite <- FnormalizeCorrect with radix b0 n (Fabs f1); auto. apply FcanonicPosFexpRlt with b0 n; auto with zarith. rewrite FnormalizeCorrect; auto; rewrite Fabs_correct; auto with real. rewrite Fabs_correct; auto with real. apply FnormalizeCanonic; auto with zarith. apply absFBounded; elim H1; auto. apply FcanonicFabs; auto; left; auto. apply Zle_lt_trans with (Fexp (Fabs f1)); [idtac|unfold Fabs; simpl; auto with zarith]. apply FcanonicLeastExp with radix b0 n; auto with zarith. rewrite FnormalizeCorrect; auto with real. apply absFBounded; elim H1; auto. apply FnormalizeCanonic; auto with zarith. apply absFBounded; elim H1; auto. Qed. Lemma EvenClosestbbplus: forall b0:Fbound, forall n:nat, forall fext f:float, Zpos (vNum b0)=(Zpower_nat radix n) -> (1 < n) -> (-dExp b0 <= Fexp fext)%Z -> (EvenClosest b0 radix n fext f) -> (EvenClosest (plusExp b0) radix n fext f). intros. elim H2; intros. cut (Closest (plusExp b0) radix fext f); [intros|apply Closestbbplus with n; auto]. split; auto. cut (Fbounded b0 f);[intros K|elim H2; intros J1 J2; elim J1; auto]. case (Zle_lt_or_eq (-(dExp b0)) (Fexp (Fnormalize radix b0 n f))). cut (Fbounded b0 (Fnormalize radix b0 n f));[intros T; elim T; auto|idtac]. apply FnormalizeBounded; auto with zarith. intros K'. cut (Fcanonic radix b0 (Fnormalize radix b0 n f)); [idtac|apply FnormalizeCanonic; auto with zarith]. intros V; case V; clear V; intros H6. 2: elim H6; intros J1 J2; elim J2; intros. 2: absurd (-(dExp b0) < -(dExp b0))%Z; auto with zarith. case H4; intros H7. left; generalize H7; unfold FNeven. replace (Fnormalize radix (plusExp b0) n f) with (Fnormalize radix b0 n f); auto. apply FcanonicUnique with radix (plusExp b0) n; auto with zarith. elim H6; intros J1 J2; elim J1; intros J3 J4. unfold plusExp; left; split;[split|idtac];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 b0))%Z; auto with zarith. apply Zle_trans with (-(dExp b0) + 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 b0)+0)%Z; auto with zarith. intros;unfold Nplus. case x; auto with zarith. apply FnormalizeCanonic; auto with zarith. elim H5; auto. repeat rewrite FnormalizeCorrect; auto with real. right; intros. case (Zle_or_lt (-(dExp b0)) (Fexp q)); intros. apply H7. apply Closestbplusb; auto. elim H8; intros J1 J2; elim J1; intros; split; auto. absurd (1=1)%R; auto with real;intros Y; clear Y. apply ClosestClosest with (plusExp b0) n fext q (Fnormalize radix b0 n f); auto. apply ClosestCompatible with (1 := H5); auto. rewrite FnormalizeCorrect; auto with real. elim H6; intros J1 J2; elim J1; intros. split; 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 b0))%Z; auto with zarith. apply Zle_trans with (-(dExp b0) + 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 b0)+0)%Z; auto with zarith. intros;unfold Nplus. case x; auto with zarith. elim H6; intros J1 J2; elim J1; 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 b0))%Z; auto with zarith. apply Zle_trans with (-(dExp b0) + 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 b0)+0)%Z; auto with zarith. intros;unfold Nplus. case x; auto with zarith. apply Zle_trans with (-(dExp b0)-1)%Z; auto with zarith. intros H6. right; intros;apply sym_eq. apply RoundedModeProjectorIdemEq with (plusExp b0) n (Closest (plusExp b0) radix); auto with zarith. apply ClosestRoundedModeP with n; auto with zarith. elim H5; auto. replace (FtoR radix f) with (FtoR radix fext); auto with real. apply Rplus_eq_reg_l with (-(FtoR radix f))%R. ring_simplify (- FtoR radix f + FtoR radix f)%R. rewrite <- FnormalizeCorrect with radix b0 n f; auto. apply trans_eq with ((-Fnum (Fnormalize radix b0 n f) + (Fnum fext)*Zpower_nat radix (Zabs_nat (Fexp fext+dExp b0)))%Z * (powerRZ radix (-(dExp b0))))%R. rewrite plus_IZR; rewrite mult_IZR; rewrite Zpower_nat_Z_powerRZ. rewrite Ropp_Ropp_IZR; unfold FtoR. replace (Fexp (Fnormalize radix b0 n f)) with (-(dExp b0))%Z. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. rewrite powerRZ_add; auto with real zarith. rewrite powerRZ_Zopp; auto with real zarith. field; auto with real zarith. replace (- Fnum (Fnormalize radix b0 n f) + Fnum fext * Zpower_nat radix (Zabs_nat (Fexp fext + dExp b0)))%Z with 0%Z; [simpl; ring|idtac]. cut (Zabs (- Fnum (Fnormalize radix b0 n f) + Fnum fext * Zpower_nat radix (Zabs_nat (Fexp fext + dExp b0))) = Zabs 0)%Z; auto with zarith. intros J; case (Zabs_eq_case _ _ J); auto with zarith. rewrite (Zabs_eq 0%Z); auto with zarith. cut (0 <= (Zabs (- Fnum (Fnormalize radix b0 n f) + Fnum fext * Zpower_nat radix (Zabs_nat (Fexp fext + dExp b0)))))%Z; auto with zarith. cut ((Zabs (- Fnum (Fnormalize radix b0 n f) + Fnum fext * Zpower_nat radix (Zabs_nat (Fexp fext + dExp b0)))) < 1)%Z; auto with zarith. apply Zlt_Rlt. rewrite <- Rabs_Zabs; rewrite plus_IZR; rewrite Ropp_Ropp_IZR. rewrite mult_IZR; rewrite Zpower_nat_Z_powerRZ. apply Rmult_lt_reg_l with (Fulp b0 radix n f); [unfold Fulp; auto with real zarith|idtac]. pattern (Fulp b0 radix n f) at 1; rewrite <- (Rabs_right (Fulp b0 radix n f)). 2: apply Rle_ge; unfold Fulp; auto with real zarith. rewrite <- Rabs_mult. replace (Fulp b0 radix n f * (- Fnum (Fnormalize radix b0 n f) + Fnum fext * powerRZ radix (Zabs_nat (Fexp fext + dExp b0))))%R with (fext -FtoR radix f)%R. apply Rlt_le_trans with ( Fulp b0 radix n f);[idtac|simpl; right; ring]. apply RoundedModeUlp with (Closest b0 radix); auto with zarith. apply ClosestRoundedModeP with n; auto with zarith. rewrite <- FnormalizeCorrect with radix b0 n f; auto. apply Rplus_eq_reg_l with (FtoR radix (Fnormalize radix b0 n f)). unfold Fulp, FtoRradix, FtoR; ring_simplify. apply trans_eq with (Fnum fext * (powerRZ radix (Fexp (Fnormalize radix b0 n f)) *(powerRZ radix (Zabs_nat (Fexp fext + dExp b0)))))%R;[idtac|ring]. rewrite <- powerRZ_add; auto with real zarith. replace (Fexp (Fnormalize radix b0 n f) + Zabs_nat (Fexp fext + dExp b0))%Z with (Fexp fext); auto. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. Qed. Lemma VeltkampS: forall x p q hx:float, Fsubnormal radix b x -> (Closest b radix (x*((powerRZ radix s)+1))%R p) -> (Closest b radix (x-p)%R q) -> (Closest b radix (q+p)%R hx) -> (Rabs (x-hx) <= (powerRZ radix (s+Fexp x)) /2)%R /\ (exists hx':float, (FtoRradix hx'=hx) /\ (Closest b' radix x hx')). intros x p q hx Sx pDef qDef hxDef. case (Req_dec 0%R x); intros Y. assert ((exists hx' : float, FtoRradix hx' = hx /\ Closest b' radix x hx' /\ (s + Fexp x <= Fexp hx')%Z /\ (FtoRradix hx'=0)%R)). exists (Fzero (s+Fexp x)). cut (Fbounded b (Fzero (s+Fexp x)));[intros KK|idtac]. split. cut (FtoR radix p=(Fzero (-(dExp b))))%R; [intros I1|idtac]. cut (FtoR radix q=(Fzero (-(dExp b))))%R; [intros I2|idtac]. unfold FtoRradix; apply RoundedModeProjectorIdemEq with b t (Closest b radix); auto with zarith. apply ClosestRoundedModeP with t; auto with zarith. replace (FtoR radix (Fzero (s+Fexp x))) with (q+p)%R; auto. unfold FtoRradix; rewrite I1; rewrite I2; unfold FtoRradix. repeat rewrite FzeroisZero. unfold Fzero, FtoR; simpl; ring. apply sym_eq; unfold FtoRradix; apply RoundedModeProjectorIdemEq with b t (Closest b radix); auto with zarith. apply ClosestRoundedModeP with t; auto with zarith. apply FboundedFzero. replace (FtoR radix (Fzero (- dExp b))) with (x -p)%R; auto. rewrite <- Y; unfold FtoRradix; rewrite I1; unfold FtoRradix. repeat rewrite FzeroisZero; ring. apply sym_eq; unfold FtoRradix; apply RoundedModeProjectorIdemEq with b t (Closest b radix); auto with zarith. apply ClosestRoundedModeP with t; auto with zarith. apply FboundedFzero. replace (FtoR radix (Fzero (- dExp b))) with (x * (powerRZ radix s + 1))%R; auto. rewrite <- Y; rewrite FzeroisZero; ring. split. rewrite <- Y; replace 0%R with (FtoR radix (Fzero (s + Fexp x))). apply RoundedModeProjectorIdem with (P:=(Closest b' radix)) (b:=b'). apply ClosestRoundedModeP with (t-s); auto with zarith. unfold b'; apply p'GivesBound; auto. unfold Fzero; split; auto with zarith. unfold b'; simpl; auto with zarith. elim Sx; intros T1 T2; elim T1; auto with zarith. unfold Fzero, FtoR; simpl; ring. split;[unfold Fzero; simpl; auto with zarith|idtac]. unfold Fzero, FtoRradix, FtoR; simpl; ring. unfold Fzero; split; auto with zarith. elim Sx; intros T1 T2; elim T1; simpl; auto with zarith. elim H; intros f T; elim T; intros H1 T'; elim T'; intros H2 T''; elim T''; intros; clear T T' T''. split. rewrite <- Y; rewrite <- H1; rewrite H3; ring_simplify (0-0)%R; rewrite Rabs_R0. unfold Rdiv; apply Rmult_le_pos; auto with real zarith. exists f; split; auto; split; auto. lapply (bimplybplusNorm x);[intros T|elim Sx; auto]. lapply T; clear T; [intros T; elim T; intros x' T'; elim T'; intros x'Eq Nx'; clear T T'|auto with real]. generalize VeltkampN; intros. elim H with radix (plusExp b) s t x' p q hx; auto with zarith; clear H. intros C T; elim T; intros f H; elim H; intros; clear H T. elim H1; clear H1; intros H1 C'. cut (Closest (plusExp b') radix x f);[clear H1; intros H1|idtac]. case (Zle_or_lt (-(dExp b)) (Fexp f)); intros H2. cut (Fbounded b' f);[intros H3|idtac]. split. rewrite <- x'Eq; unfold FtoRradix; apply Rle_trans with (1:=C). unfold Rdiv; apply Rmult_le_compat_r; auto with real. apply Rle_powerRZ; auto with real zarith. apply Zplus_le_compat_l. apply FcanonicLeastExp with radix (plusExp b) t; auto with zarith. elim Sx; intros T1 T2; elim T1; intros. split; unfold plusExp; 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. left; auto. exists f; split;auto with real. apply Closestbplusb; auto. split; [idtac|unfold b'; simpl; auto]. elim H1; intros J1 J2; elim J1; intros; auto with zarith. split. rewrite <- x'Eq; unfold FtoRradix; apply Rle_trans with (1:=C). unfold Rdiv; apply Rmult_le_compat_r; auto with real. apply Rle_powerRZ; auto with real zarith. apply Zplus_le_compat_l. apply FcanonicLeastExp with radix (plusExp b) t; auto with zarith. elim Sx; intros T1 T2; elim T1; intros. split; unfold plusExp; 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. left; auto. generalize RoundedModeRep; intros T. elim T with (plusExp b') radix (t-s) (Closest (plusExp b') radix) x f; auto with zarith. clear T;intros m H3. cut (Fbounded b' (Float m (Fexp x)));[intros H4|idtac]. exists (Float m (Fexp x)); split. unfold FtoRradix; rewrite <- H3; rewrite H0; auto with real. apply Closestbplusb; auto. apply (ClosestCompatible (plusExp b') radix x x f (Float m (Fexp x))); auto with real zarith. elim H4; intros; split; 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. unfold b'; simpl; auto with zarith. split. apply Zle_lt_trans with (Zabs (Fnum f)). apply Zle_trans with ((Zabs m)*1)%Z; auto with zarith. simpl; auto with zarith. apply Zle_trans with ((Zabs m)*(Zpower_nat radix (Zabs_nat (Fexp x-Fexp f))))%Z. apply Zmult_le_compat_l; auto with zarith. replace (Fnum f) with (m*Zpower_nat radix (Zabs_nat (Fexp x - Fexp f)))%Z. rewrite Zabs_Zmult; rewrite (Zabs_eq (Zpower_nat radix (Zabs_nat (Fexp x - Fexp f)))); auto with zarith. apply eq_IZR; rewrite mult_IZR; rewrite Zpower_nat_Z_powerRZ. apply Rmult_eq_reg_l with (powerRZ radix (Fexp f)); auto with real zarith. apply trans_eq with (FtoR radix f);[rewrite H3|unfold FtoR; ring]. unfold FtoR; simpl. apply trans_eq with (m*(powerRZ radix (Fexp f)* powerRZ radix (Zabs_nat (Fexp x - Fexp f))))%R;[ring|idtac]. rewrite <- powerRZ_add; auto with real zarith. replace (Fexp f + Zabs_nat (Fexp x - Fexp f))%Z with (Fexp x);[ring|idtac]. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. elim Sx; intros J1 J2; elim J1; intros; auto with zarith. elim H1; intros J1 J2; elim J1; unfold plusExp; simpl; auto with zarith. elim Sx; intros J1 J2; elim J1; intros ; unfold b'; simpl; auto. unfold plusExp; simpl. rewrite <- p'GivesBound with radix b s t; auto with zarith. simpl; rewrite nat_of_P_o_P_of_succ_nat_eq_succ; auto with zarith. apply ClosestRoundedModeP with (t-s); auto with zarith. unfold plusExp; simpl. rewrite <- p'GivesBound with radix b s t; auto with zarith. simpl; rewrite nat_of_P_o_P_of_succ_nat_eq_succ; auto with zarith. rewrite <- x'Eq; unfold FtoRradix;auto with zarith. replace (FtoR radix x' * (powerRZ radix s + 1))%R with (FtoRradix (Fplus radix x (Float (Fnum x) (s+Fexp x)%Z))). apply Closestbbplus with t; auto with zarith. unfold Fplus; simpl;apply Zmin_Zle. elim Sx; intros J1 J2; elim J1; auto. elim Sx; intros J1 J2; elim J1; auto with zarith. replace (FtoRradix (Fplus radix x (Float (Fnum x) (s + Fexp x)))) with (x * (powerRZ radix s + 1))%R; auto with real. unfold FtoRradix; rewrite Fplus_correct; auto. unfold FtoR; simpl; rewrite powerRZ_add; auto with real zarith; ring. fold FtoRradix; rewrite x'Eq; unfold FtoRradix; rewrite Fplus_correct; auto. unfold FtoR; simpl; rewrite powerRZ_add; auto with real zarith; ring. unfold FtoRradix in x'Eq; rewrite x'Eq; rewrite <- Fminus_correct; auto. apply Closestbbplus with t; auto with zarith. unfold Fplus; simpl;apply Zmin_Zle. elim Sx; intros J1 J2; elim J1; auto. elim pDef; intros J1 J2; elim J1; auto with zarith. replace (FtoRradix (Fminus radix x p)) with (x -p)%R; auto with real. unfold FtoRradix; rewrite Fminus_correct; auto with real. rewrite <- Fplus_correct; auto. apply Closestbbplus with t; auto with zarith. unfold Fplus; simpl;apply Zmin_Zle. elim qDef; intros J1 J2; elim J1; auto. elim pDef; intros J1 J2; elim J1; auto with zarith. replace (FtoRradix (Fplus radix q p)) with (q +p)%R; auto with real. unfold FtoRradix; rewrite Fplus_correct; auto with real. Qed. Lemma VeltkampEvenS: forall x p q hx:float, Fsubnormal radix b x -> (EvenClosest b radix t (x*((powerRZ radix s)+1))%R p) -> (EvenClosest b radix t (x-p)%R q) -> (EvenClosest b radix t (q+p)%R hx) -> (exists hx':float, (FtoRradix hx'=hx) /\ (EvenClosest b' radix (t-s) x hx')). intros x p q hx Sx pDef qDef hxDef. case (Req_dec 0%R x); intros Y. exists (Fzero (-(dExp b'))). split. cut (FtoR radix p=(Fzero (-(dExp b))))%R; [intros I1|idtac]. cut (FtoR radix q=(Fzero (-(dExp b))))%R; [intros I2|idtac]. unfold FtoRradix; apply RoundedModeProjectorIdemEq with b t (EvenClosest b radix t); auto with zarith. apply EvenClosestRoundedModeP; auto with zarith. unfold b'; simpl; apply FboundedFzero. replace (FtoR radix (Fzero (- dExp b'))) with (q+p)%R; auto. unfold FtoRradix; rewrite I1; rewrite I2; unfold FtoRradix. repeat rewrite FzeroisZero; ring. apply sym_eq; unfold FtoRradix; apply RoundedModeProjectorIdemEq with b t (EvenClosest b radix t); auto with zarith. apply EvenClosestRoundedModeP; auto with zarith. apply FboundedFzero. replace (FtoR radix (Fzero (- dExp b))) with (x -p)%R; auto. rewrite <- Y; unfold FtoRradix; rewrite I1; unfold FtoRradix. repeat rewrite FzeroisZero; ring. apply sym_eq; unfold FtoRradix; apply RoundedModeProjectorIdemEq with b t (EvenClosest b radix t); auto with zarith. apply EvenClosestRoundedModeP; auto with zarith. apply FboundedFzero. replace (FtoR radix (Fzero (- dExp b))) with (x * (powerRZ radix s + 1))%R; auto. rewrite <- Y; rewrite FzeroisZero; ring. rewrite <- Y; rewrite <- FzeroisZero with radix b'. apply RoundedModeProjectorIdem with (P:=(EvenClosest b' radix (t-s))) (b:=b'). apply EvenClosestRoundedModeP; auto with zarith. unfold b'; apply p'GivesBound; auto. apply FboundedFzero. lapply (bimplybplusNorm x);[intros T|elim Sx; auto]. lapply T; clear T; [intros T; elim T; intros x' T'; elim T'; intros x'Eq Nx'; clear T T'|auto with real]. generalize VeltkampEvenN; intros. elim H with radix (plusExp b) s t x' p q hx; auto with zarith; clear H. intros f H; elim H; intros; clear H. cut (EvenClosest (plusExp b') radix (t-s) x f);[clear H1; intros H1|idtac]. case (Zle_or_lt (-(dExp b)) (Fexp f)); intros H2. cut (Fbounded b' f);[intros H3|idtac]. exists f; split;auto with real. apply EvenClosestbplusb; auto with zarith. unfold b'; apply p'GivesBound; auto. unfold b'; simpl; elim Sx; intros J1 J2; elim J1; auto. split; [idtac|unfold b'; simpl; auto]. elim H1; intros J1 J2; elim J1; intros J3 J4; elim J3; auto with zarith. generalize RoundedModeRep; intros T. elim T with (plusExp b') radix (t-s) (Closest (plusExp b') radix) x f; auto with zarith. clear T;intros m H3. cut (Fbounded b' (Float m (Fexp x)));[intros H4|idtac]. exists (Float m (Fexp x)); split. unfold FtoRradix; rewrite <- H3; rewrite H0; auto with real. apply EvenClosestbplusb; auto with zarith. unfold b'; apply p'GivesBound; auto. unfold b'; simpl; elim Sx; intros J1 J2; elim J1; auto. generalize EvenClosestCompatible; unfold CompatibleP; intros C. apply C with x f; auto with real zarith; clear C. rewrite <- p'GivesBound with radix b s t; auto; unfold plusExp, b'; simpl; auto. elim H4; intros; split; 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. unfold b'; simpl; auto with zarith. split. apply Zle_lt_trans with (Zabs (Fnum f)). apply Zle_trans with ((Zabs m)*1)%Z; auto with zarith. simpl; auto with zarith. apply Zle_trans with ((Zabs m)*(Zpower_nat radix (Zabs_nat (Fexp x-Fexp f))))%Z. apply Zmult_le_compat_l; auto with zarith. replace (Fnum f) with (m*Zpower_nat radix (Zabs_nat (Fexp x - Fexp f)))%Z. rewrite Zabs_Zmult; rewrite (Zabs_eq (Zpower_nat radix (Zabs_nat (Fexp x - Fexp f)))); auto with zarith. apply eq_IZR; rewrite mult_IZR; rewrite Zpower_nat_Z_powerRZ. apply Rmult_eq_reg_l with (powerRZ radix (Fexp f)); auto with real zarith. apply trans_eq with (FtoR radix f);[rewrite H3|unfold FtoR; ring]. unfold FtoR; simpl. apply trans_eq with (m*(powerRZ radix (Fexp f)*powerRZ radix (Zabs_nat (Fexp x - Fexp f))))%R;[ring|idtac]. rewrite <- powerRZ_add; auto with real zarith. replace (Fexp f + Zabs_nat (Fexp x - Fexp f))%Z with (Fexp x);[ring|idtac]. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. elim Sx; intros J1 J2; elim J1; intros; auto with zarith. elim H1; intros J1 J2; elim J1; intros J3 J4; elim J3; unfold plusExp; simpl; auto with zarith. elim Sx; intros J1 J2; elim J1; intros ; unfold b'; simpl; auto. rewrite <- p'GivesBound with radix b s t; unfold plusExp, b'; simpl; auto with zarith. apply ClosestRoundedModeP with (t-s); auto with zarith. rewrite <- p'GivesBound with radix b s t; unfold plusExp, b'; simpl; auto with zarith. elim H1; auto. rewrite <- x'Eq; unfold FtoRradix;auto with zarith. replace (FtoR radix x' * (powerRZ radix s + 1))%R with (FtoRradix (Fplus radix x (Float (Fnum x) (s+Fexp x)%Z))). apply EvenClosestbbplus; auto with zarith. unfold Fplus; simpl;apply Zmin_Zle. elim Sx; intros J1 J2; elim J1; auto. elim Sx; intros J1 J2; elim J1; auto with zarith. replace (FtoRradix (Fplus radix x (Float (Fnum x) (s + Fexp x)))) with (x * (powerRZ radix s + 1))%R; auto with real. unfold FtoRradix; rewrite Fplus_correct; auto. unfold FtoR; simpl; rewrite powerRZ_add; auto with real zarith; ring. fold FtoRradix; rewrite x'Eq; unfold FtoRradix; rewrite Fplus_correct; auto. unfold FtoR; simpl; rewrite powerRZ_add; auto with real zarith; ring. unfold FtoRradix in x'Eq; rewrite x'Eq; rewrite <- Fminus_correct; auto. apply EvenClosestbbplus; auto with zarith. unfold Fplus; simpl;apply Zmin_Zle. elim Sx; intros J1 J2; elim J1; auto. elim pDef; intros J1 J2; elim J1; intros J3 J4; elim J3; auto with zarith. replace (FtoRradix (Fminus radix x p)) with (x -p)%R; auto with real. unfold FtoRradix; rewrite Fminus_correct; auto with real. rewrite <- Fplus_correct; auto. apply EvenClosestbbplus; auto with zarith. unfold Fplus; simpl;apply Zmin_Zle. elim qDef; intros J1 J2; elim J1; intros J3 J4; elim J3; auto. elim pDef; intros J1 J2; elim J1; intros J3 J4; elim J3; auto with zarith. replace (FtoRradix (Fplus radix q p)) with (q +p)%R; auto with real. unfold FtoRradix; rewrite Fplus_correct; auto with real. Qed. End VeltS. Section VeltUlt. 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 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. Theorem Veltkamp: forall x p q hx:float, (Fbounded b x) -> (Closest b radix (x*((powerRZ radix s)+1))%R p) -> (Closest b radix (x-p)%R q) -> (Closest b radix (q+p)%R hx) -> (Rabs (x-hx) <= (powerRZ radix (s+Fexp x)) /2)%R /\ (exists hx':float, (FtoRradix hx'=hx) /\ (Closest b' radix x hx') /\ ((Fnormal radix b x) -> (s+Fexp x <= Fexp hx')%Z)). intros. cut (Fcanonic radix b (Fnormalize radix b t x)); [intros C|apply FnormalizeCanonic; auto with zarith]. case C; clear C; intros. generalize VeltkampN; intros T. elim T with radix b s t (Fnormalize radix b t x) p q hx; auto. intros C TT; elim TT; intros v T'; elim T'; intros ; clear T T' TT. rewrite FnormalizeCorrect in H5; auto. rewrite FnormalizeCorrect in C; auto. split. unfold FtoRradix; apply Rle_trans with (1:=C). unfold Rdiv; apply Rmult_le_compat_r; auto with real. apply Rle_powerRZ; auto with real zarith. apply Zplus_le_compat_l. apply FcanonicLeastExp with radix b t; auto with zarith. rewrite FnormalizeCorrect; auto with zarith real. left; auto. elim H5; intros. exists v; split; auto with zarith. split; auto with zarith. intros; replace x with (Fnormalize radix b t x); auto with zarith. rewrite FcanonicFnormalizeEq; auto with zarith. left; auto. rewrite FnormalizeCorrect; auto with real. rewrite FnormalizeCorrect; auto with real. generalize VeltkampS; intros T. elim T with radix b s t (Fnormalize radix b t x) p q hx; auto; clear T. intros C TT; elim TT; intros v T'; elim T'; intros ; clear T' TT. rewrite FnormalizeCorrect in H5; auto. rewrite FnormalizeCorrect in C; auto. split. unfold FtoRradix; apply Rle_trans with (1:=C). unfold Rdiv; apply Rmult_le_compat_r; auto with real. apply Rle_powerRZ; auto with real zarith. apply Zplus_le_compat_l. apply FcanonicLeastExp with radix b t; auto with zarith. rewrite FnormalizeCorrect; auto with zarith real. right; auto. exists v; split; auto with zarith. split; auto with zarith. intros T; absurd (FtoRradix x=(Fnormalize radix b t x))%R. unfold FtoRradix; apply NormalAndSubNormalNotEq with b t; auto with zarith. unfold FtoRradix; rewrite FnormalizeCorrect; auto with real zarith. rewrite FnormalizeCorrect; auto with real. rewrite FnormalizeCorrect; auto with real. Qed. Theorem VeltkampEven: forall x p q hx:float, (Fbounded b x) -> (EvenClosest b radix t (x*((powerRZ radix s)+1))%R p) -> (EvenClosest b radix t (x-p)%R q) -> (EvenClosest b radix t (q+p)%R hx) -> (exists hx':float, (FtoRradix hx'=hx) /\ (EvenClosest b' radix (t-s) x hx')). intros. cut (Fcanonic radix b (Fnormalize radix b t x)); [intros C|apply FnormalizeCanonic; auto with zarith]. case C; clear C; intros. generalize VeltkampEvenN; intros T. elim T with radix b s t (Fnormalize radix b t x) p q hx; auto. intros v T'; elim T'; intros ; clear T T'. rewrite FnormalizeCorrect in H5; auto. exists v; split; auto with zarith. rewrite FnormalizeCorrect; auto with real. rewrite FnormalizeCorrect; auto with real. generalize VeltkampEvenS; intros T. elim T with radix b s t (Fnormalize radix b t x) p q hx; auto; clear T. intros v T'; elim T'; intros ; clear T'. rewrite FnormalizeCorrect in H5; auto. exists v; split; auto with zarith. rewrite FnormalizeCorrect; auto with real. rewrite FnormalizeCorrect; auto with real. Qed. End VeltUlt. Section VeltTail. 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 bt2 := Bound (P_of_succ_nat (pred (Zabs_nat (Zpower_nat radix (minus s 1))))) (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. Theorem Veltkamp_tail_aux: forall x p q hx tx:float, (Fcanonic radix b x) -> (Closest b radix (x*((powerRZ radix s)+1))%R p) -> (Closest b radix (x-p)%R q) -> (Closest b radix (q+p)%R hx) -> (Closest b radix (x-hx)%R tx) -> (exists v:float, (FtoRradix v=hx) /\ (Fexp (Fminus radix x v) = Fexp x) /\ (Zabs (Fnum (Fminus radix x v)) <= (powerRZ radix s)/2)%R). intros. cut (Zpos (vNum b') = Zpower_nat radix (t - s));[intros I|idtac]. 2: unfold b'; apply p'GivesBound; auto with zarith. generalize Veltkamp; intros W. elim W with radix b s t x p q hx; auto. 2: apply FcanonicBound with radix; auto. intros C TT; elim TT; intros v' W'; elim W'; fold FtoRradix; fold b'; intros W1 T; elim T; intros W2 W3; clear W W' TT T. cut (exists v:float, (Fcanonic radix b' v) /\ (FtoRradix v=v')). 2: exists (Fnormalize radix b' (t-s) v'); unfold b'; elim W2; intros; split. 2:apply FnormalizeCanonic; auto with zarith. 2: simpl. 2: rewrite <- p'GivesBound with radix b s t; simpl; auto with zarith. 2: rewrite nat_of_P_o_P_of_succ_nat_eq_succ; auto with zarith. 2: unfold FtoRradix; apply FnormalizeCorrect; auto. intros W; elim W; intros v W'; elim W'; intros; clear W W'. exists v; split. rewrite H5; auto. cut (Rabs (x-v) <= (powerRZ radix (s+Fexp x)) /2)%R;[intros T1|idtac]. cut (Fexp (Fminus radix x v) = Fexp x);[intros T2|idtac]. split; auto. apply Rmult_le_reg_l with (powerRZ radix (Fexp x)); auto with real zarith. apply Rle_trans with (Rabs (x-v))%R;[right|idtac]. unfold FtoRradix; rewrite <- Fminus_correct; auto; rewrite <- Fabs_correct; auto. rewrite <- T2; unfold FtoR, Fabs; simpl; ring. apply Rle_trans with (1:= T1); rewrite powerRZ_add; auto with real zarith. unfold Rdiv; right; ring. unfold Fminus; simpl. apply Zmin_le1. case H; intros. apply Zle_trans with (Fexp (Float (nNormMin radix (t-s)) (Fexp x))); [simpl; auto with zarith|idtac]. apply Fcanonic_Rle_Zle with radix b' (t-s); auto with zarith. apply FcanonicNnormMin; auto with zarith. cut (Fbounded b x); [intros T; elim T; intros; unfold b'; simpl; auto with zarith| apply FcanonicBound with radix; auto]. rewrite Rabs_right. apply RoundAbsMonotonel with b' (t-s) (Closest b' radix) x; auto with zarith. apply ClosestRoundedModeP with (t-s); auto with zarith. apply FcanonicBound with radix; auto. apply FcanonicNnormMin; auto with zarith. elim H6; intros T2 T3; elim T2; intros; unfold b'; simpl; auto. apply ClosestCompatible with (1:=W2); auto. apply FcanonicBound with radix; auto. unfold FtoRradix; rewrite <- Fabs_correct; auto. unfold FtoR; simpl. apply Rmult_le_compat_r; auto with real zarith. elim H6; intros; apply Rle_IZR. apply Zmult_le_reg_r with radix; auto with zarith. apply Zle_trans with (Zabs (radix * Fnum x))%Z; [idtac|rewrite Zabs_Zmult; rewrite Zabs_eq; auto with zarith]. apply Zle_trans with (2:=H8). unfold nNormMin; rewrite pGivesBound. apply Zle_trans with (Zpower_nat radix (t-s)); auto with zarith. pattern (t-s) at 2; replace (t-s) with (pred (t-s)+1); auto with zarith. rewrite Zpower_nat_is_exp; unfold Zpower_nat; simpl; auto with zarith. ring_simplify (radix*1)%Z; auto with zarith. apply Rle_ge; apply LeFnumZERO; simpl; unfold nNormMin; auto with real zarith. cut (Fbounded b' v);[intros T; elim T; unfold b'; simpl; intros| apply FcanonicBound with radix; auto]. elim H6; auto with zarith. rewrite H5; rewrite W1;auto with real. Qed. Theorem Veltkamp_tail: forall x p q hx tx:float, (Fbounded b x) -> (Closest b radix (x*((powerRZ radix s)+1))%R p) -> (Closest b radix (x-p)%R q) -> (Closest b radix (q+p)%R hx) -> (Closest b radix (x-hx)%R tx) -> (exists tx':float, (FtoRradix tx'=tx) /\ (hx+tx'=x)%R /\ (Fbounded bt tx') /\ (Fexp (Fnormalize radix b t x) <= Fexp tx')%Z). intros. generalize Veltkamp_tail_aux; intros T. elim T with (Fnormalize radix b t x) p q hx tx; auto; clear T. intros v T; elim T; intros H4 T'; elim T'; intros H5 H6; clear T T'. 2: apply FnormalizeCanonic; auto with zarith. 2: unfold FtoRradix; rewrite FnormalizeCorrect; auto with real. 2: unfold FtoRradix; rewrite FnormalizeCorrect; auto with real. 2: unfold FtoRradix; rewrite FnormalizeCorrect; auto with real. exists (Fminus radix (Fnormalize radix b t x) v). split. unfold FtoRradix; apply RoundedModeProjectorIdemEq with b t (Closest b radix); auto with zarith. apply ClosestRoundedModeP with t; auto with zarith. split. apply Zlt_Rlt. apply Rle_lt_trans with (1:=H6); rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ. apply Rlt_le_trans with (powerRZ radix s*1)%R; [unfold Rdiv; apply Rmult_lt_compat_l; auto with real zarith| ring_simplify (powerRZ radix s*1)%R; apply Rle_powerRZ; auto with real zarith]. apply Rlt_le_trans with (/1)%R; auto with real. rewrite H5; cut (Fbounded b (Fnormalize radix b t x)); [intros T; elim T; auto|apply FnormalizeBounded; auto with zarith]. rewrite Fminus_correct; auto; rewrite FnormalizeCorrect; auto with real. fold FtoRradix; rewrite H4; auto. split. unfold FtoRradix; rewrite Fminus_correct; auto. rewrite FnormalizeCorrect; auto with real. fold FtoRradix; rewrite H4; ring. split. split. apply Zlt_le_trans with (Zpower_nat radix s). apply Zlt_Rlt. apply Rle_lt_trans with (1:=H6). rewrite Zpower_nat_Z_powerRZ; apply Rlt_le_trans with (powerRZ radix s*1)%R; auto with real. unfold Rdiv; apply Rmult_lt_compat_l; auto with real zarith. apply Rlt_le_trans with (/1)%R; auto with real. apply Zeq_le; apply sym_eq. 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. rewrite <- S_pred with (Zabs_nat (Zpower_nat radix (s))) 0; auto with zarith. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. cut ( 0 < Zabs_nat (Zpower_nat radix s))%Z; auto with zarith. simpl; rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. rewrite H5; unfold bt; simpl. cut (Fbounded b (Fnormalize radix b t x)); [intros T; elim T; auto|apply FnormalizeBounded; auto with zarith]. rewrite H5; auto with zarith. Qed. Theorem Veltkamp_tail2: forall x p q hx tx:float, (radix=2)%Z -> (Fbounded b x) -> (Closest b radix (x*((powerRZ radix s)+1))%R p) -> (Closest b radix (x-p)%R q) -> (Closest b radix (q+p)%R hx) -> (Closest b radix (x-hx)%R tx) -> (exists tx':float, (FtoRradix tx'=tx) /\ (hx+tx'=x)%R /\ (Fbounded bt2 tx') /\ (Fexp (Fnormalize radix b t x) <= Fexp tx')%Z). intros x p q hx tx I; intros. generalize Veltkamp_tail_aux; intros T. elim T with (Fnormalize radix b t x) p q hx tx; auto; clear T. intros v T; elim T; intros H4 T'; elim T'; intros H5 H6; clear T T'. 2: apply FnormalizeCanonic; auto with zarith. 2: unfold FtoRradix; rewrite FnormalizeCorrect; auto with real. 2: unfold FtoRradix; rewrite FnormalizeCorrect; auto with real. 2: unfold FtoRradix; rewrite FnormalizeCorrect; auto with real. generalize FboundedMbound2; intros T. elim T with bt2 radix (s-1) (Fexp (Fminus radix (Fnormalize radix b t x) v)) (Fnum (Fminus radix (Fnormalize radix b t x) v)); auto with zarith. clear T; intros c T'; elim T'; intros H7 T''; elim T''; intros H8 H9; clear T' T''. cut (FtoRradix c=x-hx)%R;[intros J|idtac]. exists c; split. unfold FtoRradix; apply RoundedModeProjectorIdemEq with b t (Closest b radix); auto with zarith. apply ClosestRoundedModeP with t; auto with zarith. elim H7; intros. split. apply Zlt_le_trans with (1:=H10); rewrite pGivesBound. unfold bt2; simpl; auto with zarith. apply Zle_trans with (Zpower_nat radix (s-1)); auto with zarith. apply Zeq_le. 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. rewrite <- S_pred with (Zabs_nat (Zpower_nat radix (s-1))) 0; auto with zarith. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. cut ( 0 < Zabs_nat (Zpower_nat radix (s-1)))%Z; auto with zarith. simpl; rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. generalize H11; unfold bt2; simpl; auto. fold FtoRradix; rewrite J; auto with real. split; [rewrite J; ring|split; auto]. rewrite <- H5; auto. apply trans_eq with (FtoRradix (Fminus radix (Fnormalize radix b t x) v)). unfold FtoRradix; rewrite H8; unfold FtoR; simpl; ring. unfold FtoRradix; rewrite Fminus_correct; auto; rewrite FnormalizeCorrect; auto; fold FtoRradix; rewrite H4; ring. unfold bt2; simpl. 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. rewrite <- S_pred with (Zabs_nat (Zpower_nat radix (s-1))) 0; auto with zarith. rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. cut ( 0 < Zabs_nat (Zpower_nat radix (s-1)))%Z; auto with zarith. simpl; rewrite <- Zabs_absolu; rewrite Zabs_eq; auto with zarith. apply Zle_Rle; clear T. apply Rle_trans with (1:=H6); rewrite Zpower_nat_Z_powerRZ. rewrite inj_minus1; auto with zarith. unfold Zminus; rewrite powerRZ_add; auto with real zarith. rewrite I; simpl; right; field. clear T; rewrite H5; unfold bt; simpl. cut (Fbounded b (Fnormalize radix b t x)); [intros T; elim T; auto|apply FnormalizeBounded; auto with zarith]. Qed. End VeltTail. Section VeltUtile. 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. Theorem VeltkampU: forall x p q hx tx:float, (Fcanonic radix b x) -> (Closest b radix (x*((powerRZ radix s)+1))%R p) -> (Closest b radix (x-p)%R q) -> (Closest b radix (q+p)%R hx) -> (Closest b radix (x-hx)%R tx) -> (Rabs (x-hx) <= (powerRZ radix (s+Fexp x)) /2)%R /\ (FtoRradix x=hx+tx)%R /\ (exists hx':float, (FtoRradix hx'=hx)%R /\ (Fbounded b' hx') /\ ((Fnormal radix b x) -> (s+Fexp x <= Fexp hx')%Z)) /\ (exists tx':float, (FtoRradix tx'=tx)%R /\ (Fbounded bt tx') /\ (Fexp x <= Fexp tx')%Z). intros. generalize Veltkamp; intros T. elim T with radix b s t x p q hx; auto. 2: apply FcanonicBound with radix; auto. clear T; intros H4 T; elim T; intros hx' T'; elim T'; intros H5 T''; clear T T'. elim T''; intros H6 H7; clear T''. generalize Veltkamp_tail; intros T. elim T with radix b s t x p q hx tx; auto. 2: apply FcanonicBound with radix; auto. clear T; intros tx' T'; elim T'; intros H8 T''; clear T'. elim T''; intros H9 T; elim T; intros H10 H11; clear T T''. split; auto. split; auto with real. unfold FtoRradix; rewrite <- H9; rewrite H8; auto with real. split. exists hx'; split; auto. split; auto. elim H6; auto with zarith. exists tx'. split; auto. split; auto. rewrite <- FcanonicFnormalizeEq with radix b t x; auto with zarith. Qed. End VeltUtile.Float8.4/Others/discriminant.v0000644000423700002640000022344412032774527016202 0ustar sboldotoccata(** This proof file has been written by #Sylvie Boldo#(1), following a proof presented by #Pr William Kahan# (2), and adapted to Coq proof checker with the help of #Guillaume Melquiond#(1) and #Marc Daumas#(1). This work has been partially supported by the #CNRS# grant PICS 2533. (1) #LIP# Computer science laboratory UMR 5668 CNRS - ENS de Lyon - INRIA Lyon, France (2) #University of California at Berkeley# Berkeley, California *) Require Export AllFloat. Section Discriminant1. Variable bo : Fbound. Variable precision : nat. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Theorem TwoMoreThanOne : (1 < radix)%Z. unfold radix in |- *; red in |- *; simpl in |- *; auto. Qed. Hint Resolve TwoMoreThanOne. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ TwoMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum bo) = Zpower_nat radix precision. Variables a b b' c p q d:float. Let delta := (Rabs (d-(b*b'-a*c)))%R. Hypothesis Fa : (Fbounded bo a). Hypothesis Fb : (Fbounded bo b). Hypothesis Fb': (Fbounded bo b'). Hypothesis Fc : (Fbounded bo c). Hypothesis Fp : (Fbounded bo p). Hypothesis Fq : (Fbounded bo q). Hypothesis Fd : (Fbounded bo d). (** There is no underflow *) Hypothesis U1:(- dExp bo <= Fexp d - 1)%Z. Hypothesis Nd:(Fnormal radix bo d). Hypothesis Nq:(Fnormal radix bo q). Hypothesis Np:(Fnormal radix bo p). Hypothesis Square:(0 <=b*b')%R. Hypothesis Roundp : (EvenClosest bo radix precision (b*b')%R p). Hypothesis Roundq : (EvenClosest bo radix precision (a*c)%R q). Hypothesis Firstcase : (p+q <= 3*(Rabs (p-q)))%R. Hypothesis Roundd : (EvenClosest bo radix precision (p-q)%R d). Theorem delta_inf: (delta <= (/2)*(Fulp bo radix precision d)+ ((/2)*(Fulp bo radix precision p)+(/2)*(Fulp bo radix precision q)))%R. unfold delta; rewrite <- Rabs_Ropp. replace (-(d - (b * b' - a * c)))%R with (((p-q)-d)+((b*b'-p)+-(a*c-q)))%R;[idtac|ring]. apply Rle_trans with ((Rabs ((p-q)-d))+(Rabs (b * b' - p + - (a * c - q))))%R; [apply Rabs_triang|idtac]. apply Rplus_le_compat. apply Rmult_le_reg_l with (S (S O)); auto with arith real. apply Rle_trans with (Fulp bo radix precision d). unfold FtoRradix; apply ClosestUlp;auto with zarith. elim Roundd; auto. right; simpl; field; auto with real. apply Rle_trans with ((Rabs (b*b'-p))+(Rabs (-(a*c-q))))%R; [apply Rabs_triang|idtac]. apply Rplus_le_compat. apply Rmult_le_reg_l with (S (S O)); auto with arith real. apply Rle_trans with (Fulp bo radix precision p). unfold FtoRradix; apply ClosestUlp;auto with zarith. elim Roundp; auto. right; simpl; field; auto with real. rewrite Rabs_Ropp; apply Rmult_le_reg_l with (S (S O)); auto with arith real. apply Rle_trans with (Fulp bo radix precision q). unfold FtoRradix; apply ClosestUlp;auto with zarith. elim Roundq; auto. right; simpl; field; auto with real. Qed. Theorem P_positive: (Rle 0 p)%R. unfold FtoRradix; apply RleRoundedR0 with (b:=bo) (precision:=precision) (P:=(Closest bo radix)) (r:=(b*b')%R); auto. apply ClosestRoundedModeP with precision; auto. elim Roundp; auto. Qed. Theorem Fulp_le_twice_l: forall x y:float, (0 <= x)%R -> (Fnormal radix bo x) -> (Fbounded bo y) -> (2*x<=y)%R -> (2*(Fulp bo radix precision x) <= (Fulp bo radix precision y))%R. intros. assert (2*x=(Float (Fnum x) (Zsucc (Fexp x))))%R. unfold FtoRradix, FtoR, Zsucc; simpl; rewrite powerRZ_add; auto with real zarith; simpl; ring. apply Rle_trans with (Fulp bo radix precision (Float (Fnum x) (Zsucc (Fexp x)))). right; rewrite CanonicFulp; auto; [rewrite CanonicFulp|left]; auto. unfold FtoR, Zsucc; simpl; rewrite powerRZ_add; auto with real zarith. simpl; ring. elim H0; intros H4 H5; elim H4; intros. left; split; auto. split; simpl; auto with zarith. apply LeFulpPos; auto with real. elim H0; intros H4 H5; elim H4; intros;split; simpl; auto with zarith. fold FtoRradix; rewrite <- H3; apply Rmult_le_pos; auto with real. fold FtoRradix; rewrite <- H3; auto with real. Qed. Theorem Fulp_le_twice_r: forall x y:float, (0 <= x)%R -> (Fnormal radix bo y) -> (Fbounded bo x) -> (x<=2*y)%R -> ((Fulp bo radix precision x) <= 2*(Fulp bo radix precision y))%R. intros. assert (2*y=(Float (Fnum y) (Zsucc (Fexp y))))%R. unfold FtoRradix, FtoR, Zsucc; simpl; rewrite powerRZ_add; auto with real zarith; simpl; ring. apply Rle_trans with (Fulp bo radix precision (Float (Fnum y) (Zsucc (Fexp y)))). 2:right; rewrite CanonicFulp; auto; [rewrite CanonicFulp|left]; auto. 2:unfold FtoR, Zsucc; simpl; rewrite powerRZ_add; auto with real zarith. 2:simpl; ring. 2:left; auto. 2:elim H0; intros H6 H5; elim H6; intros. 2:split; auto with zarith. 2:split; simpl; auto with zarith. apply LeFulpPos; auto with real. elim H0; intros H6 H5; elim H6; intros;split; simpl; auto with zarith. fold FtoRradix; rewrite <- H3; auto with real. Qed. Theorem Half_Closest_Round: forall (x:float) (r:R), (- dExp bo <= Zpred (Fexp x))%Z -> (Closest bo radix r x) -> (Closest bo radix (r/2)%R (Float (Fnum x) (Zpred (Fexp x)))). intros x r L H. assert (x/2=(Float (Fnum x) (Zpred (Fexp x))))%R. unfold FtoRradix, FtoR, Zpred; simpl; rewrite powerRZ_add; auto with real zarith; simpl; field. elim H; intros H2 H3. split; [split; simpl; auto with float zarith|idtac]. intros. fold FtoRradix; rewrite <- H0. replace (x/2-r/2)%R with (/2*(x-r))%R;[idtac|unfold Rdiv; ring]. rewrite Rabs_mult; rewrite Rabs_right; auto with real. 2: apply Rle_ge; auto with real. replace (f-r/2)%R with (/2*((Float (Fnum f) (Zsucc (Fexp f)))-r))%R. rewrite Rabs_mult; rewrite Rabs_right with (/2)%R. 2: apply Rle_ge; auto with real. apply Rmult_le_compat_l; auto with real. unfold FtoRradix; apply H3. split; simpl; auto with zarith float. unfold FtoRradix, FtoR, Zsucc; simpl; rewrite powerRZ_add; auto with real zarith; simpl; field; auto with real. Qed. Theorem Twice_EvenClosest_Round: forall (x:float) (r:R), (-(dExp bo) <= (Fexp x)-1)%Z -> (Fnormal radix bo x) -> (EvenClosest bo radix precision r x) -> (EvenClosest bo radix precision (2*r)%R (Float (Fnum x) (Zsucc (Fexp x)))). intros x r U Nx H. assert (x*2=(Float (Fnum x) (Zsucc (Fexp x))))%R. unfold FtoRradix, FtoR, Zsucc; simpl; rewrite powerRZ_add; auto with real zarith; simpl; ring. elim H; intros H2 H3; elim H2; intros H'1 H'2; split. split; [split; simpl; auto with float zarith|idtac]. intros. fold FtoRradix; rewrite <- H0. replace (x*2-2*r)%R with (2*(x-r))%R;[idtac|unfold Rdiv; ring]. rewrite Rabs_mult; rewrite Rabs_right; auto with real. 2: apply Rle_ge; auto with real. case (Zle_lt_or_eq (-(dExp bo))%Z (Fexp f)); auto with zarith float; intros L. replace (f-2*r)%R with (2*((Float (Fnum f) (Zpred (Fexp f)))-r))%R. rewrite Rabs_mult; rewrite Rabs_right with (2)%R. 2: apply Rle_ge; auto with real. apply Rmult_le_compat_l; auto with real. unfold FtoRradix; apply H'2. split; simpl; auto with zarith float. unfold FtoRradix, FtoR, Zpred; simpl; rewrite powerRZ_add; auto with real zarith; simpl; field; auto with real. replace (f-2*r)%R with (-((2*r)-f))%R;[rewrite Rabs_Ropp|ring]. apply Rle_trans with (2:=Rabs_triang_inv (2*r)%R f). rewrite Rabs_mult; rewrite (Rabs_right 2%R); try apply Rle_ge;auto with real. pattern r at 2 in |-*; replace r with (x-(x-r))%R;[idtac|ring]. apply Rle_trans with (2*(Rabs (x)-Rabs (x-r))-Rabs f)%R;[idtac|unfold Rminus; apply Rplus_le_compat_r; apply Rmult_le_compat_l; auto with real]. 2: generalize (Rabs_triang_inv x (x-r)%R); unfold Rminus; auto with real. apply Rplus_le_reg_l with (Rabs f -2*(Rabs (x-r)))%R. apply Rle_trans with (Rabs f);[right;ring|idtac]. apply Rle_trans with (2*(Rabs x)-4*Rabs (x-r))%R;[idtac|right;ring]. apply Rle_trans with (((powerRZ radix precision)-1)*(powerRZ radix ((Fexp x)-1)))%R. unfold FtoRradix; rewrite <- Fabs_correct; auto;unfold Fabs, FtoR; simpl. apply Rmult_le_compat; auto with real zarith. apply Rle_trans with (Zpred (Zpower_nat radix precision));[rewrite <- pGivesBound|idtac]. apply Rle_IZR;apply Zle_Zpred; auto with float. unfold Zpred; rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ; auto with real zarith. rewrite <- L; apply Rle_powerRZ; auto with real zarith. apply Rle_trans with (2*(powerRZ radix (Zpred precision))*(powerRZ radix (Fexp x))-2*(powerRZ radix (Fexp x)))%R. apply Rle_trans with (((powerRZ radix (precision+1))-4)*(powerRZ radix (Fexp x-1)))%R;[apply Rmult_le_compat_r; auto with real zarith|idtac]. rewrite powerRZ_add; auto with real zarith; simpl. apply Rplus_le_reg_l with (-(powerRZ 2 precision)+4)%R. ring_simplify. apply Rle_trans with (powerRZ 2 2)%R; auto with real zarith. simpl; ring_simplify (2*(2*1))%R; auto with real zarith. apply Rle_trans with (3+1)%R; auto with real; right; ring. apply Rle_powerRZ; auto with arith zarith real. replace (2*powerRZ radix (Fexp x))%R with (4*powerRZ radix (Fexp x -1))%R. pattern 2%R at 3 in |-*; replace 2%R with (powerRZ radix 1%Z);[idtac|simpl; ring]. repeat rewrite <- powerRZ_add; auto with real zarith. replace (1+Zpred precision+Fexp x)%Z with ((precision+1)+(Fexp x-1))%Z;[idtac|unfold Zpred; ring]. rewrite powerRZ_add with (n:=(precision+1)%Z);auto with real zarith; right;ring. unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl; field. unfold Rminus; apply Rplus_le_compat;[rewrite Rmult_assoc; apply Rmult_le_compat_l; auto with real|apply Ropp_le_contravar]. unfold FtoRradix; rewrite <- Fabs_correct; auto; unfold FtoR, Fabs; simpl. apply Rmult_le_compat_r; auto with real zarith. apply Rmult_le_reg_l with radix; auto with real zarith. pattern (IZR radix) at 1 in |-*; replace (IZR radix) with (powerRZ radix 1%Z);[idtac|simpl; ring]. rewrite <- powerRZ_add; auto with real zarith; elim Nx; intros. replace (1+Zpred precision)%Z with (Z_of_nat precision)%Z;[idtac|unfold Zpred; ring]. apply Rle_trans with (IZR (Zpos (vNum bo)));[rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; auto with real zarith|idtac]. apply Rle_trans with (IZR (Zabs (radix * Fnum x))); auto with real zarith. rewrite Zabs_Zmult; rewrite Zabs_eq; auto with real zarith. rewrite mult_IZR; auto with real. replace 4%R with (2*2%nat)%R; [rewrite Rmult_assoc; apply Rmult_le_compat_l; auto with real|simpl;ring]. replace (x+-r)%R with (-(r-x))%R;[rewrite Rabs_Ropp|ring]. apply Rle_trans with (Fulp bo radix precision x). unfold FtoRradix; apply ClosestUlp; auto. rewrite CanonicFulp; auto with real zarith. right; unfold FtoR; simpl; ring. left; auto. case H3; intros V. left; generalize V; unfold FNeven; rewrite FcanonicFnormalizeEq; auto with zarith. rewrite FcanonicFnormalizeEq; auto with zarith. elim Nx; intros; left; split; auto with zarith. elim H1; intros; split; simpl; auto with zarith. left; auto. right; intros. apply trans_eq with (2*(FtoR radix (Float (Fnum q0) (Zpred (Fexp q0)))))%R. unfold FtoR, Zpred; simpl; rewrite powerRZ_add; auto with real zarith; simpl; field; auto with real. apply trans_eq with (2*(FtoR radix x))%R;[idtac|unfold FtoR, Zsucc; simpl; rewrite powerRZ_add; auto with real zarith; simpl; ring]. apply Rmult_eq_compat_l; apply V. replace r with ((2*r)/2)%R;[idtac|field; auto with real]. apply Half_Closest_Round; auto. apply Zle_trans with (1:=U). fold (Zpred (Fexp x)); cut (Fexp x <= Fexp q0)%Z; auto with zarith. apply Zle_trans with (Fexp (Fnormalize radix bo precision q0)). apply Fcanonic_Rle_Zle with radix bo precision; auto with zarith. left; auto. apply FnormalizeCanonic; auto with arith. elim H1; auto. generalize ClosestMonotone; unfold MonotoneP; intros. repeat rewrite <- Fabs_correct; auto. apply H4 with bo (Rabs r) (Rabs (2*r))%R. rewrite Rabs_mult; rewrite (Rabs_right 2%R); try apply Rle_ge; auto with real. apply Rle_lt_trans with (1*Rabs r)%R;[right;ring|apply Rmult_lt_compat_r; auto with real]. apply Rabs_pos_lt;unfold not;intros. absurd (is_Fzero x). apply FnormalNotZero with radix bo ; auto. apply is_Fzero_rep2 with radix; auto. cut (0 <= FtoR radix x)%R; intros. cut (FtoR radix x <= 0)%R; intros; auto with real. apply RleRoundedLessR0 with bo precision (Closest bo radix) r; auto with real. apply ClosestRoundedModeP with precision; auto. apply RleRoundedR0 with bo precision (Closest bo radix) r; auto with real. apply ClosestRoundedModeP with precision; auto. apply ClosestFabs with precision; auto. apply ClosestFabs with precision; auto. generalize ClosestCompatible; unfold CompatibleP; intros T. apply T with (2*r)%R q0; auto with real float zarith. apply sym_eq;apply FnormalizeCorrect; auto. apply FnormalizeBounded; auto with zarith. elim H1; auto. apply FcanonicLeastExp with radix bo precision; auto with zarith float. apply sym_eq; apply FnormalizeCorrect; auto. elim H1; auto. apply FnormalizeCanonic; auto with zarith;elim H1; auto. Qed. Theorem EvenClosestMonotone2: forall (p q : R) (p' q' : float), (p <= q)%R -> (EvenClosest bo radix precision p p') -> (EvenClosest bo radix precision q q') -> (p' <= q')%R. intros. case H; intros H2. generalize EvenClosestMonotone; unfold MonotoneP. intros W; unfold FtoRradix. apply W with bo precision p0 q0; auto. generalize EvenClosestUniqueP; unfold UniqueP. intros W; unfold FtoRradix. right; apply W with bo precision p0; auto with real. rewrite H2; auto. Qed. Theorem Fulp_le_twice_r_round: forall (x y:float) (r:R), (0 <= x)%R -> (Fbounded bo x) -> (Fnormal radix bo y) -> (- dExp bo <= Fexp y - 1)%Z -> (x<=2*r)%R -> (EvenClosest bo radix precision r y) -> ((Fulp bo radix precision x) <= 2*(Fulp bo radix precision y))%R. intros x y r H H0 H1 U H2 H3. assert (2*y=(Float (Fnum y) (Zsucc (Fexp y))))%R. unfold FtoRradix, FtoR, Zsucc; simpl; rewrite powerRZ_add; auto with real zarith; simpl; ring. apply Rle_trans with (Fulp bo radix precision (Float (Fnum y) (Zsucc (Fexp y)))). 2:right; rewrite CanonicFulp; auto; [rewrite CanonicFulp|left]; auto. 2:unfold FtoR, Zsucc; simpl; rewrite powerRZ_add; auto with real zarith. 2:simpl; ring. 2:left; auto. 2:elim H1; intros H6 H5; elim H6; intros. 2:split; simpl; auto with zarith. 2:split; simpl; auto with zarith. apply LeFulpPos; auto with real. elim H1; intros H6 H5; elim H6; intros;split; simpl; auto with zarith. apply EvenClosestMonotone2 with x (2*r)%R; auto. unfold FtoRradix; apply RoundedModeProjectorIdem with (b:=bo) (P:=(EvenClosest bo radix precision)); auto. apply EvenClosestRoundedModeP; auto. apply Twice_EvenClosest_Round; auto. Qed. Theorem discri1: (delta <= 2*(Fulp bo radix precision d))%R. apply Rle_trans with (1:=delta_inf). case (Rle_or_lt q p); intros H1. case (Rle_or_lt 0%R q); intros H2. cut (2*(Fulp bo radix precision q)<=(Fulp bo radix precision p))%R; try intros H3. cut ((Fulp bo radix precision p)<=2*(Fulp bo radix precision d))%R; try intros H4. apply Rle_trans with ((/ 2 * Fulp bo radix precision d + (/ 2 * (2*Fulp bo radix precision d) + / 2 * Fulp bo radix precision d)))%R. apply Rplus_le_compat; auto with real. apply Rplus_le_compat; auto with real. apply Rmult_le_compat_l; auto with real. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (1:=H3); auto with real. right; field; auto with real. apply Fulp_le_twice_r_round with (p-q)%R; auto. apply P_positive. apply Rplus_le_reg_l with (2*q-p)%R. ring_simplify. apply Rmult_le_reg_l with 2%R; auto with real. apply Rplus_le_reg_l with (p-3*q)%R. ring_simplify. apply Rle_trans with (1:=Firstcase); rewrite Rabs_right. right; ring. apply Rle_ge; apply Rplus_le_reg_l with q; ring_simplify; auto with real. apply Fulp_le_twice_l; auto. apply Rmult_le_reg_l with 2%R; auto with real. apply Rplus_le_reg_l with (p-3*q)%R. ring_simplify. apply Rle_trans with (1:=Firstcase); rewrite Rabs_right. right; ring. apply Rle_ge; apply Rplus_le_reg_l with q; ring_simplify; auto with real. apply Rle_trans with ((/ 2 * Fulp bo radix precision d + (/ 2 * (Fulp bo radix precision d) + / 2 * Fulp bo radix precision d)))%R. apply Rplus_le_compat; auto with real. apply Rplus_le_compat; auto with real. apply Rmult_le_compat; auto with real. unfold Fulp; auto with real zarith. apply LeFulpPos; auto with real. fold FtoRradix; apply P_positive. fold FtoRradix; apply EvenClosestMonotone2 with p (p-q)%R; auto. apply Rle_trans with (p-0)%R; unfold Rminus; auto with real; right;ring. unfold FtoRradix; apply RoundedModeProjectorIdem with (b:=bo) (P:=(EvenClosest bo radix precision)); auto. apply EvenClosestRoundedModeP; auto. apply Rmult_le_compat; auto with real. unfold Fulp; auto with real zarith. rewrite FulpFabs; auto. apply LeFulpPos; auto with real. split; auto with zarith float. rewrite Fabs_correct; auto with real. fold FtoRradix; apply EvenClosestMonotone2 with (-q)%R (p-q)%R; auto. generalize P_positive; intros; auto with real. apply Rle_trans with (0-q)%R; unfold Rminus; auto with real; right;ring. replace (-q)%R with (FtoRradix (Fabs q)). unfold FtoRradix; apply RoundedModeProjectorIdem with (b:=bo) (P:=(EvenClosest bo radix precision)); auto. apply EvenClosestRoundedModeP; auto. split; auto with zarith float. unfold FtoRradix;rewrite Fabs_correct; auto with real; rewrite Rabs_left; auto with real. apply Rle_trans with ((3*/2)*(Fulp bo radix precision d))%R. right; field; auto with real. apply Rmult_le_compat_r;auto with zarith real. unfold Fulp; auto with zarith real. apply Rmult_le_reg_l with 2%R;auto with real. apply Rle_trans with 3%R; auto with real. right; field; auto with real. replace 3%R with (IZR 3); auto with real zarith. replace 4%R with (IZR 4); auto with real zarith. simpl; ring. simpl; ring. cut (2*(Fulp bo radix precision p)<=(Fulp bo radix precision q))%R; try intros H3. cut ((Fulp bo radix precision q)<=2*(Fulp bo radix precision d))%R; try intros H4. apply Rle_trans with ((/ 2 * Fulp bo radix precision d + (/ 2 * (Fulp bo radix precision d) + / 2 * (2*Fulp bo radix precision d))))%R. apply Rplus_le_compat; auto with real. apply Rplus_le_compat; auto with real. apply Rmult_le_compat_l; auto with real. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (1:=H3); auto with real. right; field; auto with real. assert (p-q <=0)%R. apply Rplus_le_reg_l with q. ring_simplify; auto with real. rewrite FulpFabs with bo radix precision d; auto. apply Fulp_le_twice_r_round with (Rabs (p-q))%R; auto. apply Rle_trans with p; auto with real; apply P_positive. apply FnormalFabs; auto. rewrite Rabs_left; auto with real. apply Rmult_le_reg_l with 2%R; auto with real. apply Rplus_le_reg_l with (p-q)%R. ring_simplify. apply Rle_trans with (1:=Firstcase); rewrite Rabs_left1; auto. right; ring. generalize EvenClosestSymmetric; unfold SymmetricP; intros. rewrite Rabsolu_left1; auto with real. replace (Fabs d) with (Fopp d). apply H0; auto. unfold Fabs, Fopp; replace (Zabs (Fnum d)) with (-(Fnum d))%Z; auto. rewrite <- Zabs_Zopp; rewrite Zabs_eq; auto with zarith. cut (Fnum d <= 0)%Z; auto with zarith. apply R0LeFnum with radix; auto. apply RleRoundedLessR0 with bo precision (EvenClosest bo radix precision) (p-q)%R; auto with real zarith. apply EvenClosestRoundedModeP; auto. apply Fulp_le_twice_l; auto. apply P_positive. apply Rmult_le_reg_l with 2%R; auto with real. apply Rplus_le_reg_l with (-3*p+q)%R. ring_simplify. apply Rle_trans with (1:=Firstcase); rewrite Rabs_left1; auto. right; ring. apply Rplus_le_reg_l with q. ring_simplify; auto with real. Qed. End Discriminant1. Section Discriminant2. Variable bo : Fbound. Variable precision : nat. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ TwoMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum bo) = Zpower_nat radix precision. Variables a b b' c p q t dp dq s d:float. Let delta := (Rabs (d-(b*b'-a*c)))%R. Hypothesis Fa : (Fbounded bo a). Hypothesis Fb : (Fbounded bo b). Hypothesis Fb': (Fbounded bo b'). Hypothesis Fc : (Fbounded bo c). Hypothesis Fp : (Fbounded bo p). Hypothesis Fq : (Fbounded bo q). Hypothesis Fd : (Fbounded bo d). Hypothesis Ft : (Fbounded bo t). Hypothesis Fs : (Fbounded bo s). Hypothesis Fdp: (Fbounded bo dp). Hypothesis Fdq: (Fbounded bo dq). (** There is no underflow *) Hypothesis U1: (- dExp bo <= (Fexp t)-1)%Z. Hypothesis U2: (- dExp bo <= Fexp a + Fexp c - precision)%Z. Hypothesis U3: (- dExp bo <= Fexp q - precision)%Z. Hypothesis U4: (- dExp bo <= Fexp b + Fexp b' - precision)%Z. Hypothesis U5: (- dExp bo <= Fexp p - precision)%Z. Hypothesis Np:(Fnormal radix bo p). Hypothesis Nq:(Fnormal radix bo q). Hypothesis Ns:(Fnormal radix bo s). Hypothesis Nd:(Fnormal radix bo d). Hypothesis Square:(0 <=b*b')%R. Hypothesis Roundp : (EvenClosest bo radix precision (b*b')%R p). Hypothesis Roundq : (EvenClosest bo radix precision (a*c)%R q). Hypothesis Secondcase : (3*(Rabs (p-q)) < p+q)%R. Hypothesis Roundt : (EvenClosest bo radix precision (p-q)%R t). Hypothesis dpEq : (FtoRradix dp=b*b'-p)%R. Hypothesis dqEq : (FtoRradix dq=a*c-q)%R. Hypothesis Rounds : (EvenClosest bo radix precision (dp-dq)%R s). Hypothesis Roundd : (EvenClosest bo radix precision (t+s)%R d). Hypothesis p_differ_q:~(p=q)%R. Theorem Q_positive:(0 < q)%R. case (Rle_or_lt q 0%R); auto; intros. absurd (3*(Rabs (p-q)) < (Rabs (p-q)))%R. apply Rle_not_lt; apply Rle_trans with (1*(Rabs (p-q)))%R; auto with real. apply Rmult_le_compat_r; auto with real. apply Rle_trans with (IZR 1); auto with real. apply Rle_trans with (IZR 3); auto with real zarith. simpl; auto with real zarith. apply Rlt_le_trans with (1:=Secondcase). apply Rle_trans with (2:=Rabs_triang_inv p q). right; rewrite Rabs_right. rewrite Rabs_left1; auto with real; ring. apply Rle_ge; apply P_positive with bo precision b b'; auto. Qed. Theorem Q_le_two_P:(q <= 2*p)%R. fold FtoRradix; apply Rmult_le_reg_l with 2%R; auto with real; simpl. apply Rle_trans with (3*q-q)%R; [right; ring|idtac]. pattern (FtoRradix q) at 1; rewrite <- (Rabs_right q). 2: apply Rle_ge; generalize Q_positive; auto with real. pattern (FtoRradix q) at 1; replace (FtoRradix q) with (-(p-q)+p)%R;[idtac|ring]. apply Rle_trans with (3*(Rabs (-(p-q))+(Rabs p))-q)%R. unfold Rminus; apply Rplus_le_compat_r. apply Rmult_le_compat_l; auto with real. apply Rle_trans with 2%R; auto with real. apply Rabs_triang. rewrite Rabs_Ropp. rewrite (Rabs_right p). 2:apply Rle_ge; apply P_positive with bo precision b b'; auto. apply Rle_trans with (3 * (Rabs (p - q)) + (3*p - q))%R;[right;ring|idtac]. apply Rle_trans with (p+q+(3*p-q))%R; auto with real. right;ring. Qed. Theorem P_le_two_Q:(p <= 2*q)%R. fold FtoRradix; apply Rmult_le_reg_l with 2%R; auto with real; simpl. apply Rle_trans with (3*p-p)%R; [right; ring|idtac]. pattern (FtoRradix p) at 1; rewrite <- (Rabs_right p). 2: apply Rle_ge; apply P_positive with bo precision b b'; auto with real. pattern (FtoRradix p) at 1; replace (FtoRradix p) with ((p-q)+q)%R;[idtac|ring]. apply Rle_trans with (3*(Rabs (p-q)+(Rabs q))-p)%R. unfold Rminus; apply Rplus_le_compat_r. apply Rmult_le_compat_l; auto with real. apply Rle_trans with 2%R; auto with real. apply Rabs_triang. rewrite (Rabs_right q). 2: apply Rle_ge; generalize Q_positive; auto with real. apply Rle_trans with (3 * (Rabs (p - q)) + (3*q - p))%R;[right;ring|idtac]. apply Rle_trans with (p+q+(3*q-p))%R; auto with real. right;ring. Qed. Theorem t_exact: (FtoRradix t=p-q)%R. unfold FtoRradix; rewrite <- Fminus_correct; auto with zarith. apply sym_eq; apply RoundedModeProjectorIdemEq with (b:=bo) (P:=(EvenClosest bo radix precision)) (precision:=precision); auto. apply EvenClosestRoundedModeP; auto. 2: rewrite Fminus_correct; auto with zarith. apply Sterbenz; auto. fold FtoRradix; apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (FtoRradix q);[simpl; right; field; auto with real|idtac]. apply Q_le_two_P. fold FtoRradix; simpl; apply P_le_two_Q. Qed. Theorem dp_dq_le:(Rabs (dp-dq) <= (3/2)*(Rmin (Fulp bo radix precision p) (Fulp bo radix precision q)))%R. unfold Rminus; apply Rle_trans with (1:=Rabs_triang dp (-dq)). rewrite Rabs_Ropp;apply Rmult_le_reg_l with (S (S O))%R; auto with real. apply Rle_trans with (S 1 * Rabs dp + S 1*Rabs dq)%R;[right;ring|idtac]. apply Rle_trans with ((Fulp bo radix precision p)+(Fulp bo radix precision q))%R. apply Rplus_le_compat. rewrite dpEq; unfold FtoRradix; apply ClosestUlp; auto. elim Roundp; auto. rewrite dqEq; unfold FtoRradix; apply ClosestUlp; auto. elim Roundq; auto. rewrite <- Rmult_assoc. apply Rle_trans with (3*(Rmin (Fulp bo radix precision p) (Fulp bo radix precision q)))%R;[idtac|apply Rmult_le_compat_r]. 2: unfold Rmin; case (Rle_dec (Fulp bo radix precision p) (Fulp bo radix precision q)); intros H1; unfold Fulp; auto with real zarith. 2: right; simpl; unfold Rdiv; field; auto with real. unfold Rmin; case (Rle_dec (Fulp bo radix precision p) (Fulp bo radix precision q)); intros H1. apply Rle_trans with (Fulp bo radix precision p+2*Fulp bo radix precision p)%R;[apply Rplus_le_compat_l|right;ring]. apply Fulp_le_twice_r; auto with real; fold radix FtoRradix. generalize Q_positive; auto with real. apply Q_le_two_P. apply Rle_trans with (2*Fulp bo radix precision q+Fulp bo radix precision q)%R;[apply Rplus_le_compat_r|right;ring]. apply Fulp_le_twice_r; auto with real; fold radix FtoRradix. apply P_positive with bo precision b b'; auto with real. apply P_le_two_Q. Qed. Theorem EvenClosestFabs : forall (f : float) (r : R), (Fcanonic radix bo f) -> EvenClosest bo radix precision r f -> EvenClosest bo radix precision (Rabs r) (Fabs f). intros. case (Rle_or_lt 0%R r); intros. rewrite Rabs_right; auto with real. unfold Fabs; rewrite Zabs_eq; auto with zarith. apply LeR0Fnum with (radix := radix); auto with zarith. apply RleRoundedR0 with bo precision (EvenClosest bo radix precision) r; auto with float zarith. rewrite Rabs_left; auto with real. replace (Fabs f) with (Fopp f). generalize EvenClosestSymmetric; unfold SymmetricP; auto. unfold Fabs, Fopp; rewrite <- Zabs_Zopp; rewrite Zabs_eq; auto. assert (Fnum f <= 0)%Z; auto with zarith. apply R0LeFnum with (radix:=radix); auto with zarith. apply RleRoundedLessR0 with bo precision (EvenClosest bo radix precision) r; auto with float zarith real. Qed. Theorem discri2: (3*(Rmin (Fulp bo radix precision p) (Fulp bo radix precision q)) <= (Rabs (p-q)))%R -> (delta <= 2*(Fulp bo radix precision d))%R. intros H1; unfold delta. apply Rle_trans with (1 * Fulp bo radix precision d)%R;[ring_simplify (1 * Fulp bo radix precision d)%R | unfold Fulp; auto with real zarith]. replace (d - (b * b' - a * c))%R with ((d-(t+s))+(t+s-b*b'+a*c))%R;[idtac|ring]. apply Rle_trans with (1:=Rabs_triang (d-(t+s))%R (t + s - b * b' + a * c)%R). apply Rmult_le_reg_l with 2%R; auto with real. rewrite Rmult_plus_distr_l. apply Rle_trans with (Fulp bo radix precision d+Fulp bo radix precision d)%R;[idtac|right;ring]. apply Rplus_le_compat. rewrite <- Rabs_Ropp; replace (- (d - (t + s)))%R with ((t+s)-d)%R;[idtac|ring]. replace 2%R with (INR 2); auto with real. unfold FtoRradix; apply ClosestUlp; auto. elim Roundd; auto. rewrite t_exact. replace (p - q + s - b * b' + a * c)%R with (-((dp-dq) - s))%R;[idtac|rewrite dpEq; rewrite dqEq; ring]. rewrite Rabs_Ropp; apply Rle_trans with (Fulp bo radix precision s). unfold FtoRradix; apply ClosestUlp; auto. elim Rounds; auto. rewrite FulpFabs; auto; rewrite FulpFabs with (f:=d); auto. apply LeFulpPos; auto with real zarith float. rewrite Fabs_correct; auto with real. apply EvenClosestMonotone2 with bo precision (Rabs (dp-dq)) (Rabs (t+s))%R; auto. 2: apply EvenClosestFabs; auto; left; auto. 2: apply EvenClosestFabs; auto; left; auto. cut (Rabs (dp - dq) <= (Rabs (p-q))/2)%R. intros H2; cut ((Rabs s) <= (Rabs t)/2)%R. intros H3; apply Rle_trans with (1:=H2). rewrite <- t_exact; apply Rle_trans with ((Rabs t)-(Rabs t)/2)%R. right; unfold Rdiv; field; auto with real. apply Rle_trans with ((Rabs t)-(Rabs s))%R; auto with real. unfold Rminus; apply Rplus_le_compat_l; auto with real. replace (t+s)%R with (t-(-s))%R; [idtac|ring]. apply Rle_trans with ((Rabs t)-(Rabs (-s)))%R;[idtac|apply Rabs_triang_inv]. rewrite Rabs_Ropp; auto with real. assert (t/2=(Float (Fnum t) (Zpred (Fexp t))))%R. unfold FtoRradix, FtoR, Zpred; simpl; rewrite powerRZ_add; auto with real zarith; simpl ; field. unfold Rdiv; rewrite <- (Rabs_right (/2)%R); auto with real. 2: apply Rle_ge; apply Rlt_le; auto with real. rewrite <- Rabs_mult; fold (Rdiv t 2%R). rewrite H; unfold FtoRradix; rewrite <- Fabs_correct; auto. rewrite <- Fabs_correct; auto. apply EvenClosestMonotone2 with bo precision (Rabs (dp-dq))%R (Rabs (p-q)/2)%R; auto. apply EvenClosestFabs; auto; left; auto. replace (Rabs (p - q) / 2)%R with (FtoRradix (Fabs (Float (Fnum t) (Zpred (Fexp t))))). unfold FtoRradix; apply RoundedModeProjectorIdem with (b:=bo) (P:=(EvenClosest bo radix precision)); auto. apply EvenClosestRoundedModeP; auto. split; simpl; auto with zarith float. rewrite Zabs_eq; auto with zarith float. unfold FtoRradix; rewrite Fabs_correct; auto; fold FtoRradix; rewrite <- H. rewrite t_exact; unfold Rdiv; rewrite Rabs_mult; auto with real. rewrite (Rabs_right (/2)%R); auto with real. apply Rle_ge; apply Rlt_le; auto with real. apply Rle_trans with (1:=dp_dq_le). apply Rmult_le_reg_l with 2%R; auto with real; unfold Rdiv. rewrite <- Rmult_assoc. replace (2*(3*/2))%R with 3%R;[idtac|field; auto with real]. apply Rle_trans with (1:=H1). right; field; auto with real. Qed. Theorem discri3: (exists f:float, (Fbounded bo f) /\ (FtoRradix f)=(dp-dq)%R) -> (delta <= 2*(Fulp bo radix precision d))%R. intros T; elim T; intros f T1; elim T1; intros H1 H2; clear T T1. unfold delta. replace (d - (b * b' - a * c))%R with (-((t+s)-d))%R. apply Rmult_le_reg_l with (INR 2); auto with arith real. apply Rle_trans with (Fulp bo radix precision d). rewrite Rabs_Ropp; unfold FtoRradix; apply ClosestUlp; auto. elim Roundd; auto. simpl; apply Rle_trans with (1*(1*(Fulp bo radix precision d)))%R; unfold Fulp; auto with real zarith. right; ring. apply Rmult_le_compat; auto with real zarith. ring_simplify (1 * powerRZ radix (Fexp (Fnormalize radix bo precision d)))%R; auto with real zarith. replace (FtoRradix s) with (dp-dq)%R. rewrite dpEq; rewrite dqEq; rewrite t_exact; ring. rewrite <- H2. unfold FtoRradix; apply RoundedModeProjectorIdemEq with (b:=bo) (P:=(EvenClosest bo radix precision)) (precision:=precision); auto with real. apply EvenClosestRoundedModeP; auto. fold FtoRradix; rewrite H2; auto. Qed. Theorem errorBoundedMultClosest_Can: forall f1 f2 g : float, Fbounded bo f1 -> Fbounded bo f2 -> Closest bo radix (f1* f2) g -> (- dExp bo <= Fexp f1 + Fexp f2 - precision)%Z -> (- dExp bo <= Fexp g - precision)%Z -> Fcanonic radix bo g -> (exists s : float, Fbounded bo s /\ (FtoRradix s = f1*f2 - g)%R /\ Fexp s = (Fexp g - precision)%Z /\ (Rabs (Fnum s) <= powerRZ radix (Zpred precision))%R). intros. generalize errorBoundedMultClosest; intros T. elim T with (b:=bo) (radix:=radix) (precision:=precision) (p:=f1) (q:=f2) (pq:=g); auto with zarith real; clear T; fold FtoRradix. intros g' T1; elim T1; intros dg T2; elim T2; intros H5 T3; elim T3; intros H6 T4; elim T4; intros H7 T5; elim T5; intros H8 T6; elim T6; intros H9 H10; clear T1 T2 T3 T4 T5 T6. exists dg; split; auto; split. rewrite <- H8; auto with real. split; [replace g with g'; auto with zarith|idtac]. apply FcanonicUnique with radix bo precision; auto with arith. apply Rmult_le_reg_l with (powerRZ radix (Fexp dg)); auto with zarith real. apply Rle_trans with (Rabs dg);[right; unfold FtoRradix, FtoR|idtac]. rewrite Rabs_mult;rewrite (Rabs_right (powerRZ radix (Fexp dg)));auto with real. apply Rle_ge; auto with real zarith. rewrite H9; rewrite <- powerRZ_add; auto with real zarith. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix precision g'). unfold FtoRradix; apply ClosestUlp; auto. replace g' with g; auto. apply FcanonicUnique with radix bo precision; auto with arith. rewrite CanonicFulp; auto. right; apply trans_eq with (powerRZ radix (Fexp g'));[unfold FtoR; simpl; ring|idtac]. apply trans_eq with ((powerRZ radix 1%Z)*(powerRZ radix (Fexp dg+Zpred precision)))%R;[rewrite <- powerRZ_add; auto with zarith real|simpl; ring]. rewrite H10; unfold Zpred; auto with zarith real. ring_simplify (1 + (Fexp g' - precision + (precision + -1)))%Z; auto with real. rewrite FcanonicFnormalizeEq; auto with zarith. Qed. Theorem discri4: (Fexp p)=(Fexp q) -> (delta <= 2*(Fulp bo radix precision d))%R. intros H1; apply discri3. generalize errorBoundedMultClosest_Can; intros T. elim T with (f1:=b) (f2:=b') (g:=p); auto with zarith real; clear T. intros dp' T2; elim T2; intros H2 T3; elim T3; intros H3 T4; elim T4; intros H4 H5; clear T2 T3 T4. 2: elim Roundp; auto. generalize errorBoundedMultClosest_Can; intros T. elim T with (f1:=a) (f2:=c) (g:=q); auto with zarith real; clear T. intros dq' T2; elim T2; intros H2' T3; elim T3; intros H3' T4; elim T4; intros H4' H5'; clear T2 T3 T4. 2: elim Roundq; auto. 2: left; auto. 2: left; auto. assert ((Rabs (Fnum dp'-Fnum dq') < (powerRZ radix precision))%R \/ (((Rabs dp')= (powerRZ radix (Zpred (Fexp p))))%R /\ ((Rabs dq')= (powerRZ radix (Zpred (Fexp p))))%R)). case H5; intros. left; unfold Rminus; apply Rle_lt_trans with (1:=Rabs_triang (Fnum dp') (-(Fnum dq'))%R). rewrite Rabs_Ropp. apply Rlt_le_trans with ((powerRZ radix (Zpred precision)) +(Rabs (Fnum dq')))%R; auto with real zarith. apply Rle_trans with ((powerRZ radix (Zpred precision))+ (powerRZ radix (Zpred precision)))%R; auto with real zarith. right; unfold Zpred; repeat rewrite powerRZ_add; auto with real zarith. simpl; field. case H5'; intros. left; unfold Rminus; apply Rle_lt_trans with (1:=Rabs_triang (Fnum dp') (-(Fnum dq'))%R); rewrite Rabs_Ropp. apply Rle_lt_trans with ((powerRZ radix (Zpred precision)) +(Rabs (Fnum dq')))%R; auto with real zarith. apply Rlt_le_trans with ((powerRZ radix (Zpred precision))+ (powerRZ radix (Zpred precision)))%R; auto with real zarith. right; unfold Zpred; repeat rewrite powerRZ_add; auto with real zarith. simpl; field. right; unfold FtoRradix, FtoR;repeat rewrite Rabs_mult. rewrite (Rabs_right (powerRZ radix (Fexp dp'))); try apply Rle_ge; auto with real zarith. rewrite (Rabs_right (powerRZ radix (Fexp dq'))); try apply Rle_ge; auto with real zarith. rewrite H; rewrite H0. repeat rewrite <- powerRZ_add; auto with real zarith. rewrite H4'; rewrite H4; unfold Zpred. ring_simplify (precision + -1 + (Fexp p - precision))%Z; ring_simplify (precision + -1 + (Fexp q - precision))%Z; ring_simplify (Fexp p+-1)%Z; rewrite <- H1; auto with zarith real. case H; clear H; intros H. exists (Float ((Fnum dp')-(Fnum dq'))%Z (Fexp dq')). split; [split; auto with zarith|idtac]. simpl; apply Zlt_Rlt. rewrite pGivesBound;rewrite Zpower_nat_Z_powerRZ; auto. rewrite <- Rabs_Zabs; unfold Zminus; rewrite plus_IZR; rewrite Ropp_Ropp_IZR; auto with real zarith. simpl; auto with zarith float. rewrite dpEq; rewrite dqEq; rewrite <- H3; rewrite <- H3'. unfold FtoRradix, FtoR; simpl. unfold Zminus; rewrite plus_IZR; rewrite Ropp_Ropp_IZR; replace (Fexp dp') with (Fexp dq');[ring|idtac]. rewrite H4'; rewrite <- H1; auto with zarith. rewrite dpEq; rewrite dqEq; rewrite <- H3; rewrite <- H3'. elim H; unfold Rabs; case (Rcase_abs dp'); case (Rcase_abs dq'); intros. exists (Float 0%Z 0%Z); split;[split; auto with zarith|idtac]. simpl; case (dExp bo); auto with zarith. apply trans_eq with (-(-dp')+-dq')%R;[rewrite H0; rewrite H6; unfold FtoRradix, FtoR;simpl|idtac];ring. exists (Float (-2)%Z (Zpred (Fexp p))); split;[split; simpl; auto with zarith|idtac]. rewrite pGivesBound; apply Zle_lt_trans with (Zpower_nat radix 1); auto with zarith. apply trans_eq with (-(-dp')+-dq')%R;[rewrite H0; rewrite H6; unfold FtoRradix, FtoR; simpl|idtac];ring. exists (Float 2%Z (Zpred (Fexp p))); split;[split;simpl;auto with zarith|idtac]. rewrite pGivesBound; apply Zle_lt_trans with (Zpower_nat radix 1); auto with zarith. unfold Rminus;rewrite H0; rewrite H6; unfold FtoRradix, FtoR;simpl; ring. exists (Float 0%Z 0%Z); split;[split; auto with zarith|idtac]. simpl; case (dExp bo); auto with zarith. rewrite H0; rewrite H6; unfold FtoRradix, FtoR; simpl;ring. Qed. End Discriminant2. Section Discriminant3. Variable bo : Fbound. Variable precision : nat. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ TwoMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum bo) = Zpower_nat radix precision. Variables a b b' c p q t dp dq s d:float. Let delta := (Rabs (d-(b*b'-a*c)))%R. Hypothesis Fa : (Fbounded bo a). Hypothesis Fb : (Fbounded bo b). Hypothesis Fb': (Fbounded bo b'). Hypothesis Fc : (Fbounded bo c). Hypothesis Fp : (Fbounded bo p). Hypothesis Fq : (Fbounded bo q). Hypothesis Fd : (Fbounded bo d). Hypothesis Ft : (Fbounded bo t). Hypothesis Fs : (Fbounded bo s). Hypothesis Fdp: (Fbounded bo dp). Hypothesis Fdq: (Fbounded bo dq). (** There is no underflow *) Hypothesis U1: (- dExp bo <= Fexp p - precision)%Z. Hypothesis U2: (- dExp bo <= Fexp a + Fexp c - precision)%Z. Hypothesis U3: (- dExp bo <= Fexp q - precision)%Z. Hypothesis U4: (- dExp bo <= Fexp b + Fexp b' - precision)%Z. Hypothesis U5: (- dExp bo <= (Fexp d)-1)%Z. Hypothesis Np:(Fnormal radix bo p). Hypothesis Nq:(Fnormal radix bo q). Hypothesis Ns:(Fnormal radix bo s). Hypothesis Nd:(Fnormal radix bo d). Hypothesis Square:(0 <=b*b')%R. Hypothesis Roundp : (EvenClosest bo radix precision (b*b')%R p). Hypothesis Roundq : (EvenClosest bo radix precision (a*c)%R q). Hypothesis p_pos:(0 <= p)%R. Hypothesis q_pos:(0 <= q)%R. Hypothesis Secondcase : (3*(Rabs (p-q)) < p+q)%R. Hypothesis Roundt : (EvenClosest bo radix precision (p-q)%R t). Hypothesis dpEq : (FtoRradix dp=b*b'-p)%R. Hypothesis dqEq : (FtoRradix dq=a*c-q)%R. Hypothesis Rounds : (EvenClosest bo radix precision (dp-dq)%R s). Hypothesis Roundd : (EvenClosest bo radix precision (t+s)%R d). Hypothesis p_differ_q:~(p=q)%R. Variable e:Z. Hypothesis p_eqF : p=(Float (Zpower_nat radix (pred precision)) (Zsucc e)). Hypothesis p_eqR : (FtoRradix p)=(powerRZ radix (precision+e)%Z). Hypothesis q_eqExp : (Fexp q)=e. Theorem discri5: (0 < dp*dq)%R -> (delta <= 2*(Fulp bo radix precision d))%R. intros. unfold FtoRradix, delta; apply discri3 with p q t dp dq s; auto. assert (forall f1 f2 g : float, Fbounded bo f1 -> Fbounded bo f2 -> Closest bo 2 (FtoR 2 f1 * FtoR 2 f2) g -> (- dExp bo <= Fexp f1 + Fexp f2 - precision)%Z -> (- dExp bo <= Fexp g - precision)%Z -> Fcanonic 2 bo g -> exists s : float, Fbounded bo s /\ FtoR 2 s = (FtoR 2 f1 * FtoR 2 f2 - FtoR 2 g)%R /\ Fexp s = (Fexp g - precision)%Z /\ (Rabs (Fnum s) <= powerRZ (Zpos 2) (Zpred precision))%R). apply errorBoundedMultClosest_Can; auto. fold radix in H0; fold FtoRradix in H0. elim H0 with (f1:=b) (f2:=b') (g:=p); auto with zarith real. intros dp' T2; elim T2; intros H2 T3; elim T3; intros H3 T4; elim T4; intros H4 H5; clear T2 T3 T4. 2: elim Roundp; auto. elim H0 with (f1:=a) (f2:=c) (g:=q); auto with zarith real; clear H0. intros dq' T2; elim T2; intros H2' T3; elim T3; intros H3' T4; elim T4; intros H4' H5'; clear T2 T3 T4. 2: elim Roundq; auto. 2: left; auto. 2: left; auto. fold radix; fold FtoRradix; rewrite dpEq; rewrite dqEq; rewrite <- H3; rewrite <- H3'. exists (Fminus radix dp' dq'); split. 2: unfold FtoRradix; rewrite Fminus_correct; auto with real. unfold Fminus, Fopp, Fplus; simpl. repeat rewrite H4'; repeat rewrite q_eqExp; repeat rewrite H4. replace (Fexp p) with (Zsucc e); [idtac|rewrite p_eqF; auto]. rewrite Zmin_le2; auto with zarith. split; auto with zarith. simpl; unfold Zsucc. ring_simplify (e + 1 - precision - (e - precision))%Z; ring_simplify (e - precision - (e - precision))%Z. simpl. unfold nat_of_P, Zpower_nat; simpl. replace ( - Fnum dq' * 1)%Z with (- Fnum dq')%Z; [idtac|ring]. apply Zlt_Rlt. rewrite pGivesBound;rewrite Zpower_nat_Z_powerRZ; auto. rewrite <- Rabs_Zabs; rewrite plus_IZR;rewrite mult_IZR;rewrite Ropp_Ropp_IZR. assert (forall (x y z:R), (0 < x*y)%R -> (Rabs x <= z)%R -> (Rabs y <= z)%R -> (Rabs (2*x-y) < 2*z)%R). intros. unfold Rabs; case (Rcase_abs (2*x-y)%R); case (Rle_or_lt 0%R x); intros. case H7; intros;ring_simplify (- (2 * x - y))%R. assert (-x <0)%R; auto with real. apply Rlt_le_trans with (-2*0+y)%R; auto with real. apply Rplus_lt_compat_r; repeat rewrite Ropp_mult_distr_l_reverse. apply Ropp_lt_contravar; apply Rmult_lt_compat_l; auto with real. ring_simplify (-2*0+y)%R; apply Rle_trans with z; auto with real. apply Rle_trans with (2:=H6); apply RRle_abs. apply Rle_trans with (1*z)%R; auto with real. apply Rmult_le_compat_r; auto with real. apply Rle_trans with (2:=H1); auto with real. Contradict H0; rewrite <- H8; auto with real. ring_simplify (0*y)%R; auto with real. ring_simplify (- (2 * x - y))%R. apply Rlt_le_trans with ((-2*x)+0)%R;[apply Rplus_lt_compat_l|idtac]. apply Rmult_lt_reg_l with (-x)%R; auto with real. apply Rle_lt_trans with (-(x*y))%R; auto with real. apply Rlt_le_trans with (-0)%R; auto with real; right;ring. apply Rle_trans with (2*(-x))%R;[right;ring|apply Rmult_le_compat_l; auto with real]. apply Rle_trans with (2:=H1); rewrite <- Rabs_Ropp; apply RRle_abs. apply Rlt_le_trans with (2*x-0)%R;[unfold Rminus; apply Rplus_lt_compat_l|idtac]. apply Ropp_lt_contravar; apply Rmult_lt_reg_l with x; auto with real. case H7; auto with real. intros H8; Contradict H0; rewrite <- H8; ring_simplify (0*y)%R; auto with real. ring_simplify (x*0)%R; auto with real. apply Rle_trans with (2*x)%R;[right;ring|apply Rmult_le_compat_l; auto with real]. apply Rle_trans with (2:=H1); apply RRle_abs. apply Rlt_le_trans with (2*0-y)%R; [unfold Rminus; apply Rplus_lt_compat_r; apply Rmult_lt_compat_l; auto with real|idtac]. apply Rle_trans with (-y)%R;[right;ring|apply Rle_trans with z]. apply Rle_trans with (2:=H6); rewrite <- Rabs_Ropp; apply RRle_abs. apply Rle_trans with (1*z)%R;[right;ring|apply Rmult_le_compat_r; auto with real]. apply Rle_trans with (2:=H1); auto with real. replace (Fnum dp' * Zpos 2+-Fnum dq')%R with (2*(Fnum dp')-Fnum dq')%R; auto with real zarith. apply Rlt_le_trans with (2*powerRZ radix (Zpred precision))%R. apply H0; auto. apply Rmult_lt_reg_l with (powerRZ radix (Fexp dq')); auto with real zarith. apply Rmult_lt_reg_l with (powerRZ radix (Fexp dp')); auto with real zarith. apply Rle_lt_trans with 0%R;[right;ring|apply Rlt_le_trans with (1:=H)]. rewrite dpEq; rewrite dqEq; rewrite <- H3; rewrite <- H3'. unfold FtoRradix, FtoR; right; ring. right; unfold Zpred, Zminus; rewrite powerRZ_add; auto with real zarith. simpl; field; apply Rmult_integral_contrapositive; split; auto with real. simpl; ring. simpl;rewrite <-q_eqExp; rewrite <- H4'; auto with zarith float. Qed. Theorem discri6: (0< dp)%R -> (dq < 0)%R -> (delta <= 2*(Fulp bo radix precision d))%R. intros;unfold delta. replace (d - (b * b' - a * c))%R with (-((t+s)-d)+-((dp-dq)-s))%R. 2: rewrite dpEq; rewrite dqEq; unfold FtoRradix, radix; rewrite t_exact with bo precision b b' p q t; auto; ring. apply Rle_trans with (1:=Rabs_triang (-(t+s-d))%R (-(dp-dq-s))%R). apply Rmult_le_reg_l with (INR 2); auto with real zarith;rewrite Rmult_plus_distr_l. apply Rle_trans with ((Fulp bo radix precision d)+(Fulp bo radix precision s))%R;[apply Rplus_le_compat|idtac]. rewrite Rabs_Ropp; unfold FtoRradix; apply ClosestUlp; auto. elim Roundd; auto. rewrite Rabs_Ropp; unfold FtoRradix; apply ClosestUlp; auto. elim Rounds; auto. apply Rle_trans with ((Fulp bo radix precision d+ 3* Fulp bo radix precision d))%R;[apply Rplus_le_compat_l|simpl;right;ring]. apply Rle_trans with (2*Fulp bo radix precision d)%R;[idtac|unfold Fulp; auto with real zarith]. rewrite FulpFabs; auto; rewrite FulpFabs with bo radix precision d; auto. assert (2*(Fabs d)=(Float (Fnum (Fabs d)) (Zsucc (Fexp (Fabs d)))))%R. unfold FtoRradix, FtoR, Zsucc; simpl; rewrite powerRZ_add; auto with real zarith; simpl; ring. apply Rle_trans with (Fulp bo radix precision (Float (Fnum (Fabs d)) (Zsucc (Fexp (Fabs d))))). 2:assert (Fnormal radix bo (Fabs d));[apply FnormalFabs; auto|idtac]. 2:right; rewrite CanonicFulp; auto; [rewrite CanonicFulp|left]; auto. 2:unfold FtoR, Zsucc; simpl; rewrite powerRZ_add; auto with real zarith. 2:simpl; ring. 2:left; auto. 2:elim H2; intros H6 H5; elim H6; intros. 2:split; simpl; auto with zarith. 2:split; simpl; auto with zarith. apply LeFulpPos; auto with real float. assert (Fnormal radix bo (Fabs d));[apply FnormalFabs; auto|idtac]. elim H2; intros H6 H5; elim H6; intros;split; simpl; auto with zarith. rewrite Fabs_correct; auto with real zarith. apply EvenClosestMonotone2 with bo precision (Rabs (dp-dq))%R (2*Rabs (t+s))%R; auto. 2: apply EvenClosestFabs; auto; left; auto. 2: apply Twice_EvenClosest_Round; auto. 2: apply FnormalFabs; auto. 2: apply EvenClosestFabs; auto; left; auto. unfold Rminus; apply Rle_trans with (1:=Rabs_triang dp (-dq)%R). apply Rmult_le_reg_l with (INR 2); auto with real zarith; rewrite Rmult_plus_distr_l. apply Rle_trans with (Fulp bo radix precision p+Fulp bo radix precision q)%R;[apply Rplus_le_compat|idtac]. rewrite dpEq; unfold FtoRradix; apply ClosestUlp; auto. elim Roundp; auto. rewrite Rabs_Ropp; rewrite dqEq; unfold FtoRradix; apply ClosestUlp; auto. elim Roundq; auto. rewrite CanonicFulp; auto with float;[idtac|left; auto]. rewrite CanonicFulp; auto with float;[idtac|left; auto]. apply Rle_trans with (3*(powerRZ radix e))%R;[right|idtac]. unfold FtoRradix, FtoR; simpl; rewrite q_eqExp; rewrite p_eqF; simpl. unfold Zsucc; rewrite powerRZ_add; auto with real zarith; simpl;ring. assert ((powerRZ radix e <= t))%R. unfold FtoRradix, radix; rewrite t_exact with bo precision b b' p q t; auto. fold radix; fold FtoRradix; rewrite p_eqR. apply Rle_trans with (powerRZ radix (precision + e) - ((powerRZ radix precision - 1) * powerRZ radix e))%R; auto with real. rewrite powerRZ_add; auto with real zarith; right;ring. unfold Rminus; apply Rplus_le_compat_l; auto with real. apply Ropp_le_contravar. unfold FtoRradix, FtoR; rewrite q_eqExp; apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (1:=(RRle_abs (Fnum q))). assert (Zabs (Fnum q) < Zpower_nat radix precision)%Z; auto with real zarith float. rewrite <- pGivesBound; auto with zarith float. rewrite Rabs_Zabs; apply Rle_trans with (Zpred (Zpower_nat radix precision)); auto with real zarith. unfold Zpred; rewrite plus_IZR. rewrite Zpower_nat_Z_powerRZ; right; simpl; ring. assert (0<=s)%R. unfold FtoRradix; apply RleRoundedR0 with bo precision (EvenClosest bo radix precision) (dp-dq)%R; auto with real. apply EvenClosestRoundedModeP; auto. apply Rle_trans with (0-0)%R; unfold Rminus; auto with real. apply Rplus_le_compat; auto with real. rewrite Rabs_right; auto with real. 2: apply Rle_ge; apply Rle_trans with (0+0)%R; auto with real. 2: apply Rplus_le_compat; auto with real zarith. 2: apply Rle_trans with (2:=H2); auto with real zarith. apply Rle_trans with (4*powerRZ radix e)%R;[apply Rmult_le_compat_r; auto with real zarith|idtac]. replace 3%R with (INR 3);[idtac|simpl; ring]. replace 4%R with (INR 4);[auto with real zarith|simpl;ring]. apply Rle_trans with (4*(t+s))%R;[apply Rmult_le_compat_l; auto with real|simpl; right; ring]. replace 4%R with (INR 4);[auto with real zarith|simpl;ring]. apply Rle_trans with (powerRZ radix e+0)%R;[idtac|apply Rplus_le_compat];auto with real. Qed. Theorem discri7: (dp < 0)%R -> (0 < dq)%R -> (delta <= 2*(Fulp bo radix precision d))%R. intros L1 L2. unfold delta, FtoRradix; apply discri3 with p q t dp dq s; auto. assert (H0:forall f1 f2 g : float, Fbounded bo f1 -> Fbounded bo f2 -> Closest bo 2 (FtoR 2 f1 * FtoR 2 f2) g -> (- dExp bo <= Fexp f1 + Fexp f2 - precision)%Z -> (- dExp bo <= Fexp g - precision)%Z -> Fcanonic 2 bo g -> exists s : float, Fbounded bo s /\ FtoR 2 s = (FtoR 2 f1 * FtoR 2 f2 - FtoR 2 g)%R /\ Fexp s = (Fexp g - precision)%Z /\ (Rabs (Fnum s) <= powerRZ (Zpos 2) (Zpred precision))%R). apply errorBoundedMultClosest_Can; auto. fold radix in H0; fold FtoRradix in H0. elim H0 with (f1:=b) (f2:=b') (g:=p); auto with zarith real. intros dp' T2; elim T2; intros H2 T3; elim T3; intros H3 T4; elim T4; intros H4 H5; clear T2 T3 T4. 2: elim Roundp; auto. elim H0 with (f1:=a) (f2:=c) (g:=q); auto with zarith real; clear H0. intros dq' T2; elim T2; intros H2' T3; elim T3; intros H3' T4; elim T4; intros H4' H5'; clear T2 T3 T4. 2: elim Roundq; auto. 2: left; auto. 2: left; auto. cut (exists dp'':float, (Fexp dp''=Fexp dq' /\ (FtoRradix dp''=dp')%R /\ (Rabs (Fnum dp'') <= powerRZ radix (Zpred precision))%R)). intros T; elim T; intros dp'' T1; elim T1; intros H4'' T2; elim T2; intros H5'' H6''; clear T T1 T2. assert ((Rabs (Fnum dp''-Fnum dq') < (powerRZ radix precision))%R \/ (((Rabs dp'')= (powerRZ radix (Zpred (Fexp q))))%R /\ ((Rabs dq')= (powerRZ radix (Zpred (Fexp q))))%R)). case H6''; intros. left; unfold Rminus; apply Rle_lt_trans with (1:=Rabs_triang (Fnum dp'') (-(Fnum dq'))%R). rewrite Rabs_Ropp. apply Rlt_le_trans with ((powerRZ radix (Zpred precision)) +(Rabs (Fnum dq')))%R; auto with real zarith. apply Rle_trans with ((powerRZ radix (Zpred precision))+ (powerRZ radix (Zpred precision)))%R; auto with real zarith. right; unfold Zpred; repeat rewrite powerRZ_add; auto with real zarith. simpl; field. case H5'; intros. left; unfold Rminus; apply Rle_lt_trans with (1:=Rabs_triang (Fnum dp'') (-(Fnum dq'))%R); rewrite Rabs_Ropp. apply Rle_lt_trans with ((powerRZ radix (Zpred precision)) +(Rabs (Fnum dq')))%R ; auto with real zarith. apply Rlt_le_trans with ((powerRZ radix (Zpred precision))+ (powerRZ radix (Zpred precision)))%R; auto with real zarith. right; unfold Zpred; repeat rewrite powerRZ_add; auto with real zarith. simpl; field. right; unfold FtoRradix, FtoR;repeat rewrite Rabs_mult. rewrite (Rabs_right (powerRZ radix (Fexp dp''))); try apply Rle_ge; auto with real zarith. rewrite (Rabs_right (powerRZ radix (Fexp dq'))); try apply Rle_ge; auto with real zarith. rewrite H; rewrite H0. repeat rewrite <- powerRZ_add; auto with real zarith. rewrite H4''; rewrite H4'; unfold Zpred. ring_simplify (precision + -1 + (Fexp q - precision))%Z; ring_simplify (precision + -1 + (Fexp q - precision))%Z; ring_simplify (Fexp q+-1)%Z; auto with zarith real. case H; intros V; clear H. exists (Float (Fnum dp''-Fnum dq') (Fexp dq')). split;[split; auto with zarith|idtac]. simpl; apply Zlt_Rlt. rewrite pGivesBound;rewrite Zpower_nat_Z_powerRZ; auto. rewrite <- Rabs_Zabs; unfold Zminus; rewrite plus_IZR; rewrite Ropp_Ropp_IZR; auto with real zarith. simpl; auto with zarith float. fold radix; fold FtoRradix; rewrite dpEq; rewrite dqEq. rewrite <- H3'; rewrite <- H3;rewrite <- H5''. unfold FtoRradix, FtoR; simpl. unfold Zminus; rewrite plus_IZR; rewrite Ropp_Ropp_IZR. rewrite H4''; ring. exists (Float (-1)%Z (Fexp q)). split;[split; simpl; auto with zarith|idtac]. rewrite pGivesBound; apply Zle_lt_trans with (Zpower_nat radix 0); auto with zarith. fold radix; fold FtoRradix; elim V; intros. replace (FtoRradix dp) with (-(-dp))%R;[idtac|ring]. rewrite <- (Rabs_left dp); auto with real. rewrite <- (Rabs_right dq); auto with real. 2: apply Rle_ge; auto with real. rewrite dpEq; rewrite <- H3; rewrite <- H5''; rewrite H. rewrite dqEq; rewrite <- H3'; rewrite H0. unfold FtoRradix, FtoR, Zpred; simpl. repeat rewrite powerRZ_add; auto with real zarith; simpl; field. assert (FtoRradix dp'=(Float (2*Fnum dp') (Zpred (Fexp dp'))))%R. unfold FtoRradix, FtoR, Zpred. apply trans_eq with ((2 * Fnum dp')%Z*(powerRZ radix (Fexp dp'+-1)))%R;[auto|idtac]. rewrite mult_IZR;rewrite powerRZ_add; auto with real zarith; simpl; field. simpl; auto with real. exists (Float (2*Fnum dp') (Zpred (Fexp dp'))); split. simpl; rewrite H4'; rewrite H4. rewrite q_eqExp; rewrite p_eqF; unfold Zpred, Zsucc;simpl; auto with zarith. split; auto with real. apply Rmult_le_reg_l with (powerRZ radix (Zpred (Fexp dp'))); auto with real zarith. rewrite <- powerRZ_add; auto with real zarith. rewrite <- (Rabs_right (powerRZ radix (Zpred (Fexp dp'))));auto with real. 2: apply Rle_ge; auto with real zarith. rewrite <- Rabs_mult. replace (powerRZ radix (Zpred (Fexp dp')) * Fnum (Float (2 * Fnum dp') (Zpred (Fexp dp'))))%R with (FtoRradix dp'); auto with real. 2: rewrite H; unfold FtoRradix, FtoR; simpl; auto with real. rewrite H3; rewrite <- dpEq. rewrite H4; unfold Zpred;ring_simplify (Fexp p - precision + -1 + (precision + -1))%Z. rewrite Rabs_left; auto with real. apply Rmult_le_reg_l with 2%R; auto with real. apply Rplus_le_reg_l with (FtoRradix dp). ring_simplify (dp+2*(-dp))%R. rewrite <- Rabs_left; auto with real. assert (Fbounded bo (Float (Zpred (Zpower_nat radix precision)) e)). split; auto with zarith. simpl; rewrite pGivesBound; auto with zarith. rewrite Zabs_eq; auto with zarith. simpl; auto with zarith. rewrite <- Rabs_Ropp. replace (-dp)%R with (p-b*b')%R; [idtac|rewrite dpEq;ring]. elim Roundp; intros K1 K2; elim K1; intros K3 K4. apply Rle_trans with (Rabs ((Float (Zpred (Zpower_nat radix precision)) e)-b*b')). unfold FtoRradix; apply K4; auto. clear K1 K2 K3 K4; rewrite Rabs_left1. rewrite dpEq; rewrite p_eqR. apply Rle_trans with (b*b'-(powerRZ radix precision -1)*(powerRZ radix e))%R. unfold FtoRradix, FtoR, Zpred, radix; simpl. rewrite plus_IZR; simpl; right; ring_simplify. rewrite Zpower_nat_Z_powerRZ; auto with real zarith; simpl; ring. unfold Rminus; rewrite Rplus_assoc; apply Rplus_le_compat_l. replace (Fexp p) with (Zsucc e);[unfold Zsucc|rewrite p_eqF; simpl; auto with zarith]. ring_simplify (e+1-2)%Z; unfold Zminus. repeat rewrite powerRZ_add; auto with real zarith; simpl; right; field. apply Rplus_le_reg_l with (p-(Float (Zpred (Zpower_nat radix precision)) e))%R. apply Rle_trans with (-(b*b'-p))%R;[right;ring|idtac]. rewrite <- dpEq; rewrite <- Rabs_left; auto with real. rewrite dpEq; apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix precision p). unfold FtoRradix; apply ClosestUlp; auto. elim Roundp; auto. rewrite CanonicFulp; auto;[idtac|left; auto]. replace (Fexp p) with (Zsucc e);[unfold Zsucc|rewrite p_eqF; simpl; auto with zarith]. rewrite p_eqR; unfold FtoRradix, FtoR, Zpred; simpl. rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ; auto with real zarith. repeat rewrite powerRZ_add; auto with real zarith; simpl; right; field. Qed. Theorem discri8: (delta <= 2*(Fulp bo radix precision d))%R. case (Rle_or_lt 0%R dp); intros H;[case H; clear H; intros H|idtac]. case (Rle_or_lt 0%R dq); intros H';[case H'; clear H'; intros H'|idtac]. apply discri5; auto with real. apply Rle_lt_trans with (dp*0)%R;[right;ring|auto with real]. unfold FtoRradix, delta; apply discri3 with p q t dp dq s; auto. exists dp; split; auto. fold radix; fold FtoRradix; rewrite <- H'; ring. apply discri6; auto. unfold FtoRradix, delta; apply discri3 with p q t dp dq s; auto. exists (Fopp dq); split; auto with float zarith. rewrite Fopp_correct; fold radix; fold FtoRradix; rewrite <- H; ring. case (Rle_or_lt 0%R dq); intros H';[case H'; clear H'; intros H'|idtac]. apply discri7; auto. unfold FtoRradix, delta; apply discri3 with p q t dp dq s; auto. exists dp; split; auto. fold radix; fold FtoRradix; rewrite <- H'; ring. apply discri5; auto. apply Rle_lt_trans with (-dp*0)%R;[right;ring|idtac]. apply Rlt_le_trans with ((-dp)*(-dq))%R;[auto with real|right;ring]. Qed. End Discriminant3. Section Discriminant4. Variable bo : Fbound. Variable precision : nat. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ TwoMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum bo) = Zpower_nat radix precision. Variables a b c p q t dp dq s d:float. Let delta := (Rabs (d-(b*b-a*c)))%R. Hypothesis Fa : (Fbounded bo a). Hypothesis Fb : (Fbounded bo b). Hypothesis Fc : (Fbounded bo c). Hypothesis Fp : (Fbounded bo p). Hypothesis Fq : (Fbounded bo q). Hypothesis Fd : (Fbounded bo d). Hypothesis Ft : (Fbounded bo t). Hypothesis Fs : (Fbounded bo s). Hypothesis Fdp: (Fbounded bo dp). Hypothesis Fdq: (Fbounded bo dq). (** There is no underflow *) Hypothesis U0: (- dExp bo <= Fexp d - 1)%Z. Hypothesis U1: (- dExp bo <= (Fexp t)-1)%Z. Hypothesis U2: (- dExp bo <= Fexp a + Fexp c - precision)%Z. Hypothesis U3: (- dExp bo <= Fexp q - precision)%Z. Hypothesis U4: (- dExp bo <= Fexp b + Fexp b - precision)%Z. Hypothesis U5: (- dExp bo <= Fexp p - precision)%Z. Hypothesis Np:(Fnormal radix bo p). Hypothesis Nq:(Fnormal radix bo q). Hypothesis Ns:(Fnormal radix bo s). Hypothesis Nd:(Fnormal radix bo d). Hypothesis Roundp : (EvenClosest bo radix precision (b*b)%R p). Hypothesis Roundq : (EvenClosest bo radix precision (a*c)%R q). Hypothesis Firstcase : (p+q <= 3*(Rabs (p-q)))%R -> (EvenClosest bo radix precision (p-q)%R d). Hypothesis SRoundt : (3*(Rabs (p-q)) < p+q)%R -> (EvenClosest bo radix precision (p-q)%R t). Hypothesis SdpEq : (3*(Rabs (p-q)) < p+q)%R -> (FtoRradix dp=b*b-p)%R. Hypothesis SdqEq : (3*(Rabs (p-q)) < p+q)%R -> (FtoRradix dq=a*c-q)%R. Hypothesis SRounds : (3*(Rabs (p-q)) < p+q)%R -> (EvenClosest bo radix precision (dp-dq)%R s). Hypothesis SRoundd : (3*(Rabs (p-q)) < p+q)%R -> (EvenClosest bo radix precision (t+s)%R d). Theorem discri9: (delta <= 2*(Fulp bo radix precision d))%R. assert (Square:(0<=b*b)%R). apply Rle_trans with (Rsqr b); auto with real. case (Rle_or_lt (p + q)%R (3 * Rabs (p - q))%R); intros. unfold delta;apply discri1 with p q; auto. case (Rle_or_lt (3*(Rmin (Fulp bo radix precision p) (Fulp bo radix precision q)))%R (Rabs (p-q))%R); intros. unfold delta; apply discri2 with p q t dp dq s; auto. case (Zle_or_lt (Fexp q) (Fexp p)); intros. case (Zle_lt_or_eq (Fexp q) (Fexp p)); auto;intros. assert (Fexp q = Zpred (Fexp p))%Z. cut (Zle (Fexp q) (Zpred (Fexp p))); auto with zarith. cut (Zle (Zpred (Fexp p)) (Fexp q)); auto with zarith. clear H1;apply Zle_powerRZ with radix; auto with real zarith. apply Rle_trans with (Fulp bo radix precision (Float (Fnum p) (Zpred (Fexp p)))). rewrite CanonicFulp; auto. unfold FtoR; simpl; right; ring. left; split; auto with zarith. split; simpl; auto with zarith float. simpl; elim Np; auto with zarith. apply Rle_trans with (Fulp bo radix precision q). apply LeFulpPos; auto with real float zarith. split; simpl; auto with zarith float. apply LeFnumZERO; simpl; auto with real zarith. apply LeR0Fnum with radix; auto with real zarith. apply P_positive with bo precision b b; auto. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (FtoRradix p). unfold FtoRradix, FtoR, Zpred; simpl; rewrite powerRZ_add; auto with real zarith; simpl; right; field. apply P_le_two_Q with bo precision b b; auto. rewrite CanonicFulp; auto with zarith. unfold FtoR; simpl; right; ring. left; auto. clear H1 H2; assert (FtoRradix p=powerRZ radix (precision+Zpred (Fexp p)))%R. case (Zle_lt_or_eq (Zpower_nat radix (pred precision)) (Fnum p)). elim Np; intros. apply Zmult_le_reg_r with radix; auto with zarith. apply Zlt_gt; auto with zarith. apply Zle_trans with (Zpower_nat radix precision). pattern radix at 2 in |-*; replace radix with (Zpower_nat radix 1). rewrite <- Zpower_nat_is_exp; auto with zarith. simpl; auto with zarith. rewrite <- pGivesBound; apply Zle_trans with (1:=H2). rewrite Zabs_eq; auto with zarith. cut (0<=Fnum p)%Z; auto with zarith. apply LeR0Fnum with radix; auto. apply P_positive with bo precision b b; auto. intros H1; Contradict H0. apply Rle_not_lt. rewrite CanonicFulp; auto; [idtac|left; auto]. rewrite CanonicFulp; auto; [idtac|left; auto]. replace (FtoR radix (Float (S 0) (Fexp p))) with (powerRZ radix (Fexp p));[idtac|unfold FtoR; simpl; ring]. replace (FtoR radix (Float (S 0) (Fexp q))) with (powerRZ radix (Fexp q));[idtac|unfold FtoR; simpl; ring]. rewrite H3; unfold Rmin. case (Rle_dec (powerRZ radix (Fexp p)) (powerRZ radix (Zpred (Fexp p)))); auto with real zarith; intros J. Contradict J; apply Rlt_not_le; auto with real zarith. clear J; rewrite Rabs_right. unfold FtoRradix, FtoR, Rminus. apply Rle_trans with ((Zsucc (Zpower_nat radix (pred precision))*(powerRZ radix (Fexp p))+-((Zpred (Zpower_nat radix precision))*(powerRZ radix (Fexp q)))))%R. unfold Zpred, Zsucc; rewrite plus_IZR; rewrite plus_IZR; repeat rewrite Zpower_nat_Z_powerRZ. rewrite inj_pred; auto with zarith. rewrite H3; unfold Zpred; simpl; right;ring_simplify. repeat rewrite powerRZ_add; auto with real zarith; simpl; field. apply Rplus_le_compat;[apply Rmult_le_compat_r; auto with real zarith|idtac]. apply Ropp_le_contravar; apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (1:=RRle_abs (Fnum q)). rewrite Rabs_Zabs; rewrite <- pGivesBound;auto with zarith float. elim Fq; intros; auto with zarith. apply Rle_IZR;apply Zle_Zpred; auto. apply Rle_ge; apply Rlt_le; apply Rplus_lt_reg_r with q. ring_simplify. unfold FtoRradix; apply FcanonicPosFexpRlt with bo precision; auto with zarith. apply Rlt_le; apply Q_positive with bo precision b b p; auto. apply P_positive with bo precision b b; auto. left; auto. left; auto. intros H1; unfold FtoRradix, FtoR; rewrite <- H1. rewrite Zpower_nat_Z_powerRZ; rewrite <- powerRZ_add; auto with real zarith. rewrite inj_pred; auto with zarith. replace (Zpred precision+Fexp p)%Z with (precision + Zpred (Fexp p))%Z;[auto with real|unfold Zpred; ring]. unfold delta; apply discri8 with p q t dp dq s (Zpred (Fexp p)); auto. apply FcanonicUnique with radix bo precision; auto with zarith real. left; auto. left; split; [split;simpl|idtac]; auto with zarith. rewrite Zabs_eq; auto with zarith. rewrite pGivesBound; auto with zarith. simpl (Fnum (Float (Zpower_nat 2 (pred precision)) (Zsucc (Zpred (Fexp p))))). replace radix with (Zpower_nat radix 1);[idtac|simpl; auto with zarith]. rewrite <-Zpower_nat_is_exp; rewrite pGivesBound; auto with zarith. rewrite Zabs_eq; auto with zarith. fold FtoRradix; rewrite H1; unfold FtoRradix, FtoR, Zpred, Zsucc; simpl. rewrite Zpower_nat_Z_powerRZ; rewrite <- powerRZ_add; auto with real zarith. rewrite inj_pred; auto with zarith; unfold Zpred. replace (precision + -1 + (Fexp p + -1 + 1))%Z with (precision+(Fexp p+-1))%Z; auto with real; ring. unfold delta;apply discri4 with p q t dp dq s; auto. assert (Fexp p = Zpred (Fexp q))%Z. cut (Zle (Fexp p) (Zpred (Fexp q))); auto with zarith. cut (Zle (Zpred (Fexp q)) (Fexp p)); auto with zarith. clear H1;apply Zle_powerRZ with radix; auto with real zarith. apply Rle_trans with (Fulp bo radix precision (Float (Fnum q) (Zpred (Fexp q)))). rewrite CanonicFulp; auto. unfold FtoR; simpl; right; ring. left; split; auto with zarith. split; simpl; auto with zarith float. simpl; elim Nq; auto with zarith. apply Rle_trans with (Fulp bo radix precision p). apply LeFulpPos; auto with real float zarith. split; simpl; auto with zarith float. apply LeFnumZERO; simpl; auto with real zarith. apply LeR0Fnum with radix; auto with real zarith. apply Rlt_le; apply Q_positive with bo precision b b p; auto. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (FtoRradix q). unfold FtoRradix, FtoR, Zpred; simpl; rewrite powerRZ_add; auto with real zarith; simpl; right; field. apply Q_le_two_P with bo precision b b; auto. rewrite CanonicFulp; auto with zarith. unfold FtoR; simpl; right; ring. left; auto. clear H1; assert (FtoRradix q=powerRZ radix (precision+Zpred (Fexp q)))%R. case (Zle_lt_or_eq (Zpower_nat radix (pred precision)) (Fnum q)). elim Nq; intros. apply Zmult_le_reg_r with radix; auto with zarith. apply Zlt_gt; auto with zarith. apply Zle_trans with (Zpower_nat radix precision). pattern radix at 2 in |-*; replace radix with (Zpower_nat radix 1). rewrite <- Zpower_nat_is_exp; auto with zarith. simpl; auto with zarith. rewrite <- pGivesBound; apply Zle_trans with (1:=H3). rewrite Zabs_eq; auto with zarith. cut (0<=Fnum q)%Z; auto with zarith. apply LeR0Fnum with radix; auto. apply Rlt_le; apply Q_positive with bo precision b b p; auto. intros H1; Contradict H0. apply Rle_not_lt. rewrite CanonicFulp; auto; [idtac|left; auto]. rewrite CanonicFulp; auto; [idtac|left; auto]. replace (FtoR radix (Float (S 0) (Fexp p))) with (powerRZ radix (Fexp p));[idtac|unfold FtoR; simpl; ring]. replace (FtoR radix (Float (S 0) (Fexp q))) with (powerRZ radix (Fexp q));[idtac|unfold FtoR; simpl; ring]. rewrite H2; unfold Rmin. case (Rle_dec (powerRZ radix (Zpred (Fexp q))) (powerRZ radix (Fexp q))); auto with real zarith; intros J. clear J; rewrite Rabs_left1. unfold FtoRradix, FtoR, Rminus. apply Rle_trans with (- ((Zpred (Zpower_nat radix precision)) * powerRZ radix (Fexp p) + - ((Zsucc (Zpower_nat radix (pred precision))) * powerRZ radix (Fexp q))))%R. unfold Zpred, Zsucc; rewrite plus_IZR; rewrite plus_IZR; repeat rewrite Zpower_nat_Z_powerRZ. rewrite inj_pred; auto with zarith. rewrite H2; unfold Zpred; simpl; right;ring_simplify. repeat rewrite powerRZ_add; auto with real zarith; simpl; field. apply Ropp_le_contravar. apply Rplus_le_compat;[apply Rmult_le_compat_r; auto with real zarith|idtac]. 2:apply Ropp_le_contravar; apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (1:=RRle_abs (Fnum p)). rewrite Rabs_Zabs; rewrite <- pGivesBound;auto with zarith float. elim Fp; intros; auto with zarith. apply Rle_IZR;apply Zle_Zpred; auto. apply Rlt_le; apply Rplus_lt_reg_r with q. ring_simplify. unfold FtoRradix; apply FcanonicPosFexpRlt with bo precision; auto with zarith. 2:apply Rlt_le; apply Q_positive with bo precision b b p; auto. apply P_positive with bo precision b b; auto. left; auto. left; auto. Contradict J; auto with real zarith. intros H1; unfold FtoRradix, FtoR; rewrite <- H1. rewrite Zpower_nat_Z_powerRZ; rewrite <- powerRZ_add; auto with real zarith. rewrite inj_pred; auto with zarith. replace (Zpred precision+Fexp q)%Z with (precision + Zpred (Fexp q))%Z;[auto with real|unfold Zpred; ring]. unfold delta; rewrite <-Rabs_Ropp. replace (- (d - (b * b - a * c)))%R with (Fopp d-(a*c-b*b))%R;[idtac|unfold FtoRradix; rewrite Fopp_correct; ring]. replace (Fulp bo radix precision d) with (Fulp bo radix precision (Fopp d)); auto with float zarith. 2: unfold Fulp; rewrite Fnormalize_Fopp; unfold Fopp; simpl; auto with real zarith. apply discri8 with q p (Fopp t) dq dp (Fopp s) (Zpred (Fexp q)); auto with float zarith. apply FnormalFop; auto. apply FnormalFop; auto. fold radix; fold FtoRradix; case (Rle_or_lt 0%R (a*c)%R); auto. intros H3; absurd (0 < q)%R. apply Rle_not_lt; unfold FtoRradix; apply RleRoundedLessR0 with bo precision (EvenClosest bo radix precision) (a*c)%R; auto with real. apply EvenClosestRoundedModeP; auto. apply Q_positive with bo precision b b p; auto. fold radix; fold FtoRradix; rewrite (Rplus_comm q p). replace (q-p)%R with (-(p-q))%R; auto with real; rewrite Rabs_Ropp; auto. fold radix; fold FtoRradix; replace (q-p)%R with (-(p-q))%R; auto with real. generalize EvenClosestSymmetric; unfold SymmetricP;intros T; apply T; auto. fold radix; fold FtoRradix; replace (dq-dp)%R with (-(dp-dq))%R;auto with real. generalize EvenClosestSymmetric; unfold SymmetricP;intros T; apply T; auto. fold radix; fold FtoRradix; replace (Fopp t+Fopp s)%R with (-(t+s))%R;[idtac|unfold FtoRradix; repeat rewrite Fopp_correct; ring]. generalize EvenClosestSymmetric; unfold SymmetricP;intros T; apply T; auto. apply FcanonicUnique with radix bo precision; auto with zarith real. left; auto. left; split; [split;simpl|idtac]; auto with zarith. rewrite Zabs_eq; auto with zarith. rewrite pGivesBound; auto with zarith. simpl (Fnum (Float (Zpower_nat 2 (pred precision)) (Zsucc (Zpred (Fexp q))))). replace radix with (Zpower_nat radix 1);[idtac|simpl; auto with zarith]. rewrite <-Zpower_nat_is_exp; rewrite pGivesBound; auto with zarith. rewrite Zabs_eq; auto with zarith. fold FtoRradix; rewrite H1; unfold FtoRradix, FtoR, Zpred, Zsucc; simpl. rewrite Zpower_nat_Z_powerRZ; rewrite <- powerRZ_add; auto with real zarith. rewrite inj_pred; auto with zarith; unfold Zpred. replace (precision + -1 + (Fexp q + -1 + 1))%Z with (precision+(Fexp q+-1))%Z; auto with real; ring. Qed. End Discriminant4. Section Discriminant5. Variable bo : Fbound. Variable precision : nat. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ TwoMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum bo) = Zpower_nat radix precision. Variables a b c p q t dp dq s d:float. Let delta := (Rabs (d-(b*b-a*c)))%R. Hypothesis Fa : (Fbounded bo a). Hypothesis Fb : (Fbounded bo b). Hypothesis Fc : (Fbounded bo c). Hypothesis Fp : (Fbounded bo p). Hypothesis Fq : (Fbounded bo q). Hypothesis Fd : (Fbounded bo d). Hypothesis Ft : (Fbounded bo t). Hypothesis Fs : (Fbounded bo s). Hypothesis Fdp: (Fbounded bo dp). Hypothesis Fdq: (Fbounded bo dq). (** There is no underflow *) Hypothesis U0: (- dExp bo <= Fexp d - 1)%Z. Hypothesis U1: (- dExp bo <= (Fexp t)-1)%Z. Hypothesis U2: (- dExp bo <= Fexp a + Fexp c - precision)%Z. Hypothesis U3: (- dExp bo <= Fexp q - precision)%Z. Hypothesis U4: (- dExp bo <= Fexp b + Fexp b - precision)%Z. Hypothesis U5: (- dExp bo <= Fexp p - precision)%Z. Hypothesis Np:(FtoRradix p=0)%R \/ (Fnormal radix bo p). Hypothesis Nq:(FtoRradix q=0)%R \/ (Fnormal radix bo q). Hypothesis Ns:(FtoRradix s=0)%R \/ (Fnormal radix bo s). Hypothesis Nd: (Fnormal radix bo d). Hypothesis Roundp : (EvenClosest bo radix precision (b*b)%R p). Hypothesis Roundq : (EvenClosest bo radix precision (a*c)%R q). Hypothesis Firstcase : (p+q <= 3*(Rabs (p-q)))%R -> (EvenClosest bo radix precision (p-q)%R d). Hypothesis SRoundt : (3*(Rabs (p-q)) < p+q)%R -> (EvenClosest bo radix precision (p-q)%R t). Hypothesis SdpEq : (3*(Rabs (p-q)) < p+q)%R -> (FtoRradix dp=b*b-p)%R. Hypothesis SdqEq : (3*(Rabs (p-q)) < p+q)%R -> (FtoRradix dq=a*c-q)%R. Hypothesis SRounds : (3*(Rabs (p-q)) < p+q)%R -> (EvenClosest bo radix precision (dp-dq)%R s). Hypothesis SRoundd : (3*(Rabs (p-q)) < p+q)%R -> (EvenClosest bo radix precision (t+s)%R d). Theorem discri: (delta <= 2*(Fulp bo radix precision d))%R. case Np; intros. assert (FtoRradix d=(Fopp q))%R. apply sym_eq; unfold FtoRradix; apply RoundedModeProjectorIdemEq with bo precision (EvenClosest bo radix precision); auto with float zarith. replace (FtoR radix (Fopp q)) with (p-q)%R; [apply Firstcase|rewrite Fopp_correct; fold FtoRradix; rewrite H; ring]. rewrite H; ring_simplify (0-q)%R; ring_simplify (0+q)%R. rewrite Rabs_Ropp; apply Rle_trans with (1:=(RRle_abs q)). apply Rle_trans with (1*(Rabs q))%R; auto with real. apply Rmult_le_compat_r; auto with real. apply Rle_trans with 2%R; auto with real. unfold delta; rewrite H0. unfold FtoRradix; rewrite Fopp_correct; fold FtoRradix. replace (-q-(b*b-a*c))%R with ((a*c-q)+(-(b*b)))%R;[idtac|ring]. apply Rle_trans with (1:=(Rabs_triang (a * c - q)%R (-(b*b))%R)). apply Rle_trans with (/2*(Fulp bo radix precision q)+/2*(Fulp bo radix precision p))%R. apply Rplus_le_compat; apply Rmult_le_reg_l with (2%nat)%R; auto with real zarith. apply Rle_trans with (Fulp bo radix precision q);[idtac|simpl; right; field; auto with real]. unfold FtoRradix; apply ClosestUlp; auto. elim Roundq; auto. apply Rle_trans with (Fulp bo radix precision p);[idtac|simpl; right; field; auto with real]. replace (-(b*b))%R with (-(b*b-p))%R;[rewrite Rabs_Ropp|rewrite H;ring]. unfold FtoRradix; apply ClosestUlp; auto. elim Roundp; auto. apply Rle_trans with (/ 2 * Fulp bo radix precision q + / 2 * Fulp bo radix precision q)%R;[apply Rplus_le_compat; auto with real|idtac]. apply Rmult_le_compat_l; auto with real. rewrite Fulp_zero. unfold Fulp; apply Rle_powerRZ;auto with real zarith float. apply is_Fzero_rep2 with radix; auto with zarith. apply Rle_trans with (1 * Fulp bo radix precision q)%R;[right; field; auto with real|idtac]. apply Rmult_le_compat; auto with real zarith float. unfold Fulp; auto with real zarith. right; apply trans_eq with (Fulp bo radix precision (Fopp q)). unfold Fulp; rewrite Fnormalize_Fopp; auto with real zarith. apply FulpComp; auto with float zarith. case Nq; intros. assert (FtoRradix d=p)%R. apply sym_eq; unfold FtoRradix; apply RoundedModeProjectorIdemEq with bo precision (EvenClosest bo radix precision); auto with float zarith. replace (FtoR radix p) with (p-q)%R; [apply Firstcase|fold FtoRradix; rewrite H0; ring]. rewrite H0; ring_simplify (p+0)%R; ring_simplify (p-0)%R. apply Rle_trans with (1:=(RRle_abs p)). apply Rle_trans with (1*(Rabs p))%R; auto with real. apply Rmult_le_compat_r; auto with real. apply Rle_trans with 2%R; auto with real. unfold delta; rewrite H1. replace (p-(b*b-a*c))%R with (a*c+(-(b*b-p)))%R;[idtac|ring]. apply Rle_trans with (1:=(Rabs_triang (a * c )%R (-(b*b-p))%R)). apply Rle_trans with (/2*(Fulp bo radix precision q)+/2*(Fulp bo radix precision p))%R. apply Rplus_le_compat; apply Rmult_le_reg_l with (2%nat)%R; auto with real zarith. apply Rle_trans with (Fulp bo radix precision q);[idtac|simpl; right; field; auto with real]. replace (a*c)%R with (a*c-q)%R;[idtac|rewrite H0;ring]. unfold FtoRradix; apply ClosestUlp; auto. elim Roundq; auto. apply Rle_trans with (Fulp bo radix precision p);[idtac|simpl; right; field; auto with real]. rewrite Rabs_Ropp; unfold FtoRradix; apply ClosestUlp; auto. elim Roundp; auto. apply Rle_trans with (/ 2 * Fulp bo radix precision p + / 2 * Fulp bo radix precision p)%R;[apply Rplus_le_compat; auto with real|idtac]. apply Rmult_le_compat_l; auto with real. rewrite Fulp_zero. unfold Fulp; apply Rle_powerRZ;auto with real zarith float. apply is_Fzero_rep2 with radix; auto with zarith. apply Rle_trans with (1 * Fulp bo radix precision p)%R;[right; field; auto with real|idtac]. apply Rmult_le_compat; auto with real zarith float. unfold Fulp; auto with real zarith. right; apply FulpComp; auto with float zarith. case (Rle_or_lt (p + q)%R (3 * Rabs (p - q))%R); intros. unfold delta;apply discri1 with p q; auto. apply Rle_trans with (Rsqr (FtoR 2 b)) ; auto with real. case Ns; intros. unfold delta; apply discri3 with p q t dp dq s; auto with real float zarith. apply Rle_trans with (Rsqr (FtoR 2 b)) ; auto with real. 2:unfold delta; apply discri9 with p q t dp dq s; auto. exists (Float 0%Z 0%Z). split. unfold Fbounded; split; auto with zarith. simpl; case (dExp bo); auto with zarith. apply trans_eq with 0%R. unfold FtoR; simpl; ring. fold radix; fold FtoRradix. rewrite <- H2. unfold FtoRradix; rewrite plusExactR0 with bo radix precision dp (Fopp dq) s; auto. rewrite Fopp_correct; ring. auto with zarith float. replace (FtoR radix dp + FtoR radix (Fopp dq))%R with (dp - dq)%R; auto. elim SRounds; auto. unfold FtoRradix; rewrite Fopp_correct; auto with real. Qed. End Discriminant5. Float8.4/Others/discriminant2.v0000644000423700002640000021545012032774527016262 0ustar sboldotoccata(** This proof file has been written by #Sylvie Boldo#(1), following a proof presented by #Pr William Kahan# (2), and adapted to Coq proof checker with the help of #Guillaume Melquiond#(1) and #Marc Daumas#(1). This work has been partially supported by the #CNRS# grant PICS 2533. (1) #LIP# Computer science laboratory UMR 5668 CNRS - ENS de Lyon - INRIA Lyon, France (2) #University of California at Berkeley# Berkeley, California *) Require Export AllFloat. Section Discriminant1. Variable bo : Fbound. Variable precision : nat. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Theorem TwoMoreThanOne : (1 < radix)%Z. unfold radix in |- *; red in |- *; simpl in |- *; auto. Qed. Hint Resolve TwoMoreThanOne. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ TwoMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum bo) = Zpower_nat radix precision. Variables a b b' c p q d:float. Let delta := (Rabs (d-(b*b'-a*c)))%R. Hypothesis Fa : (Fbounded bo a). Hypothesis Fb : (Fbounded bo b). Hypothesis Fb': (Fbounded bo b'). Hypothesis Fc : (Fbounded bo c). Hypothesis Fp : (Fbounded bo p). Hypothesis Fq : (Fbounded bo q). Hypothesis Fd : (Fbounded bo d). (** There is no underflow *) Hypothesis U1:(- dExp bo <= Fexp d - 1)%Z. Hypothesis Nd:(Fnormal radix bo d). Hypothesis Nq:(Fnormal radix bo q). Hypothesis Np:(Fnormal radix bo p). Hypothesis Square:(0 <=b*b')%R. Hypothesis Roundp : (EvenClosest bo radix precision (b*b')%R p). Hypothesis Roundq : (EvenClosest bo radix precision (a*c)%R q). Hypothesis Firstcase : (p+q <= 3*(Rabs (p-q)))%R. Hypothesis Roundd : (EvenClosest bo radix precision (p-q)%R d). Theorem delta_inf: (delta <= (/2)*(Fulp bo radix precision d)+ ((/2)*(Fulp bo radix precision p)+(/2)*(Fulp bo radix precision q)))%R. unfold delta; rewrite <- Rabs_Ropp. replace (-(d - (b * b' - a * c)))%R with (((p-q)-d)+((b*b'-p)+-(a*c-q)))%R;[idtac|ring]. apply Rle_trans with ((Rabs ((p-q)-d))+(Rabs (b * b' - p + - (a * c - q))))%R; [apply Rabs_triang|idtac]. apply Rplus_le_compat. apply Rmult_le_reg_l with (S (S O)); auto with arith real. apply Rle_trans with (Fulp bo radix precision d). unfold FtoRradix; apply ClosestUlp;auto with zarith. elim Roundd; auto. right; simpl; field; auto with real. apply Rle_trans with ((Rabs (b*b'-p))+(Rabs (-(a*c-q))))%R; [apply Rabs_triang|idtac]. apply Rplus_le_compat. apply Rmult_le_reg_l with (S (S O)); auto with arith real. apply Rle_trans with (Fulp bo radix precision p). unfold FtoRradix; apply ClosestUlp;auto with zarith. elim Roundp; auto. right; simpl; field; auto with real. rewrite Rabs_Ropp; apply Rmult_le_reg_l with (S (S O)); auto with arith real. apply Rle_trans with (Fulp bo radix precision q). unfold FtoRradix; apply ClosestUlp;auto with zarith. elim Roundq; auto. right; simpl; field; auto with real. Qed. Theorem P_positive: (Rle 0 p)%R. unfold FtoRradix; apply RleRoundedR0 with (b:=bo) (precision:=precision) (P:=(Closest bo radix)) (r:=(b*b')%R); auto. apply ClosestRoundedModeP with precision; auto. elim Roundp; auto. Qed. Theorem Fulp_le_twice_l: forall x y:float, (0 <= x)%R -> (Fnormal radix bo x) -> (Fbounded bo y) -> (2*x<=y)%R -> (2*(Fulp bo radix precision x) <= (Fulp bo radix precision y))%R. intros. assert (2*x=(Float (Fnum x) (Zsucc (Fexp x))))%R. unfold FtoRradix, FtoR, Zsucc; simpl; rewrite powerRZ_add; auto with real zarith; simpl; ring. apply Rle_trans with (Fulp bo radix precision (Float (Fnum x) (Zsucc (Fexp x)))). right; rewrite CanonicFulp; auto; [rewrite CanonicFulp|left]; auto. unfold FtoR, Zsucc; simpl; rewrite powerRZ_add; auto with real zarith. simpl; ring. elim H0; intros H4 H5; elim H4; intros. left; split; auto. split; simpl; auto with zarith. apply LeFulpPos; auto with real. elim H0; intros H4 H5; elim H4; intros;split; simpl; auto with zarith. fold FtoRradix; rewrite <- H3; apply Rmult_le_pos; auto with real. fold FtoRradix; rewrite <- H3; auto with real. Qed. Theorem Fulp_le_twice_r: forall x y:float, (0 <= x)%R -> (Fnormal radix bo y) -> (Fbounded bo x) -> (x<=2*y)%R -> ((Fulp bo radix precision x) <= 2*(Fulp bo radix precision y))%R. intros. assert (2*y=(Float (Fnum y) (Zsucc (Fexp y))))%R. unfold FtoRradix, FtoR, Zsucc; simpl; rewrite powerRZ_add; auto with real zarith; simpl; ring. apply Rle_trans with (Fulp bo radix precision (Float (Fnum y) (Zsucc (Fexp y)))). 2:right; rewrite CanonicFulp; auto; [rewrite CanonicFulp|left]; auto. 2:unfold FtoR, Zsucc; simpl; rewrite powerRZ_add; auto with real zarith. 2:simpl; ring. 2:left; auto. 2:elim H0; intros H6 H5; elim H6; intros. 2:split; auto with zarith. 2:split; simpl; auto with zarith. apply LeFulpPos; auto with real. elim H0; intros H6 H5; elim H6; intros;split; simpl; auto with zarith. fold FtoRradix; rewrite <- H3; auto with real. Qed. Theorem Half_Closest_Round: forall (x:float) (r:R), (- dExp bo <= Zpred (Fexp x))%Z -> (Closest bo radix r x) -> (Closest bo radix (r/2)%R (Float (Fnum x) (Zpred (Fexp x)))). intros x r L H. assert (x/2=(Float (Fnum x) (Zpred (Fexp x))))%R. unfold FtoRradix, FtoR, Zpred; simpl; rewrite powerRZ_add; auto with real zarith; simpl; field. elim H; intros H2 H3. split; [split; simpl; auto with float zarith|idtac]. intros. fold FtoRradix; rewrite <- H0. replace (x/2-r/2)%R with (/2*(x-r))%R;[idtac|unfold Rdiv; ring]. rewrite Rabs_mult; rewrite Rabs_right; auto with real. 2: apply Rle_ge; auto with real. replace (f-r/2)%R with (/2*((Float (Fnum f) (Zsucc (Fexp f)))-r))%R. rewrite Rabs_mult; rewrite Rabs_right with (/2)%R. 2: apply Rle_ge; auto with real. apply Rmult_le_compat_l; auto with real. unfold FtoRradix; apply H3. split; simpl; auto with zarith float. unfold FtoRradix, FtoR, Zsucc; simpl; rewrite powerRZ_add; auto with real zarith; simpl; field; auto with real. Qed. Theorem Twice_EvenClosest_Round: forall (x:float) (r:R), (-(dExp bo) <= (Fexp x)-1)%Z -> (Fnormal radix bo x) -> (EvenClosest bo radix precision r x) -> (EvenClosest bo radix precision (2*r)%R (Float (Fnum x) (Zsucc (Fexp x)))). intros x r U Nx H. assert (x*2=(Float (Fnum x) (Zsucc (Fexp x))))%R. unfold FtoRradix, FtoR, Zsucc; simpl; rewrite powerRZ_add; auto with real zarith; simpl; ring. elim H; intros H2 H3; elim H2; intros H'1 H'2; split. split; [split; simpl; auto with float zarith|idtac]. intros. fold FtoRradix; rewrite <- H0. replace (x*2-2*r)%R with (2*(x-r))%R;[idtac|unfold Rdiv; ring]. rewrite Rabs_mult; rewrite Rabs_right; auto with real. 2: apply Rle_ge; auto with real. case (Zle_lt_or_eq (-(dExp bo))%Z (Fexp f)); auto with zarith float; intros L. replace (f-2*r)%R with (2*((Float (Fnum f) (Zpred (Fexp f)))-r))%R. rewrite Rabs_mult; rewrite Rabs_right with (2)%R. 2: apply Rle_ge; auto with real. apply Rmult_le_compat_l; auto with real. unfold FtoRradix; apply H'2. split; simpl; auto with zarith float. unfold FtoRradix, FtoR, Zpred; simpl; rewrite powerRZ_add; auto with real zarith; simpl; field; auto with real. replace (f-2*r)%R with (-((2*r)-f))%R;[rewrite Rabs_Ropp|ring]. apply Rle_trans with (2:=Rabs_triang_inv (2*r)%R f). rewrite Rabs_mult; rewrite (Rabs_right 2%R); try apply Rle_ge;auto with real. pattern r at 2 in |-*; replace r with (x-(x-r))%R;[idtac|ring]. apply Rle_trans with (2*(Rabs (x)-Rabs (x-r))-Rabs f)%R;[idtac|unfold Rminus; apply Rplus_le_compat_r; apply Rmult_le_compat_l; auto with real]. 2: generalize (Rabs_triang_inv x (x-r)%R); unfold Rminus; auto with real. apply Rplus_le_reg_l with (Rabs f -2*(Rabs (x-r)))%R. apply Rle_trans with (Rabs f);[right;ring|idtac]. apply Rle_trans with (2*(Rabs x)-4*Rabs (x-r))%R;[idtac|right;ring]. apply Rle_trans with (((powerRZ radix precision)-1)*(powerRZ radix ((Fexp x)-1)))%R. unfold FtoRradix; rewrite <- Fabs_correct; auto;unfold Fabs, FtoR; simpl. apply Rmult_le_compat; auto with real zarith. apply Rle_trans with (Zpred (Zpower_nat radix precision));[rewrite <- pGivesBound|idtac]. apply Rle_IZR;apply Zle_Zpred; auto with float. unfold Zpred; rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ; auto with real zarith. rewrite <- L; apply Rle_powerRZ; auto with real zarith. apply Rle_trans with (2*(powerRZ radix (Zpred precision))*(powerRZ radix (Fexp x))-2*(powerRZ radix (Fexp x)))%R. apply Rle_trans with (((powerRZ radix (precision+1))-4)*(powerRZ radix (Fexp x-1)))%R;[apply Rmult_le_compat_r; auto with real zarith|idtac]. rewrite powerRZ_add; auto with real zarith; simpl. apply Rplus_le_reg_l with (-(powerRZ 2 precision)+4)%R. ring_simplify. apply Rle_trans with (powerRZ 2 2)%R; auto with real zarith. simpl; ring_simplify (2*(2*1))%R; auto with real zarith. apply Rle_trans with (3+1)%R; auto with real; right; ring. apply Rle_powerRZ; auto with arith zarith real. replace (2*powerRZ radix (Fexp x))%R with (4*powerRZ radix (Fexp x -1))%R. pattern 2%R at 3 in |-*; replace 2%R with (powerRZ radix 1%Z);[idtac|simpl; ring]. repeat rewrite <- powerRZ_add; auto with real zarith. replace (1+Zpred precision+Fexp x)%Z with ((precision+1)+(Fexp x-1))%Z;[idtac|unfold Zpred; ring]. rewrite powerRZ_add with (n:=(precision+1)%Z);auto with real zarith; right;ring. unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl; field. unfold Rminus; apply Rplus_le_compat;[rewrite Rmult_assoc; apply Rmult_le_compat_l; auto with real|apply Ropp_le_contravar]. unfold FtoRradix; rewrite <- Fabs_correct; auto; unfold FtoR, Fabs; simpl. apply Rmult_le_compat_r; auto with real zarith. apply Rmult_le_reg_l with radix; auto with real zarith. pattern (IZR radix) at 1 in |-*; replace (IZR radix) with (powerRZ radix 1%Z);[idtac|simpl; ring]. rewrite <- powerRZ_add; auto with real zarith; elim Nx; intros. replace (1+Zpred precision)%Z with (Z_of_nat precision)%Z;[idtac|unfold Zpred; ring]. apply Rle_trans with (IZR (Zpos (vNum bo)));[rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; auto with real zarith|idtac]. apply Rle_trans with (IZR (Zabs (radix * Fnum x))); auto with real zarith. rewrite Zabs_Zmult; rewrite Zabs_eq; auto with real zarith. rewrite mult_IZR; auto with real. replace 4%R with (2*2%nat)%R; [rewrite Rmult_assoc; apply Rmult_le_compat_l; auto with real|simpl;ring]. replace (x+-r)%R with (-(r-x))%R;[rewrite Rabs_Ropp|ring]. apply Rle_trans with (Fulp bo radix precision x). unfold FtoRradix; apply ClosestUlp; auto. rewrite CanonicFulp; auto with real zarith. right; unfold FtoR; simpl; ring. left; auto. case H3; intros V. left; generalize V; unfold FNeven; rewrite FcanonicFnormalizeEq; auto with zarith. rewrite FcanonicFnormalizeEq; auto with zarith. elim Nx; intros; left; split; auto with zarith. elim H1; intros; split; simpl; auto with zarith. left; auto. right; intros. apply trans_eq with (2*(FtoR radix (Float (Fnum q0) (Zpred (Fexp q0)))))%R. unfold FtoR, Zpred; simpl; rewrite powerRZ_add; auto with real zarith; simpl; field; auto with real. apply trans_eq with (2*(FtoR radix x))%R;[idtac|unfold FtoR, Zsucc; simpl; rewrite powerRZ_add; auto with real zarith; simpl; ring]. apply Rmult_eq_compat_l; apply V. replace r with ((2*r)/2)%R;[idtac|field; auto with real]. apply Half_Closest_Round; auto. apply Zle_trans with (1:=U). fold (Zpred (Fexp x)); cut (Fexp x <= Fexp q0)%Z; auto with zarith. apply Zle_trans with (Fexp (Fnormalize radix bo precision q0)). apply Fcanonic_Rle_Zle with radix bo precision; auto with zarith. left; auto. apply FnormalizeCanonic; auto with arith. elim H1; auto. generalize ClosestMonotone; unfold MonotoneP; intros. repeat rewrite <- Fabs_correct; auto. apply H4 with bo (Rabs r) (Rabs (2*r))%R. rewrite Rabs_mult; rewrite (Rabs_right 2%R); try apply Rle_ge; auto with real. apply Rle_lt_trans with (1*Rabs r)%R;[right;ring|apply Rmult_lt_compat_r; auto with real]. apply Rabs_pos_lt;unfold not;intros. absurd (is_Fzero x). apply FnormalNotZero with radix bo ; auto. apply is_Fzero_rep2 with radix; auto. cut (0 <= FtoR radix x)%R; intros. cut (FtoR radix x <= 0)%R; intros; auto with real. apply RleRoundedLessR0 with bo precision (Closest bo radix) r; auto with real. apply ClosestRoundedModeP with precision; auto. apply RleRoundedR0 with bo precision (Closest bo radix) r; auto with real. apply ClosestRoundedModeP with precision; auto. apply ClosestFabs with precision; auto. apply ClosestFabs with precision; auto. generalize ClosestCompatible; unfold CompatibleP; intros T. apply T with (2*r)%R q0; auto with real float zarith. apply sym_eq;apply FnormalizeCorrect; auto. apply FnormalizeBounded; auto with zarith. elim H1; auto. apply FcanonicLeastExp with radix bo precision; auto with zarith float. apply sym_eq; apply FnormalizeCorrect; auto. elim H1; auto. apply FnormalizeCanonic; auto with zarith;elim H1; auto. Qed. Theorem EvenClosestMonotone2: forall (p q : R) (p' q' : float), (p <= q)%R -> (EvenClosest bo radix precision p p') -> (EvenClosest bo radix precision q q') -> (p' <= q')%R. intros. case H; intros H2. generalize EvenClosestMonotone; unfold MonotoneP. intros W; unfold FtoRradix. apply W with bo precision p0 q0; auto. generalize EvenClosestUniqueP; unfold UniqueP. intros W; unfold FtoRradix. right; apply W with bo precision p0; auto with real. rewrite H2; auto. Qed. Theorem Fulp_le_twice_r_round: forall (x y:float) (r:R), (0 <= x)%R -> (Fbounded bo x) -> (Fnormal radix bo y) -> (- dExp bo <= Fexp y - 1)%Z -> (x<=2*r)%R -> (EvenClosest bo radix precision r y) -> ((Fulp bo radix precision x) <= 2*(Fulp bo radix precision y))%R. intros x y r H H0 H1 U H2 H3. assert (2*y=(Float (Fnum y) (Zsucc (Fexp y))))%R. unfold FtoRradix, FtoR, Zsucc; simpl; rewrite powerRZ_add; auto with real zarith; simpl; ring. apply Rle_trans with (Fulp bo radix precision (Float (Fnum y) (Zsucc (Fexp y)))). 2:right; rewrite CanonicFulp; auto; [rewrite CanonicFulp|left]; auto. 2:unfold FtoR, Zsucc; simpl; rewrite powerRZ_add; auto with real zarith. 2:simpl; ring. 2:left; auto. 2:elim H1; intros H6 H5; elim H6; intros. 2:split; simpl; auto with zarith. 2:split; simpl; auto with zarith. apply LeFulpPos; auto with real. elim H1; intros H6 H5; elim H6; intros;split; simpl; auto with zarith. apply EvenClosestMonotone2 with x (2*r)%R; auto. unfold FtoRradix; apply RoundedModeProjectorIdem with (b:=bo) (P:=(EvenClosest bo radix precision)); auto. apply EvenClosestRoundedModeP; auto. apply Twice_EvenClosest_Round; auto. Qed. Theorem discri1: (delta <= 2*(Fulp bo radix precision d))%R. apply Rle_trans with (1:=delta_inf). case (Rle_or_lt q p); intros H1. case (Rle_or_lt 0%R q); intros H2. cut (2*(Fulp bo radix precision q)<=(Fulp bo radix precision p))%R; try intros H3. cut ((Fulp bo radix precision p)<=2*(Fulp bo radix precision d))%R; try intros H4. apply Rle_trans with ((/ 2 * Fulp bo radix precision d + (/ 2 * (2*Fulp bo radix precision d) + / 2 * Fulp bo radix precision d)))%R. apply Rplus_le_compat; auto with real. apply Rplus_le_compat; auto with real. apply Rmult_le_compat_l; auto with real. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (1:=H3); auto with real. right; field; auto with real. apply Fulp_le_twice_r_round with (p-q)%R; auto. apply P_positive. apply Rplus_le_reg_l with (2*q-p)%R. ring_simplify. apply Rmult_le_reg_l with 2%R; auto with real. apply Rplus_le_reg_l with (p-3*q)%R. ring_simplify. apply Rle_trans with (1:=Firstcase); rewrite Rabs_right. right; ring. apply Rle_ge; apply Rplus_le_reg_l with q; ring_simplify; auto with real. apply Fulp_le_twice_l; auto. apply Rmult_le_reg_l with 2%R; auto with real. apply Rplus_le_reg_l with (p-3*q)%R. ring_simplify. apply Rle_trans with (1:=Firstcase); rewrite Rabs_right. right; ring. apply Rle_ge; apply Rplus_le_reg_l with q; ring_simplify; auto with real. apply Rle_trans with ((/ 2 * Fulp bo radix precision d + (/ 2 * (Fulp bo radix precision d) + / 2 * Fulp bo radix precision d)))%R. apply Rplus_le_compat; auto with real. apply Rplus_le_compat; auto with real. apply Rmult_le_compat; auto with real. unfold Fulp; auto with real zarith. apply LeFulpPos; auto with real. fold FtoRradix; apply P_positive. fold FtoRradix; apply EvenClosestMonotone2 with p (p-q)%R; auto. apply Rle_trans with (p-0)%R; unfold Rminus; auto with real; right;ring. unfold FtoRradix; apply RoundedModeProjectorIdem with (b:=bo) (P:=(EvenClosest bo radix precision)); auto. apply EvenClosestRoundedModeP; auto. apply Rmult_le_compat; auto with real. unfold Fulp; auto with real zarith. rewrite FulpFabs; auto. apply LeFulpPos; auto with real. split; auto with zarith float. rewrite Fabs_correct; auto with real. fold FtoRradix; apply EvenClosestMonotone2 with (-q)%R (p-q)%R; auto. generalize P_positive; intros; auto with real. apply Rle_trans with (0-q)%R; unfold Rminus; auto with real; right;ring. replace (-q)%R with (FtoRradix (Fabs q)). unfold FtoRradix; apply RoundedModeProjectorIdem with (b:=bo) (P:=(EvenClosest bo radix precision)); auto. apply EvenClosestRoundedModeP; auto. split; auto with zarith float. unfold FtoRradix;rewrite Fabs_correct; auto with real; rewrite Rabs_left; auto with real. apply Rle_trans with ((3*/2)*(Fulp bo radix precision d))%R. right; field; auto with real. apply Rmult_le_compat_r;auto with zarith real. unfold Fulp; auto with zarith real. apply Rmult_le_reg_l with 2%R;auto with real. apply Rle_trans with 3%R; auto with real. right; field; auto with real. replace 3%R with (IZR 3); auto with real zarith. replace 4%R with (IZR 4); auto with real zarith. simpl; ring. simpl; ring. cut (2*(Fulp bo radix precision p)<=(Fulp bo radix precision q))%R; try intros H3. cut ((Fulp bo radix precision q)<=2*(Fulp bo radix precision d))%R; try intros H4. apply Rle_trans with ((/ 2 * Fulp bo radix precision d + (/ 2 * (Fulp bo radix precision d) + / 2 * (2*Fulp bo radix precision d))))%R. apply Rplus_le_compat; auto with real. apply Rplus_le_compat; auto with real. apply Rmult_le_compat_l; auto with real. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (1:=H3); auto with real. right; field; auto with real. assert (p-q <=0)%R. apply Rplus_le_reg_l with q. ring_simplify; auto with real. rewrite FulpFabs with bo radix precision d; auto. apply Fulp_le_twice_r_round with (Rabs (p-q))%R; auto. apply Rle_trans with p; auto with real; apply P_positive. apply FnormalFabs; auto. rewrite Rabs_left; auto with real. apply Rmult_le_reg_l with 2%R; auto with real. apply Rplus_le_reg_l with (p-q)%R. ring_simplify. apply Rle_trans with (1:=Firstcase); rewrite Rabs_left1; auto. right; ring. generalize EvenClosestSymmetric; unfold SymmetricP; intros. rewrite Rabsolu_left1; auto with real. replace (Fabs d) with (Fopp d). apply H0; auto. unfold Fabs, Fopp; replace (Zabs (Fnum d)) with (-(Fnum d))%Z; auto. rewrite <- Zabs_Zopp; rewrite Zabs_eq; auto with zarith. cut (Fnum d <= 0)%Z; auto with zarith. apply R0LeFnum with radix; auto. apply RleRoundedLessR0 with bo precision (EvenClosest bo radix precision) (p-q)%R; auto with real zarith. apply EvenClosestRoundedModeP; auto. apply Fulp_le_twice_l; auto. apply P_positive. apply Rmult_le_reg_l with 2%R; auto with real. apply Rplus_le_reg_l with (-3*p+q)%R. ring_simplify. apply Rle_trans with (1:=Firstcase); rewrite Rabs_left1; auto. right; ring. apply Rplus_le_reg_l with q. ring_simplify; auto with real. Qed. End Discriminant1. Section Discriminant2. Variable bo : Fbound. Variable precision : nat. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ TwoMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum bo) = Zpower_nat radix precision. Variables a b b' c p q t dp dq s d:float. Let delta := (Rabs (d-(b*b'-a*c)))%R. Hypothesis Fa : (Fbounded bo a). Hypothesis Fb : (Fbounded bo b). Hypothesis Fb': (Fbounded bo b'). Hypothesis Fc : (Fbounded bo c). Hypothesis Fp : (Fbounded bo p). Hypothesis Fq : (Fbounded bo q). Hypothesis Fd : (Fbounded bo d). Hypothesis Ft : (Fbounded bo t). Hypothesis Fs : (Fbounded bo s). Hypothesis Fdp: (Fbounded bo dp). Hypothesis Fdq: (Fbounded bo dq). Hypothesis Cs:(Fcanonic radix bo s). (** There is no underflow *) Hypothesis U1: (- dExp bo <= (Fexp t)-1)%Z. Hypothesis U2: (powerRZ radix (-dExp bo+2*precision-1) <= Rabs (b*b'))%R. Hypothesis U3: (powerRZ radix (-dExp bo+2*precision-1) <= Rabs (a*c))%R. Hypothesis Np:(Fnormal radix bo p). Hypothesis Nq:(Fnormal radix bo q). Hypothesis Nd:(Fnormal radix bo d). Hypothesis Square:(0 <=b*b')%R. Hypothesis Roundp : (EvenClosest bo radix precision (b*b')%R p). Hypothesis Roundq : (EvenClosest bo radix precision (a*c)%R q). Hypothesis Secondcase : (3*(Rabs (p-q)) < p+q)%R. Hypothesis Roundt : (EvenClosest bo radix precision (p-q)%R t). Hypothesis dpEq : (FtoRradix dp=b*b'-p)%R. Hypothesis dqEq : (FtoRradix dq=a*c-q)%R. Hypothesis Rounds : (EvenClosest bo radix precision (dp-dq)%R s). Hypothesis Roundd : (EvenClosest bo radix precision (t+s)%R d). Hypothesis p_differ_q:~(p=q)%R. Theorem Q_positive:(0 < q)%R. case (Rle_or_lt q 0%R); auto; intros. absurd (3*(Rabs (p-q)) < (Rabs (p-q)))%R. apply Rle_not_lt; apply Rle_trans with (1*(Rabs (p-q)))%R; auto with real. apply Rmult_le_compat_r; auto with real. apply Rle_trans with (IZR 1); auto with real. apply Rle_trans with (IZR 3); auto with real zarith. simpl; auto with real zarith. apply Rlt_le_trans with (1:=Secondcase). apply Rle_trans with (2:=Rabs_triang_inv p q). right; rewrite Rabs_right. rewrite Rabs_left1; auto with real; ring. apply Rle_ge; apply P_positive with bo precision b b'; auto. Qed. Theorem Q_le_two_P:(q <= 2*p)%R. fold FtoRradix; apply Rmult_le_reg_l with 2%R; auto with real; simpl. apply Rle_trans with (3*q-q)%R; [right; ring|idtac]. pattern (FtoRradix q) at 1; rewrite <- (Rabs_right q). 2: apply Rle_ge; generalize Q_positive; auto with real. pattern (FtoRradix q) at 1; replace (FtoRradix q) with (-(p-q)+p)%R;[idtac|ring]. apply Rle_trans with (3*(Rabs (-(p-q))+(Rabs p))-q)%R. unfold Rminus; apply Rplus_le_compat_r. apply Rmult_le_compat_l; auto with real. apply Rle_trans with 2%R; auto with real. apply Rabs_triang. rewrite Rabs_Ropp. rewrite (Rabs_right p). 2:apply Rle_ge; apply P_positive with bo precision b b'; auto. apply Rle_trans with (3 * (Rabs (p - q)) + (3*p - q))%R;[right;ring|idtac]. apply Rle_trans with (p+q+(3*p-q))%R; auto with real. right;ring. Qed. Theorem P_le_two_Q:(p <= 2*q)%R. fold FtoRradix; apply Rmult_le_reg_l with 2%R; auto with real; simpl. apply Rle_trans with (3*p-p)%R; [right; ring|idtac]. pattern (FtoRradix p) at 1; rewrite <- (Rabs_right p). 2: apply Rle_ge; apply P_positive with bo precision b b'; auto with real. pattern (FtoRradix p) at 1; replace (FtoRradix p) with ((p-q)+q)%R;[idtac|ring]. apply Rle_trans with (3*(Rabs (p-q)+(Rabs q))-p)%R. unfold Rminus; apply Rplus_le_compat_r. apply Rmult_le_compat_l; auto with real. apply Rle_trans with 2%R; auto with real. apply Rabs_triang. rewrite (Rabs_right q). 2: apply Rle_ge; generalize Q_positive; auto with real. apply Rle_trans with (3 * (Rabs (p - q)) + (3*q - p))%R;[right;ring|idtac]. apply Rle_trans with (p+q+(3*q-p))%R; auto with real. right;ring. Qed. Theorem t_exact: (FtoRradix t=p-q)%R. unfold FtoRradix; rewrite <- Fminus_correct; auto with zarith. apply sym_eq; apply RoundedModeProjectorIdemEq with (b:=bo) (P:=(EvenClosest bo radix precision)) (precision:=precision); auto. apply EvenClosestRoundedModeP; auto. 2: rewrite Fminus_correct; auto with zarith. apply Sterbenz; auto. fold FtoRradix; apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (FtoRradix q);[simpl; right; field; auto with real|idtac]. apply Q_le_two_P. fold FtoRradix; simpl; apply P_le_two_Q. Qed. Theorem dp_dq_le:(Rabs (dp-dq) <= (3/2)*(Rmin (Fulp bo radix precision p) (Fulp bo radix precision q)))%R. unfold Rminus; apply Rle_trans with (1:=Rabs_triang dp (-dq)). rewrite Rabs_Ropp;apply Rmult_le_reg_l with (S (S O))%R; auto with real. apply Rle_trans with (S 1 * Rabs dp + S 1*Rabs dq)%R;[right;ring|idtac]. apply Rle_trans with ((Fulp bo radix precision p)+(Fulp bo radix precision q))%R. apply Rplus_le_compat. rewrite dpEq; unfold FtoRradix; apply ClosestUlp; auto. elim Roundp; auto. rewrite dqEq; unfold FtoRradix; apply ClosestUlp; auto. elim Roundq; auto. rewrite <- Rmult_assoc. apply Rle_trans with (3*(Rmin (Fulp bo radix precision p) (Fulp bo radix precision q)))%R;[idtac|apply Rmult_le_compat_r]. 2: unfold Rmin; case (Rle_dec (Fulp bo radix precision p) (Fulp bo radix precision q)); intros H1; unfold Fulp; auto with real zarith. 2: right; simpl; unfold Rdiv; field; auto with real. unfold Rmin; case (Rle_dec (Fulp bo radix precision p) (Fulp bo radix precision q)); intros H1. apply Rle_trans with (Fulp bo radix precision p+2*Fulp bo radix precision p)%R;[apply Rplus_le_compat_l|right;ring]. apply Fulp_le_twice_r; auto with real; fold radix FtoRradix. generalize Q_positive; auto with real. apply Q_le_two_P. apply Rle_trans with (2*Fulp bo radix precision q+Fulp bo radix precision q)%R;[apply Rplus_le_compat_r|right;ring]. apply Fulp_le_twice_r; auto with real; fold radix FtoRradix. apply P_positive with bo precision b b'; auto with real. apply P_le_two_Q. Qed. Theorem EvenClosestFabs : forall (f : float) (r : R), (Fcanonic radix bo f) -> EvenClosest bo radix precision r f -> EvenClosest bo radix precision (Rabs r) (Fabs f). intros. case (Rle_or_lt 0%R r); intros. rewrite Rabs_right; auto with real. unfold Fabs; rewrite Zabs_eq; auto with zarith. apply LeR0Fnum with (radix := radix); auto with zarith. apply RleRoundedR0 with bo precision (EvenClosest bo radix precision) r; auto with float zarith. rewrite Rabs_left; auto with real. replace (Fabs f) with (Fopp f). generalize EvenClosestSymmetric; unfold SymmetricP; auto. unfold Fabs, Fopp; rewrite <- Zabs_Zopp; rewrite Zabs_eq; auto. assert (Fnum f <= 0)%Z; auto with zarith. apply R0LeFnum with (radix:=radix); auto with zarith. apply RleRoundedLessR0 with bo precision (EvenClosest bo radix precision) r; auto with float zarith real. Qed. Theorem discri2: (3*(Rmin (Fulp bo radix precision p) (Fulp bo radix precision q)) <= (Rabs (p-q)))%R -> (delta <= 2*(Fulp bo radix precision d))%R. intros H1; unfold delta. apply Rle_trans with (1 * Fulp bo radix precision d)%R;[ring_simplify (1 * Fulp bo radix precision d)%R | unfold Fulp; auto with real zarith]. replace (d - (b * b' - a * c))%R with ((d-(t+s))+(t+s-b*b'+a*c))%R;[idtac|ring]. apply Rle_trans with (1:=Rabs_triang (d-(t+s))%R (t + s - b * b' + a * c)%R). apply Rmult_le_reg_l with 2%R; auto with real. rewrite Rmult_plus_distr_l. apply Rle_trans with (Fulp bo radix precision d+Fulp bo radix precision d)%R;[idtac|right;ring]. apply Rplus_le_compat. rewrite <- Rabs_Ropp; replace (- (d - (t + s)))%R with ((t+s)-d)%R;[idtac|ring]. replace 2%R with (INR 2); auto with real. unfold FtoRradix; apply ClosestUlp; auto. elim Roundd; auto. rewrite t_exact. replace (p - q + s - b * b' + a * c)%R with (-((dp-dq) - s))%R;[idtac|rewrite dpEq; rewrite dqEq; ring]. rewrite Rabs_Ropp; apply Rle_trans with (Fulp bo radix precision s). unfold FtoRradix; apply ClosestUlp; auto. elim Rounds; auto. rewrite FulpFabs; auto; rewrite FulpFabs with (f:=d); auto. apply LeFulpPos; auto with real zarith float. rewrite Fabs_correct; auto with real. apply EvenClosestMonotone2 with bo precision (Rabs (dp-dq)) (Rabs (t+s))%R; auto. 2: apply EvenClosestFabs; auto; left; auto. 2: apply EvenClosestFabs; auto; left; auto. cut (Rabs (dp - dq) <= (Rabs (p-q))/2)%R. intros H2; cut ((Rabs s) <= (Rabs t)/2)%R. intros H3; apply Rle_trans with (1:=H2). rewrite <- t_exact; apply Rle_trans with ((Rabs t)-(Rabs t)/2)%R. right; unfold Rdiv; field; auto with real. apply Rle_trans with ((Rabs t)-(Rabs s))%R; auto with real. unfold Rminus; apply Rplus_le_compat_l; auto with real. replace (t+s)%R with (t-(-s))%R; [idtac|ring]. apply Rle_trans with ((Rabs t)-(Rabs (-s)))%R;[idtac|apply Rabs_triang_inv]. rewrite Rabs_Ropp; auto with real. assert (t/2=(Float (Fnum t) (Zpred (Fexp t))))%R. unfold FtoRradix, FtoR, Zpred; simpl; rewrite powerRZ_add; auto with real zarith; simpl ; field. unfold Rdiv; rewrite <- (Rabs_right (/2)%R); auto with real. 2: apply Rle_ge; apply Rlt_le; auto with real. rewrite <- Rabs_mult; fold (Rdiv t 2%R). rewrite H; unfold FtoRradix; rewrite <- Fabs_correct; auto. rewrite <- Fabs_correct; auto. apply EvenClosestMonotone2 with bo precision (Rabs (dp-dq))%R (Rabs (p-q)/2)%R; auto. apply EvenClosestFabs; auto; left; auto. replace (Rabs (p - q) / 2)%R with (FtoRradix (Fabs (Float (Fnum t) (Zpred (Fexp t))))). unfold FtoRradix; apply RoundedModeProjectorIdem with (b:=bo) (P:=(EvenClosest bo radix precision)); auto. apply EvenClosestRoundedModeP; auto. split; simpl; auto with zarith float. rewrite Zabs_eq; auto with zarith float. unfold FtoRradix; rewrite Fabs_correct; auto; fold FtoRradix; rewrite <- H. rewrite t_exact; unfold Rdiv; rewrite Rabs_mult; auto with real. rewrite (Rabs_right (/2)%R); auto with real. apply Rle_ge; apply Rlt_le; auto with real. apply Rle_trans with (1:=dp_dq_le). apply Rmult_le_reg_l with 2%R; auto with real; unfold Rdiv. rewrite <- Rmult_assoc. replace (2*(3*/2))%R with 3%R;[idtac|field; auto with real]. apply Rle_trans with (1:=H1). right; field; auto with real. Qed. Theorem discri3: (exists f:float, (Fbounded bo f) /\ (FtoRradix f)=(dp-dq)%R) -> (delta <= 2*(Fulp bo radix precision d))%R. intros T; elim T; intros f T1; elim T1; intros H1 H2; clear T T1. unfold delta. replace (d - (b * b' - a * c))%R with (-((t+s)-d))%R. apply Rmult_le_reg_l with (INR 2); auto with arith real. apply Rle_trans with (Fulp bo radix precision d). rewrite Rabs_Ropp; unfold FtoRradix; apply ClosestUlp; auto. elim Roundd; auto. simpl; apply Rle_trans with (1*(1*(Fulp bo radix precision d)))%R; unfold Fulp; auto with real zarith. right; ring. apply Rmult_le_compat; auto with real zarith. ring_simplify (1 * powerRZ radix (Fexp (Fnormalize radix bo precision d)))%R; auto with real zarith. replace (FtoRradix s) with (dp-dq)%R. rewrite dpEq; rewrite dqEq; rewrite t_exact; ring. rewrite <- H2. unfold FtoRradix; apply RoundedModeProjectorIdemEq with (b:=bo) (P:=(EvenClosest bo radix precision)) (precision:=precision); auto with real. apply EvenClosestRoundedModeP; auto. fold FtoRradix; rewrite H2; auto. Qed. Theorem errorBoundedMultClosest_Can: forall f1 f2 g : float, Fbounded bo f1 -> Fbounded bo f2 -> Closest bo radix (f1* f2) g -> (powerRZ radix (-dExp bo+2*precision-1) <= Rabs (f1*f2))%R -> Fcanonic radix bo g -> (exists s : float, Fbounded bo s /\ (FtoRradix s = f1*f2 - g)%R /\ Fexp s = (Fexp g - precision)%Z /\ (Rabs (Fnum s) <= powerRZ radix (Zpred precision))%R). intros. generalize errorBoundedMultClosest; intros T. elim T with (b:=bo) (radix:=radix) (precision:=precision) (p:=f1) (q:=f2) (pq:=g); auto with zarith real; clear T; fold FtoRradix. intros g' T1; elim T1; intros dg T2; elim T2; intros H5 T3; elim T3; intros H6 T4; elim T4; intros H7 T5; elim T5; intros H8 T6; elim T6; intros H9 H10; clear T1 T2 T3 T4 T5 T6. exists dg; split; auto; split. rewrite <- H8; auto with real. split; [replace g with g'; auto with zarith|idtac]. apply FcanonicUnique with radix bo precision; auto with arith. apply Rmult_le_reg_l with (powerRZ radix (Fexp dg)); auto with zarith real. apply Rle_trans with (Rabs dg);[right; unfold FtoRradix, FtoR|idtac]. rewrite Rabs_mult;rewrite (Rabs_right (powerRZ radix (Fexp dg)));auto with real. apply Rle_ge; auto with real zarith. rewrite H9; rewrite <- powerRZ_add; auto with real zarith. apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix precision g'). unfold FtoRradix; apply ClosestUlp; auto. replace g' with g; auto. apply FcanonicUnique with radix bo precision; auto with arith. rewrite CanonicFulp; auto. right; apply trans_eq with (powerRZ radix (Fexp g'));[unfold FtoR; simpl; ring|idtac]. apply trans_eq with ((powerRZ radix 1%Z)*(powerRZ radix (Fexp dg+Zpred precision)))%R;[rewrite <- powerRZ_add; auto with zarith real|simpl; ring]. rewrite H10; unfold Zpred; auto with zarith real. ring_simplify (1 + (Fexp g' - precision + (precision + -1)))%Z; auto with real. assert (- dExp bo + 2 * precision - 1 < 2*precision+Fexp f1+Fexp f2)%Z; auto with zarith. apply Zlt_powerRZ with radix; auto with real zarith. apply Rle_lt_trans with (1:=H2). rewrite Rabs_mult; unfold FtoRradix; repeat rewrite <- Fabs_correct; auto. replace (2*precision)%Z with (precision+precision)%Z; auto with zarith. unfold FtoR, Fabs; simpl. repeat rewrite powerRZ_add; auto with real zarith. repeat rewrite <- Rmult_assoc; apply Rmult_lt_compat_r; auto with real zarith. apply Rle_lt_trans with (Zabs (Fnum f1)*Zabs (Fnum f2) * powerRZ 2 (Fexp f1))%R; [right; ring| apply Rmult_lt_compat_r; auto with real zarith]. apply Rle_lt_trans with (Zabs (Fnum f1)* powerRZ 2 precision)%R. apply Rmult_le_compat_l; auto with real zarith. apply Rle_trans with (Zpos (vNum bo)); auto with real zarith float. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; auto with real. apply Rmult_lt_compat_r; auto with real zarith. apply Rlt_le_trans with (Zpos (vNum bo)); auto with real zarith float. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; auto with real. rewrite FcanonicFnormalizeEq; auto with zarith. assert (powerRZ radix (- dExp bo + 2 * precision - 1) <= Rabs g)%R. cut (exists f:float, Fbounded bo f /\ (FtoRradix f=(powerRZ radix (- dExp bo + 2 * precision - 1)))%R). intros T; elim T; intros f T'; elim T'; intros; clear T T'. rewrite <- H5; unfold FtoRradix. apply RoundAbsMonotonel with bo precision (Closest bo radix) (f1*f2)%R; auto with zarith float real. apply ClosestRoundedModeP with precision; auto with zarith. fold FtoRradix; rewrite H5; auto. exists (Float 1 (-dExp bo+2*precision-1)). split;[split|idtac]. simpl; apply vNumbMoreThanOne with radix precision; auto with zarith. apply Zle_trans with (- dExp bo + 2 * precision - 1)%Z; auto with zarith. unfold FtoRradix, FtoR; simpl; ring. assert (- dExp bo + 2 * precision - 1 < precision+Fexp g)%Z; auto with zarith. apply Zlt_powerRZ with radix; auto with zarith real. apply Rle_lt_trans with (1:=H4). unfold FtoRradix; rewrite <- Fabs_correct; auto. rewrite powerRZ_add; auto with real zarith. unfold FtoR, Fabs; simpl. apply Rmult_lt_compat_r; auto with real zarith. apply Rlt_le_trans with (Zpos (vNum bo)). elim H1; auto with real zarith float. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; auto with real zarith. Qed. Theorem discri4: (Fexp p)=(Fexp q) -> (delta <= 2*(Fulp bo radix precision d))%R. intros H1; apply discri3. generalize errorBoundedMultClosest_Can; intros T. elim T with (f1:=b) (f2:=b') (g:=p); auto with zarith real; clear T. intros dp' T2; elim T2; intros H2 T3; elim T3; intros H3 T4; elim T4; intros H4 H5; clear T2 T3 T4. 2: elim Roundp; auto. generalize errorBoundedMultClosest_Can; intros T. elim T with (f1:=a) (f2:=c) (g:=q); auto with zarith real; clear T. intros dq' T2; elim T2; intros H2' T3; elim T3; intros H3' T4; elim T4; intros H4' H5'; clear T2 T3 T4. 2: elim Roundq; auto. 2: left; auto. 2: left; auto. assert ((Rabs (Fnum dp'-Fnum dq') < (powerRZ radix precision))%R \/ (((Rabs dp')= (powerRZ radix (Zpred (Fexp p))))%R /\ ((Rabs dq')= (powerRZ radix (Zpred (Fexp p))))%R)). case H5; intros. left; unfold Rminus; apply Rle_lt_trans with (1:=Rabs_triang (Fnum dp') (-(Fnum dq'))%R). rewrite Rabs_Ropp. apply Rlt_le_trans with ((powerRZ radix (Zpred precision)) +(Rabs (Fnum dq')))%R; auto with real zarith. apply Rle_trans with ((powerRZ radix (Zpred precision))+ (powerRZ radix (Zpred precision)))%R; auto with real zarith. right; unfold Zpred; repeat rewrite powerRZ_add; auto with real zarith. simpl; field. case H5'; intros. left; unfold Rminus; apply Rle_lt_trans with (1:=Rabs_triang (Fnum dp') (-(Fnum dq'))%R); rewrite Rabs_Ropp. apply Rle_lt_trans with ((powerRZ radix (Zpred precision)) +(Rabs (Fnum dq')))%R; auto with real zarith. apply Rlt_le_trans with ((powerRZ radix (Zpred precision))+ (powerRZ radix (Zpred precision)))%R; auto with real zarith. right; unfold Zpred; repeat rewrite powerRZ_add; auto with real zarith. simpl; field. right; unfold FtoRradix, FtoR;repeat rewrite Rabs_mult. rewrite (Rabs_right (powerRZ radix (Fexp dp'))); try apply Rle_ge; auto with real zarith. rewrite (Rabs_right (powerRZ radix (Fexp dq'))); try apply Rle_ge; auto with real zarith. rewrite H; rewrite H0. repeat rewrite <- powerRZ_add; auto with real zarith. rewrite H4'; rewrite H4; unfold Zpred. ring_simplify (precision + -1 + (Fexp p - precision))%Z; ring_simplify (precision + -1 + (Fexp q - precision))%Z; ring_simplify (Fexp p+-1)%Z; rewrite <- H1; auto with zarith real. case H; clear H; intros H. exists (Float ((Fnum dp')-(Fnum dq'))%Z (Fexp dq')). split; [split; auto with zarith|idtac]. simpl; apply Zlt_Rlt. rewrite pGivesBound;rewrite Zpower_nat_Z_powerRZ; auto. rewrite <- Rabs_Zabs; unfold Zminus; rewrite plus_IZR; rewrite Ropp_Ropp_IZR; auto with real zarith. simpl; auto with zarith float. rewrite dpEq; rewrite dqEq; rewrite <- H3; rewrite <- H3'. unfold FtoRradix, FtoR; simpl. unfold Zminus; rewrite plus_IZR; rewrite Ropp_Ropp_IZR; replace (Fexp dp') with (Fexp dq');[ring|idtac]. rewrite H4'; rewrite <- H1; auto with zarith. rewrite dpEq; rewrite dqEq; rewrite <- H3; rewrite <- H3'. elim H; unfold Rabs; case (Rcase_abs dp'); case (Rcase_abs dq'); intros. exists (Float 0%Z 0%Z); split;[split; auto with zarith|idtac]. simpl; case (dExp bo); auto with zarith. apply trans_eq with (-(-dp')+-dq')%R;[rewrite H0; rewrite H6; unfold FtoRradix, FtoR;simpl|idtac];ring. exists (Float (-2)%Z (Zpred (Fexp p))); split;[split; simpl; auto with zarith|idtac]. rewrite pGivesBound; apply Zle_lt_trans with (Zpower_nat radix 1); auto with zarith. apply Zle_trans with (Fexp dp'); auto with zarith float. apply trans_eq with (-(-dp')+-dq')%R;[rewrite H0; rewrite H6; unfold FtoRradix, FtoR; simpl|idtac];ring. exists (Float 2%Z (Zpred (Fexp p))); split;[split;simpl;auto with zarith|idtac]. rewrite pGivesBound; apply Zle_lt_trans with (Zpower_nat radix 1); auto with zarith. apply Zle_trans with (Fexp dp'); auto with zarith float. unfold Rminus;rewrite H0; rewrite H6; unfold FtoRradix, FtoR;simpl; ring. exists (Float 0%Z 0%Z); split;[split; auto with zarith|idtac]. simpl; case (dExp bo); auto with zarith. rewrite H0; rewrite H6; unfold FtoRradix, FtoR; simpl;ring. Qed. End Discriminant2. Section Discriminant3. Variable bo : Fbound. Variable precision : nat. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ TwoMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum bo) = Zpower_nat radix precision. Variables a b b' c p q t dp dq s d:float. Let delta := (Rabs (d-(b*b'-a*c)))%R. Hypothesis Fa : (Fbounded bo a). Hypothesis Fb : (Fbounded bo b). Hypothesis Fb': (Fbounded bo b'). Hypothesis Fc : (Fbounded bo c). Hypothesis Fp : (Fbounded bo p). Hypothesis Fq : (Fbounded bo q). Hypothesis Fd : (Fbounded bo d). Hypothesis Ft : (Fbounded bo t). Hypothesis Fs : (Fbounded bo s). Hypothesis Fdp: (Fbounded bo dp). Hypothesis Fdq: (Fbounded bo dq). Hypothesis Cs:(Fcanonic radix bo s). (** There is no underflow *) Hypothesis U1: (- dExp bo <= (Fexp d)-1)%Z. Hypothesis U2: (powerRZ radix (-dExp bo+2*precision-1) <= Rabs (b*b'))%R. Hypothesis U3: (powerRZ radix (-dExp bo+2*precision-1) <= Rabs (a*c))%R. Hypothesis Np:(Fnormal radix bo p). Hypothesis Nq:(Fnormal radix bo q). Hypothesis Nd:(Fnormal radix bo d). Hypothesis Square:(0 <=b*b')%R. Hypothesis Roundp : (EvenClosest bo radix precision (b*b')%R p). Hypothesis Roundq : (EvenClosest bo radix precision (a*c)%R q). Hypothesis p_pos:(0 <= p)%R. Hypothesis q_pos:(0 <= q)%R. Hypothesis Secondcase : (3*(Rabs (p-q)) < p+q)%R. Hypothesis Roundt : (EvenClosest bo radix precision (p-q)%R t). Hypothesis dpEq : (FtoRradix dp=b*b'-p)%R. Hypothesis dqEq : (FtoRradix dq=a*c-q)%R. Hypothesis Rounds : (EvenClosest bo radix precision (dp-dq)%R s). Hypothesis Roundd : (EvenClosest bo radix precision (t+s)%R d). Hypothesis p_differ_q:~(p=q)%R. Variable e:Z. Hypothesis p_eqF : p=(Float (Zpower_nat radix (pred precision)) (Zsucc e)). Hypothesis p_eqR : (FtoRradix p)=(powerRZ radix (precision+e)%Z). Hypothesis q_eqExp : (Fexp q)=e. Theorem discri5: (0 < dp*dq)%R -> (delta <= 2*(Fulp bo radix precision d))%R. intros. unfold FtoRradix, delta; apply discri3 with p q t dp dq s; auto. assert (forall f1 f2 g : float, Fbounded bo f1 -> Fbounded bo f2 -> Closest bo 2 (FtoR 2 f1 * FtoR 2 f2) g -> (powerRZ (Zpos 2) (- dExp bo + 2 * precision - 1) <= Rabs (FtoR 2 f1 * FtoR 2 f2))%R -> Fcanonic 2 bo g -> exists s : float, Fbounded bo s /\ FtoR 2 s = (FtoR 2 f1 * FtoR 2 f2 - FtoR 2 g)%R /\ Fexp s = (Fexp g - precision)%Z /\ (Rabs (Fnum s) <= powerRZ (Zpos 2) (Zpred precision))%R). apply errorBoundedMultClosest_Can; auto. fold radix in H0; fold FtoRradix in H0. elim H0 with (f1:=b) (f2:=b') (g:=p); auto with zarith real. intros dp' T2; elim T2; intros H2 T3; elim T3; intros H3 T4; elim T4; intros H4 H5; clear T2 T3 T4. 2: elim Roundp; auto. elim H0 with (f1:=a) (f2:=c) (g:=q); auto with zarith real; clear H0. intros dq' T2; elim T2; intros H2' T3; elim T3; intros H3' T4; elim T4; intros H4' H5'; clear T2 T3 T4. 2: elim Roundq; auto. 2: left; auto. 2: left; auto. fold radix; fold FtoRradix; rewrite dpEq; rewrite dqEq; rewrite <- H3; rewrite <- H3'. exists (Fminus radix dp' dq'); split. 2: unfold FtoRradix; rewrite Fminus_correct; auto with real. unfold Fminus, Fopp, Fplus; simpl. repeat rewrite H4'; repeat rewrite q_eqExp; repeat rewrite H4. replace (Fexp p) with (Zsucc e); [idtac|rewrite p_eqF; auto]. rewrite Zmin_le2; auto with zarith. split; auto with zarith. simpl; unfold Zsucc. ring_simplify (e + 1 - precision - (e - precision))%Z; ring_simplify (e - precision - (e - precision))%Z. simpl. unfold nat_of_P, Zpower_nat; simpl. replace ( - Fnum dq' * 1)%Z with (- Fnum dq')%Z; [idtac|ring]. apply Zlt_Rlt. rewrite pGivesBound;rewrite Zpower_nat_Z_powerRZ; auto. rewrite <- Rabs_Zabs; rewrite plus_IZR;rewrite mult_IZR;rewrite Ropp_Ropp_IZR. assert (forall (x y z:R), (0 < x*y)%R -> (Rabs x <= z)%R -> (Rabs y <= z)%R -> (Rabs (2*x-y) < 2*z)%R). intros. unfold Rabs; case (Rcase_abs (2*x-y)%R); case (Rle_or_lt 0%R x); intros. case H7; intros;ring_simplify (- (2 * x - y))%R. assert (-x <0)%R; auto with real. apply Rlt_le_trans with (-2*0+y)%R; auto with real. apply Rplus_lt_compat_r; repeat rewrite Ropp_mult_distr_l_reverse; auto with real. ring_simplify (-2*0+y)%R; apply Rle_trans with z; auto with real. apply Rle_trans with (2:=H6); apply RRle_abs. apply Rle_trans with (1*z)%R; auto with real. apply Rmult_le_compat_r; auto with real. apply Rle_trans with (2:=H1); auto with real. Contradict H0; rewrite <- H8; auto with real. ring_simplify (0*y)%R; auto with real. ring_simplify (- (2 * x - y))%R. apply Rlt_le_trans with (-2*x+0)%R;[apply Rplus_lt_compat_l|idtac]. apply Rmult_lt_reg_l with (-x)%R; auto with real. apply Rle_lt_trans with (-(x*y))%R; auto with real. apply Rlt_le_trans with (-0)%R; auto with real; right;ring. apply Rle_trans with (2*(-x))%R;[right;ring|apply Rmult_le_compat_l; auto with real]. apply Rle_trans with (2:=H1); rewrite <- Rabs_Ropp; apply RRle_abs. apply Rlt_le_trans with (2*x-0)%R;[unfold Rminus; apply Rplus_lt_compat_l|idtac]. apply Ropp_lt_contravar; apply Rmult_lt_reg_l with x; auto with real. case H7; auto with real. intros H8; Contradict H0; rewrite <- H8; ring_simplify (0*y)%R; auto with real. ring_simplify (x*0)%R; auto with real. apply Rle_trans with (2*x)%R;[right;ring|apply Rmult_le_compat_l; auto with real]. apply Rle_trans with (2:=H1); apply RRle_abs. apply Rlt_le_trans with (2*0-y)%R; [unfold Rminus; apply Rplus_lt_compat_r; apply Rmult_lt_compat_l; auto with real|idtac]. apply Rle_trans with (-y)%R;[right;ring|apply Rle_trans with z]. apply Rle_trans with (2:=H6); rewrite <- Rabs_Ropp; apply RRle_abs. apply Rle_trans with (1*z)%R;[right;ring|apply Rmult_le_compat_r; auto with real]. apply Rle_trans with (2:=H1); auto with real. replace (Fnum dp' * Zpos 2+-Fnum dq')%R with (2*(Fnum dp')-Fnum dq')%R; auto with real zarith. apply Rlt_le_trans with (2*powerRZ radix (Zpred precision))%R. apply H0; auto. apply Rmult_lt_reg_l with (powerRZ radix (Fexp dq')); auto with real zarith. apply Rmult_lt_reg_l with (powerRZ radix (Fexp dp')); auto with real zarith. apply Rle_lt_trans with 0%R;[right;ring|apply Rlt_le_trans with (1:=H)]. rewrite dpEq; rewrite dqEq; rewrite <- H3; rewrite <- H3'. unfold FtoRradix, FtoR; right; ring. right; unfold Zpred, Zminus; rewrite powerRZ_add; auto with real zarith. simpl; field; apply Rmult_integral_contrapositive; split; auto with real. simpl; ring. simpl;rewrite <-q_eqExp; rewrite <- H4'; auto with zarith float. Qed. Theorem discri6: (0< dp)%R -> (dq < 0)%R -> (delta <= 2*(Fulp bo radix precision d))%R. intros;unfold delta. replace (d - (b * b' - a * c))%R with (-((t+s)-d)+-((dp-dq)-s))%R. 2: rewrite dpEq; rewrite dqEq; unfold FtoRradix, radix; rewrite t_exact with bo precision b b' p q t; auto; ring. apply Rle_trans with (1:=Rabs_triang (-(t+s-d))%R (-(dp-dq-s))%R). apply Rmult_le_reg_l with (INR 2); auto with real zarith;rewrite Rmult_plus_distr_l. apply Rle_trans with ((Fulp bo radix precision d)+(Fulp bo radix precision s))%R;[apply Rplus_le_compat|idtac]. rewrite Rabs_Ropp; unfold FtoRradix; apply ClosestUlp; auto. elim Roundd; auto. rewrite Rabs_Ropp; unfold FtoRradix; apply ClosestUlp; auto. elim Rounds; auto. apply Rle_trans with ((Fulp bo radix precision d+ 3* Fulp bo radix precision d))%R;[apply Rplus_le_compat_l|simpl;right;ring]. apply Rle_trans with (2*Fulp bo radix precision d)%R;[idtac|unfold Fulp; auto with real zarith]. rewrite FulpFabs; auto; rewrite FulpFabs with bo radix precision d; auto. assert (2*(Fabs d)=(Float (Fnum (Fabs d)) (Zsucc (Fexp (Fabs d)))))%R. unfold FtoRradix, FtoR, Zsucc; simpl; rewrite powerRZ_add; auto with real zarith; simpl; ring. apply Rle_trans with (Fulp bo radix precision (Float (Fnum (Fabs d)) (Zsucc (Fexp (Fabs d))))). 2:assert (Fnormal radix bo (Fabs d));[apply FnormalFabs; auto|idtac]. 2:right; rewrite CanonicFulp; auto; [rewrite CanonicFulp|left]; auto. 2:unfold FtoR, Zsucc; simpl; rewrite powerRZ_add; auto with real zarith. 2:simpl; ring. 2:left; auto. 2:elim H2; intros H6 H5; elim H6; intros. 2:split; simpl; auto with zarith. 2:split; simpl; auto with zarith. apply LeFulpPos; auto with real float. assert (Fnormal radix bo (Fabs d));[apply FnormalFabs; auto|idtac]. elim H2; intros H6 H5; elim H6; intros;split; simpl; auto with zarith. rewrite Fabs_correct; auto with real zarith. apply EvenClosestMonotone2 with bo precision (Rabs (dp-dq))%R (2*Rabs (t+s))%R; auto. 2: apply EvenClosestFabs; auto; left; auto. 2: apply Twice_EvenClosest_Round; auto. 2: apply FnormalFabs; auto. 2: apply EvenClosestFabs; auto; left; auto. unfold Rminus; apply Rle_trans with (1:=Rabs_triang dp (-dq)%R). apply Rmult_le_reg_l with (INR 2); auto with real zarith; rewrite Rmult_plus_distr_l. apply Rle_trans with (Fulp bo radix precision p+Fulp bo radix precision q)%R;[apply Rplus_le_compat|idtac]. rewrite dpEq; unfold FtoRradix; apply ClosestUlp; auto. elim Roundp; auto. rewrite Rabs_Ropp; rewrite dqEq; unfold FtoRradix; apply ClosestUlp; auto. elim Roundq; auto. rewrite CanonicFulp; auto with float;[idtac|left; auto]. rewrite CanonicFulp; auto with float;[idtac|left; auto]. apply Rle_trans with (3*(powerRZ radix e))%R;[right|idtac]. unfold FtoRradix, FtoR; simpl; rewrite q_eqExp; rewrite p_eqF; simpl. unfold Zsucc; rewrite powerRZ_add; auto with real zarith; simpl;ring. assert ((powerRZ radix e <= t))%R. unfold FtoRradix, radix; rewrite t_exact with bo precision b b' p q t; auto. fold radix; fold FtoRradix; rewrite p_eqR. apply Rle_trans with (powerRZ radix (precision + e) - ((powerRZ radix precision - 1) * powerRZ radix e))%R; auto with real. rewrite powerRZ_add; auto with real zarith; right;ring. unfold Rminus; apply Rplus_le_compat_l; auto with real. apply Ropp_le_contravar. unfold FtoRradix, FtoR; rewrite q_eqExp; apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (1:=(RRle_abs (Fnum q))). assert (Zabs (Fnum q) < Zpower_nat radix precision)%Z; auto with real zarith float. rewrite <- pGivesBound; auto with zarith float. rewrite Rabs_Zabs; apply Rle_trans with (Zpred (Zpower_nat radix precision)); auto with real zarith. unfold Zpred; rewrite plus_IZR. rewrite Zpower_nat_Z_powerRZ; right; simpl; ring. assert (0<=s)%R. unfold FtoRradix; apply RleRoundedR0 with bo precision (EvenClosest bo radix precision) (dp-dq)%R; auto with real. apply EvenClosestRoundedModeP; auto. apply Rle_trans with (0-0)%R; unfold Rminus; auto with real. apply Rplus_le_compat; auto with real. rewrite Rabs_right; auto with real. 2: apply Rle_ge; apply Rle_trans with (0+0)%R; auto with real. 2: apply Rplus_le_compat; auto with real zarith. 2: apply Rle_trans with (2:=H2); auto with real zarith. apply Rle_trans with (4*powerRZ radix e)%R;[apply Rmult_le_compat_r; auto with real zarith|idtac]. replace 3%R with (INR 3);[idtac|simpl; ring]. replace 4%R with (INR 4);[auto with real zarith|simpl;ring]. apply Rle_trans with (4*(t+s))%R;[apply Rmult_le_compat_l; auto with real|simpl; right; ring]. replace 4%R with (INR 4);[auto with real zarith|simpl;ring]. apply Rle_trans with (powerRZ radix e+0)%R;[idtac|apply Rplus_le_compat];auto with real. Qed. Theorem discri7: (dp < 0)%R -> (0 < dq)%R -> (delta <= 2*(Fulp bo radix precision d))%R. intros L1 L2. unfold delta, FtoRradix; apply discri3 with p q t dp dq s; auto. assert (H0:forall f1 f2 g : float, Fbounded bo f1 -> Fbounded bo f2 -> Closest bo 2 (FtoR 2 f1 * FtoR 2 f2) g -> (powerRZ (Zpos 2) (- dExp bo + 2 * precision - 1) <= Rabs (FtoR 2 f1 * FtoR 2 f2))%R -> Fcanonic 2 bo g -> exists s : float, Fbounded bo s /\ FtoR 2 s = (FtoR 2 f1 * FtoR 2 f2 - FtoR 2 g)%R /\ Fexp s = (Fexp g - precision)%Z /\ (Rabs (Fnum s) <= powerRZ (Zpos 2) (Zpred precision))%R). apply errorBoundedMultClosest_Can; auto. fold radix in H0; fold FtoRradix in H0. elim H0 with (f1:=b) (f2:=b') (g:=p); auto with zarith real. intros dp' T2; elim T2; intros H2 T3; elim T3; intros H3 T4; elim T4; intros H4 H5; clear T2 T3 T4. 2: elim Roundp; auto. elim H0 with (f1:=a) (f2:=c) (g:=q); auto with zarith real; clear H0. intros dq' T2; elim T2; intros H2' T3; elim T3; intros H3' T4; elim T4; intros H4' H5'; clear T2 T3 T4. 2: elim Roundq; auto. 2: left; auto. 2: left; auto. cut (exists dp'':float, (Fexp dp''=Fexp dq' /\ (FtoRradix dp''=dp')%R /\ (Rabs (Fnum dp'') <= powerRZ radix (Zpred precision))%R)). intros T; elim T; intros dp'' T1; elim T1; intros H4'' T2; elim T2; intros H5'' H6''; clear T T1 T2. assert ((Rabs (Fnum dp''-Fnum dq') < (powerRZ radix precision))%R \/ (((Rabs dp'')= (powerRZ radix (Zpred (Fexp q))))%R /\ ((Rabs dq')= (powerRZ radix (Zpred (Fexp q))))%R)). case H6''; intros. left; unfold Rminus; apply Rle_lt_trans with (1:=Rabs_triang (Fnum dp'') (-(Fnum dq'))%R). rewrite Rabs_Ropp. apply Rlt_le_trans with ((powerRZ radix (Zpred precision)) +(Rabs (Fnum dq')))%R; auto with real zarith. apply Rle_trans with ((powerRZ radix (Zpred precision))+ (powerRZ radix (Zpred precision)))%R; auto with real zarith. right; unfold Zpred; repeat rewrite powerRZ_add; auto with real zarith. simpl; field. case H5'; intros. left; unfold Rminus; apply Rle_lt_trans with (1:=Rabs_triang (Fnum dp'') (-(Fnum dq'))%R); rewrite Rabs_Ropp. apply Rle_lt_trans with ((powerRZ radix (Zpred precision)) +(Rabs (Fnum dq')))%R ; auto with real zarith. apply Rlt_le_trans with ((powerRZ radix (Zpred precision))+ (powerRZ radix (Zpred precision)))%R; auto with real zarith. right; unfold Zpred; repeat rewrite powerRZ_add; auto with real zarith. simpl; field. right; unfold FtoRradix, FtoR;repeat rewrite Rabs_mult. rewrite (Rabs_right (powerRZ radix (Fexp dp''))); try apply Rle_ge; auto with real zarith. rewrite (Rabs_right (powerRZ radix (Fexp dq'))); try apply Rle_ge; auto with real zarith. rewrite H; rewrite H0. repeat rewrite <- powerRZ_add; auto with real zarith. rewrite H4''; rewrite H4'; unfold Zpred. ring_simplify (precision + -1 + (Fexp q - precision))%Z; ring_simplify (precision + -1 + (Fexp q - precision))%Z; ring_simplify (Fexp q+-1)%Z; auto with zarith real. case H; intros V; clear H. exists (Float (Fnum dp''-Fnum dq') (Fexp dq')). split;[split; auto with zarith|idtac]. simpl; apply Zlt_Rlt. rewrite pGivesBound;rewrite Zpower_nat_Z_powerRZ; auto. rewrite <- Rabs_Zabs; unfold Zminus; rewrite plus_IZR; rewrite Ropp_Ropp_IZR; auto with real zarith. simpl; auto with zarith float. fold radix; fold FtoRradix; rewrite dpEq; rewrite dqEq. rewrite <- H3'; rewrite <- H3;rewrite <- H5''. unfold FtoRradix, FtoR; simpl. unfold Zminus; rewrite plus_IZR; rewrite Ropp_Ropp_IZR. rewrite H4''; ring. exists (Float (-1)%Z (Fexp q)). split;[split; simpl; auto with zarith|idtac]. rewrite pGivesBound; apply Zle_lt_trans with (Zpower_nat radix 0); auto with zarith. elim Roundq; auto with zarith float. fold radix; fold FtoRradix; elim V; intros. replace (FtoRradix dp) with (-(-dp))%R;[idtac|ring]. rewrite <- (Rabs_left dp); auto with real. rewrite <- (Rabs_right dq); auto with real. 2: apply Rle_ge; auto with real. rewrite dpEq; rewrite <- H3; rewrite <- H5''; rewrite H. rewrite dqEq; rewrite <- H3'; rewrite H0. unfold FtoRradix, FtoR, Zpred; simpl. repeat rewrite powerRZ_add; auto with real zarith; simpl; field. assert (FtoRradix dp'=(Float (2*Fnum dp') (Zpred (Fexp dp'))))%R. unfold FtoRradix, FtoR, Zpred. apply trans_eq with ((2 * Fnum dp')%Z*(powerRZ radix (Fexp dp'+-1)))%R;[auto|idtac]. rewrite mult_IZR;rewrite powerRZ_add; auto with real zarith; simpl; field. simpl; auto with real. exists (Float (2*Fnum dp') (Zpred (Fexp dp'))); split. simpl; rewrite H4'; rewrite H4. rewrite q_eqExp; rewrite p_eqF; unfold Zpred, Zsucc;simpl; auto with zarith. split; auto with real. apply Rmult_le_reg_l with (powerRZ radix (Zpred (Fexp dp'))); auto with real zarith. rewrite <- powerRZ_add; auto with real zarith. rewrite <- (Rabs_right (powerRZ radix (Zpred (Fexp dp'))));auto with real. 2: apply Rle_ge; auto with real zarith. rewrite <- Rabs_mult. replace (powerRZ radix (Zpred (Fexp dp')) * Fnum (Float (2 * Fnum dp') (Zpred (Fexp dp'))))%R with (FtoRradix dp'); auto with real. 2: rewrite H; unfold FtoRradix, FtoR; simpl; auto with real. rewrite H3; rewrite <- dpEq. rewrite H4; unfold Zpred;ring_simplify (Fexp p - precision + -1 + (precision + -1))%Z. rewrite Rabs_left; auto with real. apply Rmult_le_reg_l with 2%R; auto with real. apply Rplus_le_reg_l with (FtoRradix dp). ring_simplify (dp+2*(-dp))%R. rewrite <- Rabs_left; auto with real. assert (Fbounded bo (Float (Zpred (Zpower_nat radix precision)) e)). split; auto with zarith. simpl; rewrite pGivesBound; auto with zarith. rewrite Zabs_eq; auto with zarith. simpl; rewrite <- q_eqExp; elim Roundq; auto with zarith float. rewrite <- Rabs_Ropp. replace (-dp)%R with (p-b*b')%R; [idtac|rewrite dpEq;ring]. elim Roundp; intros K1 K2; elim K1; intros K3 K4. apply Rle_trans with (Rabs ((Float (Zpred (Zpower_nat radix precision)) e)-b*b')). unfold FtoRradix; apply K4; auto. clear K1 K2 K3 K4; rewrite Rabs_left1. rewrite dpEq; rewrite p_eqR. apply Rle_trans with (b*b'-(powerRZ radix precision -1)*(powerRZ radix e))%R. unfold FtoRradix, FtoR, Zpred, radix; simpl. rewrite plus_IZR; simpl; right; ring_simplify. rewrite Zpower_nat_Z_powerRZ; auto with real zarith; simpl; ring. unfold Rminus; rewrite Rplus_assoc; apply Rplus_le_compat_l. replace (Fexp p) with (Zsucc e);[unfold Zsucc|rewrite p_eqF; simpl; auto with zarith]. ring_simplify (e+1-2)%Z; unfold Zminus. repeat rewrite powerRZ_add; auto with real zarith; simpl; right; field. apply Rplus_le_reg_l with (p-(Float (Zpred (Zpower_nat radix precision)) e))%R. apply Rle_trans with (-(b*b'-p))%R;[right;ring|idtac]. rewrite <- dpEq; rewrite <- Rabs_left; auto with real. rewrite dpEq; apply Rmult_le_reg_l with (INR 2); auto with real zarith. apply Rle_trans with (Fulp bo radix precision p). unfold FtoRradix; apply ClosestUlp; auto. elim Roundp; auto. rewrite CanonicFulp; auto;[idtac|left; auto]. replace (Fexp p) with (Zsucc e);[unfold Zsucc|rewrite p_eqF; simpl; auto with zarith]. rewrite p_eqR; unfold FtoRradix, FtoR, Zpred; simpl. rewrite plus_IZR; rewrite Zpower_nat_Z_powerRZ; auto with real zarith. repeat rewrite powerRZ_add; auto with real zarith; simpl; right; field. Qed. Theorem discri8: (delta <= 2*(Fulp bo radix precision d))%R. case (Rle_or_lt 0%R dp); intros H;[case H; clear H; intros H|idtac]. case (Rle_or_lt 0%R dq); intros H';[case H'; clear H'; intros H'|idtac]. apply discri5; auto with real. apply Rle_lt_trans with (dp*0)%R;[right;ring|auto with real]. unfold FtoRradix, delta; apply discri3 with p q t dp dq s; auto. exists dp; split; auto. fold radix; fold FtoRradix; rewrite <- H'; ring. apply discri6; auto. unfold FtoRradix, delta; apply discri3 with p q t dp dq s; auto. exists (Fopp dq); split; auto with float zarith. rewrite Fopp_correct; fold radix; fold FtoRradix; rewrite <- H; ring. case (Rle_or_lt 0%R dq); intros H';[case H'; clear H'; intros H'|idtac]. apply discri7; auto. unfold FtoRradix, delta; apply discri3 with p q t dp dq s; auto. exists dp; split; auto. fold radix; fold FtoRradix; rewrite <- H'; ring. apply discri5; auto. apply Rle_lt_trans with (-dp*0)%R;[right;ring|idtac]. apply Rlt_le_trans with ((-dp)*(-dq))%R;[auto with real|right;ring]. Qed. End Discriminant3. Section Discriminant4. Variable bo : Fbound. Variable precision : nat. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ TwoMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum bo) = Zpower_nat radix precision. Variables a b c p q t dp dq s d:float. Let delta := (Rabs (d-(b*b-a*c)))%R. Hypothesis Fa : (Fbounded bo a). Hypothesis Fb : (Fbounded bo b). Hypothesis Fc : (Fbounded bo c). Hypothesis Fp : (Fbounded bo p). Hypothesis Fq : (Fbounded bo q). Hypothesis Fd : (Fbounded bo d). Hypothesis Ft : (Fbounded bo t). Hypothesis Fs : (3*(Rabs (p-q)) < p+q)%R -> (Fbounded bo s). Hypothesis Fdp: (3*(Rabs (p-q)) < p+q)%R -> (Fbounded bo dp). Hypothesis Fdq: (3*(Rabs (p-q)) < p+q)%R -> (Fbounded bo dq). Hypothesis Cs:(3*(Rabs (p-q)) < p+q)%R -> (Fcanonic radix bo s). (** There is no underflow *) Hypothesis U0: (- dExp bo <= (Fexp d)-1)%Z. Hypothesis U1: (- dExp bo <= (Fexp t)-1)%Z. Hypothesis U2: (powerRZ radix (-dExp bo+2*precision-1) <= Rabs (b*b))%R. Hypothesis U3: (powerRZ radix (-dExp bo+2*precision-1) <= Rabs (a*c))%R. Hypothesis Np:(Fnormal radix bo p). Hypothesis Nq:(Fnormal radix bo q). Hypothesis Nd:(Fnormal radix bo d). Hypothesis Roundp : (EvenClosest bo radix precision (b*b)%R p). Hypothesis Roundq : (EvenClosest bo radix precision (a*c)%R q). Hypothesis Firstcase : (p+q <= 3*(Rabs (p-q)))%R -> (EvenClosest bo radix precision (p-q)%R d). Hypothesis SRoundt : (3*(Rabs (p-q)) < p+q)%R -> (EvenClosest bo radix precision (p-q)%R t). Hypothesis SdpEq : (3*(Rabs (p-q)) < p+q)%R -> (FtoRradix dp=b*b-p)%R. Hypothesis SdqEq : (3*(Rabs (p-q)) < p+q)%R -> (FtoRradix dq=a*c-q)%R. Hypothesis SRounds : (3*(Rabs (p-q)) < p+q)%R -> (EvenClosest bo radix precision (dp-dq)%R s). Hypothesis SRoundd : (3*(Rabs (p-q)) < p+q)%R -> (EvenClosest bo radix precision (t+s)%R d). Theorem discri9: (delta <= 2*(Fulp bo radix precision d))%R. assert (Square:(0<=b*b)%R). apply Rle_trans with (Rsqr b); auto with real. case (Rle_or_lt (p + q)%R (3 * Rabs (p - q))%R); intros. unfold delta;apply discri1 with p q; auto. case (Rle_or_lt (3*(Rmin (Fulp bo radix precision p) (Fulp bo radix precision q)))%R (Rabs (p-q))%R); intros. unfold delta; apply discri2 with p q t dp dq s; auto. case (Zle_or_lt (Fexp q) (Fexp p)); intros. case (Zle_lt_or_eq (Fexp q) (Fexp p)); auto;intros. assert (Fexp q = Zpred (Fexp p))%Z. cut (Zle (Fexp q) (Zpred (Fexp p))); auto with zarith. cut (Zle (Zpred (Fexp p)) (Fexp q)); auto with zarith. clear H1;apply Zle_powerRZ with radix; auto with real zarith. apply Rle_trans with (Fulp bo radix precision (Float (Fnum p) (Zpred (Fexp p)))). rewrite CanonicFulp; auto. unfold FtoR; simpl; right; ring. left; split; auto with zarith. split; simpl; auto with zarith float. apply Zle_trans with (Fexp q); auto with zarith float. simpl; elim Np; auto with zarith. apply Rle_trans with (Fulp bo radix precision q). apply LeFulpPos; auto with real float zarith. split; simpl; auto with zarith float. apply Zle_trans with (Fexp q); auto with zarith float. apply LeFnumZERO; simpl; auto with real zarith. apply LeR0Fnum with radix; auto with real zarith. apply P_positive with bo precision b b; auto. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (FtoRradix p). unfold FtoRradix, FtoR, Zpred; simpl; rewrite powerRZ_add; auto with real zarith; simpl; right; field. apply P_le_two_Q with bo precision b b; auto. rewrite CanonicFulp; auto with zarith. unfold FtoR; simpl; right; ring. left; auto. clear H1 H2; assert (FtoRradix p=powerRZ radix (precision+Zpred (Fexp p)))%R. case (Zle_lt_or_eq (Zpower_nat radix (pred precision)) (Fnum p)). elim Np; intros. apply Zmult_le_reg_r with radix; auto with zarith. apply Zlt_gt; auto with zarith. apply Zle_trans with (Zpower_nat radix precision). pattern radix at 2 in |-*; replace radix with (Zpower_nat radix 1). rewrite <- Zpower_nat_is_exp; auto with zarith. simpl; auto with zarith. rewrite <- pGivesBound; apply Zle_trans with (1:=H2). rewrite Zabs_eq; auto with zarith. cut (0<=Fnum p)%Z; auto with zarith. apply LeR0Fnum with radix; auto. apply P_positive with bo precision b b; auto. intros H1; Contradict H0. apply Rle_not_lt. rewrite CanonicFulp; auto; [idtac|left; auto]. rewrite CanonicFulp; auto; [idtac|left; auto]. replace (FtoR radix (Float (S 0) (Fexp p))) with (powerRZ radix (Fexp p));[idtac|unfold FtoR; simpl; ring]. replace (FtoR radix (Float (S 0) (Fexp q))) with (powerRZ radix (Fexp q));[idtac|unfold FtoR; simpl; ring]. rewrite H3; unfold Rmin. case (Rle_dec (powerRZ radix (Fexp p)) (powerRZ radix (Zpred (Fexp p)))); auto with real zarith; intros J. Contradict J; apply Rlt_not_le; auto with real zarith. clear J; rewrite Rabs_right. unfold FtoRradix, FtoR, Rminus. apply Rle_trans with ((Zsucc (Zpower_nat radix (pred precision))*(powerRZ radix (Fexp p))+-((Zpred (Zpower_nat radix precision))*(powerRZ radix (Fexp q)))))%R. unfold Zpred, Zsucc; rewrite plus_IZR; rewrite plus_IZR; repeat rewrite Zpower_nat_Z_powerRZ. rewrite inj_pred; auto with zarith. rewrite H3; unfold Zpred; simpl; right;ring_simplify. repeat rewrite powerRZ_add; auto with real zarith; simpl; field. apply Rplus_le_compat;[apply Rmult_le_compat_r; auto with real zarith|idtac]. apply Ropp_le_contravar; apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (1:=RRle_abs (Fnum q)). rewrite Rabs_Zabs; rewrite <- pGivesBound;auto with zarith float. elim Fq; intros; auto with zarith. apply Rle_IZR;apply Zle_Zpred; auto. apply Rle_ge; apply Rlt_le; apply Rplus_lt_reg_r with q. ring_simplify. unfold FtoRradix; apply FcanonicPosFexpRlt with bo precision; auto with zarith. apply Rlt_le; apply Q_positive with bo precision b b p; auto. apply P_positive with bo precision b b; auto. left; auto. left; auto. intros H1; unfold FtoRradix, FtoR; rewrite <- H1. rewrite Zpower_nat_Z_powerRZ; rewrite <- powerRZ_add; auto with real zarith. rewrite inj_pred; auto with zarith. replace (Zpred precision+Fexp p)%Z with (precision + Zpred (Fexp p))%Z;[auto with real|unfold Zpred; ring]. unfold delta; apply discri8 with p q t dp dq s (Zpred (Fexp p)); auto. apply FcanonicUnique with radix bo precision; auto with zarith real. left; auto. left; split; [split;simpl|idtac]; auto with zarith. rewrite Zabs_eq; auto with zarith. rewrite pGivesBound; auto with zarith. apply Zle_trans with (Fexp p); auto with zarith float. unfold Zsucc, Zpred; auto with zarith. simpl (Fnum (Float (Zpower_nat 2 (pred precision)) (Zsucc (Zpred (Fexp p))))). replace radix with (Zpower_nat radix 1);[idtac|simpl; auto with zarith]. simpl (Fnum {| Fnum := Zpower_nat 2 (pred precision); Fexp := Fexp p + -1 + 1 |} ). rewrite <-Zpower_nat_is_exp; rewrite pGivesBound; auto with zarith. rewrite Zabs_eq; auto with zarith. fold FtoRradix; rewrite H1; unfold FtoRradix, FtoR, Zpred, Zsucc; simpl. rewrite Zpower_nat_Z_powerRZ; rewrite <- powerRZ_add; auto with real zarith. rewrite inj_pred; auto with zarith; unfold Zpred. replace (precision + -1 + (Fexp p + -1 + 1))%Z with (precision+(Fexp p+-1))%Z; auto with real; ring. unfold delta;apply discri4 with p q t dp dq s; auto. assert (Fexp p = Zpred (Fexp q))%Z. cut (Zle (Fexp p) (Zpred (Fexp q))); auto with zarith. cut (Zle (Zpred (Fexp q)) (Fexp p)); auto with zarith. clear H1;apply Zle_powerRZ with radix; auto with real zarith. apply Rle_trans with (Fulp bo radix precision (Float (Fnum q) (Zpred (Fexp q)))). rewrite CanonicFulp; auto. unfold FtoR; simpl; right; ring. left; split; auto with zarith. split; simpl; auto with zarith float. assert (exists s : float, Fbounded bo s /\ FtoR 2 s = (FtoR 2 a * FtoR 2 c - FtoR 2 q)%R /\ Fexp s = (Fexp q - precision)%Z /\ (Rabs (Fnum s) <= powerRZ (Zpos 2) (Zpred precision))%R). apply errorBoundedMultClosest_Can; auto. elim Roundq; auto. left; auto. elim H1; intros s' T; elim T; intros T1 T2; elim T2; intros T3 T4; elim T4; intros. apply Zle_trans with (Fexp q - precision)%Z; auto with zarith float. rewrite <- H2; auto with zarith float. simpl; elim Nq; auto with zarith. apply Rle_trans with (Fulp bo radix precision p). apply LeFulpPos; auto with real float zarith. split; simpl; auto with zarith float. assert (exists s : float, Fbounded bo s /\ FtoR 2 s = (FtoR 2 a * FtoR 2 c - FtoR 2 q)%R /\ Fexp s = (Fexp q - precision)%Z /\ (Rabs (Fnum s) <= powerRZ (Zpos 2) (Zpred precision))%R). apply errorBoundedMultClosest_Can; auto. elim Roundq; auto. left; auto. elim H1; intros s' T; elim T; intros T1 T2; elim T2; intros T3 T4; elim T4; intros. apply Zle_trans with (Fexp q - precision)%Z; auto with zarith float. rewrite <- H2; auto with zarith float. apply LeFnumZERO; simpl; auto with real zarith. apply LeR0Fnum with radix; auto with real zarith. apply Rlt_le; apply Q_positive with bo precision b b p; auto. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (FtoRradix q). unfold FtoRradix, FtoR, Zpred; simpl; rewrite powerRZ_add; auto with real zarith; simpl; right; field. apply Q_le_two_P with bo precision b b; auto. rewrite CanonicFulp; auto with zarith. unfold FtoR; simpl; right; ring. left; auto. clear H1; assert (FtoRradix q=powerRZ radix (precision+Zpred (Fexp q)))%R. case (Zle_lt_or_eq (Zpower_nat radix (pred precision)) (Fnum q)). elim Nq; intros. apply Zmult_le_reg_r with radix; auto with zarith. apply Zlt_gt; auto with zarith. apply Zle_trans with (Zpower_nat radix precision). pattern radix at 2 in |-*; replace radix with (Zpower_nat radix 1). rewrite <- Zpower_nat_is_exp; auto with zarith. simpl; auto with zarith. rewrite <- pGivesBound; apply Zle_trans with (1:=H3). rewrite Zabs_eq; auto with zarith. cut (0<=Fnum q)%Z; auto with zarith. apply LeR0Fnum with radix; auto. apply Rlt_le; apply Q_positive with bo precision b b p; auto. intros H1; Contradict H0. apply Rle_not_lt. rewrite CanonicFulp; auto; [idtac|left; auto]. rewrite CanonicFulp; auto; [idtac|left; auto]. replace (FtoR radix (Float (S 0) (Fexp p))) with (powerRZ radix (Fexp p));[idtac|unfold FtoR; simpl; ring]. replace (FtoR radix (Float (S 0) (Fexp q))) with (powerRZ radix (Fexp q));[idtac|unfold FtoR; simpl; ring]. rewrite H2; unfold Rmin. case (Rle_dec (powerRZ radix (Zpred (Fexp q))) (powerRZ radix (Fexp q))); auto with real zarith; intros J. clear J; rewrite Rabs_left1. unfold FtoRradix, FtoR, Rminus. apply Rle_trans with (- ((Zpred (Zpower_nat radix precision)) * powerRZ radix (Fexp p) + - ((Zsucc (Zpower_nat radix (pred precision))) * powerRZ radix (Fexp q))))%R. unfold Zpred, Zsucc; rewrite plus_IZR; rewrite plus_IZR; repeat rewrite Zpower_nat_Z_powerRZ. rewrite inj_pred; auto with zarith. rewrite H2; unfold Zpred; simpl; right. repeat rewrite powerRZ_add; auto with real zarith; simpl; field. apply Ropp_le_contravar. apply Rplus_le_compat;[apply Rmult_le_compat_r; auto with real zarith|idtac]. 2:apply Ropp_le_contravar; apply Rmult_le_compat_r; auto with real zarith. apply Rle_trans with (1:=RRle_abs (Fnum p)). rewrite Rabs_Zabs; rewrite <- pGivesBound;auto with zarith float. elim Fp; intros; auto with zarith. apply Rle_IZR;apply Zle_Zpred; auto. apply Rlt_le; apply Rplus_lt_reg_r with q. ring_simplify. unfold FtoRradix; apply FcanonicPosFexpRlt with bo precision; auto with zarith. 2:apply Rlt_le; apply Q_positive with bo precision b b p; auto. apply P_positive with bo precision b b; auto. left; auto. left; auto. Contradict J; auto with real zarith. intros H1; unfold FtoRradix, FtoR; rewrite <- H1. rewrite Zpower_nat_Z_powerRZ; rewrite <- powerRZ_add; auto with real zarith. rewrite inj_pred; auto with zarith. replace (Zpred precision+Fexp q)%Z with (precision + Zpred (Fexp q))%Z;[auto with real|unfold Zpred; ring]. unfold delta; rewrite <-Rabs_Ropp. replace (- (d - (b * b - a * c)))%R with (Fopp d-(a*c-b*b))%R;[idtac|unfold FtoRradix; rewrite Fopp_correct; ring]. replace (Fulp bo radix precision d) with (Fulp bo radix precision (Fopp d)); auto with float zarith. 2: unfold Fulp; rewrite Fnormalize_Fopp; unfold Fopp; simpl; auto with real zarith. apply discri8 with q p (Fopp t) dq dp (Fopp s) (Zpred (Fexp q)); auto with float zarith. apply FnormalFop; auto. fold radix; fold FtoRradix; case (Rle_or_lt 0%R (a*c)%R); auto. intros H3; absurd (0 < q)%R. apply Rle_not_lt; unfold FtoRradix; apply RleRoundedLessR0 with bo precision (EvenClosest bo radix precision) (a*c)%R; auto with real. apply EvenClosestRoundedModeP; auto. apply Q_positive with bo precision b b p; auto. fold radix; fold FtoRradix; rewrite (Rplus_comm q p). replace (q-p)%R with (-(p-q))%R; auto with real; rewrite Rabs_Ropp; auto. fold radix; fold FtoRradix; replace (q-p)%R with (-(p-q))%R; auto with real. generalize EvenClosestSymmetric; unfold SymmetricP;intros T; apply T; auto. fold radix; fold FtoRradix; replace (dq-dp)%R with (-(dp-dq))%R;auto with real. generalize EvenClosestSymmetric; unfold SymmetricP;intros T; apply T; auto. fold radix; fold FtoRradix; replace (Fopp t+Fopp s)%R with (-(t+s))%R;[idtac|unfold FtoRradix; repeat rewrite Fopp_correct; ring]. generalize EvenClosestSymmetric; unfold SymmetricP;intros T; apply T; auto. apply FcanonicUnique with radix bo precision; auto with zarith real. left; auto. left; split; [split;simpl|idtac]; auto with zarith. rewrite Zabs_eq; auto with zarith. rewrite pGivesBound; auto with zarith. apply Zle_trans with (Fexp q); auto with zarith float. unfold Zsucc, Zpred; auto with zarith. simpl (Fnum (Float (Zpower_nat 2 (pred precision)) (Zsucc (Zpred (Fexp q))))). replace radix with (Zpower_nat radix 1);[idtac|simpl; auto with zarith]. simpl (Fnum {| Fnum := Zpower_nat 2 (pred precision); Fexp := Fexp q + -1 + 1 |}). rewrite <-Zpower_nat_is_exp; rewrite pGivesBound; auto with zarith. rewrite Zabs_eq; auto with zarith. fold FtoRradix; rewrite H1; unfold FtoRradix, FtoR, Zpred, Zsucc; simpl. rewrite Zpower_nat_Z_powerRZ; rewrite <- powerRZ_add; auto with real zarith. rewrite inj_pred; auto with zarith; unfold Zpred. replace (precision + -1 + (Fexp q + -1 + 1))%Z with (precision+(Fexp q+-1))%Z; auto with real; ring. Qed. End Discriminant4. Float8.4/Others/discriminant3.v0000644000423700002640000027775612032774527016304 0ustar sboldotoccataRequire Export discriminant2. Section Discriminant1. Variable bo : Fbound. Variable precision : nat. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Theorem TwoMoreThanOne : (1 < radix)%Z. unfold radix in |- *; red in |- *; simpl in |- *; auto. Qed. Hint Resolve TwoMoreThanOne. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ TwoMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum bo) = Zpower_nat radix precision. Hypothesis precisionGreaterThanThree : 3 <= precision. Theorem RoundLeNormal: forall f:float, forall r:R, Closest bo radix r f -> (Fnormal radix bo f) -> (Rabs f <= Rabs r / (1 - powerRZ radix (- precision)))%R. intros. assert (0 < (1 - powerRZ radix (- precision)))%R. apply Rplus_lt_reg_r with (powerRZ radix (- precision)). ring_simplify. replace 1%R with (powerRZ radix 0); [ auto with real zarith | simpl in |- *; auto ]. apply Rmult_le_reg_l with ((1 - powerRZ radix (- precision)))%R; auto with real. apply Rle_trans with (Rabs r);[idtac|right; field; auto with real]. apply Rplus_le_reg_l with (-Rabs r+Rabs f*powerRZ radix (-precision))%R. apply Rle_trans with (Rabs f-Rabs r)%R;[right; ring|idtac]. apply Rle_trans with (Rabs f * powerRZ radix (- precision) )%R;[idtac|right; ring]. apply Rle_trans with (Rabs (f-r));[apply Rabs_triang_inv|idtac]. replace (f-r)%R with (-(r-f))%R;[rewrite Rabs_Ropp|ring]. apply Rmult_le_reg_l with (INR 2); auto with real. apply Rle_trans with (Fulp bo radix precision f). unfold FtoRradix; apply ClosestUlp; auto. apply Rle_trans with (Rabs f*powerRZ radix (Zsucc (-precision)))%R. unfold FtoRradix; apply FulpLe2; auto. elim H0; auto. rewrite FcanonicFnormalizeEq; auto with zarith. left; auto. right; unfold Zsucc; rewrite powerRZ_add; auto with real zarith; simpl; ring. Qed. Variables a b b' c p q t d u v dp dq:float. Let delta := (Rabs (d-(b*b'-a*c)))%R. Hypothesis Fa : (Fbounded bo a). Hypothesis Fb : (Fbounded bo b). Hypothesis Fb': (Fbounded bo b'). Hypothesis Fc : (Fbounded bo c). Hypothesis Fp : (Fbounded bo p). Hypothesis Fq : (Fbounded bo q). Hypothesis Fd : (Fbounded bo d). Hypothesis Fu : (Fbounded bo u). Hypothesis Fv : (Fbounded bo v). Hypothesis Cand : (Fcanonic radix bo d). (** There is no underflow *) Hypothesis Nq:(Fnormal radix bo q). Hypothesis Np:(Fnormal radix bo p). Hypothesis Nv:(Fnormal radix bo v). Hypothesis Nu:(Fnormal radix bo u). Hypothesis U0: (- dExp bo <= Fexp p - 2)%Z. Hypothesis Square:(0 <=b*b')%R. Hypothesis Roundp : (EvenClosest bo radix precision (b*b')%R p). Hypothesis Roundq : (EvenClosest bo radix precision (a*c)%R q). Hypothesis Roundt : (EvenClosest bo radix precision (p-q)%R t). Hypothesis dDef : d=t. Hypothesis Roundu : (EvenClosest bo radix precision (3*Rabs t)%R u). Hypothesis Roundv : (EvenClosest bo radix precision (p+q)%R v). Hypothesis dpEq : (FtoRradix dp=b*b'-p)%R. Hypothesis dqEq : (FtoRradix dq=a*c-q)%R. Hypothesis Case1 : (3*(Rabs (p-q)) < p+q )%R. Hypothesis Case2 : (v <= u )%R. Theorem IneqEq: (FtoRradix v=u)%R. assert (u <= v)%R; auto with real. generalize (EvenClosestMonotone bo radix precision); unfold MonotoneP. intros L; apply L with (3 * Rabs (p - q))%R (p+q)%R; auto; clear L. generalize (EvenClosestCompatible bo radix precision); unfold CompatibleP. intros L. apply L with (3*Rabs t)%R u; auto. replace (FtoRradix t) with (p-q)%R; auto with real. apply sym_eq; unfold FtoRradix, radix; apply t_exact with bo precision b b'; auto. Qed. Theorem dexact: (FtoRradix d=p-q)%R. unfold FtoRradix, radix; apply t_exact with bo precision b b'; auto. rewrite dDef; auto with real zarith. Qed. Theorem discri10: (q <= p)%R -> (delta <= 2*(Fulp bo radix precision d))%R. intros G. case (Zle_lt_or_eq (Fexp d) (Fexp q)). apply Fcanonic_Rle_Zle with radix bo precision; auto with real zarith. left; auto. fold FtoRradix; rewrite Rabs_right. rewrite Rabs_right. rewrite dexact; apply Rplus_le_reg_l with q. ring_simplify; apply P_le_two_Q with bo precision b b'; auto. apply Rle_ge; left; apply Q_positive with bo precision b b' p; auto. apply Rle_ge; rewrite dexact; apply Rplus_le_reg_l with q. ring_simplify; auto with real. assert ( 0 < 2+(powerRZ radix (-precision)))%R. apply Rle_lt_trans with (0+0)%R; auto with real. apply Rplus_lt_compat; auto with real zarith. assert ((q <= p * (1 + powerRZ radix (1 - precision)) / (2 + powerRZ radix (- precision)))%R). apply Rmult_le_reg_l with (2 + powerRZ radix (- precision))%R; auto with real. apply Rle_trans with (p * (1 + powerRZ radix (1 - precision)))%R;[idtac|right; field; auto with real]. apply Rmult_le_reg_l with 2%R; auto with real. apply Rplus_le_reg_l with (-2*p+p*(powerRZ radix (1-precision))-3*q*(powerRZ radix (1-precision)))%R. apply Rle_trans with ((powerRZ radix (1-precision))*(3*(p-q)))%R;[idtac|right; ring]. apply Rle_trans with ((4*q-2*p)*(1-powerRZ radix (-precision)))%R. right; unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl; ring. assert (0 < (1 - powerRZ radix (- precision)))%R. apply Rplus_lt_reg_r with (powerRZ radix (- precision)). ring_simplify. replace 1%R with (powerRZ radix 0); [ auto with real zarith | simpl in |- *; auto ]. apply Rmult_le_reg_l with (/ (1 - powerRZ radix (- precision)))%R; auto with real. apply Rle_trans with (4 * q - 2 * p)%R;[right; field; auto with real|idtac]. apply Rle_trans with (Fulp bo radix precision v). apply Rle_trans with (((p+q)-v) +- (3*(p-q)-v))%R;[right;ring|idtac]. apply Rle_trans with (Rabs (((p+q)-v) +- (3*(p-q)-v)));[apply RRle_abs|idtac]. apply Rle_trans with (Rabs (((p+q)-v)) +Rabs (- (3*(p-q)-v)))%R;[apply Rabs_triang|idtac]. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (2*(Rabs (((p+q)-v))) +2*Rabs (- (3*(p-q)-v)))%R;[right;ring|idtac]. apply Rle_trans with (Fulp bo radix precision v+Fulp bo radix precision v)%R;[idtac|right;ring]. rewrite Rabs_Ropp; replace 2%R with (INR 2); auto with real zarith. apply Rplus_le_compat; unfold FtoRradix; apply ClosestUlp; auto with zarith. elim Roundv; auto. elim Roundu; intros Y1 Y2. apply ClosestCompatible with (1:=Y1); fold FtoRradix; auto. rewrite <- dDef; rewrite dexact. rewrite Rabs_right; auto with real. apply Rle_ge; apply Rplus_le_reg_l with q; auto with real. ring_simplify (q+0)%R; apply Rle_trans with (1:=G); right; ring. apply sym_eq; apply IneqEq. apply Rle_trans with (Rabs v * powerRZ radix (Zsucc (- precision)))%R. unfold FtoRradix; apply FulpLe2; auto. rewrite FcanonicFnormalizeEq; auto with zarith. left; auto. unfold Zsucc; replace (-precision+1)%Z with (1-precision)%Z; auto with zarith. apply Rle_trans with (((3 * (p - q))*/(1 - powerRZ radix (- precision)))* powerRZ radix (1 - precision))%R; [idtac|right; ring]. apply Rmult_le_compat_r; auto with real zarith. assert (0 <= p-q)%R. apply Rplus_le_reg_l with q; auto with real. ring_simplify (q+0)%R; apply Rle_trans with (1:=G); right; ring. apply Rle_trans with (Rabs (3 * Rabs t) / (1 - powerRZ radix (- precision)))%R. rewrite IneqEq. apply RoundLeNormal; auto. elim Roundu; auto. rewrite <- dDef; rewrite dexact. rewrite Rabs_right;[rewrite Rabs_right; auto with real; right; ring|idtac]. rewrite Rabs_right; auto with real. apply Rle_ge; apply Rle_trans with (3*0)%R; auto with real. apply Rmult_le_compat_l; auto with real. apply Rle_trans with 2%R; auto with real. intros W. case (Zle_lt_or_eq (Fexp q) (Fexp p)). apply Fcanonic_Rle_Zle with radix bo precision; auto with zarith. left; auto. left; auto. assert (0 <= q)%R. left; apply Q_positive with bo precision b b' p; auto. fold FtoRradix; repeat rewrite Rabs_right; auto with real. apply Rle_ge; apply Rle_trans with (1:=H1); auto with real. intros M. assert (exists qq:float, (FtoRradix qq=2*q)%R /\ Fbounded bo qq /\ Fnormal radix bo qq /\ Fnum qq=Fnum q /\ (Fexp qq=Fexp q+1)%Z). exists (Float (Fnum q) ((Fexp q)+1)). elim Nq; intros F1 F2; elim F1; intros. split;[unfold FtoRradix, FtoR; simpl|idtac]. rewrite powerRZ_add; auto with real zarith; simpl; ring. repeat split; simpl; auto with zarith. elim H1; intros qq H1'; elim H1'; intros J1 H2; elim H2; intros J2 H3; elim H3; intros J3 H4; elim H4; intros J4 J5;clear H1' H1 H2 H3 H4. assert (2*q=FSucc bo radix precision p)%R. rewrite <- J1. assert ((FSucc bo radix precision p <= qq)%R /\ (qq <= FSucc bo radix precision p)%R). 2: elim H1; auto with real. split. unfold FtoRradix; apply FSuccProp; auto with real zarith. left; auto. left; auto. fold FtoRradix; rewrite J1. assert (p <= 2*q)%R. apply P_le_two_Q with bo precision b b'; auto. case H1; auto. intros A. absurd (3 * Rabs (p - q) < p + q)%R; auto. apply Rle_not_lt; rewrite A. ring_simplify (2*q-q)%R; rewrite Rabs_right. right; ring. apply Rle_ge; left; apply Q_positive with bo precision b b' p; auto. case (Rle_or_lt qq (FSucc bo radix precision p)); auto; intros N. absurd (FSucc bo radix precision (FSucc bo radix precision p) <= qq)%R. 2: unfold FtoRradix; apply FSuccProp; auto with zarith. 2: apply FSuccCanonic; auto with zarith. 2: left; auto. 2: left; auto. apply Rlt_not_le. apply Rle_lt_trans with (2*(p*(1+powerRZ radix (1-precision))/(2+(powerRZ radix (-precision)))))%R. rewrite J1; apply Rmult_le_compat_l; auto with real. assert (0 < (powerRZ radix precision) - 1)%R. apply Rplus_lt_reg_r with 1%R; ring_simplify. replace 1%R with (powerRZ radix 0); auto with real zarith. apply Rlt_le_trans with (p*(((powerRZ radix precision)+1)/((powerRZ radix precision) -1)))%R. apply Rle_lt_trans with (p*((2 + 2*powerRZ radix (1 - precision)) / (2 + powerRZ radix (- precision))))%R; [right; unfold Rdiv; ring|idtac]. apply Rmult_lt_compat_l. apply Rlt_le_trans with (2:=G). apply Q_positive with bo precision b b' p; auto. apply Rmult_lt_reg_l with (powerRZ radix precision - 1)%R; auto with real. apply Rlt_le_trans with (powerRZ radix precision + 1)%R;[idtac|right; field; auto with real]. apply Rmult_lt_reg_l with (2+powerRZ radix (-precision))%R; auto with real. apply Rle_lt_trans with ((powerRZ radix precision - 1) * ((2 + 2 * powerRZ radix (1 - precision))))%R;[right; field; auto with real|idtac]. apply Rle_lt_trans with (2*powerRZ radix precision+2+-2*powerRZ radix (1-precision))%R; [right; ring_simplify|idtac]. rewrite Rmult_assoc. repeat rewrite <- powerRZ_add; auto with real zarith. ring_simplify (precision+(1-precision))%Z; simpl; ring. apply Rlt_le_trans with (2 * powerRZ radix precision + 2 +1+powerRZ radix (-precision))%R. repeat rewrite Rplus_assoc; repeat apply Rplus_lt_compat_l. apply Rle_lt_trans with (1+0)%R; auto with real. ring_simplify (1+0)%R; apply Rle_trans with 0%R; auto with real. apply Ropp_le_cancel; ring_simplify ( - (-2 * powerRZ radix (1 - precision)))%R. apply Rle_trans with (2*0)%R; auto with real zarith. right; ring. right; ring_simplify. rewrite <- powerRZ_add; auto with real zarith. ring_simplify (precision+-precision)%Z; simpl; ring. apply Rle_trans with (p+2*Fulp bo radix precision p)%R. apply Rmult_le_reg_l with (powerRZ radix precision - 1)%R; auto with real. apply Rle_trans with (p * ((powerRZ radix precision + 1)))%R;[right; field; auto with real|idtac]. apply Rle_trans with ((powerRZ radix precision -1)*p+2*p)%R;[right; ring|idtac]. apply Rle_trans with ((powerRZ radix precision -1)*p + 2*((powerRZ radix precision - 1)* Fulp bo radix precision p))%R;[idtac|right; ring]. apply Rplus_le_compat_l. apply Rmult_le_compat_l; auto with real. apply Rle_trans with (Rabs p);[apply RRle_abs|idtac]. unfold FtoRradix; apply FulpGe; auto. apply Rplus_le_reg_l with (-(FSucc bo radix precision p))%R. apply Rle_trans with (Fminus radix (FSucc bo radix precision (FSucc bo radix precision p)) (FSucc bo radix precision p));[idtac|unfold FtoRradix; rewrite Fminus_correct; auto; right; ring]. unfold FtoRradix; rewrite FSuccDiff1; auto with zarith. rewrite <- CanonicFulp with bo radix precision (FSucc bo radix precision p); auto with zarith. 2:apply FSuccCanonic; auto with zarith; left; auto. apply Rle_trans with (-(Fminus radix (FSucc bo radix precision p) p)+ 2 * Fulp bo radix precision p)%R; [unfold FtoRradix; rewrite Fminus_correct; auto; right; ring|idtac]. unfold FtoRradix; rewrite FSuccDiff1; auto with zarith. rewrite <- CanonicFulp with bo radix precision p; auto with zarith. 2: left; auto. ring_simplify. apply LeFulpPos; auto with zarith. apply FBoundedSuc; auto with zarith. fold FtoRradix; apply P_positive with bo precision b b'; auto. left; apply FSuccLt; auto with zarith. assert (0 < nNormMin radix precision)%Z;[apply nNormPos; auto with zarith|idtac]. assert (0 <= Fnum p)%Z; auto with zarith. apply LeR0Fnum with radix; auto with real zarith. apply P_positive with bo precision b b'; auto. assert (0 < nNormMin radix precision)%Z;[apply nNormPos; auto with zarith|idtac]. assert (0 <= Fnum (FSucc bo radix precision p))%Z; auto with zarith. apply LeR0Fnum with radix; auto with real zarith. apply Rle_trans with (FtoR radix p). apply P_positive with bo precision b b'; auto. left; apply FSuccLt; auto with zarith. assert (Fexp d = Fexp q-1)%Z. assert (Fexp q -1 <= Fexp d)%Z; auto with zarith. apply Zle_trans with (Fexp p-2)%Z; auto with zarith. apply Zle_trans with (Fexp (Float (Fnum p) (Fexp p-2))); auto with zarith. apply Fcanonic_Rle_Zle with radix bo precision; auto with real zarith. elim Np; intros Y1 Y2; elim Y1; intros; left; split;try split; simpl; auto with zarith. apply Rle_trans with (p/4)%R. unfold Rdiv, FtoRradix, FtoR; simpl. rewrite Rabs_mult; repeat rewrite Rabs_right. unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl. ring_simplify (2*1)%R; right; ring. apply Rle_ge; auto with real zarith. apply Rle_ge; assert (0 <= Fnum p)%Z; auto with real zarith. apply LeR0Fnum with radix; auto with real zarith. fold FtoRradix; apply P_positive with bo precision b b'; auto. fold FtoRradix; rewrite dexact. rewrite Rabs_right. 2: apply Rle_ge; apply Rplus_le_reg_l with q. 2: ring_simplify; auto with real. apply Rle_trans with (p- p * (1 + powerRZ radix (1 - precision)) / (2 + powerRZ radix (- precision)))%R; auto with real. 2: unfold Rminus; apply Rplus_le_compat_l; auto with real. unfold Rdiv; apply Rle_trans with (p*(1-(1 + powerRZ radix (1 - precision)) */ (2 + powerRZ radix (- precision))))%R;[idtac|right; ring]. apply Rmult_le_compat_l. apply P_positive with bo precision b b'; auto. apply Rmult_le_reg_l with 4%R; auto with real. apply Rlt_le_trans with 2%R; auto with real. apply Rmult_le_reg_l with (2 + powerRZ radix (- precision))%R; auto with real. apply Rle_trans with (2 + powerRZ radix (- precision))%R; [right; field|idtac]. assert (0 < 4)%R; [apply Rlt_le_trans with 2%R|idtac]; auto with real. apply Rle_trans with (4* (2 + powerRZ radix (- precision))- 4*(1 + powerRZ radix (1 - precision)))%R;[idtac|right;field; auto with real]. unfold Zminus; rewrite powerRZ_add; auto with real zarith. apply Rplus_le_reg_l with (-2+4*powerRZ radix (-precision))%R. apply Rle_trans with (5*powerRZ radix (-precision))%R;[right; ring|idtac]. apply Rle_trans with 2;[idtac|simpl; right; ring]. apply Rle_trans with (powerRZ radix 0); auto with real zarith. apply Rle_trans with (powerRZ radix (3-precision)); auto with real zarith. unfold Zminus; rewrite powerRZ_add; auto with real zarith. apply Rmult_le_compat_r; auto with real zarith. simpl; apply Rle_trans with (5+1+1+1)%R; [idtac|right; ring]. apply Rle_trans with (5+0+0+0)%R; [right; ring|idtac]. repeat apply Rplus_le_compat; auto with real. apply Rle_powerRZ; auto with real zarith. case (Zle_lt_or_eq (nNormMin radix precision) (Fnum q)). elim Nq; intros. apply Zmult_le_reg_r with radix; auto with zarith. rewrite Zmult_comm; rewrite <- PosNormMin with radix bo precision; auto with zarith. apply Zle_trans with (1:=H4); rewrite Zabs_eq; auto with zarith. assert (0 < Fnum q)%Z; auto with zarith. apply LtR0Fnum with radix; auto with real zarith. apply Q_positive with bo precision b b' p; auto. intros P. assert (Fnum q < nNormMin radix precision+2)%Z. apply lt_IZR; rewrite plus_IZR; simpl. apply Rmult_lt_reg_l with (powerRZ radix (Fexp q)); auto with real zarith. apply Rle_lt_trans with q;[unfold FtoRradix, FtoR; auto with real|idtac]. apply Rplus_lt_reg_r with (-2*powerRZ radix (Fexp q))%R. apply Rlt_le_trans with (powerRZ radix (Fexp q) * (nNormMin radix precision))%R; [idtac|right; ring]. apply Rle_lt_trans with d;[rewrite dexact|idtac]. apply Rplus_le_reg_l with q. ring_simplify (q + (p - q))%R;right. rewrite <- FPredSuc with bo radix precision p; auto with zarith. 2: left; auto. replace (FSucc bo radix precision p) with qq. rewrite FPredSimpl4; auto with zarith. unfold FtoRradix, FtoR, Zpred; simpl; rewrite J4; rewrite J5; ring_simplify. rewrite plus_IZR; rewrite powerRZ_add; auto with real zarith; simpl; ring. assert (- pPred (vNum bo) < Fnum qq)%Z; auto with zarith. apply Zlt_trans with (nNormMin radix precision); auto with zarith. assert (0 < pPred (vNum bo))%Z. apply pPredMoreThanOne with radix precision; auto with zarith. apply Zlt_trans with 0%Z; auto with zarith. apply nNormPos; auto with zarith. apply FcanonicUnique with radix bo precision; auto with zarith real. left; auto. apply FSuccCanonic; auto with zarith. left; auto. fold FtoRradix; rewrite J1; auto with real. apply Rle_lt_trans with (Rabs d);[apply RRle_abs|idtac]. unfold FtoRradix; rewrite <- Fabs_correct; auto. unfold Fabs, FtoR; simpl. apply Rlt_le_trans with (powerRZ 2 precision* powerRZ 2 (Fexp d))%R. apply Rmult_lt_compat_r; auto with real zarith. assert (Fbounded bo d);[rewrite dDef; elim Roundt; intros I1 I2; elim I1; auto|idtac]. elim H3; intros. apply Rlt_le_trans with (Zpos (vNum bo)); auto with real zarith. right; rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; auto with real. unfold nNormMin; repeat rewrite <- powerRZ_add; auto with real zarith. rewrite Zpower_nat_Z_powerRZ; repeat rewrite <- powerRZ_add; auto with real zarith. replace (Fexp q+pred precision)%Z with (precision+Fexp d)%Z; auto with real zarith. rewrite inj_pred; auto with zarith; unfold Zpred; rewrite H2; ring. assert (Fnum q= nNormMin radix precision + 1)%Z; auto with zarith. clear P H3. assert (p=Float (nNormMin radix precision) (Fexp q+1)). rewrite <- FPredSuc with bo radix precision p; auto with zarith. 2: left; auto. replace (FSucc bo radix precision p) with qq. rewrite FPredSimpl4; auto with zarith. rewrite J4; rewrite J5; rewrite H4; unfold Zpred; auto with zarith. ring_simplify (nNormMin radix precision + 1 + -1)%Z; auto. assert (- pPred (vNum bo) < Fnum qq)%Z; auto with zarith. rewrite J4; rewrite H4. apply Zlt_trans with (nNormMin radix precision); auto with zarith. assert (0 < pPred (vNum bo))%Z. apply pPredMoreThanOne with radix precision; auto with zarith. apply Zlt_trans with 0%Z; auto with zarith. apply nNormPos; auto with zarith. apply FcanonicUnique with radix bo precision; auto with zarith real. left; auto. apply FSuccCanonic; auto with zarith. left; auto. fold FtoRradix; rewrite J1; auto with real. Contradict Case2; apply Rlt_not_le. assert (FtoRradix p=powerRZ radix (Fexp q)*powerRZ radix precision)%R. rewrite H3; unfold FtoRradix, FtoR; simpl. unfold nNormMin; rewrite Zpower_nat_Z_powerRZ; rewrite inj_pred; auto with zarith. repeat rewrite <- powerRZ_add; auto with real zarith. replace (Fexp q+precision)%Z with (Zpred precision+(Fexp q+1))%Z;unfold Zpred; auto with real zarith. assert (FtoRradix q=powerRZ radix (Fexp q)*(powerRZ radix (precision-1)+1))%R. unfold FtoRradix, FtoR; rewrite H4; rewrite plus_IZR; simpl. unfold nNormMin; rewrite Zpower_nat_Z_powerRZ; rewrite inj_pred; auto with zarith. unfold Zpred, Zminus; simpl; ring. assert (exists w1:float, Fbounded bo w1 /\ (FtoRradix w1=powerRZ radix (Fexp q)* (powerRZ radix precision+powerRZ radix (precision-1)-2))%R). exists (Float (Zpower_nat radix (pred precision)+Zpower_nat radix (pred (pred precision))-1) (Fexp q+1)). split;[split; simpl|idtac]. rewrite Zabs_eq; auto with zarith. rewrite pGivesBound; apply Zlt_le_trans with (Zpower_nat radix (pred precision) + Zpower_nat radix (pred precision))%Z. unfold Zminus; rewrite <- Zplus_assoc; apply Zplus_lt_compat_l. apply Zlt_le_trans with (Zpower_nat radix (pred (pred precision)) + Zpower_nat radix (pred (pred precision)))%Z. apply Zplus_lt_compat_l; auto with zarith. apply Zlt_trans with 0%Z; auto with zarith. pattern (pred precision) at 3; replace (pred precision) with (1+pred (pred precision)); auto with zarith. rewrite Zpower_nat_is_exp. replace (Zpower_nat radix 1) with 2%Z; auto with zarith. pattern precision at 3; replace precision with (1+pred precision); auto with zarith. rewrite Zpower_nat_is_exp. replace (Zpower_nat radix 1) with 2%Z; auto with zarith. assert (1 <= Zpower_nat radix (pred precision) + Zpower_nat radix (pred (pred precision)))%Z; auto with zarith. apply Zle_trans with (Zpower_nat radix (pred precision)+0)%Z; auto with zarith. apply Zle_trans with (Zpower_nat radix (pred precision))%Z; auto with zarith. elim J2; rewrite <- J5; auto. unfold FtoRradix, FtoR; simpl. unfold Zminus; repeat rewrite plus_IZR; simpl. repeat rewrite Zpower_nat_Z_powerRZ. repeat rewrite inj_pred; auto with zarith; unfold Zpred. repeat rewrite powerRZ_add; auto with real zarith; simpl. ring_simplify (2*1)%R; field; auto with real. assert (0 < 4)%R;[apply Rlt_le_trans with 2%R|idtac]; auto with real. intros. elim H7; intros w1 T1; elim T1; intros W11 W12; clear H7 T1. apply Rle_lt_trans with w1. apply Rle_trans with (Rabs u);[apply RRle_abs|idtac];unfold FtoRradix. apply RoundAbsMonotoner with bo precision (EvenClosest bo radix precision) (3*Rabs t)%R; auto with zarith. apply EvenClosestRoundedModeP; auto. fold FtoRradix; rewrite <- dDef; rewrite dexact. rewrite Rabs_right. rewrite Rabs_right. rewrite H5; rewrite H6. apply Rle_trans with (w1-powerRZ radix (Fexp q))%R. rewrite W12; right; ring_simplify. unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith; simpl. ring_simplify (2*1)%R; field; auto with real. apply Rle_trans with (w1-0)%R; auto with real. unfold Rminus; apply Rplus_le_compat_l; auto with real zarith. apply Rle_ge; apply Rplus_le_reg_l with q. ring_simplify; auto with real. apply Rle_ge; apply Rle_trans with (3*0)%R; auto with real. apply Rmult_le_compat_l; auto with real. apply Rle_trans with 2%R; auto with real. assert (exists w2:float, Fbounded bo w2 /\ (FtoRradix w2=powerRZ radix (Fexp q)* (powerRZ radix precision+powerRZ radix (precision-1)))%R). exists (Float (Zpower_nat radix (pred precision)+Zpower_nat radix (pred (pred precision))) (Fexp q+1)). split;[split; simpl|idtac]. rewrite Zabs_eq; auto with zarith. rewrite pGivesBound; apply Zlt_le_trans with (Zpower_nat radix (pred precision) + Zpower_nat radix (pred precision))%Z. apply Zplus_lt_compat_l; auto with zarith. pattern precision at 3; replace precision with (1+pred precision); auto with zarith. rewrite Zpower_nat_is_exp. replace (Zpower_nat radix 1) with 2%Z; auto with zarith. elim J2; rewrite <- J5; auto. unfold FtoRradix, FtoR; simpl. unfold Zminus; repeat rewrite plus_IZR; simpl. repeat rewrite Zpower_nat_Z_powerRZ. repeat rewrite inj_pred; auto with zarith; unfold Zpred. repeat rewrite powerRZ_add; auto with real zarith; simpl. ring_simplify (2*1)%R; field; auto with real. assert (0 < 4)%R;[apply Rlt_le_trans with 2%R|idtac]; auto with real. elim H7; intros w2 T1; elim T1; intros W21 W22; clear H7 T1. apply Rlt_le_trans with w2. rewrite W12; rewrite W22; apply Rmult_lt_compat_l; auto with real zarith. unfold Rminus; rewrite Rplus_assoc. apply Rplus_lt_compat_l; auto with real zarith. apply Rlt_le_trans with (powerRZ radix (precision - 1) + -0)%R; auto with real. right; ring. assert (0 <= p+q)%R. apply Rle_trans with (0+0)%R;auto with real; apply Rplus_le_compat. apply P_positive with bo precision b b'; auto. left; apply Q_positive with bo precision b b' p; auto. apply Rle_trans with (Rabs v). unfold FtoRradix; apply RoundAbsMonotonel with bo precision (EvenClosest bo radix precision) (p+q)%R;auto with zarith. apply EvenClosestRoundedModeP; auto. fold FtoRradix; rewrite Rabs_right; auto with real. apply Rle_trans with (w2+0)%R; auto with real zarith. apply Rle_trans with (w2+powerRZ radix (Fexp q))%R; auto with real zarith. rewrite W22; rewrite H5; rewrite H6; right;ring. rewrite Rabs_right; auto with real; apply Rle_ge. unfold FtoRradix; apply RleRoundedR0 with bo precision (EvenClosest bo radix precision) (p+q)%R; auto. apply EvenClosestRoundedModeP; auto. intros P. assert (p=Float (pPred (vNum bo)) (Fexp q)). rewrite <- FPredSuc with bo radix precision p; auto with zarith. 2: left; auto. replace (FSucc bo radix precision p) with qq. rewrite FPredSimpl2; auto with zarith. replace (Zpred (Fexp qq)) with (Fexp q); auto. rewrite J5; unfold Zpred; auto with zarith. rewrite J5; assert (-dExp bo <= Fexp q)%Z; auto with zarith float. apply FcanonicUnique with radix bo precision; auto with zarith real. left; auto. apply FSuccCanonic; auto with zarith. left; auto. fold FtoRradix; rewrite J1; auto with real. Contradict M. rewrite H3; simpl; auto with zarith. intros M. apply Rle_trans with (Rabs (-(dp-dq)))%R. unfold delta; replace (d - (b * b' - a * c))%R with (-(dp-dq))%R; auto with real. rewrite dexact; rewrite dpEq; rewrite dqEq; ring. rewrite Rabs_Ropp. unfold Rminus; apply Rle_trans with (Rabs dp + Rabs (-dq))%R;[apply Rabs_triang|rewrite Rabs_Ropp]. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with (INR 2*Rabs dp + INR 2*Rabs dq)%R;[right; simpl; ring|idtac]. apply Rle_trans with (Fulp bo radix precision p+Fulp bo radix precision q)%R; [apply Rplus_le_compat|idtac]. rewrite dpEq; unfold FtoRradix; apply ClosestUlp; auto with zarith. elim Roundp; auto. rewrite dqEq; unfold FtoRradix; apply ClosestUlp; auto with zarith. elim Roundq; auto. repeat rewrite CanonicFulp; auto with zarith. 2: left; auto. 2: left; auto. rewrite M; unfold FtoR;simpl. apply Rle_trans with (2* powerRZ 2 (Fexp p))%R;[right; ring|idtac]. apply Rmult_le_compat_l; auto with real. apply Rle_trans with (powerRZ 2 (Fexp d+1));[idtac| rewrite powerRZ_add; auto with real zarith; simpl; right; ring]. apply Rle_powerRZ; auto with real. assert (Fexp p-1 <= Fexp d)%Z; auto with zarith. assert (exists f:float, (Fexp f=Fexp p-1)%Z /\ (FtoRradix f=powerRZ radix (precision-2+Fexp p))%R /\ Fnormal radix bo f). exists (Float (nNormMin radix precision) (Fexp p -1)). split;simpl; auto with zarith. split;[unfold FtoRradix, FtoR, nNormMin; simpl|idtac]. rewrite Zpower_nat_Z_powerRZ; rewrite inj_pred; auto with zarith. rewrite <- powerRZ_add; auto with real zarith. replace (Zpred precision + (Fexp p - 1))%Z with (precision - 2 + Fexp p)%Z; [auto with real|unfold Zpred; ring]. split;[split;simpl; auto with zarith|idtac]. rewrite Zabs_eq; auto with zarith float. apply ZltNormMinVnum; auto with zarith. assert (0 < nNormMin radix precision)%Z; auto with zarith. apply nNormPos; auto with zarith. simpl (Fnum (Float (nNormMin radix precision) (Fexp p - 1))). rewrite <- PosNormMin with radix bo precision; auto with zarith. elim H1; intros f H1'; elim H1'; intros K1 H2; elim H2; intros K2 K3;clear H1' H1 H2. rewrite <- K1. apply Fcanonic_Rle_Zle with radix bo precision; auto with zarith. left; auto. fold FtoRradix; rewrite dexact; rewrite K2. rewrite Rabs_right;[idtac|apply Rle_ge; auto with real zarith]. rewrite Rabs_right. 2:apply Rle_ge;apply Rplus_le_reg_l with q. 2: ring_simplify; auto with real. apply Rmult_le_reg_l with 3%R; auto with real. apply Rlt_le_trans with 2%R; auto with real. apply Rle_trans with ((2*powerRZ radix (precision-1+Fexp p))*(1-powerRZ radix (-precision)))%R. replace (powerRZ radix (precision - 1 + Fexp p)) with (2*powerRZ radix (precision - 2 + Fexp p))%R; [idtac|unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith; simpl]. 2: ring_simplify (2*1)%R; field; auto with real. 2: assert (0 < 4*2)%R; auto with real. 2: assert (0 < 4)%R; auto with real. 2: apply Rlt_le_trans with 2%R; auto with real. 2: apply Rle_lt_trans with (0*2)%R; auto with real. apply Rle_trans with ((2*2* (1 - powerRZ radix (- precision)))* powerRZ radix (precision - 2 + Fexp p))%R;[idtac|right; ring]. apply Rmult_le_compat_r; auto with real zarith. apply Rplus_le_reg_l with (-3+4*powerRZ radix (- precision))%R. ring_simplify. apply Rle_trans with (powerRZ radix (2+-precision)); [rewrite powerRZ_add; auto with real zarith; simpl; right; ring|idtac]. apply Rle_trans with (powerRZ radix 0); auto with real zarith. assert (0 < (1 - powerRZ radix (- precision)))%R. apply Rplus_lt_reg_r with (powerRZ radix (- precision)). ring_simplify. replace 1%R with (powerRZ radix 0); [ auto with real zarith | simpl in |- *; auto ]. apply Rle_trans with (v* (1 - powerRZ radix (- precision)))%R. apply Rmult_le_compat_r; auto with real. assert (exists g:float, Fbounded bo g /\ (FtoRradix g= 2 * powerRZ radix (precision - 1 + Fexp p))%R). exists (Float 1%Z (Fexp p +precision))%Z. split;[split; simpl; auto with zarith float|idtac]. apply vNumbMoreThanOne with radix precision; auto with zarith. unfold FtoRradix, FtoR; simpl;unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith. simpl; ring_simplify (2*1)%R; field; auto with real. clear K1 K2 K3 f; elim H3; intros g H1'; elim H1'; intros K1 K2; clear H3 H1'. rewrite <- K2; unfold FtoRradix. apply EvenClosestMonotone2 with bo precision g (p+q)%R; auto with real zarith. rewrite K2; apply Rle_trans with ( powerRZ radix (precision - 1 + Fexp p)+ powerRZ radix (precision - 1 + Fexp p))%R;[right; ring|idtac]. assert (forall f:float, Fnormal radix bo f -> (0 <= f)%R -> (powerRZ radix (precision - 1 + Fexp f) <= f)%R). intros f Hf Hf'; rewrite powerRZ_add; auto with real zarith. unfold FtoRradix, FtoR; apply Rmult_le_compat_r; auto with real zarith. elim Hf; intros. apply Rmult_le_reg_l with (radix); auto with real zarith. apply Rle_trans with (Zpos (vNum bo)). rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ. unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl. ring_simplify (2*1)%R; right; field; auto with real. apply Rle_trans with (Zabs (radix * Fnum f)); auto with real zarith. rewrite Zabs_Zmult; repeat rewrite Zabs_eq; auto with real zarith. rewrite mult_IZR; auto with real zarith. apply LeR0Fnum with radix; auto with real zarith. apply Rplus_le_compat;[apply H3; auto|idtac]. apply P_positive with bo precision b b'; auto. rewrite <- M; apply H3; auto. left; apply Q_positive with bo precision b b' p; auto. unfold FtoRradix; apply RoundedModeProjectorIdem with bo; auto. apply EvenClosestRoundedModeP; auto with zarith. apply Rmult_le_reg_l with (/(1 - powerRZ radix (- precision)))%R; auto with real. apply Rle_trans with (FtoRradix v);[right; field; auto with real|idtac]. replace (3 * (p - q))%R with (Rabs (3*Rabs t)). apply Rle_trans with (Rabs (3*Rabs t) / (1 - powerRZ radix (- precision)))%R; [idtac|right; unfold Rdiv; ring]. apply Rle_trans with (Rabs v);[apply RRle_abs|idtac]. rewrite IneqEq. apply RoundLeNormal; auto. elim Roundu; auto. rewrite <- dDef; rewrite dexact; auto. rewrite Rabs_right;[idtac|apply Rle_ge]. rewrite Rabs_right;[idtac|apply Rle_ge]; auto with real. apply Rplus_le_reg_l with q. ring_simplify; auto with real. apply Rle_trans with (0*0)%R; auto with real; apply Rmult_le_compat; auto with real. apply Rle_trans with 2%R; auto with real. intros M. apply Rle_trans with (Rabs (-(dp-dq)))%R. unfold delta; replace (d - (b * b' - a * c))%R with (-(dp-dq))%R; auto with real. rewrite dexact; rewrite dpEq; rewrite dqEq; ring. rewrite Rabs_Ropp. apply Rle_trans with (3 / 2 * Rmin (Fulp bo 2 precision p) (Fulp bo 2 precision q))%R. apply dp_dq_le with a b b' c; auto. replace (Rmin (Fulp bo 2 precision p) (Fulp bo 2 precision q)) with (Fulp bo 2 precision q). apply Rmult_le_compat; auto with real zarith. unfold Rdiv; apply Rle_trans with (0*0)%R; auto with real. apply Rmult_le_compat; auto with real zarith. apply Rle_trans with 2%R; auto with real. unfold Fulp; auto with real zarith. apply Rmult_le_reg_l with 2%R; auto with real. apply Rle_trans with 3%R;[right; field|idtac]; auto with real. apply Rle_trans with (3+1)%R; auto with real; right; ring. repeat rewrite CanonicFulp; auto with zarith. right; rewrite M; auto with real. left; auto. repeat rewrite CanonicFulp; auto with zarith. 2: left; auto. 2: left; auto. rewrite Rmin_comm. unfold Rmin. case (Rle_dec (FtoR 2 (Float (S 0) (Fexp q))) (FtoR 2 (Float (S 0) (Fexp p)))); auto with real. intros N. absurd (Fexp q <= Fexp p)%Z. assert (Fexp p < Fexp q)%Z; auto with zarith. apply Zlt_powerRZ with radix; auto with real zarith. apply Rle_lt_trans with (FtoR 2 (Float (S 0) (Fexp p))); [right; unfold FtoR; simpl; ring|idtac]. apply Rlt_le_trans with (FtoR 2 (Float (S 0) (Fexp q))); auto with real. right; unfold FtoR; simpl; ring. apply Fcanonic_Rle_Zle with radix bo precision; auto with real zarith. left; auto. left; auto. fold FtoRradix; rewrite Rabs_right. rewrite Rabs_right; auto with real. apply Rle_ge; apply P_positive with bo precision b b'; auto. apply Rle_ge; left; apply Q_positive with bo precision b b' p; auto. Qed. End Discriminant1. Section Discriminant2. Variable bo : Fbound. Variable precision : nat. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ TwoMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum bo) = Zpower_nat radix precision. Hypothesis precisionGreaterThanThree : 3 <= precision. Variables a b b' c p q t d u v dp dq:float. Let delta := (Rabs (d-(b*b'-a*c)))%R. Hypothesis Fa : (Fbounded bo a). Hypothesis Fb : (Fbounded bo b). Hypothesis Fb': (Fbounded bo b'). Hypothesis Fc : (Fbounded bo c). Hypothesis Fp : (Fbounded bo p). Hypothesis Fq : (Fbounded bo q). Hypothesis Fd : (Fbounded bo d). Hypothesis Fu : (Fbounded bo u). Hypothesis Fv : (Fbounded bo v). Hypothesis Cand : (Fcanonic radix bo d). (** There is no underflow *) Hypothesis Nq:(Fnormal radix bo q). Hypothesis Np:(Fnormal radix bo p). Hypothesis Nv:(Fnormal radix bo v). Hypothesis Nu:(Fnormal radix bo u). Hypothesis U0: (- dExp bo <= Fexp p - 2)%Z. Hypothesis U1: (- dExp bo <= Fexp q - 2)%Z. Hypothesis Square:(0 <=b*b')%R. Hypothesis Roundp : (EvenClosest bo radix precision (b*b')%R p). Hypothesis Roundq : (EvenClosest bo radix precision (a*c)%R q). Hypothesis Roundt : (EvenClosest bo radix precision (p-q)%R t). Hypothesis dDef : d=t. Hypothesis Roundu : (EvenClosest bo radix precision (3*Rabs t)%R u). Hypothesis Roundv : (EvenClosest bo radix precision (p+q)%R v). Hypothesis dpEq : (FtoRradix dp=b*b'-p)%R. Hypothesis dqEq : (FtoRradix dq=a*c-q)%R. Hypothesis Case1 : (3*(Rabs (p-q)) < p+q )%R. Hypothesis Case2 : (v <= u )%R. Theorem discri11: (delta <= 2*(Fulp bo radix precision d))%R. case (Rle_or_lt q p); intros. unfold delta, FtoRradix; apply discri10 with p q t u v dp dq; auto. case (Rle_or_lt 0%R (a*c)%R)%R; intros. unfold delta. replace (d - (b * b' - a * c))%R with (-(Fopp d-(a*c-b*b')))%R;unfold FtoRradix; [idtac|rewrite Fopp_correct; ring]. rewrite Rabs_Ropp; apply Rle_trans with (2 * Fulp bo radix precision (Fopp d))%R. generalize (EvenClosestSymmetric bo radix precision); unfold SymmetricP; intros L. apply discri10 with q p (Fopp t) u v dq dp; auto with real. apply FcanonicFopp; auto with zarith. fold radix; fold FtoRradix; replace (q-p)%R with (-(p-q))%R;[apply L; auto|ring]. rewrite dDef; auto. rewrite Fopp_correct; rewrite Rabs_Ropp; auto. rewrite Rplus_comm; auto. fold radix; fold FtoRradix; rewrite Rplus_comm with q p; apply Rle_lt_trans with (2:=Case1). replace (q-p)%R with (-(p-q))%R;[rewrite Rabs_Ropp|ring]; auto with real. unfold Fulp; rewrite Fnormalize_Fopp; unfold Fopp; simpl; auto with real zarith. absurd (0-> R. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ TwoMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum bo) = Zpower_nat radix precision. Hypothesis precisionGreaterThanFour : 4 <= precision. Variables a b b' c p q t dp dq s d u v:float. Let delta := (Rabs (d-(b*b'-a*c)))%R. Hypothesis Fa : (Fbounded bo a). Hypothesis Fb : (Fbounded bo b). Hypothesis Fb': (Fbounded bo b'). Hypothesis Fc : (Fbounded bo c). Hypothesis Fp : (Fbounded bo p). Hypothesis Fq : (Fbounded bo q). Hypothesis Fd : (Fbounded bo d). Hypothesis Ft : (Fbounded bo t). Hypothesis Fs : (Fbounded bo s). Hypothesis Fdp: (u (Fbounded bo dp). Hypothesis Fdq: (u (Fbounded bo dq). Hypotheses Cv: Fcanonic radix bo v. Hypothesis Cs:(Fcanonic radix bo s). (** There is no underflow *) Hypothesis U1: (- dExp bo <= (Fexp t)-1)%Z. Hypothesis U2: (powerRZ radix (-dExp bo+2*precision-1) <= Rabs (b*b'))%R. Hypothesis U3: (powerRZ radix (-dExp bo+2*precision-1) <= Rabs (a*c))%R. Hypothesis Np:(Fnormal radix bo p). Hypothesis Nq:(Fnormal radix bo q). Hypothesis Nd:(Fnormal radix bo d). Hypothesis Nt:(Fnormal radix bo t). Hypothesis Nu:(Fnormal radix bo u). Hypothesis Nv:(Fnormal radix bo v). Hypothesis Square:(0 <=b*b')%R. Hypothesis Roundp : (EvenClosest bo radix precision (b*b')%R p). Hypothesis Roundq : (EvenClosest bo radix precision (a*c)%R q). Hypothesis Roundu : (EvenClosest bo radix precision (3*Rabs t)%R u). Hypothesis Roundv : (EvenClosest bo radix precision (p+q)%R v). Hypothesis Case1 : (p+q <= 3*(Rabs (p-q)))%R. Hypothesis Case2 : (u < v )%R. Hypothesis Roundt : (EvenClosest bo radix precision (p-q)%R t). Hypothesis dpEq : (FtoRradix dp=b*b'-p)%R. Hypothesis dqEq : (FtoRradix dq=a*c-q)%R. Hypothesis Rounds : (EvenClosest bo radix precision (dp-dq)%R s). Hypothesis Roundd : (EvenClosest bo radix precision (t+s)%R d). Theorem RoundGeNormal: forall f:float, forall r:R, Closest bo radix r f -> (Fnormal radix bo f) -> (Rabs r <= Rabs f * (1 + powerRZ radix (- precision)))%R. intros. apply Rplus_le_reg_l with (-Rabs f)%R. apply Rle_trans with (Rabs r-Rabs f)%R;[right; ring|idtac]. apply Rle_trans with (Rabs f * powerRZ radix (- precision) )%R;[idtac|right; ring]. apply Rle_trans with (Rabs (r-f));[apply Rabs_triang_inv|idtac]. apply Rmult_le_reg_l with (INR 2); auto with real. apply Rle_trans with (Fulp bo radix precision f). unfold FtoRradix; apply ClosestUlp; auto. apply Rle_trans with (Rabs f*powerRZ radix (Zsucc (-precision)))%R. unfold FtoRradix; apply FulpLe2; auto. elim H0; auto. rewrite FcanonicFnormalizeEq; auto with zarith. left; auto. right; unfold Zsucc; rewrite powerRZ_add; auto with real zarith; simpl; ring. Qed. Theorem discri12: (q <= p)%R -> (delta <= 2*(Fulp bo radix precision d))%R. intros M. assert (0 < 3)%R. apply Rlt_le_trans with 2%R; auto with real. assert (0 <= p-q)%R. apply Rplus_le_reg_l with q. ring_simplify; auto. assert (0 <= p)%R. apply P_positive with bo precision b b'; auto. assert (0 < (1 - powerRZ radix (- precision)))%R; auto with real. apply Rplus_lt_reg_r with (powerRZ radix (- precision)). ring_simplify. replace 1%R with (powerRZ radix 0); [ auto with real zarith | simpl in |- *; auto ]. assert (p-q <= Rsqr (1+powerRZ radix (-precision))/(1-powerRZ radix (-precision))*/3*(p+Rabs q))%R. apply Rle_trans with (Rabs (p-q));[apply RRle_abs|idtac]. apply Rle_trans with (Rabs t * (1 + powerRZ radix (- precision)))%R. apply RoundGeNormal; auto. elim Roundt; auto. apply Rle_trans with (((((p + Rabs q)/(1 - powerRZ radix (- precision))) * (1 + powerRZ radix (- precision)))*/3)* (1 + powerRZ radix (- precision)))%R; [idtac|right; unfold Rdiv, Rsqr; ring]. apply Rmult_le_compat_r; auto with real. apply Rle_trans with (0+0)%R; try apply Rplus_le_compat; auto with real zarith. apply Rle_trans with ((3*Rabs t)*/3)%R; [right; field; auto with real| apply Rmult_le_compat_r; auto with real]. apply Rle_trans with (Rabs (3*Rabs t));[apply RRle_abs|idtac]. apply Rle_trans with (Rabs u * (1 + powerRZ radix (- precision)))%R. apply RoundGeNormal; auto; elim Roundu; auto. apply Rmult_le_compat_r; auto with real. apply Rle_trans with (0+0)%R; try apply Rplus_le_compat; auto with real zarith. apply Rle_trans with (Rabs v). cut (0 <= u)%R. intros; repeat rewrite Rabs_right; auto with real. apply Rle_ge; apply Rle_trans with (FtoRradix u); auto with real. unfold FtoRradix; apply RleRoundedR0 with bo precision (EvenClosest bo radix precision) (3 * Rabs t)%R; auto with zarith float. apply Rle_trans with(3*0)%R; auto with real; apply Rmult_le_compat; auto with real. apply Rle_trans with (Rabs (p+q) / (1 - powerRZ radix (- precision)))%R. unfold FtoRradix; apply RoundLeNormal with bo; auto with zarith float real. elim Roundv; auto. unfold Rdiv; apply Rmult_le_compat_r; auto with real. apply Rle_trans with (Rabs p+Rabs q)%R;[apply Rabs_triang|idtac]. apply Rplus_le_compat_r; rewrite Rabs_right; auto with real. case (Rle_or_lt q 0); intros. absurd (p <= q)%R. apply Rlt_not_le; case M; auto with real. intros; absurd (0 < v)%R. apply Rle_not_lt. unfold FtoRradix; apply RleRoundedLessR0 with bo precision (EvenClosest bo radix precision) (p+q)%R; auto with zarith float. apply Rle_trans with (1:=Case1); rewrite H5. right; ring_simplify (p-p)%R; rewrite Rabs_R0; ring. apply Rle_lt_trans with (FtoRradix u); auto with real. unfold FtoRradix; apply RleRoundedR0 with bo precision (EvenClosest bo radix precision) (3 * Rabs t)%R; auto with zarith float. apply Rle_trans with(3*0)%R; auto with real; apply Rmult_le_compat; auto with real. apply Rmult_le_reg_l with (1- Rsqr (1 + powerRZ radix (- precision)) / (1 - powerRZ radix (- precision)) * / 3)%R. apply Rplus_lt_reg_r with (Rsqr (1 + powerRZ radix (- precision)) / (1 - powerRZ radix (- precision)) * / 3)%R. ring_simplify. apply Rmult_lt_reg_l with 3%R; auto with real. apply Rmult_lt_reg_l with (1 - powerRZ radix (- precision))%R; auto with real. apply Rle_lt_trans with (Rsqr (1 + powerRZ radix (- precision))); [right; field; auto with real|ring_simplify (3*1)%R]. apply Rplus_lt_reg_r with (-1+3*powerRZ radix (- precision))%R. apply Rle_lt_trans with (5* powerRZ radix (- precision) + powerRZ radix (- precision)* powerRZ radix (- precision))%R;[right; unfold Rsqr; ring|idtac]. apply Rlt_le_trans with 2%R;[idtac|right; ring]. apply Rlt_le_trans with (5 * powerRZ radix (- precision) + 3*powerRZ radix (- precision))%R; [apply Rplus_lt_compat_l; apply Rmult_lt_compat_r; auto with real zarith|idtac]. apply Rle_lt_trans with (powerRZ radix 1); auto with real zarith. simpl; ring_simplify (2*1)%R; auto with real. apply Rle_trans with (8 * powerRZ radix (- precision))%R;[right; ring|idtac]. replace 8%R with (powerRZ radix 3);[idtac|simpl; ring]. replace 2%R with (powerRZ radix 1);[idtac|simpl; ring]. rewrite <- powerRZ_add; auto with real zarith. apply Rplus_le_reg_l with (-q+ ((Rsqr (1 + powerRZ radix (- precision)) / (1 - powerRZ radix (- precision)) * / 3) * p))%R. apply Rle_trans with (p-q)%R;[right; ring|idtac]. apply Rle_trans with (1:=H3). apply Rle_trans with (Rsqr (1 + powerRZ radix (- precision)) / (1 - powerRZ radix (- precision)) * / 3 * (p - q))%R; [idtac|right; ring]. replace (Rabs q) with (-q)%R;[right; ring|rewrite Rabs_left1; auto with real]. assert (forall f1:float, forall f2:float, forall i:Z, (0 <= i)%Z -> Fbounded bo f1 -> Fnormal radix bo f2 -> (Rabs f1 <= powerRZ radix i*Rabs f2)%R -> (Fulp bo radix precision f1 <= powerRZ radix i*Fulp bo radix precision f2)%R). intros. rewrite CanonicFulp with bo radix precision f2; auto with zarith float. 2: left; auto. unfold FtoR; simpl; ring_simplify ((1 * powerRZ 2 (Fexp f2)))%R. unfold Fulp; rewrite <- powerRZ_add; auto with real zarith. apply Rle_powerRZ; auto with real zarith. apply Zle_trans with (Fexp (Float (Fnum f2) (i + Fexp f2))); auto with zarith. apply Fcanonic_Rle_Zle with radix bo precision; auto with real zarith. apply FnormalizeCanonic; auto with real zarith. elim H7; intros Y1 Y2; elim Y1; intros Y3 Y4. left; split; try split; simpl; auto with zarith. rewrite FnormalizeCorrect; auto with real zarith. fold FtoRradix; apply Rle_trans with (1:=H8). unfold FtoRradix; repeat rewrite <- Fabs_correct; auto. unfold FtoR, Rabs; simpl. rewrite powerRZ_add; auto with real zarith; right; ring. assert (2*q <= p)%R. apply Rmult_le_reg_l with 2%R; auto with real. apply Rplus_le_reg_l with (-3*q+p)%R. apply Rle_trans with (p+q)%R;[right; ring|apply Rle_trans with (1:=Case1)]. rewrite Rabs_right;[right; ring|apply Rle_ge; auto with real]. assert (q <= t)%R. apply Rle_trans with (Rabs t);[idtac|rewrite Rabs_right; auto with real]. 2:unfold FtoRradix; apply Rle_ge; apply RleRoundedR0 with bo precision (EvenClosest bo radix precision) (p-q)%R; auto with zarith float. unfold FtoRradix; apply RoundAbsMonotonel with bo precision (EvenClosest bo radix precision) (p-q)%R; auto with zarith float. fold FtoRradix; rewrite Rabs_right;[idtac|apply Rle_ge]; auto with real. apply Rplus_le_reg_l with q; ring_simplify (q+(p-q))%R. apply Rle_trans with (2*q)%R; auto with real; right; ring. assert (Rabs s <= 3*Fulp bo radix precision q)%R. assert (exists f:float, Fbounded bo f /\ (FtoRradix f= 3 * Fulp bo radix precision q)%R). exists (Float 3 (Fexp q)). split;[split; simpl; auto with zarith|idtac]. apply Zlt_le_trans with (Zpower_nat radix 2); auto with zarith. rewrite pGivesBound; auto with zarith. auto with zarith float. rewrite CanonicFulp; auto with real zarith. 2: left; auto. unfold FtoRradix, FtoR; simpl; ring. elim H8; intros f T; elim T; intros; clear T H8. rewrite <- H10. unfold FtoRradix; apply RoundAbsMonotoner with bo precision (EvenClosest bo radix precision) (dp-dq)%R; auto with zarith float. fold FtoRradix; unfold Rminus; apply Rle_trans with (Rabs dp+Rabs (-dq))%R; [apply Rabs_triang|rewrite Rabs_Ropp]. apply Rmult_le_reg_l with (INR 2); auto with real. apply Rle_trans with ((INR 2)*Rabs dp+(INR 2)*Rabs dq)%R;[right; ring|idtac]. apply Rle_trans with (Fulp bo radix precision p+Fulp bo radix precision q)%R; [apply Rplus_le_compat|idtac]. rewrite dpEq; unfold FtoRradix; apply ClosestUlp; auto with zarith. elim Roundp; auto. rewrite dqEq; unfold FtoRradix; apply ClosestUlp; auto with zarith. elim Roundq; auto. apply Rle_trans with (5*Fulp bo radix precision q+Fulp bo radix precision q)%R; [apply Rplus_le_compat_r|rewrite H10; simpl; right; ring]. apply Rle_trans with (powerRZ radix 2*Fulp bo radix precision q)%R; [idtac|apply Rmult_le_compat_r; auto with real zarith]. 2: unfold Fulp; auto with real zarith. 2: simpl; ring_simplify (2*1)%R; apply Rle_trans with (4+1)%R; auto with real. apply H5; auto with zarith. apply Rle_trans with (3*Rabs q)%R; [idtac|apply Rmult_le_compat_r; auto with real zarith]. 2: simpl; ring_simplify (2*1)%R; apply Rle_trans with (3+1)%R; auto with real; right; ring. apply Rmult_le_reg_l with (/2)%R; auto with real. apply Rplus_le_reg_l with (/2*Rabs p)%R. apply Rle_trans with (Rabs p);[right; field; auto with real|idtac]. rewrite Rabs_right;auto with real. apply Rle_trans with (/2*(p+Rabs q) +Rabs q)%R;[idtac|right; field; auto with real]. apply Rle_trans with ((p-q)+Rabs q)%R. rewrite Rabs_right; [right; ring|apply Rle_ge;auto with real]. apply Rplus_le_compat_r. apply Rle_trans with (1:=H3). apply Rmult_le_compat_r; auto with real. apply Rle_trans with (0+0)%R; try apply Rplus_le_compat; auto with real. apply Rmult_le_reg_l with 2%R; auto with real. apply Rmult_le_reg_l with 3%R; auto with real. apply Rmult_le_reg_l with (1 - powerRZ radix (- precision))%R; auto with real. apply Rle_trans with (Rsqr (1 + powerRZ radix (- precision))*2)%R; [right; field; auto with real|idtac]. apply Rle_trans with (3*(1 - powerRZ radix (- precision)))%R;[idtac|right; field; auto with real]. apply Rplus_le_reg_l with (-2+3*powerRZ radix (- precision))%R. apply Rle_trans with (7*powerRZ radix (- precision) +2*powerRZ radix (- precision)*powerRZ radix (- precision))%R;[right; unfold Rsqr; ring|idtac]. apply Rle_trans with 1%R;[idtac|right; ring]. apply Rle_trans with (7 * powerRZ radix (- precision) + powerRZ radix (- precision))%R; [apply Rplus_le_compat_l|idtac]. replace 2%R with (powerRZ radix 1); auto with real zarith. repeat rewrite <- powerRZ_add; auto with real zarith. apply Rle_trans with (powerRZ radix 3 * powerRZ radix (- precision))%R; [right; simpl; ring|idtac]. rewrite <- powerRZ_add; auto with real zarith. apply Rle_trans with (powerRZ radix 0); auto with real zarith. assert (t-3*Fulp bo radix precision t <= Rabs d)%R. assert (exists f:float, Fbounded bo f /\ (FtoRradix f= t-3 * Fulp bo radix precision t)%R). exists (Float (Fnum t-3) (Fexp t)). split;[split; simpl; auto with zarith|idtac]. assert (0 < Fnum t)%Z;[apply LtR0Fnum with radix; auto with real zarith|idtac]. fold FtoRradix; apply Rlt_le_trans with q; auto. case (Zle_or_lt 0 (Fnum t-3)%Z); intros. rewrite Zabs_eq; auto. apply Zle_lt_trans with (Zabs (Fnum t)); auto with zarith float. rewrite Zabs_eq; auto with zarith. rewrite <- Zabs_Zopp; rewrite Zabs_eq; auto with zarith. apply Zlt_le_trans with 3%Z; auto with zarith. apply Zle_trans with (nNormMin radix precision); auto with zarith. unfold nNormMin; apply Zle_trans with (Zpower_nat radix 2); auto with zarith. apply nNrMMimLevNum; auto with zarith. rewrite CanonicFulp; auto with zarith. 2: left; auto. unfold FtoRradix, FtoR, Zminus; simpl; rewrite plus_IZR; simpl; ring. elim H9; intros f T; elim T; intros; clear H9 T. rewrite <- H11. unfold FtoRradix; apply RoundAbsMonotonel with bo precision (EvenClosest bo radix precision) (t+s)%R; auto with zarith float. fold FtoRradix; replace (t+s)%R with (t-(-s))%R;[idtac|ring]. apply Rle_trans with (Rabs t -Rabs (-s))%R;[idtac|apply Rabs_triang_inv]. rewrite Rabs_Ropp; rewrite Rabs_right. rewrite H11; unfold Rminus; apply Rplus_le_compat_l; auto with real. apply Ropp_le_contravar; apply Rle_trans with (1:=H8). apply Rmult_le_compat_l; auto with real. apply LeFulpPos; auto with real. apply Rle_ge; apply Rle_trans with q; auto with real. assert (Fulp bo radix precision t <= 2*Fulp bo radix precision d)%R. replace 2%R with (powerRZ radix 1); auto with real zarith. apply H5; auto with zarith. apply Rmult_le_reg_l with (/2)%R; auto with real. apply Rle_trans with (Rabs d);[idtac|right; simpl; field; auto with real]. apply Rle_trans with (2:=H9). rewrite Rabs_right;[idtac|apply Rle_ge; apply Rle_trans with q; auto with real]. apply Rle_trans with (t-t/2)%R;[right; field; auto with real|idtac]. unfold Rminus; apply Rplus_le_compat_l; apply Ropp_le_contravar. apply Rle_trans with (3*(Rabs (FtoR radix t) * powerRZ radix (Zsucc (- precision))))%R. apply Rmult_le_compat_l; auto with real. apply FulpLe2; auto with real zarith float. rewrite FcanonicFnormalizeEq; auto with zarith float. left; auto. fold FtoRradix; apply Rle_trans with (Rabs t*(3*powerRZ radix (Zsucc (- precision))))%R; [right; ring|idtac]. rewrite Rabs_right;[idtac|apply Rle_ge; apply Rle_trans with q; auto with real]. unfold Rdiv; apply Rmult_le_compat_l; auto with real. apply Rle_trans with q; auto with real. apply Rle_trans with (4*powerRZ radix (Zsucc (- precision)))%R; [apply Rmult_le_compat_r; auto with real zarith|idtac]. apply Rle_trans with (3+1)%R; auto with real; right; ring. replace 4%R with (powerRZ radix 2). 2: simpl; ring. replace (/2)%R with (powerRZ radix (-1)). 2: simpl; ring_simplify (2*1)%R; auto with real. rewrite <- powerRZ_add; auto with real zarith. unfold Zsucc; apply Rle_powerRZ; auto with real zarith. unfold delta. replace (d-(b*b'-a*c))%R with (-((t+s)-d)+-((p-q)-t)+-((dp-dq)-s))%R;[idtac|rewrite dpEq; rewrite dqEq; ring]. apply Rle_trans with (Rabs (- (t + s - d) + (- (p - q - t))) + Rabs (- (dp - dq - s)))%R; [apply Rabs_triang|rewrite Rabs_Ropp]. apply Rle_trans with (Rabs (- (t + s - d)) + Rabs (- (p - q - t)) + Rabs ((dp - dq - s)))%R; [apply Rplus_le_compat_r; apply Rabs_triang|repeat rewrite Rabs_Ropp]. apply Rmult_le_reg_l with (INR 2); auto with real. apply Rle_trans with ((INR 2)*Rabs ((t + s - d)) + (INR 2)*Rabs ((p - q - t)) + (INR 2)*Rabs ((dp - dq - s)))%R;[right; ring|idtac]. apply Rle_trans with (Fulp bo radix precision d+Fulp bo radix precision t +Fulp bo radix precision s)%R;[apply Rplus_le_compat|idtac]. apply Rplus_le_compat. unfold FtoRradix; apply ClosestUlp; auto with zarith float; elim Roundd; auto. unfold FtoRradix; apply ClosestUlp; auto with zarith float; elim Roundt; auto. unfold FtoRradix; apply ClosestUlp; auto with zarith float; elim Rounds; auto. apply Rle_trans with (Fulp bo radix precision d + 2*Fulp bo radix precision d + Fulp bo radix precision s)%R; auto with real. apply Rle_trans with (Fulp bo radix precision d + 2 * Fulp bo radix precision d + Fulp bo radix precision d)%R;[idtac|right; simpl; ring]. apply Rplus_le_compat_l. rewrite FulpFabs with bo radix precision s; auto. rewrite FulpFabs with bo radix precision d; auto. apply LeFulpPos; auto with zarith real float. rewrite Fabs_correct; auto with real zarith. repeat rewrite Fabs_correct; auto; fold FtoRradix. apply Rle_trans with (1:=H8); apply Rle_trans with (2:=H9). apply Rle_trans with (3 * Fulp bo radix precision t)%R. apply Rmult_le_compat_l; auto with real. apply LeFulpPos; auto with zarith real float. apply Rplus_le_reg_l with (3* Fulp bo radix precision t)%R. ring_simplify (3 * Fulp bo radix precision t + (t - 3 * Fulp bo radix precision t))%R. apply Rle_trans with (6*Fulp bo radix precision t)%R;[right; ring|idtac]. apply Rle_trans with (6*(Rabs (FtoR radix t) * powerRZ radix (Zsucc (- precision))))%R. apply Rmult_le_compat_l; auto with real. apply Rle_trans with 3%R; auto with real. apply FulpLe2; auto with real zarith float. rewrite FcanonicFnormalizeEq; auto with zarith float. left; auto. fold FtoRradix; apply Rle_trans with (Rabs t*(6*powerRZ radix (Zsucc (- precision))))%R; [right; ring|idtac]. rewrite Rabs_right;[idtac|apply Rle_ge; apply Rle_trans with q; auto with real]. apply Rle_trans with (t*1)%R; auto with real. apply Rmult_le_compat_l; auto with real. apply Rle_trans with q; auto with real. apply Rle_trans with (8*powerRZ radix (Zsucc (- precision)))%R; [apply Rmult_le_compat_r; auto with real zarith|idtac]. apply Rmult_le_compat_l; auto with real. apply Rle_trans with (3+1)%R; auto with real; right; ring. replace 8%R with (powerRZ radix 3). 2: simpl; ring. replace 1%R with (powerRZ radix 0). 2: simpl; auto with real. rewrite <- powerRZ_add; auto with real zarith. apply Rle_powerRZ; auto with real zarith. Qed. End Discriminant3. Section Discriminant4. Variable bo : Fbound. Variable precision : nat. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ TwoMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum bo) = Zpower_nat radix precision. Hypothesis precisionGreaterThanFour : 4 <= precision. Variables a b b' c p q t dp dq s d u v:float. Let delta := (Rabs (d-(b*b'-a*c)))%R. Hypothesis Fa : (Fbounded bo a). Hypothesis Fb : (Fbounded bo b). Hypothesis Fb': (Fbounded bo b'). Hypothesis Fc : (Fbounded bo c). Hypothesis Fp : (Fbounded bo p). Hypothesis Fq : (Fbounded bo q). Hypothesis Fd : (Fbounded bo d). Hypothesis Ft : (Fbounded bo t). Hypothesis Fs : (Fbounded bo s). Hypothesis Fdp: (u (Fbounded bo dp). Hypothesis Fdq: (u (Fbounded bo dq). Hypotheses Cv: Fcanonic radix bo v. Hypotheses Cs: Fcanonic radix bo s. (** There is no underflow *) Hypothesis U1: (- dExp bo <= (Fexp t)-1)%Z. Hypothesis U2: (powerRZ radix (-dExp bo+2*precision-1) <= Rabs (b*b'))%R. Hypothesis U3: (powerRZ radix (-dExp bo+2*precision-1) <= Rabs (a*c))%R. Hypothesis Np:(Fnormal radix bo p). Hypothesis Nq:(Fnormal radix bo q). Hypothesis Nd:(Fnormal radix bo d). Hypothesis Nt:(Fnormal radix bo t). Hypothesis Nu:(Fnormal radix bo u). Hypothesis Nv:(Fnormal radix bo v). Hypothesis Square:(0 <=b*b')%R. Hypothesis Roundp : (EvenClosest bo radix precision (b*b')%R p). Hypothesis Roundq : (EvenClosest bo radix precision (a*c)%R q). Hypothesis Roundu : (EvenClosest bo radix precision (3*Rabs t)%R u). Hypothesis Roundv : (EvenClosest bo radix precision (p+q)%R v). Hypothesis Case1 : (p+q <= 3*(Rabs (p-q)))%R. Hypothesis Case2 : (u < v )%R. Hypothesis Roundt : (EvenClosest bo radix precision (p-q)%R t). Hypothesis dpEq : (FtoRradix dp=b*b'-p)%R. Hypothesis dqEq : (FtoRradix dq=a*c-q)%R. Hypothesis Rounds : (EvenClosest bo radix precision (dp-dq)%R s). Hypothesis Roundd : (EvenClosest bo radix precision (t+s)%R d). Theorem discri13: (delta <= 2*(Fulp bo radix precision d))%R. case (Rle_or_lt q p); intros. unfold delta, FtoRradix; apply discri12 with p q t dp dq s u v; auto with zarith. case (Rle_or_lt 0%R (a*c)%R)%R; intros. unfold delta. replace (d - (b * b' - a * c))%R with (-(Fopp d-(a*c-b*b')))%R;unfold FtoRradix; [idtac|rewrite Fopp_correct; ring]. rewrite Rabs_Ropp; apply Rle_trans with (2 * Fulp bo radix precision (Fopp d))%R. generalize (EvenClosestSymmetric bo radix precision); unfold SymmetricP; intros L. apply discri12 with q p (Fopp t) dq dp (Fopp s) u v; auto with real float zarith. apply FnormalFop; auto. apply FnormalFop; auto. rewrite Fopp_correct; rewrite Rabs_Ropp; auto. rewrite Rplus_comm; auto. rewrite Rplus_comm; fold radix; fold FtoRradix; replace (q-p)%R with (-(p-q))%R;[rewrite Rabs_Ropp|ring]; auto with real. fold radix; fold FtoRradix; replace (q-p)%R with (-(p-q))%R;[apply L; auto|ring]. fold radix; fold FtoRradix; replace (dq-dp)%R with (-(dp-dq))%R;[apply L; auto|ring]. repeat rewrite Fopp_correct; fold radix; fold FtoRradix. replace (-t+-s)%R with (-(t+s))%R;[apply L; auto|ring]. unfold Fulp; rewrite Fnormalize_Fopp; unfold Fopp; simpl; auto with real zarith. absurd (0-> R. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ TwoMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum bo) = Zpower_nat radix precision. Hypothesis precisionGreaterThanFour : 4 <= precision. Variables a b c p q t dp dq s d u v:float. Let delta := (Rabs (d-(b*b-a*c)))%R. Hypothesis Fa : (Fbounded bo a). Hypothesis Fb : (Fbounded bo b). Hypothesis Fc : (Fbounded bo c). Hypothesis Fp : (Fbounded bo p). Hypothesis Fq : (Fbounded bo q). Hypothesis Fd : (Fbounded bo d). Hypothesis Ft : (Fbounded bo t). Hypothesis Fs : (u (Fbounded bo s). Hypothesis Fdp: (u (Fbounded bo dp). Hypothesis Fdq: (u (Fbounded bo dq). Hypothesis Fu: (Fbounded bo u). Hypothesis Fv: (Fbounded bo v). Hypothesis Cs: (u < v)%R -> (Fcanonic radix bo s). (** There is no underflow *) Hypothesis U0: (- dExp bo <= Fexp d - 1)%Z. Hypothesis U1: (- dExp bo <= (Fexp t)-1)%Z. Hypothesis U2: (powerRZ radix (-dExp bo+2*precision-1) <= Rabs (b*b))%R. Hypothesis U3: (powerRZ radix (-dExp bo+2*precision-1) <= Rabs (a*c))%R. Hypothesis Np:(Fnormal radix bo p). Hypothesis Nq:(Fnormal radix bo q). Hypothesis Nd:(Fnormal radix bo d). Hypothesis Nu:(Fnormal radix bo u). Hypothesis Nv:(Fnormal radix bo v). Hypothesis Nt:(Fnormal radix bo t). Hypothesis Roundp : (EvenClosest bo radix precision (b*b)%R p). Hypothesis Roundq : (EvenClosest bo radix precision (a*c)%R q). Hypothesis Roundt : (EvenClosest bo radix precision (p-q)%R t). Hypothesis Roundu : (EvenClosest bo radix precision (3*Rabs t)%R u). Hypothesis Roundv : (EvenClosest bo radix precision (p+q)%R v). Hypothesis FRoundd : (v <= u)%R -> (EvenClosest bo radix precision (p-q)%R d). Hypothesis dpEq : (FtoRradix dp=b*b-p)%R. Hypothesis dqEq : (FtoRradix dq=a*c-q)%R. Hypothesis SRounds : (u < v)%R -> (EvenClosest bo radix precision (dp-dq)%R s). Hypothesis SRoundd : (u < v)%R -> (EvenClosest bo radix precision (t+s)%R d). Theorem discri14: (delta <= 2*(Fulp bo radix precision d))%R. case (Rle_or_lt (p+q)%R (3*(Rabs (p-q)))%R); case (Rle_or_lt v u); intros. unfold delta, FtoRradix. apply discri9 with p q t dp dq s; auto; fold radix; fold FtoRradix; intros; absurd (p + q <= 3 * Rabs (p - q))%R; auto with real. unfold delta, FtoRradix. apply discri13 with p q t dp dq s u v; auto. apply Rle_trans with (Rsqr (FtoR 2 b)); auto with real. unfold delta, FtoRradix. apply discri11 with p q t u v dp dq; auto with zarith. left; auto. assert (exists s : float, Fbounded bo s /\ FtoR 2 s = (FtoR 2 b * FtoR 2 b - FtoR 2 p)%R /\ Fexp s = (Fexp p - precision)%Z /\ (Rabs (Fnum s) <= powerRZ (Zpos 2) (Zpred precision))%R). apply errorBoundedMultClosest_Can; auto. elim Roundp; auto. left; auto. elim H1; intros s' T; elim T; intros T1 T2; elim T2; intros T3 T4; elim T4; intros. apply Zle_trans with (Fexp s')%Z; auto with zarith float. assert (exists s : float, Fbounded bo s /\ FtoR 2 s = (FtoR 2 a * FtoR 2 c - FtoR 2 q)%R /\ Fexp s = (Fexp q - precision)%Z /\ (Rabs (Fnum s) <= powerRZ (Zpos 2) (Zpred precision))%R). apply errorBoundedMultClosest_Can; auto. elim Roundq; auto. left; auto. elim H1; intros s' T; elim T; intros T1 T2; elim T2; intros T3 T4; elim T4; intros. apply Zle_trans with (Fexp s')%Z; auto with zarith float. fold FtoRradix; apply Rle_trans with (Rsqr b); auto with real. apply FcanonicUnique with radix bo precision; auto with zarith. left; auto. left; auto. generalize EvenClosestUniqueP; unfold UniqueP; intros Y. apply Y with bo precision (p-q)%R; auto with real zarith. unfold delta, FtoRradix. apply discri9 with p q t dp dq s; auto. fold radix; fold FtoRradix; intros. absurd (p + q <= 3 * Rabs (p - q))%R; auto with real. Qed. End Discriminant5. Section Discriminant6. Variable bo : Fbound. Variable precision : nat. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ TwoMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum bo) = Zpower_nat radix precision. Hypothesis precisionGreaterThanFour : 4 <= precision. Variables a b c p q t dp dq s d u v:float. Let delta := (Rabs (d-(b*b-a*c)))%R. Hypothesis Fa : (Fbounded bo a). Hypothesis Fb : (Fbounded bo b). Hypothesis Fc : (Fbounded bo c). Hypothesis Fdp: (u (Fbounded bo dp). Hypothesis Fdq: (u (Fbounded bo dq). (** There is no underflow *) Hypothesis U1: (powerRZ radix (-dExp bo+2*precision-1) <= Rabs (b*b))%R. Hypothesis U2: (powerRZ radix (-dExp bo+2*precision-1) <= Rabs (a*c))%R. Hypothesis U4: (powerRZ radix (-dExp bo+precision) <= Rabs d)%R. Hypothesis U5: (powerRZ radix (-dExp bo+precision-1) <= Rabs u)%R. Hypothesis U6: (powerRZ radix (-dExp bo+precision-1) <= Rabs v)%R. Hypothesis U7: (powerRZ radix (-dExp bo+precision) <= Rabs t)%R. Hypothesis Roundp : (EvenClosest bo radix precision (b*b)%R p). Hypothesis Roundq : (EvenClosest bo radix precision (a*c)%R q). Hypothesis Roundt : (EvenClosest bo radix precision (p-q)%R t). Hypothesis Roundu : (EvenClosest bo radix precision (3*Rabs t)%R u). Hypothesis Roundv : (EvenClosest bo radix precision (p+q)%R v). Hypothesis FRoundd : (v <= u)%R -> (EvenClosest bo radix precision (p-q)%R d). Hypothesis dpEq : (FtoRradix dp=b*b-p)%R. Hypothesis dqEq : (FtoRradix dq=a*c-q)%R. Hypothesis SRounds : (u < v)%R -> (EvenClosest bo radix precision (dp-dq)%R s). Hypothesis SRoundd : (u < v)%R -> (EvenClosest bo radix precision (t+s)%R d). Theorem discri15: (delta <= 2*(Fulp bo radix precision d))%R. assert (forall r:R, forall f:float, EvenClosest bo radix precision r f -> Fbounded bo f). intros r f T; elim T; intros T1 T2; elim T1; auto with zarith float. assert (forall f:float, (Fbounded bo f) -> (powerRZ radix (- dExp bo + precision - 1) <= Rabs f)%R -> Fnormal radix bo (Fnormalize radix bo precision f)). intros. assert (Fcanonic radix bo (Fnormalize radix bo precision f)). apply FnormalizeCanonic; auto with zarith. case H2; auto; intros. absurd (FtoR radix (Fabs f) < FtoR radix (firstNormalPos radix bo precision))%R. apply Rle_not_lt; rewrite Fabs_correct; auto. fold FtoRradix; apply Rle_trans with (2:=H1). unfold firstNormalPos, FtoRradix, FtoR, nNormMin; simpl. rewrite Zpower_nat_Z_powerRZ; rewrite inj_pred; auto with zarith; unfold Zpred. unfold Zminus; repeat rewrite powerRZ_add; auto with real zarith. right; simpl; ring. apply Rle_lt_trans with (FtoR radix (Fabs (Fnormalize radix bo precision f))). repeat rewrite Fabs_correct; auto. rewrite FnormalizeCorrect; auto with zarith real. apply FsubnormalLtFirstNormalPos; auto with zarith. apply FsubnormFabs; auto. rewrite Fabs_correct; auto with zarith real. unfold delta; unfold FtoRradix. assert (Fbounded bo d). case (Rle_or_lt v u); intros. elim FRoundd; auto; intros T T'; elim T; auto with zarith float. elim SRoundd; auto; intros T T'; elim T; auto with zarith float. apply Rle_trans with (2 * Fulp bo radix precision (Fnormalize radix bo precision d))%R. 2: unfold Fulp; rewrite FcanonicFnormalizeEq with radix bo precision (Fnormalize radix bo precision d); auto with zarith float real. rewrite <- FnormalizeCorrect with radix bo precision d; auto with zarith. assert (Fnormal radix bo (Fnormalize radix bo precision d)). apply H0; auto. apply Rle_trans with (2:=U4); auto with real zarith. assert (Fnormal radix bo (Fnormalize radix bo precision t)). apply H0. apply H with (p-q)%R; auto. apply Rle_trans with (2:=U7); auto with real zarith. apply discri14 with (Fnormalize radix bo precision p) (Fnormalize radix bo precision q) (Fnormalize radix bo precision t) dp dq (Fnormalize radix bo precision s) (Fnormalize radix bo precision u) (Fnormalize radix bo precision v); auto. apply FnormalizeBounded; auto with zarith float; apply H with (b*b)%R; auto. apply FnormalizeBounded; auto with zarith float; apply H with (a*c)%R; auto. apply FnormalizeBounded; auto with zarith float. apply FnormalizeBounded; auto with zarith float; apply H with (p-q)%R; auto. repeat rewrite FnormalizeCorrect; auto with real zarith; intros. apply FnormalizeBounded; auto with zarith float; apply H with (dp-dq)%R; auto. repeat rewrite FnormalizeCorrect; auto with real zarith. repeat rewrite FnormalizeCorrect; auto with real zarith. apply FnormalizeBounded; auto with zarith float; apply H with (3*Rabs t)%R; auto. apply FnormalizeBounded; auto with zarith float; apply H with (p+q)%R; auto. intros; apply FnormalizeCanonic; auto with zarith. apply H with (dp-dq)%R; auto. apply SRounds. rewrite FnormalizeCorrect in H4; auto with zarith real. rewrite FnormalizeCorrect in H4; auto with zarith real. assert (- dExp bo + precision < Fexp (Fnormalize radix bo precision d) + precision)%Z; auto with zarith. apply Zlt_powerRZ with radix; auto with real zarith. apply Rle_lt_trans with (1:=U4). unfold FtoRradix; rewrite <- FnormalizeCorrect with radix bo precision d; auto with zarith. rewrite <- Fabs_correct; auto; unfold FtoR, Fabs; simpl. rewrite Rmult_comm; rewrite powerRZ_add; auto with real zarith. apply Rmult_lt_compat_l; auto with real zarith. apply Rlt_le_trans with (Zpos (vNum bo)); auto with zarith real float. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; auto with real zarith. assert (- dExp bo + precision < Fexp (Fnormalize radix bo precision t) + precision)%Z; auto with zarith. apply Zlt_powerRZ with radix; auto with real zarith. apply Rle_lt_trans with (1:=U7). unfold FtoRradix; rewrite <- FnormalizeCorrect with radix bo precision t; auto with zarith. rewrite <- Fabs_correct; auto; unfold FtoR, Fabs; simpl. rewrite Rmult_comm; rewrite powerRZ_add; auto with real zarith. apply Rmult_lt_compat_l; auto with real zarith. apply Rlt_le_trans with (Zpos (vNum bo)); auto with zarith real float. assert (Fbounded bo (Fnormalize radix bo precision t)); auto with zarith float real. elim H3; auto. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; auto with real zarith. apply H0; auto. apply H with (b*b)%R; auto. cut (exists f:float, Fbounded bo f /\ (FtoRradix f=(powerRZ radix (- dExp bo + precision - 1)))%R). intros T; elim T; intros f T'; elim T'; intros; clear T T'. rewrite <- H5; unfold FtoRradix. apply RoundAbsMonotonel with bo precision (Closest bo radix) (b*b)%R; auto with zarith float real. apply ClosestRoundedModeP with precision; auto with zarith. elim Roundp; auto. fold FtoRradix; rewrite H5; auto. apply Rle_trans with (2:=U1); auto with zarith real. exists (Float 1 (-dExp bo+precision-1)). split;[split|idtac]. simpl; apply vNumbMoreThanOne with radix precision; auto with zarith. apply Zle_trans with (- dExp bo + precision - 1)%Z; auto with zarith. unfold FtoRradix, FtoR; simpl; ring. apply H0; auto. apply H with (a*c)%R; auto. cut (exists f:float, Fbounded bo f /\ (FtoRradix f=(powerRZ radix (- dExp bo + precision - 1)))%R). intros T; elim T; intros f T'; elim T'; intros; clear T T'. rewrite <- H5; unfold FtoRradix. apply RoundAbsMonotonel with bo precision (Closest bo radix) (a*c)%R; auto with zarith float real. apply ClosestRoundedModeP with precision; auto with zarith. elim Roundq; auto. fold FtoRradix; rewrite H5; auto. apply Rle_trans with (2:=U2); auto with zarith real. exists (Float 1 (-dExp bo+precision-1)). split;[split|idtac]. simpl; apply vNumbMoreThanOne with radix precision; auto with zarith. apply Zle_trans with (- dExp bo + precision - 1)%Z; auto with zarith. unfold FtoRradix, FtoR; simpl; ring. apply H0; auto; apply H with (3*Rabs t)%R; auto. apply H0; auto; apply H with (p+q)%R; auto. generalize (EvenClosestCompatible bo radix precision); unfold CompatibleP. intros T; apply T with (b*b)%R p; auto with real float zarith. rewrite FnormalizeCorrect; auto with zarith real. apply FnormalizeBounded; auto with zarith;apply H with (b*b)%R; auto. generalize (EvenClosestCompatible bo radix precision); unfold CompatibleP. intros T; apply T with (a*c)%R q; auto with real float zarith. rewrite FnormalizeCorrect; auto with zarith real. apply FnormalizeBounded; auto with zarith;apply H with (a*c)%R; auto. repeat rewrite FnormalizeCorrect; auto with zarith real. generalize (EvenClosestCompatible bo radix precision); unfold CompatibleP. intros T; apply T with (p-q)%R t; auto with real float zarith. rewrite FnormalizeCorrect; auto with zarith real. apply FnormalizeBounded; auto with zarith;apply H with (p-q)%R; auto. rewrite FnormalizeCorrect; auto with zarith real. generalize (EvenClosestCompatible bo radix precision); unfold CompatibleP. intros T; apply T with (3*Rabs t)%R u; auto with real float zarith. rewrite FnormalizeCorrect; auto with zarith real. apply FnormalizeBounded; auto with zarith;apply H with (3*Rabs t)%R; auto. repeat rewrite FnormalizeCorrect; auto with zarith real. generalize (EvenClosestCompatible bo radix precision); unfold CompatibleP. intros T; apply T with (p+q)%R v; auto with real float zarith. rewrite FnormalizeCorrect; auto with zarith real. apply FnormalizeBounded; auto with zarith;apply H with (p+q)%R; auto. repeat rewrite FnormalizeCorrect; auto with zarith real. fold FtoRradix; intros. generalize (EvenClosestCompatible bo radix precision); unfold CompatibleP. intros T; apply T with (p-q)%R d; auto with real float zarith. rewrite FnormalizeCorrect; auto with zarith real. rewrite FnormalizeCorrect; auto with zarith real. rewrite FnormalizeCorrect; auto with zarith real. repeat rewrite FnormalizeCorrect; auto with zarith real. fold FtoRradix; intros. generalize (EvenClosestCompatible bo radix precision); unfold CompatibleP. intros T; apply T with (dp-dq)%R s; auto with real float zarith. rewrite FnormalizeCorrect; auto with zarith real. apply FnormalizeBounded; auto with zarith;apply H with (dp-dq)%R; auto. repeat rewrite FnormalizeCorrect; auto with zarith real. fold FtoRradix; intros. generalize (EvenClosestCompatible bo radix precision); unfold CompatibleP. intros T; apply T with (t+s)%R d; auto with real float zarith. rewrite FnormalizeCorrect; auto with zarith real. Qed. End Discriminant6. Section Discriminant7. Variable bo : Fbound. Variable precision : nat. Let radix := 2%Z. Let FtoRradix := FtoR radix. Coercion FtoRradix : float >-> R. Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ TwoMoreThanOne). Hint Resolve radixMoreThanZERO: zarith. Hypothesis precisionGreaterThanOne : 1 < precision. Hypothesis pGivesBound : Zpos (vNum bo) = Zpower_nat radix precision. Hypothesis precisionGreaterThanFour : 4 <= precision. Theorem FexpGeUnderf: forall e:Z, forall f:float, (Fbounded bo f) -> ((powerRZ radix e) <= Rabs f)%R -> (e-precision+1 <= Fexp f)%Z. intros. assert (e < Fexp f+precision)%Z; auto with zarith. apply Zlt_powerRZ with radix;auto with real zarith. apply Rle_lt_trans with (1:=H0). unfold FtoRradix; rewrite <- Fabs_correct; auto. rewrite Zplus_comm; rewrite powerRZ_add; auto with real zarith. unfold Fabs, FtoR; simpl. apply Rmult_lt_compat_r; auto with real zarith. apply Rlt_le_trans with (Zpos (vNum bo)); auto with zarith float real. rewrite pGivesBound; rewrite Zpower_nat_Z_powerRZ; auto with real zarith. Qed. Theorem AddExpGeUnderf: forall f1:float ,forall f2:float, forall g:float, forall e:Z, Closest bo radix (f1+f2) g -> (Fbounded bo f1) -> (Fbounded bo f2) -> (powerRZ radix e <= Rabs f1)%R -> (powerRZ radix e <= Rabs f2)%R -> ((FtoRradix g=0)%R \/ (powerRZ radix (e-precision+1) <= Rabs g)%R). intros. case (Req_dec g 0); auto; intros. right. elim plusExactExp with bo radix precision f1 f2 g; auto with zarith. intros s T; elim T; intros g' T'; elim T'; intros R1 T''; clear T T'. elim T''; intros R2 T; elim T; intros R3 T'; elim T'; intros R4 TT; clear T T' T''. elim TT; intros R5 T; elim T; intros R6 R7; clear T TT. replace (FtoRradix g) with (FtoRradix g'); auto with real. apply Rle_trans with (powerRZ radix (Fexp g')). apply Rle_powerRZ; auto with real zarith. apply Zle_trans with (Zmin (Fexp f1) (Fexp f2)); auto with zarith. apply Zmin_Zle; apply FexpGeUnderf; auto. unfold FtoRradix; rewrite <- Fabs_correct; auto. unfold Fabs, FtoR; simpl. apply Rle_trans with (1%Z*powerRZ 2 (Fexp g'))%R; [simpl; right; ring|apply Rmult_le_compat_r; auto with real zarith]. case (Zle_lt_or_eq 0 (Zabs (Fnum g'))); auto with zarith real; intros. case (Z_eq_dec 0 (Fnum g')); intros. absurd (FtoR radix g=0)%R; auto with real. rewrite <- R3; unfold FtoR; simpl; rewrite <- e0; simpl; ring. absurd (0 < Zabs (Fnum g'))%Z; auto with zarith. apply Zlt_le_trans with (Zabs_nat (Fnum g')); auto with zarith. assert (0 < Zabs_nat (Fnum g')); auto with zarith arith. apply absolu_lt_nz; auto. rewrite Zabs_absolu; auto with zarith. Qed. Theorem AddExpGeUnderf2: forall f1:float ,forall f2:float, forall g:float, forall e:Z, Closest bo radix (f1+f2) g -> (Fbounded bo f1) -> (Fbounded bo f2) -> (powerRZ radix e <= Rabs f1)%R -> (powerRZ radix e <= Rabs f2)%R -> (FtoRradix g <>0)%R -> (powerRZ radix (e-precision+1) <= Rabs g)%R. intros. case (AddExpGeUnderf f1 f2 g e); auto. intros; absurd (FtoRradix g=0); auto with real. Qed. Theorem AddExpGe1Underf: forall f1:float ,forall f2:float, forall g:float, forall e:Z, Closest bo radix (f1+f2) g -> (Fcanonic radix bo f1) -> (Fcanonic radix bo f2) -> (powerRZ radix e <= Rabs f1)%R -> (-dExp bo <= e-1)%Z -> ((FtoRradix g=0)%R \/ (powerRZ radix (e-precision) <= Rabs g)%R). intros. assert (F1:(Fbounded bo f1));[apply FcanonicBound with radix; auto|idtac]. assert (F2:(Fbounded bo f2));[apply FcanonicBound with radix; auto|idtac]. case (Req_dec g 0); auto; intros. right. case (Rle_or_lt (Rabs f1) (Rabs f2)); intros. apply Rle_trans with (powerRZ radix (e-precision+1)). apply Rle_powerRZ; auto with real zarith. apply AddExpGeUnderf2 with f1 f2; auto with real. apply Rle_trans with (1:=H2); auto with real. case (Rle_or_lt (Rabs f2) ((Rabs f1)/2)); intros. apply Rle_trans with (powerRZ radix (e-1)). apply Rle_powerRZ; auto with real zarith. assert (exists f:float, Fbounded bo f /\ (FtoRradix f=powerRZ radix (e - 1))%R). exists (Float 1 (e-1)); split. split; simpl; auto with zarith float. apply vNumbMoreThanOne with radix precision; auto with zarith. unfold FtoRradix, FtoR; simpl; ring. elim H7; intros f T; elim T; intros; clear H7 T. rewrite <- H9; unfold FtoRradix. apply RoundAbsMonotonel with bo precision (Closest bo radix) (f1+f2)%R; auto. apply ClosestRoundedModeP with precision; auto with zarith. fold FtoRradix; rewrite H9. unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl. ring_simplify(2*1)%R; apply Rle_trans with ((Rabs f1)/2)%R. unfold Rdiv; apply Rmult_le_compat_r; auto with real. apply Rle_trans with (Rabs f1 -(Rabs f1)/2)%R;[right; field; auto with real|idtac]. apply Rle_trans with (Rabs f1-Rabs f2)%R. unfold Rminus; apply Rplus_le_compat_l; auto with real. rewrite <- (Rabs_Ropp f2). replace (f1+f2)%R with (f1-(-f2))%R; try ring. apply Rabs_triang_inv. elim plusExactExp with bo radix precision f1 f2 g; auto with zarith. intros s T; elim T; intros g' T'; elim T'; intros R1 T''; clear T T'. elim T''; intros R2 T; elim T; intros R3 T'; elim T'; intros R4 TT; clear T T' T''. elim TT; intros R5 T; elim T; intros R6 R7; clear T TT. replace (FtoRradix g) with (FtoRradix g'); auto with real. apply Rle_trans with (powerRZ radix (Fexp g')). apply Rle_powerRZ; auto with real zarith. apply Zle_trans with (Zmin (Fexp f1) (Fexp f2)); auto with zarith. rewrite Zmin_le2. apply Zle_trans with ((e-1)-precision+1)%Z; auto with zarith. apply FexpGeUnderf; auto. unfold Zminus; rewrite powerRZ_add; auto with real zarith; simpl. ring_simplify (2*1)%R; apply Rle_trans with ((Rabs f1)/2)%R; auto with real. unfold Rdiv; apply Rmult_le_compat_r; auto with real. apply Fcanonic_Rle_Zle with radix bo precision; auto with zarith real. unfold FtoRradix; rewrite <- Fabs_correct; auto. unfold Fabs, FtoR; simpl. apply Rle_trans with (1%Z*powerRZ 2 (Fexp g'))%R; [simpl; right; ring|apply Rmult_le_compat_r; auto with real zarith]. case (Zle_lt_or_eq 0 (Zabs (Fnum g'))); auto with zarith real; intros. case (Z_eq_dec 0 (Fnum g')); intros. absurd (FtoR radix g=0)%R; auto with real. rewrite <- R3; unfold FtoR; simpl; rewrite <- e0; simpl; ring. absurd (0 < Zabs (Fnum g'))%Z; auto with zarith. apply Zlt_le_trans with (Zabs_nat (Fnum g')); auto with zarith. assert (0 < Zabs_nat (Fnum g')); auto with zarith arith. apply absolu_lt_nz; auto. rewrite Zabs_absolu; auto with zarith. Qed. Theorem AddExpGe1Underf2: forall f1:float ,forall f2:float, forall g:float, forall e:Z, Closest bo radix (f1+f2) g -> (Fbounded bo f1) -> (Fbounded bo f2) -> (powerRZ radix e <= Rabs f1)%R -> (-dExp bo <= e-1)%Z -> (FtoRradix g <>0)%R -> (powerRZ radix (e-precision) <= Rabs g)%R. intros. case (AddExpGe1Underf (Fnormalize radix bo precision f1) (Fnormalize radix bo precision f2) g e); auto. unfold FtoRradix; repeat rewrite FnormalizeCorrect; auto with real. apply FnormalizeCanonic; auto with zarith. apply FnormalizeCanonic; auto with zarith. unfold FtoRradix; rewrite FnormalizeCorrect; auto with real. intros; absurd (FtoRradix g=0); auto with real. Qed. Variables a b c p q t dp dq s d u v:float. Let delta := (Rabs (d-(b*b-a*c)))%R. Hypothesis Fa : (Fbounded bo a). Hypothesis Fb : (Fbounded bo b). Hypothesis Fc : (Fbounded bo c). Hypothesis Fdp: (u < v)%R -> (Fbounded bo dp). Hypothesis Fdq: (u < v)%R -> (Fbounded bo dq). (** There is no underflow *) Hypothesis U1: (FtoRradix b=0)%R \/ (powerRZ radix (-dExp bo+3*precision-1) <= Rabs (b*b))%R. Hypothesis U2: (a*c=0)%R \/ (powerRZ radix (-dExp bo+3*precision-1) <= Rabs (a*c))%R. Hypothesis Roundp : (EvenClosest bo radix precision (b*b)%R p). Hypothesis Roundq : (EvenClosest bo radix precision (a*c)%R q). Hypothesis Roundt : (EvenClosest bo radix precision (p-q)%R t). Hypothesis Roundu : (EvenClosest bo radix precision (3*Rabs t)%R u). Hypothesis Roundv : (EvenClosest bo radix precision (p+q)%R v). Hypothesis FRoundd : (v <= u)%R -> (EvenClosest bo radix precision (p-q)%R d). Hypothesis dpEq : (FtoRradix dp=b*b-p)%R. Hypothesis dqEq : (FtoRradix dq=a*c-q)%R. Hypothesis SRounds : (u < v)%R -> (EvenClosest bo radix precision (dp-dq)%R s). Hypothesis SRoundd : (u < v)%R -> (EvenClosest bo radix precision (t+s)%R d). Theorem pGeUnderf: (FtoRradix b <> 0)%R -> (powerRZ radix (-dExp bo+3*precision-1) <= Rabs (p))%R. case U1; intros. absurd (FtoRradix b=0); auto with real. assert (exists f:float, Fbounded bo f /\ (powerRZ radix (- dExp bo + 3 * precision - 1)= f)%R). exists (Float 1 (- dExp bo + 3 * precision - 1)). split;[split|unfold FtoRradix, FtoR; simpl; ring]. simpl; apply vNumbMoreThanOne with radix precision; auto with zarith. apply Zle_trans with (- dExp bo + 3 * precision - 1)%Z; auto with zarith. elim H1; intros f T; elim T; intros; clear H1 T. rewrite H3; unfold FtoRradix. apply RoundAbsMonotonel with bo precision (EvenClosest bo radix precision) (b*b)%R; auto with real zarith float. fold FtoRradix; rewrite <- H3; auto. Qed. Theorem qGeUnderf: (a*c <> 0)%R -> (powerRZ radix (-dExp bo+3*precision-1) <= Rabs (q))%R. case U2; intros. absurd (a*c=0)%R; auto with real. assert (exists f:float, Fbounded bo f /\ (powerRZ radix (- dExp bo + 3 * precision - 1)= f)%R). exists (Float 1 (- dExp bo + 3 * precision - 1)). split;[split|unfold FtoRradix, FtoR; simpl; ring]. simpl; apply vNumbMoreThanOne with radix precision; auto with zarith. apply Zle_trans with (- dExp bo + 3 * precision - 1)%Z; auto with zarith. elim H1; intros f T; elim T; intros; clear H1 T. rewrite H3; unfold FtoRradix. apply RoundAbsMonotonel with bo precision (EvenClosest bo radix precision) (a*c)%R; auto with real zarith float. fold FtoRradix; rewrite <- H3; auto. Qed. Theorem cases: (FtoRradix b=0)%R \/ (a*c=0)%R \/ (FtoRradix d=0)%R \/ (FtoRradix v=0)%R \/ (FtoRradix t=0)%R \/ ((powerRZ radix (-dExp bo+2*precision-1) <= Rabs (b*b))%R /\ (powerRZ radix (-dExp bo+2*precision-1) <= Rabs (a*c))%R /\ (powerRZ radix (-dExp bo+precision) <= Rabs d)%R /\ (powerRZ radix (-dExp bo+precision-1) <= Rabs u)%R /\ (powerRZ radix (-dExp bo+precision-1) <= Rabs v)%R /\ (powerRZ radix (-dExp bo+precision) <= Rabs t)%R). case U1; auto; intros. case U2; auto; intros. case (Req_dec b 0); auto with real; intros; right. case (Req_dec (a*c) 0); auto with real; intros; right. assert (True); auto. case (Req_dec d 0); auto with real; intros; right. case (Req_dec v 0); auto with real; intros; right. case (Req_dec t 0); auto with real; intros; right. assert (powerRZ radix (-dExp bo+3*precision-1) <= Rabs (p))%R. apply pGeUnderf; auto with real. assert (powerRZ radix (-dExp bo+3*precision-1) <= Rabs (q))%R. apply qGeUnderf; auto with real. assert (powerRZ radix (-dExp bo+2*precision) <= Rabs v)%R. replace (-dExp bo+2*precision)%Z with ((-dExp bo+3*precision-1)-precision+1)%Z; auto with zarith. apply AddExpGeUnderf2 with p q; auto. elim Roundv; auto. elim Roundp; intros A1 A2; elim A1; auto. elim Roundq; intros A1 A2; elim A1; auto. assert (powerRZ radix (-dExp bo+2*precision) <= Rabs t)%R. replace (-dExp bo+2*precision)%Z with ((-dExp bo+3*precision-1)-precision+1)%Z; auto with zarith. apply AddExpGeUnderf2 with p (Fopp q); auto. unfold FtoRradix; rewrite Fopp_correct; elim Roundt; auto with real. elim Roundp; intros A1 A2; elim A1; auto. apply oppBounded; elim Roundq; intros A1 A2; elim A1; auto. unfold FtoRradix; rewrite Fopp_correct;rewrite Rabs_Ropp; auto with real. assert (powerRZ radix (-dExp bo+precision+1) <= Rabs u)%R. replace (-dExp bo+precision+1)%Z with ((-dExp bo+2*precision)-precision+1)%Z; auto with zarith. apply AddExpGeUnderf2 with (Fabs t) (Fabs (Float (Fnum t) (Fexp t+1))); auto. replace (Fabs t + Fabs (Float (Fnum t) (Fexp t + 1)))%R with (3*Rabs t)%R; [elim Roundu; auto|idtac]. unfold FtoRradix; rewrite <- Fabs_correct; auto; unfold FtoR, Fabs; simpl. rewrite powerRZ_add; auto with real zarith; simpl; ring. apply absFBounded; elim Roundt; intros A1 A2; elim A1; auto. elim Roundt; intros A1 A2; elim A1; intros A4 A3; elim A4; intros. split; unfold Fabs; simpl; auto with zarith. rewrite Zabs_eq; auto with zarith. unfold FtoRradix; rewrite Fabs_correct; auto. rewrite Rabs_right; auto with real. apply Rle_trans with (1:=H10). apply Rle_trans with (1*Rabs t)%R; auto with real. apply Rle_trans with (2*Rabs t)%R; auto with real. unfold FtoRradix; rewrite Fabs_correct; auto. rewrite Rabs_right with (Rabs (FtoR radix (Float (Fnum t) (Fexp t + 1)))); auto with real. repeat rewrite <- Fabs_correct; auto; unfold FtoR, Fabs; simpl. rewrite powerRZ_add; auto with real zarith; simpl; right; ring. assert (0 < u)%R; auto with real. apply Rlt_le_trans with (Rabs t); auto with real. assert (Rabs t <> 0)%R; auto with real. apply Rabs_no_R0; auto with real. assert (A:(0 <= Rabs t)%R); auto with real; case A; auto with real. intros; absurd (Rabs t=0)%R; auto with real. unfold FtoRradix; rewrite <- Fabs_correct; auto. apply RleBoundRoundl with bo precision (EvenClosest bo radix precision) (3 * Rabs t)%R; auto with zarith float. apply absFBounded; elim Roundt; intros A1 A2; elim A1; auto. apply Rle_trans with (1*Rabs t)%R; auto with real. rewrite Fabs_correct; auto; right; unfold FtoRradix; ring. apply Rmult_le_compat_r; auto with real. apply Rle_trans with 2%R; auto with real. split. apply Rle_trans with (2:=H); auto with real zarith. split. apply Rle_trans with (2:=H0); auto with real zarith. split. 2: split. 2: apply Rle_trans with (2:=H11); auto with real zarith. 2:split. 2:apply Rle_trans with (2:=H9); auto with real zarith. 2:apply Rle_trans with (2:=H10); auto with real zarith. case (Rle_or_lt v u); intros. assert (powerRZ radix (-dExp bo+2*precision) <= Rabs d)%R. replace (-dExp bo+2*precision)%Z with ((-dExp bo+3*precision-1)-precision+1)%Z; auto with zarith. apply AddExpGeUnderf2 with p (Fopp q); auto. unfold FtoRradix; rewrite Fopp_correct; elim FRoundd; auto with real. elim Roundp; intros A1 A2; elim A1; auto. apply oppBounded; elim Roundq; intros A1 A2; elim A1; auto. unfold FtoRradix; rewrite Fopp_correct;rewrite Rabs_Ropp; auto with real. apply Rle_trans with (2:=H13); auto with real zarith. replace (-dExp bo+precision)%Z with ((-dExp bo+2*precision)-precision)%Z; auto with zarith. apply AddExpGe1Underf2 with t s; auto with zarith. elim SRoundd; auto with real. elim Roundt; intros A1 A2; elim A1; auto. elim SRounds; auto; intros A1 A2; elim A1; auto. Qed. Theorem discri16: (FtoRradix d=0)%R \/ (delta <= 2*(Fulp bo radix precision d))%R. assert (Fq:(Fbounded bo q)). elim Roundq; intros A1 A2; elim A1; auto with zarith float. assert (Fp:(Fbounded bo p)). elim Roundp; intros A1 A2; elim A1; auto with zarith float. assert (Fd:(Fbounded bo d)). case (Rle_or_lt v u); intros. elim FRoundd; auto; intros L; elim L; intros A1 A2; elim A1; auto with zarith float. elim SRoundd; auto; intros L; elim L; intros A1 A2; elim A1; auto with zarith float. generalize cases; intros C. case C; clear C; intros C. assert (FtoRradix p=0)%R; auto with real. assert (0 <= p)%R. unfold FtoRradix; apply RleRoundedR0 with bo precision (EvenClosest bo radix precision) (b*b)%R; auto with real float zarith. rewrite C; right; ring. assert (p <= 0)%R; auto with real. unfold FtoRradix; apply RleRoundedLessR0 with bo precision (EvenClosest bo radix precision) (b*b)%R; auto with real float zarith. rewrite C; right; ring. assert (FtoRradix d=(Fopp q))%R. apply sym_eq; unfold FtoRradix; apply RoundedModeProjectorIdemEq with bo precision (EvenClosest bo radix precision); auto with float zarith. replace (FtoR radix (Fopp q)) with (p-q)%R; [apply FRoundd| rewrite Fopp_correct; fold FtoRradix; rewrite H; ring]. unfold FtoRradix; apply EvenClosestMonotone2 with bo precision (p+q)%R (3*Rabs t)%R; auto. replace (FtoRradix t) with (FtoRradix (Fopp q)). unfold FtoRradix; rewrite Fopp_correct;auto; fold FtoRradix. rewrite H; ring_simplify (0+q)%R. rewrite Rabs_Ropp; apply Rle_trans with (1:=(RRle_abs q)). apply Rle_trans with (1*(Rabs q))%R; auto with real. apply Rmult_le_compat_r; auto with real. apply Rle_trans with 2%R; auto with real. unfold FtoRradix; apply RoundedModeProjectorIdemEq with bo precision (EvenClosest bo radix precision); auto with float zarith. replace (FtoR radix (Fopp q)) with (p-q)%R; [auto| rewrite Fopp_correct; fold FtoRradix; rewrite H; ring]. right; unfold delta; rewrite H0. unfold FtoRradix; rewrite Fopp_correct; fold FtoRradix. replace (-q-(b*b-a*c))%R with ((a*c-q))%R;[idtac|rewrite C; ring]. apply Rle_trans with (/2*(Fulp bo radix precision q))%R. apply Rmult_le_reg_l with (2%nat)%R; auto with real zarith. apply Rle_trans with (Fulp bo radix precision q);[idtac|simpl; right; field; auto with real]. unfold FtoRradix; apply ClosestUlp; auto. elim Roundq; auto. apply Rle_trans with (2 * Fulp bo radix precision q)%R; [apply Rmult_le_compat_r; auto with real|idtac]. unfold Fulp; auto with real zarith. apply Rle_trans with 1%R; auto with real. apply Rle_trans with (/1)%R; auto with real. apply Rmult_le_compat_l; auto with real; right. apply trans_eq with (Fulp bo radix precision (Fopp q)). unfold Fulp; rewrite Fnormalize_Fopp; auto with real zarith. apply FulpComp; auto with float zarith. case C; clear C; intros C. assert (FtoRradix q=0)%R; auto with real. assert (0 <= q)%R. unfold FtoRradix; apply RleRoundedR0 with bo precision (EvenClosest bo radix precision) (a*c)%R; auto with real float zarith. assert (q <= 0)%R; auto with real. unfold FtoRradix; apply RleRoundedLessR0 with bo precision (EvenClosest bo radix precision) (a*c)%R; auto with real float zarith. assert (FtoRradix d=p)%R. apply sym_eq; unfold FtoRradix; apply RoundedModeProjectorIdemEq with bo precision (EvenClosest bo radix precision); auto with float zarith. replace (FtoR radix p) with (p-q)%R; [apply FRoundd| fold FtoRradix; rewrite H; ring]. unfold FtoRradix; apply EvenClosestMonotone2 with bo precision (p+q)%R (3*Rabs t)%R; auto. replace (FtoRradix t) with (FtoRradix p). rewrite H; ring_simplify (p+0)%R; apply Rle_trans with (1:=(RRle_abs p)). apply Rle_trans with (1*(Rabs p))%R; auto with real. apply Rmult_le_compat_r; auto with real. apply Rle_trans with 2%R; auto with real. unfold FtoRradix; apply RoundedModeProjectorIdemEq with bo precision (EvenClosest bo radix precision); auto with float zarith. replace (FtoR radix p) with (p-q)%R; [auto| fold FtoRradix; rewrite H; ring]. right; unfold delta; rewrite H0. replace (p-(b*b-a*c))%R with ((-(b*b-p)))%R;[idtac|rewrite C; ring]. apply Rle_trans with (/2*(Fulp bo radix precision p))%R. apply Rmult_le_reg_l with (2%nat)%R; auto with real zarith. apply Rle_trans with (Fulp bo radix precision p);[idtac|simpl; right; field; auto with real]. rewrite Rabs_Ropp; unfold FtoRradix; apply ClosestUlp; auto. elim Roundp; auto. rewrite FulpComp with bo radix precision d p; auto with float zarith. apply Rmult_le_compat_r; auto with real. unfold Fulp; auto with real zarith. apply Rle_trans with (/1)%R; auto with real. apply Rle_trans with 1%R; auto with real. case (Req_dec v 0)%R. clear C; intros C. assert (v <= u)%R. rewrite C; unfold FtoRradix; apply RleRoundedR0 with bo precision (EvenClosest bo radix precision) (3*Rabs t)%R; auto with real float zarith. apply Rle_trans with (0*0)%R; auto with real; apply Rmult_le_compat; auto with real. apply Rle_trans with 2%R; auto with real. assert (FtoRradix q=-p)%R. assert (FtoRradix v=p+q)%R. unfold FtoRradix; apply plusExactR0 with bo precision; auto with real. elim Roundv; auto. apply Rplus_eq_reg_l with p. rewrite <- H0; rewrite C; ring. assert (FtoRradix d=2*p)%R. assert (exists f:float, Fbounded bo f /\ (FtoRradix f=2*p)%R). exists (Float (Fnum p) (Fexp p+1)); split. elim Fp; intros; split; simpl; auto with zarith. unfold FtoRradix, FtoR; simpl; rewrite powerRZ_add; auto with real zarith; simpl; ring. elim H1; intros f T; elim T; intros; clear T H1. rewrite <- H3; unfold FtoRradix; apply sym_eq. apply RoundedModeProjectorIdemEq with bo precision (EvenClosest bo radix precision); auto with float zarith. replace (FtoR radix f) with (p-q)%R; auto. fold FtoRradix; rewrite H3; rewrite H0; ring. right; unfold delta. replace (d - (b * b - a * c))%R with (-(b*b-p)+(a*c-q))%R; [idtac|rewrite H1; rewrite H0; ring]. apply Rle_trans with (Rabs (- (b * b - p)) + Rabs ((a * c - q)))%R; [apply Rabs_triang|idtac]. apply Rle_trans with (/2*(Fulp bo radix precision p) +/2*(Fulp bo radix precision q))%R. apply Rplus_le_compat; apply Rmult_le_reg_l with (2%nat)%R; auto with real zarith. apply Rle_trans with (Fulp bo radix precision p); [idtac|simpl; right; field; auto with real]. rewrite Rabs_Ropp; unfold FtoRradix; apply ClosestUlp; auto. elim Roundp; auto. apply Rle_trans with (Fulp bo radix precision q); [idtac|simpl; right; field; auto with real]. unfold FtoRradix; apply ClosestUlp; auto. elim Roundq; auto. replace (Fulp bo radix precision q) with (Fulp bo radix precision p). apply Rle_trans with (Fulp bo radix precision p); [right; field; auto with real|idtac]. apply Rle_trans with (1*(Fulp bo radix precision d))%R; [idtac|apply Rmult_le_compat_r; unfold Fulp; auto with real zarith]. apply Rle_trans with (Fulp bo radix precision d); auto with real. assert (0 <= p)%R. apply P_positive with bo precision b b; auto. fold FtoRradix; apply Rle_trans with (Rsqr b); auto with real. apply LeFulpPos; auto with real zarith. fold FtoRradix; rewrite H1; apply Rle_trans with (1*p)%R; auto with real. apply trans_eq with (Fulp bo radix precision (Fopp p)). unfold Fulp; rewrite Fnormalize_Fopp; auto with real zarith. apply FulpComp; auto with float zarith. rewrite Fopp_correct; auto with real zarith. intros C'. case (Req_dec t 0). clear C; intros C. assert (FtoRradix p=q)%R. assert (FtoRradix t=p+ Fopp q)%R. unfold FtoRradix; apply plusExactR0 with bo precision; auto with real zarith float. elim Roundt; intros; rewrite Fopp_correct; auto with real. apply Rplus_eq_reg_l with (Fopp q); rewrite Rplus_comm. rewrite <- H; rewrite C; unfold FtoRradix; rewrite Fopp_correct; auto; ring. assert (FtoRradix v=2*p)%R. assert (exists f:float, Fbounded bo f /\ (FtoRradix f=2*p)%R). exists (Float (Fnum p) (Fexp p+1)); split. elim Fp; intros; split; simpl; auto with zarith. unfold FtoRradix, FtoR; simpl; rewrite powerRZ_add; auto with real zarith; simpl; ring. elim H0; intros f T; elim T; intros; clear T H0. rewrite <- H2; unfold FtoRradix; apply sym_eq. apply RoundedModeProjectorIdemEq with bo precision (EvenClosest bo radix precision); auto with float zarith. replace (FtoR radix f) with (p+q)%R; auto. fold FtoRradix; rewrite H2; rewrite H; ring. assert (FtoRradix u=0)%R. assert (0 <= u)%R. unfold FtoRradix; apply RleRoundedR0 with bo precision (EvenClosest bo radix precision) (3*Rabs t)%R; auto with real float zarith. rewrite C; rewrite Rabs_R0; right; ring. assert (u <= 0)%R; auto with real. unfold FtoRradix; apply RleRoundedLessR0 with bo precision (EvenClosest bo radix precision) (3*Rabs t)%R; auto with real float zarith. rewrite C; rewrite Rabs_R0; right; ring. assert (u < v)%R. rewrite H1; assert (0 <= v)%R; auto with real. rewrite H0; apply Rle_trans with (0*0)%R; auto with real. apply Rmult_le_compat; auto with real. apply P_positive with bo precision b b; auto. apply Rle_trans with (Rsqr (FtoR radix b)); auto with real. case H2; auto with real. intros T; absurd (FtoRradix v=0)%R; auto with real. assert (FtoRradix d=s)%R. unfold FtoRradix; apply sym_eq. apply RoundedModeProjectorIdemEq with bo precision (EvenClosest bo radix precision); auto with float zarith. elim SRounds; auto; intros A1 A2; elim A1; auto. replace (FtoR radix s) with (t+s)%R; auto. fold FtoRradix; rewrite C; ring. right; unfold delta. replace (d - (b * b - a * c))%R with (-((dp-dq)-s))%R; [idtac|rewrite dpEq; auto; rewrite dqEq; auto; rewrite H3; rewrite H; ring]. apply Rle_trans with (/2*(Fulp bo radix precision s))%R. apply Rmult_le_reg_l with (2%nat)%R; auto with real zarith. apply Rle_trans with (Fulp bo radix precision s); [idtac|simpl; right; field; auto with real]. rewrite Rabs_Ropp; unfold FtoRradix; apply ClosestUlp; auto. elim SRounds; auto. rewrite FulpComp with bo radix precision d s; auto with zarith real. 2: elim SRounds; auto; intros A1 A2; elim A1; auto. apply Rmult_le_compat_r. unfold Fulp; auto with real zarith. apply Rle_trans with (/1)%R; auto with real. apply Rle_trans with 1%R; auto with real. intros C''. case (Rle_or_lt v u); intros. case C; clear C; intros C; auto with real. case C; clear C; intros C; auto with real. absurd (FtoRradix v=0)%R; auto with real. case C; clear C; intros C; auto with real. absurd (FtoRradix t=0)%R; auto with real. elim C; intros Y1 C1; elim C1; intros Y2 C2; elim C2; intros Y3 C3; clear C C1 C2. elim C3; intros Y4 C4; elim C4; intros Y5 Y6; clear C3 C4. right; unfold delta;apply discri15 with p q t dp dq s u v; auto with real zarith float. case C; clear C; intros C; auto with real. case C; clear C; intros C; auto with real. absurd (FtoRradix v=0)%R; auto with real. case C; clear C; intros C; auto with real. absurd (FtoRradix t=0)%R; auto with real. elim C; intros Y1 C1; elim C1; intros Y2 C2; elim C2; intros Y3 C3; clear C C1 C2. elim C3; intros Y4 C4; elim C4; intros Y5 Y6; clear C3 C4. right; unfold delta;apply discri15 with p q t dp dq s u v; auto with real zarith float. Qed. End Discriminant7. Float8.4/Fsucc.v0000644000423700002640000000000012032774527013272 0ustar sboldotoccata