From 0f919eb26c68d3882e612a1b3a9df45bee6d3624 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Wed, 13 Feb 2019 18:53:17 +0100 Subject: Upgrade embedded version of Flocq to 3.1. Main changes to CompCert outside of Flocq are as follows: - Minimal supported version of Coq is now 8.7, due to Flocq requirements. - Most modifications are due to Z2R being dropped in favor of IZR and to the way Flocq now handles NaNs. - CompCert now correctly handles NaNs for the Risc-V architecture (hopefully). --- flocq/Core/Core.v | 22 + flocq/Core/Defs.v | 83 ++ flocq/Core/Digits.v | 1154 ++++++++++++++++++ flocq/Core/FIX.v | 94 ++ flocq/Core/FLT.v | 406 +++++++ flocq/Core/FLX.v | 362 ++++++ flocq/Core/FTZ.v | 340 ++++++ flocq/Core/Fcore.v | 30 - flocq/Core/Fcore_FIX.v | 100 -- flocq/Core/Fcore_FLT.v | 332 ------ flocq/Core/Fcore_FLX.v | 271 ----- flocq/Core/Fcore_FTZ.v | 345 ------ flocq/Core/Fcore_Raux.v | 2524 ---------------------------------------- flocq/Core/Fcore_Zaux.v | 991 ---------------- flocq/Core/Fcore_defs.v | 101 -- flocq/Core/Fcore_digits.v | 1185 ------------------- flocq/Core/Fcore_float_prop.v | 519 --------- flocq/Core/Fcore_generic_fmt.v | 2351 ------------------------------------- flocq/Core/Fcore_rnd.v | 1392 ---------------------- flocq/Core/Fcore_rnd_ne.v | 552 --------- flocq/Core/Fcore_ulp.v | 2322 ------------------------------------ flocq/Core/Float_prop.v | 559 +++++++++ flocq/Core/Generic_fmt.v | 2308 ++++++++++++++++++++++++++++++++++++ flocq/Core/Raux.v | 2402 ++++++++++++++++++++++++++++++++++++++ flocq/Core/Round_NE.v | 547 +++++++++ flocq/Core/Round_pred.v | 1408 ++++++++++++++++++++++ flocq/Core/Ulp.v | 2521 +++++++++++++++++++++++++++++++++++++++ flocq/Core/Zaux.v | 951 +++++++++++++++ 28 files changed, 13157 insertions(+), 13015 deletions(-) create mode 100644 flocq/Core/Core.v create mode 100644 flocq/Core/Defs.v create mode 100644 flocq/Core/Digits.v create mode 100644 flocq/Core/FIX.v create mode 100644 flocq/Core/FLT.v create mode 100644 flocq/Core/FLX.v create mode 100644 flocq/Core/FTZ.v delete mode 100644 flocq/Core/Fcore.v delete mode 100644 flocq/Core/Fcore_FIX.v delete mode 100644 flocq/Core/Fcore_FLT.v delete mode 100644 flocq/Core/Fcore_FLX.v delete mode 100644 flocq/Core/Fcore_FTZ.v delete mode 100644 flocq/Core/Fcore_Raux.v delete mode 100644 flocq/Core/Fcore_Zaux.v delete mode 100644 flocq/Core/Fcore_defs.v delete mode 100644 flocq/Core/Fcore_digits.v delete mode 100644 flocq/Core/Fcore_float_prop.v delete mode 100644 flocq/Core/Fcore_generic_fmt.v delete mode 100644 flocq/Core/Fcore_rnd.v delete mode 100644 flocq/Core/Fcore_rnd_ne.v delete mode 100644 flocq/Core/Fcore_ulp.v create mode 100644 flocq/Core/Float_prop.v create mode 100644 flocq/Core/Generic_fmt.v create mode 100644 flocq/Core/Raux.v create mode 100644 flocq/Core/Round_NE.v create mode 100644 flocq/Core/Round_pred.v create mode 100644 flocq/Core/Ulp.v create mode 100644 flocq/Core/Zaux.v (limited to 'flocq/Core') diff --git a/flocq/Core/Core.v b/flocq/Core/Core.v new file mode 100644 index 00000000..78a140e1 --- /dev/null +++ b/flocq/Core/Core.v @@ -0,0 +1,22 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2010-2018 Sylvie Boldo +#
# +Copyright (C) 2010-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +(** To ease the import *) +Require Export Raux Defs Float_prop Round_pred Generic_fmt Round_NE. +Require Export FIX FLX FLT Ulp. diff --git a/flocq/Core/Defs.v b/flocq/Core/Defs.v new file mode 100644 index 00000000..f5c6f33b --- /dev/null +++ b/flocq/Core/Defs.v @@ -0,0 +1,83 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2009-2018 Sylvie Boldo +#
# +Copyright (C) 2009-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +(** * Basic definitions: float and rounding property *) +Require Import Raux. + +Section Def. + +(** Definition of a floating-point number *) +Record float (beta : radix) := Float { Fnum : Z ; Fexp : Z }. + +Arguments Fnum {beta}. +Arguments Fexp {beta}. + +Variable beta : radix. + +Definition F2R (f : float beta) := + (IZR (Fnum f) * bpow beta (Fexp f))%R. + +(** Requirements on a rounding mode *) +Definition round_pred_total (P : R -> R -> Prop) := + forall x, exists f, P x f. + +Definition round_pred_monotone (P : R -> R -> Prop) := + forall x y f g, P x f -> P y g -> (x <= y)%R -> (f <= g)%R. + +Definition round_pred (P : R -> R -> Prop) := + round_pred_total P /\ + round_pred_monotone P. + +End Def. + +Arguments Fnum {beta}. +Arguments Fexp {beta}. +Arguments F2R {beta}. + +Section RND. + +(** property of being a round toward -inf *) +Definition Rnd_DN_pt (F : R -> Prop) (x f : R) := + F f /\ (f <= x)%R /\ + forall g : R, F g -> (g <= x)%R -> (g <= f)%R. + +(** property of being a round toward +inf *) +Definition Rnd_UP_pt (F : R -> Prop) (x f : R) := + F f /\ (x <= f)%R /\ + forall g : R, F g -> (x <= g)%R -> (f <= g)%R. + +(** property of being a round toward zero *) +Definition Rnd_ZR_pt (F : R -> Prop) (x f : R) := + ( (0 <= x)%R -> Rnd_DN_pt F x f ) /\ + ( (x <= 0)%R -> Rnd_UP_pt F x f ). + +(** property of being a round to nearest *) +Definition Rnd_N_pt (F : R -> Prop) (x f : R) := + F f /\ + forall g : R, F g -> (Rabs (f - x) <= Rabs (g - x))%R. + +Definition Rnd_NG_pt (F : R -> Prop) (P : R -> R -> Prop) (x f : R) := + Rnd_N_pt F x f /\ + ( P x f \/ forall f2 : R, Rnd_N_pt F x f2 -> f2 = f ). + +Definition Rnd_NA_pt (F : R -> Prop) (x f : R) := + Rnd_N_pt F x f /\ + forall f2 : R, Rnd_N_pt F x f2 -> (Rabs f2 <= Rabs f)%R. + +End RND. diff --git a/flocq/Core/Digits.v b/flocq/Core/Digits.v new file mode 100644 index 00000000..bed2e20a --- /dev/null +++ b/flocq/Core/Digits.v @@ -0,0 +1,1154 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2011-2018 Sylvie Boldo +#
# +Copyright (C) 2011-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +Require Import ZArith Zquot. +Require Import Zaux. + +(** Number of bits (radix 2) of a positive integer. + +It serves as an upper bound on the number of digits to ensure termination. +*) + +Fixpoint digits2_Pnat (n : positive) : nat := + match n with + | xH => O + | xO p => S (digits2_Pnat p) + | xI p => S (digits2_Pnat p) + end. + +Theorem digits2_Pnat_correct : + forall n, + let d := digits2_Pnat n in + (Zpower_nat 2 d <= Zpos n < Zpower_nat 2 (S d))%Z. +Proof. +intros n d. unfold d. clear. +assert (Hp: forall m, (Zpower_nat 2 (S m) = 2 * Zpower_nat 2 m)%Z) by easy. +induction n ; simpl digits2_Pnat. +rewrite Zpos_xI, 2!Hp. +omega. +rewrite (Zpos_xO n), 2!Hp. +omega. +now split. +Qed. + +Section Fcore_digits. + +Variable beta : radix. + +Definition Zdigit n k := Z.rem (Z.quot n (Zpower beta k)) beta. + +Theorem Zdigit_lt : + forall n k, + (k < 0)%Z -> + Zdigit n k = Z0. +Proof. +intros n [|k|k] Hk ; try easy. +now case n. +Qed. + +Theorem Zdigit_0 : + forall k, Zdigit 0 k = Z0. +Proof. +intros k. +unfold Zdigit. +rewrite Zquot_0_l. +apply Zrem_0_l. +Qed. + +Theorem Zdigit_opp : + forall n k, + Zdigit (-n) k = Z.opp (Zdigit n k). +Proof. +intros n k. +unfold Zdigit. +rewrite Zquot_opp_l. +apply Zrem_opp_l. +Qed. + +Theorem Zdigit_ge_Zpower_pos : + forall e n, + (0 <= n < Zpower beta e)%Z -> + forall k, (e <= k)%Z -> Zdigit n k = Z0. +Proof. +intros e n Hn k Hk. +unfold Zdigit. +rewrite Z.quot_small. +apply Zrem_0_l. +split. +apply Hn. +apply Z.lt_le_trans with (1 := proj2 Hn). +replace k with (e + (k - e))%Z by ring. +rewrite Zpower_plus. +rewrite <- (Zmult_1_r (beta ^ e)) at 1. +apply Zmult_le_compat_l. +apply (Zlt_le_succ 0). +apply Zpower_gt_0. +now apply Zle_minus_le_0. +apply Zlt_le_weak. +now apply Z.le_lt_trans with n. +generalize (Z.le_lt_trans _ _ _ (proj1 Hn) (proj2 Hn)). +clear. +now destruct e as [|e|e]. +now apply Zle_minus_le_0. +Qed. + +Theorem Zdigit_ge_Zpower : + forall e n, + (Z.abs n < Zpower beta e)%Z -> + forall k, (e <= k)%Z -> Zdigit n k = Z0. +Proof. +intros e [|n|n] Hn k. +easy. +apply Zdigit_ge_Zpower_pos. +now split. +intros He. +change (Zneg n) with (Z.opp (Zpos n)). +rewrite Zdigit_opp. +rewrite Zdigit_ge_Zpower_pos with (2 := He). +apply Z.opp_0. +now split. +Qed. + +Theorem Zdigit_not_0_pos : + forall e n, (0 <= e)%Z -> + (Zpower beta e <= n < Zpower beta (e + 1))%Z -> + Zdigit n e <> Z0. +Proof. +intros e n He (Hn1,Hn2). +unfold Zdigit. +rewrite <- ZOdiv_mod_mult. +rewrite Z.rem_small. +intros H. +apply Zle_not_lt with (1 := Hn1). +rewrite (Z.quot_rem' n (beta ^ e)). +rewrite H, Zmult_0_r, Zplus_0_l. +apply Zrem_lt_pos_pos. +apply Z.le_trans with (2 := Hn1). +apply Zpower_ge_0. +now apply Zpower_gt_0. +split. +apply Z.le_trans with (2 := Hn1). +apply Zpower_ge_0. +replace (beta ^ e * beta)%Z with (beta ^ (e + 1))%Z. +exact Hn2. +rewrite <- (Zmult_1_r beta) at 3. +now apply (Zpower_plus beta e 1). +Qed. + +Theorem Zdigit_not_0 : + forall e n, (0 <= e)%Z -> + (Zpower beta e <= Z.abs n < Zpower beta (e + 1))%Z -> + Zdigit n e <> Z0. +Proof. +intros e n He Hn. +destruct (Zle_or_lt 0 n) as [Hn'|Hn']. +rewrite (Z.abs_eq _ Hn') in Hn. +now apply Zdigit_not_0_pos. +intros H. +rewrite (Zabs_non_eq n) in Hn by now apply Zlt_le_weak. +apply (Zdigit_not_0_pos _ _ He Hn). +now rewrite Zdigit_opp, H. +Qed. + +Theorem Zdigit_mul_pow : + forall n k k', (0 <= k')%Z -> + Zdigit (n * Zpower beta k') k = Zdigit n (k - k'). +Proof. +intros n k k' Hk'. +destruct (Zle_or_lt k' k) as [H|H]. +revert k H. +pattern k' ; apply Zlt_0_ind with (2 := Hk'). +clear k' Hk'. +intros k' IHk' Hk' k H. +unfold Zdigit. +apply (f_equal (fun x => Z.rem x beta)). +pattern k at 1 ; replace k with (k - k' + k')%Z by ring. +rewrite Zpower_plus with (2 := Hk'). +apply Zquot_mult_cancel_r. +apply Zgt_not_eq. +now apply Zpower_gt_0. +now apply Zle_minus_le_0. +destruct (Zle_or_lt 0 k) as [H0|H0]. +rewrite (Zdigit_lt n) by omega. +unfold Zdigit. +replace k' with (k' - k + k)%Z by ring. +rewrite Zpower_plus with (2 := H0). +rewrite Zmult_assoc, Z_quot_mult. +replace (k' - k)%Z with (k' - k - 1 + 1)%Z by ring. +rewrite Zpower_exp by omega. +rewrite Zmult_assoc. +change (Zpower beta 1) with (beta * 1)%Z. +rewrite Zmult_1_r. +apply Z_rem_mult. +apply Zgt_not_eq. +now apply Zpower_gt_0. +apply Zle_minus_le_0. +now apply Zlt_le_weak. +rewrite Zdigit_lt with (1 := H0). +apply sym_eq. +apply Zdigit_lt. +omega. +Qed. + +Theorem Zdigit_div_pow : + forall n k k', (0 <= k)%Z -> (0 <= k')%Z -> + Zdigit (Z.quot n (Zpower beta k')) k = Zdigit n (k + k'). +Proof. +intros n k k' Hk Hk'. +unfold Zdigit. +rewrite Zquot_Zquot. +rewrite Zplus_comm. +now rewrite Zpower_plus. +Qed. + +Theorem Zdigit_mod_pow : + forall n k k', (k < k')%Z -> + Zdigit (Z.rem n (Zpower beta k')) k = Zdigit n k. +Proof. +intros n k k' Hk. +destruct (Zle_or_lt 0 k) as [H|H]. +unfold Zdigit. +rewrite <- 2!ZOdiv_mod_mult. +apply (f_equal (fun x => Z.quot x (beta ^ k))). +replace k' with (k + 1 + (k' - (k + 1)))%Z by ring. +rewrite Zpower_exp by omega. +rewrite Zmult_comm. +rewrite Zpower_plus by easy. +change (Zpower beta 1) with (beta * 1)%Z. +rewrite Zmult_1_r. +apply ZOmod_mod_mult. +now rewrite 2!Zdigit_lt. +Qed. + +Theorem Zdigit_mod_pow_out : + forall n k k', (0 <= k' <= k)%Z -> + Zdigit (Z.rem n (Zpower beta k')) k = Z0. +Proof. +intros n k k' Hk. +unfold Zdigit. +rewrite ZOdiv_small_abs. +apply Zrem_0_l. +apply Z.lt_le_trans with (Zpower beta k'). +rewrite <- (Z.abs_eq (beta ^ k')) at 2 by apply Zpower_ge_0. +apply Zrem_lt. +apply Zgt_not_eq. +now apply Zpower_gt_0. +now apply Zpower_le. +Qed. + +Fixpoint Zsum_digit f k := + match k with + | O => Z0 + | S k => (Zsum_digit f k + f (Z_of_nat k) * Zpower beta (Z_of_nat k))%Z + end. + +Theorem Zsum_digit_digit : + forall n k, + Zsum_digit (Zdigit n) k = Z.rem n (Zpower beta (Z_of_nat k)). +Proof. +intros n. +induction k. +apply sym_eq. +apply Z.rem_1_r. +simpl Zsum_digit. +rewrite IHk. +unfold Zdigit. +rewrite <- ZOdiv_mod_mult. +rewrite <- (ZOmod_mod_mult n beta). +rewrite Zmult_comm. +replace (beta ^ Z_of_nat k * beta)%Z with (Zpower beta (Z_of_nat (S k))). +rewrite Zplus_comm, Zmult_comm. +apply sym_eq. +apply Z.quot_rem'. +rewrite inj_S. +rewrite <- (Zmult_1_r beta) at 3. +apply Zpower_plus. +apply Zle_0_nat. +easy. +Qed. + +Theorem Zdigit_ext : + forall n1 n2, + (forall k, (0 <= k)%Z -> Zdigit n1 k = Zdigit n2 k) -> + n1 = n2. +Proof. +intros n1 n2 H. +rewrite <- (ZOmod_small_abs n1 (Zpower beta (Z.max (Z.abs n1) (Z.abs n2)))). +rewrite <- (ZOmod_small_abs n2 (Zpower beta (Z.max (Z.abs n1) (Z.abs n2)))) at 2. +replace (Z.max (Z.abs n1) (Z.abs n2)) with (Z_of_nat (Z.abs_nat (Z.max (Z.abs n1) (Z.abs n2)))). +rewrite <- 2!Zsum_digit_digit. +induction (Z.abs_nat (Z.max (Z.abs n1) (Z.abs n2))). +easy. +simpl. +rewrite H, IHn. +apply refl_equal. +apply Zle_0_nat. +rewrite inj_Zabs_nat. +apply Z.abs_eq. +apply Z.le_trans with (Z.abs n1). +apply Zabs_pos. +apply Z.le_max_l. +apply Z.lt_le_trans with (Zpower beta (Z.abs n2)). +apply Zpower_gt_id. +apply Zpower_le. +apply Z.le_max_r. +apply Z.lt_le_trans with (Zpower beta (Z.abs n1)). +apply Zpower_gt_id. +apply Zpower_le. +apply Z.le_max_l. +Qed. + +Theorem ZOmod_plus_pow_digit : + forall u v n, (0 <= u * v)%Z -> + (forall k, (0 <= k < n)%Z -> Zdigit u k = Z0 \/ Zdigit v k = Z0) -> + Z.rem (u + v) (Zpower beta n) = (Z.rem u (Zpower beta n) + Z.rem v (Zpower beta n))%Z. +Proof. +intros u v n Huv Hd. +destruct (Zle_or_lt 0 n) as [Hn|Hn]. +rewrite Zplus_rem with (1 := Huv). +apply ZOmod_small_abs. +generalize (Z.le_refl n). +pattern n at -2 ; rewrite <- Z.abs_eq with (1 := Hn). +rewrite <- (inj_Zabs_nat n). +induction (Z.abs_nat n) as [|p IHp]. +now rewrite 2!Z.rem_1_r. +rewrite <- 2!Zsum_digit_digit. +simpl Zsum_digit. +rewrite inj_S. +intros Hn'. +replace (Zsum_digit (Zdigit u) p + Zdigit u (Z_of_nat p) * beta ^ Z_of_nat p + + (Zsum_digit (Zdigit v) p + Zdigit v (Z_of_nat p) * beta ^ Z_of_nat p))%Z with + (Zsum_digit (Zdigit u) p + Zsum_digit (Zdigit v) p + + (Zdigit u (Z_of_nat p) + Zdigit v (Z_of_nat p)) * beta ^ Z_of_nat p)%Z by ring. +apply (Z.le_lt_trans _ _ _ (Z.abs_triangle _ _)). +replace (beta ^ Z.succ (Z_of_nat p))%Z with (beta ^ Z_of_nat p + (beta - 1) * beta ^ Z_of_nat p)%Z. +apply Zplus_lt_le_compat. +rewrite 2!Zsum_digit_digit. +apply IHp. +now apply Zle_succ_le. +rewrite Zabs_Zmult. +rewrite (Z.abs_eq (beta ^ Z_of_nat p)) by apply Zpower_ge_0. +apply Zmult_le_compat_r. 2: apply Zpower_ge_0. +apply Zlt_succ_le. +assert (forall u v, Z.abs (Zdigit u v) < Z.succ (beta - 1))%Z. +clear ; intros n k. +assert (0 < beta)%Z. +apply Z.lt_le_trans with 2%Z. +apply refl_equal. +apply Zle_bool_imp_le. +apply beta. +replace (Z.succ (beta - 1)) with (Z.abs beta). +apply Zrem_lt. +now apply Zgt_not_eq. +rewrite Z.abs_eq. +apply Zsucc_pred. +now apply Zlt_le_weak. +assert (0 <= Z_of_nat p < n)%Z. +split. +apply Zle_0_nat. +apply Z.gt_lt. +now apply Zle_succ_gt. +destruct (Hd (Z_of_nat p) H0) as [K|K] ; rewrite K. +apply H. +rewrite Zplus_0_r. +apply H. +unfold Z.succ. +ring_simplify. +rewrite Zpower_plus. +change (beta ^1)%Z with (beta * 1)%Z. +now rewrite Zmult_1_r. +apply Zle_0_nat. +easy. +destruct n as [|n|n] ; try easy. +now rewrite 3!Zrem_0_r. +Qed. + +Theorem ZOdiv_plus_pow_digit : + forall u v n, (0 <= u * v)%Z -> + (forall k, (0 <= k < n)%Z -> Zdigit u k = Z0 \/ Zdigit v k = Z0) -> + Z.quot (u + v) (Zpower beta n) = (Z.quot u (Zpower beta n) + Z.quot v (Zpower beta n))%Z. +Proof. +intros u v n Huv Hd. +rewrite <- (Zplus_0_r (Z.quot u (Zpower beta n) + Z.quot v (Zpower beta n))). +rewrite ZOdiv_plus with (1 := Huv). +rewrite <- ZOmod_plus_pow_digit by assumption. +apply f_equal. +destruct (Zle_or_lt 0 n) as [Hn|Hn]. +apply ZOdiv_small_abs. +rewrite <- Z.abs_eq. +apply Zrem_lt. +apply Zgt_not_eq. +now apply Zpower_gt_0. +apply Zpower_ge_0. +clear -Hn. +destruct n as [|n|n] ; try easy. +apply Zquot_0_r. +Qed. + +Theorem Zdigit_plus : + forall u v, (0 <= u * v)%Z -> + (forall k, (0 <= k)%Z -> Zdigit u k = Z0 \/ Zdigit v k = Z0) -> + forall k, + Zdigit (u + v) k = (Zdigit u k + Zdigit v k)%Z. +Proof. +intros u v Huv Hd k. +destruct (Zle_or_lt 0 k) as [Hk|Hk]. +unfold Zdigit. +rewrite ZOdiv_plus_pow_digit with (1 := Huv). +rewrite <- (Zmult_1_r beta) at 3 5 7. +change (beta * 1)%Z with (beta ^1)%Z. +apply ZOmod_plus_pow_digit. +apply Zsame_sign_trans_weak with v. +intros Zv ; rewrite Zv. +apply Zquot_0_l. +rewrite Zmult_comm. +apply Zsame_sign_trans_weak with u. +intros Zu ; rewrite Zu. +apply Zquot_0_l. +now rewrite Zmult_comm. +apply Zsame_sign_odiv. +apply Zpower_ge_0. +apply Zsame_sign_odiv. +apply Zpower_ge_0. +intros k' (Hk1,Hk2). +rewrite 2!Zdigit_div_pow by assumption. +apply Hd. +now apply Zplus_le_0_compat. +intros k' (Hk1,Hk2). +now apply Hd. +now rewrite 3!Zdigit_lt. +Qed. + +(** Left and right shifts *) + +Definition Zscale n k := + if Zle_bool 0 k then (n * Zpower beta k)%Z else Z.quot n (Zpower beta (-k)). + +Theorem Zdigit_scale : + forall n k k', (0 <= k')%Z -> + Zdigit (Zscale n k) k' = Zdigit n (k' - k). +Proof. +intros n k k' Hk'. +unfold Zscale. +case Zle_bool_spec ; intros Hk. +now apply Zdigit_mul_pow. +apply Zdigit_div_pow with (1 := Hk'). +omega. +Qed. + +Theorem Zscale_0 : + forall k, + Zscale 0 k = Z0. +Proof. +intros k. +unfold Zscale. +case Zle_bool. +apply Zmult_0_l. +apply Zquot_0_l. +Qed. + +Theorem Zsame_sign_scale : + forall n k, + (0 <= n * Zscale n k)%Z. +Proof. +intros n k. +unfold Zscale. +case Zle_bool_spec ; intros Hk. +rewrite Zmult_assoc. +apply Zmult_le_0_compat. +apply Zsame_sign_imp ; apply Zlt_le_weak. +apply Zpower_ge_0. +apply Zsame_sign_odiv. +apply Zpower_ge_0. +Qed. + +Theorem Zscale_mul_pow : + forall n k k', (0 <= k)%Z -> + Zscale (n * Zpower beta k) k' = Zscale n (k + k'). +Proof. +intros n k k' Hk. +unfold Zscale. +case Zle_bool_spec ; intros Hk'. +rewrite Zle_bool_true. +rewrite <- Zmult_assoc. +apply f_equal. +now rewrite Zpower_plus. +now apply Zplus_le_0_compat. +case Zle_bool_spec ; intros Hk''. +pattern k at 1 ; replace k with (k + k' + -k')%Z by ring. +assert (0 <= -k')%Z by omega. +rewrite Zpower_plus by easy. +rewrite Zmult_assoc, Z_quot_mult. +apply refl_equal. +apply Zgt_not_eq. +now apply Zpower_gt_0. +replace (-k')%Z with (-(k+k') + k)%Z by ring. +rewrite Zpower_plus with (2 := Hk). +apply Zquot_mult_cancel_r. +apply Zgt_not_eq. +now apply Zpower_gt_0. +omega. +Qed. + +Theorem Zscale_scale : + forall n k k', (0 <= k)%Z -> + Zscale (Zscale n k) k' = Zscale n (k + k'). +Proof. +intros n k k' Hk. +unfold Zscale at 2. +rewrite Zle_bool_true with (1 := Hk). +now apply Zscale_mul_pow. +Qed. + +(** Slice of an integer *) + +Definition Zslice n k1 k2 := + if Zle_bool 0 k2 then Z.rem (Zscale n (-k1)) (Zpower beta k2) else Z0. + +Theorem Zdigit_slice : + forall n k1 k2 k, (0 <= k < k2)%Z -> + Zdigit (Zslice n k1 k2) k = Zdigit n (k1 + k). +Proof. +intros n k1 k2 k Hk. +unfold Zslice. +rewrite Zle_bool_true. +rewrite Zdigit_mod_pow by apply Hk. +rewrite Zdigit_scale by apply Hk. +unfold Zminus. +now rewrite Z.opp_involutive, Zplus_comm. +omega. +Qed. + +Theorem Zdigit_slice_out : + forall n k1 k2 k, (k2 <= k)%Z -> + Zdigit (Zslice n k1 k2) k = Z0. +Proof. +intros n k1 k2 k Hk. +unfold Zslice. +case Zle_bool_spec ; intros Hk2. +apply Zdigit_mod_pow_out. +now split. +apply Zdigit_0. +Qed. + +Theorem Zslice_0 : + forall k k', + Zslice 0 k k' = Z0. +Proof. +intros k k'. +unfold Zslice. +case Zle_bool. +rewrite Zscale_0. +apply Zrem_0_l. +apply refl_equal. +Qed. + +Theorem Zsame_sign_slice : + forall n k k', + (0 <= n * Zslice n k k')%Z. +Proof. +intros n k k'. +unfold Zslice. +case Zle_bool. +apply Zsame_sign_trans_weak with (Zscale n (-k)). +intros H ; rewrite H. +apply Zrem_0_l. +apply Zsame_sign_scale. +rewrite Zmult_comm. +apply Zrem_sgn2. +now rewrite Zmult_0_r. +Qed. + +Theorem Zslice_slice : + forall n k1 k2 k1' k2', (0 <= k1' <= k2)%Z -> + Zslice (Zslice n k1 k2) k1' k2' = Zslice n (k1 + k1') (Z.min (k2 - k1') k2'). +Proof. +intros n k1 k2 k1' k2' Hk1'. +destruct (Zle_or_lt 0 k2') as [Hk2'|Hk2']. +apply Zdigit_ext. +intros k Hk. +destruct (Zle_or_lt (Z.min (k2 - k1') k2') k) as [Hk'|Hk']. +rewrite (Zdigit_slice_out n (k1 + k1')) with (1 := Hk'). +destruct (Zle_or_lt k2' k) as [Hk''|Hk'']. +now apply Zdigit_slice_out. +rewrite Zdigit_slice by now split. +apply Zdigit_slice_out. +zify ; omega. +rewrite Zdigit_slice by (zify ; omega). +rewrite (Zdigit_slice n (k1 + k1')) by now split. +rewrite Zdigit_slice. +now rewrite Zplus_assoc. +zify ; omega. +unfold Zslice. +rewrite Z.min_r. +now rewrite Zle_bool_false. +omega. +Qed. + +Theorem Zslice_mul_pow : + forall n k k1 k2, (0 <= k)%Z -> + Zslice (n * Zpower beta k) k1 k2 = Zslice n (k1 - k) k2. +Proof. +intros n k k1 k2 Hk. +unfold Zslice. +case Zle_bool_spec ; intros Hk2. +2: apply refl_equal. +rewrite Zscale_mul_pow with (1 := Hk). +now replace (- (k1 - k))%Z with (k + -k1)%Z by ring. +Qed. + +Theorem Zslice_div_pow : + forall n k k1 k2, (0 <= k)%Z -> (0 <= k1)%Z -> + Zslice (Z.quot n (Zpower beta k)) k1 k2 = Zslice n (k1 + k) k2. +Proof. +intros n k k1 k2 Hk Hk1. +unfold Zslice. +case Zle_bool_spec ; intros Hk2. +2: apply refl_equal. +apply (f_equal (fun x => Z.rem x (beta ^ k2))). +unfold Zscale. +case Zle_bool_spec ; intros Hk1'. +replace k1 with Z0 by omega. +case Zle_bool_spec ; intros Hk'. +replace k with Z0 by omega. +simpl. +now rewrite Z.quot_1_r. +rewrite Z.opp_involutive. +apply Zmult_1_r. +rewrite Zle_bool_false by omega. +rewrite 2!Z.opp_involutive, Zplus_comm. +rewrite Zpower_plus by assumption. +apply Zquot_Zquot. +Qed. + +Theorem Zslice_scale : + forall n k k1 k2, (0 <= k1)%Z -> + Zslice (Zscale n k) k1 k2 = Zslice n (k1 - k) k2. +Proof. +intros n k k1 k2 Hk1. +unfold Zscale. +case Zle_bool_spec; intros Hk. +now apply Zslice_mul_pow. +apply Zslice_div_pow with (2 := Hk1). +omega. +Qed. + +Theorem Zslice_div_pow_scale : + forall n k k1 k2, (0 <= k)%Z -> + Zslice (Z.quot n (Zpower beta k)) k1 k2 = Zscale (Zslice n k (k1 + k2)) (-k1). +Proof. +intros n k k1 k2 Hk. +apply Zdigit_ext. +intros k' Hk'. +rewrite Zdigit_scale with (1 := Hk'). +unfold Zminus. +rewrite (Zplus_comm k'), Z.opp_involutive. +destruct (Zle_or_lt k2 k') as [Hk2|Hk2]. +rewrite Zdigit_slice_out with (1 := Hk2). +apply sym_eq. +apply Zdigit_slice_out. +now apply Zplus_le_compat_l. +rewrite Zdigit_slice by now split. +destruct (Zle_or_lt 0 (k1 + k')) as [Hk1'|Hk1']. +rewrite Zdigit_slice by omega. +rewrite Zdigit_div_pow by assumption. +apply f_equal. +ring. +now rewrite 2!Zdigit_lt. +Qed. + +Theorem Zplus_slice : + forall n k l1 l2, (0 <= l1)%Z -> (0 <= l2)%Z -> + (Zslice n k l1 + Zscale (Zslice n (k + l1) l2) l1)%Z = Zslice n k (l1 + l2). +Proof. +intros n k1 l1 l2 Hl1 Hl2. +clear Hl1. +apply Zdigit_ext. +intros k Hk. +rewrite Zdigit_plus. +rewrite Zdigit_scale with (1 := Hk). +destruct (Zle_or_lt (l1 + l2) k) as [Hk2|Hk2]. +rewrite Zdigit_slice_out with (1 := Hk2). +now rewrite 2!Zdigit_slice_out by omega. +rewrite Zdigit_slice with (1 := conj Hk Hk2). +destruct (Zle_or_lt l1 k) as [Hk1|Hk1]. +rewrite Zdigit_slice_out with (1 := Hk1). +rewrite Zdigit_slice by omega. +simpl ; apply f_equal. +ring. +rewrite Zdigit_slice with (1 := conj Hk Hk1). +rewrite (Zdigit_lt _ (k - l1)) by omega. +apply Zplus_0_r. +rewrite Zmult_comm. +apply Zsame_sign_trans_weak with n. +intros H ; rewrite H. +apply Zslice_0. +rewrite Zmult_comm. +apply Zsame_sign_trans_weak with (Zslice n (k1 + l1) l2). +intros H ; rewrite H. +apply Zscale_0. +apply Zsame_sign_slice. +apply Zsame_sign_scale. +apply Zsame_sign_slice. +clear k Hk ; intros k Hk. +rewrite Zdigit_scale with (1 := Hk). +destruct (Zle_or_lt l1 k) as [Hk1|Hk1]. +left. +now apply Zdigit_slice_out. +right. +apply Zdigit_lt. +omega. +Qed. + +Section digits_aux. + +Variable p : Z. + +Fixpoint Zdigits_aux (nb pow : Z) (n : nat) { struct n } : Z := + match n with + | O => nb + | S n => if Zlt_bool p pow then nb else Zdigits_aux (nb + 1) (Zmult beta pow) n + end. + +End digits_aux. + +(** Number of digits of an integer *) + +Definition Zdigits n := + match n with + | Z0 => Z0 + | Zneg p => Zdigits_aux (Zpos p) 1 beta (digits2_Pnat p) + | Zpos p => Zdigits_aux n 1 beta (digits2_Pnat p) + end. + +Theorem Zdigits_correct : + forall n, + (Zpower beta (Zdigits n - 1) <= Z.abs n < Zpower beta (Zdigits n))%Z. +Proof. +cut (forall p, Zpower beta (Zdigits (Zpos p) - 1) <= Zpos p < Zpower beta (Zdigits (Zpos p)))%Z. +intros H [|n|n] ; try exact (H n). +now split. +intros n. +simpl. +(* *) +assert (U: (Zpos n < Zpower beta (Z_of_nat (S (digits2_Pnat n))))%Z). +apply Z.lt_le_trans with (1 := proj2 (digits2_Pnat_correct n)). +rewrite Zpower_Zpower_nat. +rewrite Zabs_nat_Z_of_nat. +induction (S (digits2_Pnat n)). +easy. +rewrite 2!(Zpower_nat_S). +apply Zmult_le_compat with (2 := IHn0). +apply Zle_bool_imp_le. +apply beta. +easy. +rewrite <- (Zabs_nat_Z_of_nat n0). +rewrite <- Zpower_Zpower_nat. +apply (Zpower_ge_0 (Build_radix 2 (refl_equal true))). +apply Zle_0_nat. +apply Zle_0_nat. +(* *) +revert U. +rewrite inj_S. +unfold Z.succ. +generalize (digits2_Pnat n). +intros u U. +pattern (radix_val beta) at 2 4 ; replace (radix_val beta) with (Zpower beta 1) by apply Zmult_1_r. +assert (V: (Zpower beta (1 - 1) <= Zpos n)%Z). +now apply (Zlt_le_succ 0). +generalize (conj V U). +clear. +generalize (Z.le_refl 1). +generalize 1%Z at 2 3 5 6 7 9 10. +(* *) +induction u. +easy. +rewrite inj_S; unfold Z.succ. +simpl Zdigits_aux. +intros v Hv U. +case Zlt_bool_spec ; intros K. +now split. +pattern (radix_val beta) at 2 5 ; replace (radix_val beta) with (Zpower beta 1) by apply Zmult_1_r. +rewrite <- Zpower_plus. +rewrite Zplus_comm. +apply IHu. +clear -Hv ; omega. +split. +now ring_simplify (1 + v - 1)%Z. +now rewrite Zplus_assoc. +easy. +apply Zle_succ_le with (1 := Hv). +Qed. + +Theorem Zdigits_unique : + forall n d, + (Zpower beta (d - 1) <= Z.abs n < Zpower beta d)%Z -> + Zdigits n = d. +Proof. +intros n d Hd. +assert (Hd' := Zdigits_correct n). +apply Zle_antisym. +apply (Zpower_lt_Zpower beta). +now apply Z.le_lt_trans with (Z.abs n). +apply (Zpower_lt_Zpower beta). +now apply Z.le_lt_trans with (Z.abs n). +Qed. + +Theorem Zdigits_abs : + forall n, Zdigits (Z.abs n) = Zdigits n. +Proof. +now intros [|n|n]. +Qed. + +Theorem Zdigits_gt_0 : + forall n, n <> Z0 -> (0 < Zdigits n)%Z. +Proof. +intros n Zn. +rewrite <- (Zdigits_abs n). +assert (Hn: (0 < Z.abs n)%Z). +destruct n ; [|easy|easy]. +now elim Zn. +destruct (Z.abs n) as [|p|p] ; try easy ; clear. +simpl. +generalize 1%Z (radix_val beta) (refl_equal Lt : (0 < 1)%Z). +induction (digits2_Pnat p). +easy. +simpl. +intros. +case Zlt_bool. +exact H. +apply IHn. +now apply Zlt_lt_succ. +Qed. + +Theorem Zdigits_ge_0 : + forall n, (0 <= Zdigits n)%Z. +Proof. +intros n. +destruct (Z.eq_dec n 0) as [H|H]. +now rewrite H. +apply Zlt_le_weak. +now apply Zdigits_gt_0. +Qed. + +Theorem Zdigit_out : + forall n k, (Zdigits n <= k)%Z -> + Zdigit n k = Z0. +Proof. +intros n k Hk. +apply Zdigit_ge_Zpower with (2 := Hk). +apply Zdigits_correct. +Qed. + +Theorem Zdigit_digits : + forall n, n <> Z0 -> + Zdigit n (Zdigits n - 1) <> Z0. +Proof. +intros n Zn. +apply Zdigit_not_0. +apply Zlt_0_le_0_pred. +now apply Zdigits_gt_0. +ring_simplify (Zdigits n - 1 + 1)%Z. +apply Zdigits_correct. +Qed. + +Theorem Zdigits_slice : + forall n k l, (0 <= l)%Z -> + (Zdigits (Zslice n k l) <= l)%Z. +Proof. +intros n k l Hl. +unfold Zslice. +rewrite Zle_bool_true with (1 := Hl). +destruct (Zdigits_correct (Z.rem (Zscale n (- k)) (Zpower beta l))) as (H1,H2). +apply Zpower_lt_Zpower with beta. +apply Z.le_lt_trans with (1 := H1). +rewrite <- (Z.abs_eq (beta ^ l)) at 2 by apply Zpower_ge_0. +apply Zrem_lt. +apply Zgt_not_eq. +now apply Zpower_gt_0. +Qed. + +Theorem Zdigits_mult_Zpower : + forall m e, + m <> Z0 -> (0 <= e)%Z -> + Zdigits (m * Zpower beta e) = (Zdigits m + e)%Z. +Proof. +intros m e Hm He. +assert (H := Zdigits_correct m). +apply Zdigits_unique. +rewrite Z.abs_mul, Z.abs_pow, (Z.abs_eq beta). +2: now apply Zlt_le_weak, radix_gt_0. +split. +replace (Zdigits m + e - 1)%Z with (Zdigits m - 1 + e)%Z by ring. +rewrite Zpower_plus with (2 := He). +apply Zmult_le_compat_r. +apply H. +apply Zpower_ge_0. +now apply Zlt_0_le_0_pred, Zdigits_gt_0. +rewrite Zpower_plus with (2 := He). +apply Zmult_lt_compat_r. +now apply Zpower_gt_0. +apply H. +now apply Zlt_le_weak, Zdigits_gt_0. +Qed. + +Theorem Zdigits_Zpower : + forall e, + (0 <= e)%Z -> + Zdigits (Zpower beta e) = (e + 1)%Z. +Proof. +intros e He. +rewrite <- (Zmult_1_l (Zpower beta e)). +rewrite Zdigits_mult_Zpower ; try easy. +apply Zplus_comm. +Qed. + +Theorem Zdigits_le : + forall x y, + (0 <= x)%Z -> (x <= y)%Z -> + (Zdigits x <= Zdigits y)%Z. +Proof. +intros x y Zx Hxy. +assert (Hx := Zdigits_correct x). +assert (Hy := Zdigits_correct y). +apply (Zpower_lt_Zpower beta). +zify ; omega. +Qed. + +Theorem lt_Zdigits : + forall x y, + (0 <= y)%Z -> + (Zdigits x < Zdigits y)%Z -> + (x < y)%Z. +Proof. +intros x y Hy. +cut (y <= x -> Zdigits y <= Zdigits x)%Z. omega. +now apply Zdigits_le. +Qed. + +Theorem Zpower_le_Zdigits : + forall e x, + (e < Zdigits x)%Z -> + (Zpower beta e <= Z.abs x)%Z. +Proof. +intros e x Hex. +destruct (Zdigits_correct x) as [H1 H2]. +apply Z.le_trans with (2 := H1). +apply Zpower_le. +clear -Hex ; omega. +Qed. + +Theorem Zdigits_le_Zpower : + forall e x, + (Z.abs x < Zpower beta e)%Z -> + (Zdigits x <= e)%Z. +Proof. +intros e x. +generalize (Zpower_le_Zdigits e x). +omega. +Qed. + +Theorem Zpower_gt_Zdigits : + forall e x, + (Zdigits x <= e)%Z -> + (Z.abs x < Zpower beta e)%Z. +Proof. +intros e x Hex. +destruct (Zdigits_correct x) as [H1 H2]. +apply Z.lt_le_trans with (1 := H2). +now apply Zpower_le. +Qed. + +Theorem Zdigits_gt_Zpower : + forall e x, + (Zpower beta e <= Z.abs x)%Z -> + (e < Zdigits x)%Z. +Proof. +intros e x Hex. +generalize (Zpower_gt_Zdigits e x). +omega. +Qed. + +(** Number of digits of a product. + +This strong version is needed for proofs of division and square root +algorithms, since they involve operation remainders. +*) + +Theorem Zdigits_mult_strong : + forall x y, + (0 <= x)%Z -> (0 <= y)%Z -> + (Zdigits (x + y + x * y) <= Zdigits x + Zdigits y)%Z. +Proof. +intros x y Hx Hy. +apply Zdigits_le_Zpower. +rewrite Z.abs_eq. +apply Z.lt_le_trans with ((x + 1) * (y + 1))%Z. +ring_simplify. +apply Zle_lt_succ, Z.le_refl. +rewrite Zpower_plus by apply Zdigits_ge_0. +apply Zmult_le_compat. +apply Zlt_le_succ. +rewrite <- (Z.abs_eq x) at 1 by easy. +apply Zdigits_correct. +apply Zlt_le_succ. +rewrite <- (Z.abs_eq y) at 1 by easy. +apply Zdigits_correct. +clear -Hx ; omega. +clear -Hy ; omega. +change Z0 with (0 + 0 + 0)%Z. +apply Zplus_le_compat. +now apply Zplus_le_compat. +now apply Zmult_le_0_compat. +Qed. + +Theorem Zdigits_mult : + forall x y, + (Zdigits (x * y) <= Zdigits x + Zdigits y)%Z. +Proof. +intros x y. +rewrite <- Zdigits_abs. +rewrite <- (Zdigits_abs x). +rewrite <- (Zdigits_abs y). +apply Z.le_trans with (Zdigits (Z.abs x + Z.abs y + Z.abs x * Z.abs y)). +apply Zdigits_le. +apply Zabs_pos. +rewrite Zabs_Zmult. +generalize (Zabs_pos x) (Zabs_pos y). +omega. +apply Zdigits_mult_strong ; apply Zabs_pos. +Qed. + +Theorem Zdigits_mult_ge : + forall x y, + (x <> 0)%Z -> (y <> 0)%Z -> + (Zdigits x + Zdigits y - 1 <= Zdigits (x * y))%Z. +Proof. +intros x y Zx Zy. +cut ((Zdigits x - 1) + (Zdigits y - 1) < Zdigits (x * y))%Z. omega. +apply Zdigits_gt_Zpower. +rewrite Zabs_Zmult. +rewrite Zpower_exp. +apply Zmult_le_compat. +apply Zpower_le_Zdigits. +apply Zlt_pred. +apply Zpower_le_Zdigits. +apply Zlt_pred. +apply Zpower_ge_0. +apply Zpower_ge_0. +generalize (Zdigits_gt_0 x). omega. +generalize (Zdigits_gt_0 y). omega. +Qed. + +Theorem Zdigits_div_Zpower : + forall m e, + (0 <= m)%Z -> + (0 <= e <= Zdigits m)%Z -> + Zdigits (m / Zpower beta e) = (Zdigits m - e)%Z. +Proof. +intros m e Hm He. +assert (H := Zdigits_correct m). +apply Zdigits_unique. +destruct (Zle_lt_or_eq _ _ (proj2 He)) as [He'|He']. + rewrite Z.abs_eq in H by easy. + destruct H as [H1 H2]. + rewrite Z.abs_eq. + split. + replace (Zdigits m - e - 1)%Z with (Zdigits m - 1 - e)%Z by ring. + rewrite Z.pow_sub_r. + 2: apply Zgt_not_eq, radix_gt_0. + 2: clear -He He' ; omega. + apply Z_div_le with (2 := H1). + now apply Z.lt_gt, Zpower_gt_0. + apply Zmult_lt_reg_r with (Zpower beta e). + now apply Zpower_gt_0. + apply Z.le_lt_trans with m. + rewrite Zmult_comm. + apply Z_mult_div_ge. + now apply Z.lt_gt, Zpower_gt_0. + rewrite <- Zpower_plus. + now replace (Zdigits m - e + e)%Z with (Zdigits m) by ring. + now apply Zle_minus_le_0. + apply He. + apply Z_div_pos with (2 := Hm). + now apply Z.lt_gt, Zpower_gt_0. +rewrite He'. +rewrite (Zeq_minus _ (Zdigits m)) by reflexivity. +simpl. +rewrite Zdiv_small. +easy. +split. +exact Hm. +now rewrite <- (Z.abs_eq m) at 1. +Qed. + +End Fcore_digits. + +(** Specialized version for computing the number of bits of an integer *) + +Section Zdigits2. + +Theorem Z_of_nat_S_digits2_Pnat : + forall m : positive, + Z_of_nat (S (digits2_Pnat m)) = Zdigits radix2 (Zpos m). +Proof. +intros m. +apply eq_sym, Zdigits_unique. +rewrite <- Zpower_nat_Z. +rewrite Nat2Z.inj_succ. +change (_ - 1)%Z with (Z.pred (Z.succ (Z.of_nat (digits2_Pnat m)))). +rewrite <- Zpred_succ. +rewrite <- Zpower_nat_Z. +apply digits2_Pnat_correct. +Qed. + +Fixpoint digits2_pos (n : positive) : positive := + match n with + | xH => xH + | xO p => Pos.succ (digits2_pos p) + | xI p => Pos.succ (digits2_pos p) + end. + +Theorem Zpos_digits2_pos : + forall m : positive, + Zpos (digits2_pos m) = Zdigits radix2 (Zpos m). +Proof. +intros m. +rewrite <- Z_of_nat_S_digits2_Pnat. +unfold Z.of_nat. +apply f_equal. +induction m ; simpl ; try easy ; + apply f_equal, IHm. +Qed. + +Definition Zdigits2 n := + match n with + | Z0 => n + | Zpos p => Zpos (digits2_pos p) + | Zneg p => Zpos (digits2_pos p) + end. + +Lemma Zdigits2_Zdigits : + forall n, Zdigits2 n = Zdigits radix2 n. +Proof. +intros [|p|p] ; try easy ; + apply Zpos_digits2_pos. +Qed. + +End Zdigits2. diff --git a/flocq/Core/FIX.v b/flocq/Core/FIX.v new file mode 100644 index 00000000..4e0a25e6 --- /dev/null +++ b/flocq/Core/FIX.v @@ -0,0 +1,94 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2009-2018 Sylvie Boldo +#
# +Copyright (C) 2009-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +(** * Fixed-point format *) +Require Import Raux Defs Round_pred Generic_fmt Ulp Round_NE. + +Section RND_FIX. + +Variable beta : radix. + +Notation bpow := (bpow beta). + +Variable emin : Z. + +Inductive FIX_format (x : R) : Prop := + FIX_spec (f : float beta) : + x = F2R f -> (Fexp f = emin)%Z -> FIX_format x. + +Definition FIX_exp (e : Z) := emin. + +(** Properties of the FIX format *) + +Global Instance FIX_exp_valid : Valid_exp FIX_exp. +Proof. +intros k. +unfold FIX_exp. +split ; intros H. +now apply Zlt_le_weak. +split. +apply Z.le_refl. +now intros _ _. +Qed. + +Theorem generic_format_FIX : + forall x, FIX_format x -> generic_format beta FIX_exp x. +Proof. +intros x [[xm xe] Hx1 Hx2]. +rewrite Hx1. +now apply generic_format_canonical. +Qed. + +Theorem FIX_format_generic : + forall x, generic_format beta FIX_exp x -> FIX_format x. +Proof. +intros x H. +rewrite H. +eexists ; repeat split. +Qed. + +Theorem FIX_format_satisfies_any : + satisfies_any FIX_format. +Proof. +refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FIX_exp)). +intros x. +split. +apply FIX_format_generic. +apply generic_format_FIX. +Qed. + +Global Instance FIX_exp_monotone : Monotone_exp FIX_exp. +Proof. +intros ex ey H. +apply Z.le_refl. +Qed. + +Theorem ulp_FIX : + forall x, ulp beta FIX_exp x = bpow emin. +Proof. +intros x; unfold ulp. +case Req_bool_spec; intros Zx. +case (negligible_exp_spec FIX_exp). +intros T; specialize (T (emin-1)%Z); contradict T. +unfold FIX_exp; omega. +intros n _; reflexivity. +reflexivity. +Qed. + +End RND_FIX. diff --git a/flocq/Core/FLT.v b/flocq/Core/FLT.v new file mode 100644 index 00000000..bd48d4b7 --- /dev/null +++ b/flocq/Core/FLT.v @@ -0,0 +1,406 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2009-2018 Sylvie Boldo +#
# +Copyright (C) 2009-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +(** * Floating-point format with gradual underflow *) +Require Import Raux Defs Round_pred Generic_fmt Float_prop. +Require Import FLX FIX Ulp Round_NE. +Require Import Psatz. + +Section RND_FLT. + +Variable beta : radix. + +Notation bpow e := (bpow beta e). + +Variable emin prec : Z. + +Context { prec_gt_0_ : Prec_gt_0 prec }. + +Inductive FLT_format (x : R) : Prop := + FLT_spec (f : float beta) : + x = F2R f -> (Z.abs (Fnum f) < Zpower beta prec)%Z -> + (emin <= Fexp f)%Z -> FLT_format x. + +Definition FLT_exp e := Z.max (e - prec) emin. + +(** Properties of the FLT format *) +Global Instance FLT_exp_valid : Valid_exp FLT_exp. +Proof. +intros k. +unfold FLT_exp. +generalize (prec_gt_0 prec). +repeat split ; + intros ; zify ; omega. +Qed. + +Theorem generic_format_FLT : + forall x, FLT_format x -> generic_format beta FLT_exp x. +Proof. +clear prec_gt_0_. +intros x [[mx ex] H1 H2 H3]. +simpl in H2, H3. +rewrite H1. +apply generic_format_F2R. +intros Zmx. +unfold cexp, FLT_exp. +rewrite mag_F2R with (1 := Zmx). +apply Z.max_lub with (2 := H3). +apply Zplus_le_reg_r with (prec - ex)%Z. +ring_simplify. +now apply mag_le_Zpower. +Qed. + +Theorem FLT_format_generic : + forall x, generic_format beta FLT_exp x -> FLT_format x. +Proof. +intros x. +unfold generic_format. +set (ex := cexp beta FLT_exp x). +set (mx := Ztrunc (scaled_mantissa beta FLT_exp x)). +intros Hx. +rewrite Hx. +eexists ; repeat split ; simpl. +apply lt_IZR. +rewrite IZR_Zpower. 2: now apply Zlt_le_weak. +apply Rmult_lt_reg_r with (bpow ex). +apply bpow_gt_0. +rewrite <- bpow_plus. +change (F2R (Float beta (Z.abs mx) ex) < bpow (prec + ex))%R. +rewrite F2R_Zabs. +rewrite <- Hx. +destruct (Req_dec x 0) as [Hx0|Hx0]. +rewrite Hx0, Rabs_R0. +apply bpow_gt_0. +unfold cexp in ex. +destruct (mag beta x) as (ex', He). +simpl in ex. +specialize (He Hx0). +apply Rlt_le_trans with (1 := proj2 He). +apply bpow_le. +cut (ex' - prec <= ex)%Z. omega. +unfold ex, FLT_exp. +apply Z.le_max_l. +apply Z.le_max_r. +Qed. + + +Theorem FLT_format_bpow : + forall e, (emin <= e)%Z -> generic_format beta FLT_exp (bpow e). +Proof. +intros e He. +apply generic_format_bpow; unfold FLT_exp. +apply Z.max_case; try assumption. +unfold Prec_gt_0 in prec_gt_0_; omega. +Qed. + + + + +Theorem FLT_format_satisfies_any : + satisfies_any FLT_format. +Proof. +refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLT_exp)). +intros x. +split. +apply FLT_format_generic. +apply generic_format_FLT. +Qed. + +Theorem cexp_FLT_FLX : + forall x, + (bpow (emin + prec - 1) <= Rabs x)%R -> + cexp beta FLT_exp x = cexp beta (FLX_exp prec) x. +Proof. +intros x Hx. +assert (Hx0: x <> 0%R). +intros H1; rewrite H1, Rabs_R0 in Hx. +contradict Hx; apply Rlt_not_le, bpow_gt_0. +unfold cexp. +apply Zmax_left. +destruct (mag beta x) as (ex, He). +unfold FLX_exp. simpl. +specialize (He Hx0). +cut (emin + prec - 1 < ex)%Z. omega. +apply (lt_bpow beta). +apply Rle_lt_trans with (1 := Hx). +apply He. +Qed. + +(** Links between FLT and FLX *) +Theorem generic_format_FLT_FLX : + forall x : R, + (bpow (emin + prec - 1) <= Rabs x)%R -> + generic_format beta (FLX_exp prec) x -> + generic_format beta FLT_exp x. +Proof. +intros x Hx H. +destruct (Req_dec x 0) as [Hx0|Hx0]. +rewrite Hx0. +apply generic_format_0. +unfold generic_format, scaled_mantissa. +now rewrite cexp_FLT_FLX. +Qed. + +Theorem generic_format_FLX_FLT : + forall x : R, + generic_format beta FLT_exp x -> generic_format beta (FLX_exp prec) x. +Proof. +clear prec_gt_0_. +intros x Hx. +unfold generic_format in Hx; rewrite Hx. +apply generic_format_F2R. +intros _. +rewrite <- Hx. +unfold cexp, FLX_exp, FLT_exp. +apply Z.le_max_l. +Qed. + +Theorem round_FLT_FLX : forall rnd x, + (bpow (emin + prec - 1) <= Rabs x)%R -> + round beta FLT_exp rnd x = round beta (FLX_exp prec) rnd x. +Proof. +intros rnd x Hx. +unfold round, scaled_mantissa. +rewrite cexp_FLT_FLX ; trivial. +Qed. + +(** Links between FLT and FIX (underflow) *) +Theorem cexp_FLT_FIX : + forall x, x <> 0%R -> + (Rabs x < bpow (emin + prec))%R -> + cexp beta FLT_exp x = cexp beta (FIX_exp emin) x. +Proof. +intros x Hx0 Hx. +unfold cexp. +apply Zmax_right. +unfold FIX_exp. +destruct (mag beta x) as (ex, Hex). +simpl. +cut (ex - 1 < emin + prec)%Z. omega. +apply (lt_bpow beta). +apply Rle_lt_trans with (2 := Hx). +now apply Hex. +Qed. + +Theorem generic_format_FIX_FLT : + forall x : R, + generic_format beta FLT_exp x -> + generic_format beta (FIX_exp emin) x. +Proof. +clear prec_gt_0_. +intros x Hx. +rewrite Hx. +apply generic_format_F2R. +intros _. +rewrite <- Hx. +apply Z.le_max_r. +Qed. + +Theorem generic_format_FLT_FIX : + forall x : R, + (Rabs x <= bpow (emin + prec))%R -> + generic_format beta (FIX_exp emin) x -> + generic_format beta FLT_exp x. +Proof with auto with typeclass_instances. +apply generic_inclusion_le... +intros e He. +unfold FIX_exp. +apply Z.max_lub. +omega. +apply Z.le_refl. +Qed. + +Lemma negligible_exp_FLT : + exists n, negligible_exp FLT_exp = Some n /\ (n <= emin)%Z. +Proof. +case (negligible_exp_spec FLT_exp). +{ intro H; exfalso; specialize (H emin); revert H. + apply Zle_not_lt, Z.le_max_r. } +intros n Hn; exists n; split; [now simpl|]. +destruct (Z.max_spec (n - prec) emin) as [(Hm, Hm')|(Hm, Hm')]. +{ now revert Hn; unfold FLT_exp; rewrite Hm'. } +revert Hn prec_gt_0_; unfold FLT_exp, Prec_gt_0; rewrite Hm'; lia. +Qed. + +Theorem generic_format_FLT_1 (Hemin : (emin <= 0)%Z) : + generic_format beta FLT_exp 1. +Proof. +unfold generic_format, scaled_mantissa, cexp, F2R; simpl. +rewrite Rmult_1_l, (mag_unique beta 1 1). +{ unfold FLT_exp. + destruct (Z.max_spec_le (1 - prec) emin) as [(H,Hm)|(H,Hm)]; rewrite Hm; + (rewrite <- IZR_Zpower; [|unfold Prec_gt_0 in prec_gt_0_; omega]); + (rewrite Ztrunc_IZR, IZR_Zpower, <-bpow_plus; + [|unfold Prec_gt_0 in prec_gt_0_; omega]); + now replace (_ + _)%Z with Z0 by ring. } +rewrite Rabs_R1; simpl; split; [now right|]. +rewrite IZR_Zpower_pos; simpl; rewrite Rmult_1_r; apply IZR_lt. +apply (Z.lt_le_trans _ 2); [omega|]; apply Zle_bool_imp_le, beta. +Qed. + +Theorem ulp_FLT_small: forall x, (Rabs x < bpow (emin+prec))%R -> + ulp beta FLT_exp x = bpow emin. +Proof with auto with typeclass_instances. +intros x Hx. +unfold ulp; case Req_bool_spec; intros Hx2. +(* x = 0 *) +case (negligible_exp_spec FLT_exp). +intros T; specialize (T (emin-1)%Z); contradict T. +apply Zle_not_lt; unfold FLT_exp. +apply Z.le_trans with (2:=Z.le_max_r _ _); omega. +assert (V:FLT_exp emin = emin). +unfold FLT_exp; apply Z.max_r. +unfold Prec_gt_0 in prec_gt_0_; omega. +intros n H2; rewrite <-V. +apply f_equal, fexp_negligible_exp_eq... +omega. +(* x <> 0 *) +apply f_equal; unfold cexp, FLT_exp. +apply Z.max_r. +assert (mag beta x-1 < emin+prec)%Z;[idtac|omega]. +destruct (mag beta x) as (e,He); simpl. +apply lt_bpow with beta. +apply Rle_lt_trans with (2:=Hx). +now apply He. +Qed. + +Theorem ulp_FLT_le : + forall x, (bpow (emin + prec - 1) <= Rabs x)%R -> + (ulp beta FLT_exp x <= Rabs x * bpow (1 - prec))%R. +Proof. +intros x Hx. +assert (Zx : (x <> 0)%R). + intros Z; contradict Hx; apply Rgt_not_le, Rlt_gt. + rewrite Z, Rabs_R0; apply bpow_gt_0. +rewrite ulp_neq_0 with (1 := Zx). +unfold cexp, FLT_exp. +destruct (mag beta x) as (e,He). +apply Rle_trans with (bpow (e-1)*bpow (1-prec))%R. +rewrite <- bpow_plus. +right; apply f_equal. +replace (e - 1 + (1 - prec))%Z with (e - prec)%Z by ring. +apply Z.max_l. +assert (emin+prec-1 < e)%Z; try omega. +apply lt_bpow with beta. +apply Rle_lt_trans with (1:=Hx). +now apply He. +apply Rmult_le_compat_r. +apply bpow_ge_0. +now apply He. +Qed. + +Theorem ulp_FLT_gt : + forall x, (Rabs x * bpow (-prec) < ulp beta FLT_exp x)%R. +Proof. +intros x; case (Req_dec x 0); intros Hx. +rewrite Hx, ulp_FLT_small, Rabs_R0, Rmult_0_l; try apply bpow_gt_0. +rewrite Rabs_R0; apply bpow_gt_0. +rewrite ulp_neq_0; try exact Hx. +unfold cexp, FLT_exp. +apply Rlt_le_trans with (bpow (mag beta x)*bpow (-prec))%R. +apply Rmult_lt_compat_r. +apply bpow_gt_0. +now apply bpow_mag_gt. +rewrite <- bpow_plus. +apply bpow_le. +apply Z.le_max_l. +Qed. + +Lemma ulp_FLT_exact_shift : + forall x e, + (x <> 0)%R -> + (emin + prec <= mag beta x)%Z -> + (emin + prec - mag beta x <= e)%Z -> + (ulp beta FLT_exp (x * bpow e) = ulp beta FLT_exp x * bpow e)%R. +Proof. +intros x e Nzx Hmx He. +unfold ulp; rewrite Req_bool_false; + [|now intro H; apply Nzx, (Rmult_eq_reg_r (bpow e)); + [rewrite Rmult_0_l|apply Rgt_not_eq, Rlt_gt, bpow_gt_0]]. +rewrite (Req_bool_false _ _ Nzx), <- bpow_plus; f_equal; unfold cexp, FLT_exp. +rewrite (mag_mult_bpow _ _ _ Nzx), !Z.max_l; omega. +Qed. + +Lemma succ_FLT_exact_shift_pos : + forall x e, + (0 < x)%R -> + (emin + prec <= mag beta x)%Z -> + (emin + prec - mag beta x <= e)%Z -> + (succ beta FLT_exp (x * bpow e) = succ beta FLT_exp x * bpow e)%R. +Proof. +intros x e Px Hmx He. +rewrite succ_eq_pos; [|now apply Rlt_le, Rmult_lt_0_compat, bpow_gt_0]. +rewrite (succ_eq_pos _ _ _ (Rlt_le _ _ Px)). +now rewrite Rmult_plus_distr_r; f_equal; apply ulp_FLT_exact_shift; [lra| |]. +Qed. + +Lemma succ_FLT_exact_shift : + forall x e, + (x <> 0)%R -> + (emin + prec + 1 <= mag beta x)%Z -> + (emin + prec - mag beta x + 1 <= e)%Z -> + (succ beta FLT_exp (x * bpow e) = succ beta FLT_exp x * bpow e)%R. +Proof. +intros x e Nzx Hmx He. +destruct (Rle_or_lt 0 x) as [Px|Nx]. +{ now apply succ_FLT_exact_shift_pos; [lra|lia|lia]. } +unfold succ. +rewrite Rle_bool_false; [|assert (H := bpow_gt_0 beta e); nra]. +rewrite Rle_bool_false; [|now simpl]. +rewrite Ropp_mult_distr_l_reverse, <-Ropp_mult_distr_l_reverse; f_equal. +unfold pred_pos. +rewrite mag_mult_bpow; [|lra]. +replace (_ - 1)%Z with (mag beta (- x) - 1 + e)%Z; [|ring]; rewrite bpow_plus. +unfold Req_bool; rewrite Rcompare_mult_r; [|now apply bpow_gt_0]. +fold (Req_bool (-x) (bpow (mag beta (-x) - 1))); case Req_bool. +{ rewrite mag_opp; unfold FLT_exp; do 2 (rewrite Z.max_l; [|lia]). + replace (_ - _)%Z with (mag beta x - 1 - prec + e)%Z; [|ring]. + rewrite bpow_plus; ring. } +rewrite ulp_FLT_exact_shift; [ring|lra| |]; rewrite mag_opp; lia. +Qed. + +(** FLT is a nice format: it has a monotone exponent... *) +Global Instance FLT_exp_monotone : Monotone_exp FLT_exp. +Proof. +intros ex ey. +unfold FLT_exp. +zify ; omega. +Qed. + +(** and it allows a rounding to nearest, ties to even. *) +Hypothesis NE_prop : Z.even beta = false \/ (1 < prec)%Z. + +Global Instance exists_NE_FLT : Exists_NE beta FLT_exp. +Proof. +destruct NE_prop as [H|H]. +now left. +right. +intros e. +unfold FLT_exp. +destruct (Zmax_spec (e - prec) emin) as [(H1,H2)|(H1,H2)] ; + rewrite H2 ; clear H2. +generalize (Zmax_spec (e + 1 - prec) emin). +generalize (Zmax_spec (e - prec + 1 - prec) emin). +omega. +generalize (Zmax_spec (e + 1 - prec) emin). +generalize (Zmax_spec (emin + 1 - prec) emin). +omega. +Qed. + +End RND_FLT. diff --git a/flocq/Core/FLX.v b/flocq/Core/FLX.v new file mode 100644 index 00000000..803d96ef --- /dev/null +++ b/flocq/Core/FLX.v @@ -0,0 +1,362 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2009-2018 Sylvie Boldo +#
# +Copyright (C) 2009-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +(** * Floating-point format without underflow *) +Require Import Raux Defs Round_pred Generic_fmt Float_prop. +Require Import FIX Ulp Round_NE. +Require Import Psatz. + +Section RND_FLX. + +Variable beta : radix. + +Notation bpow e := (bpow beta e). + +Variable prec : Z. + +Class Prec_gt_0 := + prec_gt_0 : (0 < prec)%Z. + +Context { prec_gt_0_ : Prec_gt_0 }. + +Inductive FLX_format (x : R) : Prop := + FLX_spec (f : float beta) : + x = F2R f -> (Z.abs (Fnum f) < Zpower beta prec)%Z -> FLX_format x. + +Definition FLX_exp (e : Z) := (e - prec)%Z. + +(** Properties of the FLX format *) + +Global Instance FLX_exp_valid : Valid_exp FLX_exp. +Proof. +intros k. +unfold FLX_exp. +generalize prec_gt_0. +repeat split ; intros ; omega. +Qed. + +Theorem FIX_format_FLX : + forall x e, + (bpow (e - 1) <= Rabs x <= bpow e)%R -> + FLX_format x -> + FIX_format beta (e - prec) x. +Proof. +clear prec_gt_0_. +intros x e Hx [[xm xe] H1 H2]. +rewrite H1, (F2R_prec_normalize beta xm xe e prec). +now eexists. +exact H2. +now rewrite <- H1. +Qed. + +Theorem FLX_format_generic : + forall x, generic_format beta FLX_exp x -> FLX_format x. +Proof. +intros x H. +rewrite H. +eexists ; repeat split. +simpl. +apply lt_IZR. +rewrite abs_IZR. +rewrite <- scaled_mantissa_generic with (1 := H). +rewrite <- scaled_mantissa_abs. +apply Rmult_lt_reg_r with (bpow (cexp beta FLX_exp (Rabs x))). +apply bpow_gt_0. +rewrite scaled_mantissa_mult_bpow. +rewrite IZR_Zpower, <- bpow_plus. +2: now apply Zlt_le_weak. +unfold cexp, FLX_exp. +ring_simplify (prec + (mag beta (Rabs x) - prec))%Z. +rewrite mag_abs. +destruct (Req_dec x 0) as [Hx|Hx]. +rewrite Hx, Rabs_R0. +apply bpow_gt_0. +destruct (mag beta x) as (ex, Ex). +now apply Ex. +Qed. + +Theorem generic_format_FLX : + forall x, FLX_format x -> generic_format beta FLX_exp x. +Proof. +clear prec_gt_0_. +intros x [[mx ex] H1 H2]. +simpl in H2. +rewrite H1. +apply generic_format_F2R. +intros Zmx. +unfold cexp, FLX_exp. +rewrite mag_F2R with (1 := Zmx). +apply Zplus_le_reg_r with (prec - ex)%Z. +ring_simplify. +now apply mag_le_Zpower. +Qed. + +Theorem FLX_format_satisfies_any : + satisfies_any FLX_format. +Proof. +refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLX_exp)). +intros x. +split. +apply FLX_format_generic. +apply generic_format_FLX. +Qed. + +Theorem FLX_format_FIX : + forall x e, + (bpow (e - 1) <= Rabs x <= bpow e)%R -> + FIX_format beta (e - prec) x -> + FLX_format x. +Proof with auto with typeclass_instances. +intros x e Hx Fx. +apply FLX_format_generic. +apply generic_format_FIX in Fx. +revert Fx. +apply generic_inclusion with (e := e)... +apply Z.le_refl. +Qed. + +(** unbounded floating-point format with normal mantissas *) +Inductive FLXN_format (x : R) : Prop := + FLXN_spec (f : float beta) : + x = F2R f -> + (x <> 0%R -> Zpower beta (prec - 1) <= Z.abs (Fnum f) < Zpower beta prec)%Z -> + FLXN_format x. + +Theorem generic_format_FLXN : + forall x, FLXN_format x -> generic_format beta FLX_exp x. +Proof. +intros x [[xm ex] H1 H2]. +destruct (Req_dec x 0) as [Zx|Zx]. +rewrite Zx. +apply generic_format_0. +specialize (H2 Zx). +apply generic_format_FLX. +rewrite H1. +eexists ; repeat split. +apply H2. +Qed. + +Theorem FLXN_format_generic : + forall x, generic_format beta FLX_exp x -> FLXN_format x. +Proof. +intros x Hx. +rewrite Hx. +simpl. +eexists. easy. +rewrite <- Hx. +intros Zx. +simpl. +split. +(* *) +apply le_IZR. +rewrite IZR_Zpower. +2: now apply Zlt_0_le_0_pred. +rewrite abs_IZR, <- scaled_mantissa_generic with (1 := Hx). +apply Rmult_le_reg_r with (bpow (cexp beta FLX_exp x)). +apply bpow_gt_0. +rewrite <- bpow_plus. +rewrite <- scaled_mantissa_abs. +rewrite <- cexp_abs. +rewrite scaled_mantissa_mult_bpow. +unfold cexp, FLX_exp. +rewrite mag_abs. +ring_simplify (prec - 1 + (mag beta x - prec))%Z. +destruct (mag beta x) as (ex,Ex). +now apply Ex. +(* *) +apply lt_IZR. +rewrite IZR_Zpower. +2: now apply Zlt_le_weak. +rewrite abs_IZR, <- scaled_mantissa_generic with (1 := Hx). +apply Rmult_lt_reg_r with (bpow (cexp beta FLX_exp x)). +apply bpow_gt_0. +rewrite <- bpow_plus. +rewrite <- scaled_mantissa_abs. +rewrite <- cexp_abs. +rewrite scaled_mantissa_mult_bpow. +unfold cexp, FLX_exp. +rewrite mag_abs. +ring_simplify (prec + (mag beta x - prec))%Z. +destruct (mag beta x) as (ex,Ex). +now apply Ex. +Qed. + +Theorem FLXN_format_satisfies_any : + satisfies_any FLXN_format. +Proof. +refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLX_exp)). +split ; intros H. +now apply FLXN_format_generic. +now apply generic_format_FLXN. +Qed. + +Lemma negligible_exp_FLX : + negligible_exp FLX_exp = None. +Proof. +case (negligible_exp_spec FLX_exp). +intros _; reflexivity. +intros n H2; contradict H2. +unfold FLX_exp; unfold Prec_gt_0 in prec_gt_0_; omega. +Qed. + +Theorem generic_format_FLX_1 : + generic_format beta FLX_exp 1. +Proof. +unfold generic_format, scaled_mantissa, cexp, F2R; simpl. +rewrite Rmult_1_l, (mag_unique beta 1 1). +{ unfold FLX_exp. + rewrite <- IZR_Zpower; [|unfold Prec_gt_0 in prec_gt_0_; omega]. + rewrite Ztrunc_IZR, IZR_Zpower; [|unfold Prec_gt_0 in prec_gt_0_; omega]. + rewrite <- bpow_plus. + now replace (_ + _)%Z with Z0 by ring. } +rewrite Rabs_R1; simpl; split; [now right|]. +unfold Z.pow_pos; simpl; rewrite Zmult_1_r; apply IZR_lt. +assert (H := Zle_bool_imp_le _ _ (radix_prop beta)); omega. +Qed. + +Theorem ulp_FLX_0: (ulp beta FLX_exp 0 = 0)%R. +Proof. +unfold ulp; rewrite Req_bool_true; trivial. +rewrite negligible_exp_FLX; easy. +Qed. + +Lemma ulp_FLX_1 : ulp beta FLX_exp 1 = bpow (-prec + 1). +Proof. +unfold ulp, FLX_exp, cexp; rewrite Req_bool_false; [|apply R1_neq_R0]. +rewrite mag_1; f_equal; ring. +Qed. + +Lemma succ_FLX_1 : (succ beta FLX_exp 1 = 1 + bpow (-prec + 1))%R. +Proof. +now unfold succ; rewrite Rle_bool_true; [|apply Rle_0_1]; rewrite ulp_FLX_1. +Qed. + +Theorem eq_0_round_0_FLX : + forall rnd {Vr: Valid_rnd rnd} x, + round beta FLX_exp rnd x = 0%R -> x = 0%R. +Proof. +intros rnd Hr x. +apply eq_0_round_0_negligible_exp; try assumption. +apply FLX_exp_valid. +apply negligible_exp_FLX. +Qed. + +Theorem gt_0_round_gt_0_FLX : + forall rnd {Vr: Valid_rnd rnd} x, + (0 < x)%R -> (0 < round beta FLX_exp rnd x)%R. +Proof with auto with typeclass_instances. +intros rnd Hr x Hx. +assert (K: (0 <= round beta FLX_exp rnd x)%R). +rewrite <- (round_0 beta FLX_exp rnd). +apply round_le... now apply Rlt_le. +destruct K; try easy. +absurd (x = 0)%R. +now apply Rgt_not_eq. +apply eq_0_round_0_FLX with rnd... +Qed. + + +Theorem ulp_FLX_le : + forall x, (ulp beta FLX_exp x <= Rabs x * bpow (1-prec))%R. +Proof. +intros x; case (Req_dec x 0); intros Hx. +rewrite Hx, ulp_FLX_0, Rabs_R0. +right; ring. +rewrite ulp_neq_0; try exact Hx. +unfold cexp, FLX_exp. +replace (mag beta x - prec)%Z with ((mag beta x - 1) + (1-prec))%Z by ring. +rewrite bpow_plus. +apply Rmult_le_compat_r. +apply bpow_ge_0. +now apply bpow_mag_le. +Qed. + +Theorem ulp_FLX_ge : + forall x, (Rabs x * bpow (-prec) <= ulp beta FLX_exp x)%R. +Proof. +intros x; case (Req_dec x 0); intros Hx. +rewrite Hx, ulp_FLX_0, Rabs_R0. +right; ring. +rewrite ulp_neq_0; try exact Hx. +unfold cexp, FLX_exp. +unfold Zminus; rewrite bpow_plus. +apply Rmult_le_compat_r. +apply bpow_ge_0. +left; now apply bpow_mag_gt. +Qed. + +Lemma ulp_FLX_exact_shift : + forall x e, + (ulp beta FLX_exp (x * bpow e) = ulp beta FLX_exp x * bpow e)%R. +Proof. +intros x e. +destruct (Req_dec x 0) as [Hx|Hx]. +{ unfold ulp. + now rewrite !Req_bool_true, negligible_exp_FLX; rewrite ?Hx, ?Rmult_0_l. } +unfold ulp; rewrite Req_bool_false; + [|now intro H; apply Hx, (Rmult_eq_reg_r (bpow e)); + [rewrite Rmult_0_l|apply Rgt_not_eq, Rlt_gt, bpow_gt_0]]. +rewrite (Req_bool_false _ _ Hx), <- bpow_plus; f_equal; unfold cexp, FLX_exp. +now rewrite mag_mult_bpow; [ring|]. +Qed. + +Lemma succ_FLX_exact_shift : + forall x e, + (succ beta FLX_exp (x * bpow e) = succ beta FLX_exp x * bpow e)%R. +Proof. +intros x e. +destruct (Rle_or_lt 0 x) as [Px|Nx]. +{ rewrite succ_eq_pos; [|now apply Rmult_le_pos, bpow_ge_0]. + rewrite (succ_eq_pos _ _ _ Px). + now rewrite Rmult_plus_distr_r; f_equal; apply ulp_FLX_exact_shift. } +unfold succ. +rewrite Rle_bool_false; [|assert (H := bpow_gt_0 beta e); nra]. +rewrite Rle_bool_false; [|now simpl]. +rewrite Ropp_mult_distr_l_reverse, <-Ropp_mult_distr_l_reverse; f_equal. +unfold pred_pos. +rewrite mag_mult_bpow; [|lra]. +replace (_ - 1)%Z with (mag beta (- x) - 1 + e)%Z; [|ring]; rewrite bpow_plus. +unfold Req_bool; rewrite Rcompare_mult_r; [|now apply bpow_gt_0]. +fold (Req_bool (-x) (bpow (mag beta (-x) - 1))); case Req_bool. +{ unfold FLX_exp. + replace (_ - _)%Z with (mag beta (- x) - 1 - prec + e)%Z; [|ring]. + rewrite bpow_plus; ring. } +rewrite ulp_FLX_exact_shift; ring. +Qed. + +(** FLX is a nice format: it has a monotone exponent... *) +Global Instance FLX_exp_monotone : Monotone_exp FLX_exp. +Proof. +intros ex ey Hxy. +now apply Zplus_le_compat_r. +Qed. + +(** and it allows a rounding to nearest, ties to even. *) +Hypothesis NE_prop : Z.even beta = false \/ (1 < prec)%Z. + +Global Instance exists_NE_FLX : Exists_NE beta FLX_exp. +Proof. +destruct NE_prop as [H|H]. +now left. +right. +unfold FLX_exp. +split ; omega. +Qed. + +End RND_FLX. diff --git a/flocq/Core/FTZ.v b/flocq/Core/FTZ.v new file mode 100644 index 00000000..1a93bcd9 --- /dev/null +++ b/flocq/Core/FTZ.v @@ -0,0 +1,340 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2009-2018 Sylvie Boldo +#
# +Copyright (C) 2009-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +(** * Floating-point format with abrupt underflow *) +Require Import Raux Defs Round_pred Generic_fmt. +Require Import Float_prop Ulp FLX. + +Section RND_FTZ. + +Variable beta : radix. + +Notation bpow e := (bpow beta e). + +Variable emin prec : Z. + +Context { prec_gt_0_ : Prec_gt_0 prec }. + +Inductive FTZ_format (x : R) : Prop := + FTZ_spec (f : float beta) : + x = F2R f -> + (x <> 0%R -> Zpower beta (prec - 1) <= Z.abs (Fnum f) < Zpower beta prec)%Z -> + (emin <= Fexp f)%Z -> + FTZ_format x. + +Definition FTZ_exp e := if Zlt_bool (e - prec) emin then (emin + prec - 1)%Z else (e - prec)%Z. + +(** Properties of the FTZ format *) +Global Instance FTZ_exp_valid : Valid_exp FTZ_exp. +Proof. +intros k. +unfold FTZ_exp. +generalize (Zlt_cases (k - prec) emin). +case (Zlt_bool (k - prec) emin) ; intros H1. +split ; intros H2. +omega. +split. +generalize (Zlt_cases (emin + prec + 1 - prec) emin). +case (Zlt_bool (emin + prec + 1 - prec) emin) ; intros H3. +omega. +generalize (Zlt_cases (emin + prec - 1 + 1 - prec) emin). +generalize (prec_gt_0 prec). +case (Zlt_bool (emin + prec - 1 + 1 - prec) emin) ; omega. +intros l H3. +generalize (Zlt_cases (l - prec) emin). +case (Zlt_bool (l - prec) emin) ; omega. +split ; intros H2. +generalize (Zlt_cases (k + 1 - prec) emin). +case (Zlt_bool (k + 1 - prec) emin) ; omega. +generalize (prec_gt_0 prec). +split ; intros ; omega. +Qed. + +Theorem FLXN_format_FTZ : + forall x, FTZ_format x -> FLXN_format beta prec x. +Proof. +intros x [[xm xe] Hx1 Hx2 Hx3]. +eexists. +exact Hx1. +exact Hx2. +Qed. + +Theorem generic_format_FTZ : + forall x, FTZ_format x -> generic_format beta FTZ_exp x. +Proof. +intros x Hx. +cut (generic_format beta (FLX_exp prec) x). +apply generic_inclusion_mag. +intros Zx. +destruct Hx as [[xm xe] Hx1 Hx2 Hx3]. +simpl in Hx2, Hx3. +specialize (Hx2 Zx). +assert (Zxm: xm <> Z0). +contradict Zx. +rewrite Hx1, Zx. +apply F2R_0. +unfold FTZ_exp, FLX_exp. +rewrite Zlt_bool_false. +apply Z.le_refl. +rewrite Hx1, mag_F2R with (1 := Zxm). +cut (prec - 1 < mag beta (IZR xm))%Z. +clear -Hx3 ; omega. +apply mag_gt_Zpower with (1 := Zxm). +apply Hx2. +apply generic_format_FLXN. +now apply FLXN_format_FTZ. +Qed. + +Theorem FTZ_format_generic : + forall x, generic_format beta FTZ_exp x -> FTZ_format x. +Proof. +intros x Hx. +destruct (Req_dec x 0) as [->|Hx3]. +exists (Float beta 0 emin). +apply sym_eq, F2R_0. +intros H. +now elim H. +apply Z.le_refl. +unfold generic_format, scaled_mantissa, cexp, FTZ_exp in Hx. +destruct (mag beta x) as (ex, Hx4). +simpl in Hx. +specialize (Hx4 Hx3). +generalize (Zlt_cases (ex - prec) emin) Hx. clear Hx. +case (Zlt_bool (ex - prec) emin) ; intros Hx5 Hx2. +elim Rlt_not_ge with (1 := proj2 Hx4). +apply Rle_ge. +rewrite Hx2, <- F2R_Zabs. +rewrite <- (Rmult_1_l (bpow ex)). +unfold F2R. simpl. +apply Rmult_le_compat. +now apply IZR_le. +apply bpow_ge_0. +apply IZR_le. +apply (Zlt_le_succ 0). +apply lt_IZR. +apply Rmult_lt_reg_r with (bpow (emin + prec - 1)). +apply bpow_gt_0. +rewrite Rmult_0_l. +change (0 < F2R (Float beta (Z.abs (Ztrunc (x * bpow (- (emin + prec - 1))))) (emin + prec - 1)))%R. +rewrite F2R_Zabs, <- Hx2. +now apply Rabs_pos_lt. +apply bpow_le. +omega. +rewrite Hx2. +eexists ; repeat split ; simpl. +apply le_IZR. +rewrite IZR_Zpower. +apply Rmult_le_reg_r with (bpow (ex - prec)). +apply bpow_gt_0. +rewrite <- bpow_plus. +replace (prec - 1 + (ex - prec))%Z with (ex - 1)%Z by ring. +change (bpow (ex - 1) <= F2R (Float beta (Z.abs (Ztrunc (x * bpow (- (ex - prec))))) (ex - prec)))%R. +rewrite F2R_Zabs, <- Hx2. +apply Hx4. +apply Zle_minus_le_0. +now apply (Zlt_le_succ 0). +apply lt_IZR. +rewrite IZR_Zpower. +apply Rmult_lt_reg_r with (bpow (ex - prec)). +apply bpow_gt_0. +rewrite <- bpow_plus. +replace (prec + (ex - prec))%Z with ex by ring. +change (F2R (Float beta (Z.abs (Ztrunc (x * bpow (- (ex - prec))))) (ex - prec)) < bpow ex)%R. +rewrite F2R_Zabs, <- Hx2. +apply Hx4. +now apply Zlt_le_weak. +now apply Z.ge_le. +Qed. + +Theorem FTZ_format_satisfies_any : + satisfies_any FTZ_format. +Proof. +refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FTZ_exp)). +intros x. +split. +apply FTZ_format_generic. +apply generic_format_FTZ. +Qed. + +Theorem FTZ_format_FLXN : + forall x : R, + (bpow (emin + prec - 1) <= Rabs x)%R -> + FLXN_format beta prec x -> FTZ_format x. +Proof. +intros x Hx Fx. +apply FTZ_format_generic. +apply generic_format_FLXN in Fx. +revert Hx Fx. +apply generic_inclusion_ge. +intros e He. +unfold FTZ_exp. +rewrite Zlt_bool_false. +apply Z.le_refl. +omega. +Qed. + +Theorem ulp_FTZ_0 : + ulp beta FTZ_exp 0 = bpow (emin+prec-1). +Proof with auto with typeclass_instances. +unfold ulp; rewrite Req_bool_true; trivial. +case (negligible_exp_spec FTZ_exp). +intros T; specialize (T (emin-1)%Z); contradict T. +apply Zle_not_lt; unfold FTZ_exp; unfold Prec_gt_0 in prec_gt_0_. +rewrite Zlt_bool_true; omega. +assert (V:(FTZ_exp (emin+prec-1) = emin+prec-1)%Z). +unfold FTZ_exp; rewrite Zlt_bool_true; omega. +intros n H2; rewrite <-V. +apply f_equal, fexp_negligible_exp_eq... +omega. +Qed. + + +Section FTZ_round. + +(** Rounding with FTZ *) +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. + +Definition Zrnd_FTZ x := + if Rle_bool 1 (Rabs x) then rnd x else Z0. + +Global Instance valid_rnd_FTZ : Valid_rnd Zrnd_FTZ. +Proof with auto with typeclass_instances. +split. +(* *) +intros x y Hxy. +unfold Zrnd_FTZ. +case Rle_bool_spec ; intros Hx ; + case Rle_bool_spec ; intros Hy. +4: easy. +(* 1 <= |x| *) +now apply Zrnd_le. +rewrite <- (Zrnd_IZR rnd 0). +apply Zrnd_le... +apply Rle_trans with (-1)%R. 2: now apply IZR_le. +destruct (Rabs_ge_inv _ _ Hx) as [Hx1|Hx1]. +exact Hx1. +elim Rle_not_lt with (1 := Hx1). +apply Rle_lt_trans with (2 := Hy). +apply Rle_trans with (1 := Hxy). +apply RRle_abs. +(* |x| < 1 *) +rewrite <- (Zrnd_IZR rnd 0). +apply Zrnd_le... +apply Rle_trans with 1%R. +now apply IZR_le. +destruct (Rabs_ge_inv _ _ Hy) as [Hy1|Hy1]. +elim Rle_not_lt with (1 := Hy1). +apply Rlt_le_trans with (2 := Hxy). +apply (Rabs_def2 _ _ Hx). +exact Hy1. +(* *) +intros n. +unfold Zrnd_FTZ. +rewrite Zrnd_IZR... +case Rle_bool_spec. +easy. +rewrite <- abs_IZR. +intros H. +generalize (lt_IZR _ 1 H). +clear. +now case n ; trivial ; simpl ; intros [p|p|]. +Qed. + +Theorem round_FTZ_FLX : + forall x : R, + (bpow (emin + prec - 1) <= Rabs x)%R -> + round beta FTZ_exp Zrnd_FTZ x = round beta (FLX_exp prec) rnd x. +Proof. +intros x Hx. +unfold round, scaled_mantissa, cexp. +destruct (mag beta x) as (ex, He). simpl. +assert (Hx0: x <> 0%R). +intros Hx0. +apply Rle_not_lt with (1 := Hx). +rewrite Hx0, Rabs_R0. +apply bpow_gt_0. +specialize (He Hx0). +assert (He': (emin + prec <= ex)%Z). +apply (bpow_lt_bpow beta). +apply Rle_lt_trans with (1 := Hx). +apply He. +replace (FTZ_exp ex) with (FLX_exp prec ex). +unfold Zrnd_FTZ. +rewrite Rle_bool_true. +apply refl_equal. +rewrite Rabs_mult. +rewrite (Rabs_pos_eq (bpow (- FLX_exp prec ex))). +change 1%R with (bpow 0). +rewrite <- (Zplus_opp_r (FLX_exp prec ex)). +rewrite bpow_plus. +apply Rmult_le_compat_r. +apply bpow_ge_0. +apply Rle_trans with (2 := proj1 He). +apply bpow_le. +unfold FLX_exp. +generalize (prec_gt_0 prec). +clear -He' ; omega. +apply bpow_ge_0. +unfold FLX_exp, FTZ_exp. +rewrite Zlt_bool_false. +apply refl_equal. +clear -He' ; omega. +Qed. + +Theorem round_FTZ_small : + forall x : R, + (Rabs x < bpow (emin + prec - 1))%R -> + round beta FTZ_exp Zrnd_FTZ x = 0%R. +Proof with auto with typeclass_instances. +intros x Hx. +destruct (Req_dec x 0) as [Hx0|Hx0]. +rewrite Hx0. +apply round_0... +unfold round, scaled_mantissa, cexp. +destruct (mag beta x) as (ex, He). simpl. +specialize (He Hx0). +unfold Zrnd_FTZ. +rewrite Rle_bool_false. +apply F2R_0. +rewrite Rabs_mult. +rewrite (Rabs_pos_eq (bpow (- FTZ_exp ex))). +change 1%R with (bpow 0). +rewrite <- (Zplus_opp_r (FTZ_exp ex)). +rewrite bpow_plus. +apply Rmult_lt_compat_r. +apply bpow_gt_0. +apply Rlt_le_trans with (1 := Hx). +apply bpow_le. +unfold FTZ_exp. +generalize (Zlt_cases (ex - prec) emin). +case Zlt_bool. +intros _. +apply Z.le_refl. +intros He'. +elim Rlt_not_le with (1 := Hx). +apply Rle_trans with (2 := proj1 He). +apply bpow_le. +omega. +apply bpow_ge_0. +Qed. + +End FTZ_round. + +End RND_FTZ. diff --git a/flocq/Core/Fcore.v b/flocq/Core/Fcore.v deleted file mode 100644 index 2a5a5f02..00000000 --- a/flocq/Core/Fcore.v +++ /dev/null @@ -1,30 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2010-2013 Sylvie Boldo -#
# -Copyright (C) 2010-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** To ease the import *) -Require Export Fcore_Raux. -Require Export Fcore_defs. -Require Export Fcore_float_prop. -Require Export Fcore_rnd. -Require Export Fcore_generic_fmt. -Require Export Fcore_rnd_ne. -Require Export Fcore_FIX. -Require Export Fcore_FLX. -Require Export Fcore_FLT. -Require Export Fcore_ulp. diff --git a/flocq/Core/Fcore_FIX.v b/flocq/Core/Fcore_FIX.v deleted file mode 100644 index e224a64a..00000000 --- a/flocq/Core/Fcore_FIX.v +++ /dev/null @@ -1,100 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2010-2013 Sylvie Boldo -#
# -Copyright (C) 2010-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** * Fixed-point format *) -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_rnd. -Require Import Fcore_generic_fmt. -Require Import Fcore_ulp. -Require Import Fcore_rnd_ne. - -Section RND_FIX. - -Variable beta : radix. - -Notation bpow := (bpow beta). - -Variable emin : Z. - -(* fixed-point format with exponent emin *) -Definition FIX_format (x : R) := - exists f : float beta, - x = F2R f /\ (Fexp f = emin)%Z. - -Definition FIX_exp (e : Z) := emin. - -(** Properties of the FIX format *) - -Global Instance FIX_exp_valid : Valid_exp FIX_exp. -Proof. -intros k. -unfold FIX_exp. -split ; intros H. -now apply Zlt_le_weak. -split. -apply Zle_refl. -now intros _ _. -Qed. - -Theorem generic_format_FIX : - forall x, FIX_format x -> generic_format beta FIX_exp x. -Proof. -intros x ((xm, xe), (Hx1, Hx2)). -rewrite Hx1. -now apply generic_format_canonic. -Qed. - -Theorem FIX_format_generic : - forall x, generic_format beta FIX_exp x -> FIX_format x. -Proof. -intros x H. -rewrite H. -eexists ; repeat split. -Qed. - -Theorem FIX_format_satisfies_any : - satisfies_any FIX_format. -Proof. -refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FIX_exp)). -intros x. -split. -apply FIX_format_generic. -apply generic_format_FIX. -Qed. - -Global Instance FIX_exp_monotone : Monotone_exp FIX_exp. -Proof. -intros ex ey H. -apply Zle_refl. -Qed. - -Theorem ulp_FIX: forall x, ulp beta FIX_exp x = bpow emin. -Proof. -intros x; unfold ulp. -case Req_bool_spec; intros Zx. -case (negligible_exp_spec FIX_exp). -intros T; specialize (T (emin-1)%Z); contradict T. -unfold FIX_exp; omega. -intros n _; reflexivity. -reflexivity. -Qed. - - -End RND_FIX. diff --git a/flocq/Core/Fcore_FLT.v b/flocq/Core/Fcore_FLT.v deleted file mode 100644 index 2258b1d9..00000000 --- a/flocq/Core/Fcore_FLT.v +++ /dev/null @@ -1,332 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2010-2013 Sylvie Boldo -#
# -Copyright (C) 2010-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** * Floating-point format with gradual underflow *) -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_rnd. -Require Import Fcore_generic_fmt. -Require Import Fcore_float_prop. -Require Import Fcore_FLX. -Require Import Fcore_FIX. -Require Import Fcore_ulp. -Require Import Fcore_rnd_ne. - -Section RND_FLT. - -Variable beta : radix. - -Notation bpow e := (bpow beta e). - -Variable emin prec : Z. - -Context { prec_gt_0_ : Prec_gt_0 prec }. - -(* floating-point format with gradual underflow *) -Definition FLT_format (x : R) := - exists f : float beta, - x = F2R f /\ (Zabs (Fnum f) < Zpower beta prec)%Z /\ (emin <= Fexp f)%Z. - -Definition FLT_exp e := Zmax (e - prec) emin. - -(** Properties of the FLT format *) -Global Instance FLT_exp_valid : Valid_exp FLT_exp. -Proof. -intros k. -unfold FLT_exp. -generalize (prec_gt_0 prec). -repeat split ; - intros ; zify ; omega. -Qed. - -Theorem generic_format_FLT : - forall x, FLT_format x -> generic_format beta FLT_exp x. -Proof. -clear prec_gt_0_. -intros x ((mx, ex), (H1, (H2, H3))). -simpl in H2, H3. -rewrite H1. -apply generic_format_F2R. -intros Zmx. -unfold canonic_exp, FLT_exp. -rewrite ln_beta_F2R with (1 := Zmx). -apply Zmax_lub with (2 := H3). -apply Zplus_le_reg_r with (prec - ex)%Z. -ring_simplify. -now apply ln_beta_le_Zpower. -Qed. - -Theorem FLT_format_generic : - forall x, generic_format beta FLT_exp x -> FLT_format x. -Proof. -intros x. -unfold generic_format. -set (ex := canonic_exp beta FLT_exp x). -set (mx := Ztrunc (scaled_mantissa beta FLT_exp x)). -intros Hx. -rewrite Hx. -eexists ; repeat split ; simpl. -apply lt_Z2R. -rewrite Z2R_Zpower. 2: now apply Zlt_le_weak. -apply Rmult_lt_reg_r with (bpow ex). -apply bpow_gt_0. -rewrite <- bpow_plus. -change (F2R (Float beta (Zabs mx) ex) < bpow (prec + ex))%R. -rewrite F2R_Zabs. -rewrite <- Hx. -destruct (Req_dec x 0) as [Hx0|Hx0]. -rewrite Hx0, Rabs_R0. -apply bpow_gt_0. -unfold canonic_exp in ex. -destruct (ln_beta beta x) as (ex', He). -simpl in ex. -specialize (He Hx0). -apply Rlt_le_trans with (1 := proj2 He). -apply bpow_le. -cut (ex' - prec <= ex)%Z. omega. -unfold ex, FLT_exp. -apply Zle_max_l. -apply Zle_max_r. -Qed. - - -Theorem FLT_format_bpow : - forall e, (emin <= e)%Z -> generic_format beta FLT_exp (bpow e). -Proof. -intros e He. -apply generic_format_bpow; unfold FLT_exp. -apply Z.max_case; try assumption. -unfold Prec_gt_0 in prec_gt_0_; omega. -Qed. - - - - -Theorem FLT_format_satisfies_any : - satisfies_any FLT_format. -Proof. -refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLT_exp)). -intros x. -split. -apply FLT_format_generic. -apply generic_format_FLT. -Qed. - -Theorem canonic_exp_FLT_FLX : - forall x, - (bpow (emin + prec - 1) <= Rabs x)%R -> - canonic_exp beta FLT_exp x = canonic_exp beta (FLX_exp prec) x. -Proof. -intros x Hx. -assert (Hx0: x <> 0%R). -intros H1; rewrite H1, Rabs_R0 in Hx. -contradict Hx; apply Rlt_not_le, bpow_gt_0. -unfold canonic_exp. -apply Zmax_left. -destruct (ln_beta beta x) as (ex, He). -unfold FLX_exp. simpl. -specialize (He Hx0). -cut (emin + prec - 1 < ex)%Z. omega. -apply (lt_bpow beta). -apply Rle_lt_trans with (1 := Hx). -apply He. -Qed. - -(** Links between FLT and FLX *) -Theorem generic_format_FLT_FLX : - forall x : R, - (bpow (emin + prec - 1) <= Rabs x)%R -> - generic_format beta (FLX_exp prec) x -> - generic_format beta FLT_exp x. -Proof. -intros x Hx H. -destruct (Req_dec x 0) as [Hx0|Hx0]. -rewrite Hx0. -apply generic_format_0. -unfold generic_format, scaled_mantissa. -now rewrite canonic_exp_FLT_FLX. -Qed. - -Theorem generic_format_FLX_FLT : - forall x : R, - generic_format beta FLT_exp x -> generic_format beta (FLX_exp prec) x. -Proof. -clear prec_gt_0_. -intros x Hx. -unfold generic_format in Hx; rewrite Hx. -apply generic_format_F2R. -intros _. -rewrite <- Hx. -unfold canonic_exp, FLX_exp, FLT_exp. -apply Zle_max_l. -Qed. - -Theorem round_FLT_FLX : forall rnd x, - (bpow (emin + prec - 1) <= Rabs x)%R -> - round beta FLT_exp rnd x = round beta (FLX_exp prec) rnd x. -intros rnd x Hx. -unfold round, scaled_mantissa. -rewrite canonic_exp_FLT_FLX ; trivial. -Qed. - -(** Links between FLT and FIX (underflow) *) -Theorem canonic_exp_FLT_FIX : - forall x, x <> 0%R -> - (Rabs x < bpow (emin + prec))%R -> - canonic_exp beta FLT_exp x = canonic_exp beta (FIX_exp emin) x. -Proof. -intros x Hx0 Hx. -unfold canonic_exp. -apply Zmax_right. -unfold FIX_exp. -destruct (ln_beta beta x) as (ex, Hex). -simpl. -cut (ex - 1 < emin + prec)%Z. omega. -apply (lt_bpow beta). -apply Rle_lt_trans with (2 := Hx). -now apply Hex. -Qed. - -Theorem generic_format_FIX_FLT : - forall x : R, - generic_format beta FLT_exp x -> - generic_format beta (FIX_exp emin) x. -Proof. -clear prec_gt_0_. -intros x Hx. -rewrite Hx. -apply generic_format_F2R. -intros _. -rewrite <- Hx. -apply Zle_max_r. -Qed. - -Theorem generic_format_FLT_FIX : - forall x : R, - (Rabs x <= bpow (emin + prec))%R -> - generic_format beta (FIX_exp emin) x -> - generic_format beta FLT_exp x. -Proof with auto with typeclass_instances. -apply generic_inclusion_le... -intros e He. -unfold FIX_exp. -apply Zmax_lub. -omega. -apply Zle_refl. -Qed. - -Theorem ulp_FLT_small: forall x, (Rabs x < bpow (emin+prec))%R -> - ulp beta FLT_exp x = bpow emin. -Proof with auto with typeclass_instances. -intros x Hx. -unfold ulp; case Req_bool_spec; intros Hx2. -(* x = 0 *) -case (negligible_exp_spec FLT_exp). -intros T; specialize (T (emin-1)%Z); contradict T. -apply Zle_not_lt; unfold FLT_exp. -apply Zle_trans with (2:=Z.le_max_r _ _); omega. -assert (V:FLT_exp emin = emin). -unfold FLT_exp; apply Z.max_r. -unfold Prec_gt_0 in prec_gt_0_; omega. -intros n H2; rewrite <-V. -apply f_equal, fexp_negligible_exp_eq... -omega. -(* x <> 0 *) -apply f_equal; unfold canonic_exp, FLT_exp. -apply Z.max_r. -assert (ln_beta beta x-1 < emin+prec)%Z;[idtac|omega]. -destruct (ln_beta beta x) as (e,He); simpl. -apply lt_bpow with beta. -apply Rle_lt_trans with (2:=Hx). -now apply He. -Qed. - -Theorem ulp_FLT_le : - forall x, (bpow (emin + prec - 1) <= Rabs x)%R -> - (ulp beta FLT_exp x <= Rabs x * bpow (1 - prec))%R. -Proof. -intros x Hx. -assert (Zx : (x <> 0)%R). - intros Z; contradict Hx; apply Rgt_not_le, Rlt_gt. - rewrite Z, Rabs_R0; apply bpow_gt_0. -rewrite ulp_neq_0 with (1 := Zx). -unfold canonic_exp, FLT_exp. -destruct (ln_beta beta x) as (e,He). -apply Rle_trans with (bpow (e-1)*bpow (1-prec))%R. -rewrite <- bpow_plus. -right; apply f_equal. -replace (e - 1 + (1 - prec))%Z with (e - prec)%Z by ring. -apply Z.max_l. -assert (emin+prec-1 < e)%Z; try omega. -apply lt_bpow with beta. -apply Rle_lt_trans with (1:=Hx). -now apply He. -apply Rmult_le_compat_r. -apply bpow_ge_0. -now apply He. -Qed. - -Theorem ulp_FLT_gt : - forall x, (Rabs x * bpow (-prec) < ulp beta FLT_exp x)%R. -Proof. -intros x; case (Req_dec x 0); intros Hx. -rewrite Hx, ulp_FLT_small, Rabs_R0, Rmult_0_l; try apply bpow_gt_0. -rewrite Rabs_R0; apply bpow_gt_0. -rewrite ulp_neq_0; try exact Hx. -unfold canonic_exp, FLT_exp. -apply Rlt_le_trans with (bpow (ln_beta beta x)*bpow (-prec))%R. -apply Rmult_lt_compat_r. -apply bpow_gt_0. -now apply bpow_ln_beta_gt. -rewrite <- bpow_plus. -apply bpow_le. -apply Z.le_max_l. -Qed. - - - -(** FLT is a nice format: it has a monotone exponent... *) -Global Instance FLT_exp_monotone : Monotone_exp FLT_exp. -Proof. -intros ex ey. -unfold FLT_exp. -zify ; omega. -Qed. - -(** and it allows a rounding to nearest, ties to even. *) -Hypothesis NE_prop : Zeven beta = false \/ (1 < prec)%Z. - -Global Instance exists_NE_FLT : Exists_NE beta FLT_exp. -Proof. -destruct NE_prop as [H|H]. -now left. -right. -intros e. -unfold FLT_exp. -destruct (Zmax_spec (e - prec) emin) as [(H1,H2)|(H1,H2)] ; - rewrite H2 ; clear H2. -generalize (Zmax_spec (e + 1 - prec) emin). -generalize (Zmax_spec (e - prec + 1 - prec) emin). -omega. -generalize (Zmax_spec (e + 1 - prec) emin). -generalize (Zmax_spec (emin + 1 - prec) emin). -omega. -Qed. - -End RND_FLT. diff --git a/flocq/Core/Fcore_FLX.v b/flocq/Core/Fcore_FLX.v deleted file mode 100644 index 55f6db61..00000000 --- a/flocq/Core/Fcore_FLX.v +++ /dev/null @@ -1,271 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2010-2013 Sylvie Boldo -#
# -Copyright (C) 2010-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** * Floating-point format without underflow *) -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_rnd. -Require Import Fcore_generic_fmt. -Require Import Fcore_float_prop. -Require Import Fcore_FIX. -Require Import Fcore_ulp. -Require Import Fcore_rnd_ne. - -Section RND_FLX. - -Variable beta : radix. - -Notation bpow e := (bpow beta e). - -Variable prec : Z. - -Class Prec_gt_0 := - prec_gt_0 : (0 < prec)%Z. - -Context { prec_gt_0_ : Prec_gt_0 }. - -(* unbounded floating-point format *) -Definition FLX_format (x : R) := - exists f : float beta, - x = F2R f /\ (Zabs (Fnum f) < Zpower beta prec)%Z. - -Definition FLX_exp (e : Z) := (e - prec)%Z. - -(** Properties of the FLX format *) - -Global Instance FLX_exp_valid : Valid_exp FLX_exp. -Proof. -intros k. -unfold FLX_exp. -generalize prec_gt_0. -repeat split ; intros ; omega. -Qed. - -Theorem FIX_format_FLX : - forall x e, - (bpow (e - 1) <= Rabs x <= bpow e)%R -> - FLX_format x -> - FIX_format beta (e - prec) x. -Proof. -clear prec_gt_0_. -intros x e Hx ((xm, xe), (H1, H2)). -rewrite H1, (F2R_prec_normalize beta xm xe e prec). -now eexists. -exact H2. -now rewrite <- H1. -Qed. - -Theorem FLX_format_generic : - forall x, generic_format beta FLX_exp x -> FLX_format x. -Proof. -intros x H. -rewrite H. -unfold FLX_format. -eexists ; repeat split. -simpl. -apply lt_Z2R. -rewrite Z2R_abs. -rewrite <- scaled_mantissa_generic with (1 := H). -rewrite <- scaled_mantissa_abs. -apply Rmult_lt_reg_r with (bpow (canonic_exp beta FLX_exp (Rabs x))). -apply bpow_gt_0. -rewrite scaled_mantissa_mult_bpow. -rewrite Z2R_Zpower, <- bpow_plus. -2: now apply Zlt_le_weak. -unfold canonic_exp, FLX_exp. -ring_simplify (prec + (ln_beta beta (Rabs x) - prec))%Z. -rewrite ln_beta_abs. -destruct (Req_dec x 0) as [Hx|Hx]. -rewrite Hx, Rabs_R0. -apply bpow_gt_0. -destruct (ln_beta beta x) as (ex, Ex). -now apply Ex. -Qed. - -Theorem generic_format_FLX : - forall x, FLX_format x -> generic_format beta FLX_exp x. -Proof. -clear prec_gt_0_. -intros x ((mx,ex),(H1,H2)). -simpl in H2. -rewrite H1. -apply generic_format_F2R. -intros Zmx. -unfold canonic_exp, FLX_exp. -rewrite ln_beta_F2R with (1 := Zmx). -apply Zplus_le_reg_r with (prec - ex)%Z. -ring_simplify. -now apply ln_beta_le_Zpower. -Qed. - -Theorem FLX_format_satisfies_any : - satisfies_any FLX_format. -Proof. -refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLX_exp)). -intros x. -split. -apply FLX_format_generic. -apply generic_format_FLX. -Qed. - -Theorem FLX_format_FIX : - forall x e, - (bpow (e - 1) <= Rabs x <= bpow e)%R -> - FIX_format beta (e - prec) x -> - FLX_format x. -Proof with auto with typeclass_instances. -intros x e Hx Fx. -apply FLX_format_generic. -apply generic_format_FIX in Fx. -revert Fx. -apply generic_inclusion with (e := e)... -apply Zle_refl. -Qed. - -(** unbounded floating-point format with normal mantissas *) -Definition FLXN_format (x : R) := - exists f : float beta, - x = F2R f /\ (x <> R0 -> - Zpower beta (prec - 1) <= Zabs (Fnum f) < Zpower beta prec)%Z. - -Theorem generic_format_FLXN : - forall x, FLXN_format x -> generic_format beta FLX_exp x. -Proof. -intros x ((xm,ex),(H1,H2)). -destruct (Req_dec x 0) as [Zx|Zx]. -rewrite Zx. -apply generic_format_0. -specialize (H2 Zx). -apply generic_format_FLX. -rewrite H1. -eexists ; repeat split. -apply H2. -Qed. - -Theorem FLXN_format_generic : - forall x, generic_format beta FLX_exp x -> FLXN_format x. -Proof. -intros x Hx. -rewrite Hx. -simpl. -eexists ; split. split. -simpl. -rewrite <- Hx. -intros Zx. -split. -(* *) -apply le_Z2R. -rewrite Z2R_Zpower. -2: now apply Zlt_0_le_0_pred. -rewrite Z2R_abs, <- scaled_mantissa_generic with (1 := Hx). -apply Rmult_le_reg_r with (bpow (canonic_exp beta FLX_exp x)). -apply bpow_gt_0. -rewrite <- bpow_plus. -rewrite <- scaled_mantissa_abs. -rewrite <- canonic_exp_abs. -rewrite scaled_mantissa_mult_bpow. -unfold canonic_exp, FLX_exp. -rewrite ln_beta_abs. -ring_simplify (prec - 1 + (ln_beta beta x - prec))%Z. -destruct (ln_beta beta x) as (ex,Ex). -now apply Ex. -(* *) -apply lt_Z2R. -rewrite Z2R_Zpower. -2: now apply Zlt_le_weak. -rewrite Z2R_abs, <- scaled_mantissa_generic with (1 := Hx). -apply Rmult_lt_reg_r with (bpow (canonic_exp beta FLX_exp x)). -apply bpow_gt_0. -rewrite <- bpow_plus. -rewrite <- scaled_mantissa_abs. -rewrite <- canonic_exp_abs. -rewrite scaled_mantissa_mult_bpow. -unfold canonic_exp, FLX_exp. -rewrite ln_beta_abs. -ring_simplify (prec + (ln_beta beta x - prec))%Z. -destruct (ln_beta beta x) as (ex,Ex). -now apply Ex. -Qed. - -Theorem FLXN_format_satisfies_any : - satisfies_any FLXN_format. -Proof. -refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLX_exp)). -split ; intros H. -now apply FLXN_format_generic. -now apply generic_format_FLXN. -Qed. - -Theorem ulp_FLX_0: (ulp beta FLX_exp 0 = 0)%R. -Proof. -unfold ulp; rewrite Req_bool_true; trivial. -case (negligible_exp_spec FLX_exp). -intros _; reflexivity. -intros n H2; contradict H2. -unfold FLX_exp; unfold Prec_gt_0 in prec_gt_0_; omega. -Qed. - -Theorem ulp_FLX_le: forall x, (ulp beta FLX_exp x <= Rabs x * bpow (1-prec))%R. -Proof. -intros x; case (Req_dec x 0); intros Hx. -rewrite Hx, ulp_FLX_0, Rabs_R0. -right; ring. -rewrite ulp_neq_0; try exact Hx. -unfold canonic_exp, FLX_exp. -replace (ln_beta beta x - prec)%Z with ((ln_beta beta x - 1) + (1-prec))%Z by ring. -rewrite bpow_plus. -apply Rmult_le_compat_r. -apply bpow_ge_0. -now apply bpow_ln_beta_le. -Qed. - - -Theorem ulp_FLX_ge: forall x, (Rabs x * bpow (-prec) <= ulp beta FLX_exp x)%R. -Proof. -intros x; case (Req_dec x 0); intros Hx. -rewrite Hx, ulp_FLX_0, Rabs_R0. -right; ring. -rewrite ulp_neq_0; try exact Hx. -unfold canonic_exp, FLX_exp. -unfold Zminus; rewrite bpow_plus. -apply Rmult_le_compat_r. -apply bpow_ge_0. -left; now apply bpow_ln_beta_gt. -Qed. - -(** FLX is a nice format: it has a monotone exponent... *) -Global Instance FLX_exp_monotone : Monotone_exp FLX_exp. -Proof. -intros ex ey Hxy. -now apply Zplus_le_compat_r. -Qed. - -(** and it allows a rounding to nearest, ties to even. *) -Hypothesis NE_prop : Zeven beta = false \/ (1 < prec)%Z. - -Global Instance exists_NE_FLX : Exists_NE beta FLX_exp. -Proof. -destruct NE_prop as [H|H]. -now left. -right. -unfold FLX_exp. -split ; omega. -Qed. - -End RND_FLX. diff --git a/flocq/Core/Fcore_FTZ.v b/flocq/Core/Fcore_FTZ.v deleted file mode 100644 index a2fab00b..00000000 --- a/flocq/Core/Fcore_FTZ.v +++ /dev/null @@ -1,345 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2010-2013 Sylvie Boldo -#
# -Copyright (C) 2010-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** * Floating-point format with abrupt underflow *) -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_rnd. -Require Import Fcore_generic_fmt. -Require Import Fcore_float_prop. -Require Import Fcore_ulp. -Require Import Fcore_FLX. - -Section RND_FTZ. - -Variable beta : radix. - -Notation bpow e := (bpow beta e). - -Variable emin prec : Z. - -Context { prec_gt_0_ : Prec_gt_0 prec }. - -(* floating-point format with abrupt underflow *) -Definition FTZ_format (x : R) := - exists f : float beta, - x = F2R f /\ (x <> R0 -> Zpower beta (prec - 1) <= Zabs (Fnum f) < Zpower beta prec)%Z /\ - (emin <= Fexp f)%Z. - -Definition FTZ_exp e := if Zlt_bool (e - prec) emin then (emin + prec - 1)%Z else (e - prec)%Z. - -(** Properties of the FTZ format *) -Global Instance FTZ_exp_valid : Valid_exp FTZ_exp. -Proof. -intros k. -unfold FTZ_exp. -generalize (Zlt_cases (k - prec) emin). -case (Zlt_bool (k - prec) emin) ; intros H1. -split ; intros H2. -omega. -split. -generalize (Zlt_cases (emin + prec + 1 - prec) emin). -case (Zlt_bool (emin + prec + 1 - prec) emin) ; intros H3. -omega. -generalize (Zlt_cases (emin + prec - 1 + 1 - prec) emin). -generalize (prec_gt_0 prec). -case (Zlt_bool (emin + prec - 1 + 1 - prec) emin) ; omega. -intros l H3. -generalize (Zlt_cases (l - prec) emin). -case (Zlt_bool (l - prec) emin) ; omega. -split ; intros H2. -generalize (Zlt_cases (k + 1 - prec) emin). -case (Zlt_bool (k + 1 - prec) emin) ; omega. -generalize (prec_gt_0 prec). -split ; intros ; omega. -Qed. - -Theorem FLXN_format_FTZ : - forall x, FTZ_format x -> FLXN_format beta prec x. -Proof. -intros x ((xm, xe), (Hx1, (Hx2, Hx3))). -eexists. -apply (conj Hx1 Hx2). -Qed. - -Theorem generic_format_FTZ : - forall x, FTZ_format x -> generic_format beta FTZ_exp x. -Proof. -intros x Hx. -cut (generic_format beta (FLX_exp prec) x). -apply generic_inclusion_ln_beta. -intros Zx. -destruct Hx as ((xm, xe), (Hx1, (Hx2, Hx3))). -simpl in Hx2, Hx3. -specialize (Hx2 Zx). -assert (Zxm: xm <> Z0). -contradict Zx. -rewrite Hx1, Zx. -apply F2R_0. -unfold FTZ_exp, FLX_exp. -rewrite Zlt_bool_false. -apply Zle_refl. -rewrite Hx1, ln_beta_F2R with (1 := Zxm). -cut (prec - 1 < ln_beta beta (Z2R xm))%Z. -clear -Hx3 ; omega. -apply ln_beta_gt_Zpower with (1 := Zxm). -apply Hx2. -apply generic_format_FLXN. -now apply FLXN_format_FTZ. -Qed. - -Theorem FTZ_format_generic : - forall x, generic_format beta FTZ_exp x -> FTZ_format x. -Proof. -intros x Hx. -destruct (Req_dec x 0) as [Hx3|Hx3]. -exists (Float beta 0 emin). -split. -unfold F2R. simpl. -now rewrite Rmult_0_l. -split. -intros H. -now elim H. -apply Zle_refl. -unfold generic_format, scaled_mantissa, canonic_exp, FTZ_exp in Hx. -destruct (ln_beta beta x) as (ex, Hx4). -simpl in Hx. -specialize (Hx4 Hx3). -generalize (Zlt_cases (ex - prec) emin) Hx. clear Hx. -case (Zlt_bool (ex - prec) emin) ; intros Hx5 Hx2. -elim Rlt_not_ge with (1 := proj2 Hx4). -apply Rle_ge. -rewrite Hx2, <- F2R_Zabs. -rewrite <- (Rmult_1_l (bpow ex)). -unfold F2R. simpl. -apply Rmult_le_compat. -now apply (Z2R_le 0 1). -apply bpow_ge_0. -apply (Z2R_le 1). -apply (Zlt_le_succ 0). -apply lt_Z2R. -apply Rmult_lt_reg_r with (bpow (emin + prec - 1)). -apply bpow_gt_0. -rewrite Rmult_0_l. -change (0 < F2R (Float beta (Zabs (Ztrunc (x * bpow (- (emin + prec - 1))))) (emin + prec - 1)))%R. -rewrite F2R_Zabs, <- Hx2. -now apply Rabs_pos_lt. -apply bpow_le. -omega. -rewrite Hx2. -eexists ; repeat split ; simpl. -apply le_Z2R. -rewrite Z2R_Zpower. -apply Rmult_le_reg_r with (bpow (ex - prec)). -apply bpow_gt_0. -rewrite <- bpow_plus. -replace (prec - 1 + (ex - prec))%Z with (ex - 1)%Z by ring. -change (bpow (ex - 1) <= F2R (Float beta (Zabs (Ztrunc (x * bpow (- (ex - prec))))) (ex - prec)))%R. -rewrite F2R_Zabs, <- Hx2. -apply Hx4. -apply Zle_minus_le_0. -now apply (Zlt_le_succ 0). -apply lt_Z2R. -rewrite Z2R_Zpower. -apply Rmult_lt_reg_r with (bpow (ex - prec)). -apply bpow_gt_0. -rewrite <- bpow_plus. -replace (prec + (ex - prec))%Z with ex by ring. -change (F2R (Float beta (Zabs (Ztrunc (x * bpow (- (ex - prec))))) (ex - prec)) < bpow ex)%R. -rewrite F2R_Zabs, <- Hx2. -apply Hx4. -now apply Zlt_le_weak. -now apply Zge_le. -Qed. - -Theorem FTZ_format_satisfies_any : - satisfies_any FTZ_format. -Proof. -refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FTZ_exp)). -intros x. -split. -apply FTZ_format_generic. -apply generic_format_FTZ. -Qed. - -Theorem FTZ_format_FLXN : - forall x : R, - (bpow (emin + prec - 1) <= Rabs x)%R -> - FLXN_format beta prec x -> FTZ_format x. -Proof. -intros x Hx Fx. -apply FTZ_format_generic. -apply generic_format_FLXN in Fx. -revert Hx Fx. -apply generic_inclusion_ge. -intros e He. -unfold FTZ_exp. -rewrite Zlt_bool_false. -apply Zle_refl. -omega. -Qed. - -Theorem ulp_FTZ_0: ulp beta FTZ_exp 0 = bpow (emin+prec-1). -Proof with auto with typeclass_instances. -unfold ulp; rewrite Req_bool_true; trivial. -case (negligible_exp_spec FTZ_exp). -intros T; specialize (T (emin-1)%Z); contradict T. -apply Zle_not_lt; unfold FTZ_exp; unfold Prec_gt_0 in prec_gt_0_. -rewrite Zlt_bool_true; omega. -assert (V:(FTZ_exp (emin+prec-1) = emin+prec-1)%Z). -unfold FTZ_exp; rewrite Zlt_bool_true; omega. -intros n H2; rewrite <-V. -apply f_equal, fexp_negligible_exp_eq... -omega. -Qed. - - -Section FTZ_round. - -(** Rounding with FTZ *) -Variable rnd : R -> Z. -Context { valid_rnd : Valid_rnd rnd }. - -Definition Zrnd_FTZ x := - if Rle_bool 1 (Rabs x) then rnd x else Z0. - -Global Instance valid_rnd_FTZ : Valid_rnd Zrnd_FTZ. -Proof with auto with typeclass_instances. -split. -(* *) -intros x y Hxy. -unfold Zrnd_FTZ. -case Rle_bool_spec ; intros Hx ; - case Rle_bool_spec ; intros Hy. -4: easy. -(* 1 <= |x| *) -now apply Zrnd_le. -rewrite <- (Zrnd_Z2R rnd 0). -apply Zrnd_le... -apply Rle_trans with (Z2R (-1)). 2: now apply Z2R_le. -destruct (Rabs_ge_inv _ _ Hx) as [Hx1|Hx1]. -exact Hx1. -elim Rle_not_lt with (1 := Hx1). -apply Rle_lt_trans with (2 := Hy). -apply Rle_trans with (1 := Hxy). -apply RRle_abs. -(* |x| < 1 *) -rewrite <- (Zrnd_Z2R rnd 0). -apply Zrnd_le... -apply Rle_trans with (Z2R 1). -now apply Z2R_le. -destruct (Rabs_ge_inv _ _ Hy) as [Hy1|Hy1]. -elim Rle_not_lt with (1 := Hy1). -apply Rlt_le_trans with (2 := Hxy). -apply (Rabs_def2 _ _ Hx). -exact Hy1. -(* *) -intros n. -unfold Zrnd_FTZ. -rewrite Zrnd_Z2R... -case Rle_bool_spec. -easy. -rewrite <- Z2R_abs. -intros H. -generalize (lt_Z2R _ 1 H). -clear. -now case n ; trivial ; simpl ; intros [p|p|]. -Qed. - -Theorem round_FTZ_FLX : - forall x : R, - (bpow (emin + prec - 1) <= Rabs x)%R -> - round beta FTZ_exp Zrnd_FTZ x = round beta (FLX_exp prec) rnd x. -Proof. -intros x Hx. -unfold round, scaled_mantissa, canonic_exp. -destruct (ln_beta beta x) as (ex, He). simpl. -assert (Hx0: x <> 0%R). -intros Hx0. -apply Rle_not_lt with (1 := Hx). -rewrite Hx0, Rabs_R0. -apply bpow_gt_0. -specialize (He Hx0). -assert (He': (emin + prec <= ex)%Z). -apply (bpow_lt_bpow beta). -apply Rle_lt_trans with (1 := Hx). -apply He. -replace (FTZ_exp ex) with (FLX_exp prec ex). -unfold Zrnd_FTZ. -rewrite Rle_bool_true. -apply refl_equal. -rewrite Rabs_mult. -rewrite (Rabs_pos_eq (bpow (- FLX_exp prec ex))). -change 1%R with (bpow 0). -rewrite <- (Zplus_opp_r (FLX_exp prec ex)). -rewrite bpow_plus. -apply Rmult_le_compat_r. -apply bpow_ge_0. -apply Rle_trans with (2 := proj1 He). -apply bpow_le. -unfold FLX_exp. -generalize (prec_gt_0 prec). -clear -He' ; omega. -apply bpow_ge_0. -unfold FLX_exp, FTZ_exp. -rewrite Zlt_bool_false. -apply refl_equal. -clear -He' ; omega. -Qed. - -Theorem round_FTZ_small : - forall x : R, - (Rabs x < bpow (emin + prec - 1))%R -> - round beta FTZ_exp Zrnd_FTZ x = R0. -Proof with auto with typeclass_instances. -intros x Hx. -destruct (Req_dec x 0) as [Hx0|Hx0]. -rewrite Hx0. -apply round_0... -unfold round, scaled_mantissa, canonic_exp. -destruct (ln_beta beta x) as (ex, He). simpl. -specialize (He Hx0). -unfold Zrnd_FTZ. -rewrite Rle_bool_false. -apply F2R_0. -rewrite Rabs_mult. -rewrite (Rabs_pos_eq (bpow (- FTZ_exp ex))). -change 1%R with (bpow 0). -rewrite <- (Zplus_opp_r (FTZ_exp ex)). -rewrite bpow_plus. -apply Rmult_lt_compat_r. -apply bpow_gt_0. -apply Rlt_le_trans with (1 := Hx). -apply bpow_le. -unfold FTZ_exp. -generalize (Zlt_cases (ex - prec) emin). -case Zlt_bool. -intros _. -apply Zle_refl. -intros He'. -elim Rlt_not_le with (1 := Hx). -apply Rle_trans with (2 := proj1 He). -apply bpow_le. -omega. -apply bpow_ge_0. -Qed. - -End FTZ_round. - -End RND_FTZ. diff --git a/flocq/Core/Fcore_Raux.v b/flocq/Core/Fcore_Raux.v deleted file mode 100644 index 77235e63..00000000 --- a/flocq/Core/Fcore_Raux.v +++ /dev/null @@ -1,2524 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2010-2013 Sylvie Boldo -#
# -Copyright (C) 2010-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** * Missing definitions/lemmas *) -Require Export Reals. -Require Export ZArith. -Require Export Fcore_Zaux. - -Section Rmissing. - -(** About R *) -Theorem Rle_0_minus : - forall x y, (x <= y)%R -> (0 <= y - x)%R. -Proof. -intros. -apply Rge_le. -apply Rge_minus. -now apply Rle_ge. -Qed. - -Theorem Rabs_eq_Rabs : - forall x y : R, - Rabs x = Rabs y -> x = y \/ x = Ropp y. -Proof. -intros x y H. -unfold Rabs in H. -destruct (Rcase_abs x) as [_|_]. -assert (H' := f_equal Ropp H). -rewrite Ropp_involutive in H'. -rewrite H'. -destruct (Rcase_abs y) as [_|_]. -left. -apply Ropp_involutive. -now right. -rewrite H. -now destruct (Rcase_abs y) as [_|_] ; [right|left]. -Qed. - -Theorem Rabs_minus_le: - forall x y : R, - (0 <= y)%R -> (y <= 2*x)%R -> - (Rabs (x-y) <= x)%R. -Proof. -intros x y Hx Hy. -unfold Rabs; case (Rcase_abs (x - y)); intros H. -apply Rplus_le_reg_l with x; ring_simplify; assumption. -apply Rplus_le_reg_l with (-x)%R; ring_simplify. -auto with real. -Qed. - -Theorem Rplus_eq_reg_r : - forall r r1 r2 : R, - (r1 + r = r2 + r)%R -> (r1 = r2)%R. -Proof. -intros r r1 r2 H. -apply Rplus_eq_reg_l with r. -now rewrite 2!(Rplus_comm r). -Qed. - -Theorem Rplus_lt_reg_l : - forall r r1 r2 : R, - (r + r1 < r + r2)%R -> (r1 < r2)%R. -Proof. -intros. -solve [ apply Rplus_lt_reg_l with (1 := H) | - apply Rplus_lt_reg_r with (1 := H) ]. -Qed. - -Theorem Rplus_lt_reg_r : - forall r r1 r2 : R, - (r1 + r < r2 + r)%R -> (r1 < r2)%R. -Proof. -intros. -apply Rplus_lt_reg_l with r. -now rewrite 2!(Rplus_comm r). -Qed. - -Theorem Rplus_le_reg_r : - forall r r1 r2 : R, - (r1 + r <= r2 + r)%R -> (r1 <= r2)%R. -Proof. -intros. -apply Rplus_le_reg_l with r. -now rewrite 2!(Rplus_comm r). -Qed. - -Theorem Rmult_lt_reg_r : - forall r r1 r2 : R, (0 < r)%R -> - (r1 * r < r2 * r)%R -> (r1 < r2)%R. -Proof. -intros. -apply Rmult_lt_reg_l with r. -exact H. -now rewrite 2!(Rmult_comm r). -Qed. - -Theorem Rmult_le_reg_r : - forall r r1 r2 : R, (0 < r)%R -> - (r1 * r <= r2 * r)%R -> (r1 <= r2)%R. -Proof. -intros. -apply Rmult_le_reg_l with r. -exact H. -now rewrite 2!(Rmult_comm r). -Qed. - -Theorem Rmult_lt_compat : - forall r1 r2 r3 r4, - (0 <= r1)%R -> (0 <= r3)%R -> (r1 < r2)%R -> (r3 < r4)%R -> - (r1 * r3 < r2 * r4)%R. -Proof. -intros r1 r2 r3 r4 Pr1 Pr3 H12 H34. -apply Rle_lt_trans with (r1 * r4)%R. -- apply Rmult_le_compat_l. - + exact Pr1. - + now apply Rlt_le. -- apply Rmult_lt_compat_r. - + now apply Rle_lt_trans with r3. - + exact H12. -Qed. - -Theorem Rmult_eq_reg_r : - forall r r1 r2 : R, (r1 * r)%R = (r2 * r)%R -> - r <> 0%R -> r1 = r2. -Proof. -intros r r1 r2 H1 H2. -apply Rmult_eq_reg_l with r. -now rewrite 2!(Rmult_comm r). -exact H2. -Qed. - -Theorem Rmult_minus_distr_r : - forall r r1 r2 : R, - ((r1 - r2) * r = r1 * r - r2 * r)%R. -Proof. -intros r r1 r2. -rewrite <- 3!(Rmult_comm r). -apply Rmult_minus_distr_l. -Qed. - -Lemma Rmult_neq_reg_r: forall r1 r2 r3:R, (r2 * r1 <> r3 * r1)%R -> r2 <> r3. -intros r1 r2 r3 H1 H2. -apply H1; rewrite H2; ring. -Qed. - -Lemma Rmult_neq_compat_r: forall r1 r2 r3:R, (r1 <> 0)%R -> (r2 <> r3)%R - -> (r2 *r1 <> r3*r1)%R. -intros r1 r2 r3 H H1 H2. -now apply H1, Rmult_eq_reg_r with r1. -Qed. - - -Theorem Rmult_min_distr_r : - forall r r1 r2 : R, - (0 <= r)%R -> - (Rmin r1 r2 * r)%R = Rmin (r1 * r) (r2 * r). -Proof. -intros r r1 r2 [Hr|Hr]. -unfold Rmin. -destruct (Rle_dec r1 r2) as [H1|H1] ; - destruct (Rle_dec (r1 * r) (r2 * r)) as [H2|H2] ; - try easy. -apply (f_equal (fun x => Rmult x r)). -apply Rle_antisym. -exact H1. -apply Rmult_le_reg_r with (1 := Hr). -apply Rlt_le. -now apply Rnot_le_lt. -apply Rle_antisym. -apply Rmult_le_compat_r. -now apply Rlt_le. -apply Rlt_le. -now apply Rnot_le_lt. -exact H2. -rewrite <- Hr. -rewrite 3!Rmult_0_r. -unfold Rmin. -destruct (Rle_dec 0 0) as [H0|H0]. -easy. -elim H0. -apply Rle_refl. -Qed. - -Theorem Rmult_min_distr_l : - forall r r1 r2 : R, - (0 <= r)%R -> - (r * Rmin r1 r2)%R = Rmin (r * r1) (r * r2). -Proof. -intros r r1 r2 Hr. -rewrite 3!(Rmult_comm r). -now apply Rmult_min_distr_r. -Qed. - -Lemma Rmin_opp: forall x y, (Rmin (-x) (-y) = - Rmax x y)%R. -Proof. -intros x y. -apply Rmax_case_strong; intros H. -rewrite Rmin_left; trivial. -now apply Ropp_le_contravar. -rewrite Rmin_right; trivial. -now apply Ropp_le_contravar. -Qed. - -Lemma Rmax_opp: forall x y, (Rmax (-x) (-y) = - Rmin x y)%R. -Proof. -intros x y. -apply Rmin_case_strong; intros H. -rewrite Rmax_left; trivial. -now apply Ropp_le_contravar. -rewrite Rmax_right; trivial. -now apply Ropp_le_contravar. -Qed. - - -Theorem exp_le : - forall x y : R, - (x <= y)%R -> (exp x <= exp y)%R. -Proof. -intros x y [H|H]. -apply Rlt_le. -now apply exp_increasing. -rewrite H. -apply Rle_refl. -Qed. - -Theorem Rinv_lt : - forall x y, - (0 < x)%R -> (x < y)%R -> (/y < /x)%R. -Proof. -intros x y Hx Hxy. -apply Rinv_lt_contravar. -apply Rmult_lt_0_compat. -exact Hx. -now apply Rlt_trans with x. -exact Hxy. -Qed. - -Theorem Rinv_le : - forall x y, - (0 < x)%R -> (x <= y)%R -> (/y <= /x)%R. -Proof. -intros x y Hx Hxy. -apply Rle_Rinv. -exact Hx. -now apply Rlt_le_trans with x. -exact Hxy. -Qed. - -Theorem sqrt_ge_0 : - forall x : R, - (0 <= sqrt x)%R. -Proof. -intros x. -unfold sqrt. -destruct (Rcase_abs x) as [_|H]. -apply Rle_refl. -apply Rsqrt_positivity. -Qed. - -Lemma sqrt_neg : forall x, (x <= 0)%R -> (sqrt x = 0)%R. -Proof. -intros x Npx. -destruct (Req_dec x 0) as [Zx|Nzx]. -- (* x = 0 *) - rewrite Zx. - exact sqrt_0. -- (* x < 0 *) - unfold sqrt. - destruct Rcase_abs. - + reflexivity. - + casetype False. - now apply Nzx, Rle_antisym; [|apply Rge_le]. -Qed. - -Theorem Rabs_le : - forall x y, - (-y <= x <= y)%R -> (Rabs x <= y)%R. -Proof. -intros x y (Hyx,Hxy). -unfold Rabs. -case Rcase_abs ; intros Hx. -apply Ropp_le_cancel. -now rewrite Ropp_involutive. -exact Hxy. -Qed. - -Theorem Rabs_le_inv : - forall x y, - (Rabs x <= y)%R -> (-y <= x <= y)%R. -Proof. -intros x y Hxy. -split. -apply Rle_trans with (- Rabs x)%R. -now apply Ropp_le_contravar. -apply Ropp_le_cancel. -rewrite Ropp_involutive, <- Rabs_Ropp. -apply RRle_abs. -apply Rle_trans with (2 := Hxy). -apply RRle_abs. -Qed. - -Theorem Rabs_ge : - forall x y, - (y <= -x \/ x <= y)%R -> (x <= Rabs y)%R. -Proof. -intros x y [Hyx|Hxy]. -apply Rle_trans with (-y)%R. -apply Ropp_le_cancel. -now rewrite Ropp_involutive. -rewrite <- Rabs_Ropp. -apply RRle_abs. -apply Rle_trans with (1 := Hxy). -apply RRle_abs. -Qed. - -Theorem Rabs_ge_inv : - forall x y, - (x <= Rabs y)%R -> (y <= -x \/ x <= y)%R. -Proof. -intros x y. -unfold Rabs. -case Rcase_abs ; intros Hy Hxy. -left. -apply Ropp_le_cancel. -now rewrite Ropp_involutive. -now right. -Qed. - -Theorem Rabs_lt : - forall x y, - (-y < x < y)%R -> (Rabs x < y)%R. -Proof. -intros x y (Hyx,Hxy). -now apply Rabs_def1. -Qed. - -Theorem Rabs_lt_inv : - forall x y, - (Rabs x < y)%R -> (-y < x < y)%R. -Proof. -intros x y H. -now split ; eapply Rabs_def2. -Qed. - -Theorem Rabs_gt : - forall x y, - (y < -x \/ x < y)%R -> (x < Rabs y)%R. -Proof. -intros x y [Hyx|Hxy]. -rewrite <- Rabs_Ropp. -apply Rlt_le_trans with (Ropp y). -apply Ropp_lt_cancel. -now rewrite Ropp_involutive. -apply RRle_abs. -apply Rlt_le_trans with (1 := Hxy). -apply RRle_abs. -Qed. - -Theorem Rabs_gt_inv : - forall x y, - (x < Rabs y)%R -> (y < -x \/ x < y)%R. -Proof. -intros x y. -unfold Rabs. -case Rcase_abs ; intros Hy Hxy. -left. -apply Ropp_lt_cancel. -now rewrite Ropp_involutive. -now right. -Qed. - -End Rmissing. - -Section Z2R. - -(** Z2R function (Z -> R) *) -Fixpoint P2R (p : positive) := - match p with - | xH => 1%R - | xO xH => 2%R - | xO t => (2 * P2R t)%R - | xI xH => 3%R - | xI t => (1 + 2 * P2R t)%R - end. - -Definition Z2R n := - match n with - | Zpos p => P2R p - | Zneg p => Ropp (P2R p) - | Z0 => 0%R - end. - -Theorem P2R_INR : - forall n, P2R n = INR (nat_of_P n). -Proof. -induction n ; simpl ; try ( - rewrite IHn ; - rewrite <- (mult_INR 2) ; - rewrite <- (nat_of_P_mult_morphism 2) ; - change (2 * n)%positive with (xO n)). -(* xI *) -rewrite (Rplus_comm 1). -change (nat_of_P (xO n)) with (Pmult_nat n 2). -case n ; intros ; simpl ; try apply refl_equal. -case (Pmult_nat p 4) ; intros ; try apply refl_equal. -rewrite Rplus_0_l. -apply refl_equal. -apply Rplus_comm. -(* xO *) -case n ; intros ; apply refl_equal. -(* xH *) -apply refl_equal. -Qed. - -Theorem Z2R_IZR : - forall n, Z2R n = IZR n. -Proof. -intro. -case n ; intros ; unfold Z2R. -apply refl_equal. -rewrite <- positive_nat_Z, <- INR_IZR_INZ. -apply P2R_INR. -change (IZR (Zneg p)) with (Ropp (IZR (Zpos p))). -apply Ropp_eq_compat. -rewrite <- positive_nat_Z, <- INR_IZR_INZ. -apply P2R_INR. -Qed. - -Theorem Z2R_opp : - forall n, Z2R (-n) = (- Z2R n)%R. -Proof. -intros. -repeat rewrite Z2R_IZR. -apply Ropp_Ropp_IZR. -Qed. - -Theorem Z2R_plus : - forall m n, (Z2R (m + n) = Z2R m + Z2R n)%R. -Proof. -intros. -repeat rewrite Z2R_IZR. -apply plus_IZR. -Qed. - -Theorem minus_IZR : - forall n m : Z, - IZR (n - m) = (IZR n - IZR m)%R. -Proof. -intros. -unfold Zminus. -rewrite plus_IZR. -rewrite Ropp_Ropp_IZR. -apply refl_equal. -Qed. - -Theorem Z2R_minus : - forall m n, (Z2R (m - n) = Z2R m - Z2R n)%R. -Proof. -intros. -repeat rewrite Z2R_IZR. -apply minus_IZR. -Qed. - -Theorem Z2R_mult : - forall m n, (Z2R (m * n) = Z2R m * Z2R n)%R. -Proof. -intros. -repeat rewrite Z2R_IZR. -apply mult_IZR. -Qed. - -Theorem le_Z2R : - forall m n, (Z2R m <= Z2R n)%R -> (m <= n)%Z. -Proof. -intros m n. -repeat rewrite Z2R_IZR. -apply le_IZR. -Qed. - -Theorem Z2R_le : - forall m n, (m <= n)%Z -> (Z2R m <= Z2R n)%R. -Proof. -intros m n. -repeat rewrite Z2R_IZR. -apply IZR_le. -Qed. - -Theorem lt_Z2R : - forall m n, (Z2R m < Z2R n)%R -> (m < n)%Z. -Proof. -intros m n. -repeat rewrite Z2R_IZR. -apply lt_IZR. -Qed. - -Theorem Z2R_lt : - forall m n, (m < n)%Z -> (Z2R m < Z2R n)%R. -Proof. -intros m n. -repeat rewrite Z2R_IZR. -apply IZR_lt. -Qed. - -Theorem Z2R_le_lt : - forall m n p, (m <= n < p)%Z -> (Z2R m <= Z2R n < Z2R p)%R. -Proof. -intros m n p (H1, H2). -split. -now apply Z2R_le. -now apply Z2R_lt. -Qed. - -Theorem le_lt_Z2R : - forall m n p, (Z2R m <= Z2R n < Z2R p)%R -> (m <= n < p)%Z. -Proof. -intros m n p (H1, H2). -split. -now apply le_Z2R. -now apply lt_Z2R. -Qed. - -Theorem eq_Z2R : - forall m n, (Z2R m = Z2R n)%R -> (m = n)%Z. -Proof. -intros m n H. -apply eq_IZR. -now rewrite <- 2!Z2R_IZR. -Qed. - -Theorem neq_Z2R : - forall m n, (Z2R m <> Z2R n)%R -> (m <> n)%Z. -Proof. -intros m n H H'. -apply H. -now apply f_equal. -Qed. - -Theorem Z2R_neq : - forall m n, (m <> n)%Z -> (Z2R m <> Z2R n)%R. -Proof. -intros m n. -repeat rewrite Z2R_IZR. -apply IZR_neq. -Qed. - -Theorem Z2R_abs : - forall z, Z2R (Zabs z) = Rabs (Z2R z). -Proof. -intros. -repeat rewrite Z2R_IZR. -now rewrite Rabs_Zabs. -Qed. - -End Z2R. - -(** Decidable comparison on reals *) -Section Rcompare. - -Definition Rcompare x y := - match total_order_T x y with - | inleft (left _) => Lt - | inleft (right _) => Eq - | inright _ => Gt - end. - -Inductive Rcompare_prop (x y : R) : comparison -> Prop := - | Rcompare_Lt_ : (x < y)%R -> Rcompare_prop x y Lt - | Rcompare_Eq_ : x = y -> Rcompare_prop x y Eq - | Rcompare_Gt_ : (y < x)%R -> Rcompare_prop x y Gt. - -Theorem Rcompare_spec : - forall x y, Rcompare_prop x y (Rcompare x y). -Proof. -intros x y. -unfold Rcompare. -now destruct (total_order_T x y) as [[H|H]|H] ; constructor. -Qed. - -Global Opaque Rcompare. - -Theorem Rcompare_Lt : - forall x y, - (x < y)%R -> Rcompare x y = Lt. -Proof. -intros x y H. -case Rcompare_spec ; intro H'. -easy. -rewrite H' in H. -elim (Rlt_irrefl _ H). -elim (Rlt_irrefl x). -now apply Rlt_trans with y. -Qed. - -Theorem Rcompare_Lt_inv : - forall x y, - Rcompare x y = Lt -> (x < y)%R. -Proof. -intros x y. -now case Rcompare_spec. -Qed. - -Theorem Rcompare_not_Lt : - forall x y, - (y <= x)%R -> Rcompare x y <> Lt. -Proof. -intros x y H1 H2. -apply Rle_not_lt with (1 := H1). -now apply Rcompare_Lt_inv. -Qed. - -Theorem Rcompare_not_Lt_inv : - forall x y, - Rcompare x y <> Lt -> (y <= x)%R. -Proof. -intros x y H. -apply Rnot_lt_le. -contradict H. -now apply Rcompare_Lt. -Qed. - -Theorem Rcompare_Eq : - forall x y, - x = y -> Rcompare x y = Eq. -Proof. -intros x y H. -rewrite H. -now case Rcompare_spec ; intro H' ; try elim (Rlt_irrefl _ H'). -Qed. - -Theorem Rcompare_Eq_inv : - forall x y, - Rcompare x y = Eq -> x = y. -Proof. -intros x y. -now case Rcompare_spec. -Qed. - -Theorem Rcompare_Gt : - forall x y, - (y < x)%R -> Rcompare x y = Gt. -Proof. -intros x y H. -case Rcompare_spec ; intro H'. -elim (Rlt_irrefl x). -now apply Rlt_trans with y. -rewrite H' in H. -elim (Rlt_irrefl _ H). -easy. -Qed. - -Theorem Rcompare_Gt_inv : - forall x y, - Rcompare x y = Gt -> (y < x)%R. -Proof. -intros x y. -now case Rcompare_spec. -Qed. - -Theorem Rcompare_not_Gt : - forall x y, - (x <= y)%R -> Rcompare x y <> Gt. -Proof. -intros x y H1 H2. -apply Rle_not_lt with (1 := H1). -now apply Rcompare_Gt_inv. -Qed. - -Theorem Rcompare_not_Gt_inv : - forall x y, - Rcompare x y <> Gt -> (x <= y)%R. -Proof. -intros x y H. -apply Rnot_lt_le. -contradict H. -now apply Rcompare_Gt. -Qed. - -Theorem Rcompare_Z2R : - forall x y, Rcompare (Z2R x) (Z2R y) = Zcompare x y. -Proof. -intros x y. -case Rcompare_spec ; intros H ; apply sym_eq. -apply Zcompare_Lt. -now apply lt_Z2R. -apply Zcompare_Eq. -now apply eq_Z2R. -apply Zcompare_Gt. -now apply lt_Z2R. -Qed. - -Theorem Rcompare_sym : - forall x y, - Rcompare x y = CompOpp (Rcompare y x). -Proof. -intros x y. -destruct (Rcompare_spec y x) as [H|H|H]. -now apply Rcompare_Gt. -now apply Rcompare_Eq. -now apply Rcompare_Lt. -Qed. - -Theorem Rcompare_plus_r : - forall z x y, - Rcompare (x + z) (y + z) = Rcompare x y. -Proof. -intros z x y. -destruct (Rcompare_spec x y) as [H|H|H]. -apply Rcompare_Lt. -now apply Rplus_lt_compat_r. -apply Rcompare_Eq. -now rewrite H. -apply Rcompare_Gt. -now apply Rplus_lt_compat_r. -Qed. - -Theorem Rcompare_plus_l : - forall z x y, - Rcompare (z + x) (z + y) = Rcompare x y. -Proof. -intros z x y. -rewrite 2!(Rplus_comm z). -apply Rcompare_plus_r. -Qed. - -Theorem Rcompare_mult_r : - forall z x y, - (0 < z)%R -> - Rcompare (x * z) (y * z) = Rcompare x y. -Proof. -intros z x y Hz. -destruct (Rcompare_spec x y) as [H|H|H]. -apply Rcompare_Lt. -now apply Rmult_lt_compat_r. -apply Rcompare_Eq. -now rewrite H. -apply Rcompare_Gt. -now apply Rmult_lt_compat_r. -Qed. - -Theorem Rcompare_mult_l : - forall z x y, - (0 < z)%R -> - Rcompare (z * x) (z * y) = Rcompare x y. -Proof. -intros z x y. -rewrite 2!(Rmult_comm z). -apply Rcompare_mult_r. -Qed. - -Theorem Rcompare_middle : - forall x d u, - Rcompare (x - d) (u - x) = Rcompare x ((d + u) / 2). -Proof. -intros x d u. -rewrite <- (Rcompare_plus_r (- x / 2 - d / 2) x). -rewrite <- (Rcompare_mult_r (/2) (x - d)). -field_simplify (x + (- x / 2 - d / 2))%R. -now field_simplify ((d + u) / 2 + (- x / 2 - d / 2))%R. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). -Qed. - -Theorem Rcompare_half_l : - forall x y, Rcompare (x / 2) y = Rcompare x (2 * y). -Proof. -intros x y. -rewrite <- (Rcompare_mult_r 2%R). -unfold Rdiv. -rewrite Rmult_assoc, Rinv_l, Rmult_1_r. -now rewrite Rmult_comm. -now apply (Z2R_neq 2 0). -now apply (Z2R_lt 0 2). -Qed. - -Theorem Rcompare_half_r : - forall x y, Rcompare x (y / 2) = Rcompare (2 * x) y. -Proof. -intros x y. -rewrite <- (Rcompare_mult_r 2%R). -unfold Rdiv. -rewrite Rmult_assoc, Rinv_l, Rmult_1_r. -now rewrite Rmult_comm. -now apply (Z2R_neq 2 0). -now apply (Z2R_lt 0 2). -Qed. - -Theorem Rcompare_sqr : - forall x y, - (0 <= x)%R -> (0 <= y)%R -> - Rcompare (x * x) (y * y) = Rcompare x y. -Proof. -intros x y Hx Hy. -destruct (Rcompare_spec x y) as [H|H|H]. -apply Rcompare_Lt. -now apply Rsqr_incrst_1. -rewrite H. -now apply Rcompare_Eq. -apply Rcompare_Gt. -now apply Rsqr_incrst_1. -Qed. - -Theorem Rmin_compare : - forall x y, - Rmin x y = match Rcompare x y with Lt => x | Eq => x | Gt => y end. -Proof. -intros x y. -unfold Rmin. -destruct (Rle_dec x y) as [[Hx|Hx]|Hx]. -now rewrite Rcompare_Lt. -now rewrite Rcompare_Eq. -rewrite Rcompare_Gt. -easy. -now apply Rnot_le_lt. -Qed. - -End Rcompare. - -Section Rle_bool. - -Definition Rle_bool x y := - match Rcompare x y with - | Gt => false - | _ => true - end. - -Inductive Rle_bool_prop (x y : R) : bool -> Prop := - | Rle_bool_true_ : (x <= y)%R -> Rle_bool_prop x y true - | Rle_bool_false_ : (y < x)%R -> Rle_bool_prop x y false. - -Theorem Rle_bool_spec : - forall x y, Rle_bool_prop x y (Rle_bool x y). -Proof. -intros x y. -unfold Rle_bool. -case Rcompare_spec ; constructor. -now apply Rlt_le. -rewrite H. -apply Rle_refl. -exact H. -Qed. - -Theorem Rle_bool_true : - forall x y, - (x <= y)%R -> Rle_bool x y = true. -Proof. -intros x y Hxy. -case Rle_bool_spec ; intros H. -apply refl_equal. -elim (Rlt_irrefl x). -now apply Rle_lt_trans with y. -Qed. - -Theorem Rle_bool_false : - forall x y, - (y < x)%R -> Rle_bool x y = false. -Proof. -intros x y Hxy. -case Rle_bool_spec ; intros H. -elim (Rlt_irrefl x). -now apply Rle_lt_trans with y. -apply refl_equal. -Qed. - -End Rle_bool. - -Section Rlt_bool. - -Definition Rlt_bool x y := - match Rcompare x y with - | Lt => true - | _ => false - end. - -Inductive Rlt_bool_prop (x y : R) : bool -> Prop := - | Rlt_bool_true_ : (x < y)%R -> Rlt_bool_prop x y true - | Rlt_bool_false_ : (y <= x)%R -> Rlt_bool_prop x y false. - -Theorem Rlt_bool_spec : - forall x y, Rlt_bool_prop x y (Rlt_bool x y). -Proof. -intros x y. -unfold Rlt_bool. -case Rcompare_spec ; constructor. -exact H. -rewrite H. -apply Rle_refl. -now apply Rlt_le. -Qed. - -Theorem negb_Rlt_bool : - forall x y, - negb (Rle_bool x y) = Rlt_bool y x. -Proof. -intros x y. -unfold Rlt_bool, Rle_bool. -rewrite Rcompare_sym. -now case Rcompare. -Qed. - -Theorem negb_Rle_bool : - forall x y, - negb (Rlt_bool x y) = Rle_bool y x. -Proof. -intros x y. -unfold Rlt_bool, Rle_bool. -rewrite Rcompare_sym. -now case Rcompare. -Qed. - -Theorem Rlt_bool_true : - forall x y, - (x < y)%R -> Rlt_bool x y = true. -Proof. -intros x y Hxy. -rewrite <- negb_Rlt_bool. -now rewrite Rle_bool_false. -Qed. - -Theorem Rlt_bool_false : - forall x y, - (y <= x)%R -> Rlt_bool x y = false. -Proof. -intros x y Hxy. -rewrite <- negb_Rlt_bool. -now rewrite Rle_bool_true. -Qed. - -End Rlt_bool. - -Section Req_bool. - -Definition Req_bool x y := - match Rcompare x y with - | Eq => true - | _ => false - end. - -Inductive Req_bool_prop (x y : R) : bool -> Prop := - | Req_bool_true_ : (x = y)%R -> Req_bool_prop x y true - | Req_bool_false_ : (x <> y)%R -> Req_bool_prop x y false. - -Theorem Req_bool_spec : - forall x y, Req_bool_prop x y (Req_bool x y). -Proof. -intros x y. -unfold Req_bool. -case Rcompare_spec ; constructor. -now apply Rlt_not_eq. -easy. -now apply Rgt_not_eq. -Qed. - -Theorem Req_bool_true : - forall x y, - (x = y)%R -> Req_bool x y = true. -Proof. -intros x y Hxy. -case Req_bool_spec ; intros H. -apply refl_equal. -contradict H. -exact Hxy. -Qed. - -Theorem Req_bool_false : - forall x y, - (x <> y)%R -> Req_bool x y = false. -Proof. -intros x y Hxy. -case Req_bool_spec ; intros H. -contradict Hxy. -exact H. -apply refl_equal. -Qed. - -End Req_bool. - -Section Floor_Ceil. - -(** Zfloor and Zceil *) -Definition Zfloor (x : R) := (up x - 1)%Z. - -Theorem Zfloor_lb : - forall x : R, - (Z2R (Zfloor x) <= x)%R. -Proof. -intros x. -unfold Zfloor. -rewrite Z2R_minus. -simpl. -rewrite Z2R_IZR. -apply Rplus_le_reg_r with (1 - x)%R. -ring_simplify. -exact (proj2 (archimed x)). -Qed. - -Theorem Zfloor_ub : - forall x : R, - (x < Z2R (Zfloor x) + 1)%R. -Proof. -intros x. -unfold Zfloor. -rewrite Z2R_minus. -unfold Rminus. -rewrite Rplus_assoc. -rewrite Rplus_opp_l, Rplus_0_r. -rewrite Z2R_IZR. -exact (proj1 (archimed x)). -Qed. - -Theorem Zfloor_lub : - forall n x, - (Z2R n <= x)%R -> - (n <= Zfloor x)%Z. -Proof. -intros n x Hnx. -apply Zlt_succ_le. -apply lt_Z2R. -apply Rle_lt_trans with (1 := Hnx). -unfold Zsucc. -rewrite Z2R_plus. -apply Zfloor_ub. -Qed. - -Theorem Zfloor_imp : - forall n x, - (Z2R n <= x < Z2R (n + 1))%R -> - Zfloor x = n. -Proof. -intros n x Hnx. -apply Zle_antisym. -apply Zlt_succ_le. -apply lt_Z2R. -apply Rle_lt_trans with (2 := proj2 Hnx). -apply Zfloor_lb. -now apply Zfloor_lub. -Qed. - -Theorem Zfloor_Z2R : - forall n, - Zfloor (Z2R n) = n. -Proof. -intros n. -apply Zfloor_imp. -split. -apply Rle_refl. -apply Z2R_lt. -apply Zlt_succ. -Qed. - -Theorem Zfloor_le : - forall x y, (x <= y)%R -> - (Zfloor x <= Zfloor y)%Z. -Proof. -intros x y Hxy. -apply Zfloor_lub. -apply Rle_trans with (2 := Hxy). -apply Zfloor_lb. -Qed. - -Definition Zceil (x : R) := (- Zfloor (- x))%Z. - -Theorem Zceil_ub : - forall x : R, - (x <= Z2R (Zceil x))%R. -Proof. -intros x. -unfold Zceil. -rewrite Z2R_opp. -apply Ropp_le_cancel. -rewrite Ropp_involutive. -apply Zfloor_lb. -Qed. - -Theorem Zceil_glb : - forall n x, - (x <= Z2R n)%R -> - (Zceil x <= n)%Z. -Proof. -intros n x Hnx. -unfold Zceil. -apply Zopp_le_cancel. -rewrite Zopp_involutive. -apply Zfloor_lub. -rewrite Z2R_opp. -now apply Ropp_le_contravar. -Qed. - -Theorem Zceil_imp : - forall n x, - (Z2R (n - 1) < x <= Z2R n)%R -> - Zceil x = n. -Proof. -intros n x Hnx. -unfold Zceil. -rewrite <- (Zopp_involutive n). -apply f_equal. -apply Zfloor_imp. -split. -rewrite Z2R_opp. -now apply Ropp_le_contravar. -rewrite <- (Zopp_involutive 1). -rewrite <- Zopp_plus_distr. -rewrite Z2R_opp. -now apply Ropp_lt_contravar. -Qed. - -Theorem Zceil_Z2R : - forall n, - Zceil (Z2R n) = n. -Proof. -intros n. -unfold Zceil. -rewrite <- Z2R_opp, Zfloor_Z2R. -apply Zopp_involutive. -Qed. - -Theorem Zceil_le : - forall x y, (x <= y)%R -> - (Zceil x <= Zceil y)%Z. -Proof. -intros x y Hxy. -apply Zceil_glb. -apply Rle_trans with (1 := Hxy). -apply Zceil_ub. -Qed. - -Theorem Zceil_floor_neq : - forall x : R, - (Z2R (Zfloor x) <> x)%R -> - (Zceil x = Zfloor x + 1)%Z. -Proof. -intros x Hx. -apply Zceil_imp. -split. -ring_simplify (Zfloor x + 1 - 1)%Z. -apply Rnot_le_lt. -intros H. -apply Hx. -apply Rle_antisym. -apply Zfloor_lb. -exact H. -apply Rlt_le. -rewrite Z2R_plus. -apply Zfloor_ub. -Qed. - -Definition Ztrunc x := if Rlt_bool x 0 then Zceil x else Zfloor x. - -Theorem Ztrunc_Z2R : - forall n, - Ztrunc (Z2R n) = n. -Proof. -intros n. -unfold Ztrunc. -case Rlt_bool_spec ; intro H. -apply Zceil_Z2R. -apply Zfloor_Z2R. -Qed. - -Theorem Ztrunc_floor : - forall x, - (0 <= x)%R -> - Ztrunc x = Zfloor x. -Proof. -intros x Hx. -unfold Ztrunc. -case Rlt_bool_spec ; intro H. -elim Rlt_irrefl with x. -now apply Rlt_le_trans with R0. -apply refl_equal. -Qed. - -Theorem Ztrunc_ceil : - forall x, - (x <= 0)%R -> - Ztrunc x = Zceil x. -Proof. -intros x Hx. -unfold Ztrunc. -case Rlt_bool_spec ; intro H. -apply refl_equal. -rewrite (Rle_antisym _ _ Hx H). -change 0%R with (Z2R 0). -rewrite Zceil_Z2R. -apply Zfloor_Z2R. -Qed. - -Theorem Ztrunc_le : - forall x y, (x <= y)%R -> - (Ztrunc x <= Ztrunc y)%Z. -Proof. -intros x y Hxy. -unfold Ztrunc at 1. -case Rlt_bool_spec ; intro Hx. -unfold Ztrunc. -case Rlt_bool_spec ; intro Hy. -now apply Zceil_le. -apply Zle_trans with 0%Z. -apply Zceil_glb. -now apply Rlt_le. -now apply Zfloor_lub. -rewrite Ztrunc_floor. -now apply Zfloor_le. -now apply Rle_trans with x. -Qed. - -Theorem Ztrunc_opp : - forall x, - Ztrunc (- x) = Zopp (Ztrunc x). -Proof. -intros x. -unfold Ztrunc at 2. -case Rlt_bool_spec ; intros Hx. -rewrite Ztrunc_floor. -apply sym_eq. -apply Zopp_involutive. -rewrite <- Ropp_0. -apply Ropp_le_contravar. -now apply Rlt_le. -rewrite Ztrunc_ceil. -unfold Zceil. -now rewrite Ropp_involutive. -rewrite <- Ropp_0. -now apply Ropp_le_contravar. -Qed. - -Theorem Ztrunc_abs : - forall x, - Ztrunc (Rabs x) = Zabs (Ztrunc x). -Proof. -intros x. -rewrite Ztrunc_floor. 2: apply Rabs_pos. -unfold Ztrunc. -case Rlt_bool_spec ; intro H. -rewrite Rabs_left with (1 := H). -rewrite Zabs_non_eq. -apply sym_eq. -apply Zopp_involutive. -apply Zceil_glb. -now apply Rlt_le. -rewrite Rabs_pos_eq with (1 := H). -apply sym_eq. -apply Zabs_eq. -now apply Zfloor_lub. -Qed. - -Theorem Ztrunc_lub : - forall n x, - (Z2R n <= Rabs x)%R -> - (n <= Zabs (Ztrunc x))%Z. -Proof. -intros n x H. -rewrite <- Ztrunc_abs. -rewrite Ztrunc_floor. 2: apply Rabs_pos. -now apply Zfloor_lub. -Qed. - -Definition Zaway x := if Rlt_bool x 0 then Zfloor x else Zceil x. - -Theorem Zaway_Z2R : - forall n, - Zaway (Z2R n) = n. -Proof. -intros n. -unfold Zaway. -case Rlt_bool_spec ; intro H. -apply Zfloor_Z2R. -apply Zceil_Z2R. -Qed. - -Theorem Zaway_ceil : - forall x, - (0 <= x)%R -> - Zaway x = Zceil x. -Proof. -intros x Hx. -unfold Zaway. -case Rlt_bool_spec ; intro H. -elim Rlt_irrefl with x. -now apply Rlt_le_trans with R0. -apply refl_equal. -Qed. - -Theorem Zaway_floor : - forall x, - (x <= 0)%R -> - Zaway x = Zfloor x. -Proof. -intros x Hx. -unfold Zaway. -case Rlt_bool_spec ; intro H. -apply refl_equal. -rewrite (Rle_antisym _ _ Hx H). -change 0%R with (Z2R 0). -rewrite Zfloor_Z2R. -apply Zceil_Z2R. -Qed. - -Theorem Zaway_le : - forall x y, (x <= y)%R -> - (Zaway x <= Zaway y)%Z. -Proof. -intros x y Hxy. -unfold Zaway at 1. -case Rlt_bool_spec ; intro Hx. -unfold Zaway. -case Rlt_bool_spec ; intro Hy. -now apply Zfloor_le. -apply le_Z2R. -apply Rle_trans with 0%R. -apply Rlt_le. -apply Rle_lt_trans with (2 := Hx). -apply Zfloor_lb. -apply Rle_trans with (1 := Hy). -apply Zceil_ub. -rewrite Zaway_ceil. -now apply Zceil_le. -now apply Rle_trans with x. -Qed. - -Theorem Zaway_opp : - forall x, - Zaway (- x) = Zopp (Zaway x). -Proof. -intros x. -unfold Zaway at 2. -case Rlt_bool_spec ; intro H. -rewrite Zaway_ceil. -unfold Zceil. -now rewrite Ropp_involutive. -apply Rlt_le. -now apply Ropp_0_gt_lt_contravar. -rewrite Zaway_floor. -apply sym_eq. -apply Zopp_involutive. -rewrite <- Ropp_0. -now apply Ropp_le_contravar. -Qed. - -Theorem Zaway_abs : - forall x, - Zaway (Rabs x) = Zabs (Zaway x). -Proof. -intros x. -rewrite Zaway_ceil. 2: apply Rabs_pos. -unfold Zaway. -case Rlt_bool_spec ; intro H. -rewrite Rabs_left with (1 := H). -rewrite Zabs_non_eq. -apply (f_equal (fun v => - Zfloor v)%Z). -apply Ropp_involutive. -apply le_Z2R. -apply Rlt_le. -apply Rle_lt_trans with (2 := H). -apply Zfloor_lb. -rewrite Rabs_pos_eq with (1 := H). -apply sym_eq. -apply Zabs_eq. -apply le_Z2R. -apply Rle_trans with (1 := H). -apply Zceil_ub. -Qed. - -End Floor_Ceil. - -Section Zdiv_Rdiv. - -Theorem Zfloor_div : - forall x y, - y <> Z0 -> - Zfloor (Z2R x / Z2R y) = (x / y)%Z. -Proof. -intros x y Zy. -generalize (Z_div_mod_eq_full x y Zy). -intros Hx. -rewrite Hx at 1. -assert (Zy': Z2R y <> R0). -contradict Zy. -now apply eq_Z2R. -unfold Rdiv. -rewrite Z2R_plus, Rmult_plus_distr_r, Z2R_mult. -replace (Z2R y * Z2R (x / y) * / Z2R y)%R with (Z2R (x / y)) by now field. -apply Zfloor_imp. -rewrite Z2R_plus. -assert (0 <= Z2R (x mod y) * / Z2R y < 1)%R. -(* *) -assert (forall x' y', (0 < y')%Z -> 0 <= Z2R (x' mod y') * / Z2R y' < 1)%R. -(* . *) -clear. -intros x y Hy. -split. -apply Rmult_le_pos. -apply (Z2R_le 0). -refine (proj1 (Z_mod_lt _ _ _)). -now apply Zlt_gt. -apply Rlt_le. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0). -apply Rmult_lt_reg_r with (Z2R y). -now apply (Z2R_lt 0). -rewrite Rmult_1_l, Rmult_assoc, Rinv_l, Rmult_1_r. -apply Z2R_lt. -eapply Z_mod_lt. -now apply Zlt_gt. -apply Rgt_not_eq. -now apply (Z2R_lt 0). -(* . *) -destruct (Z_lt_le_dec y 0) as [Hy|Hy]. -rewrite <- Rmult_opp_opp. -rewrite Ropp_inv_permute with (1 := Zy'). -rewrite <- 2!Z2R_opp. -rewrite <- Zmod_opp_opp. -apply H. -clear -Hy. omega. -apply H. -clear -Zy Hy. omega. -(* *) -split. -pattern (Z2R (x / y)) at 1 ; rewrite <- Rplus_0_r. -apply Rplus_le_compat_l. -apply H. -apply Rplus_lt_compat_l. -apply H. -Qed. - -End Zdiv_Rdiv. - -Section pow. - -Variable r : radix. - -Theorem radix_pos : (0 < Z2R r)%R. -Proof. -destruct r as (v, Hr). simpl. -apply (Z2R_lt 0). -apply Zlt_le_trans with 2%Z. -easy. -now apply Zle_bool_imp_le. -Qed. - -(** Well-used function called bpow for computing the power function #β#^e *) -Definition bpow e := - match e with - | Zpos p => Z2R (Zpower_pos r p) - | Zneg p => Rinv (Z2R (Zpower_pos r p)) - | Z0 => 1%R - end. - -Theorem Z2R_Zpower_pos : - forall n m, - Z2R (Zpower_pos n m) = powerRZ (Z2R n) (Zpos m). -Proof. -intros. -rewrite Zpower_pos_nat. -simpl. -induction (nat_of_P m). -apply refl_equal. -unfold Zpower_nat. -simpl. -rewrite Z2R_mult. -apply Rmult_eq_compat_l. -exact IHn0. -Qed. - -Theorem bpow_powerRZ : - forall e, - bpow e = powerRZ (Z2R r) e. -Proof. -destruct e ; unfold bpow. -reflexivity. -now rewrite Z2R_Zpower_pos. -now rewrite Z2R_Zpower_pos. -Qed. - -Theorem bpow_ge_0 : - forall e : Z, (0 <= bpow e)%R. -Proof. -intros. -rewrite bpow_powerRZ. -apply powerRZ_le. -apply radix_pos. -Qed. - -Theorem bpow_gt_0 : - forall e : Z, (0 < bpow e)%R. -Proof. -intros. -rewrite bpow_powerRZ. -apply powerRZ_lt. -apply radix_pos. -Qed. - -Theorem bpow_plus : - forall e1 e2 : Z, (bpow (e1 + e2) = bpow e1 * bpow e2)%R. -Proof. -intros. -repeat rewrite bpow_powerRZ. -apply powerRZ_add. -apply Rgt_not_eq. -apply radix_pos. -Qed. - -Theorem bpow_1 : - bpow 1 = Z2R r. -Proof. -unfold bpow, Zpower_pos. simpl. -now rewrite Zmult_1_r. -Qed. - -Theorem bpow_plus1 : - forall e : Z, (bpow (e + 1) = Z2R r * bpow e)%R. -Proof. -intros. -rewrite <- bpow_1. -rewrite <- bpow_plus. -now rewrite Zplus_comm. -Qed. - -Theorem bpow_opp : - forall e : Z, (bpow (-e) = /bpow e)%R. -Proof. -intros [|p|p]. -apply eq_sym, Rinv_1. -now change (-Zpos p)%Z with (Zneg p). -change (-Zneg p)%Z with (Zpos p). -simpl; rewrite Rinv_involutive; trivial. -apply Rgt_not_eq. -apply (bpow_gt_0 (Zpos p)). -Qed. - -Theorem Z2R_Zpower_nat : - forall e : nat, - Z2R (Zpower_nat r e) = bpow (Z_of_nat e). -Proof. -intros [|e]. -split. -rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ. -rewrite <- Zpower_pos_nat. -now rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P. -Qed. - -Theorem Z2R_Zpower : - forall e : Z, - (0 <= e)%Z -> - Z2R (Zpower r e) = bpow e. -Proof. -intros [|e|e] H. -split. -split. -now elim H. -Qed. - -Theorem bpow_lt : - forall e1 e2 : Z, - (e1 < e2)%Z -> (bpow e1 < bpow e2)%R. -Proof. -intros e1 e2 H. -replace e2 with (e1 + (e2 - e1))%Z by ring. -rewrite <- (Rmult_1_r (bpow e1)). -rewrite bpow_plus. -apply Rmult_lt_compat_l. -apply bpow_gt_0. -assert (0 < e2 - e1)%Z by omega. -destruct (e2 - e1)%Z ; try discriminate H0. -clear. -rewrite <- Z2R_Zpower by easy. -apply (Z2R_lt 1). -now apply Zpower_gt_1. -Qed. - -Theorem lt_bpow : - forall e1 e2 : Z, - (bpow e1 < bpow e2)%R -> (e1 < e2)%Z. -Proof. -intros e1 e2 H. -apply Zgt_lt. -apply Znot_le_gt. -intros H'. -apply Rlt_not_le with (1 := H). -destruct (Zle_lt_or_eq _ _ H'). -apply Rlt_le. -now apply bpow_lt. -rewrite H0. -apply Rle_refl. -Qed. - -Theorem bpow_le : - forall e1 e2 : Z, - (e1 <= e2)%Z -> (bpow e1 <= bpow e2)%R. -Proof. -intros e1 e2 H. -apply Rnot_lt_le. -intros H'. -apply Zle_not_gt with (1 := H). -apply Zlt_gt. -now apply lt_bpow. -Qed. - -Theorem le_bpow : - forall e1 e2 : Z, - (bpow e1 <= bpow e2)%R -> (e1 <= e2)%Z. -Proof. -intros e1 e2 H. -apply Znot_gt_le. -intros H'. -apply Rle_not_lt with (1 := H). -apply bpow_lt. -now apply Zgt_lt. -Qed. - -Theorem bpow_inj : - forall e1 e2 : Z, - bpow e1 = bpow e2 -> e1 = e2. -Proof. -intros. -apply Zle_antisym. -apply le_bpow. -now apply Req_le. -apply le_bpow. -now apply Req_le. -Qed. - -Theorem bpow_exp : - forall e : Z, - bpow e = exp (Z2R e * ln (Z2R r)). -Proof. -(* positive case *) -assert (forall e, bpow (Zpos e) = exp (Z2R (Zpos e) * ln (Z2R r))). -intros e. -unfold bpow. -rewrite Zpower_pos_nat. -unfold Z2R at 2. -rewrite P2R_INR. -induction (nat_of_P e). -rewrite Rmult_0_l. -now rewrite exp_0. -rewrite Zpower_nat_S. -rewrite S_INR. -rewrite Rmult_plus_distr_r. -rewrite exp_plus. -rewrite Rmult_1_l. -rewrite exp_ln. -rewrite <- IHn. -rewrite <- Z2R_mult. -now rewrite Zmult_comm. -apply radix_pos. -(* general case *) -intros [|e|e]. -rewrite Rmult_0_l. -now rewrite exp_0. -apply H. -unfold bpow. -change (Z2R (Zpower_pos r e)) with (bpow (Zpos e)). -rewrite H. -rewrite <- exp_Ropp. -rewrite <- Ropp_mult_distr_l_reverse. -now rewrite <- Z2R_opp. -Qed. - -(** Another well-used function for having the logarithm of a real number x to the base #β# *) -Record ln_beta_prop x := { - ln_beta_val :> Z ; - _ : (x <> 0)%R -> (bpow (ln_beta_val - 1)%Z <= Rabs x < bpow ln_beta_val)%R -}. - -Definition ln_beta : - forall x : R, ln_beta_prop x. -Proof. -intros x. -set (fact := ln (Z2R r)). -(* . *) -assert (0 < fact)%R. -apply exp_lt_inv. -rewrite exp_0. -unfold fact. -rewrite exp_ln. -apply (Z2R_lt 1). -apply radix_gt_1. -apply radix_pos. -(* . *) -exists (Zfloor (ln (Rabs x) / fact) + 1)%Z. -intros Hx'. -generalize (Rabs_pos_lt _ Hx'). clear Hx'. -generalize (Rabs x). clear x. -intros x Hx. -rewrite 2!bpow_exp. -fold fact. -pattern x at 2 3 ; replace x with (exp (ln x * / fact * fact)). -split. -rewrite Z2R_minus. -apply exp_le. -apply Rmult_le_compat_r. -now apply Rlt_le. -unfold Rminus. -rewrite Z2R_plus. -rewrite Rplus_assoc. -rewrite Rplus_opp_r, Rplus_0_r. -apply Zfloor_lb. -apply exp_increasing. -apply Rmult_lt_compat_r. -exact H. -rewrite Z2R_plus. -apply Zfloor_ub. -rewrite Rmult_assoc. -rewrite Rinv_l. -rewrite Rmult_1_r. -now apply exp_ln. -now apply Rgt_not_eq. -Qed. - -Theorem bpow_lt_bpow : - forall e1 e2, - (bpow (e1 - 1) < bpow e2)%R -> - (e1 <= e2)%Z. -Proof. -intros e1 e2 He. -rewrite (Zsucc_pred e1). -apply Zlt_le_succ. -now apply lt_bpow. -Qed. - -Theorem bpow_unique : - forall x e1 e2, - (bpow (e1 - 1) <= x < bpow e1)%R -> - (bpow (e2 - 1) <= x < bpow e2)%R -> - e1 = e2. -Proof. -intros x e1 e2 (H1a,H1b) (H2a,H2b). -apply Zle_antisym ; - apply bpow_lt_bpow ; - apply Rle_lt_trans with x ; - assumption. -Qed. - -Theorem ln_beta_unique : - forall (x : R) (e : Z), - (bpow (e - 1) <= Rabs x < bpow e)%R -> - ln_beta x = e :> Z. -Proof. -intros x e1 He. -destruct (Req_dec x 0) as [Hx|Hx]. -elim Rle_not_lt with (1 := proj1 He). -rewrite Hx, Rabs_R0. -apply bpow_gt_0. -destruct (ln_beta x) as (e2, Hx2). -simpl. -apply bpow_unique with (2 := He). -now apply Hx2. -Qed. - -Theorem ln_beta_opp : - forall x, - ln_beta (-x) = ln_beta x :> Z. -Proof. -intros x. -destruct (Req_dec x 0) as [Hx|Hx]. -now rewrite Hx, Ropp_0. -destruct (ln_beta x) as (e, He). -simpl. -specialize (He Hx). -apply ln_beta_unique. -now rewrite Rabs_Ropp. -Qed. - -Theorem ln_beta_abs : - forall x, - ln_beta (Rabs x) = ln_beta x :> Z. -Proof. -intros x. -unfold Rabs. -case Rcase_abs ; intros _. -apply ln_beta_opp. -apply refl_equal. -Qed. - -Theorem ln_beta_unique_pos : - forall (x : R) (e : Z), - (bpow (e - 1) <= x < bpow e)%R -> - ln_beta x = e :> Z. -Proof. -intros x e1 He1. -rewrite <- ln_beta_abs. -apply ln_beta_unique. -rewrite 2!Rabs_pos_eq. -exact He1. -apply Rle_trans with (2 := proj1 He1). -apply bpow_ge_0. -apply Rabs_pos. -Qed. - -Theorem ln_beta_le_abs : - forall x y, - (x <> 0)%R -> (Rabs x <= Rabs y)%R -> - (ln_beta x <= ln_beta y)%Z. -Proof. -intros x y H0x Hxy. -destruct (ln_beta x) as (ex, Hx). -destruct (ln_beta y) as (ey, Hy). -simpl. -apply bpow_lt_bpow. -specialize (Hx H0x). -apply Rle_lt_trans with (1 := proj1 Hx). -apply Rle_lt_trans with (1 := Hxy). -apply Hy. -intros Hy'. -apply Rlt_not_le with (1 := Rabs_pos_lt _ H0x). -apply Rle_trans with (1 := Hxy). -rewrite Hy', Rabs_R0. -apply Rle_refl. -Qed. - -Theorem ln_beta_le : - forall x y, - (0 < x)%R -> (x <= y)%R -> - (ln_beta x <= ln_beta y)%Z. -Proof. -intros x y H0x Hxy. -apply ln_beta_le_abs. -now apply Rgt_not_eq. -rewrite 2!Rabs_pos_eq. -exact Hxy. -apply Rle_trans with (2 := Hxy). -now apply Rlt_le. -now apply Rlt_le. -Qed. - -Lemma ln_beta_lt_pos : - forall x y, - (0 < y)%R -> - (ln_beta x < ln_beta y)%Z -> (x < y)%R. -Proof. -intros x y Py. -case (Rle_or_lt x 0); intros Px. -intros H. -now apply Rle_lt_trans with 0%R. -destruct (ln_beta x) as (ex, Hex). -destruct (ln_beta y) as (ey, Hey). -simpl. -intro H. -destruct Hex as (_,Hex); [now apply Rgt_not_eq|]. -destruct Hey as (Hey,_); [now apply Rgt_not_eq|]. -rewrite Rabs_right in Hex; [|now apply Rle_ge; apply Rlt_le]. -rewrite Rabs_right in Hey; [|now apply Rle_ge; apply Rlt_le]. -apply (Rlt_le_trans _ _ _ Hex). -apply Rle_trans with (bpow (ey - 1)); [|exact Hey]. -now apply bpow_le; omega. -Qed. - -Theorem ln_beta_bpow : - forall e, (ln_beta (bpow e) = e + 1 :> Z)%Z. -Proof. -intros e. -apply ln_beta_unique. -rewrite Rabs_right. -replace (e + 1 - 1)%Z with e by ring. -split. -apply Rle_refl. -apply bpow_lt. -apply Zlt_succ. -apply Rle_ge. -apply bpow_ge_0. -Qed. - -Theorem ln_beta_mult_bpow : - forall x e, x <> 0%R -> - (ln_beta (x * bpow e) = ln_beta x + e :>Z)%Z. -Proof. -intros x e Zx. -destruct (ln_beta x) as (ex, Ex) ; simpl. -specialize (Ex Zx). -apply ln_beta_unique. -rewrite Rabs_mult. -rewrite (Rabs_pos_eq (bpow e)) by apply bpow_ge_0. -split. -replace (ex + e - 1)%Z with (ex - 1 + e)%Z by ring. -rewrite bpow_plus. -apply Rmult_le_compat_r. -apply bpow_ge_0. -apply Ex. -rewrite bpow_plus. -apply Rmult_lt_compat_r. -apply bpow_gt_0. -apply Ex. -Qed. - -Theorem ln_beta_le_bpow : - forall x e, - x <> 0%R -> - (Rabs x < bpow e)%R -> - (ln_beta x <= e)%Z. -Proof. -intros x e Zx Hx. -destruct (ln_beta x) as (ex, Ex) ; simpl. -specialize (Ex Zx). -apply bpow_lt_bpow. -now apply Rle_lt_trans with (Rabs x). -Qed. - -Theorem ln_beta_gt_bpow : - forall x e, - (bpow e <= Rabs x)%R -> - (e < ln_beta x)%Z. -Proof. -intros x e Hx. -destruct (ln_beta x) as (ex, Ex) ; simpl. -apply lt_bpow. -apply Rle_lt_trans with (1 := Hx). -apply Ex. -intros Zx. -apply Rle_not_lt with (1 := Hx). -rewrite Zx, Rabs_R0. -apply bpow_gt_0. -Qed. - -Theorem ln_beta_ge_bpow : - forall x e, - (bpow (e - 1) <= Rabs x)%R -> - (e <= ln_beta x)%Z. -Proof. -intros x e H. -destruct (Rlt_or_le (Rabs x) (bpow e)) as [Hxe|Hxe]. -- (* Rabs x w bpow e *) - assert (ln_beta x = e :> Z) as Hln. - now apply ln_beta_unique; split. - rewrite Hln. - now apply Z.le_refl. -- (* bpow e <= Rabs x *) - apply Zlt_le_weak. - now apply ln_beta_gt_bpow. -Qed. - -Theorem bpow_ln_beta_gt : - forall x, - (Rabs x < bpow (ln_beta x))%R. -Proof. -intros x. -destruct (Req_dec x 0) as [Zx|Zx]. -rewrite Zx, Rabs_R0. -apply bpow_gt_0. -destruct (ln_beta x) as (ex, Ex) ; simpl. -now apply Ex. -Qed. - -Theorem bpow_ln_beta_le : - forall x, (x <> 0)%R -> - (bpow (ln_beta x-1) <= Rabs x)%R. -Proof. -intros x Hx. -destruct (ln_beta x) as (ex, Ex) ; simpl. -now apply Ex. -Qed. - - -Theorem ln_beta_le_Zpower : - forall m e, - m <> Z0 -> - (Zabs m < Zpower r e)%Z-> - (ln_beta (Z2R m) <= e)%Z. -Proof. -intros m e Zm Hm. -apply ln_beta_le_bpow. -exact (Z2R_neq m 0 Zm). -destruct (Zle_or_lt 0 e). -rewrite <- Z2R_abs, <- Z2R_Zpower with (1 := H). -now apply Z2R_lt. -elim Zm. -cut (Zabs m < 0)%Z. -now case m. -clear -Hm H. -now destruct e. -Qed. - -Theorem ln_beta_gt_Zpower : - forall m e, - m <> Z0 -> - (Zpower r e <= Zabs m)%Z -> - (e < ln_beta (Z2R m))%Z. -Proof. -intros m e Zm Hm. -apply ln_beta_gt_bpow. -rewrite <- Z2R_abs. -destruct (Zle_or_lt 0 e). -rewrite <- Z2R_Zpower with (1 := H). -now apply Z2R_le. -apply Rle_trans with (bpow 0). -apply bpow_le. -now apply Zlt_le_weak. -apply (Z2R_le 1). -clear -Zm. -zify ; omega. -Qed. - -Lemma ln_beta_mult : - forall x y, - (x <> 0)%R -> (y <> 0)%R -> - (ln_beta x + ln_beta y - 1 <= ln_beta (x * y) <= ln_beta x + ln_beta y)%Z. -Proof. -intros x y Hx Hy. -destruct (ln_beta x) as (ex, Hx2). -destruct (ln_beta y) as (ey, Hy2). -simpl. -destruct (Hx2 Hx) as (Hx21,Hx22); clear Hx2. -destruct (Hy2 Hy) as (Hy21,Hy22); clear Hy2. -assert (Hxy : (bpow (ex + ey - 1 - 1) <= Rabs (x * y))%R). -{ replace (ex + ey -1 -1)%Z with (ex - 1 + (ey - 1))%Z; [|ring]. - rewrite bpow_plus. - rewrite Rabs_mult. - now apply Rmult_le_compat; try apply bpow_ge_0. } -assert (Hxy2 : (Rabs (x * y) < bpow (ex + ey))%R). -{ rewrite Rabs_mult. - rewrite bpow_plus. - apply Rmult_le_0_lt_compat; try assumption. - now apply Rle_trans with (bpow (ex - 1)); try apply bpow_ge_0. - now apply Rle_trans with (bpow (ey - 1)); try apply bpow_ge_0. } -split. -- now apply ln_beta_ge_bpow. -- apply ln_beta_le_bpow. - + now apply Rmult_integral_contrapositive_currified. - + assumption. -Qed. - -Lemma ln_beta_plus : - forall x y, - (0 < y)%R -> (y <= x)%R -> - (ln_beta x <= ln_beta (x + y) <= ln_beta x + 1)%Z. -Proof. -assert (Hr : (2 <= r)%Z). -{ destruct r as (beta_val,beta_prop). - now apply Zle_bool_imp_le. } -intros x y Hy Hxy. -assert (Hx : (0 < x)%R) by apply (Rlt_le_trans _ _ _ Hy Hxy). -destruct (ln_beta x) as (ex,Hex); simpl. -destruct Hex as (Hex0,Hex1); [now apply Rgt_not_eq|]. -assert (Haxy : (Rabs (x + y) < bpow (ex + 1))%R). -{ rewrite bpow_plus1. - apply Rlt_le_trans with (2 * bpow ex)%R. - - rewrite Rabs_pos_eq. - apply Rle_lt_trans with (2 * Rabs x)%R. - + rewrite Rabs_pos_eq. - replace (2 * x)%R with (x + x)%R by ring. - now apply Rplus_le_compat_l. - now apply Rlt_le. - + apply Rmult_lt_compat_l with (2 := Hex1). - exact Rlt_0_2. - + rewrite <- (Rplus_0_l 0). - now apply Rlt_le, Rplus_lt_compat. - - apply Rmult_le_compat_r. - now apply bpow_ge_0. - now apply (Z2R_le 2). } -assert (Haxy2 : (bpow (ex - 1) <= Rabs (x + y))%R). -{ apply (Rle_trans _ _ _ Hex0). - rewrite Rabs_right; [|now apply Rgt_ge]. - apply Rabs_ge; right. - rewrite <- (Rplus_0_r x) at 1. - apply Rplus_le_compat_l. - now apply Rlt_le. } -split. -- now apply ln_beta_ge_bpow. -- apply ln_beta_le_bpow. - + now apply tech_Rplus; [apply Rlt_le|]. - + exact Haxy. -Qed. - -Lemma ln_beta_minus : - forall x y, - (0 < y)%R -> (y < x)%R -> - (ln_beta (x - y) <= ln_beta x)%Z. -Proof. -intros x y Py Hxy. -assert (Px : (0 < x)%R) by apply (Rlt_trans _ _ _ Py Hxy). -apply ln_beta_le. -- now apply Rlt_Rminus. -- rewrite <- (Rplus_0_r x) at 2. - apply Rplus_le_compat_l. - rewrite <- Ropp_0. - now apply Ropp_le_contravar; apply Rlt_le. -Qed. - -Lemma ln_beta_minus_lb : - forall x y, - (0 < x)%R -> (0 < y)%R -> - (ln_beta y <= ln_beta x - 2)%Z -> - (ln_beta x - 1 <= ln_beta (x - y))%Z. -Proof. -assert (Hbeta : (2 <= r)%Z). -{ destruct r as (beta_val,beta_prop). - now apply Zle_bool_imp_le. } -intros x y Px Py Hln. -assert (Oxy : (y < x)%R); [apply ln_beta_lt_pos;[assumption|omega]|]. -destruct (ln_beta x) as (ex,Hex). -destruct (ln_beta y) as (ey,Hey). -simpl in Hln |- *. -destruct Hex as (Hex,_); [now apply Rgt_not_eq|]. -destruct Hey as (_,Hey); [now apply Rgt_not_eq|]. -assert (Hbx : (bpow (ex - 2) + bpow (ex - 2) <= x)%R). -{ ring_simplify. - apply Rle_trans with (bpow (ex - 1)). - - replace (ex - 1)%Z with (ex - 2 + 1)%Z by ring. - rewrite bpow_plus1. - apply Rmult_le_compat_r; [now apply bpow_ge_0|]. - now change 2%R with (Z2R 2); apply Z2R_le. - - now rewrite Rabs_right in Hex; [|apply Rle_ge; apply Rlt_le]. } -assert (Hby : (y < bpow (ex - 2))%R). -{ apply Rlt_le_trans with (bpow ey). - now rewrite Rabs_right in Hey; [|apply Rle_ge; apply Rlt_le]. - now apply bpow_le. } -assert (Hbxy : (bpow (ex - 2) <= x - y)%R). -{ apply Ropp_lt_contravar in Hby. - apply Rlt_le in Hby. - replace (bpow (ex - 2))%R with (bpow (ex - 2) + bpow (ex - 2) - - bpow (ex - 2))%R by ring. - now apply Rplus_le_compat. } -apply ln_beta_ge_bpow. -replace (ex - 1 - 1)%Z with (ex - 2)%Z by ring. -now apply Rabs_ge; right. -Qed. - -Lemma ln_beta_div : - forall x y : R, - (0 < x)%R -> (0 < y)%R -> - (ln_beta x - ln_beta y <= ln_beta (x / y) <= ln_beta x - ln_beta y + 1)%Z. -Proof. -intros x y Px Py. -destruct (ln_beta x) as (ex,Hex). -destruct (ln_beta y) as (ey,Hey). -simpl. -unfold Rdiv. -rewrite Rabs_right in Hex; [|now apply Rle_ge; apply Rlt_le]. -rewrite Rabs_right in Hey; [|now apply Rle_ge; apply Rlt_le]. -assert (Heiy : (bpow (- ey) < / y <= bpow (- ey + 1))%R). -{ split. - - rewrite bpow_opp. - apply Rinv_lt_contravar. - + apply Rmult_lt_0_compat; [exact Py|]. - now apply bpow_gt_0. - + apply Hey. - now apply Rgt_not_eq. - - replace (_ + _)%Z with (- (ey - 1))%Z by ring. - rewrite bpow_opp. - apply Rinv_le; [now apply bpow_gt_0|]. - apply Hey. - now apply Rgt_not_eq. } -split. -- apply ln_beta_ge_bpow. - apply Rabs_ge; right. - replace (_ - _)%Z with (ex - 1 - ey)%Z by ring. - unfold Zminus at 1; rewrite bpow_plus. - apply Rmult_le_compat. - + now apply bpow_ge_0. - + now apply bpow_ge_0. - + apply Hex. - now apply Rgt_not_eq. - + apply Rlt_le; apply Heiy. -- assert (Pxy : (0 < x * / y)%R). - { apply Rmult_lt_0_compat; [exact Px|]. - now apply Rinv_0_lt_compat. } - apply ln_beta_le_bpow. - + now apply Rgt_not_eq. - + rewrite Rabs_right; [|now apply Rle_ge; apply Rlt_le]. - replace (_ + 1)%Z with (ex + (- ey + 1))%Z by ring. - rewrite bpow_plus. - apply Rlt_le_trans with (bpow ex * / y)%R. - * apply Rmult_lt_compat_r; [now apply Rinv_0_lt_compat|]. - apply Hex. - now apply Rgt_not_eq. - * apply Rmult_le_compat_l; [now apply bpow_ge_0|]. - apply Heiy. -Qed. - -Lemma ln_beta_sqrt : - forall x, - (0 < x)%R -> - (2 * ln_beta (sqrt x) - 1 <= ln_beta x <= 2 * ln_beta (sqrt x))%Z. -Proof. -intros x Px. -assert (H : (bpow (2 * ln_beta (sqrt x) - 1 - 1) <= Rabs x - < bpow (2 * ln_beta (sqrt x)))%R). -{ split. - - apply Rge_le; rewrite <- (sqrt_def x) at 1; - [|now apply Rlt_le]; apply Rle_ge. - rewrite Rabs_mult. - replace (_ - _)%Z with (ln_beta (sqrt x) - 1 - + (ln_beta (sqrt x) - 1))%Z by ring. - rewrite bpow_plus. - assert (H : (bpow (ln_beta (sqrt x) - 1) <= Rabs (sqrt x))%R). - { destruct (ln_beta (sqrt x)) as (esx,Hesx); simpl. - apply Hesx. - apply Rgt_not_eq; apply Rlt_gt. - now apply sqrt_lt_R0. } - now apply Rmult_le_compat; [now apply bpow_ge_0|now apply bpow_ge_0| |]. - - rewrite <- (sqrt_def x) at 1; [|now apply Rlt_le]. - rewrite Rabs_mult. - change 2%Z with (1 + 1)%Z; rewrite Zmult_plus_distr_l; - rewrite Zmult_1_l. - rewrite bpow_plus. - assert (H : (Rabs (sqrt x) < bpow (ln_beta (sqrt x)))%R). - { destruct (ln_beta (sqrt x)) as (esx,Hesx); simpl. - apply Hesx. - apply Rgt_not_eq; apply Rlt_gt. - now apply sqrt_lt_R0. } - now apply Rmult_lt_compat; [now apply Rabs_pos|now apply Rabs_pos| |]. } -split. -- now apply ln_beta_ge_bpow. -- now apply ln_beta_le_bpow; [now apply Rgt_not_eq|]. -Qed. - -End pow. - -Section Bool. - -Theorem eqb_sym : - forall x y, Bool.eqb x y = Bool.eqb y x. -Proof. -now intros [|] [|]. -Qed. - -Theorem eqb_false : - forall x y, x = negb y -> Bool.eqb x y = false. -Proof. -now intros [|] [|]. -Qed. - -Theorem eqb_true : - forall x y, x = y -> Bool.eqb x y = true. -Proof. -now intros [|] [|]. -Qed. - -End Bool. - -Section cond_Ropp. - -Definition cond_Ropp (b : bool) m := if b then Ropp m else m. - -Theorem Z2R_cond_Zopp : - forall b m, - Z2R (cond_Zopp b m) = cond_Ropp b (Z2R m). -Proof. -intros [|] m. -apply Z2R_opp. -apply refl_equal. -Qed. - -Theorem abs_cond_Ropp : - forall b m, - Rabs (cond_Ropp b m) = Rabs m. -Proof. -intros [|] m. -apply Rabs_Ropp. -apply refl_equal. -Qed. - -Theorem cond_Ropp_Rlt_bool : - forall m, - cond_Ropp (Rlt_bool m 0) m = Rabs m. -Proof. -intros m. -apply sym_eq. -case Rlt_bool_spec ; intros Hm. -now apply Rabs_left. -now apply Rabs_pos_eq. -Qed. - -Theorem cond_Ropp_involutive : - forall b x, - cond_Ropp b (cond_Ropp b x) = x. -Proof. -intros [|] x. -apply Ropp_involutive. -apply refl_equal. -Qed. - -Theorem cond_Ropp_even_function : - forall {A : Type} (f : R -> A), - (forall x, f (Ropp x) = f x) -> - forall b x, f (cond_Ropp b x) = f x. -Proof. -now intros A f Hf [|] x ; simpl. -Qed. - -Theorem cond_Ropp_odd_function : - forall (f : R -> R), - (forall x, f (Ropp x) = Ropp (f x)) -> - forall b x, f (cond_Ropp b x) = cond_Ropp b (f x). -Proof. -now intros f Hf [|] x ; simpl. -Qed. - -Theorem cond_Ropp_inj : - forall b x y, - cond_Ropp b x = cond_Ropp b y -> x = y. -Proof. -intros b x y H. -rewrite <- (cond_Ropp_involutive b x), H. -apply cond_Ropp_involutive. -Qed. - -Theorem cond_Ropp_mult_l : - forall b x y, - cond_Ropp b (x * y) = (cond_Ropp b x * y)%R. -Proof. -intros [|] x y. -apply sym_eq. -apply Ropp_mult_distr_l_reverse. -apply refl_equal. -Qed. - -Theorem cond_Ropp_mult_r : - forall b x y, - cond_Ropp b (x * y) = (x * cond_Ropp b y)%R. -Proof. -intros [|] x y. -apply sym_eq. -apply Ropp_mult_distr_r_reverse. -apply refl_equal. -Qed. - -Theorem cond_Ropp_plus : - forall b x y, - cond_Ropp b (x + y) = (cond_Ropp b x + cond_Ropp b y)%R. -Proof. -intros [|] x y. -apply Ropp_plus_distr. -apply refl_equal. -Qed. - -End cond_Ropp. - - -(** LPO taken from Coquelicot *) - -Theorem LPO_min : - forall P : nat -> Prop, (forall n, P n \/ ~ P n) -> - {n : nat | P n /\ forall i, (i < n)%nat -> ~ P i} + {forall n, ~ P n}. -Proof. -assert (Hi: forall n, (0 < INR n + 1)%R). - intros N. - rewrite <- S_INR. - apply lt_0_INR. - apply lt_0_Sn. -intros P HP. -set (E y := exists n, (P n /\ y = / (INR n + 1))%R \/ (~ P n /\ y = 0)%R). -assert (HE: forall n, P n -> E (/ (INR n + 1))%R). - intros n Pn. - exists n. - left. - now split. -assert (BE: is_upper_bound E 1). - intros x [y [[_ ->]|[_ ->]]]. - rewrite <- Rinv_1 at 2. - apply Rinv_le. - exact Rlt_0_1. - rewrite <- S_INR. - apply (le_INR 1), le_n_S, le_0_n. - exact Rle_0_1. -destruct (completeness E) as [l [ub lub]]. - now exists 1%R. - destruct (HP O) as [H0|H0]. - exists 1%R. - exists O. - left. - apply (conj H0). - rewrite Rplus_0_l. - apply sym_eq, Rinv_1. - exists 0%R. - exists O. - right. - now split. -destruct (Rle_lt_dec l 0) as [Hl|Hl]. - right. - intros n Pn. - apply Rle_not_lt with (1 := Hl). - apply Rlt_le_trans with (/ (INR n + 1))%R. - now apply Rinv_0_lt_compat. - apply ub. - now apply HE. -left. -set (N := Zabs_nat (up (/l) - 2)). -exists N. -assert (HN: (INR N + 1 = IZR (up (/ l)) - 1)%R). - unfold N. - rewrite INR_IZR_INZ. - rewrite inj_Zabs_nat. - replace (IZR (up (/ l)) - 1)%R with (IZR (up (/ l) - 2) + 1)%R. - apply (f_equal (fun v => IZR v + 1)%R). - apply Zabs_eq. - apply Zle_minus_le_0. - apply (Zlt_le_succ 1). - apply lt_IZR. - apply Rle_lt_trans with (/l)%R. - apply Rmult_le_reg_r with (1 := Hl). - rewrite Rmult_1_l, Rinv_l by now apply Rgt_not_eq. - apply lub. - exact BE. - apply archimed. - rewrite minus_IZR. - simpl. - ring. -assert (H: forall i, (i < N)%nat -> ~ P i). - intros i HiN Pi. - unfold is_upper_bound in ub. - refine (Rle_not_lt _ _ (ub (/ (INR i + 1))%R _) _). - now apply HE. - rewrite <- (Rinv_involutive l) by now apply Rgt_not_eq. - apply Rinv_1_lt_contravar. - rewrite <- S_INR. - apply (le_INR 1). - apply le_n_S. - apply le_0_n. - apply Rlt_le_trans with (INR N + 1)%R. - apply Rplus_lt_compat_r. - now apply lt_INR. - rewrite HN. - apply Rplus_le_reg_r with (-/l + 1)%R. - ring_simplify. - apply archimed. -destruct (HP N) as [PN|PN]. - now split. -elimtype False. -refine (Rle_not_lt _ _ (lub (/ (INR (S N) + 1))%R _) _). - intros x [y [[Py ->]|[_ ->]]]. - destruct (eq_nat_dec y N) as [HyN|HyN]. - elim PN. - now rewrite <- HyN. - apply Rinv_le. - apply Hi. - apply Rplus_le_compat_r. - apply Rnot_lt_le. - intros Hy. - refine (H _ _ Py). - apply INR_lt in Hy. - clear -Hy HyN. - omega. - now apply Rlt_le, Rinv_0_lt_compat. -rewrite S_INR, HN. -ring_simplify (IZR (up (/ l)) - 1 + 1)%R. -rewrite <- (Rinv_involutive l) at 2 by now apply Rgt_not_eq. -apply Rinv_1_lt_contravar. -rewrite <- Rinv_1. -apply Rinv_le. -exact Hl. -now apply lub. -apply archimed. -Qed. - -Theorem LPO : - forall P : nat -> Prop, (forall n, P n \/ ~ P n) -> - {n : nat | P n} + {forall n, ~ P n}. -Proof. -intros P HP. -destruct (LPO_min P HP) as [[n [Pn _]]|Pn]. -left. -now exists n. -now right. -Qed. - - -Lemma LPO_Z : forall P : Z -> Prop, (forall n, P n \/ ~P n) -> - {n : Z| P n} + {forall n, ~ P n}. -Proof. -intros P H. -destruct (LPO (fun n => P (Z.of_nat n))) as [J|J]. -intros n; apply H. -destruct J as (n, Hn). -left; now exists (Z.of_nat n). -destruct (LPO (fun n => P (-Z.of_nat n)%Z)) as [K|K]. -intros n; apply H. -destruct K as (n, Hn). -left; now exists (-Z.of_nat n)%Z. -right; intros n; case (Zle_or_lt 0 n); intros M. -rewrite <- (Zabs_eq n); trivial. -rewrite <- Zabs2Nat.id_abs. -apply J. -rewrite <- (Zopp_involutive n). -rewrite <- (Z.abs_neq n). -rewrite <- Zabs2Nat.id_abs. -apply K. -omega. -Qed. - - - -(** A little tactic to simplify terms of the form [bpow a * bpow b]. *) -Ltac bpow_simplify := - (* bpow ex * bpow ey ~~> bpow (ex + ey) *) - repeat - match goal with - | |- context [(bpow _ _ * bpow _ _)] => - rewrite <- bpow_plus - | |- context [(?X1 * bpow _ _ * bpow _ _)] => - rewrite (Rmult_assoc X1); rewrite <- bpow_plus - | |- context [(?X1 * (?X2 * bpow _ _) * bpow _ _)] => - rewrite <- (Rmult_assoc X1 X2); rewrite (Rmult_assoc (X1 * X2)); - rewrite <- bpow_plus - end; - (* ring_simplify arguments of bpow *) - repeat - match goal with - | |- context [(bpow _ ?X)] => - progress ring_simplify X - end; - (* bpow 0 ~~> 1 *) - change (bpow _ 0) with 1; - repeat - match goal with - | |- context [(_ * 1)] => - rewrite Rmult_1_r - end. diff --git a/flocq/Core/Fcore_Zaux.v b/flocq/Core/Fcore_Zaux.v deleted file mode 100644 index f6731b4c..00000000 --- a/flocq/Core/Fcore_Zaux.v +++ /dev/null @@ -1,991 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2011-2013 Sylvie Boldo -#
# -Copyright (C) 2011-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -Require Import ZArith. -Require Import Zquot. - -Section Zmissing. - -(** About Z *) -Theorem Zopp_le_cancel : - forall x y : Z, - (-y <= -x)%Z -> Zle x y. -Proof. -intros x y Hxy. -apply Zplus_le_reg_r with (-x - y)%Z. -now ring_simplify. -Qed. - -Theorem Zgt_not_eq : - forall x y : Z, - (y < x)%Z -> (x <> y)%Z. -Proof. -intros x y H Hn. -apply Zlt_irrefl with x. -now rewrite Hn at 1. -Qed. - -End Zmissing. - -Section Proof_Irrelevance. - -Scheme eq_dep_elim := Induction for eq Sort Type. - -Definition eqbool_dep P (h1 : P true) b := - match b return P b -> Prop with - | true => fun (h2 : P true) => h1 = h2 - | false => fun (h2 : P false) => False - end. - -Lemma eqbool_irrelevance : forall (b : bool) (h1 h2 : b = true), h1 = h2. -Proof. -assert (forall (h : true = true), refl_equal true = h). -apply (eq_dep_elim bool true (eqbool_dep _ _) (refl_equal _)). -intros b. -case b. -intros h1 h2. -now rewrite <- (H h1). -intros h. -discriminate h. -Qed. - -End Proof_Irrelevance. - -Section Even_Odd. - -(** Zeven, used for rounding to nearest, ties to even *) -Definition Zeven (n : Z) := - match n with - | Zpos (xO _) => true - | Zneg (xO _) => true - | Z0 => true - | _ => false - end. - -Theorem Zeven_mult : - forall x y, Zeven (x * y) = orb (Zeven x) (Zeven y). -Proof. -now intros [|[xp|xp|]|[xp|xp|]] [|[yp|yp|]|[yp|yp|]]. -Qed. - -Theorem Zeven_opp : - forall x, Zeven (- x) = Zeven x. -Proof. -now intros [|[n|n|]|[n|n|]]. -Qed. - -Theorem Zeven_ex : - forall x, exists p, x = (2 * p + if Zeven x then 0 else 1)%Z. -Proof. -intros [|[n|n|]|[n|n|]]. -now exists Z0. -now exists (Zpos n). -now exists (Zpos n). -now exists Z0. -exists (Zneg n - 1)%Z. -change (2 * Zneg n - 1 = 2 * (Zneg n - 1) + 1)%Z. -ring. -now exists (Zneg n). -now exists (-1)%Z. -Qed. - -Theorem Zeven_2xp1 : - forall n, Zeven (2 * n + 1) = false. -Proof. -intros n. -destruct (Zeven_ex (2 * n + 1)) as (p, Hp). -revert Hp. -case (Zeven (2 * n + 1)) ; try easy. -intros H. -apply False_ind. -omega. -Qed. - -Theorem Zeven_plus : - forall x y, Zeven (x + y) = Bool.eqb (Zeven x) (Zeven y). -Proof. -intros x y. -destruct (Zeven_ex x) as (px, Hx). -rewrite Hx at 1. -destruct (Zeven_ex y) as (py, Hy). -rewrite Hy at 1. -replace (2 * px + (if Zeven x then 0 else 1) + (2 * py + (if Zeven y then 0 else 1)))%Z - with (2 * (px + py) + ((if Zeven x then 0 else 1) + (if Zeven y then 0 else 1)))%Z by ring. -case (Zeven x) ; case (Zeven y). -rewrite Zplus_0_r. -now rewrite Zeven_mult. -apply Zeven_2xp1. -apply Zeven_2xp1. -replace (2 * (px + py) + (1 + 1))%Z with (2 * (px + py + 1))%Z by ring. -now rewrite Zeven_mult. -Qed. - -End Even_Odd. - -Section Zpower. - -Theorem Zpower_plus : - forall n k1 k2, (0 <= k1)%Z -> (0 <= k2)%Z -> - Zpower n (k1 + k2) = (Zpower n k1 * Zpower n k2)%Z. -Proof. -intros n k1 k2 H1 H2. -now apply Zpower_exp ; apply Zle_ge. -Qed. - -Theorem Zpower_Zpower_nat : - forall b e, (0 <= e)%Z -> - Zpower b e = Zpower_nat b (Zabs_nat e). -Proof. -intros b [|e|e] He. -apply refl_equal. -apply Zpower_pos_nat. -elim He. -apply refl_equal. -Qed. - -Theorem Zpower_nat_S : - forall b e, - Zpower_nat b (S e) = (b * Zpower_nat b e)%Z. -Proof. -intros b e. -rewrite (Zpower_nat_is_exp 1 e). -apply (f_equal (fun x => x * _)%Z). -apply Zmult_1_r. -Qed. - -Theorem Zpower_pos_gt_0 : - forall b p, (0 < b)%Z -> - (0 < Zpower_pos b p)%Z. -Proof. -intros b p Hb. -rewrite Zpower_pos_nat. -induction (nat_of_P p). -easy. -rewrite Zpower_nat_S. -now apply Zmult_lt_0_compat. -Qed. - -Theorem Zeven_Zpower : - forall b e, (0 < e)%Z -> - Zeven (Zpower b e) = Zeven b. -Proof. -intros b e He. -case_eq (Zeven b) ; intros Hb. -(* b even *) -replace e with (e - 1 + 1)%Z by ring. -rewrite Zpower_exp. -rewrite Zeven_mult. -replace (Zeven (b ^ 1)) with true. -apply Bool.orb_true_r. -unfold Zpower, Zpower_pos. simpl. -now rewrite Zmult_1_r. -omega. -discriminate. -(* b odd *) -rewrite Zpower_Zpower_nat. -induction (Zabs_nat e). -easy. -unfold Zpower_nat. simpl. -rewrite Zeven_mult. -now rewrite Hb. -now apply Zlt_le_weak. -Qed. - -Theorem Zeven_Zpower_odd : - forall b e, (0 <= e)%Z -> Zeven b = false -> - Zeven (Zpower b e) = false. -Proof. -intros b e He Hb. -destruct (Z_le_lt_eq_dec _ _ He) as [He'|He']. -rewrite <- Hb. -now apply Zeven_Zpower. -now rewrite <- He'. -Qed. - -(** The radix must be greater than 1 *) -Record radix := { radix_val :> Z ; radix_prop : Zle_bool 2 radix_val = true }. - -Theorem radix_val_inj : - forall r1 r2, radix_val r1 = radix_val r2 -> r1 = r2. -Proof. -intros (r1, H1) (r2, H2) H. -simpl in H. -revert H1. -rewrite H. -intros H1. -apply f_equal. -apply eqbool_irrelevance. -Qed. - -Definition radix2 := Build_radix 2 (refl_equal _). - -Variable r : radix. - -Theorem radix_gt_0 : (0 < r)%Z. -Proof. -apply Zlt_le_trans with 2%Z. -easy. -apply Zle_bool_imp_le. -apply r. -Qed. - -Theorem radix_gt_1 : (1 < r)%Z. -Proof. -destruct r as (v, Hr). simpl. -apply Zlt_le_trans with 2%Z. -easy. -now apply Zle_bool_imp_le. -Qed. - -Theorem Zpower_gt_1 : - forall p, - (0 < p)%Z -> - (1 < Zpower r p)%Z. -Proof. -intros [|p|p] Hp ; try easy. -simpl. -rewrite Zpower_pos_nat. -generalize (lt_O_nat_of_P p). -induction (nat_of_P p). -easy. -intros _. -rewrite Zpower_nat_S. -assert (0 < Zpower_nat r n)%Z. -clear. -induction n. -easy. -rewrite Zpower_nat_S. -apply Zmult_lt_0_compat with (2 := IHn). -apply radix_gt_0. -apply Zle_lt_trans with (1 * Zpower_nat r n)%Z. -rewrite Zmult_1_l. -now apply (Zlt_le_succ 0). -apply Zmult_lt_compat_r with (1 := H). -apply radix_gt_1. -Qed. - -Theorem Zpower_gt_0 : - forall p, - (0 <= p)%Z -> - (0 < Zpower r p)%Z. -Proof. -intros p Hp. -rewrite Zpower_Zpower_nat with (1 := Hp). -induction (Zabs_nat p). -easy. -rewrite Zpower_nat_S. -apply Zmult_lt_0_compat with (2 := IHn). -apply radix_gt_0. -Qed. - -Theorem Zpower_ge_0 : - forall e, - (0 <= Zpower r e)%Z. -Proof. -intros [|e|e] ; try easy. -apply Zlt_le_weak. -now apply Zpower_gt_0. -Qed. - -Theorem Zpower_le : - forall e1 e2, (e1 <= e2)%Z -> - (Zpower r e1 <= Zpower r e2)%Z. -Proof. -intros e1 e2 He. -destruct (Zle_or_lt 0 e1)%Z as [H1|H1]. -replace e2 with (e2 - e1 + e1)%Z by ring. -rewrite Zpower_plus with (2 := H1). -rewrite <- (Zmult_1_l (r ^ e1)) at 1. -apply Zmult_le_compat_r. -apply (Zlt_le_succ 0). -apply Zpower_gt_0. -now apply Zle_minus_le_0. -apply Zpower_ge_0. -now apply Zle_minus_le_0. -clear He. -destruct e1 as [|e1|e1] ; try easy. -apply Zpower_ge_0. -Qed. - -Theorem Zpower_lt : - forall e1 e2, (0 <= e2)%Z -> (e1 < e2)%Z -> - (Zpower r e1 < Zpower r e2)%Z. -Proof. -intros e1 e2 He2 He. -destruct (Zle_or_lt 0 e1)%Z as [H1|H1]. -replace e2 with (e2 - e1 + e1)%Z by ring. -rewrite Zpower_plus with (2 := H1). -rewrite Zmult_comm. -rewrite <- (Zmult_1_r (r ^ e1)) at 1. -apply Zmult_lt_compat2. -split. -now apply Zpower_gt_0. -apply Zle_refl. -split. -easy. -apply Zpower_gt_1. -clear -He ; omega. -apply Zle_minus_le_0. -now apply Zlt_le_weak. -revert H1. -clear -He2. -destruct e1 ; try easy. -intros _. -now apply Zpower_gt_0. -Qed. - -Theorem Zpower_lt_Zpower : - forall e1 e2, - (Zpower r (e1 - 1) < Zpower r e2)%Z -> - (e1 <= e2)%Z. -Proof. -intros e1 e2 He. -apply Znot_gt_le. -intros H. -apply Zlt_not_le with (1 := He). -apply Zpower_le. -clear -H ; omega. -Qed. - -End Zpower. - -Section Div_Mod. - -Theorem Zmod_mod_mult : - forall n a b, (0 < a)%Z -> (0 <= b)%Z -> - Zmod (Zmod n (a * b)) b = Zmod n b. -Proof. -intros n a [|b|b] Ha Hb. -now rewrite 2!Zmod_0_r. -rewrite (Zmod_eq n (a * Zpos b)). -rewrite Zmult_assoc. -unfold Zminus. -rewrite Zopp_mult_distr_l. -apply Z_mod_plus. -easy. -apply Zmult_gt_0_compat. -now apply Zlt_gt. -easy. -now elim Hb. -Qed. - -Theorem ZOmod_eq : - forall a b, - Z.rem a b = (a - Z.quot a b * b)%Z. -Proof. -intros a b. -rewrite (Z.quot_rem' a b) at 2. -ring. -Qed. - -Theorem ZOmod_mod_mult : - forall n a b, - Z.rem (Z.rem n (a * b)) b = Z.rem n b. -Proof. -intros n a b. -assert (Z.rem n (a * b) = n + - (Z.quot n (a * b) * a) * b)%Z. -rewrite <- Zopp_mult_distr_l. -rewrite <- Zmult_assoc. -apply ZOmod_eq. -rewrite H. -apply Z_rem_plus. -rewrite <- H. -apply Zrem_sgn2. -Qed. - -Theorem Zdiv_mod_mult : - forall n a b, (0 <= a)%Z -> (0 <= b)%Z -> - (Zdiv (Zmod n (a * b)) a) = Zmod (Zdiv n a) b. -Proof. -intros n a b Ha Hb. -destruct (Zle_lt_or_eq _ _ Ha) as [Ha'|Ha']. -destruct (Zle_lt_or_eq _ _ Hb) as [Hb'|Hb']. -rewrite (Zmod_eq n (a * b)). -rewrite (Zmult_comm a b) at 2. -rewrite Zmult_assoc. -unfold Zminus. -rewrite Zopp_mult_distr_l. -rewrite Z_div_plus by now apply Zlt_gt. -rewrite <- Zdiv_Zdiv by easy. -apply sym_eq. -apply Zmod_eq. -now apply Zlt_gt. -now apply Zmult_gt_0_compat ; apply Zlt_gt. -rewrite <- Hb'. -rewrite Zmult_0_r, 2!Zmod_0_r. -apply Zdiv_0_l. -rewrite <- Ha'. -now rewrite 2!Zdiv_0_r, Zmod_0_l. -Qed. - -Theorem ZOdiv_mod_mult : - forall n a b, - (Z.quot (Z.rem n (a * b)) a) = Z.rem (Z.quot n a) b. -Proof. -intros n a b. -destruct (Z_eq_dec a 0) as [Za|Za]. -rewrite Za. -now rewrite 2!Zquot_0_r, Zrem_0_l. -assert (Z.rem n (a * b) = n + - (Z.quot (Z.quot n a) b * b) * a)%Z. -rewrite (ZOmod_eq n (a * b)) at 1. -rewrite Zquot_Zquot. -ring. -rewrite H. -rewrite Z_quot_plus with (2 := Za). -apply sym_eq. -apply ZOmod_eq. -rewrite <- H. -apply Zrem_sgn2. -Qed. - -Theorem ZOdiv_small_abs : - forall a b, - (Zabs a < b)%Z -> Z.quot a b = Z0. -Proof. -intros a b Ha. -destruct (Zle_or_lt 0 a) as [H|H]. -apply Zquot_small. -split. -exact H. -now rewrite Zabs_eq in Ha. -apply Zopp_inj. -rewrite <- Zquot_opp_l, Zopp_0. -apply Zquot_small. -generalize (Zabs_non_eq a). -omega. -Qed. - -Theorem ZOmod_small_abs : - forall a b, - (Zabs a < b)%Z -> Z.rem a b = a. -Proof. -intros a b Ha. -destruct (Zle_or_lt 0 a) as [H|H]. -apply Zrem_small. -split. -exact H. -now rewrite Zabs_eq in Ha. -apply Zopp_inj. -rewrite <- Zrem_opp_l. -apply Zrem_small. -generalize (Zabs_non_eq a). -omega. -Qed. - -Theorem ZOdiv_plus : - forall a b c, (0 <= a * b)%Z -> - (Z.quot (a + b) c = Z.quot a c + Z.quot b c + Z.quot (Z.rem a c + Z.rem b c) c)%Z. -Proof. -intros a b c Hab. -destruct (Z_eq_dec c 0) as [Zc|Zc]. -now rewrite Zc, 4!Zquot_0_r. -apply Zmult_reg_r with (1 := Zc). -rewrite 2!Zmult_plus_distr_l. -assert (forall d, Z.quot d c * c = d - Z.rem d c)%Z. -intros d. -rewrite ZOmod_eq. -ring. -rewrite 4!H. -rewrite <- Zplus_rem with (1 := Hab). -ring. -Qed. - -End Div_Mod. - -Section Same_sign. - -Theorem Zsame_sign_trans : - forall v u w, v <> Z0 -> - (0 <= u * v)%Z -> (0 <= v * w)%Z -> (0 <= u * w)%Z. -Proof. -intros [|v|v] [|u|u] [|w|w] Zv Huv Hvw ; try easy ; now elim Zv. -Qed. - -Theorem Zsame_sign_trans_weak : - forall v u w, (v = Z0 -> w = Z0) -> - (0 <= u * v)%Z -> (0 <= v * w)%Z -> (0 <= u * w)%Z. -Proof. -intros [|v|v] [|u|u] [|w|w] Zv Huv Hvw ; try easy ; now discriminate Zv. -Qed. - -Theorem Zsame_sign_imp : - forall u v, - (0 < u -> 0 <= v)%Z -> - (0 < -u -> 0 <= -v)%Z -> - (0 <= u * v)%Z. -Proof. -intros [|u|u] v Hp Hn. -easy. -apply Zmult_le_0_compat. -easy. -now apply Hp. -replace (Zneg u * v)%Z with (Zpos u * (-v))%Z. -apply Zmult_le_0_compat. -easy. -now apply Hn. -rewrite <- Zopp_mult_distr_r. -apply Zopp_mult_distr_l. -Qed. - -Theorem Zsame_sign_odiv : - forall u v, (0 <= v)%Z -> - (0 <= u * Z.quot u v)%Z. -Proof. -intros u v Hv. -apply Zsame_sign_imp ; intros Hu. -apply Z_quot_pos with (2 := Hv). -now apply Zlt_le_weak. -rewrite <- Zquot_opp_l. -apply Z_quot_pos with (2 := Hv). -now apply Zlt_le_weak. -Qed. - -End Same_sign. - -(** Boolean comparisons *) - -Section Zeq_bool. - -Inductive Zeq_bool_prop (x y : Z) : bool -> Prop := - | Zeq_bool_true_ : x = y -> Zeq_bool_prop x y true - | Zeq_bool_false_ : x <> y -> Zeq_bool_prop x y false. - -Theorem Zeq_bool_spec : - forall x y, Zeq_bool_prop x y (Zeq_bool x y). -Proof. -intros x y. -generalize (Zeq_is_eq_bool x y). -case (Zeq_bool x y) ; intros (H1, H2) ; constructor. -now apply H2. -intros H. -specialize (H1 H). -discriminate H1. -Qed. - -Theorem Zeq_bool_true : - forall x y, x = y -> Zeq_bool x y = true. -Proof. -intros x y. -apply -> Zeq_is_eq_bool. -Qed. - -Theorem Zeq_bool_false : - forall x y, x <> y -> Zeq_bool x y = false. -Proof. -intros x y. -generalize (proj2 (Zeq_is_eq_bool x y)). -case Zeq_bool. -intros He Hn. -elim Hn. -now apply He. -now intros _ _. -Qed. - -End Zeq_bool. - -Section Zle_bool. - -Inductive Zle_bool_prop (x y : Z) : bool -> Prop := - | Zle_bool_true_ : (x <= y)%Z -> Zle_bool_prop x y true - | Zle_bool_false_ : (y < x)%Z -> Zle_bool_prop x y false. - -Theorem Zle_bool_spec : - forall x y, Zle_bool_prop x y (Zle_bool x y). -Proof. -intros x y. -generalize (Zle_is_le_bool x y). -case Zle_bool ; intros (H1, H2) ; constructor. -now apply H2. -destruct (Zle_or_lt x y) as [H|H]. -now specialize (H1 H). -exact H. -Qed. - -Theorem Zle_bool_true : - forall x y : Z, - (x <= y)%Z -> Zle_bool x y = true. -Proof. -intros x y. -apply (proj1 (Zle_is_le_bool x y)). -Qed. - -Theorem Zle_bool_false : - forall x y : Z, - (y < x)%Z -> Zle_bool x y = false. -Proof. -intros x y Hxy. -generalize (Zle_cases x y). -case Zle_bool ; intros H. -elim (Zlt_irrefl x). -now apply Zle_lt_trans with y. -apply refl_equal. -Qed. - -End Zle_bool. - -Section Zlt_bool. - -Inductive Zlt_bool_prop (x y : Z) : bool -> Prop := - | Zlt_bool_true_ : (x < y)%Z -> Zlt_bool_prop x y true - | Zlt_bool_false_ : (y <= x)%Z -> Zlt_bool_prop x y false. - -Theorem Zlt_bool_spec : - forall x y, Zlt_bool_prop x y (Zlt_bool x y). -Proof. -intros x y. -generalize (Zlt_is_lt_bool x y). -case Zlt_bool ; intros (H1, H2) ; constructor. -now apply H2. -destruct (Zle_or_lt y x) as [H|H]. -exact H. -now specialize (H1 H). -Qed. - -Theorem Zlt_bool_true : - forall x y : Z, - (x < y)%Z -> Zlt_bool x y = true. -Proof. -intros x y. -apply (proj1 (Zlt_is_lt_bool x y)). -Qed. - -Theorem Zlt_bool_false : - forall x y : Z, - (y <= x)%Z -> Zlt_bool x y = false. -Proof. -intros x y Hxy. -generalize (Zlt_cases x y). -case Zlt_bool ; intros H. -elim (Zlt_irrefl x). -now apply Zlt_le_trans with y. -apply refl_equal. -Qed. - -Theorem negb_Zle_bool : - forall x y : Z, - negb (Zle_bool x y) = Zlt_bool y x. -Proof. -intros x y. -case Zle_bool_spec ; intros H. -now rewrite Zlt_bool_false. -now rewrite Zlt_bool_true. -Qed. - -Theorem negb_Zlt_bool : - forall x y : Z, - negb (Zlt_bool x y) = Zle_bool y x. -Proof. -intros x y. -case Zlt_bool_spec ; intros H. -now rewrite Zle_bool_false. -now rewrite Zle_bool_true. -Qed. - -End Zlt_bool. - -Section Zcompare. - -Inductive Zcompare_prop (x y : Z) : comparison -> Prop := - | Zcompare_Lt_ : (x < y)%Z -> Zcompare_prop x y Lt - | Zcompare_Eq_ : x = y -> Zcompare_prop x y Eq - | Zcompare_Gt_ : (y < x)%Z -> Zcompare_prop x y Gt. - -Theorem Zcompare_spec : - forall x y, Zcompare_prop x y (Zcompare x y). -Proof. -intros x y. -destruct (Z_dec x y) as [[H|H]|H]. -generalize (Zlt_compare _ _ H). -case (Zcompare x y) ; try easy. -now constructor. -generalize (Zgt_compare _ _ H). -case (Zcompare x y) ; try easy. -constructor. -now apply Zgt_lt. -generalize (proj2 (Zcompare_Eq_iff_eq _ _) H). -case (Zcompare x y) ; try easy. -now constructor. -Qed. - -Theorem Zcompare_Lt : - forall x y, - (x < y)%Z -> Zcompare x y = Lt. -Proof. -easy. -Qed. - -Theorem Zcompare_Eq : - forall x y, - (x = y)%Z -> Zcompare x y = Eq. -Proof. -intros x y. -apply <- Zcompare_Eq_iff_eq. -Qed. - -Theorem Zcompare_Gt : - forall x y, - (y < x)%Z -> Zcompare x y = Gt. -Proof. -intros x y. -apply Zlt_gt. -Qed. - -End Zcompare. - -Section cond_Zopp. - -Definition cond_Zopp (b : bool) m := if b then Zopp m else m. - -Theorem abs_cond_Zopp : - forall b m, - Zabs (cond_Zopp b m) = Zabs m. -Proof. -intros [|] m. -apply Zabs_Zopp. -apply refl_equal. -Qed. - -Theorem cond_Zopp_Zlt_bool : - forall m, - cond_Zopp (Zlt_bool m 0) m = Zabs m. -Proof. -intros m. -apply sym_eq. -case Zlt_bool_spec ; intros Hm. -apply Zabs_non_eq. -now apply Zlt_le_weak. -now apply Zabs_eq. -Qed. - -End cond_Zopp. - -Section fast_pow_pos. - -Fixpoint Zfast_pow_pos (v : Z) (e : positive) : Z := - match e with - | xH => v - | xO e' => Z.square (Zfast_pow_pos v e') - | xI e' => Zmult v (Z.square (Zfast_pow_pos v e')) - end. - -Theorem Zfast_pow_pos_correct : - forall v e, Zfast_pow_pos v e = Zpower_pos v e. -Proof. -intros v e. -rewrite <- (Zmult_1_r (Zfast_pow_pos v e)). -unfold Z.pow_pos. -generalize 1%Z. -revert v. -induction e ; intros v f ; simpl. -- rewrite <- 2!IHe. - rewrite Z.square_spec. - ring. -- rewrite <- 2!IHe. - rewrite Z.square_spec. - apply eq_sym, Zmult_assoc. -- apply eq_refl. -Qed. - -End fast_pow_pos. - -Section faster_div. - -Lemma Zdiv_eucl_unique : - forall a b, - Zdiv_eucl a b = (Zdiv a b, Zmod a b). -Proof. -intros a b. -unfold Zdiv, Zmod. -now case Zdiv_eucl. -Qed. - -Fixpoint Zpos_div_eucl_aux1 (a b : positive) {struct b} := - match b with - | xO b' => - match a with - | xO a' => let (q, r) := Zpos_div_eucl_aux1 a' b' in (q, 2 * r)%Z - | xI a' => let (q, r) := Zpos_div_eucl_aux1 a' b' in (q, 2 * r + 1)%Z - | xH => (Z0, Zpos a) - end - | xH => (Zpos a, Z0) - | xI _ => Z.pos_div_eucl a (Zpos b) - end. - -Lemma Zpos_div_eucl_aux1_correct : - forall a b, - Zpos_div_eucl_aux1 a b = Z.pos_div_eucl a (Zpos b). -Proof. -intros a b. -revert a. -induction b ; intros a. -- easy. -- change (Z.pos_div_eucl a (Zpos b~0)) with (Zdiv_eucl (Zpos a) (Zpos b~0)). - rewrite Zdiv_eucl_unique. - change (Zpos b~0) with (2 * Zpos b)%Z. - rewrite Z.rem_mul_r by easy. - rewrite <- Zdiv_Zdiv by easy. - destruct a as [a|a|]. - + change (Zpos_div_eucl_aux1 a~1 b~0) with (let (q, r) := Zpos_div_eucl_aux1 a b in (q, 2 * r + 1)%Z). - rewrite IHb. clear IHb. - change (Z.pos_div_eucl a (Zpos b)) with (Zdiv_eucl (Zpos a) (Zpos b)). - rewrite Zdiv_eucl_unique. - change (Zpos a~1) with (1 + 2 * Zpos a)%Z. - rewrite (Zmult_comm 2 (Zpos a)). - rewrite Z_div_plus_full by easy. - apply f_equal. - rewrite Z_mod_plus_full. - apply Zplus_comm. - + change (Zpos_div_eucl_aux1 a~0 b~0) with (let (q, r) := Zpos_div_eucl_aux1 a b in (q, 2 * r)%Z). - rewrite IHb. clear IHb. - change (Z.pos_div_eucl a (Zpos b)) with (Zdiv_eucl (Zpos a) (Zpos b)). - rewrite Zdiv_eucl_unique. - change (Zpos a~0) with (2 * Zpos a)%Z. - rewrite (Zmult_comm 2 (Zpos a)). - rewrite Z_div_mult_full by easy. - apply f_equal. - now rewrite Z_mod_mult. - + easy. -- change (Z.pos_div_eucl a 1) with (Zdiv_eucl (Zpos a) 1). - rewrite Zdiv_eucl_unique. - now rewrite Zdiv_1_r, Zmod_1_r. -Qed. - -Definition Zpos_div_eucl_aux (a b : positive) := - match Pos.compare a b with - | Lt => (Z0, Zpos a) - | Eq => (1%Z, Z0) - | Gt => Zpos_div_eucl_aux1 a b - end. - -Lemma Zpos_div_eucl_aux_correct : - forall a b, - Zpos_div_eucl_aux a b = Z.pos_div_eucl a (Zpos b). -Proof. -intros a b. -unfold Zpos_div_eucl_aux. -change (Z.pos_div_eucl a (Zpos b)) with (Zdiv_eucl (Zpos a) (Zpos b)). -rewrite Zdiv_eucl_unique. -case Pos.compare_spec ; intros H. -now rewrite H, Z_div_same, Z_mod_same. -now rewrite Zdiv_small, Zmod_small by (split ; easy). -rewrite Zpos_div_eucl_aux1_correct. -change (Z.pos_div_eucl a (Zpos b)) with (Zdiv_eucl (Zpos a) (Zpos b)). -apply Zdiv_eucl_unique. -Qed. - -Definition Zfast_div_eucl (a b : Z) := - match a with - | Z0 => (0, 0)%Z - | Zpos a' => - match b with - | Z0 => (0, 0)%Z - | Zpos b' => Zpos_div_eucl_aux a' b' - | Zneg b' => - let (q, r) := Zpos_div_eucl_aux a' b' in - match r with - | Z0 => (-q, 0)%Z - | Zpos _ => (-(q + 1), (b + r))%Z - | Zneg _ => (-(q + 1), (b + r))%Z - end - end - | Zneg a' => - match b with - | Z0 => (0, 0)%Z - | Zpos b' => - let (q, r) := Zpos_div_eucl_aux a' b' in - match r with - | Z0 => (-q, 0)%Z - | Zpos _ => (-(q + 1), (b - r))%Z - | Zneg _ => (-(q + 1), (b - r))%Z - end - | Zneg b' => let (q, r) := Zpos_div_eucl_aux a' b' in (q, (-r)%Z) - end - end. - -Theorem Zfast_div_eucl_correct : - forall a b : Z, - Zfast_div_eucl a b = Zdiv_eucl a b. -Proof. -unfold Zfast_div_eucl. -intros [|a|a] [|b|b] ; try rewrite Zpos_div_eucl_aux_correct ; easy. -Qed. - -End faster_div. - -Section Iter. - -Context {A : Type}. -Variable (f : A -> A). - -Fixpoint iter_nat (n : nat) (x : A) {struct n} : A := - match n with - | S n' => iter_nat n' (f x) - | O => x - end. - -Lemma iter_nat_plus : - forall (p q : nat) (x : A), - iter_nat (p + q) x = iter_nat p (iter_nat q x). -Proof. -induction q. -now rewrite plus_0_r. -intros x. -rewrite <- plus_n_Sm. -apply IHq. -Qed. - -Lemma iter_nat_S : - forall (p : nat) (x : A), - iter_nat (S p) x = f (iter_nat p x). -Proof. -induction p. -easy. -simpl. -intros x. -apply IHp. -Qed. - -Fixpoint iter_pos (n : positive) (x : A) {struct n} : A := - match n with - | xI n' => iter_pos n' (iter_pos n' (f x)) - | xO n' => iter_pos n' (iter_pos n' x) - | xH => f x - end. - -Lemma iter_pos_nat : - forall (p : positive) (x : A), - iter_pos p x = iter_nat (Pos.to_nat p) x. -Proof. -induction p ; intros x. -rewrite Pos2Nat.inj_xI. -simpl. -rewrite plus_0_r. -rewrite iter_nat_plus. -rewrite (IHp (f x)). -apply IHp. -rewrite Pos2Nat.inj_xO. -simpl. -rewrite plus_0_r. -rewrite iter_nat_plus. -rewrite (IHp x). -apply IHp. -easy. -Qed. - -End Iter. diff --git a/flocq/Core/Fcore_defs.v b/flocq/Core/Fcore_defs.v deleted file mode 100644 index 01b868ab..00000000 --- a/flocq/Core/Fcore_defs.v +++ /dev/null @@ -1,101 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2010-2013 Sylvie Boldo -#
# -Copyright (C) 2010-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** * Basic definitions: float and rounding property *) -Require Import Fcore_Raux. - -Section Def. - -(** Definition of a floating-point number *) -Record float (beta : radix) := Float { Fnum : Z ; Fexp : Z }. - -Arguments Fnum {beta} f. -Arguments Fexp {beta} f. - -Variable beta : radix. - -Definition F2R (f : float beta) := - (Z2R (Fnum f) * bpow beta (Fexp f))%R. - -(** Requirements on a rounding mode *) -Definition round_pred_total (P : R -> R -> Prop) := - forall x, exists f, P x f. - -Definition round_pred_monotone (P : R -> R -> Prop) := - forall x y f g, P x f -> P y g -> (x <= y)%R -> (f <= g)%R. - -Definition round_pred (P : R -> R -> Prop) := - round_pred_total P /\ - round_pred_monotone P. - -End Def. - -Arguments Fnum {beta} f. -Arguments Fexp {beta} f. -Arguments F2R {beta} f. - -Section RND. - -(** property of being a round toward -inf *) -Definition Rnd_DN_pt (F : R -> Prop) (x f : R) := - F f /\ (f <= x)%R /\ - forall g : R, F g -> (g <= x)%R -> (g <= f)%R. - -Definition Rnd_DN (F : R -> Prop) (rnd : R -> R) := - forall x : R, Rnd_DN_pt F x (rnd x). - -(** property of being a round toward +inf *) -Definition Rnd_UP_pt (F : R -> Prop) (x f : R) := - F f /\ (x <= f)%R /\ - forall g : R, F g -> (x <= g)%R -> (f <= g)%R. - -Definition Rnd_UP (F : R -> Prop) (rnd : R -> R) := - forall x : R, Rnd_UP_pt F x (rnd x). - -(** property of being a round toward zero *) -Definition Rnd_ZR_pt (F : R -> Prop) (x f : R) := - ( (0 <= x)%R -> Rnd_DN_pt F x f ) /\ - ( (x <= 0)%R -> Rnd_UP_pt F x f ). - -Definition Rnd_ZR (F : R -> Prop) (rnd : R -> R) := - forall x : R, Rnd_ZR_pt F x (rnd x). - -(** property of being a round to nearest *) -Definition Rnd_N_pt (F : R -> Prop) (x f : R) := - F f /\ - forall g : R, F g -> (Rabs (f - x) <= Rabs (g - x))%R. - -Definition Rnd_N (F : R -> Prop) (rnd : R -> R) := - forall x : R, Rnd_N_pt F x (rnd x). - -Definition Rnd_NG_pt (F : R -> Prop) (P : R -> R -> Prop) (x f : R) := - Rnd_N_pt F x f /\ - ( P x f \/ forall f2 : R, Rnd_N_pt F x f2 -> f2 = f ). - -Definition Rnd_NG (F : R -> Prop) (P : R -> R -> Prop) (rnd : R -> R) := - forall x : R, Rnd_NG_pt F P x (rnd x). - -Definition Rnd_NA_pt (F : R -> Prop) (x f : R) := - Rnd_N_pt F x f /\ - forall f2 : R, Rnd_N_pt F x f2 -> (Rabs f2 <= Rabs f)%R. - -Definition Rnd_NA (F : R -> Prop) (rnd : R -> R) := - forall x : R, Rnd_NA_pt F x (rnd x). - -End RND. diff --git a/flocq/Core/Fcore_digits.v b/flocq/Core/Fcore_digits.v deleted file mode 100644 index 53743035..00000000 --- a/flocq/Core/Fcore_digits.v +++ /dev/null @@ -1,1185 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2011-2013 Sylvie Boldo -#
# -Copyright (C) 2011-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -Require Import ZArith. -Require Import Zquot. -Require Import Fcore_Zaux. - -(** Number of bits (radix 2) of a positive integer. - -It serves as an upper bound on the number of digits to ensure termination. -*) - -Fixpoint digits2_Pnat (n : positive) : nat := - match n with - | xH => O - | xO p => S (digits2_Pnat p) - | xI p => S (digits2_Pnat p) - end. - -Theorem digits2_Pnat_correct : - forall n, - let d := digits2_Pnat n in - (Zpower_nat 2 d <= Zpos n < Zpower_nat 2 (S d))%Z. -Proof. -intros n d. unfold d. clear. -assert (Hp: forall m, (Zpower_nat 2 (S m) = 2 * Zpower_nat 2 m)%Z) by easy. -induction n ; simpl digits2_Pnat. -rewrite Zpos_xI, 2!Hp. -omega. -rewrite (Zpos_xO n), 2!Hp. -omega. -now split. -Qed. - -Section Fcore_digits. - -Variable beta : radix. - -Definition Zdigit n k := Z.rem (Z.quot n (Zpower beta k)) beta. - -Theorem Zdigit_lt : - forall n k, - (k < 0)%Z -> - Zdigit n k = Z0. -Proof. -intros n [|k|k] Hk ; try easy. -now case n. -Qed. - -Theorem Zdigit_0 : - forall k, Zdigit 0 k = Z0. -Proof. -intros k. -unfold Zdigit. -rewrite Zquot_0_l. -apply Zrem_0_l. -Qed. - -Theorem Zdigit_opp : - forall n k, - Zdigit (-n) k = Zopp (Zdigit n k). -Proof. -intros n k. -unfold Zdigit. -rewrite Zquot_opp_l. -apply Zrem_opp_l. -Qed. - -Theorem Zdigit_ge_Zpower_pos : - forall e n, - (0 <= n < Zpower beta e)%Z -> - forall k, (e <= k)%Z -> Zdigit n k = Z0. -Proof. -intros e n Hn k Hk. -unfold Zdigit. -rewrite Zquot_small. -apply Zrem_0_l. -split. -apply Hn. -apply Zlt_le_trans with (1 := proj2 Hn). -replace k with (e + (k - e))%Z by ring. -rewrite Zpower_plus. -rewrite <- (Zmult_1_r (beta ^ e)) at 1. -apply Zmult_le_compat_l. -apply (Zlt_le_succ 0). -apply Zpower_gt_0. -now apply Zle_minus_le_0. -apply Zlt_le_weak. -now apply Zle_lt_trans with n. -generalize (Zle_lt_trans _ _ _ (proj1 Hn) (proj2 Hn)). -clear. -now destruct e as [|e|e]. -now apply Zle_minus_le_0. -Qed. - -Theorem Zdigit_ge_Zpower : - forall e n, - (Zabs n < Zpower beta e)%Z -> - forall k, (e <= k)%Z -> Zdigit n k = Z0. -Proof. -intros e [|n|n] Hn k. -easy. -apply Zdigit_ge_Zpower_pos. -now split. -intros He. -change (Zneg n) with (Zopp (Zpos n)). -rewrite Zdigit_opp. -rewrite Zdigit_ge_Zpower_pos with (2 := He). -apply Zopp_0. -now split. -Qed. - -Theorem Zdigit_not_0_pos : - forall e n, (0 <= e)%Z -> - (Zpower beta e <= n < Zpower beta (e + 1))%Z -> - Zdigit n e <> Z0. -Proof. -intros e n He (Hn1,Hn2). -unfold Zdigit. -rewrite <- ZOdiv_mod_mult. -rewrite Zrem_small. -intros H. -apply Zle_not_lt with (1 := Hn1). -rewrite (Z.quot_rem' n (beta ^ e)). -rewrite H, Zmult_0_r, Zplus_0_l. -apply Zrem_lt_pos_pos. -apply Zle_trans with (2 := Hn1). -apply Zpower_ge_0. -now apply Zpower_gt_0. -split. -apply Zle_trans with (2 := Hn1). -apply Zpower_ge_0. -replace (beta ^ e * beta)%Z with (beta ^ (e + 1))%Z. -exact Hn2. -rewrite <- (Zmult_1_r beta) at 3. -now apply (Zpower_plus beta e 1). -Qed. - -Theorem Zdigit_not_0 : - forall e n, (0 <= e)%Z -> - (Zpower beta e <= Zabs n < Zpower beta (e + 1))%Z -> - Zdigit n e <> Z0. -Proof. -intros e n He Hn. -destruct (Zle_or_lt 0 n) as [Hn'|Hn']. -rewrite (Zabs_eq _ Hn') in Hn. -now apply Zdigit_not_0_pos. -intros H. -rewrite (Zabs_non_eq n) in Hn by now apply Zlt_le_weak. -apply (Zdigit_not_0_pos _ _ He Hn). -now rewrite Zdigit_opp, H. -Qed. - -Theorem Zdigit_mul_pow : - forall n k k', (0 <= k')%Z -> - Zdigit (n * Zpower beta k') k = Zdigit n (k - k'). -Proof. -intros n k k' Hk'. -destruct (Zle_or_lt k' k) as [H|H]. -revert k H. -pattern k' ; apply Zlt_0_ind with (2 := Hk'). -clear k' Hk'. -intros k' IHk' Hk' k H. -unfold Zdigit. -apply (f_equal (fun x => Z.rem x beta)). -pattern k at 1 ; replace k with (k - k' + k')%Z by ring. -rewrite Zpower_plus with (2 := Hk'). -apply Zquot_mult_cancel_r. -apply Zgt_not_eq. -now apply Zpower_gt_0. -now apply Zle_minus_le_0. -destruct (Zle_or_lt 0 k) as [H0|H0]. -rewrite (Zdigit_lt n) by omega. -unfold Zdigit. -replace k' with (k' - k + k)%Z by ring. -rewrite Zpower_plus with (2 := H0). -rewrite Zmult_assoc, Z_quot_mult. -replace (k' - k)%Z with (k' - k - 1 + 1)%Z by ring. -rewrite Zpower_exp by omega. -rewrite Zmult_assoc. -change (Zpower beta 1) with (beta * 1)%Z. -rewrite Zmult_1_r. -apply Z_rem_mult. -apply Zgt_not_eq. -now apply Zpower_gt_0. -apply Zle_minus_le_0. -now apply Zlt_le_weak. -rewrite Zdigit_lt with (1 := H0). -apply sym_eq. -apply Zdigit_lt. -omega. -Qed. - -Theorem Zdigit_div_pow : - forall n k k', (0 <= k)%Z -> (0 <= k')%Z -> - Zdigit (Z.quot n (Zpower beta k')) k = Zdigit n (k + k'). -Proof. -intros n k k' Hk Hk'. -unfold Zdigit. -rewrite Zquot_Zquot. -rewrite Zplus_comm. -now rewrite Zpower_plus. -Qed. - -Theorem Zdigit_mod_pow : - forall n k k', (k < k')%Z -> - Zdigit (Z.rem n (Zpower beta k')) k = Zdigit n k. -Proof. -intros n k k' Hk. -destruct (Zle_or_lt 0 k) as [H|H]. -unfold Zdigit. -rewrite <- 2!ZOdiv_mod_mult. -apply (f_equal (fun x => Z.quot x (beta ^ k))). -replace k' with (k + 1 + (k' - (k + 1)))%Z by ring. -rewrite Zpower_exp by omega. -rewrite Zmult_comm. -rewrite Zpower_plus by easy. -change (Zpower beta 1) with (beta * 1)%Z. -rewrite Zmult_1_r. -apply ZOmod_mod_mult. -now rewrite 2!Zdigit_lt. -Qed. - -Theorem Zdigit_mod_pow_out : - forall n k k', (0 <= k' <= k)%Z -> - Zdigit (Z.rem n (Zpower beta k')) k = Z0. -Proof. -intros n k k' Hk. -unfold Zdigit. -rewrite ZOdiv_small_abs. -apply Zrem_0_l. -apply Zlt_le_trans with (Zpower beta k'). -rewrite <- (Zabs_eq (beta ^ k')) at 2 by apply Zpower_ge_0. -apply Zrem_lt. -apply Zgt_not_eq. -now apply Zpower_gt_0. -now apply Zpower_le. -Qed. - -Fixpoint Zsum_digit f k := - match k with - | O => Z0 - | S k => (Zsum_digit f k + f (Z_of_nat k) * Zpower beta (Z_of_nat k))%Z - end. - -Theorem Zsum_digit_digit : - forall n k, - Zsum_digit (Zdigit n) k = Z.rem n (Zpower beta (Z_of_nat k)). -Proof. -intros n. -induction k. -apply sym_eq. -apply Zrem_1_r. -simpl Zsum_digit. -rewrite IHk. -unfold Zdigit. -rewrite <- ZOdiv_mod_mult. -rewrite <- (ZOmod_mod_mult n beta). -rewrite Zmult_comm. -replace (beta ^ Z_of_nat k * beta)%Z with (Zpower beta (Z_of_nat (S k))). -rewrite Zplus_comm, Zmult_comm. -apply sym_eq. -apply Z.quot_rem'. -rewrite inj_S. -rewrite <- (Zmult_1_r beta) at 3. -apply Zpower_plus. -apply Zle_0_nat. -easy. -Qed. - -Theorem Zpower_gt_id : - forall n, (n < Zpower beta n)%Z. -Proof. -intros [|n|n] ; try easy. -simpl. -rewrite Zpower_pos_nat. -rewrite Zpos_eq_Z_of_nat_o_nat_of_P. -induction (nat_of_P n). -easy. -rewrite inj_S. -change (Zpower_nat beta (S n0)) with (beta * Zpower_nat beta n0)%Z. -unfold Zsucc. -apply Zlt_le_trans with (beta * (Z_of_nat n0 + 1))%Z. -clear. -apply Zlt_0_minus_lt. -replace (beta * (Z_of_nat n0 + 1) - (Z_of_nat n0 + 1))%Z with ((beta - 1) * (Z_of_nat n0 + 1))%Z by ring. -apply Zmult_lt_0_compat. -cut (2 <= beta)%Z. omega. -apply Zle_bool_imp_le. -apply beta. -apply (Zle_lt_succ 0). -apply Zle_0_nat. -apply Zmult_le_compat_l. -now apply Zlt_le_succ. -apply Zle_trans with 2%Z. -easy. -apply Zle_bool_imp_le. -apply beta. -Qed. - -Theorem Zdigit_ext : - forall n1 n2, - (forall k, (0 <= k)%Z -> Zdigit n1 k = Zdigit n2 k) -> - n1 = n2. -Proof. -intros n1 n2 H. -rewrite <- (ZOmod_small_abs n1 (Zpower beta (Zmax (Zabs n1) (Zabs n2)))). -rewrite <- (ZOmod_small_abs n2 (Zpower beta (Zmax (Zabs n1) (Zabs n2)))) at 2. -replace (Zmax (Zabs n1) (Zabs n2)) with (Z_of_nat (Zabs_nat (Zmax (Zabs n1) (Zabs n2)))). -rewrite <- 2!Zsum_digit_digit. -induction (Zabs_nat (Zmax (Zabs n1) (Zabs n2))). -easy. -simpl. -rewrite H, IHn. -apply refl_equal. -apply Zle_0_nat. -rewrite inj_Zabs_nat. -apply Zabs_eq. -apply Zle_trans with (Zabs n1). -apply Zabs_pos. -apply Zle_max_l. -apply Zlt_le_trans with (Zpower beta (Zabs n2)). -apply Zpower_gt_id. -apply Zpower_le. -apply Zle_max_r. -apply Zlt_le_trans with (Zpower beta (Zabs n1)). -apply Zpower_gt_id. -apply Zpower_le. -apply Zle_max_l. -Qed. - -Theorem ZOmod_plus_pow_digit : - forall u v n, (0 <= u * v)%Z -> - (forall k, (0 <= k < n)%Z -> Zdigit u k = Z0 \/ Zdigit v k = Z0) -> - Z.rem (u + v) (Zpower beta n) = (Z.rem u (Zpower beta n) + Z.rem v (Zpower beta n))%Z. -Proof. -intros u v n Huv Hd. -destruct (Zle_or_lt 0 n) as [Hn|Hn]. -rewrite Zplus_rem with (1 := Huv). -apply ZOmod_small_abs. -generalize (Zle_refl n). -pattern n at -2 ; rewrite <- Zabs_eq with (1 := Hn). -rewrite <- (inj_Zabs_nat n). -induction (Zabs_nat n) as [|p IHp]. -now rewrite 2!Zrem_1_r. -rewrite <- 2!Zsum_digit_digit. -simpl Zsum_digit. -rewrite inj_S. -intros Hn'. -replace (Zsum_digit (Zdigit u) p + Zdigit u (Z_of_nat p) * beta ^ Z_of_nat p + - (Zsum_digit (Zdigit v) p + Zdigit v (Z_of_nat p) * beta ^ Z_of_nat p))%Z with - (Zsum_digit (Zdigit u) p + Zsum_digit (Zdigit v) p + - (Zdigit u (Z_of_nat p) + Zdigit v (Z_of_nat p)) * beta ^ Z_of_nat p)%Z by ring. -apply (Zle_lt_trans _ _ _ (Zabs_triangle _ _)). -replace (beta ^ Zsucc (Z_of_nat p))%Z with (beta ^ Z_of_nat p + (beta - 1) * beta ^ Z_of_nat p)%Z. -apply Zplus_lt_le_compat. -rewrite 2!Zsum_digit_digit. -apply IHp. -now apply Zle_succ_le. -rewrite Zabs_Zmult. -rewrite (Zabs_eq (beta ^ Z_of_nat p)) by apply Zpower_ge_0. -apply Zmult_le_compat_r. 2: apply Zpower_ge_0. -apply Zlt_succ_le. -assert (forall u v, Zabs (Zdigit u v) < Zsucc (beta - 1))%Z. -clear ; intros n k. -assert (0 < beta)%Z. -apply Zlt_le_trans with 2%Z. -apply refl_equal. -apply Zle_bool_imp_le. -apply beta. -replace (Zsucc (beta - 1)) with (Zabs beta). -apply Zrem_lt. -now apply Zgt_not_eq. -rewrite Zabs_eq. -apply Zsucc_pred. -now apply Zlt_le_weak. -assert (0 <= Z_of_nat p < n)%Z. -split. -apply Zle_0_nat. -apply Zgt_lt. -now apply Zle_succ_gt. -destruct (Hd (Z_of_nat p) H0) as [K|K] ; rewrite K. -apply H. -rewrite Zplus_0_r. -apply H. -unfold Zsucc. -ring_simplify. -rewrite Zpower_plus. -change (beta ^1)%Z with (beta * 1)%Z. -now rewrite Zmult_1_r. -apply Zle_0_nat. -easy. -destruct n as [|n|n] ; try easy. -now rewrite 3!Zrem_0_r. -Qed. - -Theorem ZOdiv_plus_pow_digit : - forall u v n, (0 <= u * v)%Z -> - (forall k, (0 <= k < n)%Z -> Zdigit u k = Z0 \/ Zdigit v k = Z0) -> - Z.quot (u + v) (Zpower beta n) = (Z.quot u (Zpower beta n) + Z.quot v (Zpower beta n))%Z. -Proof. -intros u v n Huv Hd. -rewrite <- (Zplus_0_r (Z.quot u (Zpower beta n) + Z.quot v (Zpower beta n))). -rewrite ZOdiv_plus with (1 := Huv). -rewrite <- ZOmod_plus_pow_digit by assumption. -apply f_equal. -destruct (Zle_or_lt 0 n) as [Hn|Hn]. -apply ZOdiv_small_abs. -rewrite <- Zabs_eq. -apply Zrem_lt. -apply Zgt_not_eq. -now apply Zpower_gt_0. -apply Zpower_ge_0. -clear -Hn. -destruct n as [|n|n] ; try easy. -apply Zquot_0_r. -Qed. - -Theorem Zdigit_plus : - forall u v, (0 <= u * v)%Z -> - (forall k, (0 <= k)%Z -> Zdigit u k = Z0 \/ Zdigit v k = Z0) -> - forall k, - Zdigit (u + v) k = (Zdigit u k + Zdigit v k)%Z. -Proof. -intros u v Huv Hd k. -destruct (Zle_or_lt 0 k) as [Hk|Hk]. -unfold Zdigit. -rewrite ZOdiv_plus_pow_digit with (1 := Huv). -rewrite <- (Zmult_1_r beta) at 3 5 7. -change (beta * 1)%Z with (beta ^1)%Z. -apply ZOmod_plus_pow_digit. -apply Zsame_sign_trans_weak with v. -intros Zv ; rewrite Zv. -apply Zquot_0_l. -rewrite Zmult_comm. -apply Zsame_sign_trans_weak with u. -intros Zu ; rewrite Zu. -apply Zquot_0_l. -now rewrite Zmult_comm. -apply Zsame_sign_odiv. -apply Zpower_ge_0. -apply Zsame_sign_odiv. -apply Zpower_ge_0. -intros k' (Hk1,Hk2). -rewrite 2!Zdigit_div_pow by assumption. -apply Hd. -now apply Zplus_le_0_compat. -intros k' (Hk1,Hk2). -now apply Hd. -now rewrite 3!Zdigit_lt. -Qed. - -(** Left and right shifts *) - -Definition Zscale n k := - if Zle_bool 0 k then (n * Zpower beta k)%Z else Z.quot n (Zpower beta (-k)). - -Theorem Zdigit_scale : - forall n k k', (0 <= k')%Z -> - Zdigit (Zscale n k) k' = Zdigit n (k' - k). -Proof. -intros n k k' Hk'. -unfold Zscale. -case Zle_bool_spec ; intros Hk. -now apply Zdigit_mul_pow. -apply Zdigit_div_pow with (1 := Hk'). -omega. -Qed. - -Theorem Zscale_0 : - forall k, - Zscale 0 k = Z0. -Proof. -intros k. -unfold Zscale. -case Zle_bool. -apply Zmult_0_l. -apply Zquot_0_l. -Qed. - -Theorem Zsame_sign_scale : - forall n k, - (0 <= n * Zscale n k)%Z. -Proof. -intros n k. -unfold Zscale. -case Zle_bool_spec ; intros Hk. -rewrite Zmult_assoc. -apply Zmult_le_0_compat. -apply Zsame_sign_imp ; apply Zlt_le_weak. -apply Zpower_ge_0. -apply Zsame_sign_odiv. -apply Zpower_ge_0. -Qed. - -Theorem Zscale_mul_pow : - forall n k k', (0 <= k)%Z -> - Zscale (n * Zpower beta k) k' = Zscale n (k + k'). -Proof. -intros n k k' Hk. -unfold Zscale. -case Zle_bool_spec ; intros Hk'. -rewrite Zle_bool_true. -rewrite <- Zmult_assoc. -apply f_equal. -now rewrite Zpower_plus. -now apply Zplus_le_0_compat. -case Zle_bool_spec ; intros Hk''. -pattern k at 1 ; replace k with (k + k' + -k')%Z by ring. -assert (0 <= -k')%Z by omega. -rewrite Zpower_plus by easy. -rewrite Zmult_assoc, Z_quot_mult. -apply refl_equal. -apply Zgt_not_eq. -now apply Zpower_gt_0. -replace (-k')%Z with (-(k+k') + k)%Z by ring. -rewrite Zpower_plus with (2 := Hk). -apply Zquot_mult_cancel_r. -apply Zgt_not_eq. -now apply Zpower_gt_0. -omega. -Qed. - -Theorem Zscale_scale : - forall n k k', (0 <= k)%Z -> - Zscale (Zscale n k) k' = Zscale n (k + k'). -Proof. -intros n k k' Hk. -unfold Zscale at 2. -rewrite Zle_bool_true with (1 := Hk). -now apply Zscale_mul_pow. -Qed. - -(** Slice of an integer *) - -Definition Zslice n k1 k2 := - if Zle_bool 0 k2 then Z.rem (Zscale n (-k1)) (Zpower beta k2) else Z0. - -Theorem Zdigit_slice : - forall n k1 k2 k, (0 <= k < k2)%Z -> - Zdigit (Zslice n k1 k2) k = Zdigit n (k1 + k). -Proof. -intros n k1 k2 k Hk. -unfold Zslice. -rewrite Zle_bool_true. -rewrite Zdigit_mod_pow by apply Hk. -rewrite Zdigit_scale by apply Hk. -unfold Zminus. -now rewrite Zopp_involutive, Zplus_comm. -omega. -Qed. - -Theorem Zdigit_slice_out : - forall n k1 k2 k, (k2 <= k)%Z -> - Zdigit (Zslice n k1 k2) k = Z0. -Proof. -intros n k1 k2 k Hk. -unfold Zslice. -case Zle_bool_spec ; intros Hk2. -apply Zdigit_mod_pow_out. -now split. -apply Zdigit_0. -Qed. - -Theorem Zslice_0 : - forall k k', - Zslice 0 k k' = Z0. -Proof. -intros k k'. -unfold Zslice. -case Zle_bool. -rewrite Zscale_0. -apply Zrem_0_l. -apply refl_equal. -Qed. - -Theorem Zsame_sign_slice : - forall n k k', - (0 <= n * Zslice n k k')%Z. -Proof. -intros n k k'. -unfold Zslice. -case Zle_bool. -apply Zsame_sign_trans_weak with (Zscale n (-k)). -intros H ; rewrite H. -apply Zrem_0_l. -apply Zsame_sign_scale. -rewrite Zmult_comm. -apply Zrem_sgn2. -now rewrite Zmult_0_r. -Qed. - -Theorem Zslice_slice : - forall n k1 k2 k1' k2', (0 <= k1' <= k2)%Z -> - Zslice (Zslice n k1 k2) k1' k2' = Zslice n (k1 + k1') (Zmin (k2 - k1') k2'). -Proof. -intros n k1 k2 k1' k2' Hk1'. -destruct (Zle_or_lt 0 k2') as [Hk2'|Hk2']. -apply Zdigit_ext. -intros k Hk. -destruct (Zle_or_lt (Zmin (k2 - k1') k2') k) as [Hk'|Hk']. -rewrite (Zdigit_slice_out n (k1 + k1')) with (1 := Hk'). -destruct (Zle_or_lt k2' k) as [Hk''|Hk'']. -now apply Zdigit_slice_out. -rewrite Zdigit_slice by now split. -apply Zdigit_slice_out. -zify ; omega. -rewrite Zdigit_slice by (zify ; omega). -rewrite (Zdigit_slice n (k1 + k1')) by now split. -rewrite Zdigit_slice. -now rewrite Zplus_assoc. -zify ; omega. -unfold Zslice. -rewrite Zmin_r. -now rewrite Zle_bool_false. -omega. -Qed. - -Theorem Zslice_mul_pow : - forall n k k1 k2, (0 <= k)%Z -> - Zslice (n * Zpower beta k) k1 k2 = Zslice n (k1 - k) k2. -Proof. -intros n k k1 k2 Hk. -unfold Zslice. -case Zle_bool_spec ; intros Hk2. -2: apply refl_equal. -rewrite Zscale_mul_pow with (1 := Hk). -now replace (- (k1 - k))%Z with (k + -k1)%Z by ring. -Qed. - -Theorem Zslice_div_pow : - forall n k k1 k2, (0 <= k)%Z -> (0 <= k1)%Z -> - Zslice (Z.quot n (Zpower beta k)) k1 k2 = Zslice n (k1 + k) k2. -Proof. -intros n k k1 k2 Hk Hk1. -unfold Zslice. -case Zle_bool_spec ; intros Hk2. -2: apply refl_equal. -apply (f_equal (fun x => Z.rem x (beta ^ k2))). -unfold Zscale. -case Zle_bool_spec ; intros Hk1'. -replace k1 with Z0 by omega. -case Zle_bool_spec ; intros Hk'. -replace k with Z0 by omega. -simpl. -now rewrite Zquot_1_r. -rewrite Zopp_involutive. -apply Zmult_1_r. -rewrite Zle_bool_false by omega. -rewrite 2!Zopp_involutive, Zplus_comm. -rewrite Zpower_plus by assumption. -apply Zquot_Zquot. -Qed. - -Theorem Zslice_scale : - forall n k k1 k2, (0 <= k1)%Z -> - Zslice (Zscale n k) k1 k2 = Zslice n (k1 - k) k2. -Proof. -intros n k k1 k2 Hk1. -unfold Zscale. -case Zle_bool_spec; intros Hk. -now apply Zslice_mul_pow. -apply Zslice_div_pow with (2 := Hk1). -omega. -Qed. - -Theorem Zslice_div_pow_scale : - forall n k k1 k2, (0 <= k)%Z -> - Zslice (Z.quot n (Zpower beta k)) k1 k2 = Zscale (Zslice n k (k1 + k2)) (-k1). -Proof. -intros n k k1 k2 Hk. -apply Zdigit_ext. -intros k' Hk'. -rewrite Zdigit_scale with (1 := Hk'). -unfold Zminus. -rewrite (Zplus_comm k'), Zopp_involutive. -destruct (Zle_or_lt k2 k') as [Hk2|Hk2]. -rewrite Zdigit_slice_out with (1 := Hk2). -apply sym_eq. -apply Zdigit_slice_out. -now apply Zplus_le_compat_l. -rewrite Zdigit_slice by now split. -destruct (Zle_or_lt 0 (k1 + k')) as [Hk1'|Hk1']. -rewrite Zdigit_slice by omega. -rewrite Zdigit_div_pow by assumption. -apply f_equal. -ring. -now rewrite 2!Zdigit_lt. -Qed. - -Theorem Zplus_slice : - forall n k l1 l2, (0 <= l1)%Z -> (0 <= l2)%Z -> - (Zslice n k l1 + Zscale (Zslice n (k + l1) l2) l1)%Z = Zslice n k (l1 + l2). -Proof. -intros n k1 l1 l2 Hl1 Hl2. -clear Hl1. -apply Zdigit_ext. -intros k Hk. -rewrite Zdigit_plus. -rewrite Zdigit_scale with (1 := Hk). -destruct (Zle_or_lt (l1 + l2) k) as [Hk2|Hk2]. -rewrite Zdigit_slice_out with (1 := Hk2). -now rewrite 2!Zdigit_slice_out by omega. -rewrite Zdigit_slice with (1 := conj Hk Hk2). -destruct (Zle_or_lt l1 k) as [Hk1|Hk1]. -rewrite Zdigit_slice_out with (1 := Hk1). -rewrite Zdigit_slice by omega. -simpl ; apply f_equal. -ring. -rewrite Zdigit_slice with (1 := conj Hk Hk1). -rewrite (Zdigit_lt _ (k - l1)) by omega. -apply Zplus_0_r. -rewrite Zmult_comm. -apply Zsame_sign_trans_weak with n. -intros H ; rewrite H. -apply Zslice_0. -rewrite Zmult_comm. -apply Zsame_sign_trans_weak with (Zslice n (k1 + l1) l2). -intros H ; rewrite H. -apply Zscale_0. -apply Zsame_sign_slice. -apply Zsame_sign_scale. -apply Zsame_sign_slice. -clear k Hk ; intros k Hk. -rewrite Zdigit_scale with (1 := Hk). -destruct (Zle_or_lt l1 k) as [Hk1|Hk1]. -left. -now apply Zdigit_slice_out. -right. -apply Zdigit_lt. -omega. -Qed. - -Section digits_aux. - -Variable p : Z. - -Fixpoint Zdigits_aux (nb pow : Z) (n : nat) { struct n } : Z := - match n with - | O => nb - | S n => if Zlt_bool p pow then nb else Zdigits_aux (nb + 1) (Zmult beta pow) n - end. - -End digits_aux. - -(** Number of digits of an integer *) - -Definition Zdigits n := - match n with - | Z0 => Z0 - | Zneg p => Zdigits_aux (Zpos p) 1 beta (digits2_Pnat p) - | Zpos p => Zdigits_aux n 1 beta (digits2_Pnat p) - end. - -Theorem Zdigits_correct : - forall n, - (Zpower beta (Zdigits n - 1) <= Zabs n < Zpower beta (Zdigits n))%Z. -Proof. -cut (forall p, Zpower beta (Zdigits (Zpos p) - 1) <= Zpos p < Zpower beta (Zdigits (Zpos p)))%Z. -intros H [|n|n] ; try exact (H n). -now split. -intros n. -simpl. -(* *) -assert (U: (Zpos n < Zpower beta (Z_of_nat (S (digits2_Pnat n))))%Z). -apply Zlt_le_trans with (1 := proj2 (digits2_Pnat_correct n)). -rewrite Zpower_Zpower_nat. -rewrite Zabs_nat_Z_of_nat. -induction (S (digits2_Pnat n)). -easy. -rewrite 2!(Zpower_nat_S). -apply Zmult_le_compat with (2 := IHn0). -apply Zle_bool_imp_le. -apply beta. -easy. -rewrite <- (Zabs_nat_Z_of_nat n0). -rewrite <- Zpower_Zpower_nat. -apply (Zpower_ge_0 (Build_radix 2 (refl_equal true))). -apply Zle_0_nat. -apply Zle_0_nat. -(* *) -revert U. -rewrite inj_S. -unfold Zsucc. -generalize (digits2_Pnat n). -intros u U. -pattern (radix_val beta) at 2 4 ; replace (radix_val beta) with (Zpower beta 1) by apply Zmult_1_r. -assert (V: (Zpower beta (1 - 1) <= Zpos n)%Z). -now apply (Zlt_le_succ 0). -generalize (conj V U). -clear. -generalize (Zle_refl 1). -generalize 1%Z at 2 3 5 6 7 9 10. -(* *) -induction u. -easy. -rewrite inj_S; unfold Zsucc. -simpl Zdigits_aux. -intros v Hv U. -case Zlt_bool_spec ; intros K. -now split. -pattern (radix_val beta) at 2 5 ; replace (radix_val beta) with (Zpower beta 1) by apply Zmult_1_r. -rewrite <- Zpower_plus. -rewrite Zplus_comm. -apply IHu. -clear -Hv ; omega. -split. -now ring_simplify (1 + v - 1)%Z. -now rewrite Zplus_assoc. -easy. -apply Zle_succ_le with (1 := Hv). -Qed. - -Theorem Zdigits_unique : - forall n d, - (Zpower beta (d - 1) <= Zabs n < Zpower beta d)%Z -> - Zdigits n = d. -Proof. -intros n d Hd. -assert (Hd' := Zdigits_correct n). -apply Zle_antisym. -apply (Zpower_lt_Zpower beta). -now apply Zle_lt_trans with (Zabs n). -apply (Zpower_lt_Zpower beta). -now apply Zle_lt_trans with (Zabs n). -Qed. - -Theorem Zdigits_abs : - forall n, Zdigits (Zabs n) = Zdigits n. -Proof. -now intros [|n|n]. -Qed. - -Theorem Zdigits_gt_0 : - forall n, n <> Z0 -> (0 < Zdigits n)%Z. -Proof. -intros n Zn. -rewrite <- (Zdigits_abs n). -assert (Hn: (0 < Zabs n)%Z). -destruct n ; [|easy|easy]. -now elim Zn. -destruct (Zabs n) as [|p|p] ; try easy ; clear. -simpl. -generalize 1%Z (radix_val beta) (refl_equal Lt : (0 < 1)%Z). -induction (digits2_Pnat p). -easy. -simpl. -intros. -case Zlt_bool. -exact H. -apply IHn. -now apply Zlt_lt_succ. -Qed. - -Theorem Zdigits_ge_0 : - forall n, (0 <= Zdigits n)%Z. -Proof. -intros n. -destruct (Z_eq_dec n 0) as [H|H]. -now rewrite H. -apply Zlt_le_weak. -now apply Zdigits_gt_0. -Qed. - -Theorem Zdigit_out : - forall n k, (Zdigits n <= k)%Z -> - Zdigit n k = Z0. -Proof. -intros n k Hk. -apply Zdigit_ge_Zpower with (2 := Hk). -apply Zdigits_correct. -Qed. - -Theorem Zdigit_digits : - forall n, n <> Z0 -> - Zdigit n (Zdigits n - 1) <> Z0. -Proof. -intros n Zn. -apply Zdigit_not_0. -apply Zlt_0_le_0_pred. -now apply Zdigits_gt_0. -ring_simplify (Zdigits n - 1 + 1)%Z. -apply Zdigits_correct. -Qed. - -Theorem Zdigits_slice : - forall n k l, (0 <= l)%Z -> - (Zdigits (Zslice n k l) <= l)%Z. -Proof. -intros n k l Hl. -unfold Zslice. -rewrite Zle_bool_true with (1 := Hl). -destruct (Zdigits_correct (Z.rem (Zscale n (- k)) (Zpower beta l))) as (H1,H2). -apply Zpower_lt_Zpower with beta. -apply Zle_lt_trans with (1 := H1). -rewrite <- (Zabs_eq (beta ^ l)) at 2 by apply Zpower_ge_0. -apply Zrem_lt. -apply Zgt_not_eq. -now apply Zpower_gt_0. -Qed. - -Theorem Zdigits_mult_Zpower : - forall m e, - m <> Z0 -> (0 <= e)%Z -> - Zdigits (m * Zpower beta e) = (Zdigits m + e)%Z. -Proof. -intros m e Hm He. -assert (H := Zdigits_correct m). -apply Zdigits_unique. -rewrite Z.abs_mul, Z.abs_pow, (Zabs_eq beta). -2: now apply Zlt_le_weak, radix_gt_0. -split. -replace (Zdigits m + e - 1)%Z with (Zdigits m - 1 + e)%Z by ring. -rewrite Zpower_plus with (2 := He). -apply Zmult_le_compat_r. -apply H. -apply Zpower_ge_0. -now apply Zlt_0_le_0_pred, Zdigits_gt_0. -rewrite Zpower_plus with (2 := He). -apply Zmult_lt_compat_r. -now apply Zpower_gt_0. -apply H. -now apply Zlt_le_weak, Zdigits_gt_0. -Qed. - -Theorem Zdigits_Zpower : - forall e, - (0 <= e)%Z -> - Zdigits (Zpower beta e) = (e + 1)%Z. -Proof. -intros e He. -rewrite <- (Zmult_1_l (Zpower beta e)). -rewrite Zdigits_mult_Zpower ; try easy. -apply Zplus_comm. -Qed. - -Theorem Zdigits_le : - forall x y, - (0 <= x)%Z -> (x <= y)%Z -> - (Zdigits x <= Zdigits y)%Z. -Proof. -intros x y Zx Hxy. -assert (Hx := Zdigits_correct x). -assert (Hy := Zdigits_correct y). -apply (Zpower_lt_Zpower beta). -zify ; omega. -Qed. - -Theorem lt_Zdigits : - forall x y, - (0 <= y)%Z -> - (Zdigits x < Zdigits y)%Z -> - (x < y)%Z. -Proof. -intros x y Hy. -cut (y <= x -> Zdigits y <= Zdigits x)%Z. omega. -now apply Zdigits_le. -Qed. - -Theorem Zpower_le_Zdigits : - forall e x, - (e < Zdigits x)%Z -> - (Zpower beta e <= Zabs x)%Z. -Proof. -intros e x Hex. -destruct (Zdigits_correct x) as [H1 H2]. -apply Zle_trans with (2 := H1). -apply Zpower_le. -clear -Hex ; omega. -Qed. - -Theorem Zdigits_le_Zpower : - forall e x, - (Zabs x < Zpower beta e)%Z -> - (Zdigits x <= e)%Z. -Proof. -intros e x. -generalize (Zpower_le_Zdigits e x). -omega. -Qed. - -Theorem Zpower_gt_Zdigits : - forall e x, - (Zdigits x <= e)%Z -> - (Zabs x < Zpower beta e)%Z. -Proof. -intros e x Hex. -destruct (Zdigits_correct x) as [H1 H2]. -apply Zlt_le_trans with (1 := H2). -now apply Zpower_le. -Qed. - -Theorem Zdigits_gt_Zpower : - forall e x, - (Zpower beta e <= Zabs x)%Z -> - (e < Zdigits x)%Z. -Proof. -intros e x Hex. -generalize (Zpower_gt_Zdigits e x). -omega. -Qed. - -(** Number of digits of a product. - -This strong version is needed for proofs of division and square root -algorithms, since they involve operation remainders. -*) - -Theorem Zdigits_mult_strong : - forall x y, - (0 <= x)%Z -> (0 <= y)%Z -> - (Zdigits (x + y + x * y) <= Zdigits x + Zdigits y)%Z. -Proof. -intros x y Hx Hy. -apply Zdigits_le_Zpower. -rewrite Zabs_eq. -apply Zlt_le_trans with ((x + 1) * (y + 1))%Z. -ring_simplify. -apply Zle_lt_succ, Zle_refl. -rewrite Zpower_plus by apply Zdigits_ge_0. -apply Zmult_le_compat. -apply Zlt_le_succ. -rewrite <- (Zabs_eq x) at 1 by easy. -apply Zdigits_correct. -apply Zlt_le_succ. -rewrite <- (Zabs_eq y) at 1 by easy. -apply Zdigits_correct. -clear -Hx ; omega. -clear -Hy ; omega. -change Z0 with (0 + 0 + 0)%Z. -apply Zplus_le_compat. -now apply Zplus_le_compat. -now apply Zmult_le_0_compat. -Qed. - -Theorem Zdigits_mult : - forall x y, - (Zdigits (x * y) <= Zdigits x + Zdigits y)%Z. -Proof. -intros x y. -rewrite <- Zdigits_abs. -rewrite <- (Zdigits_abs x). -rewrite <- (Zdigits_abs y). -apply Zle_trans with (Zdigits (Zabs x + Zabs y + Zabs x * Zabs y)). -apply Zdigits_le. -apply Zabs_pos. -rewrite Zabs_Zmult. -generalize (Zabs_pos x) (Zabs_pos y). -omega. -apply Zdigits_mult_strong ; apply Zabs_pos. -Qed. - -Theorem Zdigits_mult_ge : - forall x y, - (x <> 0)%Z -> (y <> 0)%Z -> - (Zdigits x + Zdigits y - 1 <= Zdigits (x * y))%Z. -Proof. -intros x y Zx Zy. -cut ((Zdigits x - 1) + (Zdigits y - 1) < Zdigits (x * y))%Z. omega. -apply Zdigits_gt_Zpower. -rewrite Zabs_Zmult. -rewrite Zpower_exp. -apply Zmult_le_compat. -apply Zpower_le_Zdigits. -apply Zlt_pred. -apply Zpower_le_Zdigits. -apply Zlt_pred. -apply Zpower_ge_0. -apply Zpower_ge_0. -generalize (Zdigits_gt_0 x). omega. -generalize (Zdigits_gt_0 y). omega. -Qed. - -Theorem Zdigits_div_Zpower : - forall m e, - (0 <= m)%Z -> - (0 <= e <= Zdigits m)%Z -> - Zdigits (m / Zpower beta e) = (Zdigits m - e)%Z. -Proof. -intros m e Hm He. -assert (H := Zdigits_correct m). -apply Zdigits_unique. -destruct (Zle_lt_or_eq _ _ (proj2 He)) as [He'|He']. - rewrite Zabs_eq in H by easy. - destruct H as [H1 H2]. - rewrite Zabs_eq. - split. - replace (Zdigits m - e - 1)%Z with (Zdigits m - 1 - e)%Z by ring. - rewrite Z.pow_sub_r. - 2: apply Zgt_not_eq, radix_gt_0. - 2: clear -He He' ; omega. - apply Z_div_le with (2 := H1). - now apply Zlt_gt, Zpower_gt_0. - apply Zmult_lt_reg_r with (Zpower beta e). - now apply Zpower_gt_0. - apply Zle_lt_trans with m. - rewrite Zmult_comm. - apply Z_mult_div_ge. - now apply Zlt_gt, Zpower_gt_0. - rewrite <- Zpower_plus. - now replace (Zdigits m - e + e)%Z with (Zdigits m) by ring. - now apply Zle_minus_le_0. - apply He. - apply Z_div_pos with (2 := Hm). - now apply Zlt_gt, Zpower_gt_0. -rewrite He'. -rewrite (Zeq_minus _ (Zdigits m)) by reflexivity. -simpl. -rewrite Zdiv_small. -easy. -split. -exact Hm. -now rewrite <- (Zabs_eq m) at 1. -Qed. - -End Fcore_digits. - -(** Specialized version for computing the number of bits of an integer *) - -Section Zdigits2. - -Theorem Z_of_nat_S_digits2_Pnat : - forall m : positive, - Z_of_nat (S (digits2_Pnat m)) = Zdigits radix2 (Zpos m). -Proof. -intros m. -apply eq_sym, Zdigits_unique. -rewrite <- Zpower_nat_Z. -rewrite Nat2Z.inj_succ. -change (_ - 1)%Z with (Zpred (Zsucc (Z.of_nat (digits2_Pnat m)))). -rewrite <- Zpred_succ. -rewrite <- Zpower_nat_Z. -apply digits2_Pnat_correct. -Qed. - -Fixpoint digits2_pos (n : positive) : positive := - match n with - | xH => xH - | xO p => Psucc (digits2_pos p) - | xI p => Psucc (digits2_pos p) - end. - -Theorem Zpos_digits2_pos : - forall m : positive, - Zpos (digits2_pos m) = Zdigits radix2 (Zpos m). -Proof. -intros m. -rewrite <- Z_of_nat_S_digits2_Pnat. -unfold Z.of_nat. -apply f_equal. -induction m ; simpl ; try easy ; - apply f_equal, IHm. -Qed. - -Definition Zdigits2 n := - match n with - | Z0 => n - | Zpos p => Zpos (digits2_pos p) - | Zneg p => Zpos (digits2_pos p) - end. - -Lemma Zdigits2_Zdigits : - forall n, Zdigits2 n = Zdigits radix2 n. -Proof. -intros [|p|p] ; try easy ; - apply Zpos_digits2_pos. -Qed. - -End Zdigits2. diff --git a/flocq/Core/Fcore_float_prop.v b/flocq/Core/Fcore_float_prop.v deleted file mode 100644 index a183bf0a..00000000 --- a/flocq/Core/Fcore_float_prop.v +++ /dev/null @@ -1,519 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2010-2013 Sylvie Boldo -#
# -Copyright (C) 2010-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** * Basic properties of floating-point formats: lemmas about mantissa, exponent... *) -Require Import Fcore_Raux. -Require Import Fcore_defs. - -Section Float_prop. - -Variable beta : radix. - -Notation bpow e := (bpow beta e). - -Theorem Rcompare_F2R : - forall e m1 m2 : Z, - Rcompare (F2R (Float beta m1 e)) (F2R (Float beta m2 e)) = Zcompare m1 m2. -Proof. -intros e m1 m2. -unfold F2R. simpl. -rewrite Rcompare_mult_r. -apply Rcompare_Z2R. -apply bpow_gt_0. -Qed. - -(** Basic facts *) -Theorem F2R_le_reg : - forall e m1 m2 : Z, - (F2R (Float beta m1 e) <= F2R (Float beta m2 e))%R -> - (m1 <= m2)%Z. -Proof. -intros e m1 m2 H. -apply le_Z2R. -apply Rmult_le_reg_r with (bpow e). -apply bpow_gt_0. -exact H. -Qed. - -Theorem F2R_le_compat : - forall m1 m2 e : Z, - (m1 <= m2)%Z -> - (F2R (Float beta m1 e) <= F2R (Float beta m2 e))%R. -Proof. -intros m1 m2 e H. -unfold F2R. simpl. -apply Rmult_le_compat_r. -apply bpow_ge_0. -now apply Z2R_le. -Qed. - -Theorem F2R_lt_reg : - forall e m1 m2 : Z, - (F2R (Float beta m1 e) < F2R (Float beta m2 e))%R -> - (m1 < m2)%Z. -Proof. -intros e m1 m2 H. -apply lt_Z2R. -apply Rmult_lt_reg_r with (bpow e). -apply bpow_gt_0. -exact H. -Qed. - -Theorem F2R_lt_compat : - forall e m1 m2 : Z, - (m1 < m2)%Z -> - (F2R (Float beta m1 e) < F2R (Float beta m2 e))%R. -Proof. -intros e m1 m2 H. -unfold F2R. simpl. -apply Rmult_lt_compat_r. -apply bpow_gt_0. -now apply Z2R_lt. -Qed. - -Theorem F2R_eq_compat : - forall e m1 m2 : Z, - (m1 = m2)%Z -> - (F2R (Float beta m1 e) = F2R (Float beta m2 e))%R. -Proof. -intros e m1 m2 H. -now apply (f_equal (fun m => F2R (Float beta m e))). -Qed. - -Theorem F2R_eq_reg : - forall e m1 m2 : Z, - F2R (Float beta m1 e) = F2R (Float beta m2 e) -> - m1 = m2. -Proof. -intros e m1 m2 H. -apply Zle_antisym ; - apply F2R_le_reg with e ; - rewrite H ; - apply Rle_refl. -Qed. - -Theorem F2R_Zabs: - forall m e : Z, - F2R (Float beta (Zabs m) e) = Rabs (F2R (Float beta m e)). -Proof. -intros m e. -unfold F2R. -rewrite Rabs_mult. -rewrite <- Z2R_abs. -simpl. -apply f_equal. -apply sym_eq; apply Rabs_right. -apply Rle_ge. -apply bpow_ge_0. -Qed. - -Theorem F2R_Zopp : - forall m e : Z, - F2R (Float beta (Zopp m) e) = Ropp (F2R (Float beta m e)). -Proof. -intros m e. -unfold F2R. simpl. -rewrite <- Ropp_mult_distr_l_reverse. -now rewrite Z2R_opp. -Qed. - -(** Sign facts *) -Theorem F2R_0 : - forall e : Z, - F2R (Float beta 0 e) = 0%R. -Proof. -intros e. -unfold F2R. simpl. -apply Rmult_0_l. -Qed. - -Theorem F2R_eq_0_reg : - forall m e : Z, - F2R (Float beta m e) = 0%R -> - m = Z0. -Proof. -intros m e H. -apply F2R_eq_reg with e. -now rewrite F2R_0. -Qed. - -Theorem F2R_ge_0_reg : - forall m e : Z, - (0 <= F2R (Float beta m e))%R -> - (0 <= m)%Z. -Proof. -intros m e H. -apply F2R_le_reg with e. -now rewrite F2R_0. -Qed. - -Theorem F2R_le_0_reg : - forall m e : Z, - (F2R (Float beta m e) <= 0)%R -> - (m <= 0)%Z. -Proof. -intros m e H. -apply F2R_le_reg with e. -now rewrite F2R_0. -Qed. - -Theorem F2R_gt_0_reg : - forall m e : Z, - (0 < F2R (Float beta m e))%R -> - (0 < m)%Z. -Proof. -intros m e H. -apply F2R_lt_reg with e. -now rewrite F2R_0. -Qed. - -Theorem F2R_lt_0_reg : - forall m e : Z, - (F2R (Float beta m e) < 0)%R -> - (m < 0)%Z. -Proof. -intros m e H. -apply F2R_lt_reg with e. -now rewrite F2R_0. -Qed. - -Theorem F2R_ge_0_compat : - forall f : float beta, - (0 <= Fnum f)%Z -> - (0 <= F2R f)%R. -Proof. -intros f H. -rewrite <- F2R_0 with (Fexp f). -now apply F2R_le_compat. -Qed. - -Theorem F2R_le_0_compat : - forall f : float beta, - (Fnum f <= 0)%Z -> - (F2R f <= 0)%R. -Proof. -intros f H. -rewrite <- F2R_0 with (Fexp f). -now apply F2R_le_compat. -Qed. - -Theorem F2R_gt_0_compat : - forall f : float beta, - (0 < Fnum f)%Z -> - (0 < F2R f)%R. -Proof. -intros f H. -rewrite <- F2R_0 with (Fexp f). -now apply F2R_lt_compat. -Qed. - -Theorem F2R_lt_0_compat : - forall f : float beta, - (Fnum f < 0)%Z -> - (F2R f < 0)%R. -Proof. -intros f H. -rewrite <- F2R_0 with (Fexp f). -now apply F2R_lt_compat. -Qed. - -Theorem F2R_neq_0_compat : - forall f : float beta, - (Fnum f <> 0)%Z -> - (F2R f <> 0)%R. -Proof. -intros f H H1. -apply H. -now apply F2R_eq_0_reg with (Fexp f). -Qed. - - -Lemma Fnum_ge_0_compat: forall (f : float beta), - (0 <= F2R f)%R -> (0 <= Fnum f)%Z. -Proof. -intros f H. -case (Zle_or_lt 0 (Fnum f)); trivial. -intros H1; contradict H. -apply Rlt_not_le. -now apply F2R_lt_0_compat. -Qed. - -Lemma Fnum_le_0_compat: forall (f : float beta), - (F2R f <= 0)%R -> (Fnum f <= 0)%Z. -Proof. -intros f H. -case (Zle_or_lt (Fnum f) 0); trivial. -intros H1; contradict H. -apply Rlt_not_le. -now apply F2R_gt_0_compat. -Qed. - -(** Floats and bpow *) -Theorem F2R_bpow : - forall e : Z, - F2R (Float beta 1 e) = bpow e. -Proof. -intros e. -unfold F2R. simpl. -apply Rmult_1_l. -Qed. - -Theorem bpow_le_F2R : - forall m e : Z, - (0 < m)%Z -> - (bpow e <= F2R (Float beta m e))%R. -Proof. -intros m e H. -rewrite <- F2R_bpow. -apply F2R_le_compat. -now apply (Zlt_le_succ 0). -Qed. - -Theorem F2R_p1_le_bpow : - forall m e1 e2 : Z, - (0 < m)%Z -> - (F2R (Float beta m e1) < bpow e2)%R -> - (F2R (Float beta (m + 1) e1) <= bpow e2)%R. -Proof. -intros m e1 e2 Hm. -intros H. -assert (He : (e1 <= e2)%Z). -(* . *) -apply (le_bpow beta). -apply Rle_trans with (F2R (Float beta m e1)). -unfold F2R. simpl. -rewrite <- (Rmult_1_l (bpow e1)) at 1. -apply Rmult_le_compat_r. -apply bpow_ge_0. -apply (Z2R_le 1). -now apply (Zlt_le_succ 0). -now apply Rlt_le. -(* . *) -revert H. -replace e2 with (e2 - e1 + e1)%Z by ring. -rewrite bpow_plus. -unfold F2R. simpl. -rewrite <- (Z2R_Zpower beta (e2 - e1)). -intros H. -apply Rmult_le_compat_r. -apply bpow_ge_0. -apply Rmult_lt_reg_r in H. -apply Z2R_le. -apply Zlt_le_succ. -now apply lt_Z2R. -apply bpow_gt_0. -now apply Zle_minus_le_0. -Qed. - -Theorem bpow_le_F2R_m1 : - forall m e1 e2 : Z, - (1 < m)%Z -> - (bpow e2 < F2R (Float beta m e1))%R -> - (bpow e2 <= F2R (Float beta (m - 1) e1))%R. -Proof. -intros m e1 e2 Hm. -case (Zle_or_lt e1 e2); intros He. -replace e2 with (e2 - e1 + e1)%Z by ring. -rewrite bpow_plus. -unfold F2R. simpl. -rewrite <- (Z2R_Zpower beta (e2 - e1)). -intros H. -apply Rmult_le_compat_r. -apply bpow_ge_0. -apply Rmult_lt_reg_r in H. -apply Z2R_le. -rewrite (Zpred_succ (Zpower _ _)). -apply Zplus_le_compat_r. -apply Zlt_le_succ. -now apply lt_Z2R. -apply bpow_gt_0. -now apply Zle_minus_le_0. -intros H. -apply Rle_trans with (1*bpow e1)%R. -rewrite Rmult_1_l. -apply bpow_le. -now apply Zlt_le_weak. -unfold F2R. simpl. -apply Rmult_le_compat_r. -apply bpow_ge_0. -replace 1%R with (Z2R 1) by reflexivity. -apply Z2R_le. -omega. -Qed. - -Theorem F2R_lt_bpow : - forall f : float beta, forall e', - (Zabs (Fnum f) < Zpower beta (e' - Fexp f))%Z -> - (Rabs (F2R f) < bpow e')%R. -Proof. -intros (m, e) e' Hm. -rewrite <- F2R_Zabs. -destruct (Zle_or_lt e e') as [He|He]. -unfold F2R. simpl. -apply Rmult_lt_reg_r with (bpow (-e)). -apply bpow_gt_0. -rewrite Rmult_assoc, <- 2!bpow_plus, Zplus_opp_r, Rmult_1_r. -rewrite <-Z2R_Zpower. 2: now apply Zle_left. -now apply Z2R_lt. -elim Zlt_not_le with (1 := Hm). -simpl. -cut (e' - e < 0)%Z. 2: omega. -clear. -case (e' - e)%Z ; try easy. -intros p _. -apply Zabs_pos. -Qed. - -Theorem F2R_change_exp : - forall e' m e : Z, - (e' <= e)%Z -> - F2R (Float beta m e) = F2R (Float beta (m * Zpower beta (e - e')) e'). -Proof. -intros e' m e He. -unfold F2R. simpl. -rewrite Z2R_mult, Z2R_Zpower, Rmult_assoc. -apply f_equal. -pattern e at 1 ; replace e with (e - e' + e')%Z by ring. -apply bpow_plus. -now apply Zle_minus_le_0. -Qed. - -Theorem F2R_prec_normalize : - forall m e e' p : Z, - (Zabs m < Zpower beta p)%Z -> - (bpow (e' - 1)%Z <= Rabs (F2R (Float beta m e)))%R -> - F2R (Float beta m e) = F2R (Float beta (m * Zpower beta (e - e' + p)) (e' - p)). -Proof. -intros m e e' p Hm Hf. -assert (Hp: (0 <= p)%Z). -destruct p ; try easy. -now elim (Zle_not_lt _ _ (Zabs_pos m)). -(* . *) -replace (e - e' + p)%Z with (e - (e' - p))%Z by ring. -apply F2R_change_exp. -cut (e' - 1 < e + p)%Z. omega. -apply (lt_bpow beta). -apply Rle_lt_trans with (1 := Hf). -rewrite <- F2R_Zabs, Zplus_comm, bpow_plus. -apply Rmult_lt_compat_r. -apply bpow_gt_0. -rewrite <- Z2R_Zpower. -now apply Z2R_lt. -exact Hp. -Qed. - -(** Floats and ln_beta *) -Theorem ln_beta_F2R_bounds : - forall x m e, (0 < m)%Z -> - (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R -> - ln_beta beta x = ln_beta beta (F2R (Float beta m e)) :> Z. -Proof. -intros x m e Hp (Hx,Hx2). -destruct (ln_beta beta (F2R (Float beta m e))) as (ex, He). -simpl. -apply ln_beta_unique. -assert (Hp1: (0 < F2R (Float beta m e))%R). -now apply F2R_gt_0_compat. -specialize (He (Rgt_not_eq _ _ Hp1)). -rewrite Rabs_pos_eq in He. 2: now apply Rlt_le. -destruct He as (He1, He2). -assert (Hx1: (0 < x)%R). -now apply Rlt_le_trans with (2 := Hx). -rewrite Rabs_pos_eq. 2: now apply Rlt_le. -split. -now apply Rle_trans with (1 := He1). -apply Rlt_le_trans with (1 := Hx2). -now apply F2R_p1_le_bpow. -Qed. - -Theorem ln_beta_F2R : - forall m e : Z, - m <> Z0 -> - (ln_beta beta (F2R (Float beta m e)) = ln_beta beta (Z2R m) + e :> Z)%Z. -Proof. -intros m e H. -unfold F2R ; simpl. -apply ln_beta_mult_bpow. -exact (Z2R_neq m 0 H). -Qed. - -Theorem float_distribution_pos : - forall m1 e1 m2 e2 : Z, - (0 < m1)%Z -> - (F2R (Float beta m1 e1) < F2R (Float beta m2 e2) < F2R (Float beta (m1 + 1) e1))%R -> - (e2 < e1)%Z /\ (e1 + ln_beta beta (Z2R m1) = e2 + ln_beta beta (Z2R m2))%Z. -Proof. -intros m1 e1 m2 e2 Hp1 (H12, H21). -assert (He: (e2 < e1)%Z). -(* . *) -apply Znot_ge_lt. -intros H0. -elim Rlt_not_le with (1 := H21). -apply Zge_le in H0. -apply (F2R_change_exp e1 m2 e2) in H0. -rewrite H0. -apply F2R_le_compat. -apply Zlt_le_succ. -apply (F2R_lt_reg e1). -now rewrite <- H0. -(* . *) -split. -exact He. -rewrite (Zplus_comm e1), (Zplus_comm e2). -assert (Hp2: (0 < m2)%Z). -apply (F2R_gt_0_reg m2 e2). -apply Rlt_trans with (2 := H12). -now apply F2R_gt_0_compat. -rewrite <- 2!ln_beta_F2R. -destruct (ln_beta beta (F2R (Float beta m1 e1))) as (e1', H1). -simpl. -apply sym_eq. -apply ln_beta_unique. -assert (H2 : (bpow (e1' - 1) <= F2R (Float beta m1 e1) < bpow e1')%R). -rewrite <- (Zabs_eq m1), F2R_Zabs. -apply H1. -apply Rgt_not_eq. -apply Rlt_gt. -now apply F2R_gt_0_compat. -now apply Zlt_le_weak. -clear H1. -rewrite <- F2R_Zabs, Zabs_eq. -split. -apply Rlt_le. -apply Rle_lt_trans with (2 := H12). -apply H2. -apply Rlt_le_trans with (1 := H21). -now apply F2R_p1_le_bpow. -now apply Zlt_le_weak. -apply sym_not_eq. -now apply Zlt_not_eq. -apply sym_not_eq. -now apply Zlt_not_eq. -Qed. - -Theorem F2R_cond_Zopp : - forall b m e, - F2R (Float beta (cond_Zopp b m) e) = cond_Ropp b (F2R (Float beta m e)). -Proof. -intros [|] m e ; unfold F2R ; simpl. -now rewrite Z2R_opp, Ropp_mult_distr_l_reverse. -apply refl_equal. -Qed. - -End Float_prop. diff --git a/flocq/Core/Fcore_generic_fmt.v b/flocq/Core/Fcore_generic_fmt.v deleted file mode 100644 index 668b4da2..00000000 --- a/flocq/Core/Fcore_generic_fmt.v +++ /dev/null @@ -1,2351 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2010-2013 Sylvie Boldo -#
# -Copyright (C) 2010-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** * What is a real number belonging to a format, and many properties. *) -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_rnd. -Require Import Fcore_float_prop. - -Section Generic. - -Variable beta : radix. - -Notation bpow e := (bpow beta e). - -Section Format. - -Variable fexp : Z -> Z. - -(** To be a good fexp *) - -Class Valid_exp := - valid_exp : - forall k : Z, - ( (fexp k < k)%Z -> (fexp (k + 1) <= k)%Z ) /\ - ( (k <= fexp k)%Z -> - (fexp (fexp k + 1) <= fexp k)%Z /\ - forall l : Z, (l <= fexp k)%Z -> fexp l = fexp k ). - -Context { valid_exp_ : Valid_exp }. - -Theorem valid_exp_large : - forall k l, - (fexp k < k)%Z -> (k <= l)%Z -> - (fexp l < l)%Z. -Proof. -intros k l Hk H. -apply Znot_ge_lt. -intros Hl. -apply Zge_le in Hl. -assert (H' := proj2 (proj2 (valid_exp l) Hl) k). -omega. -Qed. - -Theorem valid_exp_large' : - forall k l, - (fexp k < k)%Z -> (l <= k)%Z -> - (fexp l < k)%Z. -Proof. -intros k l Hk H. -apply Znot_ge_lt. -intros H'. -apply Zge_le in H'. -assert (Hl := Zle_trans _ _ _ H H'). -apply valid_exp in Hl. -assert (H1 := proj2 Hl k H'). -omega. -Qed. - -Definition canonic_exp x := - fexp (ln_beta beta x). - -Definition canonic (f : float beta) := - Fexp f = canonic_exp (F2R f). - -Definition scaled_mantissa x := - (x * bpow (- canonic_exp x))%R. - -Definition generic_format (x : R) := - x = F2R (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x)). - -(** Basic facts *) -Theorem generic_format_0 : - generic_format 0. -Proof. -unfold generic_format, scaled_mantissa. -rewrite Rmult_0_l. -change (Ztrunc 0) with (Ztrunc (Z2R 0)). -now rewrite Ztrunc_Z2R, F2R_0. -Qed. - -Theorem canonic_exp_opp : - forall x, - canonic_exp (-x) = canonic_exp x. -Proof. -intros x. -unfold canonic_exp. -now rewrite ln_beta_opp. -Qed. - -Theorem canonic_exp_abs : - forall x, - canonic_exp (Rabs x) = canonic_exp x. -Proof. -intros x. -unfold canonic_exp. -now rewrite ln_beta_abs. -Qed. - -Theorem generic_format_bpow : - forall e, (fexp (e + 1) <= e)%Z -> - generic_format (bpow e). -Proof. -intros e H. -unfold generic_format, scaled_mantissa, canonic_exp. -rewrite ln_beta_bpow. -rewrite <- bpow_plus. -rewrite <- (Z2R_Zpower beta (e + - fexp (e + 1))). -rewrite Ztrunc_Z2R. -rewrite <- F2R_bpow. -rewrite F2R_change_exp with (1 := H). -now rewrite Zmult_1_l. -now apply Zle_minus_le_0. -Qed. - -Theorem generic_format_bpow' : - forall e, (fexp e <= e)%Z -> - generic_format (bpow e). -Proof. -intros e He. -apply generic_format_bpow. -destruct (Zle_lt_or_eq _ _ He). -now apply valid_exp_. -rewrite <- H. -apply valid_exp. -rewrite H. -apply Zle_refl. -Qed. - -Theorem generic_format_F2R : - forall m e, - ( m <> 0 -> canonic_exp (F2R (Float beta m e)) <= e )%Z -> - generic_format (F2R (Float beta m e)). -Proof. -intros m e. -destruct (Z_eq_dec m 0) as [Zm|Zm]. -intros _. -rewrite Zm, F2R_0. -apply generic_format_0. -unfold generic_format, scaled_mantissa. -set (e' := canonic_exp (F2R (Float beta m e))). -intros He. -specialize (He Zm). -unfold F2R at 3. simpl. -rewrite F2R_change_exp with (1 := He). -apply F2R_eq_compat. -rewrite Rmult_assoc, <- bpow_plus, <- Z2R_Zpower, <- Z2R_mult. -now rewrite Ztrunc_Z2R. -now apply Zle_left. -Qed. - -Lemma generic_format_F2R': forall (x:R) (f:float beta), - F2R f = x -> ((x <> 0)%R -> - (canonic_exp x <= Fexp f)%Z) -> - generic_format x. -Proof. -intros x f H1 H2. -rewrite <- H1; destruct f as (m,e). -apply generic_format_F2R. -simpl in *; intros H3. -rewrite H1; apply H2. -intros Y; apply H3. -apply F2R_eq_0_reg with beta e. -now rewrite H1. -Qed. - - -Theorem canonic_opp : - forall m e, - canonic (Float beta m e) -> - canonic (Float beta (-m) e). -Proof. -intros m e H. -unfold canonic. -now rewrite F2R_Zopp, canonic_exp_opp. -Qed. - -Theorem canonic_abs : - forall m e, - canonic (Float beta m e) -> - canonic (Float beta (Zabs m) e). -Proof. -intros m e H. -unfold canonic. -now rewrite F2R_Zabs, canonic_exp_abs. -Qed. - -Theorem canonic_0: canonic (Float beta 0 (fexp (ln_beta beta 0%R))). -Proof. -unfold canonic; simpl; unfold canonic_exp. -replace (F2R {| Fnum := 0; Fexp := fexp (ln_beta beta 0) |}) with 0%R. -reflexivity. -unfold F2R; simpl; ring. -Qed. - - - -Theorem canonic_unicity : - forall f1 f2, - canonic f1 -> - canonic f2 -> - F2R f1 = F2R f2 -> - f1 = f2. -Proof. -intros (m1, e1) (m2, e2). -unfold canonic. simpl. -intros H1 H2 H. -rewrite H in H1. -rewrite <- H2 in H1. clear H2. -rewrite H1 in H |- *. -apply (f_equal (fun m => Float beta m e2)). -apply F2R_eq_reg with (1 := H). -Qed. - -Theorem scaled_mantissa_generic : - forall x, - generic_format x -> - scaled_mantissa x = Z2R (Ztrunc (scaled_mantissa x)). -Proof. -intros x Hx. -unfold scaled_mantissa. -pattern x at 1 3 ; rewrite Hx. -unfold F2R. simpl. -rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r. -now rewrite Ztrunc_Z2R. -Qed. - -Theorem scaled_mantissa_mult_bpow : - forall x, - (scaled_mantissa x * bpow (canonic_exp x))%R = x. -Proof. -intros x. -unfold scaled_mantissa. -rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_l. -apply Rmult_1_r. -Qed. - -Theorem scaled_mantissa_0 : - scaled_mantissa 0 = 0%R. -Proof. -apply Rmult_0_l. -Qed. - -Theorem scaled_mantissa_opp : - forall x, - scaled_mantissa (-x) = (-scaled_mantissa x)%R. -Proof. -intros x. -unfold scaled_mantissa. -rewrite canonic_exp_opp. -now rewrite Ropp_mult_distr_l_reverse. -Qed. - -Theorem scaled_mantissa_abs : - forall x, - scaled_mantissa (Rabs x) = Rabs (scaled_mantissa x). -Proof. -intros x. -unfold scaled_mantissa. -rewrite canonic_exp_abs, Rabs_mult. -apply f_equal. -apply sym_eq. -apply Rabs_pos_eq. -apply bpow_ge_0. -Qed. - -Theorem generic_format_opp : - forall x, generic_format x -> generic_format (-x). -Proof. -intros x Hx. -unfold generic_format. -rewrite scaled_mantissa_opp, canonic_exp_opp. -rewrite Ztrunc_opp. -rewrite F2R_Zopp. -now apply f_equal. -Qed. - -Theorem generic_format_abs : - forall x, generic_format x -> generic_format (Rabs x). -Proof. -intros x Hx. -unfold generic_format. -rewrite scaled_mantissa_abs, canonic_exp_abs. -rewrite Ztrunc_abs. -rewrite F2R_Zabs. -now apply f_equal. -Qed. - -Theorem generic_format_abs_inv : - forall x, generic_format (Rabs x) -> generic_format x. -Proof. -intros x. -unfold generic_format, Rabs. -case Rcase_abs ; intros _. -rewrite scaled_mantissa_opp, canonic_exp_opp, Ztrunc_opp. -intros H. -rewrite <- (Ropp_involutive x) at 1. -rewrite H, F2R_Zopp. -apply Ropp_involutive. -easy. -Qed. - -Theorem canonic_exp_fexp : - forall x ex, - (bpow (ex - 1) <= Rabs x < bpow ex)%R -> - canonic_exp x = fexp ex. -Proof. -intros x ex Hx. -unfold canonic_exp. -now rewrite ln_beta_unique with (1 := Hx). -Qed. - -Theorem canonic_exp_fexp_pos : - forall x ex, - (bpow (ex - 1) <= x < bpow ex)%R -> - canonic_exp x = fexp ex. -Proof. -intros x ex Hx. -apply canonic_exp_fexp. -rewrite Rabs_pos_eq. -exact Hx. -apply Rle_trans with (2 := proj1 Hx). -apply bpow_ge_0. -Qed. - -(** Properties when the real number is "small" (kind of subnormal) *) -Theorem mantissa_small_pos : - forall x ex, - (bpow (ex - 1) <= x < bpow ex)%R -> - (ex <= fexp ex)%Z -> - (0 < x * bpow (- fexp ex) < 1)%R. -Proof. -intros x ex Hx He. -split. -apply Rmult_lt_0_compat. -apply Rlt_le_trans with (2 := proj1 Hx). -apply bpow_gt_0. -apply bpow_gt_0. -apply Rmult_lt_reg_r with (bpow (fexp ex)). -apply bpow_gt_0. -rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_l. -rewrite Rmult_1_r, Rmult_1_l. -apply Rlt_le_trans with (1 := proj2 Hx). -now apply bpow_le. -Qed. - -Theorem scaled_mantissa_small : - forall x ex, - (Rabs x < bpow ex)%R -> - (ex <= fexp ex)%Z -> - (Rabs (scaled_mantissa x) < 1)%R. -Proof. -intros x ex Ex He. -destruct (Req_dec x 0) as [Zx|Zx]. -rewrite Zx, scaled_mantissa_0, Rabs_R0. -now apply (Z2R_lt 0 1). -rewrite <- scaled_mantissa_abs. -unfold scaled_mantissa. -rewrite canonic_exp_abs. -unfold canonic_exp. -destruct (ln_beta beta x) as (ex', Ex'). -simpl. -specialize (Ex' Zx). -apply (mantissa_small_pos _ _ Ex'). -assert (ex' <= fexp ex)%Z. -apply Zle_trans with (2 := He). -apply bpow_lt_bpow with beta. -now apply Rle_lt_trans with (2 := Ex). -now rewrite (proj2 (proj2 (valid_exp _) He)). -Qed. - -Theorem abs_scaled_mantissa_lt_bpow : - forall x, - (Rabs (scaled_mantissa x) < bpow (ln_beta beta x - canonic_exp x))%R. -Proof. -intros x. -destruct (Req_dec x 0) as [Zx|Zx]. -rewrite Zx, scaled_mantissa_0, Rabs_R0. -apply bpow_gt_0. -apply Rlt_le_trans with (1 := bpow_ln_beta_gt beta _). -apply bpow_le. -unfold scaled_mantissa. -rewrite ln_beta_mult_bpow with (1 := Zx). -apply Zle_refl. -Qed. - -Theorem ln_beta_generic_gt : - forall x, (x <> 0)%R -> - generic_format x -> - (canonic_exp x < ln_beta beta x)%Z. -Proof. -intros x Zx Gx. -apply Znot_ge_lt. -unfold canonic_exp. -destruct (ln_beta beta x) as (ex,Ex) ; simpl. -specialize (Ex Zx). -intros H. -apply Zge_le in H. -generalize (scaled_mantissa_small x ex (proj2 Ex) H). -contradict Zx. -rewrite Gx. -replace (Ztrunc (scaled_mantissa x)) with Z0. -apply F2R_0. -cut (Zabs (Ztrunc (scaled_mantissa x)) < 1)%Z. -clear ; zify ; omega. -apply lt_Z2R. -rewrite Z2R_abs. -now rewrite <- scaled_mantissa_generic. -Qed. - -Theorem mantissa_DN_small_pos : - forall x ex, - (bpow (ex - 1) <= x < bpow ex)%R -> - (ex <= fexp ex)%Z -> - Zfloor (x * bpow (- fexp ex)) = Z0. -Proof. -intros x ex Hx He. -apply Zfloor_imp. simpl. -assert (H := mantissa_small_pos x ex Hx He). -split ; try apply Rlt_le ; apply H. -Qed. - -Theorem mantissa_UP_small_pos : - forall x ex, - (bpow (ex - 1) <= x < bpow ex)%R -> - (ex <= fexp ex)%Z -> - Zceil (x * bpow (- fexp ex)) = 1%Z. -Proof. -intros x ex Hx He. -apply Zceil_imp. simpl. -assert (H := mantissa_small_pos x ex Hx He). -split ; try apply Rlt_le ; apply H. -Qed. - -(** Generic facts about any format *) -Theorem generic_format_discrete : - forall x m, - let e := canonic_exp x in - (F2R (Float beta m e) < x < F2R (Float beta (m + 1) e))%R -> - ~ generic_format x. -Proof. -intros x m e (Hx,Hx2) Hf. -apply Rlt_not_le with (1 := Hx2). clear Hx2. -rewrite Hf. -fold e. -apply F2R_le_compat. -apply Zlt_le_succ. -apply lt_Z2R. -rewrite <- scaled_mantissa_generic with (1 := Hf). -apply Rmult_lt_reg_r with (bpow e). -apply bpow_gt_0. -now rewrite scaled_mantissa_mult_bpow. -Qed. - -Theorem generic_format_canonic : - forall f, canonic f -> - generic_format (F2R f). -Proof. -intros (m, e) Hf. -unfold canonic in Hf. simpl in Hf. -unfold generic_format, scaled_mantissa. -rewrite <- Hf. -apply F2R_eq_compat. -unfold F2R. simpl. -rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r. -now rewrite Ztrunc_Z2R. -Qed. - -Theorem generic_format_ge_bpow : - forall emin, - ( forall e, (emin <= fexp e)%Z ) -> - forall x, - (0 < x)%R -> - generic_format x -> - (bpow emin <= x)%R. -Proof. -intros emin Emin x Hx Fx. -rewrite Fx. -apply Rle_trans with (bpow (fexp (ln_beta beta x))). -now apply bpow_le. -apply bpow_le_F2R. -apply F2R_gt_0_reg with beta (canonic_exp x). -now rewrite <- Fx. -Qed. - -Theorem abs_lt_bpow_prec: - forall prec, - (forall e, (e - prec <= fexp e)%Z) -> - (* OK with FLX, FLT and FTZ *) - forall x, - (Rabs x < bpow (prec + canonic_exp x))%R. -intros prec Hp x. -case (Req_dec x 0); intros Hxz. -rewrite Hxz, Rabs_R0. -apply bpow_gt_0. -unfold canonic_exp. -destruct (ln_beta beta x) as (ex,Ex) ; simpl. -specialize (Ex Hxz). -apply Rlt_le_trans with (1 := proj2 Ex). -apply bpow_le. -specialize (Hp ex). -omega. -Qed. - -Theorem generic_format_bpow_inv' : - forall e, - generic_format (bpow e) -> - (fexp (e + 1) <= e)%Z. -Proof. -intros e He. -apply Znot_gt_le. -contradict He. -unfold generic_format, scaled_mantissa, canonic_exp, F2R. simpl. -rewrite ln_beta_bpow, <- bpow_plus. -apply Rgt_not_eq. -rewrite Ztrunc_floor. -2: apply bpow_ge_0. -rewrite Zfloor_imp with (n := Z0). -rewrite Rmult_0_l. -apply bpow_gt_0. -split. -apply bpow_ge_0. -apply (bpow_lt _ _ 0). -clear -He ; omega. -Qed. - -Theorem generic_format_bpow_inv : - forall e, - generic_format (bpow e) -> - (fexp e <= e)%Z. -Proof. -intros e He. -apply generic_format_bpow_inv' in He. -assert (H := valid_exp_large' (e + 1) e). -omega. -Qed. - -Section Fcore_generic_round_pos. - -(** Rounding functions: R -> Z *) - -Variable rnd : R -> Z. - -Class Valid_rnd := { - Zrnd_le : forall x y, (x <= y)%R -> (rnd x <= rnd y)%Z ; - Zrnd_Z2R : forall n, rnd (Z2R n) = n -}. - -Context { valid_rnd : Valid_rnd }. - -Theorem Zrnd_DN_or_UP : - forall x, rnd x = Zfloor x \/ rnd x = Zceil x. -Proof. -intros x. -destruct (Zle_or_lt (rnd x) (Zfloor x)) as [Hx|Hx]. -left. -apply Zle_antisym with (1 := Hx). -rewrite <- (Zrnd_Z2R (Zfloor x)). -apply Zrnd_le. -apply Zfloor_lb. -right. -apply Zle_antisym. -rewrite <- (Zrnd_Z2R (Zceil x)). -apply Zrnd_le. -apply Zceil_ub. -rewrite Zceil_floor_neq. -omega. -intros H. -rewrite <- H in Hx. -rewrite Zfloor_Z2R, Zrnd_Z2R in Hx. -apply Zlt_irrefl with (1 := Hx). -Qed. - -Theorem Zrnd_ZR_or_AW : - forall x, rnd x = Ztrunc x \/ rnd x = Zaway x. -Proof. -intros x. -unfold Ztrunc, Zaway. -destruct (Zrnd_DN_or_UP x) as [Hx|Hx] ; - case Rlt_bool. -now right. -now left. -now left. -now right. -Qed. - -(** the most useful one: R -> F *) -Definition round x := - F2R (Float beta (rnd (scaled_mantissa x)) (canonic_exp x)). - -Theorem round_bounded_large_pos : - forall x ex, - (fexp ex < ex)%Z -> - (bpow (ex - 1) <= x < bpow ex)%R -> - (bpow (ex - 1) <= round x <= bpow ex)%R. -Proof. -intros x ex He Hx. -unfold round, scaled_mantissa. -rewrite (canonic_exp_fexp_pos _ _ Hx). -unfold F2R. simpl. -destruct (Zrnd_DN_or_UP (x * bpow (- fexp ex))) as [Hr|Hr] ; rewrite Hr. -(* DN *) -split. -replace (ex - 1)%Z with (ex - 1 + - fexp ex + fexp ex)%Z by ring. -rewrite bpow_plus. -apply Rmult_le_compat_r. -apply bpow_ge_0. -assert (Hf: Z2R (Zpower beta (ex - 1 - fexp ex)) = bpow (ex - 1 + - fexp ex)). -apply Z2R_Zpower. -omega. -rewrite <- Hf. -apply Z2R_le. -apply Zfloor_lub. -rewrite Hf. -rewrite bpow_plus. -apply Rmult_le_compat_r. -apply bpow_ge_0. -apply Hx. -apply Rle_trans with (2 := Rlt_le _ _ (proj2 Hx)). -apply Rmult_le_reg_r with (bpow (- fexp ex)). -apply bpow_gt_0. -rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r. -apply Zfloor_lb. -(* UP *) -split. -apply Rle_trans with (1 := proj1 Hx). -apply Rmult_le_reg_r with (bpow (- fexp ex)). -apply bpow_gt_0. -rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r. -apply Zceil_ub. -pattern ex at 3 ; replace ex with (ex - fexp ex + fexp ex)%Z by ring. -rewrite bpow_plus. -apply Rmult_le_compat_r. -apply bpow_ge_0. -assert (Hf: Z2R (Zpower beta (ex - fexp ex)) = bpow (ex - fexp ex)). -apply Z2R_Zpower. -omega. -rewrite <- Hf. -apply Z2R_le. -apply Zceil_glb. -rewrite Hf. -unfold Zminus. -rewrite bpow_plus. -apply Rmult_le_compat_r. -apply bpow_ge_0. -apply Rlt_le. -apply Hx. -Qed. - -Theorem round_bounded_small_pos : - forall x ex, - (ex <= fexp ex)%Z -> - (bpow (ex - 1) <= x < bpow ex)%R -> - round x = 0%R \/ round x = bpow (fexp ex). -Proof. -intros x ex He Hx. -unfold round, scaled_mantissa. -rewrite (canonic_exp_fexp_pos _ _ Hx). -unfold F2R. simpl. -destruct (Zrnd_DN_or_UP (x * bpow (-fexp ex))) as [Hr|Hr] ; rewrite Hr. -(* DN *) -left. -apply Rmult_eq_0_compat_r. -apply (@f_equal _ _ Z2R _ Z0). -apply Zfloor_imp. -refine (let H := _ in conj (Rlt_le _ _ (proj1 H)) (proj2 H)). -now apply mantissa_small_pos. -(* UP *) -right. -pattern (bpow (fexp ex)) at 2 ; rewrite <- Rmult_1_l. -apply (f_equal (fun m => (m * bpow (fexp ex))%R)). -apply (@f_equal _ _ Z2R _ 1%Z). -apply Zceil_imp. -refine (let H := _ in conj (proj1 H) (Rlt_le _ _ (proj2 H))). -now apply mantissa_small_pos. -Qed. - -Theorem round_le_pos : - forall x y, (0 < x)%R -> (x <= y)%R -> (round x <= round y)%R. -Proof. -intros x y Hx Hxy. -destruct (ln_beta beta x) as [ex Hex]. -destruct (ln_beta beta y) as [ey Hey]. -specialize (Hex (Rgt_not_eq _ _ Hx)). -specialize (Hey (Rgt_not_eq _ _ (Rlt_le_trans _ _ _ Hx Hxy))). -rewrite Rabs_pos_eq in Hex. -2: now apply Rlt_le. -rewrite Rabs_pos_eq in Hey. -2: apply Rle_trans with (2:=Hxy); now apply Rlt_le. -assert (He: (ex <= ey)%Z). - apply bpow_lt_bpow with beta. - apply Rle_lt_trans with (1 := proj1 Hex). - now apply Rle_lt_trans with y. -assert (Heq: fexp ex = fexp ey -> (round x <= round y)%R). - intros H. - unfold round, scaled_mantissa, canonic_exp. - rewrite ln_beta_unique_pos with (1 := Hex). - rewrite ln_beta_unique_pos with (1 := Hey). - rewrite H. - apply F2R_le_compat. - apply Zrnd_le. - apply Rmult_le_compat_r with (2 := Hxy). - apply bpow_ge_0. -destruct (Zle_or_lt ey (fexp ey)) as [Hy1|Hy1]. - apply Heq. - apply valid_exp with (1 := Hy1). - now apply Zle_trans with ey. -destruct (Zle_lt_or_eq _ _ He) as [He'|He']. -2: now apply Heq, f_equal. -apply Rle_trans with (bpow (ey - 1)). -2: now apply round_bounded_large_pos. -destruct (Zle_or_lt ex (fexp ex)) as [Hx1|Hx1]. - destruct (round_bounded_small_pos _ _ Hx1 Hex) as [-> | ->]. - apply bpow_ge_0. - apply bpow_le. - apply valid_exp, proj2 in Hx1. - specialize (Hx1 ey). - omega. -apply Rle_trans with (bpow ex). -now apply round_bounded_large_pos. -apply bpow_le. -now apply Z.lt_le_pred. -Qed. - -Theorem round_generic : - forall x, - generic_format x -> - round x = x. -Proof. -intros x Hx. -unfold round. -rewrite scaled_mantissa_generic with (1 := Hx). -rewrite Zrnd_Z2R. -now apply sym_eq. -Qed. - -Theorem round_0 : - round 0 = 0%R. -Proof. -unfold round, scaled_mantissa. -rewrite Rmult_0_l. -change 0%R with (Z2R 0). -rewrite Zrnd_Z2R. -apply F2R_0. -Qed. - -Theorem exp_small_round_0_pos : - forall x ex, - (bpow (ex - 1) <= x < bpow ex)%R -> - round x = 0%R -> (ex <= fexp ex)%Z . -Proof. -intros x ex H H1. -case (Zle_or_lt ex (fexp ex)); trivial; intros V. -contradict H1. -apply Rgt_not_eq. -apply Rlt_le_trans with (bpow (ex-1)). -apply bpow_gt_0. -apply (round_bounded_large_pos); assumption. -Qed. - -Theorem generic_format_round_pos : - forall x, - (0 < x)%R -> - generic_format (round x). -Proof. -intros x Hx0. -destruct (ln_beta beta x) as (ex, Hex). -specialize (Hex (Rgt_not_eq _ _ Hx0)). -rewrite Rabs_pos_eq in Hex. 2: now apply Rlt_le. -destruct (Zle_or_lt ex (fexp ex)) as [He|He]. -(* small *) -destruct (round_bounded_small_pos _ _ He Hex) as [Hr|Hr] ; rewrite Hr. -apply generic_format_0. -apply generic_format_bpow. -now apply valid_exp. -(* large *) -generalize (round_bounded_large_pos _ _ He Hex). -intros (Hr1, Hr2). -destruct (Rle_or_lt (bpow ex) (round x)) as [Hr|Hr]. -rewrite <- (Rle_antisym _ _ Hr Hr2). -apply generic_format_bpow. -now apply valid_exp. -apply generic_format_F2R. -intros _. -rewrite (canonic_exp_fexp_pos (F2R _) _ (conj Hr1 Hr)). -rewrite (canonic_exp_fexp_pos _ _ Hex). -now apply Zeq_le. -Qed. - -End Fcore_generic_round_pos. - -Theorem round_ext : - forall rnd1 rnd2, - ( forall x, rnd1 x = rnd2 x ) -> - forall x, - round rnd1 x = round rnd2 x. -Proof. -intros rnd1 rnd2 Hext x. -unfold round. -now rewrite Hext. -Qed. - -Section Zround_opp. - -Variable rnd : R -> Z. -Context { valid_rnd : Valid_rnd rnd }. - -Definition Zrnd_opp x := Zopp (rnd (-x)). - -Global Instance valid_rnd_opp : Valid_rnd Zrnd_opp. -Proof with auto with typeclass_instances. -split. -(* *) -intros x y Hxy. -unfold Zrnd_opp. -apply Zopp_le_cancel. -rewrite 2!Zopp_involutive. -apply Zrnd_le... -now apply Ropp_le_contravar. -(* *) -intros n. -unfold Zrnd_opp. -rewrite <- Z2R_opp, Zrnd_Z2R... -apply Zopp_involutive. -Qed. - -Theorem round_opp : - forall x, - round rnd (- x) = Ropp (round Zrnd_opp x). -Proof. -intros x. -unfold round. -rewrite <- F2R_Zopp, canonic_exp_opp, scaled_mantissa_opp. -apply F2R_eq_compat. -apply sym_eq. -exact (Zopp_involutive _). -Qed. - -End Zround_opp. - -(** IEEE-754 roundings: up, down and to zero *) - -Global Instance valid_rnd_DN : Valid_rnd Zfloor. -Proof. -split. -apply Zfloor_le. -apply Zfloor_Z2R. -Qed. - -Global Instance valid_rnd_UP : Valid_rnd Zceil. -Proof. -split. -apply Zceil_le. -apply Zceil_Z2R. -Qed. - -Global Instance valid_rnd_ZR : Valid_rnd Ztrunc. -Proof. -split. -apply Ztrunc_le. -apply Ztrunc_Z2R. -Qed. - -Global Instance valid_rnd_AW : Valid_rnd Zaway. -Proof. -split. -apply Zaway_le. -apply Zaway_Z2R. -Qed. - -Section monotone. - -Variable rnd : R -> Z. -Context { valid_rnd : Valid_rnd rnd }. - -Theorem round_DN_or_UP : - forall x, - round rnd x = round Zfloor x \/ round rnd x = round Zceil x. -Proof. -intros x. -unfold round. -destruct (Zrnd_DN_or_UP rnd (scaled_mantissa x)) as [Hx|Hx]. -left. now rewrite Hx. -right. now rewrite Hx. -Qed. - -Theorem round_ZR_or_AW : - forall x, - round rnd x = round Ztrunc x \/ round rnd x = round Zaway x. -Proof. -intros x. -unfold round. -destruct (Zrnd_ZR_or_AW rnd (scaled_mantissa x)) as [Hx|Hx]. -left. now rewrite Hx. -right. now rewrite Hx. -Qed. - -Theorem round_le : - forall x y, (x <= y)%R -> (round rnd x <= round rnd y)%R. -Proof with auto with typeclass_instances. -intros x y Hxy. -destruct (total_order_T x 0) as [[Hx|Hx]|Hx]. -3: now apply round_le_pos. -(* x < 0 *) -unfold round. -destruct (Rlt_or_le y 0) as [Hy|Hy]. -(* . y < 0 *) -rewrite <- (Ropp_involutive x), <- (Ropp_involutive y). -rewrite (scaled_mantissa_opp (-x)), (scaled_mantissa_opp (-y)). -rewrite (canonic_exp_opp (-x)), (canonic_exp_opp (-y)). -apply Ropp_le_cancel. -rewrite <- 2!F2R_Zopp. -apply (round_le_pos (Zrnd_opp rnd) (-y) (-x)). -rewrite <- Ropp_0. -now apply Ropp_lt_contravar. -now apply Ropp_le_contravar. -(* . 0 <= y *) -apply Rle_trans with 0%R. -apply F2R_le_0_compat. simpl. -rewrite <- (Zrnd_Z2R rnd 0). -apply Zrnd_le... -simpl. -rewrite <- (Rmult_0_l (bpow (- fexp (ln_beta beta x)))). -apply Rmult_le_compat_r. -apply bpow_ge_0. -now apply Rlt_le. -apply F2R_ge_0_compat. simpl. -rewrite <- (Zrnd_Z2R rnd 0). -apply Zrnd_le... -apply Rmult_le_pos. -exact Hy. -apply bpow_ge_0. -(* x = 0 *) -rewrite Hx. -rewrite round_0... -apply F2R_ge_0_compat. -simpl. -rewrite <- (Zrnd_Z2R rnd 0). -apply Zrnd_le... -apply Rmult_le_pos. -now rewrite <- Hx. -apply bpow_ge_0. -Qed. - -Theorem round_ge_generic : - forall x y, generic_format x -> (x <= y)%R -> (x <= round rnd y)%R. -Proof. -intros x y Hx Hxy. -rewrite <- (round_generic rnd x Hx). -now apply round_le. -Qed. - -Theorem round_le_generic : - forall x y, generic_format y -> (x <= y)%R -> (round rnd x <= y)%R. -Proof. -intros x y Hy Hxy. -rewrite <- (round_generic rnd y Hy). -now apply round_le. -Qed. - -End monotone. - -Theorem round_abs_abs : - forall P : R -> R -> Prop, - ( forall rnd (Hr : Valid_rnd rnd) x, (0 <= x)%R -> P x (round rnd x) ) -> - forall rnd {Hr : Valid_rnd rnd} x, P (Rabs x) (Rabs (round rnd x)). -Proof with auto with typeclass_instances. -intros P HP rnd Hr x. -destruct (Rle_or_lt 0 x) as [Hx|Hx]. -(* . *) -rewrite 2!Rabs_pos_eq. -now apply HP. -rewrite <- (round_0 rnd). -now apply round_le. -exact Hx. -(* . *) -rewrite (Rabs_left _ Hx). -rewrite Rabs_left1. -pattern x at 2 ; rewrite <- Ropp_involutive. -rewrite round_opp. -rewrite Ropp_involutive. -apply HP... -rewrite <- Ropp_0. -apply Ropp_le_contravar. -now apply Rlt_le. -rewrite <- (round_0 rnd). -apply round_le... -now apply Rlt_le. -Qed. - -Theorem round_bounded_large : - forall rnd {Hr : Valid_rnd rnd} x ex, - (fexp ex < ex)%Z -> - (bpow (ex - 1) <= Rabs x < bpow ex)%R -> - (bpow (ex - 1) <= Rabs (round rnd x) <= bpow ex)%R. -Proof with auto with typeclass_instances. -intros rnd Hr x ex He. -apply round_abs_abs... -clear rnd Hr x. -intros rnd' Hr x _. -apply round_bounded_large_pos... -Qed. - -Theorem exp_small_round_0 : - forall rnd {Hr : Valid_rnd rnd} x ex, - (bpow (ex - 1) <= Rabs x < bpow ex)%R -> - round rnd x = 0%R -> (ex <= fexp ex)%Z . -Proof. -intros rnd Hr x ex H1 H2. -generalize Rabs_R0. -rewrite <- H2 at 1. -apply (round_abs_abs (fun t rt => forall (ex : Z), -(bpow (ex - 1) <= t < bpow ex)%R -> -rt = 0%R -> (ex <= fexp ex)%Z)); trivial. -clear; intros rnd Hr x Hx. -now apply exp_small_round_0_pos. -Qed. - - - - -Section monotone_abs. - -Variable rnd : R -> Z. -Context { valid_rnd : Valid_rnd rnd }. - -Theorem abs_round_ge_generic : - forall x y, generic_format x -> (x <= Rabs y)%R -> (x <= Rabs (round rnd y))%R. -Proof with auto with typeclass_instances. -intros x y. -apply round_abs_abs... -clear rnd valid_rnd y. -intros rnd' Hrnd y Hy. -apply round_ge_generic... -Qed. - -Theorem abs_round_le_generic : - forall x y, generic_format y -> (Rabs x <= y)%R -> (Rabs (round rnd x) <= y)%R. -Proof with auto with typeclass_instances. -intros x y. -apply round_abs_abs... -clear rnd valid_rnd x. -intros rnd' Hrnd x Hx. -apply round_le_generic... -Qed. - -End monotone_abs. - -Theorem round_DN_opp : - forall x, - round Zfloor (-x) = (- round Zceil x)%R. -Proof. -intros x. -unfold round. -rewrite scaled_mantissa_opp. -rewrite <- F2R_Zopp. -unfold Zceil. -rewrite Zopp_involutive. -now rewrite canonic_exp_opp. -Qed. - -Theorem round_UP_opp : - forall x, - round Zceil (-x) = (- round Zfloor x)%R. -Proof. -intros x. -unfold round. -rewrite scaled_mantissa_opp. -rewrite <- F2R_Zopp. -unfold Zceil. -rewrite Ropp_involutive. -now rewrite canonic_exp_opp. -Qed. - -Theorem round_ZR_opp : - forall x, - round Ztrunc (- x) = Ropp (round Ztrunc x). -Proof. -intros x. -unfold round. -rewrite scaled_mantissa_opp, canonic_exp_opp, Ztrunc_opp. -apply F2R_Zopp. -Qed. - -Theorem round_ZR_abs : - forall x, - round Ztrunc (Rabs x) = Rabs (round Ztrunc x). -Proof with auto with typeclass_instances. -intros x. -apply sym_eq. -unfold Rabs at 2. -destruct (Rcase_abs x) as [Hx|Hx]. -rewrite round_ZR_opp. -apply Rabs_left1. -rewrite <- (round_0 Ztrunc). -apply round_le... -now apply Rlt_le. -apply Rabs_pos_eq. -rewrite <- (round_0 Ztrunc). -apply round_le... -now apply Rge_le. -Qed. - -Theorem round_AW_opp : - forall x, - round Zaway (- x) = Ropp (round Zaway x). -Proof. -intros x. -unfold round. -rewrite scaled_mantissa_opp, canonic_exp_opp, Zaway_opp. -apply F2R_Zopp. -Qed. - -Theorem round_AW_abs : - forall x, - round Zaway (Rabs x) = Rabs (round Zaway x). -Proof with auto with typeclass_instances. -intros x. -apply sym_eq. -unfold Rabs at 2. -destruct (Rcase_abs x) as [Hx|Hx]. -rewrite round_AW_opp. -apply Rabs_left1. -rewrite <- (round_0 Zaway). -apply round_le... -now apply Rlt_le. -apply Rabs_pos_eq. -rewrite <- (round_0 Zaway). -apply round_le... -now apply Rge_le. -Qed. - -Theorem round_ZR_pos : - forall x, - (0 <= x)%R -> - round Ztrunc x = round Zfloor x. -Proof. -intros x Hx. -unfold round, Ztrunc. -case Rlt_bool_spec. -intros H. -elim Rlt_not_le with (1 := H). -rewrite <- (Rmult_0_l (bpow (- canonic_exp x))). -apply Rmult_le_compat_r with (2 := Hx). -apply bpow_ge_0. -easy. -Qed. - -Theorem round_ZR_neg : - forall x, - (x <= 0)%R -> - round Ztrunc x = round Zceil x. -Proof. -intros x Hx. -unfold round, Ztrunc. -case Rlt_bool_spec. -easy. -intros [H|H]. -elim Rlt_not_le with (1 := H). -rewrite <- (Rmult_0_l (bpow (- canonic_exp x))). -apply Rmult_le_compat_r with (2 := Hx). -apply bpow_ge_0. -rewrite <- H. -change 0%R with (Z2R 0). -now rewrite Zfloor_Z2R, Zceil_Z2R. -Qed. - -Theorem round_AW_pos : - forall x, - (0 <= x)%R -> - round Zaway x = round Zceil x. -Proof. -intros x Hx. -unfold round, Zaway. -case Rlt_bool_spec. -intros H. -elim Rlt_not_le with (1 := H). -rewrite <- (Rmult_0_l (bpow (- canonic_exp x))). -apply Rmult_le_compat_r with (2 := Hx). -apply bpow_ge_0. -easy. -Qed. - -Theorem round_AW_neg : - forall x, - (x <= 0)%R -> - round Zaway x = round Zfloor x. -Proof. -intros x Hx. -unfold round, Zaway. -case Rlt_bool_spec. -easy. -intros [H|H]. -elim Rlt_not_le with (1 := H). -rewrite <- (Rmult_0_l (bpow (- canonic_exp x))). -apply Rmult_le_compat_r with (2 := Hx). -apply bpow_ge_0. -rewrite <- H. -change 0%R with (Z2R 0). -now rewrite Zfloor_Z2R, Zceil_Z2R. -Qed. - -Theorem generic_format_round : - forall rnd { Hr : Valid_rnd rnd } x, - generic_format (round rnd x). -Proof with auto with typeclass_instances. -intros rnd Zrnd x. -destruct (total_order_T x 0) as [[Hx|Hx]|Hx]. -rewrite <- (Ropp_involutive x). -destruct (round_DN_or_UP rnd (- - x)) as [Hr|Hr] ; rewrite Hr. -rewrite round_DN_opp. -apply generic_format_opp. -apply generic_format_round_pos... -now apply Ropp_0_gt_lt_contravar. -rewrite round_UP_opp. -apply generic_format_opp. -apply generic_format_round_pos... -now apply Ropp_0_gt_lt_contravar. -rewrite Hx. -rewrite round_0... -apply generic_format_0. -now apply generic_format_round_pos. -Qed. - -Theorem round_DN_pt : - forall x, - Rnd_DN_pt generic_format x (round Zfloor x). -Proof with auto with typeclass_instances. -intros x. -split. -apply generic_format_round... -split. -pattern x at 2 ; rewrite <- scaled_mantissa_mult_bpow. -unfold round, F2R. simpl. -apply Rmult_le_compat_r. -apply bpow_ge_0. -apply Zfloor_lb. -intros g Hg Hgx. -apply round_ge_generic... -Qed. - -Theorem generic_format_satisfies_any : - satisfies_any generic_format. -Proof. -split. -(* symmetric set *) -exact generic_format_0. -exact generic_format_opp. -(* round down *) -intros x. -eexists. -apply round_DN_pt. -Qed. - -Theorem round_UP_pt : - forall x, - Rnd_UP_pt generic_format x (round Zceil x). -Proof. -intros x. -rewrite <- (Ropp_involutive x). -rewrite round_UP_opp. -apply Rnd_DN_UP_pt_sym. -apply generic_format_opp. -apply round_DN_pt. -Qed. - -Theorem round_ZR_pt : - forall x, - Rnd_ZR_pt generic_format x (round Ztrunc x). -Proof. -intros x. -split ; intros Hx. -rewrite round_ZR_pos with (1 := Hx). -apply round_DN_pt. -rewrite round_ZR_neg with (1 := Hx). -apply round_UP_pt. -Qed. - -Theorem round_DN_small_pos : - forall x ex, - (bpow (ex - 1) <= x < bpow ex)%R -> - (ex <= fexp ex)%Z -> - round Zfloor x = 0%R. -Proof. -intros x ex Hx He. -rewrite <- (F2R_0 beta (canonic_exp x)). -rewrite <- mantissa_DN_small_pos with (1 := Hx) (2 := He). -now rewrite <- canonic_exp_fexp_pos with (1 := Hx). -Qed. - - -Theorem round_DN_UP_lt : - forall x, ~ generic_format x -> - (round Zfloor x < x < round Zceil x)%R. -Proof with auto with typeclass_instances. -intros x Fx. -assert (Hx:(round Zfloor x <= x <= round Zceil x)%R). -split. -apply round_DN_pt. -apply round_UP_pt. -split. - destruct Hx as [Hx _]. - apply Rnot_le_lt; intro Hle. - assert (x = round Zfloor x) by now apply Rle_antisym. - rewrite H in Fx. - contradict Fx. - apply generic_format_round... -destruct Hx as [_ Hx]. -apply Rnot_le_lt; intro Hle. -assert (x = round Zceil x) by now apply Rle_antisym. -rewrite H in Fx. -contradict Fx. -apply generic_format_round... -Qed. - -Theorem round_UP_small_pos : - forall x ex, - (bpow (ex - 1) <= x < bpow ex)%R -> - (ex <= fexp ex)%Z -> - round Zceil x = (bpow (fexp ex)). -Proof. -intros x ex Hx He. -rewrite <- F2R_bpow. -rewrite <- mantissa_UP_small_pos with (1 := Hx) (2 := He). -now rewrite <- canonic_exp_fexp_pos with (1 := Hx). -Qed. - -Theorem generic_format_EM : - forall x, - generic_format x \/ ~generic_format x. -Proof with auto with typeclass_instances. -intros x. -destruct (Req_dec (round Zfloor x) x) as [Hx|Hx]. -left. -rewrite <- Hx. -apply generic_format_round... -right. -intros H. -apply Hx. -apply round_generic... -Qed. - -Section round_large. - -Variable rnd : R -> Z. -Context { valid_rnd : Valid_rnd rnd }. - -Theorem round_large_pos_ge_pow : - forall x e, - (0 < round rnd x)%R -> - (bpow e <= x)%R -> - (bpow e <= round rnd x)%R. -Proof. -intros x e Hd Hex. -destruct (ln_beta beta x) as (ex, He). -assert (Hx: (0 < x)%R). -apply Rlt_le_trans with (2 := Hex). -apply bpow_gt_0. -specialize (He (Rgt_not_eq _ _ Hx)). -rewrite Rabs_pos_eq in He. 2: now apply Rlt_le. -apply Rle_trans with (bpow (ex - 1)). -apply bpow_le. -cut (e < ex)%Z. omega. -apply (lt_bpow beta). -now apply Rle_lt_trans with (2 := proj2 He). -destruct (Zle_or_lt ex (fexp ex)). -destruct (round_bounded_small_pos rnd x ex H He) as [Hr|Hr]. -rewrite Hr in Hd. -elim Rlt_irrefl with (1 := Hd). -rewrite Hr. -apply bpow_le. -omega. -apply (round_bounded_large_pos rnd x ex H He). -Qed. - -End round_large. - -Theorem ln_beta_round_ZR : - forall x, - (round Ztrunc x <> 0)%R -> - (ln_beta beta (round Ztrunc x) = ln_beta beta x :> Z). -Proof with auto with typeclass_instances. -intros x Zr. -destruct (Req_dec x 0) as [Zx|Zx]. -rewrite Zx, round_0... -apply ln_beta_unique. -destruct (ln_beta beta x) as (ex, Ex) ; simpl. -specialize (Ex Zx). -rewrite <- round_ZR_abs. -split. -apply round_large_pos_ge_pow... -rewrite round_ZR_abs. -now apply Rabs_pos_lt. -apply Ex. -apply Rle_lt_trans with (2 := proj2 Ex). -rewrite round_ZR_pos. -apply round_DN_pt. -apply Rabs_pos. -Qed. - -Theorem ln_beta_round : - forall rnd {Hrnd : Valid_rnd rnd} x, - (round rnd x <> 0)%R -> - (ln_beta beta (round rnd x) = ln_beta beta x :> Z) \/ - Rabs (round rnd x) = bpow (Zmax (ln_beta beta x) (fexp (ln_beta beta x))). -Proof with auto with typeclass_instances. -intros rnd Hrnd x. -destruct (round_ZR_or_AW rnd x) as [Hr|Hr] ; rewrite Hr ; clear Hr rnd Hrnd. -left. -now apply ln_beta_round_ZR. -intros Zr. -destruct (Req_dec x 0) as [Zx|Zx]. -rewrite Zx, round_0... -destruct (ln_beta beta x) as (ex, Ex) ; simpl. -specialize (Ex Zx). -rewrite <- ln_beta_abs. -rewrite <- round_AW_abs. -destruct (Zle_or_lt ex (fexp ex)) as [He|He]. -right. -rewrite Zmax_r with (1 := He). -rewrite round_AW_pos with (1 := Rabs_pos _). -now apply round_UP_small_pos. -destruct (round_bounded_large_pos Zaway _ ex He Ex) as (H1,[H2|H2]). -left. -apply ln_beta_unique. -rewrite <- round_AW_abs, Rabs_Rabsolu. -now split. -right. -now rewrite Zmax_l with (1 := Zlt_le_weak _ _ He). -Qed. - -Theorem ln_beta_DN : - forall x, - (0 < round Zfloor x)%R -> - (ln_beta beta (round Zfloor x) = ln_beta beta x :> Z). -Proof. -intros x Hd. -assert (0 < x)%R. -apply Rlt_le_trans with (1 := Hd). -apply round_DN_pt. -revert Hd. -rewrite <- round_ZR_pos. -intros Hd. -apply ln_beta_round_ZR. -now apply Rgt_not_eq. -now apply Rlt_le. -Qed. - -Theorem canonic_exp_DN : - forall x, - (0 < round Zfloor x)%R -> - canonic_exp (round Zfloor x) = canonic_exp x. -Proof. -intros x Hd. -apply (f_equal fexp). -now apply ln_beta_DN. -Qed. - -Theorem scaled_mantissa_DN : - forall x, - (0 < round Zfloor x)%R -> - scaled_mantissa (round Zfloor x) = Z2R (Zfloor (scaled_mantissa x)). -Proof. -intros x Hd. -unfold scaled_mantissa. -rewrite canonic_exp_DN with (1 := Hd). -unfold round, F2R. simpl. -now rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r. -Qed. - -Theorem generic_N_pt_DN_or_UP : - forall x f, - Rnd_N_pt generic_format x f -> - f = round Zfloor x \/ f = round Zceil x. -Proof. -intros x f Hxf. -destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf). -left. -apply Rnd_DN_pt_unicity with (1 := H). -apply round_DN_pt. -right. -apply Rnd_UP_pt_unicity with (1 := H). -apply round_UP_pt. -Qed. - -Section not_FTZ. - -Class Exp_not_FTZ := - exp_not_FTZ : forall e, (fexp (fexp e + 1) <= fexp e)%Z. - -Context { exp_not_FTZ_ : Exp_not_FTZ }. - -Theorem subnormal_exponent : - forall e x, - (e <= fexp e)%Z -> - generic_format x -> - x = F2R (Float beta (Ztrunc (x * bpow (- fexp e))) (fexp e)). -Proof. -intros e x He Hx. -pattern x at 2 ; rewrite Hx. -unfold F2R at 2. simpl. -rewrite Rmult_assoc, <- bpow_plus. -assert (H: Z2R (Zpower beta (canonic_exp x + - fexp e)) = bpow (canonic_exp x + - fexp e)). -apply Z2R_Zpower. -unfold canonic_exp. -set (ex := ln_beta beta x). -generalize (exp_not_FTZ ex). -generalize (proj2 (proj2 (valid_exp _) He) (fexp ex + 1)%Z). -omega. -rewrite <- H. -rewrite <- Z2R_mult, Ztrunc_Z2R. -unfold F2R. simpl. -rewrite Z2R_mult. -rewrite H. -rewrite Rmult_assoc, <- bpow_plus. -now ring_simplify (canonic_exp x + - fexp e + fexp e)%Z. -Qed. - -End not_FTZ. - -Section monotone_exp. - -Class Monotone_exp := - monotone_exp : forall ex ey, (ex <= ey)%Z -> (fexp ex <= fexp ey)%Z. - -Context { monotone_exp_ : Monotone_exp }. - -Global Instance monotone_exp_not_FTZ : Exp_not_FTZ. -Proof. -intros e. -destruct (Z_lt_le_dec (fexp e) e) as [He|He]. -apply monotone_exp. -now apply Zlt_le_succ. -now apply valid_exp. -Qed. - -Lemma canonic_exp_le_bpow : - forall (x : R) (e : Z), - x <> 0%R -> - (Rabs x < bpow e)%R -> - (canonic_exp x <= fexp e)%Z. -Proof. -intros x e Zx Hx. -apply monotone_exp. -now apply ln_beta_le_bpow. -Qed. - -Lemma canonic_exp_ge_bpow : - forall (x : R) (e : Z), - (bpow (e - 1) <= Rabs x)%R -> - (fexp e <= canonic_exp x)%Z. -Proof. -intros x e Hx. -apply monotone_exp. -rewrite (Zsucc_pred e). -apply Zlt_le_succ. -now apply ln_beta_gt_bpow. -Qed. - -Variable rnd : R -> Z. -Context { valid_rnd : Valid_rnd rnd }. - -Theorem ln_beta_round_ge : - forall x, - round rnd x <> 0%R -> - (ln_beta beta x <= ln_beta beta (round rnd x))%Z. -Proof with auto with typeclass_instances. -intros x. -destruct (round_ZR_or_AW rnd x) as [H|H] ; rewrite H ; clear H ; intros Zr. -rewrite ln_beta_round_ZR with (1 := Zr). -apply Zle_refl. -apply ln_beta_le_abs. -contradict Zr. -rewrite Zr. -apply round_0... -rewrite <- round_AW_abs. -rewrite round_AW_pos. -apply round_UP_pt. -apply Rabs_pos. -Qed. - -Theorem canonic_exp_round_ge : - forall x, - round rnd x <> 0%R -> - (canonic_exp x <= canonic_exp (round rnd x))%Z. -Proof with auto with typeclass_instances. -intros x Zr. -unfold canonic_exp. -apply monotone_exp. -now apply ln_beta_round_ge. -Qed. - -End monotone_exp. - -Section Znearest. - -(** Roundings to nearest: when in the middle, use the choice function *) -Variable choice : Z -> bool. - -Definition Znearest x := - match Rcompare (x - Z2R (Zfloor x)) (/2) with - | Lt => Zfloor x - | Eq => if choice (Zfloor x) then Zceil x else Zfloor x - | Gt => Zceil x - end. - -Theorem Znearest_DN_or_UP : - forall x, - Znearest x = Zfloor x \/ Znearest x = Zceil x. -Proof. -intros x. -unfold Znearest. -case Rcompare_spec ; intros _. -now left. -case choice. -now right. -now left. -now right. -Qed. - -Theorem Znearest_ge_floor : - forall x, - (Zfloor x <= Znearest x)%Z. -Proof. -intros x. -destruct (Znearest_DN_or_UP x) as [Hx|Hx] ; rewrite Hx. -apply Zle_refl. -apply le_Z2R. -apply Rle_trans with x. -apply Zfloor_lb. -apply Zceil_ub. -Qed. - -Theorem Znearest_le_ceil : - forall x, - (Znearest x <= Zceil x)%Z. -Proof. -intros x. -destruct (Znearest_DN_or_UP x) as [Hx|Hx] ; rewrite Hx. -apply le_Z2R. -apply Rle_trans with x. -apply Zfloor_lb. -apply Zceil_ub. -apply Zle_refl. -Qed. - -Global Instance valid_rnd_N : Valid_rnd Znearest. -Proof. -split. -(* *) -intros x y Hxy. -destruct (Rle_or_lt (Z2R (Zceil x)) y) as [H|H]. -apply Zle_trans with (1 := Znearest_le_ceil x). -apply Zle_trans with (2 := Znearest_ge_floor y). -now apply Zfloor_lub. -(* . *) -assert (Hf: Zfloor y = Zfloor x). -apply Zfloor_imp. -split. -apply Rle_trans with (2 := Zfloor_lb y). -apply Z2R_le. -now apply Zfloor_le. -apply Rlt_le_trans with (1 := H). -apply Z2R_le. -apply Zceil_glb. -apply Rlt_le. -rewrite Z2R_plus. -apply Zfloor_ub. -(* . *) -unfold Znearest at 1. -case Rcompare_spec ; intro Hx. -(* .. *) -rewrite <- Hf. -apply Znearest_ge_floor. -(* .. *) -unfold Znearest. -rewrite Hf. -case Rcompare_spec ; intro Hy. -elim Rlt_not_le with (1 := Hy). -rewrite <- Hx. -now apply Rplus_le_compat_r. -replace y with x. -apply Zle_refl. -apply Rplus_eq_reg_l with (- Z2R (Zfloor x))%R. -rewrite 2!(Rplus_comm (- (Z2R (Zfloor x)))). -change (x - Z2R (Zfloor x) = y - Z2R (Zfloor x))%R. -now rewrite Hy. -apply Zle_trans with (Zceil x). -case choice. -apply Zle_refl. -apply le_Z2R. -apply Rle_trans with x. -apply Zfloor_lb. -apply Zceil_ub. -now apply Zceil_le. -(* .. *) -unfold Znearest. -rewrite Hf. -rewrite Rcompare_Gt. -now apply Zceil_le. -apply Rlt_le_trans with (1 := Hx). -now apply Rplus_le_compat_r. -(* *) -intros n. -unfold Znearest. -rewrite Zfloor_Z2R. -rewrite Rcompare_Lt. -easy. -unfold Rminus. -rewrite Rplus_opp_r. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). -Qed. - -Theorem Rcompare_floor_ceil_mid : - forall x, - Z2R (Zfloor x) <> x -> - Rcompare (x - Z2R (Zfloor x)) (/ 2) = Rcompare (x - Z2R (Zfloor x)) (Z2R (Zceil x) - x). -Proof. -intros x Hx. -rewrite Zceil_floor_neq with (1 := Hx). -rewrite Z2R_plus. simpl. -destruct (Rcompare_spec (x - Z2R (Zfloor x)) (/ 2)) as [H1|H1|H1] ; apply sym_eq. -(* . *) -apply Rcompare_Lt. -apply Rplus_lt_reg_l with (x - Z2R (Zfloor x))%R. -replace (x - Z2R (Zfloor x) + (x - Z2R (Zfloor x)))%R with ((x - Z2R (Zfloor x)) * 2)%R by ring. -replace (x - Z2R (Zfloor x) + (Z2R (Zfloor x) + 1 - x))%R with (/2 * 2)%R by field. -apply Rmult_lt_compat_r with (2 := H1). -now apply (Z2R_lt 0 2). -(* . *) -apply Rcompare_Eq. -replace (Z2R (Zfloor x) + 1 - x)%R with (1 - (x - Z2R (Zfloor x)))%R by ring. -rewrite H1. -field. -(* . *) -apply Rcompare_Gt. -apply Rplus_lt_reg_l with (x - Z2R (Zfloor x))%R. -replace (x - Z2R (Zfloor x) + (x - Z2R (Zfloor x)))%R with ((x - Z2R (Zfloor x)) * 2)%R by ring. -replace (x - Z2R (Zfloor x) + (Z2R (Zfloor x) + 1 - x))%R with (/2 * 2)%R by field. -apply Rmult_lt_compat_r with (2 := H1). -now apply (Z2R_lt 0 2). -Qed. - -Theorem Rcompare_ceil_floor_mid : - forall x, - Z2R (Zfloor x) <> x -> - Rcompare (Z2R (Zceil x) - x) (/ 2) = Rcompare (Z2R (Zceil x) - x) (x - Z2R (Zfloor x)). -Proof. -intros x Hx. -rewrite Zceil_floor_neq with (1 := Hx). -rewrite Z2R_plus. simpl. -destruct (Rcompare_spec (Z2R (Zfloor x) + 1 - x) (/ 2)) as [H1|H1|H1] ; apply sym_eq. -(* . *) -apply Rcompare_Lt. -apply Rplus_lt_reg_l with (Z2R (Zfloor x) + 1 - x)%R. -replace (Z2R (Zfloor x) + 1 - x + (Z2R (Zfloor x) + 1 - x))%R with ((Z2R (Zfloor x) + 1 - x) * 2)%R by ring. -replace (Z2R (Zfloor x) + 1 - x + (x - Z2R (Zfloor x)))%R with (/2 * 2)%R by field. -apply Rmult_lt_compat_r with (2 := H1). -now apply (Z2R_lt 0 2). -(* . *) -apply Rcompare_Eq. -replace (x - Z2R (Zfloor x))%R with (1 - (Z2R (Zfloor x) + 1 - x))%R by ring. -rewrite H1. -field. -(* . *) -apply Rcompare_Gt. -apply Rplus_lt_reg_l with (Z2R (Zfloor x) + 1 - x)%R. -replace (Z2R (Zfloor x) + 1 - x + (Z2R (Zfloor x) + 1 - x))%R with ((Z2R (Zfloor x) + 1 - x) * 2)%R by ring. -replace (Z2R (Zfloor x) + 1 - x + (x - Z2R (Zfloor x)))%R with (/2 * 2)%R by field. -apply Rmult_lt_compat_r with (2 := H1). -now apply (Z2R_lt 0 2). -Qed. - -Theorem Znearest_N_strict : - forall x, - (x - Z2R (Zfloor x) <> /2)%R -> - (Rabs (x - Z2R (Znearest x)) < /2)%R. -Proof. -intros x Hx. -unfold Znearest. -case Rcompare_spec ; intros H. -rewrite Rabs_pos_eq. -exact H. -apply Rle_0_minus. -apply Zfloor_lb. -now elim Hx. -rewrite Rabs_left1. -rewrite Ropp_minus_distr. -rewrite Zceil_floor_neq. -rewrite Z2R_plus. -simpl. -apply Ropp_lt_cancel. -apply Rplus_lt_reg_l with 1%R. -replace (1 + -/2)%R with (/2)%R by field. -now replace (1 + - (Z2R (Zfloor x) + 1 - x))%R with (x - Z2R (Zfloor x))%R by ring. -apply Rlt_not_eq. -apply Rplus_lt_reg_l with (- Z2R (Zfloor x))%R. -apply Rlt_trans with (/2)%R. -rewrite Rplus_opp_l. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). -now rewrite <- (Rplus_comm x). -apply Rle_minus. -apply Zceil_ub. -Qed. - -Theorem Znearest_N : - forall x, - (Rabs (x - Z2R (Znearest x)) <= /2)%R. -Proof. -intros x. -destruct (Req_dec (x - Z2R (Zfloor x)) (/2)) as [Hx|Hx]. -assert (K: (Rabs (/2) <= /2)%R). -apply Req_le. -apply Rabs_pos_eq. -apply Rlt_le. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). -destruct (Znearest_DN_or_UP x) as [H|H] ; rewrite H ; clear H. -now rewrite Hx. -rewrite Zceil_floor_neq. -rewrite Z2R_plus. -simpl. -replace (x - (Z2R (Zfloor x) + 1))%R with (x - Z2R (Zfloor x) - 1)%R by ring. -rewrite Hx. -rewrite Rabs_minus_sym. -now replace (1 - /2)%R with (/2)%R by field. -apply Rlt_not_eq. -apply Rplus_lt_reg_l with (- Z2R (Zfloor x))%R. -rewrite Rplus_opp_l, Rplus_comm. -fold (x - Z2R (Zfloor x))%R. -rewrite Hx. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). -apply Rlt_le. -now apply Znearest_N_strict. -Qed. - -Theorem Znearest_imp : - forall x n, - (Rabs (x - Z2R n) < /2)%R -> - Znearest x = n. -Proof. -intros x n Hd. -cut (Zabs (Znearest x - n) < 1)%Z. -clear ; zify ; omega. -apply lt_Z2R. -rewrite Z2R_abs, Z2R_minus. -replace (Z2R (Znearest x) - Z2R n)%R with (- (x - Z2R (Znearest x)) + (x - Z2R n))%R by ring. -apply Rle_lt_trans with (1 := Rabs_triang _ _). -simpl. -replace 1%R with (/2 + /2)%R by field. -apply Rplus_le_lt_compat with (2 := Hd). -rewrite Rabs_Ropp. -apply Znearest_N. -Qed. - -Theorem round_N_pt : - forall x, - Rnd_N_pt generic_format x (round Znearest x). -Proof. -intros x. -set (d := round Zfloor x). -set (u := round Zceil x). -set (mx := scaled_mantissa x). -set (bx := bpow (canonic_exp x)). -(* . *) -assert (H: (Rabs (round Znearest x - x) <= Rmin (x - d) (u - x))%R). -pattern x at -1 ; rewrite <- scaled_mantissa_mult_bpow. -unfold d, u, round, F2R. simpl. -fold mx bx. -rewrite <- 3!Rmult_minus_distr_r. -rewrite Rabs_mult, (Rabs_pos_eq bx). 2: apply bpow_ge_0. -rewrite <- Rmult_min_distr_r. 2: apply bpow_ge_0. -apply Rmult_le_compat_r. -apply bpow_ge_0. -unfold Znearest. -destruct (Req_dec (Z2R (Zfloor mx)) mx) as [Hm|Hm]. -(* .. *) -rewrite Hm. -unfold Rminus at 2. -rewrite Rplus_opp_r. -rewrite Rcompare_Lt. -rewrite Hm. -unfold Rminus at -3. -rewrite Rplus_opp_r. -rewrite Rabs_R0. -unfold Rmin. -destruct (Rle_dec 0 (Z2R (Zceil mx) - mx)) as [H|H]. -apply Rle_refl. -apply Rle_0_minus. -apply Zceil_ub. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). -(* .. *) -rewrite Rcompare_floor_ceil_mid with (1 := Hm). -rewrite Rmin_compare. -assert (H: (Rabs (mx - Z2R (Zfloor mx)) <= mx - Z2R (Zfloor mx))%R). -rewrite Rabs_pos_eq. -apply Rle_refl. -apply Rle_0_minus. -apply Zfloor_lb. -case Rcompare_spec ; intros Hm'. -now rewrite Rabs_minus_sym. -case choice. -rewrite <- Hm'. -exact H. -now rewrite Rabs_minus_sym. -rewrite Rabs_pos_eq. -apply Rle_refl. -apply Rle_0_minus. -apply Zceil_ub. -(* . *) -apply Rnd_DN_UP_pt_N with d u. -apply generic_format_round. -auto with typeclass_instances. -now apply round_DN_pt. -now apply round_UP_pt. -apply Rle_trans with (1 := H). -apply Rmin_l. -apply Rle_trans with (1 := H). -apply Rmin_r. -Qed. - -Theorem round_N_middle : - forall x, - (x - round Zfloor x = round Zceil x - x)%R -> - round Znearest x = if choice (Zfloor (scaled_mantissa x)) then round Zceil x else round Zfloor x. -Proof. -intros x. -pattern x at 1 4 ; rewrite <- scaled_mantissa_mult_bpow. -unfold round, Znearest, F2R. simpl. -destruct (Req_dec (Z2R (Zfloor (scaled_mantissa x))) (scaled_mantissa x)) as [Fx|Fx]. -(* *) -intros _. -rewrite <- Fx. -rewrite Zceil_Z2R, Zfloor_Z2R. -set (m := Zfloor (scaled_mantissa x)). -now case (Rcompare (Z2R m - Z2R m) (/ 2)) ; case (choice m). -(* *) -intros H. -rewrite Rcompare_floor_ceil_mid with (1 := Fx). -rewrite Rcompare_Eq. -now case choice. -apply Rmult_eq_reg_r with (bpow (canonic_exp x)). -now rewrite 2!Rmult_minus_distr_r. -apply Rgt_not_eq. -apply bpow_gt_0. -Qed. - -Lemma round_N_really_small_pos : - forall x, - forall ex, - (Fcore_Raux.bpow beta (ex - 1) <= x < Fcore_Raux.bpow beta ex)%R -> - (ex < fexp ex)%Z -> - (round Znearest x = 0)%R. -Proof. -intros x ex Hex Hf. -unfold round, F2R, scaled_mantissa, canonic_exp; simpl. -apply (Rmult_eq_reg_r (bpow (- fexp (ln_beta beta x)))); - [|now apply Rgt_not_eq; apply bpow_gt_0]. -rewrite Rmult_0_l, Rmult_assoc, <- bpow_plus. -replace (_ + - _)%Z with 0%Z by ring; simpl; rewrite Rmult_1_r. -change 0%R with (Z2R 0); apply f_equal. -apply Znearest_imp. -simpl; unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r. -assert (H : (x >= 0)%R). -{ apply Rle_ge; apply Rle_trans with (bpow (ex - 1)); [|exact (proj1 Hex)]. - now apply bpow_ge_0. } -assert (H' : (x * bpow (- fexp (ln_beta beta x)) >= 0)%R). -{ apply Rle_ge; apply Rmult_le_pos. - - now apply Rge_le. - - now apply bpow_ge_0. } -rewrite Rabs_right; [|exact H']. -apply (Rmult_lt_reg_r (bpow (fexp (ln_beta beta x)))); [now apply bpow_gt_0|]. -rewrite Rmult_assoc, <- bpow_plus. -replace (- _ + _)%Z with 0%Z by ring; simpl; rewrite Rmult_1_r. -apply (Rlt_le_trans _ _ _ (proj2 Hex)). -apply Rle_trans with (bpow (fexp (ln_beta beta x) - 1)). -- apply bpow_le. - rewrite (ln_beta_unique beta x ex); [omega|]. - now rewrite Rabs_right. -- unfold Zminus; rewrite bpow_plus. - rewrite Rmult_comm. - apply Rmult_le_compat_r; [now apply bpow_ge_0|]. - unfold Fcore_Raux.bpow, Z.pow_pos; simpl. - rewrite Zmult_1_r. - apply Rinv_le; [exact Rlt_0_2|]. - change 2%R with (Z2R 2); apply Z2R_le. - destruct beta as (beta_val,beta_prop). - now apply Zle_bool_imp_le. -Qed. - -End Znearest. - -Section rndNA. - -Global Instance valid_rnd_NA : Valid_rnd (Znearest (Zle_bool 0)) := valid_rnd_N _. - -Theorem round_NA_pt : - forall x, - Rnd_NA_pt generic_format x (round (Znearest (Zle_bool 0)) x). -Proof. -intros x. -generalize (round_N_pt (Zle_bool 0) x). -set (f := round (Znearest (Zle_bool 0)) x). -intros Rxf. -destruct (Req_dec (x - round Zfloor x) (round Zceil x - x)) as [Hm|Hm]. -(* *) -apply Rnd_NA_N_pt. -exact generic_format_0. -exact Rxf. -destruct (Rle_or_lt 0 x) as [Hx|Hx]. -(* . *) -rewrite Rabs_pos_eq with (1 := Hx). -rewrite Rabs_pos_eq. -unfold f. -rewrite round_N_middle with (1 := Hm). -rewrite Zle_bool_true. -apply (round_UP_pt x). -apply Zfloor_lub. -apply Rmult_le_pos with (1 := Hx). -apply bpow_ge_0. -apply Rnd_N_pt_pos with (2 := Hx) (3 := Rxf). -exact generic_format_0. -(* . *) -rewrite Rabs_left with (1 := Hx). -rewrite Rabs_left1. -apply Ropp_le_contravar. -unfold f. -rewrite round_N_middle with (1 := Hm). -rewrite Zle_bool_false. -apply (round_DN_pt x). -apply lt_Z2R. -apply Rle_lt_trans with (scaled_mantissa x). -apply Zfloor_lb. -simpl. -rewrite <- (Rmult_0_l (bpow (- canonic_exp x))). -apply Rmult_lt_compat_r with (2 := Hx). -apply bpow_gt_0. -apply Rnd_N_pt_neg with (3 := Rxf). -exact generic_format_0. -now apply Rlt_le. -(* *) -split. -apply Rxf. -intros g Rxg. -rewrite Rnd_N_pt_unicity with (3 := Hm) (4 := Rxf) (5 := Rxg). -apply Rle_refl. -apply round_DN_pt. -apply round_UP_pt. -Qed. - -End rndNA. - -Section rndN_opp. - -Theorem Znearest_opp : - forall choice x, - Znearest choice (- x) = (- Znearest (fun t => negb (choice (- (t + 1))%Z)) x)%Z. -Proof with auto with typeclass_instances. -intros choice x. -destruct (Req_dec (Z2R (Zfloor x)) x) as [Hx|Hx]. -rewrite <- Hx. -rewrite <- Z2R_opp. -rewrite 2!Zrnd_Z2R... -unfold Znearest. -replace (- x - Z2R (Zfloor (-x)))%R with (Z2R (Zceil x) - x)%R. -rewrite Rcompare_ceil_floor_mid with (1 := Hx). -rewrite Rcompare_floor_ceil_mid with (1 := Hx). -rewrite Rcompare_sym. -rewrite <- Zceil_floor_neq with (1 := Hx). -unfold Zceil. -rewrite Ropp_involutive. -case Rcompare ; simpl ; trivial. -rewrite Zopp_involutive. -case (choice (Zfloor (- x))) ; simpl ; trivial. -now rewrite Zopp_involutive. -now rewrite Zopp_involutive. -unfold Zceil. -rewrite Z2R_opp. -apply Rplus_comm. -Qed. - -Theorem round_N_opp : - forall choice, - forall x, - round (Znearest choice) (-x) = (- round (Znearest (fun t => negb (choice (- (t + 1))%Z))) x)%R. -Proof. -intros choice x. -unfold round, F2R. simpl. -rewrite canonic_exp_opp. -rewrite scaled_mantissa_opp. -rewrite Znearest_opp. -rewrite Z2R_opp. -now rewrite Ropp_mult_distr_l_reverse. -Qed. - -End rndN_opp. - -End Format. - -(** Inclusion of a format into an extended format *) -Section Inclusion. - -Variables fexp1 fexp2 : Z -> Z. - -Context { valid_exp1 : Valid_exp fexp1 }. -Context { valid_exp2 : Valid_exp fexp2 }. - -Theorem generic_inclusion_ln_beta : - forall x, - ( x <> R0 -> (fexp2 (ln_beta beta x) <= fexp1 (ln_beta beta x))%Z ) -> - generic_format fexp1 x -> - generic_format fexp2 x. -Proof. -intros x He Fx. -rewrite Fx. -apply generic_format_F2R. -intros Zx. -rewrite <- Fx. -apply He. -contradict Zx. -rewrite Zx, scaled_mantissa_0. -apply (Ztrunc_Z2R 0). -Qed. - -Theorem generic_inclusion_lt_ge : - forall e1 e2, - ( forall e, (e1 < e <= e2)%Z -> (fexp2 e <= fexp1 e)%Z ) -> - forall x, - (bpow e1 <= Rabs x < bpow e2)%R -> - generic_format fexp1 x -> - generic_format fexp2 x. -Proof. -intros e1 e2 He x (Hx1,Hx2). -apply generic_inclusion_ln_beta. -intros Zx. -apply He. -split. -now apply ln_beta_gt_bpow. -now apply ln_beta_le_bpow. -Qed. - -Theorem generic_inclusion : - forall e, - (fexp2 e <= fexp1 e)%Z -> - forall x, - (bpow (e - 1) <= Rabs x <= bpow e)%R -> - generic_format fexp1 x -> - generic_format fexp2 x. -Proof with auto with typeclass_instances. -intros e He x (Hx1,[Hx2|Hx2]). -apply generic_inclusion_ln_beta. -now rewrite ln_beta_unique with (1 := conj Hx1 Hx2). -intros Fx. -apply generic_format_abs_inv. -rewrite Hx2. -apply generic_format_bpow'... -apply Zle_trans with (1 := He). -apply generic_format_bpow_inv... -rewrite <- Hx2. -now apply generic_format_abs. -Qed. - -Theorem generic_inclusion_le_ge : - forall e1 e2, - (e1 < e2)%Z -> - ( forall e, (e1 < e <= e2)%Z -> (fexp2 e <= fexp1 e)%Z ) -> - forall x, - (bpow e1 <= Rabs x <= bpow e2)%R -> - generic_format fexp1 x -> - generic_format fexp2 x. -Proof. -intros e1 e2 He' He x (Hx1,[Hx2|Hx2]). -(* *) -apply generic_inclusion_ln_beta. -intros Zx. -apply He. -split. -now apply ln_beta_gt_bpow. -now apply ln_beta_le_bpow. -(* *) -apply generic_inclusion with (e := e2). -apply He. -split. -apply He'. -apply Zle_refl. -rewrite Hx2. -split. -apply bpow_le. -apply Zle_pred. -apply Rle_refl. -Qed. - -Theorem generic_inclusion_le : - forall e2, - ( forall e, (e <= e2)%Z -> (fexp2 e <= fexp1 e)%Z ) -> - forall x, - (Rabs x <= bpow e2)%R -> - generic_format fexp1 x -> - generic_format fexp2 x. -Proof. -intros e2 He x [Hx|Hx]. -apply generic_inclusion_ln_beta. -intros Zx. -apply He. -now apply ln_beta_le_bpow. -apply generic_inclusion with (e := e2). -apply He. -apply Zle_refl. -rewrite Hx. -split. -apply bpow_le. -apply Zle_pred. -apply Rle_refl. -Qed. - -Theorem generic_inclusion_ge : - forall e1, - ( forall e, (e1 < e)%Z -> (fexp2 e <= fexp1 e)%Z ) -> - forall x, - (bpow e1 <= Rabs x)%R -> - generic_format fexp1 x -> - generic_format fexp2 x. -Proof. -intros e1 He x Hx. -apply generic_inclusion_ln_beta. -intros Zx. -apply He. -now apply ln_beta_gt_bpow. -Qed. - -Variable rnd : R -> Z. -Context { valid_rnd : Valid_rnd rnd }. - -Theorem generic_round_generic : - forall x, - generic_format fexp1 x -> - generic_format fexp1 (round fexp2 rnd x). -Proof with auto with typeclass_instances. -intros x Gx. -apply generic_format_abs_inv. -apply generic_format_abs in Gx. -revert rnd valid_rnd x Gx. -refine (round_abs_abs _ (fun x y => generic_format fexp1 x -> generic_format fexp1 y) _). -intros rnd valid_rnd x [Hx|Hx] Gx. -(* x > 0 *) -generalize (ln_beta_generic_gt _ x (Rgt_not_eq _ _ Hx) Gx). -unfold canonic_exp. -destruct (ln_beta beta x) as (ex,Ex) ; simpl. -specialize (Ex (Rgt_not_eq _ _ Hx)). -intros He'. -rewrite Rabs_pos_eq in Ex by now apply Rlt_le. -destruct (Zle_or_lt ex (fexp2 ex)) as [He|He]. -(* - x near 0 for fexp2 *) -destruct (round_bounded_small_pos fexp2 rnd x ex He Ex) as [Hr|Hr]. -rewrite Hr. -apply generic_format_0. -rewrite Hr. -apply generic_format_bpow'... -apply Zlt_le_weak. -apply valid_exp_large with ex... -(* - x large for fexp2 *) -destruct (Zle_or_lt (canonic_exp fexp2 x) (canonic_exp fexp1 x)) as [He''|He'']. -(* - - round fexp2 x is representable for fexp1 *) -rewrite round_generic... -rewrite Gx. -apply generic_format_F2R. -fold (round fexp1 Ztrunc x). -intros Zx. -unfold canonic_exp at 1. -rewrite ln_beta_round_ZR... -contradict Zx. -apply F2R_eq_0_reg with (1 := Zx). -(* - - round fexp2 x has too many digits for fexp1 *) -destruct (round_bounded_large_pos fexp2 rnd x ex He Ex) as (Hr1,[Hr2|Hr2]). -apply generic_format_F2R. -intros Zx. -fold (round fexp2 rnd x). -unfold canonic_exp at 1. -rewrite ln_beta_unique_pos with (1 := conj Hr1 Hr2). -rewrite <- ln_beta_unique_pos with (1 := Ex). -now apply Zlt_le_weak. -rewrite Hr2. -apply generic_format_bpow'... -now apply Zlt_le_weak. -(* x = 0 *) -rewrite <- Hx, round_0... -apply generic_format_0. -Qed. - -End Inclusion. - -End Generic. - -Notation ZnearestA := (Znearest (Zle_bool 0)). - -Section rndNA_opp. - -Lemma round_NA_opp : - forall beta : radix, - forall (fexp : Z -> Z), - forall x, - (round beta fexp ZnearestA (- x) = - round beta fexp ZnearestA x)%R. -Proof. -intros beta fexp x. -rewrite round_N_opp. -apply Ropp_eq_compat. -apply round_ext. -clear x; intro x. -unfold Znearest. -case_eq (Rcompare (x - Z2R (Zfloor x)) (/ 2)); intro C; -[|reflexivity|reflexivity]. -apply Rcompare_Eq_inv in C. -assert (H : negb (0 <=? - (Zfloor x + 1))%Z = (0 <=? Zfloor x)%Z); - [|now rewrite H]. -rewrite negb_Zle_bool. -case_eq (0 <=? Zfloor x)%Z; intro C'. -- apply Zle_bool_imp_le in C'. - apply Zlt_bool_true. - omega. -- rewrite Z.leb_gt in C'. - apply Zlt_bool_false. - omega. -Qed. - -End rndNA_opp. - -(** Notations for backward-compatibility with Flocq 1.4. *) -Notation rndDN := Zfloor (only parsing). -Notation rndUP := Zceil (only parsing). -Notation rndZR := Ztrunc (only parsing). -Notation rndNA := ZnearestA (only parsing). diff --git a/flocq/Core/Fcore_rnd.v b/flocq/Core/Fcore_rnd.v deleted file mode 100644 index e5091684..00000000 --- a/flocq/Core/Fcore_rnd.v +++ /dev/null @@ -1,1392 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2010-2013 Sylvie Boldo -#
# -Copyright (C) 2010-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** * Roundings: properties and/or functions *) -Require Import Fcore_Raux. -Require Import Fcore_defs. - -Section RND_prop. - -Open Scope R_scope. - -Theorem round_val_of_pred : - forall rnd : R -> R -> Prop, - round_pred rnd -> - forall x, { f : R | rnd x f }. -Proof. -intros rnd (H1,H2) x. -specialize (H1 x). -(* . *) -assert (H3 : bound (rnd x)). -destruct H1 as (f, H1). -exists f. -intros g Hg. -now apply H2 with (3 := Rle_refl x). -(* . *) -exists (proj1_sig (completeness _ H3 H1)). -destruct completeness as (f1, (H4, H5)). -simpl. -destruct H1 as (f2, H1). -assert (f1 = f2). -apply Rle_antisym. -apply H5. -intros f3 H. -now apply H2 with (3 := Rle_refl x). -now apply H4. -now rewrite H. -Qed. - -Theorem round_fun_of_pred : - forall rnd : R -> R -> Prop, - round_pred rnd -> - { f : R -> R | forall x, rnd x (f x) }. -Proof. -intros rnd H. -exists (fun x => proj1_sig (round_val_of_pred rnd H x)). -intros x. -now destruct round_val_of_pred as (f, H1). -Qed. - -Theorem round_unicity : - forall rnd : R -> R -> Prop, - round_pred_monotone rnd -> - forall x f1 f2, - rnd x f1 -> - rnd x f2 -> - f1 = f2. -Proof. -intros rnd Hr x f1 f2 H1 H2. -apply Rle_antisym. -now apply Hr with (3 := Rle_refl x). -now apply Hr with (3 := Rle_refl x). -Qed. - -Theorem Rnd_DN_pt_monotone : - forall F : R -> Prop, - round_pred_monotone (Rnd_DN_pt F). -Proof. -intros F x y f g (Hx1,(Hx2,_)) (Hy1,(_,Hy2)) Hxy. -apply Hy2. -apply Hx1. -now apply Rle_trans with (2 := Hxy). -Qed. - -Theorem Rnd_DN_pt_unicity : - forall F : R -> Prop, - forall x f1 f2 : R, - Rnd_DN_pt F x f1 -> Rnd_DN_pt F x f2 -> - f1 = f2. -Proof. -intros F. -apply round_unicity. -apply Rnd_DN_pt_monotone. -Qed. - -Theorem Rnd_DN_unicity : - forall F : R -> Prop, - forall rnd1 rnd2 : R -> R, - Rnd_DN F rnd1 -> Rnd_DN F rnd2 -> - forall x, rnd1 x = rnd2 x. -Proof. -intros F rnd1 rnd2 H1 H2 x. -now eapply Rnd_DN_pt_unicity. -Qed. - -Theorem Rnd_UP_pt_monotone : - forall F : R -> Prop, - round_pred_monotone (Rnd_UP_pt F). -Proof. -intros F x y f g (Hx1,(_,Hx2)) (Hy1,(Hy2,_)) Hxy. -apply Hx2. -apply Hy1. -now apply Rle_trans with (1 := Hxy). -Qed. - -Theorem Rnd_UP_pt_unicity : - forall F : R -> Prop, - forall x f1 f2 : R, - Rnd_UP_pt F x f1 -> Rnd_UP_pt F x f2 -> - f1 = f2. -Proof. -intros F. -apply round_unicity. -apply Rnd_UP_pt_monotone. -Qed. - -Theorem Rnd_UP_unicity : - forall F : R -> Prop, - forall rnd1 rnd2 : R -> R, - Rnd_UP F rnd1 -> Rnd_UP F rnd2 -> - forall x, rnd1 x = rnd2 x. -Proof. -intros F rnd1 rnd2 H1 H2 x. -now eapply Rnd_UP_pt_unicity. -Qed. - -Theorem Rnd_DN_UP_pt_sym : - forall F : R -> Prop, - ( forall x, F x -> F (- x) ) -> - forall x f : R, - Rnd_DN_pt F x f -> Rnd_UP_pt F (-x) (-f). -Proof. -intros F HF x f H. -repeat split. -apply HF. -apply H. -apply Ropp_le_contravar. -apply H. -intros g Hg. -rewrite <- (Ropp_involutive g). -intros Hxg. -apply Ropp_le_contravar. -apply H. -now apply HF. -now apply Ropp_le_cancel. -Qed. - -Theorem Rnd_UP_DN_pt_sym : - forall F : R -> Prop, - ( forall x, F x -> F (- x) ) -> - forall x f : R, - Rnd_UP_pt F x f -> Rnd_DN_pt F (-x) (-f). -Proof. -intros F HF x f H. -repeat split. -apply HF. -apply H. -apply Ropp_le_contravar. -apply H. -intros g Hg. -rewrite <- (Ropp_involutive g). -intros Hxg. -apply Ropp_le_contravar. -apply H. -now apply HF. -now apply Ropp_le_cancel. -Qed. - -Theorem Rnd_DN_UP_sym : - forall F : R -> Prop, - ( forall x, F x -> F (- x) ) -> - forall rnd1 rnd2 : R -> R, - Rnd_DN F rnd1 -> Rnd_UP F rnd2 -> - forall x, rnd1 (- x) = - rnd2 x. -Proof. -intros F HF rnd1 rnd2 H1 H2 x. -rewrite <- (Ropp_involutive (rnd1 (-x))). -apply f_equal. -apply (Rnd_UP_unicity F (fun x => - rnd1 (-x))) ; trivial. -intros y. -pattern y at 1 ; rewrite <- Ropp_involutive. -apply Rnd_DN_UP_pt_sym. -apply HF. -apply H1. -Qed. - -Theorem Rnd_DN_UP_pt_split : - forall F : R -> Prop, - forall x d u, - Rnd_DN_pt F x d -> - Rnd_UP_pt F x u -> - forall f, F f -> - (f <= d) \/ (u <= f). -Proof. -intros F x d u Hd Hu f Hf. -destruct (Rle_or_lt f x). -left. -now apply Hd. -right. -assert (H' := Rlt_le _ _ H). -now apply Hu. -Qed. - -Theorem Rnd_DN_pt_refl : - forall F : R -> Prop, - forall x : R, F x -> - Rnd_DN_pt F x x. -Proof. -intros F x Hx. -repeat split. -exact Hx. -apply Rle_refl. -now intros. -Qed. - -Theorem Rnd_DN_pt_idempotent : - forall F : R -> Prop, - forall x f : R, - Rnd_DN_pt F x f -> F x -> - f = x. -Proof. -intros F x f (_,(Hx1,Hx2)) Hx. -apply Rle_antisym. -exact Hx1. -apply Hx2. -exact Hx. -apply Rle_refl. -Qed. - -Theorem Rnd_UP_pt_refl : - forall F : R -> Prop, - forall x : R, F x -> - Rnd_UP_pt F x x. -Proof. -intros F x Hx. -repeat split. -exact Hx. -apply Rle_refl. -now intros. -Qed. - -Theorem Rnd_UP_pt_idempotent : - forall F : R -> Prop, - forall x f : R, - Rnd_UP_pt F x f -> F x -> - f = x. -Proof. -intros F x f (_,(Hx1,Hx2)) Hx. -apply Rle_antisym. -apply Hx2. -exact Hx. -apply Rle_refl. -exact Hx1. -Qed. - -Theorem Only_DN_or_UP : - forall F : R -> Prop, - forall x fd fu f : R, - Rnd_DN_pt F x fd -> Rnd_UP_pt F x fu -> - F f -> (fd <= f <= fu)%R -> - f = fd \/ f = fu. -Proof. -intros F x fd fu f Hd Hu Hf [Hdf Hfu]. -destruct (Rle_or_lt x f) ; [right|left]. -apply Rle_antisym with (1 := Hfu). -now apply Hu. -apply Rlt_le in H. -apply Rle_antisym with (2 := Hdf). -now apply Hd. -Qed. - -Theorem Rnd_ZR_abs : - forall (F : R -> Prop) (rnd: R-> R), - Rnd_ZR F rnd -> - forall x : R, (Rabs (rnd x) <= Rabs x)%R. -Proof. -intros F rnd H x. -assert (F 0%R). -replace 0%R with (rnd 0%R). -eapply H. -apply Rle_refl. -destruct (H 0%R) as (H1, H2). -apply Rle_antisym. -apply H1. -apply Rle_refl. -apply H2. -apply Rle_refl. -(* . *) -destruct (Rle_or_lt 0 x). -(* positive *) -rewrite Rabs_right. -rewrite Rabs_right; auto with real. -now apply (proj1 (H x)). -apply Rle_ge. -now apply (proj1 (H x)). -(* negative *) -rewrite Rabs_left1. -rewrite Rabs_left1 ; auto with real. -apply Ropp_le_contravar. -apply (proj2 (H x)). -auto with real. -apply (proj2 (H x)) ; auto with real. -Qed. - -Theorem Rnd_ZR_pt_monotone : - forall F : R -> Prop, F 0 -> - round_pred_monotone (Rnd_ZR_pt F). -Proof. -intros F F0 x y f g (Hx1, Hx2) (Hy1, Hy2) Hxy. -destruct (Rle_or_lt 0 x) as [Hx|Hx]. -(* . *) -apply Hy1. -now apply Rle_trans with x. -now apply Hx1. -apply Rle_trans with (2 := Hxy). -now apply Hx1. -(* . *) -apply Rlt_le in Hx. -destruct (Rle_or_lt 0 y) as [Hy|Hy]. -apply Rle_trans with 0. -now apply Hx2. -now apply Hy1. -apply Rlt_le in Hy. -apply Hx2. -exact Hx. -now apply Hy2. -apply Rle_trans with (1 := Hxy). -now apply Hy2. -Qed. - -Theorem Rnd_N_pt_DN_or_UP : - forall F : R -> Prop, - forall x f : R, - Rnd_N_pt F x f -> - Rnd_DN_pt F x f \/ Rnd_UP_pt F x f. -Proof. -intros F x f (Hf1,Hf2). -destruct (Rle_or_lt x f) as [Hxf|Hxf]. -(* . *) -right. -repeat split ; try assumption. -intros g Hg Hxg. -specialize (Hf2 g Hg). -rewrite 2!Rabs_pos_eq in Hf2. -now apply Rplus_le_reg_r with (-x)%R. -now apply Rle_0_minus. -now apply Rle_0_minus. -(* . *) -left. -repeat split ; try assumption. -now apply Rlt_le. -intros g Hg Hxg. -specialize (Hf2 g Hg). -rewrite 2!Rabs_left1 in Hf2. -generalize (Ropp_le_cancel _ _ Hf2). -intros H. -now apply Rplus_le_reg_r with (-x)%R. -now apply Rle_minus. -apply Rlt_le. -now apply Rlt_minus. -Qed. - -Theorem Rnd_N_pt_DN_or_UP_eq : - forall F : R -> Prop, - forall x fd fu f : R, - Rnd_DN_pt F x fd -> Rnd_UP_pt F x fu -> - Rnd_N_pt F x f -> - f = fd \/ f = fu. -Proof. -intros F x fd fu f Hd Hu Hf. -destruct (Rnd_N_pt_DN_or_UP F x f Hf) as [H|H]. -left. -apply Rnd_DN_pt_unicity with (1 := H) (2 := Hd). -right. -apply Rnd_UP_pt_unicity with (1 := H) (2 := Hu). -Qed. - -Theorem Rnd_N_pt_sym : - forall F : R -> Prop, - ( forall x, F x -> F (- x) ) -> - forall x f : R, - Rnd_N_pt F (-x) (-f) -> Rnd_N_pt F x f. -Proof. -intros F HF x f (H1,H2). -rewrite <- (Ropp_involutive f). -repeat split. -apply HF. -apply H1. -intros g H3. -rewrite Ropp_involutive. -replace (f - x)%R with (-(-f - -x))%R by ring. -replace (g - x)%R with (-(-g - -x))%R by ring. -rewrite 2!Rabs_Ropp. -apply H2. -now apply HF. -Qed. - -Theorem Rnd_N_pt_monotone : - forall F : R -> Prop, - forall x y f g : R, - Rnd_N_pt F x f -> Rnd_N_pt F y g -> - x < y -> f <= g. -Proof. -intros F x y f g (Hf,Hx) (Hg,Hy) Hxy. -apply Rnot_lt_le. -intros Hgf. -assert (Hfgx := Hx g Hg). -assert (Hgfy := Hy f Hf). -clear F Hf Hg Hx Hy. -destruct (Rle_or_lt x g) as [Hxg|Hgx]. -(* x <= g < f *) -apply Rle_not_lt with (1 := Hfgx). -rewrite 2!Rabs_pos_eq. -now apply Rplus_lt_compat_r. -apply Rle_0_minus. -apply Rlt_le. -now apply Rle_lt_trans with (1 := Hxg). -now apply Rle_0_minus. -assert (Hgy := Rlt_trans _ _ _ Hgx Hxy). -destruct (Rle_or_lt f y) as [Hfy|Hyf]. -(* g < f <= y *) -apply Rle_not_lt with (1 := Hgfy). -rewrite (Rabs_left (g - y)). -2: now apply Rlt_minus. -rewrite Rabs_left1. -apply Ropp_lt_contravar. -now apply Rplus_lt_compat_r. -now apply Rle_minus. -(* g < x < y < f *) -rewrite Rabs_left, Rabs_pos_eq, Ropp_minus_distr in Hgfy. -rewrite Rabs_pos_eq, Rabs_left, Ropp_minus_distr in Hfgx. -apply Rle_not_lt with (1 := Rplus_le_compat _ _ _ _ Hfgx Hgfy). -apply Rminus_lt. -ring_simplify. -apply Rlt_minus. -apply Rmult_lt_compat_l. -now apply (Z2R_lt 0 2). -exact Hxy. -now apply Rlt_minus. -apply Rle_0_minus. -apply Rlt_le. -now apply Rlt_trans with (1 := Hxy). -apply Rle_0_minus. -now apply Rlt_le. -now apply Rlt_minus. -Qed. - -Theorem Rnd_N_pt_unicity : - forall F : R -> Prop, - forall x d u f1 f2 : R, - Rnd_DN_pt F x d -> - Rnd_UP_pt F x u -> - x - d <> u - x -> - Rnd_N_pt F x f1 -> - Rnd_N_pt F x f2 -> - f1 = f2. -Proof. -intros F x d u f1 f2 Hd Hu Hdu. -assert (forall f1 f2, Rnd_N_pt F x f1 -> Rnd_N_pt F x f2 -> f1 < f2 -> False). -clear f1 f2. intros f1 f2 Hf1 Hf2 H12. -destruct (Rnd_N_pt_DN_or_UP F x f1 Hf1) as [Hd1|Hu1] ; - destruct (Rnd_N_pt_DN_or_UP F x f2 Hf2) as [Hd2|Hu2]. -apply Rlt_not_eq with (1 := H12). -now apply Rnd_DN_pt_unicity with (1 := Hd1). -apply Hdu. -rewrite Rnd_DN_pt_unicity with (1 := Hd) (2 := Hd1). -rewrite Rnd_UP_pt_unicity with (1 := Hu) (2 := Hu2). -rewrite <- (Rabs_pos_eq (x - f1)). -rewrite <- (Rabs_pos_eq (f2 - x)). -rewrite Rabs_minus_sym. -apply Rle_antisym. -apply Hf1. apply Hf2. -apply Hf2. apply Hf1. -apply Rle_0_minus. -apply Hu2. -apply Rle_0_minus. -apply Hd1. -apply Rlt_not_le with (1 := H12). -apply Rle_trans with x. -apply Hd2. -apply Hu1. -apply Rgt_not_eq with (1 := H12). -now apply Rnd_UP_pt_unicity with (1 := Hu2). -intros Hf1 Hf2. -now apply Rle_antisym ; apply Rnot_lt_le ; refine (H _ _ _ _). -Qed. - -Theorem Rnd_N_pt_refl : - forall F : R -> Prop, - forall x : R, F x -> - Rnd_N_pt F x x. -Proof. -intros F x Hx. -repeat split. -exact Hx. -intros g _. -unfold Rminus at 1. -rewrite Rplus_opp_r, Rabs_R0. -apply Rabs_pos. -Qed. - -Theorem Rnd_N_pt_idempotent : - forall F : R -> Prop, - forall x f : R, - Rnd_N_pt F x f -> F x -> - f = x. -Proof. -intros F x f (_,Hf) Hx. -apply Rminus_diag_uniq. -destruct (Req_dec (f - x) 0) as [H|H]. -exact H. -elim Rabs_no_R0 with (1 := H). -apply Rle_antisym. -replace 0 with (Rabs (x - x)). -now apply Hf. -unfold Rminus. -rewrite Rplus_opp_r. -apply Rabs_R0. -apply Rabs_pos. -Qed. - -Theorem Rnd_N_pt_0 : - forall F : R -> Prop, - F 0 -> - Rnd_N_pt F 0 0. -Proof. -intros F HF. -split. -exact HF. -intros g _. -rewrite 2!Rminus_0_r, Rabs_R0. -apply Rabs_pos. -Qed. - -Theorem Rnd_N_pt_pos : - forall F : R -> Prop, F 0 -> - forall x f, 0 <= x -> - Rnd_N_pt F x f -> - 0 <= f. -Proof. -intros F HF x f [Hx|Hx] Hxf. -eapply Rnd_N_pt_monotone ; try eassumption. -now apply Rnd_N_pt_0. -right. -apply sym_eq. -apply Rnd_N_pt_idempotent with F. -now rewrite Hx. -exact HF. -Qed. - -Theorem Rnd_N_pt_neg : - forall F : R -> Prop, F 0 -> - forall x f, x <= 0 -> - Rnd_N_pt F x f -> - f <= 0. -Proof. -intros F HF x f [Hx|Hx] Hxf. -eapply Rnd_N_pt_monotone ; try eassumption. -now apply Rnd_N_pt_0. -right. -apply Rnd_N_pt_idempotent with F. -now rewrite <- Hx. -exact HF. -Qed. - -Theorem Rnd_N_pt_abs : - forall F : R -> Prop, - F 0 -> - ( forall x, F x -> F (- x) ) -> - forall x f : R, - Rnd_N_pt F x f -> Rnd_N_pt F (Rabs x) (Rabs f). -Proof. -intros F HF0 HF x f Hxf. -unfold Rabs at 1. -destruct (Rcase_abs x) as [Hx|Hx]. -rewrite Rabs_left1. -apply Rnd_N_pt_sym. -exact HF. -now rewrite 2!Ropp_involutive. -apply Rnd_N_pt_neg with (3 := Hxf). -exact HF0. -now apply Rlt_le. -rewrite Rabs_pos_eq. -exact Hxf. -apply Rnd_N_pt_pos with (3 := Hxf). -exact HF0. -now apply Rge_le. -Qed. - -Theorem Rnd_DN_UP_pt_N : - forall F : R -> Prop, - forall x d u f : R, - F f -> - Rnd_DN_pt F x d -> - Rnd_UP_pt F x u -> - (Rabs (f - x) <= x - d)%R -> - (Rabs (f - x) <= u - x)%R -> - Rnd_N_pt F x f. -Proof. -intros F x d u f Hf Hxd Hxu Hd Hu. -split. -exact Hf. -intros g Hg. -destruct (Rnd_DN_UP_pt_split F x d u Hxd Hxu g Hg) as [Hgd|Hgu]. -(* g <= d *) -apply Rle_trans with (1 := Hd). -rewrite Rabs_left1. -rewrite Ropp_minus_distr. -apply Rplus_le_compat_l. -now apply Ropp_le_contravar. -apply Rle_minus. -apply Rle_trans with (1 := Hgd). -apply Hxd. -(* u <= g *) -apply Rle_trans with (1 := Hu). -rewrite Rabs_pos_eq. -now apply Rplus_le_compat_r. -apply Rle_0_minus. -apply Rle_trans with (2 := Hgu). -apply Hxu. -Qed. - -Theorem Rnd_DN_pt_N : - forall F : R -> Prop, - forall x d u : R, - Rnd_DN_pt F x d -> - Rnd_UP_pt F x u -> - (x - d <= u - x)%R -> - Rnd_N_pt F x d. -Proof. -intros F x d u Hd Hu Hx. -assert (Hdx: (Rabs (d - x) = x - d)%R). -rewrite Rabs_minus_sym. -apply Rabs_pos_eq. -apply Rle_0_minus. -apply Hd. -apply Rnd_DN_UP_pt_N with (2 := Hd) (3 := Hu). -apply Hd. -rewrite Hdx. -apply Rle_refl. -now rewrite Hdx. -Qed. - -Theorem Rnd_UP_pt_N : - forall F : R -> Prop, - forall x d u : R, - Rnd_DN_pt F x d -> - Rnd_UP_pt F x u -> - (u - x <= x - d)%R -> - Rnd_N_pt F x u. -Proof. -intros F x d u Hd Hu Hx. -assert (Hux: (Rabs (u - x) = u - x)%R). -apply Rabs_pos_eq. -apply Rle_0_minus. -apply Hu. -apply Rnd_DN_UP_pt_N with (2 := Hd) (3 := Hu). -apply Hu. -now rewrite Hux. -rewrite Hux. -apply Rle_refl. -Qed. - -Definition Rnd_NG_pt_unicity_prop F P := - forall x d u, - Rnd_DN_pt F x d -> Rnd_N_pt F x d -> - Rnd_UP_pt F x u -> Rnd_N_pt F x u -> - P x d -> P x u -> d = u. - -Theorem Rnd_NG_pt_unicity : - forall (F : R -> Prop) (P : R -> R -> Prop), - Rnd_NG_pt_unicity_prop F P -> - forall x f1 f2 : R, - Rnd_NG_pt F P x f1 -> Rnd_NG_pt F P x f2 -> - f1 = f2. -Proof. -intros F P HP x f1 f2 (H1a,H1b) (H2a,H2b). -destruct H1b as [H1b|H1b]. -destruct H2b as [H2b|H2b]. -destruct (Rnd_N_pt_DN_or_UP _ _ _ H1a) as [H1c|H1c] ; - destruct (Rnd_N_pt_DN_or_UP _ _ _ H2a) as [H2c|H2c]. -eapply Rnd_DN_pt_unicity ; eassumption. -now apply (HP x f1 f2). -apply sym_eq. -now apply (HP x f2 f1 H2c H2a H1c H1a). -eapply Rnd_UP_pt_unicity ; eassumption. -now apply H2b. -apply sym_eq. -now apply H1b. -Qed. - -Theorem Rnd_NG_pt_monotone : - forall (F : R -> Prop) (P : R -> R -> Prop), - Rnd_NG_pt_unicity_prop F P -> - round_pred_monotone (Rnd_NG_pt F P). -Proof. -intros F P HP x y f g (Hf,Hx) (Hg,Hy) [Hxy|Hxy]. -now apply Rnd_N_pt_monotone with F x y. -apply Req_le. -rewrite <- Hxy in Hg, Hy. -eapply Rnd_NG_pt_unicity ; try split ; eassumption. -Qed. - -Theorem Rnd_NG_pt_refl : - forall (F : R -> Prop) (P : R -> R -> Prop), - forall x, F x -> Rnd_NG_pt F P x x. -Proof. -intros F P x Hx. -split. -now apply Rnd_N_pt_refl. -right. -intros f2 Hf2. -now apply Rnd_N_pt_idempotent with F. -Qed. - -Theorem Rnd_NG_pt_sym : - forall (F : R -> Prop) (P : R -> R -> Prop), - ( forall x, F x -> F (-x) ) -> - ( forall x f, P x f -> P (-x) (-f) ) -> - forall x f : R, - Rnd_NG_pt F P (-x) (-f) -> Rnd_NG_pt F P x f. -Proof. -intros F P HF HP x f (H1,H2). -split. -now apply Rnd_N_pt_sym. -destruct H2 as [H2|H2]. -left. -rewrite <- (Ropp_involutive x), <- (Ropp_involutive f). -now apply HP. -right. -intros f2 Hxf2. -rewrite <- (Ropp_involutive f). -rewrite <- H2 with (-f2). -apply sym_eq. -apply Ropp_involutive. -apply Rnd_N_pt_sym. -exact HF. -now rewrite 2!Ropp_involutive. -Qed. - -Theorem Rnd_NG_unicity : - forall (F : R -> Prop) (P : R -> R -> Prop), - Rnd_NG_pt_unicity_prop F P -> - forall rnd1 rnd2 : R -> R, - Rnd_NG F P rnd1 -> Rnd_NG F P rnd2 -> - forall x, rnd1 x = rnd2 x. -Proof. -intros F P HP rnd1 rnd2 H1 H2 x. -now apply Rnd_NG_pt_unicity with F P x. -Qed. - -Theorem Rnd_NA_NG_pt : - forall F : R -> Prop, - F 0 -> - forall x f, - Rnd_NA_pt F x f <-> Rnd_NG_pt F (fun x f => Rabs x <= Rabs f) x f. -Proof. -intros F HF x f. -destruct (Rle_or_lt 0 x) as [Hx|Hx]. -(* *) -split ; intros (H1, H2). -(* . *) -assert (Hf := Rnd_N_pt_pos F HF x f Hx H1). -split. -exact H1. -destruct (Rnd_N_pt_DN_or_UP _ _ _ H1) as [H3|H3]. -(* . . *) -right. -intros f2 Hxf2. -specialize (H2 _ Hxf2). -destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H4|H4]. -eapply Rnd_DN_pt_unicity ; eassumption. -apply Rle_antisym. -rewrite Rabs_pos_eq with (1 := Hf) in H2. -rewrite Rabs_pos_eq in H2. -exact H2. -now apply Rnd_N_pt_pos with F x. -apply Rle_trans with x. -apply H3. -apply H4. -(* . . *) -left. -rewrite Rabs_pos_eq with (1 := Hf). -rewrite Rabs_pos_eq with (1 := Hx). -apply H3. -(* . *) -split. -exact H1. -intros f2 Hxf2. -destruct H2 as [H2|H2]. -assert (Hf := Rnd_N_pt_pos F HF x f Hx H1). -assert (Hf2 := Rnd_N_pt_pos F HF x f2 Hx Hxf2). -rewrite 2!Rabs_pos_eq ; trivial. -rewrite 2!Rabs_pos_eq in H2 ; trivial. -destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H3|H3]. -apply Rle_trans with (2 := H2). -apply H3. -apply H3. -apply H1. -apply H2. -rewrite (H2 _ Hxf2). -apply Rle_refl. -(* *) -assert (Hx' := Rlt_le _ _ Hx). -clear Hx. rename Hx' into Hx. -split ; intros (H1, H2). -(* . *) -assert (Hf := Rnd_N_pt_neg F HF x f Hx H1). -split. -exact H1. -destruct (Rnd_N_pt_DN_or_UP _ _ _ H1) as [H3|H3]. -(* . . *) -left. -rewrite Rabs_left1 with (1 := Hf). -rewrite Rabs_left1 with (1 := Hx). -apply Ropp_le_contravar. -apply H3. -(* . . *) -right. -intros f2 Hxf2. -specialize (H2 _ Hxf2). -destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H4|H4]. -apply Rle_antisym. -apply Rle_trans with x. -apply H4. -apply H3. -rewrite Rabs_left1 with (1 := Hf) in H2. -rewrite Rabs_left1 in H2. -now apply Ropp_le_cancel. -now apply Rnd_N_pt_neg with F x. -eapply Rnd_UP_pt_unicity ; eassumption. -(* . *) -split. -exact H1. -intros f2 Hxf2. -destruct H2 as [H2|H2]. -assert (Hf := Rnd_N_pt_neg F HF x f Hx H1). -assert (Hf2 := Rnd_N_pt_neg F HF x f2 Hx Hxf2). -rewrite 2!Rabs_left1 ; trivial. -rewrite 2!Rabs_left1 in H2 ; trivial. -apply Ropp_le_contravar. -apply Ropp_le_cancel in H2. -destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H3|H3]. -apply H3. -apply H1. -apply H2. -apply Rle_trans with (1 := H2). -apply H3. -rewrite (H2 _ Hxf2). -apply Rle_refl. -Qed. - -Theorem Rnd_NA_pt_unicity_prop : - forall F : R -> Prop, - F 0 -> - Rnd_NG_pt_unicity_prop F (fun a b => (Rabs a <= Rabs b)%R). -Proof. -intros F HF x d u Hxd1 Hxd2 Hxu1 Hxu2 Hd Hu. -apply Rle_antisym. -apply Rle_trans with x. -apply Hxd1. -apply Hxu1. -destruct (Rle_or_lt 0 x) as [Hx|Hx]. -apply Hxu1. -apply Hxd1. -rewrite Rabs_pos_eq with (1 := Hx) in Hd. -rewrite Rabs_pos_eq in Hd. -exact Hd. -now apply Hxd1. -apply Hxd1. -apply Hxu1. -rewrite Rabs_left with (1 := Hx) in Hu. -rewrite Rabs_left1 in Hu. -now apply Ropp_le_cancel. -apply Hxu1. -apply HF. -now apply Rlt_le. -Qed. - -Theorem Rnd_NA_pt_unicity : - forall F : R -> Prop, - F 0 -> - forall x f1 f2 : R, - Rnd_NA_pt F x f1 -> Rnd_NA_pt F x f2 -> - f1 = f2. -Proof. -intros F HF x f1 f2 H1 H2. -apply (Rnd_NG_pt_unicity F _ (Rnd_NA_pt_unicity_prop F HF) x). -now apply -> Rnd_NA_NG_pt. -now apply -> Rnd_NA_NG_pt. -Qed. - -Theorem Rnd_NA_N_pt : - forall F : R -> Prop, - F 0 -> - forall x f : R, - Rnd_N_pt F x f -> - (Rabs x <= Rabs f)%R -> - Rnd_NA_pt F x f. -Proof. -intros F HF x f Rxf Hxf. -split. -apply Rxf. -intros g Rxg. -destruct (Rabs_eq_Rabs (f - x) (g - x)) as [H|H]. -apply Rle_antisym. -apply Rxf. -apply Rxg. -apply Rxg. -apply Rxf. -(* *) -replace g with f. -apply Rle_refl. -apply Rplus_eq_reg_r with (1 := H). -(* *) -assert (g = 2 * x - f)%R. -replace (2 * x - f)%R with (x - (f - x))%R by ring. -rewrite H. -ring. -destruct (Rle_lt_dec 0 x) as [Hx|Hx]. -(* . *) -revert Hxf. -rewrite Rabs_pos_eq with (1 := Hx). -rewrite 2!Rabs_pos_eq ; try ( apply (Rnd_N_pt_pos F HF x) ; assumption ). -intros Hxf. -rewrite H0. -apply Rplus_le_reg_r with f. -ring_simplify. -apply Rmult_le_compat_l with (2 := Hxf). -now apply (Z2R_le 0 2). -(* . *) -revert Hxf. -apply Rlt_le in Hx. -rewrite Rabs_left1 with (1 := Hx). -rewrite 2!Rabs_left1 ; try ( apply (Rnd_N_pt_neg F HF x) ; assumption ). -intros Hxf. -rewrite H0. -apply Ropp_le_contravar. -apply Rplus_le_reg_r with f. -ring_simplify. -apply Rmult_le_compat_l. -now apply (Z2R_le 0 2). -now apply Ropp_le_cancel. -Qed. - -Theorem Rnd_NA_unicity : - forall (F : R -> Prop), - F 0 -> - forall rnd1 rnd2 : R -> R, - Rnd_NA F rnd1 -> Rnd_NA F rnd2 -> - forall x, rnd1 x = rnd2 x. -Proof. -intros F HF rnd1 rnd2 H1 H2 x. -now apply Rnd_NA_pt_unicity with F x. -Qed. - -Theorem Rnd_NA_pt_monotone : - forall F : R -> Prop, - F 0 -> - round_pred_monotone (Rnd_NA_pt F). -Proof. -intros F HF x y f g Hxf Hyg Hxy. -apply (Rnd_NG_pt_monotone F _ (Rnd_NA_pt_unicity_prop F HF) x y). -now apply -> Rnd_NA_NG_pt. -now apply -> Rnd_NA_NG_pt. -exact Hxy. -Qed. - -Theorem Rnd_NA_pt_refl : - forall F : R -> Prop, - forall x : R, F x -> - Rnd_NA_pt F x x. -Proof. -intros F x Hx. -split. -now apply Rnd_N_pt_refl. -intros f Hxf. -apply Req_le. -apply f_equal. -now apply Rnd_N_pt_idempotent with (1 := Hxf). -Qed. - -Theorem Rnd_NA_pt_idempotent : - forall F : R -> Prop, - forall x f : R, - Rnd_NA_pt F x f -> F x -> - f = x. -Proof. -intros F x f (Hf,_) Hx. -now apply Rnd_N_pt_idempotent with F. -Qed. - -Theorem round_pred_ge_0 : - forall P : R -> R -> Prop, - round_pred_monotone P -> - P 0 0 -> - forall x f, P x f -> 0 <= x -> 0 <= f. -Proof. -intros P HP HP0 x f Hxf Hx. -now apply (HP 0 x). -Qed. - -Theorem round_pred_gt_0 : - forall P : R -> R -> Prop, - round_pred_monotone P -> - P 0 0 -> - forall x f, P x f -> 0 < f -> 0 < x. -Proof. -intros P HP HP0 x f Hxf Hf. -apply Rnot_le_lt. -intros Hx. -apply Rlt_not_le with (1 := Hf). -now apply (HP x 0). -Qed. - -Theorem round_pred_le_0 : - forall P : R -> R -> Prop, - round_pred_monotone P -> - P 0 0 -> - forall x f, P x f -> x <= 0 -> f <= 0. -Proof. -intros P HP HP0 x f Hxf Hx. -now apply (HP x 0). -Qed. - -Theorem round_pred_lt_0 : - forall P : R -> R -> Prop, - round_pred_monotone P -> - P 0 0 -> - forall x f, P x f -> f < 0 -> x < 0. -Proof. -intros P HP HP0 x f Hxf Hf. -apply Rnot_le_lt. -intros Hx. -apply Rlt_not_le with (1 := Hf). -now apply (HP 0 x). -Qed. - -Theorem Rnd_DN_pt_equiv_format : - forall F1 F2 : R -> Prop, - forall a b : R, - F1 a -> - ( forall x, a <= x <= b -> (F1 x <-> F2 x) ) -> - forall x f, a <= x <= b -> Rnd_DN_pt F1 x f -> Rnd_DN_pt F2 x f. -Proof. -intros F1 F2 a b Ha HF x f Hx (H1, (H2, H3)). -split. -apply -> HF. -exact H1. -split. -now apply H3. -now apply Rle_trans with (1 := H2). -split. -exact H2. -intros k Hk Hl. -destruct (Rlt_or_le k a) as [H|H]. -apply Rlt_le. -apply Rlt_le_trans with (1 := H). -now apply H3. -apply H3. -apply <- HF. -exact Hk. -split. -exact H. -now apply Rle_trans with (1 := Hl). -exact Hl. -Qed. - -Theorem Rnd_UP_pt_equiv_format : - forall F1 F2 : R -> Prop, - forall a b : R, - F1 b -> - ( forall x, a <= x <= b -> (F1 x <-> F2 x) ) -> - forall x f, a <= x <= b -> Rnd_UP_pt F1 x f -> Rnd_UP_pt F2 x f. -Proof. -intros F1 F2 a b Hb HF x f Hx (H1, (H2, H3)). -split. -apply -> HF. -exact H1. -split. -now apply Rle_trans with (2 := H2). -now apply H3. -split. -exact H2. -intros k Hk Hl. -destruct (Rle_or_lt k b) as [H|H]. -apply H3. -apply <- HF. -exact Hk. -split. -now apply Rle_trans with (2 := Hl). -exact H. -exact Hl. -apply Rlt_le. -apply Rle_lt_trans with (2 := H). -now apply H3. -Qed. - -(** ensures a real number can always be rounded *) -Inductive satisfies_any (F : R -> Prop) := - Satisfies_any : - F 0 -> ( forall x : R, F x -> F (-x) ) -> - round_pred_total (Rnd_DN_pt F) -> satisfies_any F. - -Theorem satisfies_any_eq : - forall F1 F2 : R -> Prop, - ( forall x, F1 x <-> F2 x ) -> - satisfies_any F1 -> - satisfies_any F2. -Proof. -intros F1 F2 Heq (Hzero, Hsym, Hrnd). -split. -now apply -> Heq. -intros x Hx. -apply -> Heq. -apply Hsym. -now apply <- Heq. -intros x. -destruct (Hrnd x) as (f, (H1, (H2, H3))). -exists f. -split. -now apply -> Heq. -split. -exact H2. -intros g Hg Hgx. -apply H3. -now apply <- Heq. -exact Hgx. -Qed. - -Theorem satisfies_any_imp_DN : - forall F : R -> Prop, - satisfies_any F -> - round_pred (Rnd_DN_pt F). -Proof. -intros F (_,_,Hrnd). -split. -apply Hrnd. -apply Rnd_DN_pt_monotone. -Qed. - -Theorem satisfies_any_imp_UP : - forall F : R -> Prop, - satisfies_any F -> - round_pred (Rnd_UP_pt F). -Proof. -intros F Hany. -split. -intros x. -destruct (proj1 (satisfies_any_imp_DN F Hany) (-x)) as (f, Hf). -exists (-f). -rewrite <- (Ropp_involutive x). -apply Rnd_DN_UP_pt_sym. -apply Hany. -exact Hf. -apply Rnd_UP_pt_monotone. -Qed. - -Theorem satisfies_any_imp_ZR : - forall F : R -> Prop, - satisfies_any F -> - round_pred (Rnd_ZR_pt F). -Proof. -intros F Hany. -split. -intros x. -destruct (Rle_or_lt 0 x) as [Hx|Hx]. -(* positive *) -destruct (proj1 (satisfies_any_imp_DN F Hany) x) as (f, Hf). -exists f. -split. -now intros _. -intros Hx'. -(* zero *) -assert (x = 0). -now apply Rle_antisym. -rewrite H in Hf |- *. -clear H Hx Hx'. -rewrite Rnd_DN_pt_idempotent with (1 := Hf). -apply Rnd_UP_pt_refl. -apply Hany. -apply Hany. -(* negative *) -destruct (proj1 (satisfies_any_imp_UP F Hany) x) as (f, Hf). -exists f. -split. -intros Hx'. -elim (Rlt_irrefl 0). -now apply Rle_lt_trans with x. -now intros _. -(* . *) -apply Rnd_ZR_pt_monotone. -apply Hany. -Qed. - -Definition NG_existence_prop (F : R -> Prop) (P : R -> R -> Prop) := - forall x d u, ~F x -> Rnd_DN_pt F x d -> Rnd_UP_pt F x u -> P x u \/ P x d. - -Theorem satisfies_any_imp_NG : - forall (F : R -> Prop) (P : R -> R -> Prop), - satisfies_any F -> - NG_existence_prop F P -> - round_pred_total (Rnd_NG_pt F P). -Proof. -intros F P Hany HP x. -destruct (proj1 (satisfies_any_imp_DN F Hany) x) as (d, Hd). -destruct (proj1 (satisfies_any_imp_UP F Hany) x) as (u, Hu). -destruct (total_order_T (Rabs (u - x)) (Rabs (d - x))) as [[H|H]|H]. -(* |up(x) - x| < |dn(x) - x| *) -exists u. -split. -(* - . *) -split. -apply Hu. -intros g Hg. -destruct (Rle_or_lt x g) as [Hxg|Hxg]. -rewrite 2!Rabs_pos_eq. -apply Rplus_le_compat_r. -now apply Hu. -now apply Rle_0_minus. -apply Rle_0_minus. -apply Hu. -apply Rlt_le in Hxg. -apply Rlt_le. -apply Rlt_le_trans with (1 := H). -do 2 rewrite <- (Rabs_minus_sym x). -rewrite 2!Rabs_pos_eq. -apply Rplus_le_compat_l. -apply Ropp_le_contravar. -now apply Hd. -now apply Rle_0_minus. -apply Rle_0_minus. -apply Hd. -(* - . *) -right. -intros f Hf. -destruct (Rnd_N_pt_DN_or_UP_eq F x _ _ _ Hd Hu Hf) as [K|K] ; rewrite K. -elim Rlt_not_le with (1 := H). -rewrite <- K. -apply Hf. -apply Hu. -apply refl_equal. -(* |up(x) - x| = |dn(x) - x| *) -destruct (Req_dec x d) as [He|Hne]. -(* - x = d = u *) -exists x. -split. -apply Rnd_N_pt_refl. -rewrite He. -apply Hd. -right. -intros. -apply Rnd_N_pt_idempotent with (1 := H0). -rewrite He. -apply Hd. -assert (Hf : ~F x). -intros Hf. -apply Hne. -apply sym_eq. -now apply Rnd_DN_pt_idempotent with (1 := Hd). -destruct (HP x _ _ Hf Hd Hu) as [H'|H']. -(* - u >> d *) -exists u. -split. -split. -apply Hu. -intros g Hg. -destruct (Rle_or_lt x g) as [Hxg|Hxg]. -rewrite 2!Rabs_pos_eq. -apply Rplus_le_compat_r. -now apply Hu. -now apply Rle_0_minus. -apply Rle_0_minus. -apply Hu. -apply Rlt_le in Hxg. -rewrite H. -rewrite 2!Rabs_left1. -apply Ropp_le_contravar. -apply Rplus_le_compat_r. -now apply Hd. -now apply Rle_minus. -apply Rle_minus. -apply Hd. -now left. -(* - d >> u *) -exists d. -split. -split. -apply Hd. -intros g Hg. -destruct (Rle_or_lt x g) as [Hxg|Hxg]. -rewrite <- H. -rewrite 2!Rabs_pos_eq. -apply Rplus_le_compat_r. -now apply Hu. -now apply Rle_0_minus. -apply Rle_0_minus. -apply Hu. -apply Rlt_le in Hxg. -rewrite 2!Rabs_left1. -apply Ropp_le_contravar. -apply Rplus_le_compat_r. -now apply Hd. -now apply Rle_minus. -apply Rle_minus. -apply Hd. -now left. -(* |up(x) - x| > |dn(x) - x| *) -exists d. -split. -split. -apply Hd. -intros g Hg. -destruct (Rle_or_lt x g) as [Hxg|Hxg]. -apply Rlt_le. -apply Rlt_le_trans with (1 := H). -rewrite 2!Rabs_pos_eq. -apply Rplus_le_compat_r. -now apply Hu. -now apply Rle_0_minus. -apply Rle_0_minus. -apply Hu. -apply Rlt_le in Hxg. -rewrite 2!Rabs_left1. -apply Ropp_le_contravar. -apply Rplus_le_compat_r. -now apply Hd. -now apply Rle_minus. -apply Rle_minus. -apply Hd. -right. -intros f Hf. -destruct (Rnd_N_pt_DN_or_UP_eq F x _ _ _ Hd Hu Hf) as [K|K] ; rewrite K. -apply refl_equal. -elim Rlt_not_le with (1 := H). -rewrite <- K. -apply Hf. -apply Hd. -Qed. - -Theorem satisfies_any_imp_NA : - forall F : R -> Prop, - satisfies_any F -> - round_pred (Rnd_NA_pt F). -Proof. -intros F Hany. -split. -assert (H : round_pred_total (Rnd_NG_pt F (fun a b => (Rabs a <= Rabs b)%R))). -apply satisfies_any_imp_NG. -apply Hany. -intros x d u Hf Hd Hu. -destruct (Rle_lt_dec 0 x) as [Hx|Hx]. -left. -rewrite Rabs_pos_eq with (1 := Hx). -rewrite Rabs_pos_eq. -apply Hu. -apply Rle_trans with (1 := Hx). -apply Hu. -right. -rewrite Rabs_left with (1 := Hx). -rewrite Rabs_left1. -apply Ropp_le_contravar. -apply Hd. -apply Rlt_le in Hx. -apply Rle_trans with (2 := Hx). -apply Hd. -intros x. -destruct (H x) as (f, Hf). -exists f. -apply <- Rnd_NA_NG_pt. -apply Hf. -apply Hany. -apply Rnd_NA_pt_monotone. -apply Hany. -Qed. - -End RND_prop. diff --git a/flocq/Core/Fcore_rnd_ne.v b/flocq/Core/Fcore_rnd_ne.v deleted file mode 100644 index 2d67e709..00000000 --- a/flocq/Core/Fcore_rnd_ne.v +++ /dev/null @@ -1,552 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2010-2013 Sylvie Boldo -#
# -Copyright (C) 2010-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** * Rounding to nearest, ties to even: existence, unicity... *) -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_rnd. -Require Import Fcore_generic_fmt. -Require Import Fcore_float_prop. -Require Import Fcore_ulp. - -Notation ZnearestE := (Znearest (fun x => negb (Zeven x))). - -Section Fcore_rnd_NE. - -Variable beta : radix. - -Notation bpow e := (bpow beta e). - -Variable fexp : Z -> Z. - -Context { valid_exp : Valid_exp fexp }. - -Notation format := (generic_format beta fexp). -Notation canonic := (canonic beta fexp). - -Definition NE_prop (_ : R) f := - exists g : float beta, f = F2R g /\ canonic g /\ Zeven (Fnum g) = true. - -Definition Rnd_NE_pt := - Rnd_NG_pt format NE_prop. - -Definition DN_UP_parity_pos_prop := - forall x xd xu, - (0 < x)%R -> - ~ format x -> - canonic xd -> - canonic xu -> - F2R xd = round beta fexp Zfloor x -> - F2R xu = round beta fexp Zceil x -> - Zeven (Fnum xu) = negb (Zeven (Fnum xd)). - -Definition DN_UP_parity_prop := - forall x xd xu, - ~ format x -> - canonic xd -> - canonic xu -> - F2R xd = round beta fexp Zfloor x -> - F2R xu = round beta fexp Zceil x -> - Zeven (Fnum xu) = negb (Zeven (Fnum xd)). - -Lemma DN_UP_parity_aux : - DN_UP_parity_pos_prop -> - DN_UP_parity_prop. -Proof. -intros Hpos x xd xu Hfx Hd Hu Hxd Hxu. -destruct (total_order_T 0 x) as [[Hx|Hx]|Hx]. -(* . *) -exact (Hpos x xd xu Hx Hfx Hd Hu Hxd Hxu). -elim Hfx. -rewrite <- Hx. -apply generic_format_0. -(* . *) -assert (Hx': (0 < -x)%R). -apply Ropp_lt_cancel. -now rewrite Ropp_involutive, Ropp_0. -destruct xd as (md, ed). -destruct xu as (mu, eu). -simpl. -rewrite <- (Bool.negb_involutive (Zeven mu)). -apply f_equal. -apply sym_eq. -rewrite <- (Zeven_opp mu), <- (Zeven_opp md). -change (Zeven (Fnum (Float beta (-md) ed)) = negb (Zeven (Fnum (Float beta (-mu) eu)))). -apply (Hpos (-x)%R _ _ Hx'). -intros H. -apply Hfx. -rewrite <- Ropp_involutive. -now apply generic_format_opp. -now apply canonic_opp. -now apply canonic_opp. -rewrite round_DN_opp, F2R_Zopp. -now apply f_equal. -rewrite round_UP_opp, F2R_Zopp. -now apply f_equal. -Qed. - -Class Exists_NE := - exists_NE : Zeven beta = false \/ forall e, - ((fexp e < e)%Z -> (fexp (e + 1) < e)%Z) /\ ((e <= fexp e)%Z -> fexp (fexp e + 1) = fexp e). - -Context { exists_NE_ : Exists_NE }. - -Theorem DN_UP_parity_generic_pos : - DN_UP_parity_pos_prop. -Proof with auto with typeclass_instances. -intros x xd xu H0x Hfx Hd Hu Hxd Hxu. -destruct (ln_beta beta x) as (ex, Hexa). -specialize (Hexa (Rgt_not_eq _ _ H0x)). -generalize Hexa. intros Hex. -rewrite (Rabs_pos_eq _ (Rlt_le _ _ H0x)) in Hex. -destruct (Zle_or_lt ex (fexp ex)) as [Hxe|Hxe]. -(* small x *) -assert (Hd3 : Fnum xd = Z0). -apply F2R_eq_0_reg with beta (Fexp xd). -change (F2R xd = R0). -rewrite Hxd. -apply round_DN_small_pos with (1 := Hex) (2 := Hxe). -assert (Hu3 : xu = Float beta (1 * Zpower beta (fexp ex - fexp (fexp ex + 1))) (fexp (fexp ex + 1))). -apply canonic_unicity with (1 := Hu). -apply (f_equal fexp). -rewrite <- F2R_change_exp. -now rewrite F2R_bpow, ln_beta_bpow. -now apply valid_exp. -rewrite <- F2R_change_exp. -rewrite F2R_bpow. -apply sym_eq. -rewrite Hxu. -apply sym_eq. -apply round_UP_small_pos with (1 := Hex) (2 := Hxe). -now apply valid_exp. -rewrite Hd3, Hu3. -rewrite Zmult_1_l. -simpl. -destruct exists_NE_ as [H|H]. -apply Zeven_Zpower_odd with (2 := H). -apply Zle_minus_le_0. -now apply valid_exp. -rewrite (proj2 (H ex)). -now rewrite Zminus_diag. -exact Hxe. -(* large x *) -assert (Hd4: (bpow (ex - 1) <= Rabs (F2R xd) < bpow ex)%R). -rewrite Rabs_pos_eq. -rewrite Hxd. -split. -apply (round_DN_pt beta fexp x). -apply generic_format_bpow. -ring_simplify (ex - 1 + 1)%Z. -omega. -apply Hex. -apply Rle_lt_trans with (2 := proj2 Hex). -apply (round_DN_pt beta fexp x). -rewrite Hxd. -apply (round_DN_pt beta fexp x). -apply generic_format_0. -now apply Rlt_le. -assert (Hxe2 : (fexp (ex + 1) <= ex)%Z) by now apply valid_exp. -assert (Hud: (F2R xu = F2R xd + ulp beta fexp x)%R). -rewrite Hxu, Hxd. -now apply round_UP_DN_ulp. -destruct (total_order_T (bpow ex) (F2R xu)) as [[Hu2|Hu2]|Hu2]. -(* - xu > bpow ex *) -elim (Rlt_not_le _ _ Hu2). -rewrite Hxu. -apply round_bounded_large_pos... -(* - xu = bpow ex *) -assert (Hu3: xu = Float beta (1 * Zpower beta (ex - fexp (ex + 1))) (fexp (ex + 1))). -apply canonic_unicity with (1 := Hu). -apply (f_equal fexp). -rewrite <- F2R_change_exp. -now rewrite F2R_bpow, ln_beta_bpow. -now apply valid_exp. -rewrite <- Hu2. -apply sym_eq. -rewrite <- F2R_change_exp. -apply F2R_bpow. -exact Hxe2. -assert (Hd3: xd = Float beta (Zpower beta (ex - fexp ex) - 1) (fexp ex)). -assert (H: F2R xd = F2R (Float beta (Zpower beta (ex - fexp ex) - 1) (fexp ex))). -unfold F2R. simpl. -rewrite Z2R_minus. -unfold Rminus. -rewrite Rmult_plus_distr_r. -rewrite Z2R_Zpower, <- bpow_plus. -ring_simplify (ex - fexp ex + fexp ex)%Z. -rewrite Hu2, Hud. -rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq]. -unfold canonic_exp. -rewrite ln_beta_unique with beta x ex. -unfold F2R. -simpl. ring. -rewrite Rabs_pos_eq. -exact Hex. -now apply Rlt_le. -apply Zle_minus_le_0. -now apply Zlt_le_weak. -apply canonic_unicity with (1 := Hd) (3 := H). -apply (f_equal fexp). -rewrite <- H. -apply sym_eq. -now apply ln_beta_unique. -rewrite Hd3, Hu3. -unfold Fnum. -rewrite Zeven_mult. simpl. -unfold Zminus at 2. -rewrite Zeven_plus. -rewrite eqb_sym. simpl. -fold (negb (Zeven (beta ^ (ex - fexp ex)))). -rewrite Bool.negb_involutive. -rewrite (Zeven_Zpower beta (ex - fexp ex)). 2: omega. -destruct exists_NE_. -rewrite H. -apply Zeven_Zpower_odd with (2 := H). -now apply Zle_minus_le_0. -apply Zeven_Zpower. -specialize (H ex). -omega. -(* - xu < bpow ex *) -revert Hud. -rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq]. -unfold F2R. -rewrite Hd, Hu. -unfold canonic_exp. -rewrite ln_beta_unique with beta (F2R xu) ex. -rewrite ln_beta_unique with (1 := Hd4). -rewrite ln_beta_unique with (1 := Hexa). -intros H. -replace (Fnum xu) with (Fnum xd + 1)%Z. -rewrite Zeven_plus. -now apply eqb_sym. -apply sym_eq. -apply eq_Z2R. -rewrite Z2R_plus. -apply Rmult_eq_reg_r with (bpow (fexp ex)). -rewrite H. -simpl. ring. -apply Rgt_not_eq. -apply bpow_gt_0. -rewrite Rabs_pos_eq. -split. -apply Rle_trans with (1 := proj1 Hex). -rewrite Hxu. -apply (round_UP_pt beta fexp x). -exact Hu2. -apply Rlt_le. -apply Rlt_le_trans with (1 := H0x). -rewrite Hxu. -apply (round_UP_pt beta fexp x). -Qed. - -Theorem DN_UP_parity_generic : - DN_UP_parity_prop. -Proof. -apply DN_UP_parity_aux. -apply DN_UP_parity_generic_pos. -Qed. - -Theorem Rnd_NE_pt_total : - round_pred_total Rnd_NE_pt. -Proof. -apply satisfies_any_imp_NG. -now apply generic_format_satisfies_any. -intros x d u Hf Hd Hu. -generalize (proj1 Hd). -unfold generic_format. -set (ed := canonic_exp beta fexp d). -set (md := Ztrunc (scaled_mantissa beta fexp d)). -intros Hd1. -case_eq (Zeven md) ; [ intros He | intros Ho ]. -right. -exists (Float beta md ed). -unfold Fcore_generic_fmt.canonic. -rewrite <- Hd1. -now repeat split. -left. -generalize (proj1 Hu). -unfold generic_format. -set (eu := canonic_exp beta fexp u). -set (mu := Ztrunc (scaled_mantissa beta fexp u)). -intros Hu1. -rewrite Hu1. -eexists ; repeat split. -unfold Fcore_generic_fmt.canonic. -now rewrite <- Hu1. -rewrite (DN_UP_parity_generic x (Float beta md ed) (Float beta mu eu)). -simpl. -now rewrite Ho. -exact Hf. -unfold Fcore_generic_fmt.canonic. -now rewrite <- Hd1. -unfold Fcore_generic_fmt.canonic. -now rewrite <- Hu1. -rewrite <- Hd1. -apply Rnd_DN_pt_unicity with (1 := Hd). -now apply round_DN_pt. -rewrite <- Hu1. -apply Rnd_UP_pt_unicity with (1 := Hu). -now apply round_UP_pt. -Qed. - -Theorem Rnd_NE_pt_monotone : - round_pred_monotone Rnd_NE_pt. -Proof. -apply Rnd_NG_pt_monotone. -intros x d u Hd Hdn Hu Hun (cd, (Hd1, Hd2)) (cu, (Hu1, Hu2)). -destruct (Req_dec x d) as [Hx|Hx]. -rewrite <- Hx. -apply sym_eq. -apply Rnd_UP_pt_idempotent with (1 := Hu). -rewrite Hx. -apply Hd. -rewrite (DN_UP_parity_aux DN_UP_parity_generic_pos x cd cu) in Hu2 ; try easy. -now rewrite (proj2 Hd2) in Hu2. -intros Hf. -apply Hx. -apply sym_eq. -now apply Rnd_DN_pt_idempotent with (1 := Hd). -rewrite <- Hd1. -apply Rnd_DN_pt_unicity with (1 := Hd). -now apply round_DN_pt. -rewrite <- Hu1. -apply Rnd_UP_pt_unicity with (1 := Hu). -now apply round_UP_pt. -Qed. - -Theorem Rnd_NE_pt_round : - round_pred Rnd_NE_pt. -split. -apply Rnd_NE_pt_total. -apply Rnd_NE_pt_monotone. -Qed. - -Lemma round_NE_pt_pos : - forall x, - (0 < x)%R -> - Rnd_NE_pt x (round beta fexp ZnearestE x). -Proof with auto with typeclass_instances. -intros x Hx. -split. -now apply round_N_pt. -unfold NE_prop. -set (mx := scaled_mantissa beta fexp x). -set (xr := round beta fexp ZnearestE x). -destruct (Req_dec (mx - Z2R (Zfloor mx)) (/2)) as [Hm|Hm]. -(* midpoint *) -left. -exists (Float beta (Ztrunc (scaled_mantissa beta fexp xr)) (canonic_exp beta fexp xr)). -split. -apply round_N_pt... -split. -unfold Fcore_generic_fmt.canonic. simpl. -apply f_equal. -apply round_N_pt... -simpl. -unfold xr, round, Znearest. -fold mx. -rewrite Hm. -rewrite Rcompare_Eq. 2: apply refl_equal. -case_eq (Zeven (Zfloor mx)) ; intros Hmx. -(* . even floor *) -change (Zeven (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zfloor x))) = true). -destruct (Rle_or_lt (round beta fexp Zfloor x) 0) as [Hr|Hr]. -rewrite (Rle_antisym _ _ Hr). -unfold scaled_mantissa. -rewrite Rmult_0_l. -change 0%R with (Z2R 0). -now rewrite (Ztrunc_Z2R 0). -rewrite <- (round_0 beta fexp Zfloor). -apply round_le... -now apply Rlt_le. -rewrite scaled_mantissa_DN... -now rewrite Ztrunc_Z2R. -(* . odd floor *) -change (Zeven (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zceil x))) = true). -destruct (ln_beta beta x) as (ex, Hex). -specialize (Hex (Rgt_not_eq _ _ Hx)). -rewrite (Rabs_pos_eq _ (Rlt_le _ _ Hx)) in Hex. -destruct (Z_lt_le_dec (fexp ex) ex) as [He|He]. -(* .. large pos *) -assert (Hu := round_bounded_large_pos _ _ Zceil _ _ He Hex). -assert (Hfc: Zceil mx = (Zfloor mx + 1)%Z). -apply Zceil_floor_neq. -intros H. -rewrite H in Hm. -unfold Rminus in Hm. -rewrite Rplus_opp_r in Hm. -elim (Rlt_irrefl 0). -rewrite Hm at 2. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). -destruct (proj2 Hu) as [Hu'|Hu']. -(* ... u <> bpow *) -unfold scaled_mantissa. -rewrite canonic_exp_fexp_pos with (1 := conj (proj1 Hu) Hu'). -unfold round, F2R. simpl. -rewrite canonic_exp_fexp_pos with (1 := Hex). -rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r. -rewrite Ztrunc_Z2R. -fold mx. -rewrite Hfc. -now rewrite Zeven_plus, Hmx. -(* ... u = bpow *) -rewrite Hu'. -unfold scaled_mantissa, canonic_exp. -rewrite ln_beta_bpow. -rewrite <- bpow_plus, <- Z2R_Zpower. -rewrite Ztrunc_Z2R. -case_eq (Zeven beta) ; intros Hr. -destruct exists_NE_ as [Hs|Hs]. -now rewrite Hs in Hr. -destruct (Hs ex) as (H,_). -rewrite Zeven_Zpower. -exact Hr. -omega. -assert (Zeven (Zfloor mx) = true). 2: now rewrite H in Hmx. -replace (Zfloor mx) with (Zceil mx + -1)%Z by omega. -rewrite Zeven_plus. -apply eqb_true. -unfold mx. -replace (Zceil (scaled_mantissa beta fexp x)) with (Zpower beta (ex - fexp ex)). -rewrite Zeven_Zpower_odd with (2 := Hr). -easy. -omega. -apply eq_Z2R. -rewrite Z2R_Zpower. 2: omega. -apply Rmult_eq_reg_r with (bpow (fexp ex)). -unfold Zminus. -rewrite bpow_plus. -rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_l, Rmult_1_r. -pattern (fexp ex) ; rewrite <- canonic_exp_fexp_pos with (1 := Hex). -now apply sym_eq. -apply Rgt_not_eq. -apply bpow_gt_0. -generalize (proj1 (valid_exp ex) He). -omega. -(* .. small pos *) -assert (Zeven (Zfloor mx) = true). 2: now rewrite H in Hmx. -unfold mx, scaled_mantissa. -rewrite canonic_exp_fexp_pos with (1 := Hex). -now rewrite mantissa_DN_small_pos. -(* not midpoint *) -right. -intros g Hg. -destruct (Req_dec x g) as [Hxg|Hxg]. -rewrite <- Hxg. -apply sym_eq. -apply round_generic... -rewrite Hxg. -apply Hg. -set (d := round beta fexp Zfloor x). -set (u := round beta fexp Zceil x). -apply Rnd_N_pt_unicity with (d := d) (u := u) (4 := Hg). -now apply round_DN_pt. -now apply round_UP_pt. -2: now apply round_N_pt. -rewrite <- (scaled_mantissa_mult_bpow beta fexp x). -unfold d, u, round, F2R. simpl. fold mx. -rewrite <- 2!Rmult_minus_distr_r. -intros H. -apply Rmult_eq_reg_r in H. -apply Hm. -apply Rcompare_Eq_inv. -rewrite Rcompare_floor_ceil_mid. -now apply Rcompare_Eq. -contradict Hxg. -apply sym_eq. -apply Rnd_N_pt_idempotent with (1 := Hg). -rewrite <- (scaled_mantissa_mult_bpow beta fexp x). -fold mx. -rewrite <- Hxg. -change (Z2R (Zfloor mx) * bpow (canonic_exp beta fexp x))%R with d. -now eapply round_DN_pt. -apply Rgt_not_eq. -apply bpow_gt_0. -Qed. - -Theorem round_NE_opp : - forall x, - round beta fexp ZnearestE (-x) = (- round beta fexp ZnearestE x)%R. -Proof. -intros x. -unfold round. simpl. -rewrite scaled_mantissa_opp, canonic_exp_opp. -rewrite Znearest_opp. -rewrite <- F2R_Zopp. -apply (f_equal (fun v => F2R (Float beta (-v) _))). -set (m := scaled_mantissa beta fexp x). -unfold Znearest. -case Rcompare ; trivial. -apply (f_equal (fun (b : bool) => if b then Zceil m else Zfloor m)). -rewrite Bool.negb_involutive. -rewrite Zeven_opp. -rewrite Zeven_plus. -now rewrite eqb_sym. -Qed. - -Lemma round_NE_abs: - forall x : R, - round beta fexp ZnearestE (Rabs x) = Rabs (round beta fexp ZnearestE x). -Proof with auto with typeclass_instances. -intros x. -apply sym_eq. -unfold Rabs at 2. -destruct (Rcase_abs x) as [Hx|Hx]. -rewrite round_NE_opp. -apply Rabs_left1. -rewrite <- (round_0 beta fexp ZnearestE). -apply round_le... -now apply Rlt_le. -apply Rabs_pos_eq. -rewrite <- (round_0 beta fexp ZnearestE). -apply round_le... -now apply Rge_le. -Qed. - -Theorem round_NE_pt : - forall x, - Rnd_NE_pt x (round beta fexp ZnearestE x). -Proof with auto with typeclass_instances. -intros x. -destruct (total_order_T x 0) as [[Hx|Hx]|Hx]. -apply Rnd_NG_pt_sym. -apply generic_format_opp. -unfold NE_prop. -intros _ f ((mg,eg),(H1,(H2,H3))). -exists (Float beta (- mg) eg). -repeat split. -rewrite H1. -now rewrite F2R_Zopp. -now apply canonic_opp. -simpl. -now rewrite Zeven_opp. -rewrite <- round_NE_opp. -apply round_NE_pt_pos. -now apply Ropp_0_gt_lt_contravar. -rewrite Hx, round_0... -apply Rnd_NG_pt_refl. -apply generic_format_0. -now apply round_NE_pt_pos. -Qed. - -End Fcore_rnd_NE. - -(** Notations for backward-compatibility with Flocq 1.4. *) -Notation rndNE := ZnearestE (only parsing). diff --git a/flocq/Core/Fcore_ulp.v b/flocq/Core/Fcore_ulp.v deleted file mode 100644 index 4fdd319e..00000000 --- a/flocq/Core/Fcore_ulp.v +++ /dev/null @@ -1,2322 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2010-2013 Sylvie Boldo -#
# -Copyright (C) 2010-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** * Unit in the Last Place: our definition using fexp and its properties, successor and predecessor *) -Require Import Reals Psatz. -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_rnd. -Require Import Fcore_generic_fmt. -Require Import Fcore_float_prop. - -Section Fcore_ulp. - -Variable beta : radix. - -Notation bpow e := (bpow beta e). - -Variable fexp : Z -> Z. - -(** Definition and basic properties about the minimal exponent, when it exists *) - -Lemma Z_le_dec_aux: forall x y : Z, (x <= y)%Z \/ ~ (x <= y)%Z. -Proof. -intros. -destruct (Z_le_dec x y). -now left. -now right. -Qed. - -(** [negligible_exp] is either none (as in FLX) or Some n such that n <= fexp n. *) -Definition negligible_exp: option Z := - match (LPO_Z _ (fun z => Z_le_dec_aux z (fexp z))) with - | inleft N => Some (proj1_sig N) - | inright _ => None - end. - - -Inductive negligible_exp_prop: option Z -> Prop := - | negligible_None: (forall n, (fexp n < n)%Z) -> negligible_exp_prop None - | negligible_Some: forall n, (n <= fexp n)%Z -> negligible_exp_prop (Some n). - - -Lemma negligible_exp_spec: negligible_exp_prop negligible_exp. -Proof. -unfold negligible_exp; destruct LPO_Z as [(n,Hn)|Hn]. -now apply negligible_Some. -apply negligible_None. -intros n; specialize (Hn n); omega. -Qed. - -Lemma negligible_exp_spec': (negligible_exp = None /\ forall n, (fexp n < n)%Z) - \/ exists n, (negligible_exp = Some n /\ (n <= fexp n)%Z). -Proof. -unfold negligible_exp; destruct LPO_Z as [(n,Hn)|Hn]. -right; simpl; exists n; now split. -left; split; trivial. -intros n; specialize (Hn n); omega. -Qed. - -Context { valid_exp : Valid_exp fexp }. - -Lemma fexp_negligible_exp_eq: forall n m, (n <= fexp n)%Z -> (m <= fexp m)%Z -> fexp n = fexp m. -Proof. -intros n m Hn Hm. -case (Zle_or_lt n m); intros H. -apply valid_exp; omega. -apply sym_eq, valid_exp; omega. -Qed. - - -(** Definition and basic properties about the ulp *) -(** Now includes a nice ulp(0): ulp(0) is now 0 when there is no minimal - exponent, such as in FLX, and beta^(fexp n) when there is a n such - that n <= fexp n. For instance, the value of ulp(O) is then - beta^emin in FIX and FLT. The main lemma to use is ulp_neq_0 that - is equivalent to the previous "unfold ulp" provided the value is - not zero. *) - -Definition ulp x := match Req_bool x 0 with - | true => match negligible_exp with - | Some n => bpow (fexp n) - | None => 0%R - end - | false => bpow (canonic_exp beta fexp x) - end. - -Lemma ulp_neq_0 : forall x:R, (x <> 0)%R -> ulp x = bpow (canonic_exp beta fexp x). -Proof. -intros x Hx. -unfold ulp; case (Req_bool_spec x); trivial. -intros H; now contradict H. -Qed. - -Notation F := (generic_format beta fexp). - -Theorem ulp_opp : - forall x, ulp (- x) = ulp x. -Proof. -intros x. -unfold ulp. -case Req_bool_spec; intros H1. -rewrite Req_bool_true; trivial. -rewrite <- (Ropp_involutive x), H1; ring. -rewrite Req_bool_false. -now rewrite canonic_exp_opp. -intros H2; apply H1; rewrite H2; ring. -Qed. - -Theorem ulp_abs : - forall x, ulp (Rabs x) = ulp x. -Proof. -intros x. -unfold ulp; case (Req_bool_spec x 0); intros H1. -rewrite Req_bool_true; trivial. -now rewrite H1, Rabs_R0. -rewrite Req_bool_false. -now rewrite canonic_exp_abs. -now apply Rabs_no_R0. -Qed. - -Theorem ulp_ge_0: - forall x, (0 <= ulp x)%R. -Proof. -intros x; unfold ulp; case Req_bool_spec; intros. -case negligible_exp; intros. -apply bpow_ge_0. -apply Rle_refl. -apply bpow_ge_0. -Qed. - - -Theorem ulp_le_id: - forall x, - (0 < x)%R -> - F x -> - (ulp x <= x)%R. -Proof. -intros x Zx Fx. -rewrite <- (Rmult_1_l (ulp x)). -pattern x at 2; rewrite Fx. -rewrite ulp_neq_0. -2: now apply Rgt_not_eq. -unfold F2R; simpl. -apply Rmult_le_compat_r. -apply bpow_ge_0. -apply (Z2R_le (Zsucc 0)). -apply Zlt_le_succ. -apply F2R_gt_0_reg with beta (canonic_exp beta fexp x). -now rewrite <- Fx. -Qed. - -Theorem ulp_le_abs: - forall x, - (x <> 0)%R -> - F x -> - (ulp x <= Rabs x)%R. -Proof. -intros x Zx Fx. -rewrite <- ulp_abs. -apply ulp_le_id. -now apply Rabs_pos_lt. -now apply generic_format_abs. -Qed. - - -(* was ulp_DN_UP *) -Theorem round_UP_DN_ulp : - forall x, ~ F x -> - round beta fexp Zceil x = (round beta fexp Zfloor x + ulp x)%R. -Proof. -intros x Fx. -rewrite ulp_neq_0. -unfold round. simpl. -unfold F2R. simpl. -rewrite Zceil_floor_neq. -rewrite Z2R_plus. simpl. -ring. -intros H. -apply Fx. -unfold generic_format, F2R. simpl. -rewrite <- H. -rewrite Ztrunc_Z2R. -rewrite H. -now rewrite scaled_mantissa_mult_bpow. -intros V; apply Fx. -rewrite V. -apply generic_format_0. -Qed. - - -Theorem ulp_bpow : - forall e, ulp (bpow e) = bpow (fexp (e + 1)). -Proof. -intros e. -rewrite ulp_neq_0. -apply f_equal. -apply canonic_exp_fexp. -rewrite Rabs_pos_eq. -split. -ring_simplify (e + 1 - 1)%Z. -apply Rle_refl. -apply bpow_lt. -apply Zlt_succ. -apply bpow_ge_0. -apply Rgt_not_eq, Rlt_gt, bpow_gt_0. -Qed. - - -Lemma generic_format_ulp_0: - F (ulp 0). -Proof. -unfold ulp. -rewrite Req_bool_true; trivial. -case negligible_exp_spec. -intros _; apply generic_format_0. -intros n H1. -apply generic_format_bpow. -now apply valid_exp. -Qed. - -Lemma generic_format_bpow_ge_ulp_0: forall e, - (ulp 0 <= bpow e)%R -> F (bpow e). -Proof. -intros e; unfold ulp. -rewrite Req_bool_true; trivial. -case negligible_exp_spec. -intros H1 _. -apply generic_format_bpow. -specialize (H1 (e+1)%Z); omega. -intros n H1 H2. -apply generic_format_bpow. -case (Zle_or_lt (e+1) (fexp (e+1))); intros H4. -absurd (e+1 <= e)%Z. -omega. -apply Zle_trans with (1:=H4). -replace (fexp (e+1)) with (fexp n). -now apply le_bpow with beta. -now apply fexp_negligible_exp_eq. -omega. -Qed. - -(** The three following properties are equivalent: - [Exp_not_FTZ] ; forall x, F (ulp x) ; forall x, ulp 0 <= ulp x *) - -Lemma generic_format_ulp: Exp_not_FTZ fexp -> - forall x, F (ulp x). -Proof. -unfold Exp_not_FTZ; intros H x. -case (Req_dec x 0); intros Hx. -rewrite Hx; apply generic_format_ulp_0. -rewrite (ulp_neq_0 _ Hx). -apply generic_format_bpow; unfold canonic_exp. -apply H. -Qed. - -Lemma not_FTZ_generic_format_ulp: - (forall x, F (ulp x)) -> Exp_not_FTZ fexp. -Proof. -intros H e. -specialize (H (bpow (e-1))). -rewrite ulp_neq_0 in H. -2: apply Rgt_not_eq, bpow_gt_0. -unfold canonic_exp in H. -rewrite ln_beta_bpow in H. -apply generic_format_bpow_inv' in H... -now replace (e-1+1)%Z with e in H by ring. -Qed. - - -Lemma ulp_ge_ulp_0: Exp_not_FTZ fexp -> - forall x, (ulp 0 <= ulp x)%R. -Proof. -unfold Exp_not_FTZ; intros H x. -case (Req_dec x 0); intros Hx. -rewrite Hx; now right. -unfold ulp at 1. -rewrite Req_bool_true; trivial. -case negligible_exp_spec'. -intros (H1,H2); rewrite H1; apply ulp_ge_0. -intros (n,(H1,H2)); rewrite H1. -rewrite ulp_neq_0; trivial. -apply bpow_le; unfold canonic_exp. -generalize (ln_beta beta x); intros l. -case (Zle_or_lt l (fexp l)); intros Hl. -rewrite (fexp_negligible_exp_eq n l); trivial; apply Zle_refl. -case (Zle_or_lt (fexp n) (fexp l)); trivial; intros K. -absurd (fexp n <= fexp l)%Z. -omega. -apply Zle_trans with (2:= H _). -apply Zeq_le, sym_eq, valid_exp; trivial. -omega. -Qed. - -Lemma not_FTZ_ulp_ge_ulp_0: - (forall x, (ulp 0 <= ulp x)%R) -> Exp_not_FTZ fexp. -Proof. -intros H e. -apply generic_format_bpow_inv' with beta. -apply generic_format_bpow_ge_ulp_0. -replace e with ((e-1)+1)%Z by ring. -rewrite <- ulp_bpow. -apply H. -Qed. - - - -Theorem ulp_le_pos : - forall { Hm : Monotone_exp fexp }, - forall x y: R, - (0 <= x)%R -> (x <= y)%R -> - (ulp x <= ulp y)%R. -Proof with auto with typeclass_instances. -intros Hm x y Hx Hxy. -destruct Hx as [Hx|Hx]. -rewrite ulp_neq_0. -rewrite ulp_neq_0. -apply bpow_le. -apply Hm. -now apply ln_beta_le. -apply Rgt_not_eq, Rlt_gt. -now apply Rlt_le_trans with (1:=Hx). -now apply Rgt_not_eq. -rewrite <- Hx. -apply ulp_ge_ulp_0. -apply monotone_exp_not_FTZ... -Qed. - - -Theorem ulp_le : - forall { Hm : Monotone_exp fexp }, - forall x y: R, - (Rabs x <= Rabs y)%R -> - (ulp x <= ulp y)%R. -Proof. -intros Hm x y Hxy. -rewrite <- ulp_abs. -rewrite <- (ulp_abs y). -apply ulp_le_pos; trivial. -apply Rabs_pos. -Qed. - - - -(** Definition and properties of pred and succ *) - -Definition pred_pos x := - if Req_bool x (bpow (ln_beta beta x - 1)) then - (x - bpow (fexp (ln_beta beta x - 1)))%R - else - (x - ulp x)%R. - -Definition succ x := - if (Rle_bool 0 x) then - (x+ulp x)%R - else - (- pred_pos (-x))%R. - -Definition pred x := (- succ (-x))%R. - -Theorem pred_eq_pos: - forall x, (0 <= x)%R -> (pred x = pred_pos x)%R. -Proof. -intros x Hx; unfold pred, succ. -case Rle_bool_spec; intros Hx'. -assert (K:(x = 0)%R). -apply Rle_antisym; try assumption. -apply Ropp_le_cancel. -now rewrite Ropp_0. -rewrite K; unfold pred_pos. -rewrite Req_bool_false. -2: apply Rlt_not_eq, bpow_gt_0. -rewrite Ropp_0; ring. -now rewrite 2!Ropp_involutive. -Qed. - -Theorem succ_eq_pos: - forall x, (0 <= x)%R -> (succ x = x + ulp x)%R. -Proof. -intros x Hx; unfold succ. -now rewrite Rle_bool_true. -Qed. - -Lemma pred_eq_opp_succ_opp: forall x, pred x = (- succ (-x))%R. -Proof. -reflexivity. -Qed. - -Lemma succ_eq_opp_pred_opp: forall x, succ x = (- pred (-x))%R. -Proof. -intros x; unfold pred. -now rewrite 2!Ropp_involutive. -Qed. - -Lemma succ_opp: forall x, (succ (-x) = - pred x)%R. -Proof. -intros x; rewrite succ_eq_opp_pred_opp. -now rewrite Ropp_involutive. -Qed. - -Lemma pred_opp: forall x, (pred (-x) = - succ x)%R. -Proof. -intros x; rewrite pred_eq_opp_succ_opp. -now rewrite Ropp_involutive. -Qed. - - - - -(** pred and succ are in the format *) - -(* cannont be x <> ulp 0, due to the counter-example 1-bit FP format fexp: e -> e-1 *) -(* was pred_ge_bpow *) -Theorem id_m_ulp_ge_bpow : - forall x e, F x -> - x <> ulp x -> - (bpow e < x)%R -> - (bpow e <= x - ulp x)%R. -Proof. -intros x e Fx Hx' Hx. -(* *) -assert (1 <= Ztrunc (scaled_mantissa beta fexp x))%Z. -assert (0 < Ztrunc (scaled_mantissa beta fexp x))%Z. -apply F2R_gt_0_reg with beta (canonic_exp beta fexp x). -rewrite <- Fx. -apply Rle_lt_trans with (2:=Hx). -apply bpow_ge_0. -omega. -case (Zle_lt_or_eq _ _ H); intros Hm. -(* *) -pattern x at 1 ; rewrite Fx. -rewrite ulp_neq_0. -unfold F2R. simpl. -pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l. -rewrite <- Rmult_minus_distr_r. -change 1%R with (Z2R 1). -rewrite <- Z2R_minus. -change (bpow e <= F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) - 1) (canonic_exp beta fexp x)))%R. -apply bpow_le_F2R_m1; trivial. -now rewrite <- Fx. -apply Rgt_not_eq, Rlt_gt. -apply Rlt_trans with (2:=Hx), bpow_gt_0. -(* *) -contradict Hx'. -pattern x at 1; rewrite Fx. -rewrite <- Hm. -rewrite ulp_neq_0. -unfold F2R; simpl. -now rewrite Rmult_1_l. -apply Rgt_not_eq, Rlt_gt. -apply Rlt_trans with (2:=Hx), bpow_gt_0. -Qed. - -(* was succ_le_bpow *) -Theorem id_p_ulp_le_bpow : - forall x e, (0 < x)%R -> F x -> - (x < bpow e)%R -> - (x + ulp x <= bpow e)%R. -Proof. -intros x e Zx Fx Hx. -pattern x at 1 ; rewrite Fx. -rewrite ulp_neq_0. -unfold F2R. simpl. -pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l. -rewrite <- Rmult_plus_distr_r. -change 1%R with (Z2R 1). -rewrite <- Z2R_plus. -change (F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) + 1) (canonic_exp beta fexp x)) <= bpow e)%R. -apply F2R_p1_le_bpow. -apply F2R_gt_0_reg with beta (canonic_exp beta fexp x). -now rewrite <- Fx. -now rewrite <- Fx. -now apply Rgt_not_eq. -Qed. - - - -Lemma generic_format_pred_aux1: - forall x, (0 < x)%R -> F x -> - x <> bpow (ln_beta beta x - 1) -> - F (x - ulp x). -Proof. -intros x Zx Fx Hx. -destruct (ln_beta beta x) as (ex, Ex). -simpl in Hx. -specialize (Ex (Rgt_not_eq _ _ Zx)). -assert (Ex' : (bpow (ex - 1) < x < bpow ex)%R). -rewrite Rabs_pos_eq in Ex. -destruct Ex as (H,H'); destruct H; split; trivial. -contradict Hx; easy. -now apply Rlt_le. -unfold generic_format, scaled_mantissa, canonic_exp. -rewrite ln_beta_unique with beta (x - ulp x)%R ex. -pattern x at 1 3 ; rewrite Fx. -rewrite ulp_neq_0. -unfold scaled_mantissa. -rewrite canonic_exp_fexp with (1 := Ex). -unfold F2R. simpl. -rewrite Rmult_minus_distr_r. -rewrite Rmult_assoc. -rewrite <- bpow_plus, Zplus_opp_r, Rmult_1_r. -change (bpow 0) with (Z2R 1). -rewrite <- Z2R_minus. -rewrite Ztrunc_Z2R. -rewrite Z2R_minus. -rewrite Rmult_minus_distr_r. -now rewrite Rmult_1_l. -now apply Rgt_not_eq. -rewrite Rabs_pos_eq. -split. -apply id_m_ulp_ge_bpow; trivial. -rewrite ulp_neq_0. -intro H. -assert (ex-1 < canonic_exp beta fexp x < ex)%Z. -split ; apply (lt_bpow beta) ; rewrite <- H ; easy. -clear -H0. omega. -now apply Rgt_not_eq. -apply Ex'. -apply Rle_lt_trans with (2 := proj2 Ex'). -pattern x at 3 ; rewrite <- Rplus_0_r. -apply Rplus_le_compat_l. -rewrite <-Ropp_0. -apply Ropp_le_contravar. -apply ulp_ge_0. -apply Rle_0_minus. -pattern x at 2; rewrite Fx. -rewrite ulp_neq_0. -unfold F2R; simpl. -pattern (bpow (canonic_exp beta fexp x)) at 1; rewrite <- Rmult_1_l. -apply Rmult_le_compat_r. -apply bpow_ge_0. -replace 1%R with (Z2R 1) by reflexivity. -apply Z2R_le. -assert (0 < Ztrunc (scaled_mantissa beta fexp x))%Z. -apply F2R_gt_0_reg with beta (canonic_exp beta fexp x). -rewrite <- Fx. -apply Rle_lt_trans with (2:=proj1 Ex'). -apply bpow_ge_0. -omega. -now apply Rgt_not_eq. -Qed. - -Lemma generic_format_pred_aux2 : - forall x, (0 < x)%R -> F x -> - let e := ln_beta_val beta x (ln_beta beta x) in - x = bpow (e - 1) -> - F (x - bpow (fexp (e - 1))). -Proof. -intros x Zx Fx e Hx. -pose (f:=(x - bpow (fexp (e - 1)))%R). -fold f. -assert (He:(fexp (e-1) <= e-1)%Z). -apply generic_format_bpow_inv with beta; trivial. -rewrite <- Hx; assumption. -case (Zle_lt_or_eq _ _ He); clear He; intros He. -assert (f = F2R (Float beta (Zpower beta (e-1-(fexp (e-1))) -1) (fexp (e-1))))%R. -unfold f; rewrite Hx. -unfold F2R; simpl. -rewrite Z2R_minus, Z2R_Zpower. -rewrite Rmult_minus_distr_r, Rmult_1_l. -rewrite <- bpow_plus. -now replace (e - 1 - fexp (e - 1) + fexp (e - 1))%Z with (e-1)%Z by ring. -omega. -rewrite H. -apply generic_format_F2R. -intros _. -apply Zeq_le. -apply canonic_exp_fexp. -rewrite <- H. -unfold f; rewrite Hx. -rewrite Rabs_right. -split. -apply Rplus_le_reg_l with (bpow (fexp (e-1))). -ring_simplify. -apply Rle_trans with (bpow (e - 2) + bpow (e - 2))%R. -apply Rplus_le_compat ; apply bpow_le ; omega. -apply Rle_trans with (2*bpow (e - 2))%R;[right; ring|idtac]. -apply Rle_trans with (bpow 1*bpow (e - 2))%R. -apply Rmult_le_compat_r. -apply bpow_ge_0. -replace 2%R with (Z2R 2) by reflexivity. -replace (bpow 1) with (Z2R beta). -apply Z2R_le. -apply <- Zle_is_le_bool. -now destruct beta. -simpl. -unfold Zpower_pos; simpl. -now rewrite Zmult_1_r. -rewrite <- bpow_plus. -replace (1+(e-2))%Z with (e-1)%Z by ring. -now right. -rewrite <- Rplus_0_r. -apply Rplus_lt_compat_l. -rewrite <- Ropp_0. -apply Ropp_lt_contravar. -apply bpow_gt_0. -apply Rle_ge; apply Rle_0_minus. -apply bpow_le. -omega. -replace f with 0%R. -apply generic_format_0. -unfold f. -rewrite Hx, He. -ring. -Qed. - - -Theorem generic_format_succ_aux1 : - forall x, (0 < x)%R -> F x -> - F (x + ulp x). -Proof. -intros x Zx Fx. -destruct (ln_beta beta x) as (ex, Ex). -specialize (Ex (Rgt_not_eq _ _ Zx)). -assert (Ex' := Ex). -rewrite Rabs_pos_eq in Ex'. -destruct (id_p_ulp_le_bpow x ex) ; try easy. -unfold generic_format, scaled_mantissa, canonic_exp. -rewrite ln_beta_unique with beta (x + ulp x)%R ex. -pattern x at 1 3 ; rewrite Fx. -rewrite ulp_neq_0. -unfold scaled_mantissa. -rewrite canonic_exp_fexp with (1 := Ex). -unfold F2R. simpl. -rewrite Rmult_plus_distr_r. -rewrite Rmult_assoc. -rewrite <- bpow_plus, Zplus_opp_r, Rmult_1_r. -change (bpow 0) with (Z2R 1). -rewrite <- Z2R_plus. -rewrite Ztrunc_Z2R. -rewrite Z2R_plus. -rewrite Rmult_plus_distr_r. -now rewrite Rmult_1_l. -now apply Rgt_not_eq. -rewrite Rabs_pos_eq. -split. -apply Rle_trans with (1 := proj1 Ex'). -pattern x at 1 ; rewrite <- Rplus_0_r. -apply Rplus_le_compat_l. -apply ulp_ge_0. -exact H. -apply Rplus_le_le_0_compat. -now apply Rlt_le. -apply ulp_ge_0. -rewrite H. -apply generic_format_bpow. -apply valid_exp. -destruct (Zle_or_lt ex (fexp ex)) ; trivial. -elim Rlt_not_le with (1 := Zx). -rewrite Fx. -replace (Ztrunc (scaled_mantissa beta fexp x)) with Z0. -rewrite F2R_0. -apply Rle_refl. -unfold scaled_mantissa. -rewrite canonic_exp_fexp with (1 := Ex). -destruct (mantissa_small_pos beta fexp x ex) ; trivial. -rewrite Ztrunc_floor. -apply sym_eq. -apply Zfloor_imp. -split. -now apply Rlt_le. -exact H2. -now apply Rlt_le. -now apply Rlt_le. -Qed. - -Theorem generic_format_pred_pos : - forall x, F x -> (0 < x)%R -> - F (pred_pos x). -Proof. -intros x Fx Zx. -unfold pred_pos; case Req_bool_spec; intros H. -now apply generic_format_pred_aux2. -now apply generic_format_pred_aux1. -Qed. - - -Theorem generic_format_succ : - forall x, F x -> - F (succ x). -Proof. -intros x Fx. -unfold succ; case Rle_bool_spec; intros Zx. -destruct Zx as [Zx|Zx]. -now apply generic_format_succ_aux1. -rewrite <- Zx, Rplus_0_l. -apply generic_format_ulp_0. -apply generic_format_opp. -apply generic_format_pred_pos. -now apply generic_format_opp. -now apply Ropp_0_gt_lt_contravar. -Qed. - -Theorem generic_format_pred : - forall x, F x -> - F (pred x). -Proof. -intros x Fx. -unfold pred. -apply generic_format_opp. -apply generic_format_succ. -now apply generic_format_opp. -Qed. - - - -Theorem pred_pos_lt_id : - forall x, (x <> 0)%R -> - (pred_pos x < x)%R. -Proof. -intros x Zx. -unfold pred_pos. -case Req_bool_spec; intros H. -(* *) -rewrite <- Rplus_0_r. -apply Rplus_lt_compat_l. -rewrite <- Ropp_0. -apply Ropp_lt_contravar. -apply bpow_gt_0. -(* *) -rewrite <- Rplus_0_r. -apply Rplus_lt_compat_l. -rewrite <- Ropp_0. -apply Ropp_lt_contravar. -rewrite ulp_neq_0; trivial. -apply bpow_gt_0. -Qed. - -Theorem succ_gt_id : - forall x, (x <> 0)%R -> - (x < succ x)%R. -Proof. -intros x Zx; unfold succ. -case Rle_bool_spec; intros Hx. -pattern x at 1; rewrite <- (Rplus_0_r x). -apply Rplus_lt_compat_l. -rewrite ulp_neq_0; trivial. -apply bpow_gt_0. -pattern x at 1; rewrite <- (Ropp_involutive x). -apply Ropp_lt_contravar. -apply pred_pos_lt_id. -now auto with real. -Qed. - - -Theorem pred_lt_id : - forall x, (x <> 0)%R -> - (pred x < x)%R. -Proof. -intros x Zx; unfold pred. -pattern x at 2; rewrite <- (Ropp_involutive x). -apply Ropp_lt_contravar. -apply succ_gt_id. -now auto with real. -Qed. - -Theorem succ_ge_id : - forall x, (x <= succ x)%R. -Proof. -intros x; case (Req_dec x 0). -intros V; rewrite V. -unfold succ; rewrite Rle_bool_true;[idtac|now right]. -rewrite Rplus_0_l; apply ulp_ge_0. -intros; left; now apply succ_gt_id. -Qed. - - -Theorem pred_le_id : - forall x, (pred x <= x)%R. -Proof. -intros x; unfold pred. -pattern x at 2; rewrite <- (Ropp_involutive x). -apply Ropp_le_contravar. -apply succ_ge_id. -Qed. - - -Theorem pred_pos_ge_0 : - forall x, - (0 < x)%R -> F x -> (0 <= pred_pos x)%R. -Proof. -intros x Zx Fx. -unfold pred_pos. -case Req_bool_spec; intros H. -(* *) -apply Rle_0_minus. -rewrite H. -apply bpow_le. -destruct (ln_beta beta x) as (ex,Ex) ; simpl. -rewrite ln_beta_bpow. -ring_simplify (ex - 1 + 1 - 1)%Z. -apply generic_format_bpow_inv with beta; trivial. -simpl in H. -rewrite <- H; assumption. -apply Rle_0_minus. -now apply ulp_le_id. -Qed. - -Theorem pred_ge_0 : - forall x, - (0 < x)%R -> F x -> (0 <= pred x)%R. -Proof. -intros x Zx Fx. -rewrite pred_eq_pos. -now apply pred_pos_ge_0. -now left. -Qed. - - -Lemma pred_pos_plus_ulp_aux1 : - forall x, (0 < x)%R -> F x -> - x <> bpow (ln_beta beta x - 1) -> - ((x - ulp x) + ulp (x-ulp x) = x)%R. -Proof. -intros x Zx Fx Hx. -replace (ulp (x - ulp x)) with (ulp x). -ring. -assert (H:(x <> 0)%R) by auto with real. -assert (H':(x <> bpow (canonic_exp beta fexp x))%R). -unfold canonic_exp; intros M. -case_eq (ln_beta beta x); intros ex Hex T. -assert (Lex:(ln_beta_val beta x (ln_beta beta x) = ex)%Z). -rewrite T; reflexivity. -rewrite Lex in *. -clear T; simpl in *; specialize (Hex H). -rewrite Rabs_right in Hex. -2: apply Rle_ge; apply Rlt_le; easy. -assert (ex-1 < fexp ex < ex)%Z. -split ; apply (lt_bpow beta); rewrite <- M;[idtac|easy]. -destruct (proj1 Hex);[trivial|idtac]. -contradict Hx; auto with real. -omega. -rewrite 2!ulp_neq_0; try auto with real. -apply f_equal. -unfold canonic_exp; apply f_equal. -case_eq (ln_beta beta x); intros ex Hex T. -assert (Lex:(ln_beta_val beta x (ln_beta beta x) = ex)%Z). -rewrite T; reflexivity. -rewrite Lex in *; simpl in *; clear T. -specialize (Hex H). -apply sym_eq, ln_beta_unique. -rewrite Rabs_right. -rewrite Rabs_right in Hex. -2: apply Rle_ge; apply Rlt_le; easy. -split. -destruct Hex as ([H1|H1],H2). -apply Rle_trans with (x-ulp x)%R. -apply id_m_ulp_ge_bpow; trivial. -rewrite ulp_neq_0; trivial. -rewrite ulp_neq_0; trivial. -right; unfold canonic_exp; now rewrite Lex. -contradict Hx; auto with real. -apply Rle_lt_trans with (2:=proj2 Hex). -rewrite <- Rplus_0_r. -apply Rplus_le_compat_l. -rewrite <- Ropp_0. -apply Ropp_le_contravar. -apply bpow_ge_0. -apply Rle_ge. -apply Rle_0_minus. -rewrite Fx. -unfold F2R, canonic_exp; simpl. -rewrite Lex. -pattern (bpow (fexp ex)) at 1; rewrite <- Rmult_1_l. -apply Rmult_le_compat_r. -apply bpow_ge_0. -replace 1%R with (Z2R (Zsucc 0)) by reflexivity. -apply Z2R_le. -apply Zlt_le_succ. -apply F2R_gt_0_reg with beta (canonic_exp beta fexp x). -now rewrite <- Fx. -Qed. - - -Lemma pred_pos_plus_ulp_aux2 : - forall x, (0 < x)%R -> F x -> - let e := ln_beta_val beta x (ln_beta beta x) in - x = bpow (e - 1) -> - (x - bpow (fexp (e-1)) <> 0)%R -> - ((x - bpow (fexp (e-1))) + ulp (x - bpow (fexp (e-1))) = x)%R. -Proof. -intros x Zx Fx e Hxe Zp. -replace (ulp (x - bpow (fexp (e - 1)))) with (bpow (fexp (e - 1))). -ring. -assert (He:(fexp (e-1) <= e-1)%Z). -apply generic_format_bpow_inv with beta; trivial. -rewrite <- Hxe; assumption. -case (Zle_lt_or_eq _ _ He); clear He; intros He. -(* *) -rewrite ulp_neq_0; trivial. -apply f_equal. -unfold canonic_exp; apply f_equal. -apply sym_eq. -apply ln_beta_unique. -rewrite Rabs_right. -split. -apply Rplus_le_reg_l with (bpow (fexp (e-1))). -ring_simplify. -apply Rle_trans with (bpow (e - 2) + bpow (e - 2))%R. -apply Rplus_le_compat; apply bpow_le; omega. -apply Rle_trans with (2*bpow (e - 2))%R;[right; ring|idtac]. -apply Rle_trans with (bpow 1*bpow (e - 2))%R. -apply Rmult_le_compat_r. -apply bpow_ge_0. -replace 2%R with (Z2R 2) by reflexivity. -replace (bpow 1) with (Z2R beta). -apply Z2R_le. -apply <- Zle_is_le_bool. -now destruct beta. -simpl. -unfold Zpower_pos; simpl. -now rewrite Zmult_1_r. -rewrite <- bpow_plus. -replace (1+(e-2))%Z with (e-1)%Z by ring. -now right. -rewrite <- Rplus_0_r, Hxe. -apply Rplus_lt_compat_l. -rewrite <- Ropp_0. -apply Ropp_lt_contravar. -apply bpow_gt_0. -apply Rle_ge; apply Rle_0_minus. -rewrite Hxe. -apply bpow_le. -omega. -(* *) -contradict Zp. -rewrite Hxe, He; ring. -Qed. - -Lemma pred_pos_plus_ulp_aux3 : - forall x, (0 < x)%R -> F x -> - let e := ln_beta_val beta x (ln_beta beta x) in - x = bpow (e - 1) -> - (x - bpow (fexp (e-1)) = 0)%R -> - (ulp 0 = x)%R. -Proof. -intros x Hx Fx e H1 H2. -assert (H3:(x = bpow (fexp (e - 1)))). -now apply Rminus_diag_uniq. -assert (H4: (fexp (e-1) = e-1)%Z). -apply bpow_inj with beta. -now rewrite <- H1. -unfold ulp; rewrite Req_bool_true; trivial. -case negligible_exp_spec. -intros K. -specialize (K (e-1)%Z). -contradict K; omega. -intros n Hn. -rewrite H3; apply f_equal. -case (Zle_or_lt n (e-1)); intros H6. -apply valid_exp; omega. -apply sym_eq, valid_exp; omega. -Qed. - - - - -(** The following one is false for x = 0 in FTZ *) - -Theorem pred_pos_plus_ulp : - forall x, (0 < x)%R -> F x -> - (pred_pos x + ulp (pred_pos x) = x)%R. -Proof. -intros x Zx Fx. -unfold pred_pos. -case Req_bool_spec; intros H. -case (Req_EM_T (x - bpow (fexp (ln_beta_val beta x (ln_beta beta x) -1))) 0); intros H1. -rewrite H1, Rplus_0_l. -now apply pred_pos_plus_ulp_aux3. -now apply pred_pos_plus_ulp_aux2. -now apply pred_pos_plus_ulp_aux1. -Qed. - - - - -(** Rounding x + small epsilon *) - -Theorem ln_beta_plus_eps: - forall x, (0 < x)%R -> F x -> - forall eps, (0 <= eps < ulp x)%R -> - ln_beta beta (x + eps) = ln_beta beta x :> Z. -Proof. -intros x Zx Fx eps Heps. -destruct (ln_beta beta x) as (ex, He). -simpl. -specialize (He (Rgt_not_eq _ _ Zx)). -apply ln_beta_unique. -rewrite Rabs_pos_eq. -rewrite Rabs_pos_eq in He. -split. -apply Rle_trans with (1 := proj1 He). -pattern x at 1 ; rewrite <- Rplus_0_r. -now apply Rplus_le_compat_l. -apply Rlt_le_trans with (x + ulp x)%R. -now apply Rplus_lt_compat_l. -pattern x at 1 ; rewrite Fx. -rewrite ulp_neq_0. -unfold F2R. simpl. -pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l. -rewrite <- Rmult_plus_distr_r. -change 1%R with (Z2R 1). -rewrite <- Z2R_plus. -change (F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) + 1) (canonic_exp beta fexp x)) <= bpow ex)%R. -apply F2R_p1_le_bpow. -apply F2R_gt_0_reg with beta (canonic_exp beta fexp x). -now rewrite <- Fx. -now rewrite <- Fx. -now apply Rgt_not_eq. -now apply Rlt_le. -apply Rplus_le_le_0_compat. -now apply Rlt_le. -apply Heps. -Qed. - -Theorem round_DN_plus_eps_pos: - forall x, (0 <= x)%R -> F x -> - forall eps, (0 <= eps < ulp x)%R -> - round beta fexp Zfloor (x + eps) = x. -Proof. -intros x Zx Fx eps Heps. -destruct Zx as [Zx|Zx]. -(* . 0 < x *) -pattern x at 2 ; rewrite Fx. -unfold round. -unfold scaled_mantissa. simpl. -unfold canonic_exp at 1 2. -rewrite ln_beta_plus_eps ; trivial. -apply (f_equal (fun m => F2R (Float beta m _))). -rewrite Ztrunc_floor. -apply Zfloor_imp. -split. -apply (Rle_trans _ _ _ (Zfloor_lb _)). -apply Rmult_le_compat_r. -apply bpow_ge_0. -pattern x at 1 ; rewrite <- Rplus_0_r. -now apply Rplus_le_compat_l. -apply Rlt_le_trans with ((x + ulp x) * bpow (- canonic_exp beta fexp x))%R. -apply Rmult_lt_compat_r. -apply bpow_gt_0. -now apply Rplus_lt_compat_l. -rewrite Rmult_plus_distr_r. -rewrite Z2R_plus. -apply Rplus_le_compat. -pattern x at 1 3 ; rewrite Fx. -unfold F2R. simpl. -rewrite Rmult_assoc. -rewrite <- bpow_plus. -rewrite Zplus_opp_r. -rewrite Rmult_1_r. -rewrite Zfloor_Z2R. -apply Rle_refl. -rewrite ulp_neq_0. -2: now apply Rgt_not_eq. -rewrite <- bpow_plus. -rewrite Zplus_opp_r. -apply Rle_refl. -apply Rmult_le_pos. -now apply Rlt_le. -apply bpow_ge_0. -(* . x=0 *) -rewrite <- Zx, Rplus_0_l; rewrite <- Zx in Heps. -case (proj1 Heps); intros P. -unfold round, scaled_mantissa, canonic_exp. -revert Heps; unfold ulp. -rewrite Req_bool_true; trivial. -case negligible_exp_spec. -intros _ (H1,H2). -absurd (0 < 0)%R; auto with real. -now apply Rle_lt_trans with (1:=H1). -intros n Hn H. -assert (fexp (ln_beta beta eps) = fexp n). -apply valid_exp; try assumption. -assert(ln_beta beta eps-1 < fexp n)%Z;[idtac|omega]. -apply lt_bpow with beta. -apply Rle_lt_trans with (2:=proj2 H). -destruct (ln_beta beta eps) as (e,He). -simpl; rewrite Rabs_pos_eq in He. -now apply He, Rgt_not_eq. -now left. -replace (Zfloor (eps * bpow (- fexp (ln_beta beta eps)))) with 0%Z. -unfold F2R; simpl; ring. -apply sym_eq, Zfloor_imp. -split. -apply Rmult_le_pos. -now left. -apply bpow_ge_0. -apply Rmult_lt_reg_r with (bpow (fexp n)). -apply bpow_gt_0. -rewrite Rmult_assoc, <- bpow_plus. -rewrite H0; ring_simplify (-fexp n + fexp n)%Z. -simpl; rewrite Rmult_1_l, Rmult_1_r. -apply H. -rewrite <- P, round_0; trivial. -apply valid_rnd_DN. -Qed. - - -Theorem round_UP_plus_eps_pos : - forall x, (0 <= x)%R -> F x -> - forall eps, (0 < eps <= ulp x)%R -> - round beta fexp Zceil (x + eps) = (x + ulp x)%R. -Proof with auto with typeclass_instances. -intros x Zx Fx eps. -case Zx; intros Zx1. -(* . 0 < x *) -intros (Heps1,[Heps2|Heps2]). -assert (Heps: (0 <= eps < ulp x)%R). -split. -now apply Rlt_le. -exact Heps2. -assert (Hd := round_DN_plus_eps_pos x Zx Fx eps Heps). -rewrite round_UP_DN_ulp. -rewrite Hd. -rewrite 2!ulp_neq_0. -unfold canonic_exp. -now rewrite ln_beta_plus_eps. -now apply Rgt_not_eq. -now apply Rgt_not_eq, Rplus_lt_0_compat. -intros Fs. -rewrite round_generic in Hd... -apply Rgt_not_eq with (2 := Hd). -pattern x at 2 ; rewrite <- Rplus_0_r. -now apply Rplus_lt_compat_l. -rewrite Heps2. -apply round_generic... -now apply generic_format_succ_aux1. -(* . x=0 *) -rewrite <- Zx1, 2!Rplus_0_l. -intros Heps. -case (proj2 Heps). -unfold round, scaled_mantissa, canonic_exp. -unfold ulp. -rewrite Req_bool_true; trivial. -case negligible_exp_spec. -intros H2. -intros J; absurd (0 < 0)%R; auto with real. -apply Rlt_trans with eps; try assumption; apply Heps. -intros n Hn H. -assert (fexp (ln_beta beta eps) = fexp n). -apply valid_exp; try assumption. -assert(ln_beta beta eps-1 < fexp n)%Z;[idtac|omega]. -apply lt_bpow with beta. -apply Rle_lt_trans with (2:=H). -destruct (ln_beta beta eps) as (e,He). -simpl; rewrite Rabs_pos_eq in He. -now apply He, Rgt_not_eq. -now left. -replace (Zceil (eps * bpow (- fexp (ln_beta beta eps)))) with 1%Z. -unfold F2R; simpl; rewrite H0; ring. -apply sym_eq, Zceil_imp. -split. -simpl; apply Rmult_lt_0_compat. -apply Heps. -apply bpow_gt_0. -apply Rmult_le_reg_r with (bpow (fexp n)). -apply bpow_gt_0. -rewrite Rmult_assoc, <- bpow_plus. -rewrite H0; ring_simplify (-fexp n + fexp n)%Z. -simpl; rewrite Rmult_1_l, Rmult_1_r. -now left. -intros P; rewrite P. -apply round_generic... -apply generic_format_ulp_0. -Qed. - - -Theorem round_UP_pred_plus_eps_pos : - forall x, (0 < x)%R -> F x -> - forall eps, (0 < eps <= ulp (pred x) )%R -> - round beta fexp Zceil (pred x + eps) = x. -Proof. -intros x Hx Fx eps Heps. -rewrite round_UP_plus_eps_pos; trivial. -rewrite pred_eq_pos. -apply pred_pos_plus_ulp; trivial. -now left. -now apply pred_ge_0. -apply generic_format_pred; trivial. -Qed. - -Theorem round_DN_minus_eps_pos : - forall x, (0 < x)%R -> F x -> - forall eps, (0 < eps <= ulp (pred x))%R -> - round beta fexp Zfloor (x - eps) = pred x. -Proof. -intros x Hpx Fx eps. -rewrite pred_eq_pos;[intros Heps|now left]. -replace (x-eps)%R with (pred_pos x + (ulp (pred_pos x)-eps))%R. -2: pattern x at 3; rewrite <- (pred_pos_plus_ulp x); trivial. -2: ring. -rewrite round_DN_plus_eps_pos; trivial. -now apply pred_pos_ge_0. -now apply generic_format_pred_pos. -split. -apply Rle_0_minus. -now apply Heps. -rewrite <- Rplus_0_r. -apply Rplus_lt_compat_l. -rewrite <- Ropp_0. -apply Ropp_lt_contravar. -now apply Heps. -Qed. - - -Theorem round_DN_plus_eps: - forall x, F x -> - forall eps, (0 <= eps < if (Rle_bool 0 x) then (ulp x) - else (ulp (pred (-x))))%R -> - round beta fexp Zfloor (x + eps) = x. -Proof. -intros x Fx eps Heps. -case (Rle_or_lt 0 x); intros Zx. -apply round_DN_plus_eps_pos; try assumption. -split; try apply Heps. -rewrite Rle_bool_true in Heps; trivial. -now apply Heps. -(* *) -rewrite Rle_bool_false in Heps; trivial. -rewrite <- (Ropp_involutive (x+eps)). -pattern x at 2; rewrite <- (Ropp_involutive x). -rewrite round_DN_opp. -apply f_equal. -replace (-(x+eps))%R with (pred (-x) + (ulp (pred (-x)) - eps))%R. -rewrite round_UP_pred_plus_eps_pos; try reflexivity. -now apply Ropp_0_gt_lt_contravar. -now apply generic_format_opp. -split. -apply Rplus_lt_reg_l with eps; ring_simplify. -apply Heps. -apply Rplus_le_reg_l with (eps-ulp (pred (- x)))%R; ring_simplify. -apply Heps. -unfold pred. -rewrite Ropp_involutive. -unfold succ; rewrite Rle_bool_false; try assumption. -rewrite Ropp_involutive; unfold Rminus. -rewrite <- Rplus_assoc, pred_pos_plus_ulp. -ring. -now apply Ropp_0_gt_lt_contravar. -now apply generic_format_opp. -Qed. - - -Theorem round_UP_plus_eps : - forall x, F x -> - forall eps, (0 < eps <= if (Rle_bool 0 x) then (ulp x) - else (ulp (pred (-x))))%R -> - round beta fexp Zceil (x + eps) = (succ x)%R. -Proof with auto with typeclass_instances. -intros x Fx eps Heps. -case (Rle_or_lt 0 x); intros Zx. -rewrite succ_eq_pos; try assumption. -rewrite Rle_bool_true in Heps; trivial. -apply round_UP_plus_eps_pos; assumption. -(* *) -rewrite Rle_bool_false in Heps; trivial. -rewrite <- (Ropp_involutive (x+eps)). -rewrite <- (Ropp_involutive (succ x)). -rewrite round_UP_opp. -apply f_equal. -replace (-(x+eps))%R with (-succ x + (-eps + ulp (pred (-x))))%R. -apply round_DN_plus_eps_pos. -rewrite <- pred_opp. -apply pred_ge_0. -now apply Ropp_0_gt_lt_contravar. -now apply generic_format_opp. -now apply generic_format_opp, generic_format_succ. -split. -apply Rplus_le_reg_l with eps; ring_simplify. -apply Heps. -unfold pred; rewrite Ropp_involutive. -apply Rplus_lt_reg_l with (eps-ulp (- succ x))%R; ring_simplify. -apply Heps. -unfold succ; rewrite Rle_bool_false; try assumption. -apply trans_eq with (-x +-eps)%R;[idtac|ring]. -pattern (-x)%R at 3; rewrite <- (pred_pos_plus_ulp (-x)). -rewrite pred_eq_pos. -ring. -left; now apply Ropp_0_gt_lt_contravar. -now apply Ropp_0_gt_lt_contravar. -now apply generic_format_opp. -Qed. - - -Lemma le_pred_pos_lt : - forall x y, - F x -> F y -> - (0 <= x < y)%R -> - (x <= pred_pos y)%R. -Proof with auto with typeclass_instances. -intros x y Fx Fy H. -case (proj1 H); intros V. -assert (Zy:(0 < y)%R). -apply Rle_lt_trans with (1:=proj1 H). -apply H. -(* *) -assert (Zp: (0 < pred y)%R). -assert (Zp:(0 <= pred y)%R). -apply pred_ge_0 ; trivial. -destruct Zp; trivial. -generalize H0. -rewrite pred_eq_pos;[idtac|now left]. -unfold pred_pos. -destruct (ln_beta beta y) as (ey,Hey); simpl. -case Req_bool_spec; intros Hy2. -(* . *) -intros Hy3. -assert (ey-1 = fexp (ey -1))%Z. -apply bpow_inj with beta. -rewrite <- Hy2, <- Rplus_0_l, Hy3. -ring. -assert (Zx: (x <> 0)%R). -now apply Rgt_not_eq. -destruct (ln_beta beta x) as (ex,Hex). -specialize (Hex Zx). -assert (ex <= ey)%Z. -apply bpow_lt_bpow with beta. -apply Rle_lt_trans with (1:=proj1 Hex). -apply Rlt_trans with (Rabs y). -rewrite 2!Rabs_right. -apply H. -now apply Rgt_ge. -now apply Rgt_ge. -apply Hey. -now apply Rgt_not_eq. -case (Zle_lt_or_eq _ _ H2); intros Hexy. -assert (fexp ex = fexp (ey-1))%Z. -apply valid_exp. -omega. -rewrite <- H1. -omega. -absurd (0 < Ztrunc (scaled_mantissa beta fexp x) < 1)%Z. -omega. -split. -apply F2R_gt_0_reg with beta (canonic_exp beta fexp x). -now rewrite <- Fx. -apply lt_Z2R. -apply Rmult_lt_reg_r with (bpow (canonic_exp beta fexp x)). -apply bpow_gt_0. -replace (Z2R (Ztrunc (scaled_mantissa beta fexp x)) * - bpow (canonic_exp beta fexp x))%R with x. -rewrite Rmult_1_l. -unfold canonic_exp. -rewrite ln_beta_unique with beta x ex. -rewrite H3,<-H1, <- Hy2. -apply H. -exact Hex. -absurd (y <= x)%R. -now apply Rlt_not_le. -rewrite Rabs_right in Hex. -apply Rle_trans with (2:=proj1 Hex). -rewrite Hexy, Hy2. -now apply Rle_refl. -now apply Rgt_ge. -(* . *) -intros Hy3. -assert (y = bpow (fexp ey))%R. -apply Rminus_diag_uniq. -rewrite Hy3. -rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq]. -unfold canonic_exp. -rewrite (ln_beta_unique beta y ey); trivial. -apply Hey. -now apply Rgt_not_eq. -contradict Hy2. -rewrite H1. -apply f_equal. -apply Zplus_reg_l with 1%Z. -ring_simplify. -apply trans_eq with (ln_beta beta y). -apply sym_eq; apply ln_beta_unique. -rewrite H1, Rabs_right. -split. -apply bpow_le. -omega. -apply bpow_lt. -omega. -apply Rle_ge; apply bpow_ge_0. -apply ln_beta_unique. -apply Hey. -now apply Rgt_not_eq. -(* *) -case (Rle_or_lt (ulp (pred_pos y)) (y-x)); intros H1. -(* . *) -apply Rplus_le_reg_r with (-x + ulp (pred_pos y))%R. -ring_simplify (x+(-x+ulp (pred_pos y)))%R. -apply Rle_trans with (1:=H1). -rewrite <- (pred_pos_plus_ulp y) at 1; trivial. -apply Req_le; ring. -(* . *) -replace x with (y-(y-x))%R by ring. -rewrite <- pred_eq_pos;[idtac|now left]. -rewrite <- round_DN_minus_eps_pos with (eps:=(y-x)%R); try easy. -ring_simplify (y-(y-x))%R. -apply Req_le. -apply sym_eq. -apply round_generic... -split; trivial. -now apply Rlt_Rminus. -rewrite pred_eq_pos;[idtac|now left]. -now apply Rlt_le. -rewrite <- V; apply pred_pos_ge_0; trivial. -apply Rle_lt_trans with (1:=proj1 H); apply H. -Qed. - -Theorem succ_le_lt_aux: - forall x y, - F x -> F y -> - (0 <= x)%R -> (x < y)%R -> - (succ x <= y)%R. -Proof with auto with typeclass_instances. -intros x y Hx Hy Zx H. -rewrite succ_eq_pos; trivial. -case (Rle_or_lt (ulp x) (y-x)); intros H1. -apply Rplus_le_reg_r with (-x)%R. -now ring_simplify (x+ulp x + -x)%R. -replace y with (x+(y-x))%R by ring. -absurd (x < y)%R. -2: apply H. -apply Rle_not_lt; apply Req_le. -rewrite <- round_DN_plus_eps_pos with (eps:=(y-x)%R); try easy. -ring_simplify (x+(y-x))%R. -apply sym_eq. -apply round_generic... -split; trivial. -apply Rlt_le; now apply Rlt_Rminus. -Qed. - -Theorem succ_le_lt: - forall x y, - F x -> F y -> - (x < y)%R -> - (succ x <= y)%R. -Proof with auto with typeclass_instances. -intros x y Fx Fy H. -destruct (Rle_or_lt 0 x) as [Hx|Hx]. -now apply succ_le_lt_aux. -unfold succ; rewrite Rle_bool_false; try assumption. -case (Rle_or_lt y 0); intros Hy. -rewrite <- (Ropp_involutive y). -apply Ropp_le_contravar. -apply le_pred_pos_lt. -now apply generic_format_opp. -now apply generic_format_opp. -split. -rewrite <- Ropp_0; now apply Ropp_le_contravar. -now apply Ropp_lt_contravar. -apply Rle_trans with (-0)%R. -apply Ropp_le_contravar. -apply pred_pos_ge_0. -rewrite <- Ropp_0; now apply Ropp_lt_contravar. -now apply generic_format_opp. -rewrite Ropp_0; now left. -Qed. - -Theorem le_pred_lt : - forall x y, - F x -> F y -> - (x < y)%R -> - (x <= pred y)%R. -Proof. -intros x y Fx Fy Hxy. -rewrite <- (Ropp_involutive x). -unfold pred; apply Ropp_le_contravar. -apply succ_le_lt. -now apply generic_format_opp. -now apply generic_format_opp. -now apply Ropp_lt_contravar. -Qed. - -Theorem lt_succ_le : - forall x y, - (y <> 0)%R -> - (x <= y)%R -> - (x < succ y)%R. -Proof. -intros x y Zy Hxy. -apply Rle_lt_trans with (1 := Hxy). -now apply succ_gt_id. -Qed. - -Theorem pred_lt_le : - forall x y, - (x <> 0)%R -> - (x <= y)%R -> - (pred x < y)%R. -Proof. -intros x y Zy Hxy. -apply Rlt_le_trans with (2 := Hxy). -now apply pred_lt_id. -Qed. - -Theorem succ_pred_aux : forall x, F x -> (0 < x)%R -> succ (pred x)=x. -Proof. -intros x Fx Hx. -rewrite pred_eq_pos;[idtac|now left]. -rewrite succ_eq_pos. -2: now apply pred_pos_ge_0. -now apply pred_pos_plus_ulp. -Qed. - -Theorem pred_ulp_0 : - pred (ulp 0) = 0%R. -Proof. -rewrite pred_eq_pos. -2: apply ulp_ge_0. -unfold ulp; rewrite Req_bool_true; trivial. -case negligible_exp_spec'. -(* *) -intros [H1 _]; rewrite H1. -unfold pred_pos; rewrite Req_bool_false. -2: apply Rlt_not_eq, bpow_gt_0. -unfold ulp; rewrite Req_bool_true; trivial. -rewrite H1; ring. -(* *) -intros (n,(H1,H2)); rewrite H1. -unfold pred_pos. -rewrite ln_beta_bpow. -replace (fexp n + 1 - 1)%Z with (fexp n) by ring. -rewrite Req_bool_true; trivial. -apply Rminus_diag_eq, f_equal. -apply sym_eq, valid_exp; omega. -Qed. - -Theorem succ_0 : - succ 0 = ulp 0. -Proof. -unfold succ. -rewrite Rle_bool_true. -apply Rplus_0_l. -apply Rle_refl. -Qed. - -Theorem pred_0 : - pred 0 = Ropp (ulp 0). -Proof. -rewrite <- succ_0. -rewrite <- Ropp_0 at 1. -apply pred_opp. -Qed. - -Theorem pred_succ_aux : - forall x, F x -> (0 < x)%R -> - pred (succ x) = x. -Proof. -intros x Fx Hx. -apply Rle_antisym. -- apply Rnot_lt_le. - intros H. - apply succ_le_lt with (1 := Fx) in H. - revert H. - apply Rlt_not_le. - apply pred_lt_id. - apply Rgt_not_eq. - apply Rlt_le_trans with (1 := Hx). - apply succ_ge_id. - now apply generic_format_pred, generic_format_succ. -- apply le_pred_lt with (1 := Fx). - now apply generic_format_succ. - apply succ_gt_id. - now apply Rgt_not_eq. -Qed. - -Theorem succ_pred : - forall x, F x -> - succ (pred x) = x. -Proof. -intros x Fx. -destruct (Rle_or_lt 0 x) as [[Hx|Hx]|Hx]. -now apply succ_pred_aux. -rewrite <- Hx. -rewrite pred_0, succ_opp, pred_ulp_0. -apply Ropp_0. -rewrite pred_eq_opp_succ_opp, succ_opp. -rewrite pred_succ_aux. -apply Ropp_involutive. -now apply generic_format_opp. -now apply Ropp_0_gt_lt_contravar. -Qed. - -Theorem pred_succ : - forall x, F x -> - pred (succ x) = x. -Proof. -intros x Fx. -rewrite <- (Ropp_involutive x). -rewrite succ_opp, pred_opp. -apply f_equal, succ_pred. -now apply generic_format_opp. -Qed. - -Theorem round_UP_pred_plus_eps : - forall x, F x -> - forall eps, (0 < eps <= if (Rle_bool x 0) then (ulp x) - else (ulp (pred x)))%R -> - round beta fexp Zceil (pred x + eps) = x. -Proof. -intros x Fx eps Heps. -rewrite round_UP_plus_eps. -now apply succ_pred. -now apply generic_format_pred. -unfold pred at 4. -rewrite Ropp_involutive, pred_succ. -rewrite ulp_opp. -generalize Heps; case (Rle_bool_spec x 0); intros H1 H2. -rewrite Rle_bool_false; trivial. -case H1; intros H1'. -apply Rlt_le_trans with (2:=H1). -apply pred_lt_id. -now apply Rlt_not_eq. -rewrite H1'; unfold pred, succ. -rewrite Ropp_0; rewrite Rle_bool_true;[idtac|now right]. -rewrite Rplus_0_l. -rewrite <- Ropp_0; apply Ropp_lt_contravar. -apply Rlt_le_trans with (1:=proj1 H2). -apply Rle_trans with (1:=proj2 H2). -rewrite Ropp_0, H1'. -now right. -rewrite Rle_bool_true; trivial. -now apply pred_ge_0. -now apply generic_format_opp. -Qed. - - -Theorem round_DN_minus_eps: - forall x, F x -> - forall eps, (0 < eps <= if (Rle_bool x 0) then (ulp x) - else (ulp (pred x)))%R -> - round beta fexp Zfloor (x - eps) = pred x. -Proof. -intros x Fx eps Heps. -replace (x-eps)%R with (-(-x+eps))%R by ring. -rewrite round_DN_opp. -unfold pred; apply f_equal. -pattern (-x)%R at 1; rewrite <- (pred_succ (-x)). -apply round_UP_pred_plus_eps. -now apply generic_format_succ, generic_format_opp. -rewrite pred_succ. -rewrite ulp_opp. -generalize Heps; case (Rle_bool_spec x 0); intros H1 H2. -rewrite Rle_bool_false; trivial. -case H1; intros H1'. -apply Rlt_le_trans with (-x)%R. -now apply Ropp_0_gt_lt_contravar. -apply succ_ge_id. -rewrite H1', Ropp_0, succ_eq_pos;[idtac|now right]. -rewrite Rplus_0_l. -apply Rlt_le_trans with (1:=proj1 H2). -rewrite H1' in H2; apply H2. -rewrite Rle_bool_true. -now rewrite succ_opp, ulp_opp. -rewrite succ_opp. -rewrite <- Ropp_0; apply Ropp_le_contravar. -now apply pred_ge_0. -now apply generic_format_opp. -now apply generic_format_opp. -Qed. - -(** Error of a rounding, expressed in number of ulps *) -(** false for x=0 in the FLX format *) -(* was ulp_error *) -Theorem error_lt_ulp : - forall rnd { Zrnd : Valid_rnd rnd } x, - (x <> 0)%R -> - (Rabs (round beta fexp rnd x - x) < ulp x)%R. -Proof with auto with typeclass_instances. -intros rnd Zrnd x Zx. -destruct (generic_format_EM beta fexp x) as [Hx|Hx]. -(* x = rnd x *) -rewrite round_generic... -unfold Rminus. -rewrite Rplus_opp_r, Rabs_R0. -rewrite ulp_neq_0; trivial. -apply bpow_gt_0. -(* x <> rnd x *) -destruct (round_DN_or_UP beta fexp rnd x) as [H|H] ; rewrite H ; clear H. -(* . *) -rewrite Rabs_left1. -rewrite Ropp_minus_distr. -apply Rplus_lt_reg_l with (round beta fexp Zfloor x). -rewrite <- round_UP_DN_ulp with (1 := Hx). -ring_simplify. -assert (Hu: (x <= round beta fexp Zceil x)%R). -apply round_UP_pt... -destruct Hu as [Hu|Hu]. -exact Hu. -elim Hx. -rewrite Hu. -apply generic_format_round... -apply Rle_minus. -apply round_DN_pt... -(* . *) -rewrite Rabs_pos_eq. -rewrite round_UP_DN_ulp with (1 := Hx). -apply Rplus_lt_reg_r with (x - ulp x)%R. -ring_simplify. -assert (Hd: (round beta fexp Zfloor x <= x)%R). -apply round_DN_pt... -destruct Hd as [Hd|Hd]. -exact Hd. -elim Hx. -rewrite <- Hd. -apply generic_format_round... -apply Rle_0_minus. -apply round_UP_pt... -Qed. - -(* was ulp_error_le *) -Theorem error_le_ulp : - forall rnd { Zrnd : Valid_rnd rnd } x, - (Rabs (round beta fexp rnd x - x) <= ulp x)%R. -Proof with auto with typeclass_instances. -intros rnd Zrnd x. -case (Req_dec x 0). -intros Zx; rewrite Zx, round_0... -unfold Rminus; rewrite Rplus_0_l, Ropp_0, Rabs_R0. -apply ulp_ge_0. -intros Zx; left. -now apply error_lt_ulp. -Qed. - -(* was ulp_half_error *) -Theorem error_le_half_ulp : - forall choice x, - (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * ulp x)%R. -Proof with auto with typeclass_instances. -intros choice x. -destruct (generic_format_EM beta fexp x) as [Hx|Hx]. -(* x = rnd x *) -rewrite round_generic... -unfold Rminus. -rewrite Rplus_opp_r, Rabs_R0. -apply Rmult_le_pos. -apply Rlt_le. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). -apply ulp_ge_0. -(* x <> rnd x *) -set (d := round beta fexp Zfloor x). -destruct (round_N_pt beta fexp choice x) as (Hr1, Hr2). -destruct (Rle_or_lt (x - d) (d + ulp x - x)) as [H|H]. -(* . rnd(x) = rndd(x) *) -apply Rle_trans with (Rabs (d - x)). -apply Hr2. -apply (round_DN_pt beta fexp x). -rewrite Rabs_left1. -rewrite Ropp_minus_distr. -apply Rmult_le_reg_r with 2%R. -now apply (Z2R_lt 0 2). -apply Rplus_le_reg_r with (d - x)%R. -ring_simplify. -apply Rle_trans with (1 := H). -right. field. -apply Rle_minus. -apply (round_DN_pt beta fexp x). -(* . rnd(x) = rndu(x) *) -assert (Hu: (d + ulp x)%R = round beta fexp Zceil x). -unfold d. -now rewrite <- round_UP_DN_ulp. -apply Rle_trans with (Rabs (d + ulp x - x)). -apply Hr2. -rewrite Hu. -apply (round_UP_pt beta fexp x). -rewrite Rabs_pos_eq. -apply Rmult_le_reg_r with 2%R. -now apply (Z2R_lt 0 2). -apply Rplus_le_reg_r with (- (d + ulp x - x))%R. -ring_simplify. -apply Rlt_le. -apply Rlt_le_trans with (1 := H). -right. field. -apply Rle_0_minus. -rewrite Hu. -apply (round_UP_pt beta fexp x). -Qed. - - -Theorem ulp_DN : - forall x, - (0 < round beta fexp Zfloor x)%R -> - ulp (round beta fexp Zfloor x) = ulp x. -Proof with auto with typeclass_instances. -intros x Hd. -rewrite 2!ulp_neq_0. -now rewrite canonic_exp_DN with (2 := Hd). -intros T; contradict Hd; rewrite T, round_0... -apply Rlt_irrefl. -now apply Rgt_not_eq. -Qed. - -Theorem round_neq_0_negligible_exp: - negligible_exp=None -> forall rnd { Zrnd : Valid_rnd rnd } x, - (x <> 0)%R -> (round beta fexp rnd x <> 0)%R. -Proof with auto with typeclass_instances. -intros H rndn Hrnd x Hx K. -case negligible_exp_spec'. -intros (_,Hn). -destruct (ln_beta beta x) as (e,He). -absurd (fexp e < e)%Z. -apply Zle_not_lt. -apply exp_small_round_0 with beta rndn x... -apply (Hn e). -intros (n,(H1,_)). -rewrite H in H1; discriminate. -Qed. - - -(** allows rnd x to be 0 *) -(* was ulp_error_f *) -Theorem error_lt_ulp_round : - forall { Hm : Monotone_exp fexp } rnd { Zrnd : Valid_rnd rnd } x, - ( x <> 0)%R -> - (Rabs (round beta fexp rnd x - x) < ulp (round beta fexp rnd x))%R. -Proof with auto with typeclass_instances. -intros Hm. -(* wlog *) -cut (forall rnd : R -> Z, Valid_rnd rnd -> forall x : R, (0 < x)%R -> - (Rabs (round beta fexp rnd x - x) < ulp (round beta fexp rnd x))%R). -intros M rnd Hrnd x Zx. -case (Rle_or_lt 0 x). -intros H; destruct H. -now apply M. -contradict H; now apply sym_not_eq. -intros H. -rewrite <- (Ropp_involutive x). -rewrite round_opp, ulp_opp. -replace (- round beta fexp (Zrnd_opp rnd) (- x) - - - x)%R with - (-(round beta fexp (Zrnd_opp rnd) (- x) - (-x)))%R by ring. -rewrite Rabs_Ropp. -apply M. -now apply valid_rnd_opp. -now apply Ropp_0_gt_lt_contravar. -(* 0 < x *) -intros rnd Hrnd x Hx. -case (Rle_lt_or_eq_dec 0 (round beta fexp Zfloor x)). -apply round_ge_generic... -apply generic_format_0. -now left. -(* . 0 < round Zfloor x *) -intros Hx2. -apply Rlt_le_trans with (ulp x). -apply error_lt_ulp... -now apply Rgt_not_eq. -rewrite <- ulp_DN; trivial. -apply ulp_le_pos. -now left. -case (round_DN_or_UP beta fexp rnd x); intros V; rewrite V. -apply Rle_refl. -apply Rle_trans with x. -apply round_DN_pt... -apply round_UP_pt... -(* . 0 = round Zfloor x *) -intros Hx2. -case (round_DN_or_UP beta fexp rnd x); intros V; rewrite V; clear V. -(* .. round down -- difficult case *) -rewrite <- Hx2. -unfold Rminus; rewrite Rplus_0_l, Rabs_Ropp. -unfold ulp; rewrite Req_bool_true; trivial. -case negligible_exp_spec. -(* without minimal exponent *) -intros K; contradict Hx2. -apply Rlt_not_eq. -apply F2R_gt_0_compat; simpl. -apply Zlt_le_trans with 1%Z. -apply Pos2Z.is_pos. -apply Zfloor_lub. -simpl; unfold scaled_mantissa, canonic_exp. -destruct (ln_beta beta x) as (e,He); simpl. -apply Rle_trans with (bpow (e-1) * bpow (- fexp e))%R. -rewrite <- bpow_plus. -replace 1%R with (bpow 0) by reflexivity. -apply bpow_le. -specialize (K e); omega. -apply Rmult_le_compat_r. -apply bpow_ge_0. -rewrite <- (Rabs_pos_eq x). -now apply He, Rgt_not_eq. -now left. -(* with a minimal exponent *) -intros n Hn. -rewrite Rabs_pos_eq;[idtac|now left]. -case (Rle_or_lt (bpow (fexp n)) x); trivial. -intros K; contradict Hx2. -apply Rlt_not_eq. -apply Rlt_le_trans with (bpow (fexp n)). -apply bpow_gt_0. -apply round_ge_generic... -apply generic_format_bpow. -now apply valid_exp. -(* .. round up *) -apply Rlt_le_trans with (ulp x). -apply error_lt_ulp... -now apply Rgt_not_eq. -apply ulp_le_pos. -now left. -apply round_UP_pt... -Qed. - -(** allows both x and rnd x to be 0 *) -(* was ulp_half_error_f *) -Theorem error_le_half_ulp_round : - forall { Hm : Monotone_exp fexp }, - forall choice x, - (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * ulp (round beta fexp (Znearest choice) x))%R. -Proof with auto with typeclass_instances. -intros Hm choice x. -case (Req_dec (round beta fexp (Znearest choice) x) 0); intros Hfx. -(* *) -case (Req_dec x 0); intros Hx. -apply Rle_trans with (1:=error_le_half_ulp _ _). -rewrite Hx, round_0... -right; ring. -generalize (error_le_half_ulp choice x). -rewrite Hfx. -unfold Rminus; rewrite Rplus_0_l, Rabs_Ropp. -intros N. -unfold ulp; rewrite Req_bool_true; trivial. -case negligible_exp_spec'. -intros (H1,H2). -contradict Hfx. -apply round_neq_0_negligible_exp... -intros (n,(H1,Hn)); rewrite H1. -apply Rle_trans with (1:=N). -right; apply f_equal. -rewrite ulp_neq_0; trivial. -apply f_equal. -unfold canonic_exp. -apply valid_exp; trivial. -assert (ln_beta beta x -1 < fexp n)%Z;[idtac|omega]. -apply lt_bpow with beta. -destruct (ln_beta beta x) as (e,He). -simpl. -apply Rle_lt_trans with (Rabs x). -now apply He. -apply Rle_lt_trans with (Rabs (round beta fexp (Znearest choice) x - x)). -right; rewrite Hfx; unfold Rminus; rewrite Rplus_0_l. -apply sym_eq, Rabs_Ropp. -apply Rlt_le_trans with (ulp 0). -rewrite <- Hfx. -apply error_lt_ulp_round... -unfold ulp; rewrite Req_bool_true, H1; trivial. -now right. -(* *) -case (round_DN_or_UP beta fexp (Znearest choice) x); intros Hx. -(* . *) -case (Rle_or_lt 0 (round beta fexp Zfloor x)). -intros H; destruct H. -rewrite Hx at 2. -rewrite ulp_DN; trivial. -apply error_le_half_ulp. -rewrite Hx in Hfx; contradict Hfx; auto with real. -intros H. -apply Rle_trans with (1:=error_le_half_ulp _ _). -apply Rmult_le_compat_l. -apply Rlt_le, pos_half_prf. -apply ulp_le. -rewrite Hx; rewrite (Rabs_left1 x), Rabs_left; try assumption. -apply Ropp_le_contravar. -apply (round_DN_pt beta fexp x). -case (Rle_or_lt x 0); trivial. -intros H1; contradict H. -apply Rle_not_lt. -apply round_ge_generic... -apply generic_format_0. -now left. -(* . *) -case (Rle_or_lt 0 (round beta fexp Zceil x)). -intros H; destruct H. -apply Rle_trans with (1:=error_le_half_ulp _ _). -apply Rmult_le_compat_l. -apply Rlt_le, pos_half_prf. -apply ulp_le_pos; trivial. -case (Rle_or_lt 0 x); trivial. -intros H1; contradict H. -apply Rle_not_lt. -apply round_le_generic... -apply generic_format_0. -now left. -rewrite Hx; apply (round_UP_pt beta fexp x). -rewrite Hx in Hfx; contradict Hfx; auto with real. -intros H. -rewrite Hx at 2; rewrite <- (ulp_opp (round beta fexp Zceil x)). -rewrite <- round_DN_opp. -rewrite ulp_DN; trivial. -pattern x at 1 2; rewrite <- Ropp_involutive. -rewrite round_N_opp. -unfold Rminus. -rewrite <- Ropp_plus_distr, Rabs_Ropp. -apply error_le_half_ulp. -rewrite round_DN_opp; apply Ropp_0_gt_lt_contravar; apply Rlt_gt; assumption. -Qed. - -Theorem pred_le : - forall x y, F x -> F y -> (x <= y)%R -> - (pred x <= pred y)%R. -Proof. -intros x y Fx Fy [Hxy| ->]. -2: apply Rle_refl. -apply le_pred_lt with (2 := Fy). -now apply generic_format_pred. -apply Rle_lt_trans with (2 := Hxy). -apply pred_le_id. -Qed. - -Theorem succ_le: forall x y, - F x -> F y -> (x <= y)%R -> (succ x <= succ y)%R. -Proof. -intros x y Fx Fy Hxy. -rewrite 2!succ_eq_opp_pred_opp. -apply Ropp_le_contravar, pred_le; try apply generic_format_opp; try assumption. -now apply Ropp_le_contravar. -Qed. - -Theorem pred_le_inv: forall x y, F x -> F y - -> (pred x <= pred y)%R -> (x <= y)%R. -Proof. -intros x y Fx Fy Hxy. -rewrite <- (succ_pred x), <- (succ_pred y); try assumption. -apply succ_le; trivial; now apply generic_format_pred. -Qed. - -Theorem succ_le_inv: forall x y, F x -> F y - -> (succ x <= succ y)%R -> (x <= y)%R. -Proof. -intros x y Fx Fy Hxy. -rewrite <- (pred_succ x), <- (pred_succ y); try assumption. -apply pred_le; trivial; now apply generic_format_succ. -Qed. - -Theorem pred_lt : - forall x y, F x -> F y -> (x < y)%R -> - (pred x < pred y)%R. -Proof. -intros x y Fx Fy Hxy. -apply Rnot_le_lt. -intros H. -apply Rgt_not_le with (1 := Hxy). -now apply pred_le_inv. -Qed. - -Theorem succ_lt : - forall x y, F x -> F y -> (x < y)%R -> - (succ x < succ y)%R. -Proof. -intros x y Fx Fy Hxy. -apply Rnot_le_lt. -intros H. -apply Rgt_not_le with (1 := Hxy). -now apply succ_le_inv. -Qed. - -(* was lt_UP_le_DN *) -Theorem le_round_DN_lt_UP : - forall x y, F y -> - (y < round beta fexp Zceil x -> y <= round beta fexp Zfloor x)%R. -Proof with auto with typeclass_instances. -intros x y Fy Hlt. -apply round_DN_pt... -apply Rnot_lt_le. -contradict Hlt. -apply RIneq.Rle_not_lt. -apply round_UP_pt... -now apply Rlt_le. -Qed. - -(* was lt_DN_le_UP *) -Theorem round_UP_le_gt_DN : - forall x y, F y -> - (round beta fexp Zfloor x < y -> round beta fexp Zceil x <= y)%R. -Proof with auto with typeclass_instances. -intros x y Fy Hlt. -apply round_UP_pt... -apply Rnot_lt_le. -contradict Hlt. -apply RIneq.Rle_not_lt. -apply round_DN_pt... -now apply Rlt_le. -Qed. - - - -Theorem pred_UP_le_DN : - forall x, (pred (round beta fexp Zceil x) <= round beta fexp Zfloor x)%R. -Proof with auto with typeclass_instances. -intros x. -destruct (generic_format_EM beta fexp x) as [Fx|Fx]. -rewrite !round_generic... -apply pred_le_id. -case (Req_dec (round beta fexp Zceil x) 0); intros Zx. -rewrite Zx; unfold pred; rewrite Ropp_0. -unfold succ; rewrite Rle_bool_true;[idtac|now right]. -rewrite Rplus_0_l; unfold ulp; rewrite Req_bool_true; trivial. -case negligible_exp_spec'. -intros (H1,H2). -contradict Zx; apply round_neq_0_negligible_exp... -intros L; apply Fx; rewrite L; apply generic_format_0. -intros (n,(H1,Hn)); rewrite H1. -case (Rle_or_lt (- bpow (fexp n)) (round beta fexp Zfloor x)); trivial; intros K. -absurd (round beta fexp Zceil x <= - bpow (fexp n))%R. -apply Rlt_not_le. -rewrite Zx, <- Ropp_0. -apply Ropp_lt_contravar, bpow_gt_0. -apply round_UP_le_gt_DN; try assumption. -apply generic_format_opp, generic_format_bpow. -now apply valid_exp. -assert (let u := round beta fexp Zceil x in pred u < u)%R as Hup. -now apply pred_lt_id. -apply le_round_DN_lt_UP... -apply generic_format_pred... -now apply round_UP_pt. -Qed. - -Theorem pred_UP_eq_DN : - forall x, ~ F x -> - (pred (round beta fexp Zceil x) = round beta fexp Zfloor x)%R. -Proof with auto with typeclass_instances. -intros x Fx. -apply Rle_antisym. -now apply pred_UP_le_DN. -apply le_pred_lt; try apply generic_format_round... -pose proof round_DN_UP_lt _ _ _ Fx as HE. -now apply Rlt_trans with (1 := proj1 HE) (2 := proj2 HE). -Qed. - -Theorem succ_DN_eq_UP : - forall x, ~ F x -> - (succ (round beta fexp Zfloor x) = round beta fexp Zceil x)%R. -Proof with auto with typeclass_instances. -intros x Fx. -rewrite <- pred_UP_eq_DN; trivial. -rewrite succ_pred; trivial. -apply generic_format_round... -Qed. - - -(* was betw_eq_DN *) -Theorem round_DN_eq_betw: forall x d, F d - -> (d <= x < succ d)%R - -> round beta fexp Zfloor x = d. -Proof with auto with typeclass_instances. -intros x d Fd (Hxd1,Hxd2). -generalize (round_DN_pt beta fexp x); intros (T1,(T2,T3)). -apply sym_eq, Rle_antisym. -now apply T3. -destruct (generic_format_EM beta fexp x) as [Fx|NFx]. -rewrite round_generic... -apply succ_le_inv; try assumption. -apply succ_le_lt; try assumption. -apply generic_format_succ... -apply succ_le_inv; try assumption. -rewrite succ_DN_eq_UP; trivial. -apply round_UP_pt... -apply generic_format_succ... -now left. -Qed. - -(* was betw_eq_UP *) -Theorem round_UP_eq_betw: forall x u, F u - -> (pred u < x <= u)%R - -> round beta fexp Zceil x = u. -Proof with auto with typeclass_instances. -intros x u Fu Hux. -rewrite <- (Ropp_involutive (round beta fexp Zceil x)). -rewrite <- round_DN_opp. -rewrite <- (Ropp_involutive u). -apply f_equal. -apply round_DN_eq_betw; try assumption. -now apply generic_format_opp. -split;[now apply Ropp_le_contravar|idtac]. -rewrite succ_opp. -now apply Ropp_lt_contravar. -Qed. - - - - -(** Properties of rounding to nearest and ulp *) - -Theorem round_N_le_midp: forall choice u v, - F u -> (v < (u + succ u)/2)%R - -> (round beta fexp (Znearest choice) v <= u)%R. -Proof with auto with typeclass_instances. -intros choice u v Fu H. -(* . *) -assert (V: ((succ u = 0 /\ u = 0) \/ u < succ u)%R). -specialize (succ_ge_id u); intros P; destruct P as [P|P]. -now right. -case (Req_dec u 0); intros Zu. -left; split; trivial. -now rewrite <- P. -right; now apply succ_gt_id. -(* *) -destruct V as [(V1,V2)|V]. -rewrite V2; apply round_le_generic... -apply generic_format_0. -left; apply Rlt_le_trans with (1:=H). -rewrite V1,V2; right; field. -(* *) -assert (T: (u < (u + succ u) / 2 < succ u)%R) by lra. -destruct T as (T1,T2). -apply Rnd_N_pt_monotone with F v ((u + succ u) / 2)%R... -apply round_N_pt... -apply Rnd_DN_pt_N with (succ u)%R. -pattern u at 3; replace u with (round beta fexp Zfloor ((u + succ u) / 2)). -apply round_DN_pt... -apply round_DN_eq_betw; trivial. -split; try left; assumption. -pattern (succ u) at 2; replace (succ u) with (round beta fexp Zceil ((u + succ u) / 2)). -apply round_UP_pt... -apply round_UP_eq_betw; trivial. -apply generic_format_succ... -rewrite pred_succ; trivial. -split; try left; assumption. -right; field. -Qed. - - -Theorem round_N_ge_midp: forall choice u v, - F u -> ((u + pred u)/2 < v)%R - -> (u <= round beta fexp (Znearest choice) v)%R. -Proof with auto with typeclass_instances. -intros choice u v Fu H. -rewrite <- (Ropp_involutive v). -rewrite round_N_opp. -rewrite <- (Ropp_involutive u). -apply Ropp_le_contravar. -apply round_N_le_midp. -now apply generic_format_opp. -apply Ropp_lt_cancel. -rewrite Ropp_involutive. -apply Rle_lt_trans with (2:=H). -unfold pred. -right; field. -Qed. - - -Lemma round_N_eq_DN: forall choice x, - let d:=round beta fexp Zfloor x in - let u:=round beta fexp Zceil x in - (x<(d+u)/2)%R -> - round beta fexp (Znearest choice) x = d. -Proof with auto with typeclass_instances. -intros choice x d u H. -apply Rle_antisym. -destruct (generic_format_EM beta fexp x) as [Fx|Fx]. -rewrite round_generic... -apply round_DN_pt; trivial; now right. -apply round_N_le_midp. -apply round_DN_pt... -apply Rlt_le_trans with (1:=H). -right; apply f_equal2; trivial; apply f_equal. -now apply sym_eq, succ_DN_eq_UP. -apply round_ge_generic; try apply round_DN_pt... -Qed. - -Lemma round_N_eq_DN_pt: forall choice x d u, - Rnd_DN_pt F x d -> Rnd_UP_pt F x u -> - (x<(d+u)/2)%R -> - round beta fexp (Znearest choice) x = d. -Proof with auto with typeclass_instances. -intros choice x d u Hd Hu H. -assert (H0:(d = round beta fexp Zfloor x)%R). -apply Rnd_DN_pt_unicity with (1:=Hd). -apply round_DN_pt... -rewrite H0. -apply round_N_eq_DN. -rewrite <- H0. -rewrite Rnd_UP_pt_unicity with F x (round beta fexp Zceil x) u; try assumption. -apply round_UP_pt... -Qed. - -Lemma round_N_eq_UP: forall choice x, - let d:=round beta fexp Zfloor x in - let u:=round beta fexp Zceil x in - ((d+u)/2 < x)%R -> - round beta fexp (Znearest choice) x = u. -Proof with auto with typeclass_instances. -intros choice x d u H. -apply Rle_antisym. -apply round_le_generic; try apply round_UP_pt... -destruct (generic_format_EM beta fexp x) as [Fx|Fx]. -rewrite round_generic... -apply round_UP_pt; trivial; now right. -apply round_N_ge_midp. -apply round_UP_pt... -apply Rle_lt_trans with (2:=H). -right; apply f_equal2; trivial; rewrite Rplus_comm; apply f_equal2; trivial. -now apply pred_UP_eq_DN. -Qed. - -Lemma round_N_eq_UP_pt: forall choice x d u, - Rnd_DN_pt F x d -> Rnd_UP_pt F x u -> - ((d+u)/2 < x)%R -> - round beta fexp (Znearest choice) x = u. -Proof with auto with typeclass_instances. -intros choice x d u Hd Hu H. -assert (H0:(u = round beta fexp Zceil x)%R). -apply Rnd_UP_pt_unicity with (1:=Hu). -apply round_UP_pt... -rewrite H0. -apply round_N_eq_UP. -rewrite <- H0. -rewrite Rnd_DN_pt_unicity with F x (round beta fexp Zfloor x) d; try assumption. -apply round_DN_pt... -Qed. - -End Fcore_ulp. diff --git a/flocq/Core/Float_prop.v b/flocq/Core/Float_prop.v new file mode 100644 index 00000000..804dd397 --- /dev/null +++ b/flocq/Core/Float_prop.v @@ -0,0 +1,559 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2009-2018 Sylvie Boldo +#
# +Copyright (C) 2009-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +(** * Basic properties of floating-point formats: lemmas about mantissa, exponent... *) +Require Import Raux Defs Digits. + +Section Float_prop. + +Variable beta : radix. +Notation bpow e := (bpow beta e). + +Theorem Rcompare_F2R : + forall e m1 m2 : Z, + Rcompare (F2R (Float beta m1 e)) (F2R (Float beta m2 e)) = Z.compare m1 m2. +Proof. +intros e m1 m2. +unfold F2R. simpl. +rewrite Rcompare_mult_r. +apply Rcompare_IZR. +apply bpow_gt_0. +Qed. + +(** Basic facts *) +Theorem le_F2R : + forall e m1 m2 : Z, + (F2R (Float beta m1 e) <= F2R (Float beta m2 e))%R -> + (m1 <= m2)%Z. +Proof. +intros e m1 m2 H. +apply le_IZR. +apply Rmult_le_reg_r with (bpow e). +apply bpow_gt_0. +exact H. +Qed. + +Theorem F2R_le : + forall m1 m2 e : Z, + (m1 <= m2)%Z -> + (F2R (Float beta m1 e) <= F2R (Float beta m2 e))%R. +Proof. +intros m1 m2 e H. +unfold F2R. simpl. +apply Rmult_le_compat_r. +apply bpow_ge_0. +now apply IZR_le. +Qed. + +Theorem lt_F2R : + forall e m1 m2 : Z, + (F2R (Float beta m1 e) < F2R (Float beta m2 e))%R -> + (m1 < m2)%Z. +Proof. +intros e m1 m2 H. +apply lt_IZR. +apply Rmult_lt_reg_r with (bpow e). +apply bpow_gt_0. +exact H. +Qed. + +Theorem F2R_lt : + forall e m1 m2 : Z, + (m1 < m2)%Z -> + (F2R (Float beta m1 e) < F2R (Float beta m2 e))%R. +Proof. +intros e m1 m2 H. +unfold F2R. simpl. +apply Rmult_lt_compat_r. +apply bpow_gt_0. +now apply IZR_lt. +Qed. + +Theorem F2R_eq : + forall e m1 m2 : Z, + (m1 = m2)%Z -> + (F2R (Float beta m1 e) = F2R (Float beta m2 e))%R. +Proof. +intros e m1 m2 H. +now apply (f_equal (fun m => F2R (Float beta m e))). +Qed. + +Theorem eq_F2R : + forall e m1 m2 : Z, + F2R (Float beta m1 e) = F2R (Float beta m2 e) -> + m1 = m2. +Proof. +intros e m1 m2 H. +apply Zle_antisym ; + apply le_F2R with e ; + rewrite H ; + apply Rle_refl. +Qed. + +Theorem F2R_Zabs: + forall m e : Z, + F2R (Float beta (Z.abs m) e) = Rabs (F2R (Float beta m e)). +Proof. +intros m e. +unfold F2R. +rewrite Rabs_mult. +rewrite <- abs_IZR. +simpl. +apply f_equal. +apply sym_eq; apply Rabs_right. +apply Rle_ge. +apply bpow_ge_0. +Qed. + +Theorem F2R_Zopp : + forall m e : Z, + F2R (Float beta (Z.opp m) e) = Ropp (F2R (Float beta m e)). +Proof. +intros m e. +unfold F2R. simpl. +rewrite <- Ropp_mult_distr_l_reverse. +now rewrite opp_IZR. +Qed. + +Theorem F2R_cond_Zopp : + forall b m e, + F2R (Float beta (cond_Zopp b m) e) = cond_Ropp b (F2R (Float beta m e)). +Proof. +intros [|] m e ; unfold F2R ; simpl. +now rewrite opp_IZR, Ropp_mult_distr_l_reverse. +apply refl_equal. +Qed. + +(** Sign facts *) +Theorem F2R_0 : + forall e : Z, + F2R (Float beta 0 e) = 0%R. +Proof. +intros e. +unfold F2R. simpl. +apply Rmult_0_l. +Qed. + +Theorem eq_0_F2R : + forall m e : Z, + F2R (Float beta m e) = 0%R -> + m = Z0. +Proof. +intros m e H. +apply eq_F2R with e. +now rewrite F2R_0. +Qed. + +Theorem ge_0_F2R : + forall m e : Z, + (0 <= F2R (Float beta m e))%R -> + (0 <= m)%Z. +Proof. +intros m e H. +apply le_F2R with e. +now rewrite F2R_0. +Qed. + +Theorem le_0_F2R : + forall m e : Z, + (F2R (Float beta m e) <= 0)%R -> + (m <= 0)%Z. +Proof. +intros m e H. +apply le_F2R with e. +now rewrite F2R_0. +Qed. + +Theorem gt_0_F2R : + forall m e : Z, + (0 < F2R (Float beta m e))%R -> + (0 < m)%Z. +Proof. +intros m e H. +apply lt_F2R with e. +now rewrite F2R_0. +Qed. + +Theorem lt_0_F2R : + forall m e : Z, + (F2R (Float beta m e) < 0)%R -> + (m < 0)%Z. +Proof. +intros m e H. +apply lt_F2R with e. +now rewrite F2R_0. +Qed. + +Theorem F2R_ge_0 : + forall f : float beta, + (0 <= Fnum f)%Z -> + (0 <= F2R f)%R. +Proof. +intros f H. +rewrite <- F2R_0 with (Fexp f). +now apply F2R_le. +Qed. + +Theorem F2R_le_0 : + forall f : float beta, + (Fnum f <= 0)%Z -> + (F2R f <= 0)%R. +Proof. +intros f H. +rewrite <- F2R_0 with (Fexp f). +now apply F2R_le. +Qed. + +Theorem F2R_gt_0 : + forall f : float beta, + (0 < Fnum f)%Z -> + (0 < F2R f)%R. +Proof. +intros f H. +rewrite <- F2R_0 with (Fexp f). +now apply F2R_lt. +Qed. + +Theorem F2R_lt_0 : + forall f : float beta, + (Fnum f < 0)%Z -> + (F2R f < 0)%R. +Proof. +intros f H. +rewrite <- F2R_0 with (Fexp f). +now apply F2R_lt. +Qed. + +Theorem F2R_neq_0 : + forall f : float beta, + (Fnum f <> 0)%Z -> + (F2R f <> 0)%R. +Proof. +intros f H H1. +apply H. +now apply eq_0_F2R with (Fexp f). +Qed. + + +Lemma Fnum_ge_0: forall (f : float beta), + (0 <= F2R f)%R -> (0 <= Fnum f)%Z. +Proof. +intros f H. +case (Zle_or_lt 0 (Fnum f)); trivial. +intros H1; contradict H. +apply Rlt_not_le. +now apply F2R_lt_0. +Qed. + +Lemma Fnum_le_0: forall (f : float beta), + (F2R f <= 0)%R -> (Fnum f <= 0)%Z. +Proof. +intros f H. +case (Zle_or_lt (Fnum f) 0); trivial. +intros H1; contradict H. +apply Rlt_not_le. +now apply F2R_gt_0. +Qed. + +(** Floats and bpow *) +Theorem F2R_bpow : + forall e : Z, + F2R (Float beta 1 e) = bpow e. +Proof. +intros e. +unfold F2R. simpl. +apply Rmult_1_l. +Qed. + +Theorem bpow_le_F2R : + forall m e : Z, + (0 < m)%Z -> + (bpow e <= F2R (Float beta m e))%R. +Proof. +intros m e H. +rewrite <- F2R_bpow. +apply F2R_le. +now apply (Zlt_le_succ 0). +Qed. + +Theorem F2R_p1_le_bpow : + forall m e1 e2 : Z, + (0 < m)%Z -> + (F2R (Float beta m e1) < bpow e2)%R -> + (F2R (Float beta (m + 1) e1) <= bpow e2)%R. +Proof. +intros m e1 e2 Hm. +intros H. +assert (He : (e1 <= e2)%Z). +(* . *) +apply (le_bpow beta). +apply Rle_trans with (F2R (Float beta m e1)). +unfold F2R. simpl. +rewrite <- (Rmult_1_l (bpow e1)) at 1. +apply Rmult_le_compat_r. +apply bpow_ge_0. +apply IZR_le. +now apply (Zlt_le_succ 0). +now apply Rlt_le. +(* . *) +revert H. +replace e2 with (e2 - e1 + e1)%Z by ring. +rewrite bpow_plus. +unfold F2R. simpl. +rewrite <- (IZR_Zpower beta (e2 - e1)). +intros H. +apply Rmult_le_compat_r. +apply bpow_ge_0. +apply Rmult_lt_reg_r in H. +apply IZR_le. +apply Zlt_le_succ. +now apply lt_IZR. +apply bpow_gt_0. +now apply Zle_minus_le_0. +Qed. + +Theorem bpow_le_F2R_m1 : + forall m e1 e2 : Z, + (1 < m)%Z -> + (bpow e2 < F2R (Float beta m e1))%R -> + (bpow e2 <= F2R (Float beta (m - 1) e1))%R. +Proof. +intros m e1 e2 Hm. +case (Zle_or_lt e1 e2); intros He. +replace e2 with (e2 - e1 + e1)%Z by ring. +rewrite bpow_plus. +unfold F2R. simpl. +rewrite <- (IZR_Zpower beta (e2 - e1)). +intros H. +apply Rmult_le_compat_r. +apply bpow_ge_0. +apply Rmult_lt_reg_r in H. +apply IZR_le. +rewrite (Zpred_succ (Zpower _ _)). +apply Zplus_le_compat_r. +apply Zlt_le_succ. +now apply lt_IZR. +apply bpow_gt_0. +now apply Zle_minus_le_0. +intros H. +apply Rle_trans with (1*bpow e1)%R. +rewrite Rmult_1_l. +apply bpow_le. +now apply Zlt_le_weak. +unfold F2R. simpl. +apply Rmult_le_compat_r. +apply bpow_ge_0. +apply IZR_le. +omega. +Qed. + +Theorem F2R_lt_bpow : + forall f : float beta, forall e', + (Z.abs (Fnum f) < Zpower beta (e' - Fexp f))%Z -> + (Rabs (F2R f) < bpow e')%R. +Proof. +intros (m, e) e' Hm. +rewrite <- F2R_Zabs. +destruct (Zle_or_lt e e') as [He|He]. +unfold F2R. simpl. +apply Rmult_lt_reg_r with (bpow (-e)). +apply bpow_gt_0. +rewrite Rmult_assoc, <- 2!bpow_plus, Zplus_opp_r, Rmult_1_r. +rewrite <-IZR_Zpower. 2: now apply Zle_left. +now apply IZR_lt. +elim Zlt_not_le with (1 := Hm). +simpl. +cut (e' - e < 0)%Z. 2: omega. +clear. +case (e' - e)%Z ; try easy. +intros p _. +apply Zabs_pos. +Qed. + +Theorem F2R_change_exp : + forall e' m e : Z, + (e' <= e)%Z -> + F2R (Float beta m e) = F2R (Float beta (m * Zpower beta (e - e')) e'). +Proof. +intros e' m e He. +unfold F2R. simpl. +rewrite mult_IZR, IZR_Zpower, Rmult_assoc. +apply f_equal. +pattern e at 1 ; replace e with (e - e' + e')%Z by ring. +apply bpow_plus. +now apply Zle_minus_le_0. +Qed. + +Theorem F2R_prec_normalize : + forall m e e' p : Z, + (Z.abs m < Zpower beta p)%Z -> + (bpow (e' - 1)%Z <= Rabs (F2R (Float beta m e)))%R -> + F2R (Float beta m e) = F2R (Float beta (m * Zpower beta (e - e' + p)) (e' - p)). +Proof. +intros m e e' p Hm Hf. +assert (Hp: (0 <= p)%Z). +destruct p ; try easy. +now elim (Zle_not_lt _ _ (Zabs_pos m)). +(* . *) +replace (e - e' + p)%Z with (e - (e' - p))%Z by ring. +apply F2R_change_exp. +cut (e' - 1 < e + p)%Z. omega. +apply (lt_bpow beta). +apply Rle_lt_trans with (1 := Hf). +rewrite <- F2R_Zabs, Zplus_comm, bpow_plus. +apply Rmult_lt_compat_r. +apply bpow_gt_0. +rewrite <- IZR_Zpower. +now apply IZR_lt. +exact Hp. +Qed. + +(** Floats and mag *) +Theorem mag_F2R_bounds : + forall x m e, (0 < m)%Z -> + (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R -> + mag beta x = mag beta (F2R (Float beta m e)) :> Z. +Proof. +intros x m e Hp (Hx,Hx2). +destruct (mag beta (F2R (Float beta m e))) as (ex, He). +simpl. +apply mag_unique. +assert (Hp1: (0 < F2R (Float beta m e))%R). +now apply F2R_gt_0. +specialize (He (Rgt_not_eq _ _ Hp1)). +rewrite Rabs_pos_eq in He. 2: now apply Rlt_le. +destruct He as (He1, He2). +assert (Hx1: (0 < x)%R). +now apply Rlt_le_trans with (2 := Hx). +rewrite Rabs_pos_eq. 2: now apply Rlt_le. +split. +now apply Rle_trans with (1 := He1). +apply Rlt_le_trans with (1 := Hx2). +now apply F2R_p1_le_bpow. +Qed. + +Theorem mag_F2R : + forall m e : Z, + m <> Z0 -> + (mag beta (F2R (Float beta m e)) = mag beta (IZR m) + e :> Z)%Z. +Proof. +intros m e H. +unfold F2R ; simpl. +apply mag_mult_bpow. +now apply IZR_neq. +Qed. + +Theorem Zdigits_mag : + forall n, + n <> Z0 -> + Zdigits beta n = mag beta (IZR n). +Proof. +intros n Hn. +destruct (mag beta (IZR n)) as (e, He) ; simpl. +specialize (He (IZR_neq _ _ Hn)). +rewrite <- abs_IZR in He. +assert (Hd := Zdigits_correct beta n). +assert (Hd' := Zdigits_gt_0 beta n). +apply Zle_antisym ; apply (bpow_lt_bpow beta). +apply Rle_lt_trans with (2 := proj2 He). +rewrite <- IZR_Zpower by omega. +now apply IZR_le. +apply Rle_lt_trans with (1 := proj1 He). +rewrite <- IZR_Zpower by omega. +now apply IZR_lt. +Qed. + +Theorem mag_F2R_Zdigits : + forall m e, m <> Z0 -> + (mag beta (F2R (Float beta m e)) = Zdigits beta m + e :> Z)%Z. +Proof. +intros m e Hm. +rewrite mag_F2R with (1 := Hm). +apply (f_equal (fun v => Zplus v e)). +apply sym_eq. +now apply Zdigits_mag. +Qed. + +Theorem mag_F2R_bounds_Zdigits : + forall x m e, (0 < m)%Z -> + (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R -> + mag beta x = (Zdigits beta m + e)%Z :> Z. +Proof. +intros x m e Hm Bx. +apply mag_F2R_bounds with (1 := Hm) in Bx. +rewrite Bx. +apply mag_F2R_Zdigits. +now apply Zgt_not_eq. +Qed. + +Theorem float_distribution_pos : + forall m1 e1 m2 e2 : Z, + (0 < m1)%Z -> + (F2R (Float beta m1 e1) < F2R (Float beta m2 e2) < F2R (Float beta (m1 + 1) e1))%R -> + (e2 < e1)%Z /\ (e1 + mag beta (IZR m1) = e2 + mag beta (IZR m2))%Z. +Proof. +intros m1 e1 m2 e2 Hp1 (H12, H21). +assert (He: (e2 < e1)%Z). +(* . *) +apply Znot_ge_lt. +intros H0. +elim Rlt_not_le with (1 := H21). +apply Z.ge_le in H0. +apply (F2R_change_exp e1 m2 e2) in H0. +rewrite H0. +apply F2R_le. +apply Zlt_le_succ. +apply (lt_F2R e1). +now rewrite <- H0. +(* . *) +split. +exact He. +rewrite (Zplus_comm e1), (Zplus_comm e2). +assert (Hp2: (0 < m2)%Z). +apply (gt_0_F2R m2 e2). +apply Rlt_trans with (2 := H12). +now apply F2R_gt_0. +rewrite <- 2!mag_F2R. +destruct (mag beta (F2R (Float beta m1 e1))) as (e1', H1). +simpl. +apply sym_eq. +apply mag_unique. +assert (H2 : (bpow (e1' - 1) <= F2R (Float beta m1 e1) < bpow e1')%R). +rewrite <- (Z.abs_eq m1), F2R_Zabs. +apply H1. +apply Rgt_not_eq. +apply Rlt_gt. +now apply F2R_gt_0. +now apply Zlt_le_weak. +clear H1. +rewrite <- F2R_Zabs, Z.abs_eq. +split. +apply Rlt_le. +apply Rle_lt_trans with (2 := H12). +apply H2. +apply Rlt_le_trans with (1 := H21). +now apply F2R_p1_le_bpow. +now apply Zlt_le_weak. +apply sym_not_eq. +now apply Zlt_not_eq. +apply sym_not_eq. +now apply Zlt_not_eq. +Qed. + +End Float_prop. diff --git a/flocq/Core/Generic_fmt.v b/flocq/Core/Generic_fmt.v new file mode 100644 index 00000000..cb37bd91 --- /dev/null +++ b/flocq/Core/Generic_fmt.v @@ -0,0 +1,2308 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2009-2018 Sylvie Boldo +#
# +Copyright (C) 2009-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +(** * What is a real number belonging to a format, and many properties. *) +Require Import Raux Defs Round_pred Float_prop. + +Section Generic. + +Variable beta : radix. + +Notation bpow e := (bpow beta e). + +Section Format. + +Variable fexp : Z -> Z. + +(** To be a good fexp *) + +Class Valid_exp := + valid_exp : + forall k : Z, + ( (fexp k < k)%Z -> (fexp (k + 1) <= k)%Z ) /\ + ( (k <= fexp k)%Z -> + (fexp (fexp k + 1) <= fexp k)%Z /\ + forall l : Z, (l <= fexp k)%Z -> fexp l = fexp k ). + +Context { valid_exp_ : Valid_exp }. + +Theorem valid_exp_large : + forall k l, + (fexp k < k)%Z -> (k <= l)%Z -> + (fexp l < l)%Z. +Proof. +intros k l Hk H. +apply Znot_ge_lt. +intros Hl. +apply Z.ge_le in Hl. +assert (H' := proj2 (proj2 (valid_exp l) Hl) k). +omega. +Qed. + +Theorem valid_exp_large' : + forall k l, + (fexp k < k)%Z -> (l <= k)%Z -> + (fexp l < k)%Z. +Proof. +intros k l Hk H. +apply Znot_ge_lt. +intros H'. +apply Z.ge_le in H'. +assert (Hl := Z.le_trans _ _ _ H H'). +apply valid_exp in Hl. +assert (H1 := proj2 Hl k H'). +omega. +Qed. + +Definition cexp x := + fexp (mag beta x). + +Definition canonical (f : float beta) := + Fexp f = cexp (F2R f). + +Definition scaled_mantissa x := + (x * bpow (- cexp x))%R. + +Definition generic_format (x : R) := + x = F2R (Float beta (Ztrunc (scaled_mantissa x)) (cexp x)). + +(** Basic facts *) +Theorem generic_format_0 : + generic_format 0. +Proof. +unfold generic_format, scaled_mantissa. +rewrite Rmult_0_l. +now rewrite Ztrunc_IZR, F2R_0. +Qed. + +Theorem cexp_opp : + forall x, + cexp (-x) = cexp x. +Proof. +intros x. +unfold cexp. +now rewrite mag_opp. +Qed. + +Theorem cexp_abs : + forall x, + cexp (Rabs x) = cexp x. +Proof. +intros x. +unfold cexp. +now rewrite mag_abs. +Qed. + +Theorem canonical_generic_format : + forall x, + generic_format x -> + exists f : float beta, + x = F2R f /\ canonical f. +Proof. +intros x Hx. +rewrite Hx. +eexists. +apply (conj eq_refl). +unfold canonical. +now rewrite <- Hx. +Qed. + +Theorem generic_format_bpow : + forall e, (fexp (e + 1) <= e)%Z -> + generic_format (bpow e). +Proof. +intros e H. +unfold generic_format, scaled_mantissa, cexp. +rewrite mag_bpow. +rewrite <- bpow_plus. +rewrite <- (IZR_Zpower beta (e + - fexp (e + 1))). +rewrite Ztrunc_IZR. +rewrite <- F2R_bpow. +rewrite F2R_change_exp with (1 := H). +now rewrite Zmult_1_l. +now apply Zle_minus_le_0. +Qed. + +Theorem generic_format_bpow' : + forall e, (fexp e <= e)%Z -> + generic_format (bpow e). +Proof. +intros e He. +apply generic_format_bpow. +destruct (Zle_lt_or_eq _ _ He). +now apply valid_exp_. +rewrite <- H. +apply valid_exp. +rewrite H. +apply Z.le_refl. +Qed. + +Theorem generic_format_F2R : + forall m e, + ( m <> 0 -> cexp (F2R (Float beta m e)) <= e )%Z -> + generic_format (F2R (Float beta m e)). +Proof. +intros m e. +destruct (Z.eq_dec m 0) as [Zm|Zm]. +intros _. +rewrite Zm, F2R_0. +apply generic_format_0. +unfold generic_format, scaled_mantissa. +set (e' := cexp (F2R (Float beta m e))). +intros He. +specialize (He Zm). +unfold F2R at 3. simpl. +rewrite F2R_change_exp with (1 := He). +apply F2R_eq. +rewrite Rmult_assoc, <- bpow_plus, <- IZR_Zpower, <- mult_IZR. +now rewrite Ztrunc_IZR. +now apply Zle_left. +Qed. + +Lemma generic_format_F2R' : + forall (x : R) (f : float beta), + F2R f = x -> + (x <> 0%R -> (cexp x <= Fexp f)%Z) -> + generic_format x. +Proof. +intros x f H1 H2. +rewrite <- H1; destruct f as (m,e). +apply generic_format_F2R. +simpl in *; intros H3. +rewrite H1; apply H2. +intros Y; apply H3. +apply eq_0_F2R with beta e. +now rewrite H1. +Qed. + +Theorem canonical_opp : + forall m e, + canonical (Float beta m e) -> + canonical (Float beta (-m) e). +Proof. +intros m e H. +unfold canonical. +now rewrite F2R_Zopp, cexp_opp. +Qed. + +Theorem canonical_abs : + forall m e, + canonical (Float beta m e) -> + canonical (Float beta (Z.abs m) e). +Proof. +intros m e H. +unfold canonical. +now rewrite F2R_Zabs, cexp_abs. +Qed. + +Theorem canonical_0 : + canonical (Float beta 0 (fexp (mag beta 0%R))). +Proof. +unfold canonical; simpl ; unfold cexp. +now rewrite F2R_0. +Qed. + +Theorem canonical_unique : + forall f1 f2, + canonical f1 -> + canonical f2 -> + F2R f1 = F2R f2 -> + f1 = f2. +Proof. +intros (m1, e1) (m2, e2). +unfold canonical. simpl. +intros H1 H2 H. +rewrite H in H1. +rewrite <- H2 in H1. clear H2. +rewrite H1 in H |- *. +apply (f_equal (fun m => Float beta m e2)). +apply eq_F2R with (1 := H). +Qed. + +Theorem scaled_mantissa_generic : + forall x, + generic_format x -> + scaled_mantissa x = IZR (Ztrunc (scaled_mantissa x)). +Proof. +intros x Hx. +unfold scaled_mantissa. +pattern x at 1 3 ; rewrite Hx. +unfold F2R. simpl. +rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r. +now rewrite Ztrunc_IZR. +Qed. + +Theorem scaled_mantissa_mult_bpow : + forall x, + (scaled_mantissa x * bpow (cexp x))%R = x. +Proof. +intros x. +unfold scaled_mantissa. +rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_l. +apply Rmult_1_r. +Qed. + +Theorem scaled_mantissa_0 : + scaled_mantissa 0 = 0%R. +Proof. +apply Rmult_0_l. +Qed. + +Theorem scaled_mantissa_opp : + forall x, + scaled_mantissa (-x) = (-scaled_mantissa x)%R. +Proof. +intros x. +unfold scaled_mantissa. +rewrite cexp_opp. +now rewrite Ropp_mult_distr_l_reverse. +Qed. + +Theorem scaled_mantissa_abs : + forall x, + scaled_mantissa (Rabs x) = Rabs (scaled_mantissa x). +Proof. +intros x. +unfold scaled_mantissa. +rewrite cexp_abs, Rabs_mult. +apply f_equal. +apply sym_eq. +apply Rabs_pos_eq. +apply bpow_ge_0. +Qed. + +Theorem generic_format_opp : + forall x, generic_format x -> generic_format (-x). +Proof. +intros x Hx. +unfold generic_format. +rewrite scaled_mantissa_opp, cexp_opp. +rewrite Ztrunc_opp. +rewrite F2R_Zopp. +now apply f_equal. +Qed. + +Theorem generic_format_abs : + forall x, generic_format x -> generic_format (Rabs x). +Proof. +intros x Hx. +unfold generic_format. +rewrite scaled_mantissa_abs, cexp_abs. +rewrite Ztrunc_abs. +rewrite F2R_Zabs. +now apply f_equal. +Qed. + +Theorem generic_format_abs_inv : + forall x, generic_format (Rabs x) -> generic_format x. +Proof. +intros x. +unfold generic_format, Rabs. +case Rcase_abs ; intros _. +rewrite scaled_mantissa_opp, cexp_opp, Ztrunc_opp. +intros H. +rewrite <- (Ropp_involutive x) at 1. +rewrite H, F2R_Zopp. +apply Ropp_involutive. +easy. +Qed. + +Theorem cexp_fexp : + forall x ex, + (bpow (ex - 1) <= Rabs x < bpow ex)%R -> + cexp x = fexp ex. +Proof. +intros x ex Hx. +unfold cexp. +now rewrite mag_unique with (1 := Hx). +Qed. + +Theorem cexp_fexp_pos : + forall x ex, + (bpow (ex - 1) <= x < bpow ex)%R -> + cexp x = fexp ex. +Proof. +intros x ex Hx. +apply cexp_fexp. +rewrite Rabs_pos_eq. +exact Hx. +apply Rle_trans with (2 := proj1 Hx). +apply bpow_ge_0. +Qed. + +(** Properties when the real number is "small" (kind of subnormal) *) +Theorem mantissa_small_pos : + forall x ex, + (bpow (ex - 1) <= x < bpow ex)%R -> + (ex <= fexp ex)%Z -> + (0 < x * bpow (- fexp ex) < 1)%R. +Proof. +intros x ex Hx He. +split. +apply Rmult_lt_0_compat. +apply Rlt_le_trans with (2 := proj1 Hx). +apply bpow_gt_0. +apply bpow_gt_0. +apply Rmult_lt_reg_r with (bpow (fexp ex)). +apply bpow_gt_0. +rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_l. +rewrite Rmult_1_r, Rmult_1_l. +apply Rlt_le_trans with (1 := proj2 Hx). +now apply bpow_le. +Qed. + +Theorem scaled_mantissa_lt_1 : + forall x ex, + (Rabs x < bpow ex)%R -> + (ex <= fexp ex)%Z -> + (Rabs (scaled_mantissa x) < 1)%R. +Proof. +intros x ex Ex He. +destruct (Req_dec x 0) as [Zx|Zx]. +rewrite Zx, scaled_mantissa_0, Rabs_R0. +now apply IZR_lt. +rewrite <- scaled_mantissa_abs. +unfold scaled_mantissa. +rewrite cexp_abs. +unfold cexp. +destruct (mag beta x) as (ex', Ex'). +simpl. +specialize (Ex' Zx). +apply (mantissa_small_pos _ _ Ex'). +assert (ex' <= fexp ex)%Z. +apply Z.le_trans with (2 := He). +apply bpow_lt_bpow with beta. +now apply Rle_lt_trans with (2 := Ex). +now rewrite (proj2 (proj2 (valid_exp _) He)). +Qed. + +Theorem scaled_mantissa_lt_bpow : + forall x, + (Rabs (scaled_mantissa x) < bpow (mag beta x - cexp x))%R. +Proof. +intros x. +destruct (Req_dec x 0) as [Zx|Zx]. +rewrite Zx, scaled_mantissa_0, Rabs_R0. +apply bpow_gt_0. +apply Rlt_le_trans with (1 := bpow_mag_gt beta _). +apply bpow_le. +unfold scaled_mantissa. +rewrite mag_mult_bpow with (1 := Zx). +apply Z.le_refl. +Qed. + +Theorem mag_generic_gt : + forall x, (x <> 0)%R -> + generic_format x -> + (cexp x < mag beta x)%Z. +Proof. +intros x Zx Gx. +apply Znot_ge_lt. +unfold cexp. +destruct (mag beta x) as (ex,Ex) ; simpl. +specialize (Ex Zx). +intros H. +apply Z.ge_le in H. +generalize (scaled_mantissa_lt_1 x ex (proj2 Ex) H). +contradict Zx. +rewrite Gx. +replace (Ztrunc (scaled_mantissa x)) with Z0. +apply F2R_0. +cut (Z.abs (Ztrunc (scaled_mantissa x)) < 1)%Z. +clear ; zify ; omega. +apply lt_IZR. +rewrite abs_IZR. +now rewrite <- scaled_mantissa_generic. +Qed. + +Lemma mantissa_DN_small_pos : + forall x ex, + (bpow (ex - 1) <= x < bpow ex)%R -> + (ex <= fexp ex)%Z -> + Zfloor (x * bpow (- fexp ex)) = Z0. +Proof. +intros x ex Hx He. +apply Zfloor_imp. simpl. +assert (H := mantissa_small_pos x ex Hx He). +split ; try apply Rlt_le ; apply H. +Qed. + +Lemma mantissa_UP_small_pos : + forall x ex, + (bpow (ex - 1) <= x < bpow ex)%R -> + (ex <= fexp ex)%Z -> + Zceil (x * bpow (- fexp ex)) = 1%Z. +Proof. +intros x ex Hx He. +apply Zceil_imp. simpl. +assert (H := mantissa_small_pos x ex Hx He). +split ; try apply Rlt_le ; apply H. +Qed. + +(** Generic facts about any format *) +Theorem generic_format_discrete : + forall x m, + let e := cexp x in + (F2R (Float beta m e) < x < F2R (Float beta (m + 1) e))%R -> + ~ generic_format x. +Proof. +intros x m e (Hx,Hx2) Hf. +apply Rlt_not_le with (1 := Hx2). clear Hx2. +rewrite Hf. +fold e. +apply F2R_le. +apply Zlt_le_succ. +apply lt_IZR. +rewrite <- scaled_mantissa_generic with (1 := Hf). +apply Rmult_lt_reg_r with (bpow e). +apply bpow_gt_0. +now rewrite scaled_mantissa_mult_bpow. +Qed. + +Theorem generic_format_canonical : + forall f, canonical f -> + generic_format (F2R f). +Proof. +intros (m, e) Hf. +unfold canonical in Hf. simpl in Hf. +unfold generic_format, scaled_mantissa. +rewrite <- Hf. +apply F2R_eq. +unfold F2R. simpl. +rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r. +now rewrite Ztrunc_IZR. +Qed. + +Theorem generic_format_ge_bpow : + forall emin, + ( forall e, (emin <= fexp e)%Z ) -> + forall x, + (0 < x)%R -> + generic_format x -> + (bpow emin <= x)%R. +Proof. +intros emin Emin x Hx Fx. +rewrite Fx. +apply Rle_trans with (bpow (fexp (mag beta x))). +now apply bpow_le. +apply bpow_le_F2R. +apply gt_0_F2R with beta (cexp x). +now rewrite <- Fx. +Qed. + +Theorem abs_lt_bpow_prec: + forall prec, + (forall e, (e - prec <= fexp e)%Z) -> + (* OK with FLX, FLT and FTZ *) + forall x, + (Rabs x < bpow (prec + cexp x))%R. +intros prec Hp x. +case (Req_dec x 0); intros Hxz. +rewrite Hxz, Rabs_R0. +apply bpow_gt_0. +unfold cexp. +destruct (mag beta x) as (ex,Ex) ; simpl. +specialize (Ex Hxz). +apply Rlt_le_trans with (1 := proj2 Ex). +apply bpow_le. +specialize (Hp ex). +omega. +Qed. + +Theorem generic_format_bpow_inv' : + forall e, + generic_format (bpow e) -> + (fexp (e + 1) <= e)%Z. +Proof. +intros e He. +apply Znot_gt_le. +contradict He. +unfold generic_format, scaled_mantissa, cexp, F2R. simpl. +rewrite mag_bpow, <- bpow_plus. +apply Rgt_not_eq. +rewrite Ztrunc_floor. +2: apply bpow_ge_0. +rewrite Zfloor_imp with (n := Z0). +rewrite Rmult_0_l. +apply bpow_gt_0. +split. +apply bpow_ge_0. +apply (bpow_lt _ _ 0). +clear -He ; omega. +Qed. + +Theorem generic_format_bpow_inv : + forall e, + generic_format (bpow e) -> + (fexp e <= e)%Z. +Proof. +intros e He. +apply generic_format_bpow_inv' in He. +assert (H := valid_exp_large' (e + 1) e). +omega. +Qed. + +Section Fcore_generic_round_pos. + +(** Rounding functions: R -> Z *) + +Variable rnd : R -> Z. + +Class Valid_rnd := { + Zrnd_le : forall x y, (x <= y)%R -> (rnd x <= rnd y)%Z ; + Zrnd_IZR : forall n, rnd (IZR n) = n +}. + +Context { valid_rnd : Valid_rnd }. + +Theorem Zrnd_DN_or_UP : + forall x, rnd x = Zfloor x \/ rnd x = Zceil x. +Proof. +intros x. +destruct (Zle_or_lt (rnd x) (Zfloor x)) as [Hx|Hx]. +left. +apply Zle_antisym with (1 := Hx). +rewrite <- (Zrnd_IZR (Zfloor x)). +apply Zrnd_le. +apply Zfloor_lb. +right. +apply Zle_antisym. +rewrite <- (Zrnd_IZR (Zceil x)). +apply Zrnd_le. +apply Zceil_ub. +rewrite Zceil_floor_neq. +omega. +intros H. +rewrite <- H in Hx. +rewrite Zfloor_IZR, Zrnd_IZR in Hx. +apply Z.lt_irrefl with (1 := Hx). +Qed. + +Theorem Zrnd_ZR_or_AW : + forall x, rnd x = Ztrunc x \/ rnd x = Zaway x. +Proof. +intros x. +unfold Ztrunc, Zaway. +destruct (Zrnd_DN_or_UP x) as [Hx|Hx] ; + case Rlt_bool. +now right. +now left. +now left. +now right. +Qed. + +(** the most useful one: R -> F *) +Definition round x := + F2R (Float beta (rnd (scaled_mantissa x)) (cexp x)). + +Theorem round_bounded_large_pos : + forall x ex, + (fexp ex < ex)%Z -> + (bpow (ex - 1) <= x < bpow ex)%R -> + (bpow (ex - 1) <= round x <= bpow ex)%R. +Proof. +intros x ex He Hx. +unfold round, scaled_mantissa. +rewrite (cexp_fexp_pos _ _ Hx). +unfold F2R. simpl. +destruct (Zrnd_DN_or_UP (x * bpow (- fexp ex))) as [Hr|Hr] ; rewrite Hr. +(* DN *) +split. +replace (ex - 1)%Z with (ex - 1 + - fexp ex + fexp ex)%Z by ring. +rewrite bpow_plus. +apply Rmult_le_compat_r. +apply bpow_ge_0. +assert (Hf: IZR (Zpower beta (ex - 1 - fexp ex)) = bpow (ex - 1 + - fexp ex)). +apply IZR_Zpower. +omega. +rewrite <- Hf. +apply IZR_le. +apply Zfloor_lub. +rewrite Hf. +rewrite bpow_plus. +apply Rmult_le_compat_r. +apply bpow_ge_0. +apply Hx. +apply Rle_trans with (2 := Rlt_le _ _ (proj2 Hx)). +apply Rmult_le_reg_r with (bpow (- fexp ex)). +apply bpow_gt_0. +rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r. +apply Zfloor_lb. +(* UP *) +split. +apply Rle_trans with (1 := proj1 Hx). +apply Rmult_le_reg_r with (bpow (- fexp ex)). +apply bpow_gt_0. +rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r. +apply Zceil_ub. +pattern ex at 3 ; replace ex with (ex - fexp ex + fexp ex)%Z by ring. +rewrite bpow_plus. +apply Rmult_le_compat_r. +apply bpow_ge_0. +assert (Hf: IZR (Zpower beta (ex - fexp ex)) = bpow (ex - fexp ex)). +apply IZR_Zpower. +omega. +rewrite <- Hf. +apply IZR_le. +apply Zceil_glb. +rewrite Hf. +unfold Zminus. +rewrite bpow_plus. +apply Rmult_le_compat_r. +apply bpow_ge_0. +apply Rlt_le. +apply Hx. +Qed. + +Theorem round_bounded_small_pos : + forall x ex, + (ex <= fexp ex)%Z -> + (bpow (ex - 1) <= x < bpow ex)%R -> + round x = 0%R \/ round x = bpow (fexp ex). +Proof. +intros x ex He Hx. +unfold round, scaled_mantissa. +rewrite (cexp_fexp_pos _ _ Hx). +unfold F2R. simpl. +destruct (Zrnd_DN_or_UP (x * bpow (-fexp ex))) as [Hr|Hr] ; rewrite Hr. +(* DN *) +left. +apply Rmult_eq_0_compat_r. +apply IZR_eq. +apply Zfloor_imp. +refine (let H := _ in conj (Rlt_le _ _ (proj1 H)) (proj2 H)). +now apply mantissa_small_pos. +(* UP *) +right. +pattern (bpow (fexp ex)) at 2 ; rewrite <- Rmult_1_l. +apply (f_equal (fun m => (m * bpow (fexp ex))%R)). +apply IZR_eq. +apply Zceil_imp. +refine (let H := _ in conj (proj1 H) (Rlt_le _ _ (proj2 H))). +now apply mantissa_small_pos. +Qed. + +Lemma round_le_pos : + forall x y, (0 < x)%R -> (x <= y)%R -> (round x <= round y)%R. +Proof. +intros x y Hx Hxy. +destruct (mag beta x) as [ex Hex]. +destruct (mag beta y) as [ey Hey]. +specialize (Hex (Rgt_not_eq _ _ Hx)). +specialize (Hey (Rgt_not_eq _ _ (Rlt_le_trans _ _ _ Hx Hxy))). +rewrite Rabs_pos_eq in Hex. +2: now apply Rlt_le. +rewrite Rabs_pos_eq in Hey. +2: apply Rle_trans with (2:=Hxy); now apply Rlt_le. +assert (He: (ex <= ey)%Z). + apply bpow_lt_bpow with beta. + apply Rle_lt_trans with (1 := proj1 Hex). + now apply Rle_lt_trans with y. +assert (Heq: fexp ex = fexp ey -> (round x <= round y)%R). + intros H. + unfold round, scaled_mantissa, cexp. + rewrite mag_unique_pos with (1 := Hex). + rewrite mag_unique_pos with (1 := Hey). + rewrite H. + apply F2R_le. + apply Zrnd_le. + apply Rmult_le_compat_r with (2 := Hxy). + apply bpow_ge_0. +destruct (Zle_or_lt ey (fexp ey)) as [Hy1|Hy1]. + apply Heq. + apply valid_exp with (1 := Hy1). + now apply Z.le_trans with ey. +destruct (Zle_lt_or_eq _ _ He) as [He'|He']. +2: now apply Heq, f_equal. +apply Rle_trans with (bpow (ey - 1)). +2: now apply round_bounded_large_pos. +destruct (Zle_or_lt ex (fexp ex)) as [Hx1|Hx1]. + destruct (round_bounded_small_pos _ _ Hx1 Hex) as [-> | ->]. + apply bpow_ge_0. + apply bpow_le. + apply valid_exp, proj2 in Hx1. + specialize (Hx1 ey). + omega. +apply Rle_trans with (bpow ex). +now apply round_bounded_large_pos. +apply bpow_le. +now apply Z.lt_le_pred. +Qed. + +Theorem round_generic : + forall x, + generic_format x -> + round x = x. +Proof. +intros x Hx. +unfold round. +rewrite scaled_mantissa_generic with (1 := Hx). +rewrite Zrnd_IZR. +now apply sym_eq. +Qed. + +Theorem round_0 : + round 0 = 0%R. +Proof. +unfold round, scaled_mantissa. +rewrite Rmult_0_l. +rewrite Zrnd_IZR. +apply F2R_0. +Qed. + +Theorem exp_small_round_0_pos : + forall x ex, + (bpow (ex - 1) <= x < bpow ex)%R -> + round x = 0%R -> (ex <= fexp ex)%Z . +Proof. +intros x ex H H1. +case (Zle_or_lt ex (fexp ex)); trivial; intros V. +contradict H1. +apply Rgt_not_eq. +apply Rlt_le_trans with (bpow (ex-1)). +apply bpow_gt_0. +apply (round_bounded_large_pos); assumption. +Qed. + +Lemma generic_format_round_pos : + forall x, + (0 < x)%R -> + generic_format (round x). +Proof. +intros x Hx0. +destruct (mag beta x) as (ex, Hex). +specialize (Hex (Rgt_not_eq _ _ Hx0)). +rewrite Rabs_pos_eq in Hex. 2: now apply Rlt_le. +destruct (Zle_or_lt ex (fexp ex)) as [He|He]. +(* small *) +destruct (round_bounded_small_pos _ _ He Hex) as [Hr|Hr] ; rewrite Hr. +apply generic_format_0. +apply generic_format_bpow. +now apply valid_exp. +(* large *) +generalize (round_bounded_large_pos _ _ He Hex). +intros (Hr1, Hr2). +destruct (Rle_or_lt (bpow ex) (round x)) as [Hr|Hr]. +rewrite <- (Rle_antisym _ _ Hr Hr2). +apply generic_format_bpow. +now apply valid_exp. +apply generic_format_F2R. +intros _. +rewrite (cexp_fexp_pos (F2R _) _ (conj Hr1 Hr)). +rewrite (cexp_fexp_pos _ _ Hex). +now apply Zeq_le. +Qed. + +End Fcore_generic_round_pos. + +Theorem round_ext : + forall rnd1 rnd2, + ( forall x, rnd1 x = rnd2 x ) -> + forall x, + round rnd1 x = round rnd2 x. +Proof. +intros rnd1 rnd2 Hext x. +unfold round. +now rewrite Hext. +Qed. + +Section Zround_opp. + +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. + +Definition Zrnd_opp x := Z.opp (rnd (-x)). + +Global Instance valid_rnd_opp : Valid_rnd Zrnd_opp. +Proof with auto with typeclass_instances. +split. +(* *) +intros x y Hxy. +unfold Zrnd_opp. +apply Zopp_le_cancel. +rewrite 2!Z.opp_involutive. +apply Zrnd_le... +now apply Ropp_le_contravar. +(* *) +intros n. +unfold Zrnd_opp. +rewrite <- opp_IZR, Zrnd_IZR... +apply Z.opp_involutive. +Qed. + +Theorem round_opp : + forall x, + round rnd (- x) = Ropp (round Zrnd_opp x). +Proof. +intros x. +unfold round. +rewrite <- F2R_Zopp, cexp_opp, scaled_mantissa_opp. +apply F2R_eq. +apply sym_eq. +exact (Z.opp_involutive _). +Qed. + +End Zround_opp. + +(** IEEE-754 roundings: up, down and to zero *) + +Global Instance valid_rnd_DN : Valid_rnd Zfloor. +Proof. +split. +apply Zfloor_le. +apply Zfloor_IZR. +Qed. + +Global Instance valid_rnd_UP : Valid_rnd Zceil. +Proof. +split. +apply Zceil_le. +apply Zceil_IZR. +Qed. + +Global Instance valid_rnd_ZR : Valid_rnd Ztrunc. +Proof. +split. +apply Ztrunc_le. +apply Ztrunc_IZR. +Qed. + +Global Instance valid_rnd_AW : Valid_rnd Zaway. +Proof. +split. +apply Zaway_le. +apply Zaway_IZR. +Qed. + +Section monotone. + +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. + +Theorem round_DN_or_UP : + forall x, + round rnd x = round Zfloor x \/ round rnd x = round Zceil x. +Proof. +intros x. +unfold round. +destruct (Zrnd_DN_or_UP rnd (scaled_mantissa x)) as [Hx|Hx]. +left. now rewrite Hx. +right. now rewrite Hx. +Qed. + +Theorem round_ZR_or_AW : + forall x, + round rnd x = round Ztrunc x \/ round rnd x = round Zaway x. +Proof. +intros x. +unfold round. +destruct (Zrnd_ZR_or_AW rnd (scaled_mantissa x)) as [Hx|Hx]. +left. now rewrite Hx. +right. now rewrite Hx. +Qed. + +Theorem round_le : + forall x y, (x <= y)%R -> (round rnd x <= round rnd y)%R. +Proof with auto with typeclass_instances. +intros x y Hxy. +destruct (total_order_T x 0) as [[Hx|Hx]|Hx]. +3: now apply round_le_pos. +(* x < 0 *) +unfold round. +destruct (Rlt_or_le y 0) as [Hy|Hy]. +(* . y < 0 *) +rewrite <- (Ropp_involutive x), <- (Ropp_involutive y). +rewrite (scaled_mantissa_opp (-x)), (scaled_mantissa_opp (-y)). +rewrite (cexp_opp (-x)), (cexp_opp (-y)). +apply Ropp_le_cancel. +rewrite <- 2!F2R_Zopp. +apply (round_le_pos (Zrnd_opp rnd) (-y) (-x)). +rewrite <- Ropp_0. +now apply Ropp_lt_contravar. +now apply Ropp_le_contravar. +(* . 0 <= y *) +apply Rle_trans with 0%R. +apply F2R_le_0. simpl. +rewrite <- (Zrnd_IZR rnd 0). +apply Zrnd_le... +simpl. +rewrite <- (Rmult_0_l (bpow (- fexp (mag beta x)))). +apply Rmult_le_compat_r. +apply bpow_ge_0. +now apply Rlt_le. +apply F2R_ge_0. simpl. +rewrite <- (Zrnd_IZR rnd 0). +apply Zrnd_le... +apply Rmult_le_pos. +exact Hy. +apply bpow_ge_0. +(* x = 0 *) +rewrite Hx. +rewrite round_0... +apply F2R_ge_0. +simpl. +rewrite <- (Zrnd_IZR rnd 0). +apply Zrnd_le... +apply Rmult_le_pos. +now rewrite <- Hx. +apply bpow_ge_0. +Qed. + +Theorem round_ge_generic : + forall x y, generic_format x -> (x <= y)%R -> (x <= round rnd y)%R. +Proof. +intros x y Hx Hxy. +rewrite <- (round_generic rnd x Hx). +now apply round_le. +Qed. + +Theorem round_le_generic : + forall x y, generic_format y -> (x <= y)%R -> (round rnd x <= y)%R. +Proof. +intros x y Hy Hxy. +rewrite <- (round_generic rnd y Hy). +now apply round_le. +Qed. + +End monotone. + +Theorem round_abs_abs : + forall P : R -> R -> Prop, + ( forall rnd (Hr : Valid_rnd rnd) x, (0 <= x)%R -> P x (round rnd x) ) -> + forall rnd {Hr : Valid_rnd rnd} x, P (Rabs x) (Rabs (round rnd x)). +Proof with auto with typeclass_instances. +intros P HP rnd Hr x. +destruct (Rle_or_lt 0 x) as [Hx|Hx]. +(* . *) +rewrite 2!Rabs_pos_eq. +now apply HP. +rewrite <- (round_0 rnd). +now apply round_le. +exact Hx. +(* . *) +rewrite (Rabs_left _ Hx). +rewrite Rabs_left1. +pattern x at 2 ; rewrite <- Ropp_involutive. +rewrite round_opp. +rewrite Ropp_involutive. +apply HP... +rewrite <- Ropp_0. +apply Ropp_le_contravar. +now apply Rlt_le. +rewrite <- (round_0 rnd). +apply round_le... +now apply Rlt_le. +Qed. + +Theorem round_bounded_large : + forall rnd {Hr : Valid_rnd rnd} x ex, + (fexp ex < ex)%Z -> + (bpow (ex - 1) <= Rabs x < bpow ex)%R -> + (bpow (ex - 1) <= Rabs (round rnd x) <= bpow ex)%R. +Proof with auto with typeclass_instances. +intros rnd Hr x ex He. +apply round_abs_abs... +clear rnd Hr x. +intros rnd' Hr x _. +apply round_bounded_large_pos... +Qed. + +Theorem exp_small_round_0 : + forall rnd {Hr : Valid_rnd rnd} x ex, + (bpow (ex - 1) <= Rabs x < bpow ex)%R -> + round rnd x = 0%R -> (ex <= fexp ex)%Z . +Proof. +intros rnd Hr x ex H1 H2. +generalize Rabs_R0. +rewrite <- H2 at 1. +apply (round_abs_abs (fun t rt => forall (ex : Z), +(bpow (ex - 1) <= t < bpow ex)%R -> +rt = 0%R -> (ex <= fexp ex)%Z)); trivial. +clear; intros rnd Hr x Hx. +now apply exp_small_round_0_pos. +Qed. + + + + +Section monotone_abs. + +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. + +Theorem abs_round_ge_generic : + forall x y, generic_format x -> (x <= Rabs y)%R -> (x <= Rabs (round rnd y))%R. +Proof with auto with typeclass_instances. +intros x y. +apply round_abs_abs... +clear rnd valid_rnd y. +intros rnd' Hrnd y Hy. +apply round_ge_generic... +Qed. + +Theorem abs_round_le_generic : + forall x y, generic_format y -> (Rabs x <= y)%R -> (Rabs (round rnd x) <= y)%R. +Proof with auto with typeclass_instances. +intros x y. +apply round_abs_abs... +clear rnd valid_rnd x. +intros rnd' Hrnd x Hx. +apply round_le_generic... +Qed. + +End monotone_abs. + +Theorem round_DN_opp : + forall x, + round Zfloor (-x) = (- round Zceil x)%R. +Proof. +intros x. +unfold round. +rewrite scaled_mantissa_opp. +rewrite <- F2R_Zopp. +unfold Zceil. +rewrite Z.opp_involutive. +now rewrite cexp_opp. +Qed. + +Theorem round_UP_opp : + forall x, + round Zceil (-x) = (- round Zfloor x)%R. +Proof. +intros x. +unfold round. +rewrite scaled_mantissa_opp. +rewrite <- F2R_Zopp. +unfold Zceil. +rewrite Ropp_involutive. +now rewrite cexp_opp. +Qed. + +Theorem round_ZR_opp : + forall x, + round Ztrunc (- x) = Ropp (round Ztrunc x). +Proof. +intros x. +unfold round. +rewrite scaled_mantissa_opp, cexp_opp, Ztrunc_opp. +apply F2R_Zopp. +Qed. + +Theorem round_ZR_abs : + forall x, + round Ztrunc (Rabs x) = Rabs (round Ztrunc x). +Proof with auto with typeclass_instances. +intros x. +apply sym_eq. +unfold Rabs at 2. +destruct (Rcase_abs x) as [Hx|Hx]. +rewrite round_ZR_opp. +apply Rabs_left1. +rewrite <- (round_0 Ztrunc). +apply round_le... +now apply Rlt_le. +apply Rabs_pos_eq. +rewrite <- (round_0 Ztrunc). +apply round_le... +now apply Rge_le. +Qed. + +Theorem round_AW_opp : + forall x, + round Zaway (- x) = Ropp (round Zaway x). +Proof. +intros x. +unfold round. +rewrite scaled_mantissa_opp, cexp_opp, Zaway_opp. +apply F2R_Zopp. +Qed. + +Theorem round_AW_abs : + forall x, + round Zaway (Rabs x) = Rabs (round Zaway x). +Proof with auto with typeclass_instances. +intros x. +apply sym_eq. +unfold Rabs at 2. +destruct (Rcase_abs x) as [Hx|Hx]. +rewrite round_AW_opp. +apply Rabs_left1. +rewrite <- (round_0 Zaway). +apply round_le... +now apply Rlt_le. +apply Rabs_pos_eq. +rewrite <- (round_0 Zaway). +apply round_le... +now apply Rge_le. +Qed. + +Theorem round_ZR_DN : + forall x, + (0 <= x)%R -> + round Ztrunc x = round Zfloor x. +Proof. +intros x Hx. +unfold round, Ztrunc. +case Rlt_bool_spec. +intros H. +elim Rlt_not_le with (1 := H). +rewrite <- (Rmult_0_l (bpow (- cexp x))). +apply Rmult_le_compat_r with (2 := Hx). +apply bpow_ge_0. +easy. +Qed. + +Theorem round_ZR_UP : + forall x, + (x <= 0)%R -> + round Ztrunc x = round Zceil x. +Proof. +intros x Hx. +unfold round, Ztrunc. +case Rlt_bool_spec. +easy. +intros [H|H]. +elim Rlt_not_le with (1 := H). +rewrite <- (Rmult_0_l (bpow (- cexp x))). +apply Rmult_le_compat_r with (2 := Hx). +apply bpow_ge_0. +rewrite <- H. +now rewrite Zfloor_IZR, Zceil_IZR. +Qed. + +Theorem round_AW_UP : + forall x, + (0 <= x)%R -> + round Zaway x = round Zceil x. +Proof. +intros x Hx. +unfold round, Zaway. +case Rlt_bool_spec. +intros H. +elim Rlt_not_le with (1 := H). +rewrite <- (Rmult_0_l (bpow (- cexp x))). +apply Rmult_le_compat_r with (2 := Hx). +apply bpow_ge_0. +easy. +Qed. + +Theorem round_AW_DN : + forall x, + (x <= 0)%R -> + round Zaway x = round Zfloor x. +Proof. +intros x Hx. +unfold round, Zaway. +case Rlt_bool_spec. +easy. +intros [H|H]. +elim Rlt_not_le with (1 := H). +rewrite <- (Rmult_0_l (bpow (- cexp x))). +apply Rmult_le_compat_r with (2 := Hx). +apply bpow_ge_0. +rewrite <- H. +now rewrite Zfloor_IZR, Zceil_IZR. +Qed. + +Theorem generic_format_round : + forall rnd { Hr : Valid_rnd rnd } x, + generic_format (round rnd x). +Proof with auto with typeclass_instances. +intros rnd Zrnd x. +destruct (total_order_T x 0) as [[Hx|Hx]|Hx]. +rewrite <- (Ropp_involutive x). +destruct (round_DN_or_UP rnd (- - x)) as [Hr|Hr] ; rewrite Hr. +rewrite round_DN_opp. +apply generic_format_opp. +apply generic_format_round_pos... +now apply Ropp_0_gt_lt_contravar. +rewrite round_UP_opp. +apply generic_format_opp. +apply generic_format_round_pos... +now apply Ropp_0_gt_lt_contravar. +rewrite Hx. +rewrite round_0... +apply generic_format_0. +now apply generic_format_round_pos. +Qed. + +Theorem round_DN_pt : + forall x, + Rnd_DN_pt generic_format x (round Zfloor x). +Proof with auto with typeclass_instances. +intros x. +split. +apply generic_format_round... +split. +pattern x at 2 ; rewrite <- scaled_mantissa_mult_bpow. +unfold round, F2R. simpl. +apply Rmult_le_compat_r. +apply bpow_ge_0. +apply Zfloor_lb. +intros g Hg Hgx. +apply round_ge_generic... +Qed. + +Theorem generic_format_satisfies_any : + satisfies_any generic_format. +Proof. +split. +(* symmetric set *) +exact generic_format_0. +exact generic_format_opp. +(* round down *) +intros x. +eexists. +apply round_DN_pt. +Qed. + +Theorem round_UP_pt : + forall x, + Rnd_UP_pt generic_format x (round Zceil x). +Proof. +intros x. +rewrite <- (Ropp_involutive x). +rewrite round_UP_opp. +apply Rnd_UP_pt_opp. +apply generic_format_opp. +apply round_DN_pt. +Qed. + +Theorem round_ZR_pt : + forall x, + Rnd_ZR_pt generic_format x (round Ztrunc x). +Proof. +intros x. +split ; intros Hx. +rewrite round_ZR_DN with (1 := Hx). +apply round_DN_pt. +rewrite round_ZR_UP with (1 := Hx). +apply round_UP_pt. +Qed. + +Lemma round_DN_small_pos : + forall x ex, + (bpow (ex - 1) <= x < bpow ex)%R -> + (ex <= fexp ex)%Z -> + round Zfloor x = 0%R. +Proof. +intros x ex Hx He. +rewrite <- (F2R_0 beta (cexp x)). +rewrite <- mantissa_DN_small_pos with (1 := Hx) (2 := He). +now rewrite <- cexp_fexp_pos with (1 := Hx). +Qed. + + +Theorem round_DN_UP_lt : + forall x, ~ generic_format x -> + (round Zfloor x < x < round Zceil x)%R. +Proof with auto with typeclass_instances. +intros x Fx. +assert (Hx:(round Zfloor x <= x <= round Zceil x)%R). +split. +apply round_DN_pt. +apply round_UP_pt. +split. + destruct Hx as [Hx _]. + apply Rnot_le_lt; intro Hle. + assert (x = round Zfloor x) by now apply Rle_antisym. + rewrite H in Fx. + contradict Fx. + apply generic_format_round... +destruct Hx as [_ Hx]. +apply Rnot_le_lt; intro Hle. +assert (x = round Zceil x) by now apply Rle_antisym. +rewrite H in Fx. +contradict Fx. +apply generic_format_round... +Qed. + +Lemma round_UP_small_pos : + forall x ex, + (bpow (ex - 1) <= x < bpow ex)%R -> + (ex <= fexp ex)%Z -> + round Zceil x = (bpow (fexp ex)). +Proof. +intros x ex Hx He. +rewrite <- F2R_bpow. +rewrite <- mantissa_UP_small_pos with (1 := Hx) (2 := He). +now rewrite <- cexp_fexp_pos with (1 := Hx). +Qed. + +Theorem generic_format_EM : + forall x, + generic_format x \/ ~generic_format x. +Proof with auto with typeclass_instances. +intros x. +destruct (Req_dec (round Zfloor x) x) as [Hx|Hx]. +left. +rewrite <- Hx. +apply generic_format_round... +right. +intros H. +apply Hx. +apply round_generic... +Qed. + +Section round_large. + +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. + +Lemma round_large_pos_ge_bpow : + forall x e, + (0 < round rnd x)%R -> + (bpow e <= x)%R -> + (bpow e <= round rnd x)%R. +Proof. +intros x e Hd Hex. +destruct (mag beta x) as (ex, He). +assert (Hx: (0 < x)%R). +apply Rlt_le_trans with (2 := Hex). +apply bpow_gt_0. +specialize (He (Rgt_not_eq _ _ Hx)). +rewrite Rabs_pos_eq in He. 2: now apply Rlt_le. +apply Rle_trans with (bpow (ex - 1)). +apply bpow_le. +cut (e < ex)%Z. omega. +apply (lt_bpow beta). +now apply Rle_lt_trans with (2 := proj2 He). +destruct (Zle_or_lt ex (fexp ex)). +destruct (round_bounded_small_pos rnd x ex H He) as [Hr|Hr]. +rewrite Hr in Hd. +elim Rlt_irrefl with (1 := Hd). +rewrite Hr. +apply bpow_le. +omega. +apply (round_bounded_large_pos rnd x ex H He). +Qed. + +End round_large. + +Theorem mag_round_ZR : + forall x, + (round Ztrunc x <> 0)%R -> + (mag beta (round Ztrunc x) = mag beta x :> Z). +Proof with auto with typeclass_instances. +intros x Zr. +destruct (Req_dec x 0) as [Zx|Zx]. +rewrite Zx, round_0... +apply mag_unique. +destruct (mag beta x) as (ex, Ex) ; simpl. +specialize (Ex Zx). +rewrite <- round_ZR_abs. +split. +apply round_large_pos_ge_bpow... +rewrite round_ZR_abs. +now apply Rabs_pos_lt. +apply Ex. +apply Rle_lt_trans with (2 := proj2 Ex). +rewrite round_ZR_DN. +apply round_DN_pt. +apply Rabs_pos. +Qed. + +Theorem mag_round : + forall rnd {Hrnd : Valid_rnd rnd} x, + (round rnd x <> 0)%R -> + (mag beta (round rnd x) = mag beta x :> Z) \/ + Rabs (round rnd x) = bpow (Z.max (mag beta x) (fexp (mag beta x))). +Proof with auto with typeclass_instances. +intros rnd Hrnd x. +destruct (round_ZR_or_AW rnd x) as [Hr|Hr] ; rewrite Hr ; clear Hr rnd Hrnd. +left. +now apply mag_round_ZR. +intros Zr. +destruct (Req_dec x 0) as [Zx|Zx]. +rewrite Zx, round_0... +destruct (mag beta x) as (ex, Ex) ; simpl. +specialize (Ex Zx). +rewrite <- mag_abs. +rewrite <- round_AW_abs. +destruct (Zle_or_lt ex (fexp ex)) as [He|He]. +right. +rewrite Z.max_r with (1 := He). +rewrite round_AW_UP with (1 := Rabs_pos _). +now apply round_UP_small_pos. +destruct (round_bounded_large_pos Zaway _ ex He Ex) as (H1,[H2|H2]). +left. +apply mag_unique. +rewrite <- round_AW_abs, Rabs_Rabsolu. +now split. +right. +now rewrite Z.max_l with (1 := Zlt_le_weak _ _ He). +Qed. + +Theorem mag_DN : + forall x, + (0 < round Zfloor x)%R -> + (mag beta (round Zfloor x) = mag beta x :> Z). +Proof. +intros x Hd. +assert (0 < x)%R. +apply Rlt_le_trans with (1 := Hd). +apply round_DN_pt. +revert Hd. +rewrite <- round_ZR_DN. +intros Hd. +apply mag_round_ZR. +now apply Rgt_not_eq. +now apply Rlt_le. +Qed. + +Theorem cexp_DN : + forall x, + (0 < round Zfloor x)%R -> + cexp (round Zfloor x) = cexp x. +Proof. +intros x Hd. +apply (f_equal fexp). +now apply mag_DN. +Qed. + +Theorem scaled_mantissa_DN : + forall x, + (0 < round Zfloor x)%R -> + scaled_mantissa (round Zfloor x) = IZR (Zfloor (scaled_mantissa x)). +Proof. +intros x Hd. +unfold scaled_mantissa. +rewrite cexp_DN with (1 := Hd). +unfold round, F2R. simpl. +now rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r. +Qed. + +Theorem generic_N_pt_DN_or_UP : + forall x f, + Rnd_N_pt generic_format x f -> + f = round Zfloor x \/ f = round Zceil x. +Proof. +intros x f Hxf. +destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf). +left. +apply Rnd_DN_pt_unique with (1 := H). +apply round_DN_pt. +right. +apply Rnd_UP_pt_unique with (1 := H). +apply round_UP_pt. +Qed. + +Section not_FTZ. + +Class Exp_not_FTZ := + exp_not_FTZ : forall e, (fexp (fexp e + 1) <= fexp e)%Z. + +Context { exp_not_FTZ_ : Exp_not_FTZ }. + +Theorem subnormal_exponent : + forall e x, + (e <= fexp e)%Z -> + generic_format x -> + x = F2R (Float beta (Ztrunc (x * bpow (- fexp e))) (fexp e)). +Proof. +intros e x He Hx. +pattern x at 2 ; rewrite Hx. +unfold F2R at 2. simpl. +rewrite Rmult_assoc, <- bpow_plus. +assert (H: IZR (Zpower beta (cexp x + - fexp e)) = bpow (cexp x + - fexp e)). +apply IZR_Zpower. +unfold cexp. +set (ex := mag beta x). +generalize (exp_not_FTZ ex). +generalize (proj2 (proj2 (valid_exp _) He) (fexp ex + 1)%Z). +omega. +rewrite <- H. +rewrite <- mult_IZR, Ztrunc_IZR. +unfold F2R. simpl. +rewrite mult_IZR. +rewrite H. +rewrite Rmult_assoc, <- bpow_plus. +now ring_simplify (cexp x + - fexp e + fexp e)%Z. +Qed. + +End not_FTZ. + +Section monotone_exp. + +Class Monotone_exp := + monotone_exp : forall ex ey, (ex <= ey)%Z -> (fexp ex <= fexp ey)%Z. + +Context { monotone_exp_ : Monotone_exp }. + +Global Instance monotone_exp_not_FTZ : Exp_not_FTZ. +Proof. +intros e. +destruct (Z_lt_le_dec (fexp e) e) as [He|He]. +apply monotone_exp. +now apply Zlt_le_succ. +now apply valid_exp. +Qed. + +Lemma cexp_le_bpow : + forall (x : R) (e : Z), + x <> 0%R -> + (Rabs x < bpow e)%R -> + (cexp x <= fexp e)%Z. +Proof. +intros x e Zx Hx. +apply monotone_exp. +now apply mag_le_bpow. +Qed. + +Lemma cexp_ge_bpow : + forall (x : R) (e : Z), + (bpow (e - 1) <= Rabs x)%R -> + (fexp e <= cexp x)%Z. +Proof. +intros x e Hx. +apply monotone_exp. +rewrite (Zsucc_pred e). +apply Zlt_le_succ. +now apply mag_gt_bpow. +Qed. + +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. + +Theorem mag_round_ge : + forall x, + round rnd x <> 0%R -> + (mag beta x <= mag beta (round rnd x))%Z. +Proof with auto with typeclass_instances. +intros x. +destruct (round_ZR_or_AW rnd x) as [H|H] ; rewrite H ; clear H ; intros Zr. +rewrite mag_round_ZR with (1 := Zr). +apply Z.le_refl. +apply mag_le_abs. +contradict Zr. +rewrite Zr. +apply round_0... +rewrite <- round_AW_abs. +rewrite round_AW_UP. +apply round_UP_pt. +apply Rabs_pos. +Qed. + +Theorem cexp_round_ge : + forall x, + round rnd x <> 0%R -> + (cexp x <= cexp (round rnd x))%Z. +Proof with auto with typeclass_instances. +intros x Zr. +unfold cexp. +apply monotone_exp. +now apply mag_round_ge. +Qed. + +End monotone_exp. + +Section Znearest. + +(** Roundings to nearest: when in the middle, use the choice function *) +Variable choice : Z -> bool. + +Definition Znearest x := + match Rcompare (x - IZR (Zfloor x)) (/2) with + | Lt => Zfloor x + | Eq => if choice (Zfloor x) then Zceil x else Zfloor x + | Gt => Zceil x + end. + +Theorem Znearest_DN_or_UP : + forall x, + Znearest x = Zfloor x \/ Znearest x = Zceil x. +Proof. +intros x. +unfold Znearest. +case Rcompare_spec ; intros _. +now left. +case choice. +now right. +now left. +now right. +Qed. + +Theorem Znearest_ge_floor : + forall x, + (Zfloor x <= Znearest x)%Z. +Proof. +intros x. +destruct (Znearest_DN_or_UP x) as [Hx|Hx] ; rewrite Hx. +apply Z.le_refl. +apply le_IZR. +apply Rle_trans with x. +apply Zfloor_lb. +apply Zceil_ub. +Qed. + +Theorem Znearest_le_ceil : + forall x, + (Znearest x <= Zceil x)%Z. +Proof. +intros x. +destruct (Znearest_DN_or_UP x) as [Hx|Hx] ; rewrite Hx. +apply le_IZR. +apply Rle_trans with x. +apply Zfloor_lb. +apply Zceil_ub. +apply Z.le_refl. +Qed. + +Global Instance valid_rnd_N : Valid_rnd Znearest. +Proof. +split. +(* *) +intros x y Hxy. +destruct (Rle_or_lt (IZR (Zceil x)) y) as [H|H]. +apply Z.le_trans with (1 := Znearest_le_ceil x). +apply Z.le_trans with (2 := Znearest_ge_floor y). +now apply Zfloor_lub. +(* . *) +assert (Hf: Zfloor y = Zfloor x). +apply Zfloor_imp. +split. +apply Rle_trans with (2 := Zfloor_lb y). +apply IZR_le. +now apply Zfloor_le. +apply Rlt_le_trans with (1 := H). +apply IZR_le. +apply Zceil_glb. +apply Rlt_le. +rewrite plus_IZR. +apply Zfloor_ub. +(* . *) +unfold Znearest at 1. +case Rcompare_spec ; intro Hx. +(* .. *) +rewrite <- Hf. +apply Znearest_ge_floor. +(* .. *) +unfold Znearest. +rewrite Hf. +case Rcompare_spec ; intro Hy. +elim Rlt_not_le with (1 := Hy). +rewrite <- Hx. +now apply Rplus_le_compat_r. +replace y with x. +apply Z.le_refl. +apply Rplus_eq_reg_l with (- IZR (Zfloor x))%R. +rewrite 2!(Rplus_comm (- (IZR (Zfloor x)))). +change (x - IZR (Zfloor x) = y - IZR (Zfloor x))%R. +now rewrite Hy. +apply Z.le_trans with (Zceil x). +case choice. +apply Z.le_refl. +apply le_IZR. +apply Rle_trans with x. +apply Zfloor_lb. +apply Zceil_ub. +now apply Zceil_le. +(* .. *) +unfold Znearest. +rewrite Hf. +rewrite Rcompare_Gt. +now apply Zceil_le. +apply Rlt_le_trans with (1 := Hx). +now apply Rplus_le_compat_r. +(* *) +intros n. +unfold Znearest. +rewrite Zfloor_IZR. +rewrite Rcompare_Lt. +easy. +unfold Rminus. +rewrite Rplus_opp_r. +apply Rinv_0_lt_compat. +now apply IZR_lt. +Qed. + +Theorem Znearest_N_strict : + forall x, + (x - IZR (Zfloor x) <> /2)%R -> + (Rabs (x - IZR (Znearest x)) < /2)%R. +Proof. +intros x Hx. +unfold Znearest. +case Rcompare_spec ; intros H. +rewrite Rabs_pos_eq. +exact H. +apply Rle_0_minus. +apply Zfloor_lb. +now elim Hx. +rewrite Rabs_left1. +rewrite Ropp_minus_distr. +rewrite Zceil_floor_neq. +rewrite plus_IZR. +apply Ropp_lt_cancel. +apply Rplus_lt_reg_l with 1%R. +replace (1 + -/2)%R with (/2)%R by field. +now replace (1 + - (IZR (Zfloor x) + 1 - x))%R with (x - IZR (Zfloor x))%R by ring. +apply Rlt_not_eq. +apply Rplus_lt_reg_l with (- IZR (Zfloor x))%R. +apply Rlt_trans with (/2)%R. +rewrite Rplus_opp_l. +apply Rinv_0_lt_compat. +now apply IZR_lt. +now rewrite <- (Rplus_comm x). +apply Rle_minus. +apply Zceil_ub. +Qed. + +Theorem Znearest_half : + forall x, + (Rabs (x - IZR (Znearest x)) <= /2)%R. +Proof. +intros x. +destruct (Req_dec (x - IZR (Zfloor x)) (/2)) as [Hx|Hx]. +assert (K: (Rabs (/2) <= /2)%R). +apply Req_le. +apply Rabs_pos_eq. +apply Rlt_le. +apply Rinv_0_lt_compat. +now apply IZR_lt. +destruct (Znearest_DN_or_UP x) as [H|H] ; rewrite H ; clear H. +now rewrite Hx. +rewrite Zceil_floor_neq. +rewrite plus_IZR. +replace (x - (IZR (Zfloor x) + 1))%R with (x - IZR (Zfloor x) - 1)%R by ring. +rewrite Hx. +rewrite Rabs_minus_sym. +now replace (1 - /2)%R with (/2)%R by field. +apply Rlt_not_eq. +apply Rplus_lt_reg_l with (- IZR (Zfloor x))%R. +rewrite Rplus_opp_l, Rplus_comm. +fold (x - IZR (Zfloor x))%R. +rewrite Hx. +apply Rinv_0_lt_compat. +now apply IZR_lt. +apply Rlt_le. +now apply Znearest_N_strict. +Qed. + +Theorem Znearest_imp : + forall x n, + (Rabs (x - IZR n) < /2)%R -> + Znearest x = n. +Proof. +intros x n Hd. +cut (Z.abs (Znearest x - n) < 1)%Z. +clear ; zify ; omega. +apply lt_IZR. +rewrite abs_IZR, minus_IZR. +replace (IZR (Znearest x) - IZR n)%R with (- (x - IZR (Znearest x)) + (x - IZR n))%R by ring. +apply Rle_lt_trans with (1 := Rabs_triang _ _). +simpl. +replace 1%R with (/2 + /2)%R by field. +apply Rplus_le_lt_compat with (2 := Hd). +rewrite Rabs_Ropp. +apply Znearest_half. +Qed. + +Theorem round_N_pt : + forall x, + Rnd_N_pt generic_format x (round Znearest x). +Proof. +intros x. +set (d := round Zfloor x). +set (u := round Zceil x). +set (mx := scaled_mantissa x). +set (bx := bpow (cexp x)). +(* . *) +assert (H: (Rabs (round Znearest x - x) <= Rmin (x - d) (u - x))%R). +pattern x at -1 ; rewrite <- scaled_mantissa_mult_bpow. +unfold d, u, round, F2R. simpl. +fold mx bx. +rewrite <- 3!Rmult_minus_distr_r. +rewrite Rabs_mult, (Rabs_pos_eq bx). 2: apply bpow_ge_0. +rewrite <- Rmult_min_distr_r. 2: apply bpow_ge_0. +apply Rmult_le_compat_r. +apply bpow_ge_0. +unfold Znearest. +destruct (Req_dec (IZR (Zfloor mx)) mx) as [Hm|Hm]. +(* .. *) +rewrite Hm. +unfold Rminus at 2. +rewrite Rplus_opp_r. +rewrite Rcompare_Lt. +rewrite Hm. +unfold Rminus at -3. +rewrite Rplus_opp_r. +rewrite Rabs_R0. +unfold Rmin. +destruct (Rle_dec 0 (IZR (Zceil mx) - mx)) as [H|H]. +apply Rle_refl. +apply Rle_0_minus. +apply Zceil_ub. +apply Rinv_0_lt_compat. +now apply IZR_lt. +(* .. *) +rewrite Rcompare_floor_ceil_middle with (1 := Hm). +rewrite Rmin_compare. +assert (H: (Rabs (mx - IZR (Zfloor mx)) <= mx - IZR (Zfloor mx))%R). +rewrite Rabs_pos_eq. +apply Rle_refl. +apply Rle_0_minus. +apply Zfloor_lb. +case Rcompare_spec ; intros Hm'. +now rewrite Rabs_minus_sym. +case choice. +rewrite <- Hm'. +exact H. +now rewrite Rabs_minus_sym. +rewrite Rabs_pos_eq. +apply Rle_refl. +apply Rle_0_minus. +apply Zceil_ub. +(* . *) +apply Rnd_N_pt_DN_UP with d u. +apply generic_format_round. +auto with typeclass_instances. +now apply round_DN_pt. +now apply round_UP_pt. +apply Rle_trans with (1 := H). +apply Rmin_l. +apply Rle_trans with (1 := H). +apply Rmin_r. +Qed. + +Theorem round_N_middle : + forall x, + (x - round Zfloor x = round Zceil x - x)%R -> + round Znearest x = if choice (Zfloor (scaled_mantissa x)) then round Zceil x else round Zfloor x. +Proof. +intros x. +pattern x at 1 4 ; rewrite <- scaled_mantissa_mult_bpow. +unfold round, Znearest, F2R. simpl. +destruct (Req_dec (IZR (Zfloor (scaled_mantissa x))) (scaled_mantissa x)) as [Fx|Fx]. +(* *) +intros _. +rewrite <- Fx. +rewrite Zceil_IZR, Zfloor_IZR. +set (m := Zfloor (scaled_mantissa x)). +now case (Rcompare (IZR m - IZR m) (/ 2)) ; case (choice m). +(* *) +intros H. +rewrite Rcompare_floor_ceil_middle with (1 := Fx). +rewrite Rcompare_Eq. +now case choice. +apply Rmult_eq_reg_r with (bpow (cexp x)). +now rewrite 2!Rmult_minus_distr_r. +apply Rgt_not_eq. +apply bpow_gt_0. +Qed. + +Lemma round_N_small_pos : + forall x, + forall ex, + (Raux.bpow beta (ex - 1) <= x < Raux.bpow beta ex)%R -> + (ex < fexp ex)%Z -> + (round Znearest x = 0)%R. +Proof. +intros x ex Hex Hf. +unfold round, F2R, scaled_mantissa, cexp; simpl. +apply (Rmult_eq_reg_r (bpow (- fexp (mag beta x)))); + [|now apply Rgt_not_eq; apply bpow_gt_0]. +rewrite Rmult_0_l, Rmult_assoc, <- bpow_plus. +replace (_ + - _)%Z with 0%Z by ring; simpl; rewrite Rmult_1_r. +apply IZR_eq. +apply Znearest_imp. +unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r. +assert (H : (x >= 0)%R). +{ apply Rle_ge; apply Rle_trans with (bpow (ex - 1)); [|exact (proj1 Hex)]. + now apply bpow_ge_0. } +assert (H' : (x * bpow (- fexp (mag beta x)) >= 0)%R). +{ apply Rle_ge; apply Rmult_le_pos. + - now apply Rge_le. + - now apply bpow_ge_0. } +rewrite Rabs_right; [|exact H']. +apply (Rmult_lt_reg_r (bpow (fexp (mag beta x)))); [now apply bpow_gt_0|]. +rewrite Rmult_assoc, <- bpow_plus. +replace (- _ + _)%Z with 0%Z by ring; simpl; rewrite Rmult_1_r. +apply (Rlt_le_trans _ _ _ (proj2 Hex)). +apply Rle_trans with (bpow (fexp (mag beta x) - 1)). +- apply bpow_le. + rewrite (mag_unique beta x ex); [omega|]. + now rewrite Rabs_right. +- unfold Zminus; rewrite bpow_plus. + rewrite Rmult_comm. + apply Rmult_le_compat_r; [now apply bpow_ge_0|]. + unfold Raux.bpow, Z.pow_pos; simpl. + rewrite Zmult_1_r. + apply Rinv_le; [exact Rlt_0_2|]. + apply IZR_le. + destruct beta as (beta_val,beta_prop). + now apply Zle_bool_imp_le. +Qed. + +End Znearest. + +Section rndNA. + +Global Instance valid_rnd_NA : Valid_rnd (Znearest (Zle_bool 0)) := valid_rnd_N _. + +Theorem round_NA_pt : + forall x, + Rnd_NA_pt generic_format x (round (Znearest (Zle_bool 0)) x). +Proof. +intros x. +generalize (round_N_pt (Zle_bool 0) x). +set (f := round (Znearest (Zle_bool 0)) x). +intros Rxf. +destruct (Req_dec (x - round Zfloor x) (round Zceil x - x)) as [Hm|Hm]. +(* *) +apply Rnd_NA_pt_N. +exact generic_format_0. +exact Rxf. +destruct (Rle_or_lt 0 x) as [Hx|Hx]. +(* . *) +rewrite Rabs_pos_eq with (1 := Hx). +rewrite Rabs_pos_eq. +unfold f. +rewrite round_N_middle with (1 := Hm). +rewrite Zle_bool_true. +apply (round_UP_pt x). +apply Zfloor_lub. +apply Rmult_le_pos with (1 := Hx). +apply bpow_ge_0. +apply Rnd_N_pt_ge_0 with (2 := Hx) (3 := Rxf). +exact generic_format_0. +(* . *) +rewrite Rabs_left with (1 := Hx). +rewrite Rabs_left1. +apply Ropp_le_contravar. +unfold f. +rewrite round_N_middle with (1 := Hm). +rewrite Zle_bool_false. +apply (round_DN_pt x). +apply lt_IZR. +apply Rle_lt_trans with (scaled_mantissa x). +apply Zfloor_lb. +simpl. +rewrite <- (Rmult_0_l (bpow (- cexp x))). +apply Rmult_lt_compat_r with (2 := Hx). +apply bpow_gt_0. +apply Rnd_N_pt_le_0 with (3 := Rxf). +exact generic_format_0. +now apply Rlt_le. +(* *) +split. +apply Rxf. +intros g Rxg. +rewrite Rnd_N_pt_unique with (3 := Hm) (4 := Rxf) (5 := Rxg). +apply Rle_refl. +apply round_DN_pt. +apply round_UP_pt. +Qed. + +End rndNA. + +Section rndN_opp. + +Theorem Znearest_opp : + forall choice x, + Znearest choice (- x) = (- Znearest (fun t => negb (choice (- (t + 1))%Z)) x)%Z. +Proof with auto with typeclass_instances. +intros choice x. +destruct (Req_dec (IZR (Zfloor x)) x) as [Hx|Hx]. +rewrite <- Hx. +rewrite <- opp_IZR. +rewrite 2!Zrnd_IZR... +unfold Znearest. +replace (- x - IZR (Zfloor (-x)))%R with (IZR (Zceil x) - x)%R. +rewrite Rcompare_ceil_floor_middle with (1 := Hx). +rewrite Rcompare_floor_ceil_middle with (1 := Hx). +rewrite Rcompare_sym. +rewrite <- Zceil_floor_neq with (1 := Hx). +unfold Zceil. +rewrite Ropp_involutive. +case Rcompare ; simpl ; trivial. +rewrite Z.opp_involutive. +case (choice (Zfloor (- x))) ; simpl ; trivial. +now rewrite Z.opp_involutive. +now rewrite Z.opp_involutive. +unfold Zceil. +rewrite opp_IZR. +apply Rplus_comm. +Qed. + +Theorem round_N_opp : + forall choice, + forall x, + round (Znearest choice) (-x) = (- round (Znearest (fun t => negb (choice (- (t + 1))%Z))) x)%R. +Proof. +intros choice x. +unfold round, F2R. simpl. +rewrite cexp_opp. +rewrite scaled_mantissa_opp. +rewrite Znearest_opp. +rewrite opp_IZR. +now rewrite Ropp_mult_distr_l_reverse. +Qed. + +End rndN_opp. + +Lemma round_N_small : + forall choice, + forall x, + forall ex, + (Raux.bpow beta (ex - 1) <= Rabs x < Raux.bpow beta ex)%R -> + (ex < fexp ex)%Z -> + (round (Znearest choice) x = 0)%R. +Proof. +intros choice x ex Hx Hex. +destruct (Rle_or_lt 0 x) as [Px|Nx]. +{ now revert Hex; apply round_N_small_pos; revert Hx; rewrite Rabs_pos_eq. } +rewrite <-(Ropp_involutive x), round_N_opp, <-Ropp_0; f_equal. +now revert Hex; apply round_N_small_pos; revert Hx; rewrite Rabs_left. +Qed. + +End Format. + +(** Inclusion of a format into an extended format *) +Section Inclusion. + +Variables fexp1 fexp2 : Z -> Z. + +Context { valid_exp1 : Valid_exp fexp1 }. +Context { valid_exp2 : Valid_exp fexp2 }. + +Theorem generic_inclusion_mag : + forall x, + ( x <> 0%R -> (fexp2 (mag beta x) <= fexp1 (mag beta x))%Z ) -> + generic_format fexp1 x -> + generic_format fexp2 x. +Proof. +intros x He Fx. +rewrite Fx. +apply generic_format_F2R. +intros Zx. +rewrite <- Fx. +apply He. +contradict Zx. +rewrite Zx, scaled_mantissa_0. +apply Ztrunc_IZR. +Qed. + +Theorem generic_inclusion_lt_ge : + forall e1 e2, + ( forall e, (e1 < e <= e2)%Z -> (fexp2 e <= fexp1 e)%Z ) -> + forall x, + (bpow e1 <= Rabs x < bpow e2)%R -> + generic_format fexp1 x -> + generic_format fexp2 x. +Proof. +intros e1 e2 He x (Hx1,Hx2). +apply generic_inclusion_mag. +intros Zx. +apply He. +split. +now apply mag_gt_bpow. +now apply mag_le_bpow. +Qed. + +Theorem generic_inclusion : + forall e, + (fexp2 e <= fexp1 e)%Z -> + forall x, + (bpow (e - 1) <= Rabs x <= bpow e)%R -> + generic_format fexp1 x -> + generic_format fexp2 x. +Proof with auto with typeclass_instances. +intros e He x (Hx1,[Hx2|Hx2]). +apply generic_inclusion_mag. +now rewrite mag_unique with (1 := conj Hx1 Hx2). +intros Fx. +apply generic_format_abs_inv. +rewrite Hx2. +apply generic_format_bpow'... +apply Z.le_trans with (1 := He). +apply generic_format_bpow_inv... +rewrite <- Hx2. +now apply generic_format_abs. +Qed. + +Theorem generic_inclusion_le_ge : + forall e1 e2, + (e1 < e2)%Z -> + ( forall e, (e1 < e <= e2)%Z -> (fexp2 e <= fexp1 e)%Z ) -> + forall x, + (bpow e1 <= Rabs x <= bpow e2)%R -> + generic_format fexp1 x -> + generic_format fexp2 x. +Proof. +intros e1 e2 He' He x (Hx1,[Hx2|Hx2]). +(* *) +apply generic_inclusion_mag. +intros Zx. +apply He. +split. +now apply mag_gt_bpow. +now apply mag_le_bpow. +(* *) +apply generic_inclusion with (e := e2). +apply He. +split. +apply He'. +apply Z.le_refl. +rewrite Hx2. +split. +apply bpow_le. +apply Zle_pred. +apply Rle_refl. +Qed. + +Theorem generic_inclusion_le : + forall e2, + ( forall e, (e <= e2)%Z -> (fexp2 e <= fexp1 e)%Z ) -> + forall x, + (Rabs x <= bpow e2)%R -> + generic_format fexp1 x -> + generic_format fexp2 x. +Proof. +intros e2 He x [Hx|Hx]. +apply generic_inclusion_mag. +intros Zx. +apply He. +now apply mag_le_bpow. +apply generic_inclusion with (e := e2). +apply He. +apply Z.le_refl. +rewrite Hx. +split. +apply bpow_le. +apply Zle_pred. +apply Rle_refl. +Qed. + +Theorem generic_inclusion_ge : + forall e1, + ( forall e, (e1 < e)%Z -> (fexp2 e <= fexp1 e)%Z ) -> + forall x, + (bpow e1 <= Rabs x)%R -> + generic_format fexp1 x -> + generic_format fexp2 x. +Proof. +intros e1 He x Hx. +apply generic_inclusion_mag. +intros Zx. +apply He. +now apply mag_gt_bpow. +Qed. + +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. + +Theorem generic_round_generic : + forall x, + generic_format fexp1 x -> + generic_format fexp1 (round fexp2 rnd x). +Proof with auto with typeclass_instances. +intros x Gx. +apply generic_format_abs_inv. +apply generic_format_abs in Gx. +revert rnd valid_rnd x Gx. +refine (round_abs_abs _ (fun x y => generic_format fexp1 x -> generic_format fexp1 y) _). +intros rnd valid_rnd x [Hx|Hx] Gx. +(* x > 0 *) +generalize (mag_generic_gt _ x (Rgt_not_eq _ _ Hx) Gx). +unfold cexp. +destruct (mag beta x) as (ex,Ex) ; simpl. +specialize (Ex (Rgt_not_eq _ _ Hx)). +intros He'. +rewrite Rabs_pos_eq in Ex by now apply Rlt_le. +destruct (Zle_or_lt ex (fexp2 ex)) as [He|He]. +(* - x near 0 for fexp2 *) +destruct (round_bounded_small_pos fexp2 rnd x ex He Ex) as [Hr|Hr]. +rewrite Hr. +apply generic_format_0. +rewrite Hr. +apply generic_format_bpow'... +apply Zlt_le_weak. +apply valid_exp_large with ex... +(* - x large for fexp2 *) +destruct (Zle_or_lt (cexp fexp2 x) (cexp fexp1 x)) as [He''|He'']. +(* - - round fexp2 x is representable for fexp1 *) +rewrite round_generic... +rewrite Gx. +apply generic_format_F2R. +fold (round fexp1 Ztrunc x). +intros Zx. +unfold cexp at 1. +rewrite mag_round_ZR... +contradict Zx. +apply eq_0_F2R with (1 := Zx). +(* - - round fexp2 x has too many digits for fexp1 *) +destruct (round_bounded_large_pos fexp2 rnd x ex He Ex) as (Hr1,[Hr2|Hr2]). +apply generic_format_F2R. +intros Zx. +fold (round fexp2 rnd x). +unfold cexp at 1. +rewrite mag_unique_pos with (1 := conj Hr1 Hr2). +rewrite <- mag_unique_pos with (1 := Ex). +now apply Zlt_le_weak. +rewrite Hr2. +apply generic_format_bpow'... +now apply Zlt_le_weak. +(* x = 0 *) +rewrite <- Hx, round_0... +apply generic_format_0. +Qed. + +End Inclusion. + +End Generic. + +Notation ZnearestA := (Znearest (Zle_bool 0)). + +Section rndNA_opp. + +Lemma round_NA_opp : + forall beta : radix, + forall (fexp : Z -> Z), + forall x, + (round beta fexp ZnearestA (- x) = - round beta fexp ZnearestA x)%R. +Proof. +intros beta fexp x. +rewrite round_N_opp. +apply Ropp_eq_compat. +apply round_ext. +clear x; intro x. +unfold Znearest. +case_eq (Rcompare (x - IZR (Zfloor x)) (/ 2)); intro C; +[|reflexivity|reflexivity]. +apply Rcompare_Eq_inv in C. +assert (H : negb (0 <=? - (Zfloor x + 1))%Z = (0 <=? Zfloor x)%Z); + [|now rewrite H]. +rewrite negb_Zle_bool. +case_eq (0 <=? Zfloor x)%Z; intro C'. +- apply Zle_bool_imp_le in C'. + apply Zlt_bool_true. + omega. +- rewrite Z.leb_gt in C'. + apply Zlt_bool_false. + omega. +Qed. + +End rndNA_opp. + +(** Notations for backward-compatibility with Flocq 1.4. *) +Notation rndDN := Zfloor (only parsing). +Notation rndUP := Zceil (only parsing). +Notation rndZR := Ztrunc (only parsing). +Notation rndNA := ZnearestA (only parsing). diff --git a/flocq/Core/Raux.v b/flocq/Core/Raux.v new file mode 100644 index 00000000..8273a55b --- /dev/null +++ b/flocq/Core/Raux.v @@ -0,0 +1,2402 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2009-2018 Sylvie Boldo +#
# +Copyright (C) 2009-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +(** * Missing definitions/lemmas *) +Require Import Psatz. +Require Export Reals ZArith. +Require Export Zaux. + +Section Rmissing. + +(** About R *) +Theorem Rle_0_minus : + forall x y, (x <= y)%R -> (0 <= y - x)%R. +Proof. +intros. +apply Rge_le. +apply Rge_minus. +now apply Rle_ge. +Qed. + +Theorem Rabs_eq_Rabs : + forall x y : R, + Rabs x = Rabs y -> x = y \/ x = Ropp y. +Proof. +intros x y H. +unfold Rabs in H. +destruct (Rcase_abs x) as [_|_]. +assert (H' := f_equal Ropp H). +rewrite Ropp_involutive in H'. +rewrite H'. +destruct (Rcase_abs y) as [_|_]. +left. +apply Ropp_involutive. +now right. +rewrite H. +now destruct (Rcase_abs y) as [_|_] ; [right|left]. +Qed. + +Theorem Rabs_minus_le: + forall x y : R, + (0 <= y)%R -> (y <= 2*x)%R -> + (Rabs (x-y) <= x)%R. +Proof. +intros x y Hx Hy. +apply Rabs_le. +lra. +Qed. + +Theorem Rabs_eq_R0 x : (Rabs x = 0 -> x = 0)%R. +Proof. split_Rabs; lra. Qed. + +Theorem Rplus_eq_reg_r : + forall r r1 r2 : R, + (r1 + r = r2 + r)%R -> (r1 = r2)%R. +Proof. +intros r r1 r2 H. +apply Rplus_eq_reg_l with r. +now rewrite 2!(Rplus_comm r). +Qed. + +Theorem Rmult_lt_compat : + forall r1 r2 r3 r4, + (0 <= r1)%R -> (0 <= r3)%R -> (r1 < r2)%R -> (r3 < r4)%R -> + (r1 * r3 < r2 * r4)%R. +Proof. +intros r1 r2 r3 r4 Pr1 Pr3 H12 H34. +apply Rle_lt_trans with (r1 * r4)%R. +- apply Rmult_le_compat_l. + + exact Pr1. + + now apply Rlt_le. +- apply Rmult_lt_compat_r. + + now apply Rle_lt_trans with r3. + + exact H12. +Qed. + +Theorem Rmult_minus_distr_r : + forall r r1 r2 : R, + ((r1 - r2) * r = r1 * r - r2 * r)%R. +Proof. +intros r r1 r2. +rewrite <- 3!(Rmult_comm r). +apply Rmult_minus_distr_l. +Qed. + +Lemma Rmult_neq_reg_r : + forall r1 r2 r3 : R, (r2 * r1 <> r3 * r1)%R -> r2 <> r3. +Proof. +intros r1 r2 r3 H1 H2. +apply H1; rewrite H2; ring. +Qed. + +Lemma Rmult_neq_compat_r : + forall r1 r2 r3 : R, + (r1 <> 0)%R -> (r2 <> r3)%R -> + (r2 * r1 <> r3 * r1)%R. +Proof. +intros r1 r2 r3 H H1 H2. +now apply H1, Rmult_eq_reg_r with r1. +Qed. + + +Theorem Rmult_min_distr_r : + forall r r1 r2 : R, + (0 <= r)%R -> + (Rmin r1 r2 * r)%R = Rmin (r1 * r) (r2 * r). +Proof. +intros r r1 r2 [Hr|Hr]. +unfold Rmin. +destruct (Rle_dec r1 r2) as [H1|H1] ; + destruct (Rle_dec (r1 * r) (r2 * r)) as [H2|H2] ; + try easy. +apply (f_equal (fun x => Rmult x r)). +apply Rle_antisym. +exact H1. +apply Rmult_le_reg_r with (1 := Hr). +apply Rlt_le. +now apply Rnot_le_lt. +apply Rle_antisym. +apply Rmult_le_compat_r. +now apply Rlt_le. +apply Rlt_le. +now apply Rnot_le_lt. +exact H2. +rewrite <- Hr. +rewrite 3!Rmult_0_r. +unfold Rmin. +destruct (Rle_dec 0 0) as [H0|H0]. +easy. +elim H0. +apply Rle_refl. +Qed. + +Theorem Rmult_min_distr_l : + forall r r1 r2 : R, + (0 <= r)%R -> + (r * Rmin r1 r2)%R = Rmin (r * r1) (r * r2). +Proof. +intros r r1 r2 Hr. +rewrite 3!(Rmult_comm r). +now apply Rmult_min_distr_r. +Qed. + +Lemma Rmin_opp: forall x y, (Rmin (-x) (-y) = - Rmax x y)%R. +Proof. +intros x y. +apply Rmax_case_strong; intros H. +rewrite Rmin_left; trivial. +now apply Ropp_le_contravar. +rewrite Rmin_right; trivial. +now apply Ropp_le_contravar. +Qed. + +Lemma Rmax_opp: forall x y, (Rmax (-x) (-y) = - Rmin x y)%R. +Proof. +intros x y. +apply Rmin_case_strong; intros H. +rewrite Rmax_left; trivial. +now apply Ropp_le_contravar. +rewrite Rmax_right; trivial. +now apply Ropp_le_contravar. +Qed. + +Theorem exp_le : + forall x y : R, + (x <= y)%R -> (exp x <= exp y)%R. +Proof. +intros x y [H|H]. +apply Rlt_le. +now apply exp_increasing. +rewrite H. +apply Rle_refl. +Qed. + +Theorem Rinv_lt : + forall x y, + (0 < x)%R -> (x < y)%R -> (/y < /x)%R. +Proof. +intros x y Hx Hxy. +apply Rinv_lt_contravar. +apply Rmult_lt_0_compat. +exact Hx. +now apply Rlt_trans with x. +exact Hxy. +Qed. + +Theorem Rinv_le : + forall x y, + (0 < x)%R -> (x <= y)%R -> (/y <= /x)%R. +Proof. +intros x y Hx Hxy. +apply Rle_Rinv. +exact Hx. +now apply Rlt_le_trans with x. +exact Hxy. +Qed. + +Theorem sqrt_ge_0 : + forall x : R, + (0 <= sqrt x)%R. +Proof. +intros x. +unfold sqrt. +destruct (Rcase_abs x) as [_|H]. +apply Rle_refl. +apply Rsqrt_positivity. +Qed. + +Lemma sqrt_neg : forall x, (x <= 0)%R -> (sqrt x = 0)%R. +Proof. +intros x Npx. +destruct (Req_dec x 0) as [Zx|Nzx]. +- (* x = 0 *) + rewrite Zx. + exact sqrt_0. +- (* x < 0 *) + unfold sqrt. + destruct Rcase_abs. + + reflexivity. + + casetype False. + now apply Nzx, Rle_antisym; [|apply Rge_le]. +Qed. + +Lemma Rsqr_le_abs_0_alt : + forall x y, + (x² <= y² -> x <= Rabs y)%R. +Proof. +intros x y H. +apply (Rle_trans _ (Rabs x)); [apply Rle_abs|apply (Rsqr_le_abs_0 _ _ H)]. +Qed. + +Theorem Rabs_le : + forall x y, + (-y <= x <= y)%R -> (Rabs x <= y)%R. +Proof. +intros x y (Hyx,Hxy). +unfold Rabs. +case Rcase_abs ; intros Hx. +apply Ropp_le_cancel. +now rewrite Ropp_involutive. +exact Hxy. +Qed. + +Theorem Rabs_le_inv : + forall x y, + (Rabs x <= y)%R -> (-y <= x <= y)%R. +Proof. +intros x y Hxy. +split. +apply Rle_trans with (- Rabs x)%R. +now apply Ropp_le_contravar. +apply Ropp_le_cancel. +rewrite Ropp_involutive, <- Rabs_Ropp. +apply RRle_abs. +apply Rle_trans with (2 := Hxy). +apply RRle_abs. +Qed. + +Theorem Rabs_ge : + forall x y, + (y <= -x \/ x <= y)%R -> (x <= Rabs y)%R. +Proof. +intros x y [Hyx|Hxy]. +apply Rle_trans with (-y)%R. +apply Ropp_le_cancel. +now rewrite Ropp_involutive. +rewrite <- Rabs_Ropp. +apply RRle_abs. +apply Rle_trans with (1 := Hxy). +apply RRle_abs. +Qed. + +Theorem Rabs_ge_inv : + forall x y, + (x <= Rabs y)%R -> (y <= -x \/ x <= y)%R. +Proof. +intros x y. +unfold Rabs. +case Rcase_abs ; intros Hy Hxy. +left. +apply Ropp_le_cancel. +now rewrite Ropp_involutive. +now right. +Qed. + +Theorem Rabs_lt : + forall x y, + (-y < x < y)%R -> (Rabs x < y)%R. +Proof. +intros x y (Hyx,Hxy). +now apply Rabs_def1. +Qed. + +Theorem Rabs_lt_inv : + forall x y, + (Rabs x < y)%R -> (-y < x < y)%R. +Proof. +intros x y H. +now split ; eapply Rabs_def2. +Qed. + +Theorem Rabs_gt : + forall x y, + (y < -x \/ x < y)%R -> (x < Rabs y)%R. +Proof. +intros x y [Hyx|Hxy]. +rewrite <- Rabs_Ropp. +apply Rlt_le_trans with (Ropp y). +apply Ropp_lt_cancel. +now rewrite Ropp_involutive. +apply RRle_abs. +apply Rlt_le_trans with (1 := Hxy). +apply RRle_abs. +Qed. + +Theorem Rabs_gt_inv : + forall x y, + (x < Rabs y)%R -> (y < -x \/ x < y)%R. +Proof. +intros x y. +unfold Rabs. +case Rcase_abs ; intros Hy Hxy. +left. +apply Ropp_lt_cancel. +now rewrite Ropp_involutive. +now right. +Qed. + +End Rmissing. + +Section IZR. + +Theorem IZR_le_lt : + forall m n p, (m <= n < p)%Z -> (IZR m <= IZR n < IZR p)%R. +Proof. +intros m n p (H1, H2). +split. +now apply IZR_le. +now apply IZR_lt. +Qed. + +Theorem le_lt_IZR : + forall m n p, (IZR m <= IZR n < IZR p)%R -> (m <= n < p)%Z. +Proof. +intros m n p (H1, H2). +split. +now apply le_IZR. +now apply lt_IZR. +Qed. + +Theorem neq_IZR : + forall m n, (IZR m <> IZR n)%R -> (m <> n)%Z. +Proof. +intros m n H H'. +apply H. +now apply f_equal. +Qed. + +End IZR. + +(** Decidable comparison on reals *) +Section Rcompare. + +Definition Rcompare x y := + match total_order_T x y with + | inleft (left _) => Lt + | inleft (right _) => Eq + | inright _ => Gt + end. + +Inductive Rcompare_prop (x y : R) : comparison -> Prop := + | Rcompare_Lt_ : (x < y)%R -> Rcompare_prop x y Lt + | Rcompare_Eq_ : x = y -> Rcompare_prop x y Eq + | Rcompare_Gt_ : (y < x)%R -> Rcompare_prop x y Gt. + +Theorem Rcompare_spec : + forall x y, Rcompare_prop x y (Rcompare x y). +Proof. +intros x y. +unfold Rcompare. +now destruct (total_order_T x y) as [[H|H]|H] ; constructor. +Qed. + +Global Opaque Rcompare. + +Theorem Rcompare_Lt : + forall x y, + (x < y)%R -> Rcompare x y = Lt. +Proof. +intros x y H. +case Rcompare_spec ; intro H'. +easy. +rewrite H' in H. +elim (Rlt_irrefl _ H). +elim (Rlt_irrefl x). +now apply Rlt_trans with y. +Qed. + +Theorem Rcompare_Lt_inv : + forall x y, + Rcompare x y = Lt -> (x < y)%R. +Proof. +intros x y. +now case Rcompare_spec. +Qed. + +Theorem Rcompare_not_Lt : + forall x y, + (y <= x)%R -> Rcompare x y <> Lt. +Proof. +intros x y H1 H2. +apply Rle_not_lt with (1 := H1). +now apply Rcompare_Lt_inv. +Qed. + +Theorem Rcompare_not_Lt_inv : + forall x y, + Rcompare x y <> Lt -> (y <= x)%R. +Proof. +intros x y H. +apply Rnot_lt_le. +contradict H. +now apply Rcompare_Lt. +Qed. + +Theorem Rcompare_Eq : + forall x y, + x = y -> Rcompare x y = Eq. +Proof. +intros x y H. +rewrite H. +now case Rcompare_spec ; intro H' ; try elim (Rlt_irrefl _ H'). +Qed. + +Theorem Rcompare_Eq_inv : + forall x y, + Rcompare x y = Eq -> x = y. +Proof. +intros x y. +now case Rcompare_spec. +Qed. + +Theorem Rcompare_Gt : + forall x y, + (y < x)%R -> Rcompare x y = Gt. +Proof. +intros x y H. +case Rcompare_spec ; intro H'. +elim (Rlt_irrefl x). +now apply Rlt_trans with y. +rewrite H' in H. +elim (Rlt_irrefl _ H). +easy. +Qed. + +Theorem Rcompare_Gt_inv : + forall x y, + Rcompare x y = Gt -> (y < x)%R. +Proof. +intros x y. +now case Rcompare_spec. +Qed. + +Theorem Rcompare_not_Gt : + forall x y, + (x <= y)%R -> Rcompare x y <> Gt. +Proof. +intros x y H1 H2. +apply Rle_not_lt with (1 := H1). +now apply Rcompare_Gt_inv. +Qed. + +Theorem Rcompare_not_Gt_inv : + forall x y, + Rcompare x y <> Gt -> (x <= y)%R. +Proof. +intros x y H. +apply Rnot_lt_le. +contradict H. +now apply Rcompare_Gt. +Qed. + +Theorem Rcompare_IZR : + forall x y, Rcompare (IZR x) (IZR y) = Z.compare x y. +Proof. +intros x y. +case Rcompare_spec ; intros H ; apply sym_eq. +apply Zcompare_Lt. +now apply lt_IZR. +apply Zcompare_Eq. +now apply eq_IZR. +apply Zcompare_Gt. +now apply lt_IZR. +Qed. + +Theorem Rcompare_sym : + forall x y, + Rcompare x y = CompOpp (Rcompare y x). +Proof. +intros x y. +destruct (Rcompare_spec y x) as [H|H|H]. +now apply Rcompare_Gt. +now apply Rcompare_Eq. +now apply Rcompare_Lt. +Qed. + +Lemma Rcompare_opp : + forall x y, + Rcompare (- x) (- y) = Rcompare y x. +Proof. +intros x y. +destruct (Rcompare_spec y x); + destruct (Rcompare_spec (- x) (- y)); + try reflexivity; exfalso; lra. +Qed. + +Theorem Rcompare_plus_r : + forall z x y, + Rcompare (x + z) (y + z) = Rcompare x y. +Proof. +intros z x y. +destruct (Rcompare_spec x y) as [H|H|H]. +apply Rcompare_Lt. +now apply Rplus_lt_compat_r. +apply Rcompare_Eq. +now rewrite H. +apply Rcompare_Gt. +now apply Rplus_lt_compat_r. +Qed. + +Theorem Rcompare_plus_l : + forall z x y, + Rcompare (z + x) (z + y) = Rcompare x y. +Proof. +intros z x y. +rewrite 2!(Rplus_comm z). +apply Rcompare_plus_r. +Qed. + +Theorem Rcompare_mult_r : + forall z x y, + (0 < z)%R -> + Rcompare (x * z) (y * z) = Rcompare x y. +Proof. +intros z x y Hz. +destruct (Rcompare_spec x y) as [H|H|H]. +apply Rcompare_Lt. +now apply Rmult_lt_compat_r. +apply Rcompare_Eq. +now rewrite H. +apply Rcompare_Gt. +now apply Rmult_lt_compat_r. +Qed. + +Theorem Rcompare_mult_l : + forall z x y, + (0 < z)%R -> + Rcompare (z * x) (z * y) = Rcompare x y. +Proof. +intros z x y. +rewrite 2!(Rmult_comm z). +apply Rcompare_mult_r. +Qed. + +Theorem Rcompare_middle : + forall x d u, + Rcompare (x - d) (u - x) = Rcompare x ((d + u) / 2). +Proof. +intros x d u. +rewrite <- (Rcompare_plus_r (- x / 2 - d / 2) x). +rewrite <- (Rcompare_mult_r (/2) (x - d)). +field_simplify (x + (- x / 2 - d / 2))%R. +now field_simplify ((d + u) / 2 + (- x / 2 - d / 2))%R. +apply Rinv_0_lt_compat. +now apply IZR_lt. +Qed. + +Theorem Rcompare_half_l : + forall x y, Rcompare (x / 2) y = Rcompare x (2 * y). +Proof. +intros x y. +rewrite <- (Rcompare_mult_r 2%R). +unfold Rdiv. +rewrite Rmult_assoc, Rinv_l, Rmult_1_r. +now rewrite Rmult_comm. +now apply IZR_neq. +now apply IZR_lt. +Qed. + +Theorem Rcompare_half_r : + forall x y, Rcompare x (y / 2) = Rcompare (2 * x) y. +Proof. +intros x y. +rewrite <- (Rcompare_mult_r 2%R). +unfold Rdiv. +rewrite Rmult_assoc, Rinv_l, Rmult_1_r. +now rewrite Rmult_comm. +now apply IZR_neq. +now apply IZR_lt. +Qed. + +Theorem Rcompare_sqr : + forall x y, + Rcompare (x * x) (y * y) = Rcompare (Rabs x) (Rabs y). +Proof. +intros x y. +destruct (Rcompare_spec (Rabs x) (Rabs y)) as [H|H|H]. +apply Rcompare_Lt. +now apply Rsqr_lt_abs_1. +change (Rcompare (Rsqr x) (Rsqr y) = Eq). +rewrite Rsqr_abs, H, (Rsqr_abs y). +now apply Rcompare_Eq. +apply Rcompare_Gt. +now apply Rsqr_lt_abs_1. +Qed. + +Theorem Rmin_compare : + forall x y, + Rmin x y = match Rcompare x y with Lt => x | Eq => x | Gt => y end. +Proof. +intros x y. +unfold Rmin. +destruct (Rle_dec x y) as [[Hx|Hx]|Hx]. +now rewrite Rcompare_Lt. +now rewrite Rcompare_Eq. +rewrite Rcompare_Gt. +easy. +now apply Rnot_le_lt. +Qed. + +End Rcompare. + +Section Rle_bool. + +Definition Rle_bool x y := + match Rcompare x y with + | Gt => false + | _ => true + end. + +Inductive Rle_bool_prop (x y : R) : bool -> Prop := + | Rle_bool_true_ : (x <= y)%R -> Rle_bool_prop x y true + | Rle_bool_false_ : (y < x)%R -> Rle_bool_prop x y false. + +Theorem Rle_bool_spec : + forall x y, Rle_bool_prop x y (Rle_bool x y). +Proof. +intros x y. +unfold Rle_bool. +case Rcompare_spec ; constructor. +now apply Rlt_le. +rewrite H. +apply Rle_refl. +exact H. +Qed. + +Theorem Rle_bool_true : + forall x y, + (x <= y)%R -> Rle_bool x y = true. +Proof. +intros x y Hxy. +case Rle_bool_spec ; intros H. +apply refl_equal. +elim (Rlt_irrefl x). +now apply Rle_lt_trans with y. +Qed. + +Theorem Rle_bool_false : + forall x y, + (y < x)%R -> Rle_bool x y = false. +Proof. +intros x y Hxy. +case Rle_bool_spec ; intros H. +elim (Rlt_irrefl x). +now apply Rle_lt_trans with y. +apply refl_equal. +Qed. + +End Rle_bool. + +Section Rlt_bool. + +Definition Rlt_bool x y := + match Rcompare x y with + | Lt => true + | _ => false + end. + +Inductive Rlt_bool_prop (x y : R) : bool -> Prop := + | Rlt_bool_true_ : (x < y)%R -> Rlt_bool_prop x y true + | Rlt_bool_false_ : (y <= x)%R -> Rlt_bool_prop x y false. + +Theorem Rlt_bool_spec : + forall x y, Rlt_bool_prop x y (Rlt_bool x y). +Proof. +intros x y. +unfold Rlt_bool. +case Rcompare_spec ; constructor. +exact H. +rewrite H. +apply Rle_refl. +now apply Rlt_le. +Qed. + +Theorem negb_Rlt_bool : + forall x y, + negb (Rle_bool x y) = Rlt_bool y x. +Proof. +intros x y. +unfold Rlt_bool, Rle_bool. +rewrite Rcompare_sym. +now case Rcompare. +Qed. + +Theorem negb_Rle_bool : + forall x y, + negb (Rlt_bool x y) = Rle_bool y x. +Proof. +intros x y. +unfold Rlt_bool, Rle_bool. +rewrite Rcompare_sym. +now case Rcompare. +Qed. + +Theorem Rlt_bool_true : + forall x y, + (x < y)%R -> Rlt_bool x y = true. +Proof. +intros x y Hxy. +rewrite <- negb_Rlt_bool. +now rewrite Rle_bool_false. +Qed. + +Theorem Rlt_bool_false : + forall x y, + (y <= x)%R -> Rlt_bool x y = false. +Proof. +intros x y Hxy. +rewrite <- negb_Rlt_bool. +now rewrite Rle_bool_true. +Qed. + +Lemma Rlt_bool_opp : + forall x y, + Rlt_bool (- x) (- y) = Rlt_bool y x. +Proof. +intros x y. +now unfold Rlt_bool; rewrite Rcompare_opp. +Qed. + +End Rlt_bool. + +Section Req_bool. + +Definition Req_bool x y := + match Rcompare x y with + | Eq => true + | _ => false + end. + +Inductive Req_bool_prop (x y : R) : bool -> Prop := + | Req_bool_true_ : (x = y)%R -> Req_bool_prop x y true + | Req_bool_false_ : (x <> y)%R -> Req_bool_prop x y false. + +Theorem Req_bool_spec : + forall x y, Req_bool_prop x y (Req_bool x y). +Proof. +intros x y. +unfold Req_bool. +case Rcompare_spec ; constructor. +now apply Rlt_not_eq. +easy. +now apply Rgt_not_eq. +Qed. + +Theorem Req_bool_true : + forall x y, + (x = y)%R -> Req_bool x y = true. +Proof. +intros x y Hxy. +case Req_bool_spec ; intros H. +apply refl_equal. +contradict H. +exact Hxy. +Qed. + +Theorem Req_bool_false : + forall x y, + (x <> y)%R -> Req_bool x y = false. +Proof. +intros x y Hxy. +case Req_bool_spec ; intros H. +contradict Hxy. +exact H. +apply refl_equal. +Qed. + +End Req_bool. + +Section Floor_Ceil. + +(** Zfloor and Zceil *) +Definition Zfloor (x : R) := (up x - 1)%Z. + +Theorem Zfloor_lb : + forall x : R, + (IZR (Zfloor x) <= x)%R. +Proof. +intros x. +unfold Zfloor. +rewrite minus_IZR. +simpl. +apply Rplus_le_reg_r with (1 - x)%R. +ring_simplify. +exact (proj2 (archimed x)). +Qed. + +Theorem Zfloor_ub : + forall x : R, + (x < IZR (Zfloor x) + 1)%R. +Proof. +intros x. +unfold Zfloor. +rewrite minus_IZR. +unfold Rminus. +rewrite Rplus_assoc. +rewrite Rplus_opp_l, Rplus_0_r. +exact (proj1 (archimed x)). +Qed. + +Theorem Zfloor_lub : + forall n x, + (IZR n <= x)%R -> + (n <= Zfloor x)%Z. +Proof. +intros n x Hnx. +apply Zlt_succ_le. +apply lt_IZR. +apply Rle_lt_trans with (1 := Hnx). +unfold Z.succ. +rewrite plus_IZR. +apply Zfloor_ub. +Qed. + +Theorem Zfloor_imp : + forall n x, + (IZR n <= x < IZR (n + 1))%R -> + Zfloor x = n. +Proof. +intros n x Hnx. +apply Zle_antisym. +apply Zlt_succ_le. +apply lt_IZR. +apply Rle_lt_trans with (2 := proj2 Hnx). +apply Zfloor_lb. +now apply Zfloor_lub. +Qed. + +Theorem Zfloor_IZR : + forall n, + Zfloor (IZR n) = n. +Proof. +intros n. +apply Zfloor_imp. +split. +apply Rle_refl. +apply IZR_lt. +apply Zlt_succ. +Qed. + +Theorem Zfloor_le : + forall x y, (x <= y)%R -> + (Zfloor x <= Zfloor y)%Z. +Proof. +intros x y Hxy. +apply Zfloor_lub. +apply Rle_trans with (2 := Hxy). +apply Zfloor_lb. +Qed. + +Definition Zceil (x : R) := (- Zfloor (- x))%Z. + +Theorem Zceil_ub : + forall x : R, + (x <= IZR (Zceil x))%R. +Proof. +intros x. +unfold Zceil. +rewrite opp_IZR. +apply Ropp_le_cancel. +rewrite Ropp_involutive. +apply Zfloor_lb. +Qed. + +Theorem Zceil_glb : + forall n x, + (x <= IZR n)%R -> + (Zceil x <= n)%Z. +Proof. +intros n x Hnx. +unfold Zceil. +apply Zopp_le_cancel. +rewrite Z.opp_involutive. +apply Zfloor_lub. +rewrite opp_IZR. +now apply Ropp_le_contravar. +Qed. + +Theorem Zceil_imp : + forall n x, + (IZR (n - 1) < x <= IZR n)%R -> + Zceil x = n. +Proof. +intros n x Hnx. +unfold Zceil. +rewrite <- (Z.opp_involutive n). +apply f_equal. +apply Zfloor_imp. +split. +rewrite opp_IZR. +now apply Ropp_le_contravar. +rewrite <- (Z.opp_involutive 1). +rewrite <- Zopp_plus_distr. +rewrite opp_IZR. +now apply Ropp_lt_contravar. +Qed. + +Theorem Zceil_IZR : + forall n, + Zceil (IZR n) = n. +Proof. +intros n. +unfold Zceil. +rewrite <- opp_IZR, Zfloor_IZR. +apply Z.opp_involutive. +Qed. + +Theorem Zceil_le : + forall x y, (x <= y)%R -> + (Zceil x <= Zceil y)%Z. +Proof. +intros x y Hxy. +apply Zceil_glb. +apply Rle_trans with (1 := Hxy). +apply Zceil_ub. +Qed. + +Theorem Zceil_floor_neq : + forall x : R, + (IZR (Zfloor x) <> x)%R -> + (Zceil x = Zfloor x + 1)%Z. +Proof. +intros x Hx. +apply Zceil_imp. +split. +ring_simplify (Zfloor x + 1 - 1)%Z. +apply Rnot_le_lt. +intros H. +apply Hx. +apply Rle_antisym. +apply Zfloor_lb. +exact H. +apply Rlt_le. +rewrite plus_IZR. +apply Zfloor_ub. +Qed. + +Definition Ztrunc x := if Rlt_bool x 0 then Zceil x else Zfloor x. + +Theorem Ztrunc_IZR : + forall n, + Ztrunc (IZR n) = n. +Proof. +intros n. +unfold Ztrunc. +case Rlt_bool_spec ; intro H. +apply Zceil_IZR. +apply Zfloor_IZR. +Qed. + +Theorem Ztrunc_floor : + forall x, + (0 <= x)%R -> + Ztrunc x = Zfloor x. +Proof. +intros x Hx. +unfold Ztrunc. +case Rlt_bool_spec ; intro H. +elim Rlt_irrefl with x. +now apply Rlt_le_trans with R0. +apply refl_equal. +Qed. + +Theorem Ztrunc_ceil : + forall x, + (x <= 0)%R -> + Ztrunc x = Zceil x. +Proof. +intros x Hx. +unfold Ztrunc. +case Rlt_bool_spec ; intro H. +apply refl_equal. +rewrite (Rle_antisym _ _ Hx H). +rewrite Zceil_IZR. +apply Zfloor_IZR. +Qed. + +Theorem Ztrunc_le : + forall x y, (x <= y)%R -> + (Ztrunc x <= Ztrunc y)%Z. +Proof. +intros x y Hxy. +unfold Ztrunc at 1. +case Rlt_bool_spec ; intro Hx. +unfold Ztrunc. +case Rlt_bool_spec ; intro Hy. +now apply Zceil_le. +apply Z.le_trans with 0%Z. +apply Zceil_glb. +now apply Rlt_le. +now apply Zfloor_lub. +rewrite Ztrunc_floor. +now apply Zfloor_le. +now apply Rle_trans with x. +Qed. + +Theorem Ztrunc_opp : + forall x, + Ztrunc (- x) = Z.opp (Ztrunc x). +Proof. +intros x. +unfold Ztrunc at 2. +case Rlt_bool_spec ; intros Hx. +rewrite Ztrunc_floor. +apply sym_eq. +apply Z.opp_involutive. +rewrite <- Ropp_0. +apply Ropp_le_contravar. +now apply Rlt_le. +rewrite Ztrunc_ceil. +unfold Zceil. +now rewrite Ropp_involutive. +rewrite <- Ropp_0. +now apply Ropp_le_contravar. +Qed. + +Theorem Ztrunc_abs : + forall x, + Ztrunc (Rabs x) = Z.abs (Ztrunc x). +Proof. +intros x. +rewrite Ztrunc_floor. 2: apply Rabs_pos. +unfold Ztrunc. +case Rlt_bool_spec ; intro H. +rewrite Rabs_left with (1 := H). +rewrite Zabs_non_eq. +apply sym_eq. +apply Z.opp_involutive. +apply Zceil_glb. +now apply Rlt_le. +rewrite Rabs_pos_eq with (1 := H). +apply sym_eq. +apply Z.abs_eq. +now apply Zfloor_lub. +Qed. + +Theorem Ztrunc_lub : + forall n x, + (IZR n <= Rabs x)%R -> + (n <= Z.abs (Ztrunc x))%Z. +Proof. +intros n x H. +rewrite <- Ztrunc_abs. +rewrite Ztrunc_floor. 2: apply Rabs_pos. +now apply Zfloor_lub. +Qed. + +Definition Zaway x := if Rlt_bool x 0 then Zfloor x else Zceil x. + +Theorem Zaway_IZR : + forall n, + Zaway (IZR n) = n. +Proof. +intros n. +unfold Zaway. +case Rlt_bool_spec ; intro H. +apply Zfloor_IZR. +apply Zceil_IZR. +Qed. + +Theorem Zaway_ceil : + forall x, + (0 <= x)%R -> + Zaway x = Zceil x. +Proof. +intros x Hx. +unfold Zaway. +case Rlt_bool_spec ; intro H. +elim Rlt_irrefl with x. +now apply Rlt_le_trans with R0. +apply refl_equal. +Qed. + +Theorem Zaway_floor : + forall x, + (x <= 0)%R -> + Zaway x = Zfloor x. +Proof. +intros x Hx. +unfold Zaway. +case Rlt_bool_spec ; intro H. +apply refl_equal. +rewrite (Rle_antisym _ _ Hx H). +rewrite Zfloor_IZR. +apply Zceil_IZR. +Qed. + +Theorem Zaway_le : + forall x y, (x <= y)%R -> + (Zaway x <= Zaway y)%Z. +Proof. +intros x y Hxy. +unfold Zaway at 1. +case Rlt_bool_spec ; intro Hx. +unfold Zaway. +case Rlt_bool_spec ; intro Hy. +now apply Zfloor_le. +apply le_IZR. +apply Rle_trans with 0%R. +apply Rlt_le. +apply Rle_lt_trans with (2 := Hx). +apply Zfloor_lb. +apply Rle_trans with (1 := Hy). +apply Zceil_ub. +rewrite Zaway_ceil. +now apply Zceil_le. +now apply Rle_trans with x. +Qed. + +Theorem Zaway_opp : + forall x, + Zaway (- x) = Z.opp (Zaway x). +Proof. +intros x. +unfold Zaway at 2. +case Rlt_bool_spec ; intro H. +rewrite Zaway_ceil. +unfold Zceil. +now rewrite Ropp_involutive. +apply Rlt_le. +now apply Ropp_0_gt_lt_contravar. +rewrite Zaway_floor. +apply sym_eq. +apply Z.opp_involutive. +rewrite <- Ropp_0. +now apply Ropp_le_contravar. +Qed. + +Theorem Zaway_abs : + forall x, + Zaway (Rabs x) = Z.abs (Zaway x). +Proof. +intros x. +rewrite Zaway_ceil. 2: apply Rabs_pos. +unfold Zaway. +case Rlt_bool_spec ; intro H. +rewrite Rabs_left with (1 := H). +rewrite Zabs_non_eq. +apply (f_equal (fun v => - Zfloor v)%Z). +apply Ropp_involutive. +apply le_IZR. +apply Rlt_le. +apply Rle_lt_trans with (2 := H). +apply Zfloor_lb. +rewrite Rabs_pos_eq with (1 := H). +apply sym_eq. +apply Z.abs_eq. +apply le_IZR. +apply Rle_trans with (1 := H). +apply Zceil_ub. +Qed. + +End Floor_Ceil. + +Theorem Rcompare_floor_ceil_middle : + forall x, + IZR (Zfloor x) <> x -> + Rcompare (x - IZR (Zfloor x)) (/ 2) = Rcompare (x - IZR (Zfloor x)) (IZR (Zceil x) - x). +Proof. +intros x Hx. +rewrite Zceil_floor_neq with (1 := Hx). +rewrite plus_IZR. +destruct (Rcompare_spec (x - IZR (Zfloor x)) (/ 2)) as [H1|H1|H1] ; apply sym_eq. +(* . *) +apply Rcompare_Lt. +apply Rplus_lt_reg_l with (x - IZR (Zfloor x))%R. +replace (x - IZR (Zfloor x) + (x - IZR (Zfloor x)))%R with ((x - IZR (Zfloor x)) * 2)%R by ring. +replace (x - IZR (Zfloor x) + (IZR (Zfloor x) + 1 - x))%R with (/2 * 2)%R by field. +apply Rmult_lt_compat_r with (2 := H1). +now apply IZR_lt. +(* . *) +apply Rcompare_Eq. +replace (IZR (Zfloor x) + 1 - x)%R with (1 - (x - IZR (Zfloor x)))%R by ring. +rewrite H1. +field. +(* . *) +apply Rcompare_Gt. +apply Rplus_lt_reg_l with (x - IZR (Zfloor x))%R. +replace (x - IZR (Zfloor x) + (x - IZR (Zfloor x)))%R with ((x - IZR (Zfloor x)) * 2)%R by ring. +replace (x - IZR (Zfloor x) + (IZR (Zfloor x) + 1 - x))%R with (/2 * 2)%R by field. +apply Rmult_lt_compat_r with (2 := H1). +now apply IZR_lt. +Qed. + +Theorem Rcompare_ceil_floor_middle : + forall x, + IZR (Zfloor x) <> x -> + Rcompare (IZR (Zceil x) - x) (/ 2) = Rcompare (IZR (Zceil x) - x) (x - IZR (Zfloor x)). +Proof. +intros x Hx. +rewrite Zceil_floor_neq with (1 := Hx). +rewrite plus_IZR. +destruct (Rcompare_spec (IZR (Zfloor x) + 1 - x) (/ 2)) as [H1|H1|H1] ; apply sym_eq. +(* . *) +apply Rcompare_Lt. +apply Rplus_lt_reg_l with (IZR (Zfloor x) + 1 - x)%R. +replace (IZR (Zfloor x) + 1 - x + (IZR (Zfloor x) + 1 - x))%R with ((IZR (Zfloor x) + 1 - x) * 2)%R by ring. +replace (IZR (Zfloor x) + 1 - x + (x - IZR (Zfloor x)))%R with (/2 * 2)%R by field. +apply Rmult_lt_compat_r with (2 := H1). +now apply IZR_lt. +(* . *) +apply Rcompare_Eq. +replace (x - IZR (Zfloor x))%R with (1 - (IZR (Zfloor x) + 1 - x))%R by ring. +rewrite H1. +field. +(* . *) +apply Rcompare_Gt. +apply Rplus_lt_reg_l with (IZR (Zfloor x) + 1 - x)%R. +replace (IZR (Zfloor x) + 1 - x + (IZR (Zfloor x) + 1 - x))%R with ((IZR (Zfloor x) + 1 - x) * 2)%R by ring. +replace (IZR (Zfloor x) + 1 - x + (x - IZR (Zfloor x)))%R with (/2 * 2)%R by field. +apply Rmult_lt_compat_r with (2 := H1). +now apply IZR_lt. +Qed. + +Section Zdiv_Rdiv. + +Theorem Zfloor_div : + forall x y, + y <> Z0 -> + Zfloor (IZR x / IZR y) = (x / y)%Z. +Proof. +intros x y Zy. +generalize (Z_div_mod_eq_full x y Zy). +intros Hx. +rewrite Hx at 1. +assert (Zy': IZR y <> 0%R). +contradict Zy. +now apply eq_IZR. +unfold Rdiv. +rewrite plus_IZR, Rmult_plus_distr_r, mult_IZR. +replace (IZR y * IZR (x / y) * / IZR y)%R with (IZR (x / y)) by now field. +apply Zfloor_imp. +rewrite plus_IZR. +assert (0 <= IZR (x mod y) * / IZR y < 1)%R. +(* *) +assert (forall x' y', (0 < y')%Z -> 0 <= IZR (x' mod y') * / IZR y' < 1)%R. +(* . *) +clear. +intros x y Hy. +split. +apply Rmult_le_pos. +apply IZR_le. +refine (proj1 (Z_mod_lt _ _ _)). +now apply Z.lt_gt. +apply Rlt_le. +apply Rinv_0_lt_compat. +now apply IZR_lt. +apply Rmult_lt_reg_r with (IZR y). +now apply IZR_lt. +rewrite Rmult_1_l, Rmult_assoc, Rinv_l, Rmult_1_r. +apply IZR_lt. +eapply Z_mod_lt. +now apply Z.lt_gt. +apply Rgt_not_eq. +now apply IZR_lt. +(* . *) +destruct (Z_lt_le_dec y 0) as [Hy|Hy]. +rewrite <- Rmult_opp_opp. +rewrite Ropp_inv_permute with (1 := Zy'). +rewrite <- 2!opp_IZR. +rewrite <- Zmod_opp_opp. +apply H. +clear -Hy. omega. +apply H. +clear -Zy Hy. omega. +(* *) +split. +pattern (IZR (x / y)) at 1 ; rewrite <- Rplus_0_r. +apply Rplus_le_compat_l. +apply H. +apply Rplus_lt_compat_l. +apply H. +Qed. + +End Zdiv_Rdiv. + +Section pow. + +Variable r : radix. + +Theorem radix_pos : (0 < IZR r)%R. +Proof. +destruct r as (v, Hr). simpl. +apply IZR_lt. +apply Z.lt_le_trans with 2%Z. +easy. +now apply Zle_bool_imp_le. +Qed. + +(** Well-used function called bpow for computing the power function #β#^e *) +Definition bpow e := + match e with + | Zpos p => IZR (Zpower_pos r p) + | Zneg p => Rinv (IZR (Zpower_pos r p)) + | Z0 => 1%R + end. + +Theorem IZR_Zpower_pos : + forall n m, + IZR (Zpower_pos n m) = powerRZ (IZR n) (Zpos m). +Proof. +intros. +rewrite Zpower_pos_nat. +simpl. +induction (nat_of_P m). +apply refl_equal. +unfold Zpower_nat. +simpl. +rewrite mult_IZR. +apply Rmult_eq_compat_l. +exact IHn0. +Qed. + +Theorem bpow_powerRZ : + forall e, + bpow e = powerRZ (IZR r) e. +Proof. +destruct e ; unfold bpow. +reflexivity. +now rewrite IZR_Zpower_pos. +now rewrite IZR_Zpower_pos. +Qed. + +Theorem bpow_ge_0 : + forall e : Z, (0 <= bpow e)%R. +Proof. +intros. +rewrite bpow_powerRZ. +apply powerRZ_le. +apply radix_pos. +Qed. + +Theorem bpow_gt_0 : + forall e : Z, (0 < bpow e)%R. +Proof. +intros. +rewrite bpow_powerRZ. +apply powerRZ_lt. +apply radix_pos. +Qed. + +Theorem bpow_plus : + forall e1 e2 : Z, (bpow (e1 + e2) = bpow e1 * bpow e2)%R. +Proof. +intros. +repeat rewrite bpow_powerRZ. +apply powerRZ_add. +apply Rgt_not_eq. +apply radix_pos. +Qed. + +Theorem bpow_1 : + bpow 1 = IZR r. +Proof. +unfold bpow, Zpower_pos. simpl. +now rewrite Zmult_1_r. +Qed. + +Theorem bpow_plus_1 : + forall e : Z, (bpow (e + 1) = IZR r * bpow e)%R. +Proof. +intros. +rewrite <- bpow_1. +rewrite <- bpow_plus. +now rewrite Zplus_comm. +Qed. + +Theorem bpow_opp : + forall e : Z, (bpow (-e) = /bpow e)%R. +Proof. +intros [|p|p]. +apply eq_sym, Rinv_1. +now change (-Zpos p)%Z with (Zneg p). +change (-Zneg p)%Z with (Zpos p). +simpl; rewrite Rinv_involutive; trivial. +apply Rgt_not_eq. +apply (bpow_gt_0 (Zpos p)). +Qed. + +Theorem IZR_Zpower_nat : + forall e : nat, + IZR (Zpower_nat r e) = bpow (Z_of_nat e). +Proof. +intros [|e]. +split. +rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ. +rewrite <- Zpower_pos_nat. +now rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P. +Qed. + +Theorem IZR_Zpower : + forall e : Z, + (0 <= e)%Z -> + IZR (Zpower r e) = bpow e. +Proof. +intros [|e|e] H. +split. +split. +now elim H. +Qed. + +Theorem bpow_lt : + forall e1 e2 : Z, + (e1 < e2)%Z -> (bpow e1 < bpow e2)%R. +Proof. +intros e1 e2 H. +replace e2 with (e1 + (e2 - e1))%Z by ring. +rewrite <- (Rmult_1_r (bpow e1)). +rewrite bpow_plus. +apply Rmult_lt_compat_l. +apply bpow_gt_0. +assert (0 < e2 - e1)%Z by omega. +destruct (e2 - e1)%Z ; try discriminate H0. +clear. +rewrite <- IZR_Zpower by easy. +apply IZR_lt. +now apply Zpower_gt_1. +Qed. + +Theorem lt_bpow : + forall e1 e2 : Z, + (bpow e1 < bpow e2)%R -> (e1 < e2)%Z. +Proof. +intros e1 e2 H. +apply Z.gt_lt. +apply Znot_le_gt. +intros H'. +apply Rlt_not_le with (1 := H). +destruct (Zle_lt_or_eq _ _ H'). +apply Rlt_le. +now apply bpow_lt. +rewrite H0. +apply Rle_refl. +Qed. + +Theorem bpow_le : + forall e1 e2 : Z, + (e1 <= e2)%Z -> (bpow e1 <= bpow e2)%R. +Proof. +intros e1 e2 H. +apply Rnot_lt_le. +intros H'. +apply Zle_not_gt with (1 := H). +apply Z.lt_gt. +now apply lt_bpow. +Qed. + +Theorem le_bpow : + forall e1 e2 : Z, + (bpow e1 <= bpow e2)%R -> (e1 <= e2)%Z. +Proof. +intros e1 e2 H. +apply Znot_gt_le. +intros H'. +apply Rle_not_lt with (1 := H). +apply bpow_lt. +now apply Z.gt_lt. +Qed. + +Theorem bpow_inj : + forall e1 e2 : Z, + bpow e1 = bpow e2 -> e1 = e2. +Proof. +intros. +apply Zle_antisym. +apply le_bpow. +now apply Req_le. +apply le_bpow. +now apply Req_le. +Qed. + +Theorem bpow_exp : + forall e : Z, + bpow e = exp (IZR e * ln (IZR r)). +Proof. +(* positive case *) +assert (forall e, bpow (Zpos e) = exp (IZR (Zpos e) * ln (IZR r))). +intros e. +unfold bpow. +rewrite Zpower_pos_nat. +rewrite <- positive_nat_Z. +rewrite <- INR_IZR_INZ. +induction (nat_of_P e). +rewrite Rmult_0_l. +now rewrite exp_0. +rewrite Zpower_nat_S. +rewrite S_INR. +rewrite Rmult_plus_distr_r. +rewrite exp_plus. +rewrite Rmult_1_l. +rewrite exp_ln. +rewrite <- IHn. +rewrite <- mult_IZR. +now rewrite Zmult_comm. +apply radix_pos. +(* general case *) +intros [|e|e]. +rewrite Rmult_0_l. +now rewrite exp_0. +apply H. +unfold bpow. +change (IZR (Zpower_pos r e)) with (bpow (Zpos e)). +rewrite H. +rewrite <- exp_Ropp. +rewrite <- Ropp_mult_distr_l_reverse. +now rewrite <- opp_IZR. +Qed. + +Lemma sqrt_bpow : + forall e, + sqrt (bpow (2 * e)) = bpow e. +Proof. +intro e. +change 2%Z with (1 + 1)%Z; rewrite Z.mul_add_distr_r, Z.mul_1_l, bpow_plus. +apply sqrt_square, bpow_ge_0. +Qed. + +Lemma sqrt_bpow_ge : + forall e, + (bpow (e / 2) <= sqrt (bpow e))%R. +Proof. +intro e. +rewrite <- (sqrt_square (bpow _)); [|now apply bpow_ge_0]. +apply sqrt_le_1_alt; rewrite <- bpow_plus; apply bpow_le. +now replace (_ + _)%Z with (2 * (e / 2))%Z by ring; apply Z_mult_div_ge. +Qed. + +(** Another well-used function for having the magnitude of a real number x to the base #β# *) +Record mag_prop x := { + mag_val :> Z ; + _ : (x <> 0)%R -> (bpow (mag_val - 1)%Z <= Rabs x < bpow mag_val)%R +}. + +Definition mag : + forall x : R, mag_prop x. +Proof. +intros x. +set (fact := ln (IZR r)). +(* . *) +assert (0 < fact)%R. +apply exp_lt_inv. +rewrite exp_0. +unfold fact. +rewrite exp_ln. +apply IZR_lt. +apply radix_gt_1. +apply radix_pos. +(* . *) +exists (Zfloor (ln (Rabs x) / fact) + 1)%Z. +intros Hx'. +generalize (Rabs_pos_lt _ Hx'). clear Hx'. +generalize (Rabs x). clear x. +intros x Hx. +rewrite 2!bpow_exp. +fold fact. +pattern x at 2 3 ; replace x with (exp (ln x * / fact * fact)). +split. +rewrite minus_IZR. +apply exp_le. +apply Rmult_le_compat_r. +now apply Rlt_le. +unfold Rminus. +rewrite plus_IZR. +rewrite Rplus_assoc. +rewrite Rplus_opp_r, Rplus_0_r. +apply Zfloor_lb. +apply exp_increasing. +apply Rmult_lt_compat_r. +exact H. +rewrite plus_IZR. +apply Zfloor_ub. +rewrite Rmult_assoc. +rewrite Rinv_l. +rewrite Rmult_1_r. +now apply exp_ln. +now apply Rgt_not_eq. +Qed. + +Theorem bpow_lt_bpow : + forall e1 e2, + (bpow (e1 - 1) < bpow e2)%R -> + (e1 <= e2)%Z. +Proof. +intros e1 e2 He. +rewrite (Zsucc_pred e1). +apply Zlt_le_succ. +now apply lt_bpow. +Qed. + +Theorem bpow_unique : + forall x e1 e2, + (bpow (e1 - 1) <= x < bpow e1)%R -> + (bpow (e2 - 1) <= x < bpow e2)%R -> + e1 = e2. +Proof. +intros x e1 e2 (H1a,H1b) (H2a,H2b). +apply Zle_antisym ; + apply bpow_lt_bpow ; + apply Rle_lt_trans with x ; + assumption. +Qed. + +Theorem mag_unique : + forall (x : R) (e : Z), + (bpow (e - 1) <= Rabs x < bpow e)%R -> + mag x = e :> Z. +Proof. +intros x e1 He. +destruct (Req_dec x 0) as [Hx|Hx]. +elim Rle_not_lt with (1 := proj1 He). +rewrite Hx, Rabs_R0. +apply bpow_gt_0. +destruct (mag x) as (e2, Hx2). +simpl. +apply bpow_unique with (2 := He). +now apply Hx2. +Qed. + +Theorem mag_opp : + forall x, + mag (-x) = mag x :> Z. +Proof. +intros x. +destruct (Req_dec x 0) as [Hx|Hx]. +now rewrite Hx, Ropp_0. +destruct (mag x) as (e, He). +simpl. +specialize (He Hx). +apply mag_unique. +now rewrite Rabs_Ropp. +Qed. + +Theorem mag_abs : + forall x, + mag (Rabs x) = mag x :> Z. +Proof. +intros x. +unfold Rabs. +case Rcase_abs ; intros _. +apply mag_opp. +apply refl_equal. +Qed. + +Theorem mag_unique_pos : + forall (x : R) (e : Z), + (bpow (e - 1) <= x < bpow e)%R -> + mag x = e :> Z. +Proof. +intros x e1 He1. +rewrite <- mag_abs. +apply mag_unique. +rewrite 2!Rabs_pos_eq. +exact He1. +apply Rle_trans with (2 := proj1 He1). +apply bpow_ge_0. +apply Rabs_pos. +Qed. + +Theorem mag_le_abs : + forall x y, + (x <> 0)%R -> (Rabs x <= Rabs y)%R -> + (mag x <= mag y)%Z. +Proof. +intros x y H0x Hxy. +destruct (mag x) as (ex, Hx). +destruct (mag y) as (ey, Hy). +simpl. +apply bpow_lt_bpow. +specialize (Hx H0x). +apply Rle_lt_trans with (1 := proj1 Hx). +apply Rle_lt_trans with (1 := Hxy). +apply Hy. +intros Hy'. +apply Rlt_not_le with (1 := Rabs_pos_lt _ H0x). +apply Rle_trans with (1 := Hxy). +rewrite Hy', Rabs_R0. +apply Rle_refl. +Qed. + +Theorem mag_le : + forall x y, + (0 < x)%R -> (x <= y)%R -> + (mag x <= mag y)%Z. +Proof. +intros x y H0x Hxy. +apply mag_le_abs. +now apply Rgt_not_eq. +rewrite 2!Rabs_pos_eq. +exact Hxy. +apply Rle_trans with (2 := Hxy). +now apply Rlt_le. +now apply Rlt_le. +Qed. + +Lemma lt_mag : + forall x y, + (0 < y)%R -> + (mag x < mag y)%Z -> (x < y)%R. +Proof. +intros x y Py. +case (Rle_or_lt x 0); intros Px. +intros H. +now apply Rle_lt_trans with 0%R. +destruct (mag x) as (ex, Hex). +destruct (mag y) as (ey, Hey). +simpl. +intro H. +destruct Hex as (_,Hex); [now apply Rgt_not_eq|]. +destruct Hey as (Hey,_); [now apply Rgt_not_eq|]. +rewrite Rabs_right in Hex; [|now apply Rle_ge; apply Rlt_le]. +rewrite Rabs_right in Hey; [|now apply Rle_ge; apply Rlt_le]. +apply (Rlt_le_trans _ _ _ Hex). +apply Rle_trans with (bpow (ey - 1)); [|exact Hey]. +now apply bpow_le; omega. +Qed. + +Theorem mag_bpow : + forall e, (mag (bpow e) = e + 1 :> Z)%Z. +Proof. +intros e. +apply mag_unique. +rewrite Rabs_right. +replace (e + 1 - 1)%Z with e by ring. +split. +apply Rle_refl. +apply bpow_lt. +apply Zlt_succ. +apply Rle_ge. +apply bpow_ge_0. +Qed. + +Theorem mag_mult_bpow : + forall x e, x <> 0%R -> + (mag (x * bpow e) = mag x + e :>Z)%Z. +Proof. +intros x e Zx. +destruct (mag x) as (ex, Ex) ; simpl. +specialize (Ex Zx). +apply mag_unique. +rewrite Rabs_mult. +rewrite (Rabs_pos_eq (bpow e)) by apply bpow_ge_0. +split. +replace (ex + e - 1)%Z with (ex - 1 + e)%Z by ring. +rewrite bpow_plus. +apply Rmult_le_compat_r. +apply bpow_ge_0. +apply Ex. +rewrite bpow_plus. +apply Rmult_lt_compat_r. +apply bpow_gt_0. +apply Ex. +Qed. + +Theorem mag_le_bpow : + forall x e, + x <> 0%R -> + (Rabs x < bpow e)%R -> + (mag x <= e)%Z. +Proof. +intros x e Zx Hx. +destruct (mag x) as (ex, Ex) ; simpl. +specialize (Ex Zx). +apply bpow_lt_bpow. +now apply Rle_lt_trans with (Rabs x). +Qed. + +Theorem mag_gt_bpow : + forall x e, + (bpow e <= Rabs x)%R -> + (e < mag x)%Z. +Proof. +intros x e Hx. +destruct (mag x) as (ex, Ex) ; simpl. +apply lt_bpow. +apply Rle_lt_trans with (1 := Hx). +apply Ex. +intros Zx. +apply Rle_not_lt with (1 := Hx). +rewrite Zx, Rabs_R0. +apply bpow_gt_0. +Qed. + +Theorem mag_ge_bpow : + forall x e, + (bpow (e - 1) <= Rabs x)%R -> + (e <= mag x)%Z. +Proof. +intros x e H. +destruct (Rlt_or_le (Rabs x) (bpow e)) as [Hxe|Hxe]. +- (* Rabs x w bpow e *) + assert (mag x = e :> Z) as Hln. + now apply mag_unique; split. + rewrite Hln. + now apply Z.le_refl. +- (* bpow e <= Rabs x *) + apply Zlt_le_weak. + now apply mag_gt_bpow. +Qed. + +Theorem bpow_mag_gt : + forall x, + (Rabs x < bpow (mag x))%R. +Proof. +intros x. +destruct (Req_dec x 0) as [Zx|Zx]. +rewrite Zx, Rabs_R0. +apply bpow_gt_0. +destruct (mag x) as (ex, Ex) ; simpl. +now apply Ex. +Qed. + +Theorem bpow_mag_le : + forall x, (x <> 0)%R -> + (bpow (mag x-1) <= Rabs x)%R. +Proof. +intros x Hx. +destruct (mag x) as (ex, Ex) ; simpl. +now apply Ex. +Qed. + + +Theorem mag_le_Zpower : + forall m e, + m <> Z0 -> + (Z.abs m < Zpower r e)%Z-> + (mag (IZR m) <= e)%Z. +Proof. +intros m e Zm Hm. +apply mag_le_bpow. +now apply IZR_neq. +destruct (Zle_or_lt 0 e). +rewrite <- abs_IZR, <- IZR_Zpower with (1 := H). +now apply IZR_lt. +elim Zm. +cut (Z.abs m < 0)%Z. +now case m. +clear -Hm H. +now destruct e. +Qed. + +Theorem mag_gt_Zpower : + forall m e, + m <> Z0 -> + (Zpower r e <= Z.abs m)%Z -> + (e < mag (IZR m))%Z. +Proof. +intros m e Zm Hm. +apply mag_gt_bpow. +rewrite <- abs_IZR. +destruct (Zle_or_lt 0 e). +rewrite <- IZR_Zpower with (1 := H). +now apply IZR_le. +apply Rle_trans with (bpow 0). +apply bpow_le. +now apply Zlt_le_weak. +apply IZR_le. +clear -Zm. +zify ; omega. +Qed. + +Lemma mag_mult : + forall x y, + (x <> 0)%R -> (y <> 0)%R -> + (mag x + mag y - 1 <= mag (x * y) <= mag x + mag y)%Z. +Proof. +intros x y Hx Hy. +destruct (mag x) as (ex, Hx2). +destruct (mag y) as (ey, Hy2). +simpl. +destruct (Hx2 Hx) as (Hx21,Hx22); clear Hx2. +destruct (Hy2 Hy) as (Hy21,Hy22); clear Hy2. +assert (Hxy : (bpow (ex + ey - 1 - 1) <= Rabs (x * y))%R). +{ replace (ex + ey -1 -1)%Z with (ex - 1 + (ey - 1))%Z; [|ring]. + rewrite bpow_plus. + rewrite Rabs_mult. + now apply Rmult_le_compat; try apply bpow_ge_0. } +assert (Hxy2 : (Rabs (x * y) < bpow (ex + ey))%R). +{ rewrite Rabs_mult. + rewrite bpow_plus. + apply Rmult_le_0_lt_compat; try assumption. + now apply Rle_trans with (bpow (ex - 1)); try apply bpow_ge_0. + now apply Rle_trans with (bpow (ey - 1)); try apply bpow_ge_0. } +split. +- now apply mag_ge_bpow. +- apply mag_le_bpow. + + now apply Rmult_integral_contrapositive_currified. + + assumption. +Qed. + +Lemma mag_plus : + forall x y, + (0 < y)%R -> (y <= x)%R -> + (mag x <= mag (x + y) <= mag x + 1)%Z. +Proof. +assert (Hr : (2 <= r)%Z). +{ destruct r as (beta_val,beta_prop). + now apply Zle_bool_imp_le. } +intros x y Hy Hxy. +assert (Hx : (0 < x)%R) by apply (Rlt_le_trans _ _ _ Hy Hxy). +destruct (mag x) as (ex,Hex); simpl. +destruct Hex as (Hex0,Hex1); [now apply Rgt_not_eq|]. +assert (Haxy : (Rabs (x + y) < bpow (ex + 1))%R). +{ rewrite bpow_plus_1. + apply Rlt_le_trans with (2 * bpow ex)%R. + - rewrite Rabs_pos_eq. + apply Rle_lt_trans with (2 * Rabs x)%R. + + rewrite Rabs_pos_eq. + replace (2 * x)%R with (x + x)%R by ring. + now apply Rplus_le_compat_l. + now apply Rlt_le. + + apply Rmult_lt_compat_l with (2 := Hex1). + exact Rlt_0_2. + + rewrite <- (Rplus_0_l 0). + now apply Rlt_le, Rplus_lt_compat. + - apply Rmult_le_compat_r. + now apply bpow_ge_0. + now apply IZR_le. } +assert (Haxy2 : (bpow (ex - 1) <= Rabs (x + y))%R). +{ apply (Rle_trans _ _ _ Hex0). + rewrite Rabs_right; [|now apply Rgt_ge]. + apply Rabs_ge; right. + rewrite <- (Rplus_0_r x) at 1. + apply Rplus_le_compat_l. + now apply Rlt_le. } +split. +- now apply mag_ge_bpow. +- apply mag_le_bpow. + + now apply tech_Rplus; [apply Rlt_le|]. + + exact Haxy. +Qed. + +Lemma mag_minus : + forall x y, + (0 < y)%R -> (y < x)%R -> + (mag (x - y) <= mag x)%Z. +Proof. +intros x y Py Hxy. +assert (Px : (0 < x)%R) by apply (Rlt_trans _ _ _ Py Hxy). +apply mag_le. +- now apply Rlt_Rminus. +- rewrite <- (Rplus_0_r x) at 2. + apply Rplus_le_compat_l. + rewrite <- Ropp_0. + now apply Ropp_le_contravar; apply Rlt_le. +Qed. + +Lemma mag_minus_lb : + forall x y, + (0 < x)%R -> (0 < y)%R -> + (mag y <= mag x - 2)%Z -> + (mag x - 1 <= mag (x - y))%Z. +Proof. +assert (Hbeta : (2 <= r)%Z). +{ destruct r as (beta_val,beta_prop). + now apply Zle_bool_imp_le. } +intros x y Px Py Hln. +assert (Oxy : (y < x)%R); [apply lt_mag;[assumption|omega]|]. +destruct (mag x) as (ex,Hex). +destruct (mag y) as (ey,Hey). +simpl in Hln |- *. +destruct Hex as (Hex,_); [now apply Rgt_not_eq|]. +destruct Hey as (_,Hey); [now apply Rgt_not_eq|]. +assert (Hbx : (bpow (ex - 2) + bpow (ex - 2) <= x)%R). +{ ring_simplify. + apply Rle_trans with (bpow (ex - 1)). + - replace (ex - 1)%Z with (ex - 2 + 1)%Z by ring. + rewrite bpow_plus_1. + apply Rmult_le_compat_r; [now apply bpow_ge_0|]. + now apply IZR_le. + - now rewrite Rabs_right in Hex; [|apply Rle_ge; apply Rlt_le]. } +assert (Hby : (y < bpow (ex - 2))%R). +{ apply Rlt_le_trans with (bpow ey). + now rewrite Rabs_right in Hey; [|apply Rle_ge; apply Rlt_le]. + now apply bpow_le. } +assert (Hbxy : (bpow (ex - 2) <= x - y)%R). +{ apply Ropp_lt_contravar in Hby. + apply Rlt_le in Hby. + replace (bpow (ex - 2))%R with (bpow (ex - 2) + bpow (ex - 2) + - bpow (ex - 2))%R by ring. + now apply Rplus_le_compat. } +apply mag_ge_bpow. +replace (ex - 1 - 1)%Z with (ex - 2)%Z by ring. +now apply Rabs_ge; right. +Qed. + +Lemma mag_div : + forall x y : R, + x <> 0%R -> y <> 0%R -> + (mag x - mag y <= mag (x / y) <= mag x - mag y + 1)%Z. +Proof. +intros x y Px Py. +destruct (mag x) as (ex,Hex). +destruct (mag y) as (ey,Hey). +simpl. +unfold Rdiv. +assert (Heiy : (bpow (- ey) < Rabs (/ y) <= bpow (- ey + 1))%R). +{ rewrite Rabs_Rinv by easy. + split. + - rewrite bpow_opp. + apply Rinv_lt_contravar. + + apply Rmult_lt_0_compat. + now apply Rabs_pos_lt. + now apply bpow_gt_0. + + now apply Hey. + - replace (_ + _)%Z with (- (ey - 1))%Z by ring. + rewrite bpow_opp. + apply Rinv_le; [now apply bpow_gt_0|]. + now apply Hey. } +split. +- apply mag_ge_bpow. + replace (_ - _)%Z with (ex - 1 - ey)%Z by ring. + unfold Zminus at 1; rewrite bpow_plus. + rewrite Rabs_mult. + apply Rmult_le_compat. + + now apply bpow_ge_0. + + now apply bpow_ge_0. + + now apply Hex. + + now apply Rlt_le; apply Heiy. +- apply mag_le_bpow. + + apply Rmult_integral_contrapositive_currified. + exact Px. + now apply Rinv_neq_0_compat. + + replace (_ + 1)%Z with (ex + (- ey + 1))%Z by ring. + rewrite bpow_plus. + apply Rlt_le_trans with (bpow ex * Rabs (/ y))%R. + * rewrite Rabs_mult. + apply Rmult_lt_compat_r. + apply Rabs_pos_lt. + now apply Rinv_neq_0_compat. + now apply Hex. + * apply Rmult_le_compat_l; [now apply bpow_ge_0|]. + apply Heiy. +Qed. + +Lemma mag_sqrt : + forall x, + (0 < x)%R -> + mag (sqrt x) = Z.div2 (mag x + 1) :> Z. +Proof. +intros x Px. +apply mag_unique. +destruct mag as [e He]. +simpl. +specialize (He (Rgt_not_eq _ _ Px)). +rewrite Rabs_pos_eq in He by now apply Rlt_le. +split. +- rewrite <- (Rabs_pos_eq (bpow _)) by apply bpow_ge_0. + apply Rsqr_le_abs_0. + rewrite Rsqr_sqrt by now apply Rlt_le. + apply Rle_trans with (2 := proj1 He). + unfold Rsqr ; rewrite <- bpow_plus. + apply bpow_le. + generalize (Zdiv2_odd_eqn (e + 1)). + destruct Z.odd ; intros ; omega. +- rewrite <- (Rabs_pos_eq (bpow _)) by apply bpow_ge_0. + apply Rsqr_lt_abs_0. + rewrite Rsqr_sqrt by now apply Rlt_le. + apply Rlt_le_trans with (1 := proj2 He). + unfold Rsqr ; rewrite <- bpow_plus. + apply bpow_le. + generalize (Zdiv2_odd_eqn (e + 1)). + destruct Z.odd ; intros ; omega. +Qed. + +Lemma mag_1 : mag 1 = 1%Z :> Z. +Proof. +apply mag_unique_pos; rewrite bpow_1; simpl; split; [now right|apply IZR_lt]. +assert (H := Zle_bool_imp_le _ _ (radix_prop r)); revert H. +now apply Z.lt_le_trans. +Qed. + +End pow. + +Section Bool. + +Theorem eqb_sym : + forall x y, Bool.eqb x y = Bool.eqb y x. +Proof. +now intros [|] [|]. +Qed. + +Theorem eqb_false : + forall x y, x = negb y -> Bool.eqb x y = false. +Proof. +now intros [|] [|]. +Qed. + +Theorem eqb_true : + forall x y, x = y -> Bool.eqb x y = true. +Proof. +now intros [|] [|]. +Qed. + +End Bool. + +Section cond_Ropp. + +Definition cond_Ropp (b : bool) m := if b then Ropp m else m. + +Theorem IZR_cond_Zopp : + forall b m, + IZR (cond_Zopp b m) = cond_Ropp b (IZR m). +Proof. +intros [|] m. +apply opp_IZR. +apply refl_equal. +Qed. + +Theorem abs_cond_Ropp : + forall b m, + Rabs (cond_Ropp b m) = Rabs m. +Proof. +intros [|] m. +apply Rabs_Ropp. +apply refl_equal. +Qed. + +Theorem cond_Ropp_Rlt_bool : + forall m, + cond_Ropp (Rlt_bool m 0) m = Rabs m. +Proof. +intros m. +apply sym_eq. +case Rlt_bool_spec ; intros Hm. +now apply Rabs_left. +now apply Rabs_pos_eq. +Qed. + +Theorem cond_Ropp_involutive : + forall b x, + cond_Ropp b (cond_Ropp b x) = x. +Proof. +intros [|] x. +apply Ropp_involutive. +apply refl_equal. +Qed. + +Theorem cond_Ropp_inj : + forall b x y, + cond_Ropp b x = cond_Ropp b y -> x = y. +Proof. +intros b x y H. +rewrite <- (cond_Ropp_involutive b x), H. +apply cond_Ropp_involutive. +Qed. + +Theorem cond_Ropp_mult_l : + forall b x y, + cond_Ropp b (x * y) = (cond_Ropp b x * y)%R. +Proof. +intros [|] x y. +apply sym_eq. +apply Ropp_mult_distr_l_reverse. +apply refl_equal. +Qed. + +Theorem cond_Ropp_mult_r : + forall b x y, + cond_Ropp b (x * y) = (x * cond_Ropp b y)%R. +Proof. +intros [|] x y. +apply sym_eq. +apply Ropp_mult_distr_r_reverse. +apply refl_equal. +Qed. + +Theorem cond_Ropp_plus : + forall b x y, + cond_Ropp b (x + y) = (cond_Ropp b x + cond_Ropp b y)%R. +Proof. +intros [|] x y. +apply Ropp_plus_distr. +apply refl_equal. +Qed. + +End cond_Ropp. + + +(** LPO taken from Coquelicot *) + +Theorem LPO_min : + forall P : nat -> Prop, (forall n, P n \/ ~ P n) -> + {n : nat | P n /\ forall i, (i < n)%nat -> ~ P i} + {forall n, ~ P n}. +Proof. +assert (Hi: forall n, (0 < INR n + 1)%R). + intros N. + rewrite <- S_INR. + apply lt_0_INR. + apply lt_0_Sn. +intros P HP. +set (E y := exists n, (P n /\ y = / (INR n + 1))%R \/ (~ P n /\ y = 0)%R). +assert (HE: forall n, P n -> E (/ (INR n + 1))%R). + intros n Pn. + exists n. + left. + now split. +assert (BE: is_upper_bound E 1). + intros x [y [[_ ->]|[_ ->]]]. + rewrite <- Rinv_1 at 2. + apply Rinv_le. + exact Rlt_0_1. + rewrite <- S_INR. + apply (le_INR 1), le_n_S, le_0_n. + exact Rle_0_1. +destruct (completeness E) as [l [ub lub]]. + now exists 1%R. + destruct (HP O) as [H0|H0]. + exists 1%R. + exists O. + left. + apply (conj H0). + rewrite Rplus_0_l. + apply sym_eq, Rinv_1. + exists 0%R. + exists O. + right. + now split. +destruct (Rle_lt_dec l 0) as [Hl|Hl]. + right. + intros n Pn. + apply Rle_not_lt with (1 := Hl). + apply Rlt_le_trans with (/ (INR n + 1))%R. + now apply Rinv_0_lt_compat. + apply ub. + now apply HE. +left. +set (N := Z.abs_nat (up (/l) - 2)). +exists N. +assert (HN: (INR N + 1 = IZR (up (/ l)) - 1)%R). + unfold N. + rewrite INR_IZR_INZ. + rewrite inj_Zabs_nat. + replace (IZR (up (/ l)) - 1)%R with (IZR (up (/ l) - 2) + 1)%R. + apply (f_equal (fun v => IZR v + 1)%R). + apply Z.abs_eq. + apply Zle_minus_le_0. + apply (Zlt_le_succ 1). + apply lt_IZR. + apply Rle_lt_trans with (/l)%R. + apply Rmult_le_reg_r with (1 := Hl). + rewrite Rmult_1_l, Rinv_l by now apply Rgt_not_eq. + apply lub. + exact BE. + apply archimed. + rewrite minus_IZR. + simpl. + ring. +assert (H: forall i, (i < N)%nat -> ~ P i). + intros i HiN Pi. + unfold is_upper_bound in ub. + refine (Rle_not_lt _ _ (ub (/ (INR i + 1))%R _) _). + now apply HE. + rewrite <- (Rinv_involutive l) by now apply Rgt_not_eq. + apply Rinv_1_lt_contravar. + rewrite <- S_INR. + apply (le_INR 1). + apply le_n_S. + apply le_0_n. + apply Rlt_le_trans with (INR N + 1)%R. + apply Rplus_lt_compat_r. + now apply lt_INR. + rewrite HN. + apply Rplus_le_reg_r with (-/l + 1)%R. + ring_simplify. + apply archimed. +destruct (HP N) as [PN|PN]. + now split. +elimtype False. +refine (Rle_not_lt _ _ (lub (/ (INR (S N) + 1))%R _) _). + intros x [y [[Py ->]|[_ ->]]]. + destruct (eq_nat_dec y N) as [HyN|HyN]. + elim PN. + now rewrite <- HyN. + apply Rinv_le. + apply Hi. + apply Rplus_le_compat_r. + apply Rnot_lt_le. + intros Hy. + refine (H _ _ Py). + apply INR_lt in Hy. + clear -Hy HyN. + omega. + now apply Rlt_le, Rinv_0_lt_compat. +rewrite S_INR, HN. +ring_simplify (IZR (up (/ l)) - 1 + 1)%R. +rewrite <- (Rinv_involutive l) at 2 by now apply Rgt_not_eq. +apply Rinv_1_lt_contravar. +rewrite <- Rinv_1. +apply Rinv_le. +exact Hl. +now apply lub. +apply archimed. +Qed. + +Theorem LPO : + forall P : nat -> Prop, (forall n, P n \/ ~ P n) -> + {n : nat | P n} + {forall n, ~ P n}. +Proof. +intros P HP. +destruct (LPO_min P HP) as [[n [Pn _]]|Pn]. +left. +now exists n. +now right. +Qed. + + +Lemma LPO_Z : forall P : Z -> Prop, (forall n, P n \/ ~P n) -> + {n : Z| P n} + {forall n, ~ P n}. +Proof. +intros P H. +destruct (LPO (fun n => P (Z.of_nat n))) as [J|J]. +intros n; apply H. +destruct J as (n, Hn). +left; now exists (Z.of_nat n). +destruct (LPO (fun n => P (-Z.of_nat n)%Z)) as [K|K]. +intros n; apply H. +destruct K as (n, Hn). +left; now exists (-Z.of_nat n)%Z. +right; intros n; case (Zle_or_lt 0 n); intros M. +rewrite <- (Z.abs_eq n); trivial. +rewrite <- Zabs2Nat.id_abs. +apply J. +rewrite <- (Z.opp_involutive n). +rewrite <- (Z.abs_neq n). +rewrite <- Zabs2Nat.id_abs. +apply K. +omega. +Qed. + + + +(** A little tactic to simplify terms of the form [bpow a * bpow b]. *) +Ltac bpow_simplify := + (* bpow ex * bpow ey ~~> bpow (ex + ey) *) + repeat + match goal with + | |- context [(bpow _ _ * bpow _ _)] => + rewrite <- bpow_plus + | |- context [(?X1 * bpow _ _ * bpow _ _)] => + rewrite (Rmult_assoc X1); rewrite <- bpow_plus + | |- context [(?X1 * (?X2 * bpow _ _) * bpow _ _)] => + rewrite <- (Rmult_assoc X1 X2); rewrite (Rmult_assoc (X1 * X2)); + rewrite <- bpow_plus + end; + (* ring_simplify arguments of bpow *) + repeat + match goal with + | |- context [(bpow _ ?X)] => + progress ring_simplify X + end; + (* bpow 0 ~~> 1 *) + change (bpow _ 0) with 1; + repeat + match goal with + | |- context [(_ * 1)] => + rewrite Rmult_1_r + end. diff --git a/flocq/Core/Round_NE.v b/flocq/Core/Round_NE.v new file mode 100644 index 00000000..20b60ef5 --- /dev/null +++ b/flocq/Core/Round_NE.v @@ -0,0 +1,547 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2009-2018 Sylvie Boldo +#
# +Copyright (C) 2009-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +(** * Rounding to nearest, ties to even: existence, unicity... *) +Require Import Raux Defs Round_pred Generic_fmt Float_prop Ulp. + +Notation ZnearestE := (Znearest (fun x => negb (Z.even x))). + +Section Fcore_rnd_NE. + +Variable beta : radix. + +Notation bpow e := (bpow beta e). + +Variable fexp : Z -> Z. + +Context { valid_exp : Valid_exp fexp }. + +Notation format := (generic_format beta fexp). +Notation canonical := (canonical beta fexp). + +Definition NE_prop (_ : R) f := + exists g : float beta, f = F2R g /\ canonical g /\ Z.even (Fnum g) = true. + +Definition Rnd_NE_pt := + Rnd_NG_pt format NE_prop. + +Definition DN_UP_parity_pos_prop := + forall x xd xu, + (0 < x)%R -> + ~ format x -> + canonical xd -> + canonical xu -> + F2R xd = round beta fexp Zfloor x -> + F2R xu = round beta fexp Zceil x -> + Z.even (Fnum xu) = negb (Z.even (Fnum xd)). + +Definition DN_UP_parity_prop := + forall x xd xu, + ~ format x -> + canonical xd -> + canonical xu -> + F2R xd = round beta fexp Zfloor x -> + F2R xu = round beta fexp Zceil x -> + Z.even (Fnum xu) = negb (Z.even (Fnum xd)). + +Lemma DN_UP_parity_aux : + DN_UP_parity_pos_prop -> + DN_UP_parity_prop. +Proof. +intros Hpos x xd xu Hfx Hd Hu Hxd Hxu. +destruct (total_order_T 0 x) as [[Hx|Hx]|Hx]. +(* . *) +exact (Hpos x xd xu Hx Hfx Hd Hu Hxd Hxu). +elim Hfx. +rewrite <- Hx. +apply generic_format_0. +(* . *) +assert (Hx': (0 < -x)%R). +apply Ropp_lt_cancel. +now rewrite Ropp_involutive, Ropp_0. +destruct xd as (md, ed). +destruct xu as (mu, eu). +simpl. +rewrite <- (Bool.negb_involutive (Z.even mu)). +apply f_equal. +apply sym_eq. +rewrite <- (Z.even_opp mu), <- (Z.even_opp md). +change (Z.even (Fnum (Float beta (-md) ed)) = negb (Z.even (Fnum (Float beta (-mu) eu)))). +apply (Hpos (-x)%R _ _ Hx'). +intros H. +apply Hfx. +rewrite <- Ropp_involutive. +now apply generic_format_opp. +now apply canonical_opp. +now apply canonical_opp. +rewrite round_DN_opp, F2R_Zopp. +now apply f_equal. +rewrite round_UP_opp, F2R_Zopp. +now apply f_equal. +Qed. + +Class Exists_NE := + exists_NE : Z.even beta = false \/ forall e, + ((fexp e < e)%Z -> (fexp (e + 1) < e)%Z) /\ ((e <= fexp e)%Z -> fexp (fexp e + 1) = fexp e). + +Context { exists_NE_ : Exists_NE }. + +Theorem DN_UP_parity_generic_pos : + DN_UP_parity_pos_prop. +Proof with auto with typeclass_instances. +intros x xd xu H0x Hfx Hd Hu Hxd Hxu. +destruct (mag beta x) as (ex, Hexa). +specialize (Hexa (Rgt_not_eq _ _ H0x)). +generalize Hexa. intros Hex. +rewrite (Rabs_pos_eq _ (Rlt_le _ _ H0x)) in Hex. +destruct (Zle_or_lt ex (fexp ex)) as [Hxe|Hxe]. +(* small x *) +assert (Hd3 : Fnum xd = Z0). +apply eq_0_F2R with beta (Fexp xd). +change (F2R xd = R0). +rewrite Hxd. +apply round_DN_small_pos with (1 := Hex) (2 := Hxe). +assert (Hu3 : xu = Float beta (1 * Zpower beta (fexp ex - fexp (fexp ex + 1))) (fexp (fexp ex + 1))). +apply canonical_unique with (1 := Hu). +apply (f_equal fexp). +rewrite <- F2R_change_exp. +now rewrite F2R_bpow, mag_bpow. +now apply valid_exp. +rewrite <- F2R_change_exp. +rewrite F2R_bpow. +apply sym_eq. +rewrite Hxu. +apply sym_eq. +apply round_UP_small_pos with (1 := Hex) (2 := Hxe). +now apply valid_exp. +rewrite Hd3, Hu3. +rewrite Zmult_1_l. +simpl. +destruct exists_NE_ as [H|H]. +apply Zeven_Zpower_odd with (2 := H). +apply Zle_minus_le_0. +now apply valid_exp. +rewrite (proj2 (H ex)). +now rewrite Zminus_diag. +exact Hxe. +(* large x *) +assert (Hd4: (bpow (ex - 1) <= Rabs (F2R xd) < bpow ex)%R). +rewrite Rabs_pos_eq. +rewrite Hxd. +split. +apply (round_DN_pt beta fexp x). +apply generic_format_bpow. +ring_simplify (ex - 1 + 1)%Z. +omega. +apply Hex. +apply Rle_lt_trans with (2 := proj2 Hex). +apply (round_DN_pt beta fexp x). +rewrite Hxd. +apply (round_DN_pt beta fexp x). +apply generic_format_0. +now apply Rlt_le. +assert (Hxe2 : (fexp (ex + 1) <= ex)%Z) by now apply valid_exp. +assert (Hud: (F2R xu = F2R xd + ulp beta fexp x)%R). +rewrite Hxu, Hxd. +now apply round_UP_DN_ulp. +destruct (total_order_T (bpow ex) (F2R xu)) as [[Hu2|Hu2]|Hu2]. +(* - xu > bpow ex *) +elim (Rlt_not_le _ _ Hu2). +rewrite Hxu. +apply round_bounded_large_pos... +(* - xu = bpow ex *) +assert (Hu3: xu = Float beta (1 * Zpower beta (ex - fexp (ex + 1))) (fexp (ex + 1))). +apply canonical_unique with (1 := Hu). +apply (f_equal fexp). +rewrite <- F2R_change_exp. +now rewrite F2R_bpow, mag_bpow. +now apply valid_exp. +rewrite <- Hu2. +apply sym_eq. +rewrite <- F2R_change_exp. +apply F2R_bpow. +exact Hxe2. +assert (Hd3: xd = Float beta (Zpower beta (ex - fexp ex) - 1) (fexp ex)). +assert (H: F2R xd = F2R (Float beta (Zpower beta (ex - fexp ex) - 1) (fexp ex))). +unfold F2R. simpl. +rewrite minus_IZR. +unfold Rminus. +rewrite Rmult_plus_distr_r. +rewrite IZR_Zpower, <- bpow_plus. +ring_simplify (ex - fexp ex + fexp ex)%Z. +rewrite Hu2, Hud. +rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq]. +unfold cexp. +rewrite mag_unique with beta x ex. +unfold F2R. +simpl. ring. +rewrite Rabs_pos_eq. +exact Hex. +now apply Rlt_le. +apply Zle_minus_le_0. +now apply Zlt_le_weak. +apply canonical_unique with (1 := Hd) (3 := H). +apply (f_equal fexp). +rewrite <- H. +apply sym_eq. +now apply mag_unique. +rewrite Hd3, Hu3. +unfold Fnum. +rewrite Z.even_mul. simpl. +unfold Zminus at 2. +rewrite Z.even_add. +rewrite eqb_sym. simpl. +fold (negb (Z.even (beta ^ (ex - fexp ex)))). +rewrite Bool.negb_involutive. +rewrite (Z.even_pow beta (ex - fexp ex)). 2: omega. +destruct exists_NE_. +rewrite H. +apply Zeven_Zpower_odd with (2 := H). +now apply Zle_minus_le_0. +apply Z.even_pow. +specialize (H ex). +omega. +(* - xu < bpow ex *) +revert Hud. +rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq]. +unfold F2R. +rewrite Hd, Hu. +unfold cexp. +rewrite mag_unique with beta (F2R xu) ex. +rewrite mag_unique with (1 := Hd4). +rewrite mag_unique with (1 := Hexa). +intros H. +replace (Fnum xu) with (Fnum xd + 1)%Z. +rewrite Z.even_add. +now apply eqb_sym. +apply sym_eq. +apply eq_IZR. +rewrite plus_IZR. +apply Rmult_eq_reg_r with (bpow (fexp ex)). +rewrite H. +simpl. ring. +apply Rgt_not_eq. +apply bpow_gt_0. +rewrite Rabs_pos_eq. +split. +apply Rle_trans with (1 := proj1 Hex). +rewrite Hxu. +apply (round_UP_pt beta fexp x). +exact Hu2. +apply Rlt_le. +apply Rlt_le_trans with (1 := H0x). +rewrite Hxu. +apply (round_UP_pt beta fexp x). +Qed. + +Theorem DN_UP_parity_generic : + DN_UP_parity_prop. +Proof. +apply DN_UP_parity_aux. +apply DN_UP_parity_generic_pos. +Qed. + +Theorem Rnd_NE_pt_total : + round_pred_total Rnd_NE_pt. +Proof. +apply satisfies_any_imp_NG. +now apply generic_format_satisfies_any. +intros x d u Hf Hd Hu. +generalize (proj1 Hd). +unfold generic_format. +set (ed := cexp beta fexp d). +set (md := Ztrunc (scaled_mantissa beta fexp d)). +intros Hd1. +case_eq (Z.even md) ; [ intros He | intros Ho ]. +right. +exists (Float beta md ed). +unfold Generic_fmt.canonical. +rewrite <- Hd1. +now repeat split. +left. +generalize (proj1 Hu). +unfold generic_format. +set (eu := cexp beta fexp u). +set (mu := Ztrunc (scaled_mantissa beta fexp u)). +intros Hu1. +rewrite Hu1. +eexists ; repeat split. +unfold Generic_fmt.canonical. +now rewrite <- Hu1. +rewrite (DN_UP_parity_generic x (Float beta md ed) (Float beta mu eu)). +simpl. +now rewrite Ho. +exact Hf. +unfold Generic_fmt.canonical. +now rewrite <- Hd1. +unfold Generic_fmt.canonical. +now rewrite <- Hu1. +rewrite <- Hd1. +apply Rnd_DN_pt_unique with (1 := Hd). +now apply round_DN_pt. +rewrite <- Hu1. +apply Rnd_UP_pt_unique with (1 := Hu). +now apply round_UP_pt. +Qed. + +Theorem Rnd_NE_pt_monotone : + round_pred_monotone Rnd_NE_pt. +Proof. +apply Rnd_NG_pt_monotone. +intros x d u Hd Hdn Hu Hun (cd, (Hd1, Hd2)) (cu, (Hu1, Hu2)). +destruct (Req_dec x d) as [Hx|Hx]. +rewrite <- Hx. +apply sym_eq. +apply Rnd_UP_pt_idempotent with (1 := Hu). +rewrite Hx. +apply Hd. +rewrite (DN_UP_parity_aux DN_UP_parity_generic_pos x cd cu) in Hu2 ; try easy. +now rewrite (proj2 Hd2) in Hu2. +intros Hf. +apply Hx. +apply sym_eq. +now apply Rnd_DN_pt_idempotent with (1 := Hd). +rewrite <- Hd1. +apply Rnd_DN_pt_unique with (1 := Hd). +now apply round_DN_pt. +rewrite <- Hu1. +apply Rnd_UP_pt_unique with (1 := Hu). +now apply round_UP_pt. +Qed. + +Theorem Rnd_NE_pt_round : + round_pred Rnd_NE_pt. +Proof. +split. +apply Rnd_NE_pt_total. +apply Rnd_NE_pt_monotone. +Qed. + +Lemma round_NE_pt_pos : + forall x, + (0 < x)%R -> + Rnd_NE_pt x (round beta fexp ZnearestE x). +Proof with auto with typeclass_instances. +intros x Hx. +split. +now apply round_N_pt. +unfold NE_prop. +set (mx := scaled_mantissa beta fexp x). +set (xr := round beta fexp ZnearestE x). +destruct (Req_dec (mx - IZR (Zfloor mx)) (/2)) as [Hm|Hm]. +(* midpoint *) +left. +exists (Float beta (Ztrunc (scaled_mantissa beta fexp xr)) (cexp beta fexp xr)). +split. +apply round_N_pt... +split. +unfold Generic_fmt.canonical. simpl. +apply f_equal. +apply round_N_pt... +simpl. +unfold xr, round, Znearest. +fold mx. +rewrite Hm. +rewrite Rcompare_Eq. 2: apply refl_equal. +case_eq (Z.even (Zfloor mx)) ; intros Hmx. +(* . even floor *) +change (Z.even (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zfloor x))) = true). +destruct (Rle_or_lt (round beta fexp Zfloor x) 0) as [Hr|Hr]. +rewrite (Rle_antisym _ _ Hr). +unfold scaled_mantissa. +rewrite Rmult_0_l. +now rewrite Ztrunc_IZR. +rewrite <- (round_0 beta fexp Zfloor). +apply round_le... +now apply Rlt_le. +rewrite scaled_mantissa_DN... +now rewrite Ztrunc_IZR. +(* . odd floor *) +change (Z.even (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zceil x))) = true). +destruct (mag beta x) as (ex, Hex). +specialize (Hex (Rgt_not_eq _ _ Hx)). +rewrite (Rabs_pos_eq _ (Rlt_le _ _ Hx)) in Hex. +destruct (Z_lt_le_dec (fexp ex) ex) as [He|He]. +(* .. large pos *) +assert (Hu := round_bounded_large_pos _ _ Zceil _ _ He Hex). +assert (Hfc: Zceil mx = (Zfloor mx + 1)%Z). +apply Zceil_floor_neq. +intros H. +rewrite H in Hm. +unfold Rminus in Hm. +rewrite Rplus_opp_r in Hm. +elim (Rlt_irrefl 0). +rewrite Hm at 2. +apply Rinv_0_lt_compat. +now apply IZR_lt. +destruct (proj2 Hu) as [Hu'|Hu']. +(* ... u <> bpow *) +unfold scaled_mantissa. +rewrite cexp_fexp_pos with (1 := conj (proj1 Hu) Hu'). +unfold round, F2R. simpl. +rewrite cexp_fexp_pos with (1 := Hex). +rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r. +rewrite Ztrunc_IZR. +fold mx. +rewrite Hfc. +now rewrite Z.even_add, Hmx. +(* ... u = bpow *) +rewrite Hu'. +unfold scaled_mantissa, cexp. +rewrite mag_bpow. +rewrite <- bpow_plus, <- IZR_Zpower. +rewrite Ztrunc_IZR. +case_eq (Z.even beta) ; intros Hr. +destruct exists_NE_ as [Hs|Hs]. +now rewrite Hs in Hr. +destruct (Hs ex) as (H,_). +rewrite Z.even_pow. +exact Hr. +omega. +assert (Z.even (Zfloor mx) = true). 2: now rewrite H in Hmx. +replace (Zfloor mx) with (Zceil mx + -1)%Z by omega. +rewrite Z.even_add. +apply eqb_true. +unfold mx. +replace (Zceil (scaled_mantissa beta fexp x)) with (Zpower beta (ex - fexp ex)). +rewrite Zeven_Zpower_odd with (2 := Hr). +easy. +omega. +apply eq_IZR. +rewrite IZR_Zpower. 2: omega. +apply Rmult_eq_reg_r with (bpow (fexp ex)). +unfold Zminus. +rewrite bpow_plus. +rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_l, Rmult_1_r. +pattern (fexp ex) ; rewrite <- cexp_fexp_pos with (1 := Hex). +now apply sym_eq. +apply Rgt_not_eq. +apply bpow_gt_0. +generalize (proj1 (valid_exp ex) He). +omega. +(* .. small pos *) +assert (Z.even (Zfloor mx) = true). 2: now rewrite H in Hmx. +unfold mx, scaled_mantissa. +rewrite cexp_fexp_pos with (1 := Hex). +now rewrite mantissa_DN_small_pos. +(* not midpoint *) +right. +intros g Hg. +destruct (Req_dec x g) as [Hxg|Hxg]. +rewrite <- Hxg. +apply sym_eq. +apply round_generic... +rewrite Hxg. +apply Hg. +set (d := round beta fexp Zfloor x). +set (u := round beta fexp Zceil x). +apply Rnd_N_pt_unique with (d := d) (u := u) (4 := Hg). +now apply round_DN_pt. +now apply round_UP_pt. +2: now apply round_N_pt. +rewrite <- (scaled_mantissa_mult_bpow beta fexp x). +unfold d, u, round, F2R. simpl. fold mx. +rewrite <- 2!Rmult_minus_distr_r. +intros H. +apply Rmult_eq_reg_r in H. +apply Hm. +apply Rcompare_Eq_inv. +rewrite Rcompare_floor_ceil_middle. +now apply Rcompare_Eq. +contradict Hxg. +apply sym_eq. +apply Rnd_N_pt_idempotent with (1 := Hg). +rewrite <- (scaled_mantissa_mult_bpow beta fexp x). +fold mx. +rewrite <- Hxg. +change (IZR (Zfloor mx) * bpow (cexp beta fexp x))%R with d. +now eapply round_DN_pt. +apply Rgt_not_eq. +apply bpow_gt_0. +Qed. + +Theorem round_NE_opp : + forall x, + round beta fexp ZnearestE (-x) = (- round beta fexp ZnearestE x)%R. +Proof. +intros x. +unfold round. simpl. +rewrite scaled_mantissa_opp, cexp_opp. +rewrite Znearest_opp. +rewrite <- F2R_Zopp. +apply (f_equal (fun v => F2R (Float beta (-v) _))). +set (m := scaled_mantissa beta fexp x). +unfold Znearest. +case Rcompare ; trivial. +apply (f_equal (fun (b : bool) => if b then Zceil m else Zfloor m)). +rewrite Bool.negb_involutive. +rewrite Z.even_opp. +rewrite Z.even_add. +now rewrite eqb_sym. +Qed. + +Lemma round_NE_abs: + forall x : R, + round beta fexp ZnearestE (Rabs x) = Rabs (round beta fexp ZnearestE x). +Proof with auto with typeclass_instances. +intros x. +apply sym_eq. +unfold Rabs at 2. +destruct (Rcase_abs x) as [Hx|Hx]. +rewrite round_NE_opp. +apply Rabs_left1. +rewrite <- (round_0 beta fexp ZnearestE). +apply round_le... +now apply Rlt_le. +apply Rabs_pos_eq. +rewrite <- (round_0 beta fexp ZnearestE). +apply round_le... +now apply Rge_le. +Qed. + +Theorem round_NE_pt : + forall x, + Rnd_NE_pt x (round beta fexp ZnearestE x). +Proof with auto with typeclass_instances. +intros x. +destruct (total_order_T x 0) as [[Hx|Hx]|Hx]. +apply Rnd_NG_pt_opp_inv. +apply generic_format_opp. +unfold NE_prop. +intros _ f ((mg,eg),(H1,(H2,H3))). +exists (Float beta (- mg) eg). +repeat split. +rewrite H1. +now rewrite F2R_Zopp. +now apply canonical_opp. +simpl. +now rewrite Z.even_opp. +rewrite <- round_NE_opp. +apply round_NE_pt_pos. +now apply Ropp_0_gt_lt_contravar. +rewrite Hx, round_0... +apply Rnd_NG_pt_refl. +apply generic_format_0. +now apply round_NE_pt_pos. +Qed. + +End Fcore_rnd_NE. + +(** Notations for backward-compatibility with Flocq 1.4. *) +Notation rndNE := ZnearestE (only parsing). diff --git a/flocq/Core/Round_pred.v b/flocq/Core/Round_pred.v new file mode 100644 index 00000000..428a4bac --- /dev/null +++ b/flocq/Core/Round_pred.v @@ -0,0 +1,1408 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2009-2018 Sylvie Boldo +#
# +Copyright (C) 2009-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +(** * Roundings: properties and/or functions *) +Require Import Raux Defs. + +Section RND_prop. + +Open Scope R_scope. + +Definition Rnd_DN (F : R -> Prop) (rnd : R -> R) := + forall x : R, Rnd_DN_pt F x (rnd x). + +Definition Rnd_UP (F : R -> Prop) (rnd : R -> R) := + forall x : R, Rnd_UP_pt F x (rnd x). + +Definition Rnd_ZR (F : R -> Prop) (rnd : R -> R) := + forall x : R, Rnd_ZR_pt F x (rnd x). + +Definition Rnd_N (F : R -> Prop) (rnd : R -> R) := + forall x : R, Rnd_N_pt F x (rnd x). + +Definition Rnd_NG (F : R -> Prop) (P : R -> R -> Prop) (rnd : R -> R) := + forall x : R, Rnd_NG_pt F P x (rnd x). + +Definition Rnd_NA (F : R -> Prop) (rnd : R -> R) := + forall x : R, Rnd_NA_pt F x (rnd x). + +Theorem round_val_of_pred : + forall rnd : R -> R -> Prop, + round_pred rnd -> + forall x, { f : R | rnd x f }. +Proof. +intros rnd (H1,H2) x. +specialize (H1 x). +(* . *) +assert (H3 : bound (rnd x)). +destruct H1 as (f, H1). +exists f. +intros g Hg. +now apply H2 with (3 := Rle_refl x). +(* . *) +exists (proj1_sig (completeness _ H3 H1)). +destruct completeness as (f1, (H4, H5)). +simpl. +destruct H1 as (f2, H1). +assert (f1 = f2). +apply Rle_antisym. +apply H5. +intros f3 H. +now apply H2 with (3 := Rle_refl x). +now apply H4. +now rewrite H. +Qed. + +Theorem round_fun_of_pred : + forall rnd : R -> R -> Prop, + round_pred rnd -> + { f : R -> R | forall x, rnd x (f x) }. +Proof. +intros rnd H. +exists (fun x => proj1_sig (round_val_of_pred rnd H x)). +intros x. +now destruct round_val_of_pred as (f, H1). +Qed. + +Theorem round_unique : + forall rnd : R -> R -> Prop, + round_pred_monotone rnd -> + forall x f1 f2, + rnd x f1 -> + rnd x f2 -> + f1 = f2. +Proof. +intros rnd Hr x f1 f2 H1 H2. +apply Rle_antisym. +now apply Hr with (3 := Rle_refl x). +now apply Hr with (3 := Rle_refl x). +Qed. + +Theorem Rnd_DN_pt_monotone : + forall F : R -> Prop, + round_pred_monotone (Rnd_DN_pt F). +Proof. +intros F x y f g (Hx1,(Hx2,_)) (Hy1,(_,Hy2)) Hxy. +apply Hy2. +apply Hx1. +now apply Rle_trans with (2 := Hxy). +Qed. + +Theorem Rnd_DN_pt_unique : + forall F : R -> Prop, + forall x f1 f2 : R, + Rnd_DN_pt F x f1 -> Rnd_DN_pt F x f2 -> + f1 = f2. +Proof. +intros F. +apply round_unique. +apply Rnd_DN_pt_monotone. +Qed. + +Theorem Rnd_DN_unique : + forall F : R -> Prop, + forall rnd1 rnd2 : R -> R, + Rnd_DN F rnd1 -> Rnd_DN F rnd2 -> + forall x, rnd1 x = rnd2 x. +Proof. +intros F rnd1 rnd2 H1 H2 x. +now eapply Rnd_DN_pt_unique. +Qed. + +Theorem Rnd_UP_pt_monotone : + forall F : R -> Prop, + round_pred_monotone (Rnd_UP_pt F). +Proof. +intros F x y f g (Hx1,(_,Hx2)) (Hy1,(Hy2,_)) Hxy. +apply Hx2. +apply Hy1. +now apply Rle_trans with (1 := Hxy). +Qed. + +Theorem Rnd_UP_pt_unique : + forall F : R -> Prop, + forall x f1 f2 : R, + Rnd_UP_pt F x f1 -> Rnd_UP_pt F x f2 -> + f1 = f2. +Proof. +intros F. +apply round_unique. +apply Rnd_UP_pt_monotone. +Qed. + +Theorem Rnd_UP_unique : + forall F : R -> Prop, + forall rnd1 rnd2 : R -> R, + Rnd_UP F rnd1 -> Rnd_UP F rnd2 -> + forall x, rnd1 x = rnd2 x. +Proof. +intros F rnd1 rnd2 H1 H2 x. +now eapply Rnd_UP_pt_unique. +Qed. + +Theorem Rnd_UP_pt_opp : + forall F : R -> Prop, + ( forall x, F x -> F (- x) ) -> + forall x f : R, + Rnd_DN_pt F x f -> Rnd_UP_pt F (-x) (-f). +Proof. +intros F HF x f H. +repeat split. +apply HF. +apply H. +apply Ropp_le_contravar. +apply H. +intros g Hg. +rewrite <- (Ropp_involutive g). +intros Hxg. +apply Ropp_le_contravar. +apply H. +now apply HF. +now apply Ropp_le_cancel. +Qed. + +Theorem Rnd_DN_pt_opp : + forall F : R -> Prop, + ( forall x, F x -> F (- x) ) -> + forall x f : R, + Rnd_UP_pt F x f -> Rnd_DN_pt F (-x) (-f). +Proof. +intros F HF x f H. +repeat split. +apply HF. +apply H. +apply Ropp_le_contravar. +apply H. +intros g Hg. +rewrite <- (Ropp_involutive g). +intros Hxg. +apply Ropp_le_contravar. +apply H. +now apply HF. +now apply Ropp_le_cancel. +Qed. + +Theorem Rnd_DN_opp : + forall F : R -> Prop, + ( forall x, F x -> F (- x) ) -> + forall rnd1 rnd2 : R -> R, + Rnd_DN F rnd1 -> Rnd_UP F rnd2 -> + forall x, rnd1 (- x) = - rnd2 x. +Proof. +intros F HF rnd1 rnd2 H1 H2 x. +rewrite <- (Ropp_involutive (rnd1 (-x))). +apply f_equal. +apply (Rnd_UP_unique F (fun x => - rnd1 (-x))) ; trivial. +intros y. +pattern y at 1 ; rewrite <- Ropp_involutive. +apply Rnd_UP_pt_opp. +apply HF. +apply H1. +Qed. + +Theorem Rnd_DN_UP_pt_split : + forall F : R -> Prop, + forall x d u, + Rnd_DN_pt F x d -> + Rnd_UP_pt F x u -> + forall f, F f -> + (f <= d) \/ (u <= f). +Proof. +intros F x d u Hd Hu f Hf. +destruct (Rle_or_lt f x). +left. +now apply Hd. +right. +assert (H' := Rlt_le _ _ H). +now apply Hu. +Qed. + +Theorem Rnd_DN_pt_refl : + forall F : R -> Prop, + forall x : R, F x -> + Rnd_DN_pt F x x. +Proof. +intros F x Hx. +repeat split. +exact Hx. +apply Rle_refl. +now intros. +Qed. + +Theorem Rnd_DN_pt_idempotent : + forall F : R -> Prop, + forall x f : R, + Rnd_DN_pt F x f -> F x -> + f = x. +Proof. +intros F x f (_,(Hx1,Hx2)) Hx. +apply Rle_antisym. +exact Hx1. +apply Hx2. +exact Hx. +apply Rle_refl. +Qed. + +Theorem Rnd_UP_pt_refl : + forall F : R -> Prop, + forall x : R, F x -> + Rnd_UP_pt F x x. +Proof. +intros F x Hx. +repeat split. +exact Hx. +apply Rle_refl. +now intros. +Qed. + +Theorem Rnd_UP_pt_idempotent : + forall F : R -> Prop, + forall x f : R, + Rnd_UP_pt F x f -> F x -> + f = x. +Proof. +intros F x f (_,(Hx1,Hx2)) Hx. +apply Rle_antisym. +apply Hx2. +exact Hx. +apply Rle_refl. +exact Hx1. +Qed. + +Theorem Only_DN_or_UP : + forall F : R -> Prop, + forall x fd fu f : R, + Rnd_DN_pt F x fd -> Rnd_UP_pt F x fu -> + F f -> (fd <= f <= fu)%R -> + f = fd \/ f = fu. +Proof. +intros F x fd fu f Hd Hu Hf [Hdf Hfu]. +destruct (Rle_or_lt x f) ; [right|left]. +apply Rle_antisym with (1 := Hfu). +now apply Hu. +apply Rlt_le in H. +apply Rle_antisym with (2 := Hdf). +now apply Hd. +Qed. + +Theorem Rnd_ZR_abs : + forall (F : R -> Prop) (rnd: R-> R), + Rnd_ZR F rnd -> + forall x : R, (Rabs (rnd x) <= Rabs x)%R. +Proof. +intros F rnd H x. +assert (F 0%R). +replace 0%R with (rnd 0%R). +eapply H. +apply Rle_refl. +destruct (H 0%R) as (H1, H2). +apply Rle_antisym. +apply H1. +apply Rle_refl. +apply H2. +apply Rle_refl. +(* . *) +destruct (Rle_or_lt 0 x). +(* positive *) +rewrite Rabs_pos_eq with (1 := H1). +rewrite Rabs_pos_eq. +now apply (proj1 (H x)). +now apply (proj1 (H x)). +(* negative *) +apply Rlt_le in H1. +rewrite Rabs_left1 with (1 := H1). +rewrite Rabs_left1. +apply Ropp_le_contravar. +now apply (proj2 (H x)). +now apply (proj2 (H x)). +Qed. + +Theorem Rnd_ZR_pt_monotone : + forall F : R -> Prop, F 0 -> + round_pred_monotone (Rnd_ZR_pt F). +Proof. +intros F F0 x y f g (Hx1, Hx2) (Hy1, Hy2) Hxy. +destruct (Rle_or_lt 0 x) as [Hx|Hx]. +(* . *) +apply Hy1. +now apply Rle_trans with x. +now apply Hx1. +apply Rle_trans with (2 := Hxy). +now apply Hx1. +(* . *) +apply Rlt_le in Hx. +destruct (Rle_or_lt 0 y) as [Hy|Hy]. +apply Rle_trans with 0. +now apply Hx2. +now apply Hy1. +apply Rlt_le in Hy. +apply Hx2. +exact Hx. +now apply Hy2. +apply Rle_trans with (1 := Hxy). +now apply Hy2. +Qed. + +Theorem Rnd_N_pt_DN_or_UP : + forall F : R -> Prop, + forall x f : R, + Rnd_N_pt F x f -> + Rnd_DN_pt F x f \/ Rnd_UP_pt F x f. +Proof. +intros F x f (Hf1,Hf2). +destruct (Rle_or_lt x f) as [Hxf|Hxf]. +(* . *) +right. +repeat split ; try assumption. +intros g Hg Hxg. +specialize (Hf2 g Hg). +rewrite 2!Rabs_pos_eq in Hf2. +now apply Rplus_le_reg_r with (-x)%R. +now apply Rle_0_minus. +now apply Rle_0_minus. +(* . *) +left. +repeat split ; try assumption. +now apply Rlt_le. +intros g Hg Hxg. +specialize (Hf2 g Hg). +rewrite 2!Rabs_left1 in Hf2. +generalize (Ropp_le_cancel _ _ Hf2). +intros H. +now apply Rplus_le_reg_r with (-x)%R. +now apply Rle_minus. +apply Rlt_le. +now apply Rlt_minus. +Qed. + +Theorem Rnd_N_pt_DN_or_UP_eq : + forall F : R -> Prop, + forall x fd fu f : R, + Rnd_DN_pt F x fd -> Rnd_UP_pt F x fu -> + Rnd_N_pt F x f -> + f = fd \/ f = fu. +Proof. +intros F x fd fu f Hd Hu Hf. +destruct (Rnd_N_pt_DN_or_UP F x f Hf) as [H|H]. +left. +apply Rnd_DN_pt_unique with (1 := H) (2 := Hd). +right. +apply Rnd_UP_pt_unique with (1 := H) (2 := Hu). +Qed. + +Theorem Rnd_N_pt_opp_inv : + forall F : R -> Prop, + ( forall x, F x -> F (- x) ) -> + forall x f : R, + Rnd_N_pt F (-x) (-f) -> Rnd_N_pt F x f. +Proof. +intros F HF x f (H1,H2). +rewrite <- (Ropp_involutive f). +repeat split. +apply HF. +apply H1. +intros g H3. +rewrite Ropp_involutive. +replace (f - x)%R with (-(-f - -x))%R by ring. +replace (g - x)%R with (-(-g - -x))%R by ring. +rewrite 2!Rabs_Ropp. +apply H2. +now apply HF. +Qed. + +Theorem Rnd_N_pt_monotone : + forall F : R -> Prop, + forall x y f g : R, + Rnd_N_pt F x f -> Rnd_N_pt F y g -> + x < y -> f <= g. +Proof. +intros F x y f g (Hf,Hx) (Hg,Hy) Hxy. +apply Rnot_lt_le. +intros Hgf. +assert (Hfgx := Hx g Hg). +assert (Hgfy := Hy f Hf). +clear F Hf Hg Hx Hy. +destruct (Rle_or_lt x g) as [Hxg|Hgx]. +(* x <= g < f *) +apply Rle_not_lt with (1 := Hfgx). +rewrite 2!Rabs_pos_eq. +now apply Rplus_lt_compat_r. +apply Rle_0_minus. +apply Rlt_le. +now apply Rle_lt_trans with (1 := Hxg). +now apply Rle_0_minus. +assert (Hgy := Rlt_trans _ _ _ Hgx Hxy). +destruct (Rle_or_lt f y) as [Hfy|Hyf]. +(* g < f <= y *) +apply Rle_not_lt with (1 := Hgfy). +rewrite (Rabs_left (g - y)). +2: now apply Rlt_minus. +rewrite Rabs_left1. +apply Ropp_lt_contravar. +now apply Rplus_lt_compat_r. +now apply Rle_minus. +(* g < x < y < f *) +rewrite Rabs_left, Rabs_pos_eq, Ropp_minus_distr in Hgfy. +rewrite Rabs_pos_eq, Rabs_left, Ropp_minus_distr in Hfgx. +apply Rle_not_lt with (1 := Rplus_le_compat _ _ _ _ Hfgx Hgfy). +apply Rminus_lt. +ring_simplify. +apply Rlt_minus. +apply Rmult_lt_compat_l. +now apply IZR_lt. +exact Hxy. +now apply Rlt_minus. +apply Rle_0_minus. +apply Rlt_le. +now apply Rlt_trans with (1 := Hxy). +apply Rle_0_minus. +now apply Rlt_le. +now apply Rlt_minus. +Qed. + +Theorem Rnd_N_pt_unique : + forall F : R -> Prop, + forall x d u f1 f2 : R, + Rnd_DN_pt F x d -> + Rnd_UP_pt F x u -> + x - d <> u - x -> + Rnd_N_pt F x f1 -> + Rnd_N_pt F x f2 -> + f1 = f2. +Proof. +intros F x d u f1 f2 Hd Hu Hdu. +assert (forall f1 f2, Rnd_N_pt F x f1 -> Rnd_N_pt F x f2 -> f1 < f2 -> False). +clear f1 f2. intros f1 f2 Hf1 Hf2 H12. +destruct (Rnd_N_pt_DN_or_UP F x f1 Hf1) as [Hd1|Hu1] ; + destruct (Rnd_N_pt_DN_or_UP F x f2 Hf2) as [Hd2|Hu2]. +apply Rlt_not_eq with (1 := H12). +now apply Rnd_DN_pt_unique with (1 := Hd1). +apply Hdu. +rewrite Rnd_DN_pt_unique with (1 := Hd) (2 := Hd1). +rewrite Rnd_UP_pt_unique with (1 := Hu) (2 := Hu2). +rewrite <- (Rabs_pos_eq (x - f1)). +rewrite <- (Rabs_pos_eq (f2 - x)). +rewrite Rabs_minus_sym. +apply Rle_antisym. +apply Hf1. apply Hf2. +apply Hf2. apply Hf1. +apply Rle_0_minus. +apply Hu2. +apply Rle_0_minus. +apply Hd1. +apply Rlt_not_le with (1 := H12). +apply Rle_trans with x. +apply Hd2. +apply Hu1. +apply Rgt_not_eq with (1 := H12). +now apply Rnd_UP_pt_unique with (1 := Hu2). +intros Hf1 Hf2. +now apply Rle_antisym ; apply Rnot_lt_le ; refine (H _ _ _ _). +Qed. + +Theorem Rnd_N_pt_refl : + forall F : R -> Prop, + forall x : R, F x -> + Rnd_N_pt F x x. +Proof. +intros F x Hx. +repeat split. +exact Hx. +intros g _. +unfold Rminus at 1. +rewrite Rplus_opp_r, Rabs_R0. +apply Rabs_pos. +Qed. + +Theorem Rnd_N_pt_idempotent : + forall F : R -> Prop, + forall x f : R, + Rnd_N_pt F x f -> F x -> + f = x. +Proof. +intros F x f (_,Hf) Hx. +apply Rminus_diag_uniq. +destruct (Req_dec (f - x) 0) as [H|H]. +exact H. +elim Rabs_no_R0 with (1 := H). +apply Rle_antisym. +replace 0 with (Rabs (x - x)). +now apply Hf. +unfold Rminus. +rewrite Rplus_opp_r. +apply Rabs_R0. +apply Rabs_pos. +Qed. + +Theorem Rnd_N_pt_0 : + forall F : R -> Prop, + F 0 -> + Rnd_N_pt F 0 0. +Proof. +intros F HF. +split. +exact HF. +intros g _. +rewrite 2!Rminus_0_r, Rabs_R0. +apply Rabs_pos. +Qed. + +Theorem Rnd_N_pt_ge_0 : + forall F : R -> Prop, F 0 -> + forall x f, 0 <= x -> + Rnd_N_pt F x f -> + 0 <= f. +Proof. +intros F HF x f [Hx|Hx] Hxf. +eapply Rnd_N_pt_monotone ; try eassumption. +now apply Rnd_N_pt_0. +right. +apply sym_eq. +apply Rnd_N_pt_idempotent with F. +now rewrite Hx. +exact HF. +Qed. + +Theorem Rnd_N_pt_le_0 : + forall F : R -> Prop, F 0 -> + forall x f, x <= 0 -> + Rnd_N_pt F x f -> + f <= 0. +Proof. +intros F HF x f [Hx|Hx] Hxf. +eapply Rnd_N_pt_monotone ; try eassumption. +now apply Rnd_N_pt_0. +right. +apply Rnd_N_pt_idempotent with F. +now rewrite <- Hx. +exact HF. +Qed. + +Theorem Rnd_N_pt_abs : + forall F : R -> Prop, + F 0 -> + ( forall x, F x -> F (- x) ) -> + forall x f : R, + Rnd_N_pt F x f -> Rnd_N_pt F (Rabs x) (Rabs f). +Proof. +intros F HF0 HF x f Hxf. +unfold Rabs at 1. +destruct (Rcase_abs x) as [Hx|Hx]. +rewrite Rabs_left1. +apply Rnd_N_pt_opp_inv. +exact HF. +now rewrite 2!Ropp_involutive. +apply Rnd_N_pt_le_0 with (3 := Hxf). +exact HF0. +now apply Rlt_le. +rewrite Rabs_pos_eq. +exact Hxf. +apply Rnd_N_pt_ge_0 with (3 := Hxf). +exact HF0. +now apply Rge_le. +Qed. + +Theorem Rnd_N_pt_DN_UP : + forall F : R -> Prop, + forall x d u f : R, + F f -> + Rnd_DN_pt F x d -> + Rnd_UP_pt F x u -> + (Rabs (f - x) <= x - d)%R -> + (Rabs (f - x) <= u - x)%R -> + Rnd_N_pt F x f. +Proof. +intros F x d u f Hf Hxd Hxu Hd Hu. +split. +exact Hf. +intros g Hg. +destruct (Rnd_DN_UP_pt_split F x d u Hxd Hxu g Hg) as [Hgd|Hgu]. +(* g <= d *) +apply Rle_trans with (1 := Hd). +rewrite Rabs_left1. +rewrite Ropp_minus_distr. +apply Rplus_le_compat_l. +now apply Ropp_le_contravar. +apply Rle_minus. +apply Rle_trans with (1 := Hgd). +apply Hxd. +(* u <= g *) +apply Rle_trans with (1 := Hu). +rewrite Rabs_pos_eq. +now apply Rplus_le_compat_r. +apply Rle_0_minus. +apply Rle_trans with (2 := Hgu). +apply Hxu. +Qed. + +Theorem Rnd_N_pt_DN : + forall F : R -> Prop, + forall x d u : R, + Rnd_DN_pt F x d -> + Rnd_UP_pt F x u -> + (x - d <= u - x)%R -> + Rnd_N_pt F x d. +Proof. +intros F x d u Hd Hu Hx. +assert (Hdx: (Rabs (d - x) = x - d)%R). +rewrite Rabs_minus_sym. +apply Rabs_pos_eq. +apply Rle_0_minus. +apply Hd. +apply Rnd_N_pt_DN_UP with (2 := Hd) (3 := Hu). +apply Hd. +rewrite Hdx. +apply Rle_refl. +now rewrite Hdx. +Qed. + +Theorem Rnd_N_pt_UP : + forall F : R -> Prop, + forall x d u : R, + Rnd_DN_pt F x d -> + Rnd_UP_pt F x u -> + (u - x <= x - d)%R -> + Rnd_N_pt F x u. +Proof. +intros F x d u Hd Hu Hx. +assert (Hux: (Rabs (u - x) = u - x)%R). +apply Rabs_pos_eq. +apply Rle_0_minus. +apply Hu. +apply Rnd_N_pt_DN_UP with (2 := Hd) (3 := Hu). +apply Hu. +now rewrite Hux. +rewrite Hux. +apply Rle_refl. +Qed. + +Definition Rnd_NG_pt_unique_prop F P := + forall x d u, + Rnd_DN_pt F x d -> Rnd_N_pt F x d -> + Rnd_UP_pt F x u -> Rnd_N_pt F x u -> + P x d -> P x u -> d = u. + +Theorem Rnd_NG_pt_unique : + forall (F : R -> Prop) (P : R -> R -> Prop), + Rnd_NG_pt_unique_prop F P -> + forall x f1 f2 : R, + Rnd_NG_pt F P x f1 -> Rnd_NG_pt F P x f2 -> + f1 = f2. +Proof. +intros F P HP x f1 f2 (H1a,H1b) (H2a,H2b). +destruct H1b as [H1b|H1b]. +destruct H2b as [H2b|H2b]. +destruct (Rnd_N_pt_DN_or_UP _ _ _ H1a) as [H1c|H1c] ; + destruct (Rnd_N_pt_DN_or_UP _ _ _ H2a) as [H2c|H2c]. +eapply Rnd_DN_pt_unique ; eassumption. +now apply (HP x f1 f2). +apply sym_eq. +now apply (HP x f2 f1 H2c H2a H1c H1a). +eapply Rnd_UP_pt_unique ; eassumption. +now apply H2b. +apply sym_eq. +now apply H1b. +Qed. + +Theorem Rnd_NG_pt_monotone : + forall (F : R -> Prop) (P : R -> R -> Prop), + Rnd_NG_pt_unique_prop F P -> + round_pred_monotone (Rnd_NG_pt F P). +Proof. +intros F P HP x y f g (Hf,Hx) (Hg,Hy) [Hxy|Hxy]. +now apply Rnd_N_pt_monotone with F x y. +apply Req_le. +rewrite <- Hxy in Hg, Hy. +eapply Rnd_NG_pt_unique ; try split ; eassumption. +Qed. + +Theorem Rnd_NG_pt_refl : + forall (F : R -> Prop) (P : R -> R -> Prop), + forall x, F x -> Rnd_NG_pt F P x x. +Proof. +intros F P x Hx. +split. +now apply Rnd_N_pt_refl. +right. +intros f2 Hf2. +now apply Rnd_N_pt_idempotent with F. +Qed. + +Theorem Rnd_NG_pt_opp_inv : + forall (F : R -> Prop) (P : R -> R -> Prop), + ( forall x, F x -> F (-x) ) -> + ( forall x f, P x f -> P (-x) (-f) ) -> + forall x f : R, + Rnd_NG_pt F P (-x) (-f) -> Rnd_NG_pt F P x f. +Proof. +intros F P HF HP x f (H1,H2). +split. +now apply Rnd_N_pt_opp_inv. +destruct H2 as [H2|H2]. +left. +rewrite <- (Ropp_involutive x), <- (Ropp_involutive f). +now apply HP. +right. +intros f2 Hxf2. +rewrite <- (Ropp_involutive f). +rewrite <- H2 with (-f2). +apply sym_eq. +apply Ropp_involutive. +apply Rnd_N_pt_opp_inv. +exact HF. +now rewrite 2!Ropp_involutive. +Qed. + +Theorem Rnd_NG_unique : + forall (F : R -> Prop) (P : R -> R -> Prop), + Rnd_NG_pt_unique_prop F P -> + forall rnd1 rnd2 : R -> R, + Rnd_NG F P rnd1 -> Rnd_NG F P rnd2 -> + forall x, rnd1 x = rnd2 x. +Proof. +intros F P HP rnd1 rnd2 H1 H2 x. +now apply Rnd_NG_pt_unique with F P x. +Qed. + +Theorem Rnd_NA_NG_pt : + forall F : R -> Prop, + F 0 -> + forall x f, + Rnd_NA_pt F x f <-> Rnd_NG_pt F (fun x f => Rabs x <= Rabs f) x f. +Proof. +intros F HF x f. +destruct (Rle_or_lt 0 x) as [Hx|Hx]. +(* *) +split ; intros (H1, H2). +(* . *) +assert (Hf := Rnd_N_pt_ge_0 F HF x f Hx H1). +split. +exact H1. +destruct (Rnd_N_pt_DN_or_UP _ _ _ H1) as [H3|H3]. +(* . . *) +right. +intros f2 Hxf2. +specialize (H2 _ Hxf2). +destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H4|H4]. +eapply Rnd_DN_pt_unique ; eassumption. +apply Rle_antisym. +rewrite Rabs_pos_eq with (1 := Hf) in H2. +rewrite Rabs_pos_eq in H2. +exact H2. +now apply Rnd_N_pt_ge_0 with F x. +apply Rle_trans with x. +apply H3. +apply H4. +(* . . *) +left. +rewrite Rabs_pos_eq with (1 := Hf). +rewrite Rabs_pos_eq with (1 := Hx). +apply H3. +(* . *) +split. +exact H1. +intros f2 Hxf2. +destruct H2 as [H2|H2]. +assert (Hf := Rnd_N_pt_ge_0 F HF x f Hx H1). +assert (Hf2 := Rnd_N_pt_ge_0 F HF x f2 Hx Hxf2). +rewrite 2!Rabs_pos_eq ; trivial. +rewrite 2!Rabs_pos_eq in H2 ; trivial. +destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H3|H3]. +apply Rle_trans with (2 := H2). +apply H3. +apply H3. +apply H1. +apply H2. +rewrite (H2 _ Hxf2). +apply Rle_refl. +(* *) +assert (Hx' := Rlt_le _ _ Hx). +clear Hx. rename Hx' into Hx. +split ; intros (H1, H2). +(* . *) +assert (Hf := Rnd_N_pt_le_0 F HF x f Hx H1). +split. +exact H1. +destruct (Rnd_N_pt_DN_or_UP _ _ _ H1) as [H3|H3]. +(* . . *) +left. +rewrite Rabs_left1 with (1 := Hf). +rewrite Rabs_left1 with (1 := Hx). +apply Ropp_le_contravar. +apply H3. +(* . . *) +right. +intros f2 Hxf2. +specialize (H2 _ Hxf2). +destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H4|H4]. +apply Rle_antisym. +apply Rle_trans with x. +apply H4. +apply H3. +rewrite Rabs_left1 with (1 := Hf) in H2. +rewrite Rabs_left1 in H2. +now apply Ropp_le_cancel. +now apply Rnd_N_pt_le_0 with F x. +eapply Rnd_UP_pt_unique ; eassumption. +(* . *) +split. +exact H1. +intros f2 Hxf2. +destruct H2 as [H2|H2]. +assert (Hf := Rnd_N_pt_le_0 F HF x f Hx H1). +assert (Hf2 := Rnd_N_pt_le_0 F HF x f2 Hx Hxf2). +rewrite 2!Rabs_left1 ; trivial. +rewrite 2!Rabs_left1 in H2 ; trivial. +apply Ropp_le_contravar. +apply Ropp_le_cancel in H2. +destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H3|H3]. +apply H3. +apply H1. +apply H2. +apply Rle_trans with (1 := H2). +apply H3. +rewrite (H2 _ Hxf2). +apply Rle_refl. +Qed. + +Lemma Rnd_NA_pt_unique_prop : + forall F : R -> Prop, + F 0 -> + Rnd_NG_pt_unique_prop F (fun a b => (Rabs a <= Rabs b)%R). +Proof. +intros F HF x d u Hxd1 Hxd2 Hxu1 Hxu2 Hd Hu. +apply Rle_antisym. +apply Rle_trans with x. +apply Hxd1. +apply Hxu1. +destruct (Rle_or_lt 0 x) as [Hx|Hx]. +apply Hxu1. +apply Hxd1. +rewrite Rabs_pos_eq with (1 := Hx) in Hd. +rewrite Rabs_pos_eq in Hd. +exact Hd. +now apply Hxd1. +apply Hxd1. +apply Hxu1. +rewrite Rabs_left with (1 := Hx) in Hu. +rewrite Rabs_left1 in Hu. +now apply Ropp_le_cancel. +apply Hxu1. +apply HF. +now apply Rlt_le. +Qed. + +Theorem Rnd_NA_pt_unique : + forall F : R -> Prop, + F 0 -> + forall x f1 f2 : R, + Rnd_NA_pt F x f1 -> Rnd_NA_pt F x f2 -> + f1 = f2. +Proof. +intros F HF x f1 f2 H1 H2. +apply (Rnd_NG_pt_unique F _ (Rnd_NA_pt_unique_prop F HF) x). +now apply -> Rnd_NA_NG_pt. +now apply -> Rnd_NA_NG_pt. +Qed. + +Theorem Rnd_NA_pt_N : + forall F : R -> Prop, + F 0 -> + forall x f : R, + Rnd_N_pt F x f -> + (Rabs x <= Rabs f)%R -> + Rnd_NA_pt F x f. +Proof. +intros F HF x f Rxf Hxf. +split. +apply Rxf. +intros g Rxg. +destruct (Rabs_eq_Rabs (f - x) (g - x)) as [H|H]. +apply Rle_antisym. +apply Rxf. +apply Rxg. +apply Rxg. +apply Rxf. +(* *) +replace g with f. +apply Rle_refl. +apply Rplus_eq_reg_r with (1 := H). +(* *) +assert (g = 2 * x - f)%R. +replace (2 * x - f)%R with (x - (f - x))%R by ring. +rewrite H. +ring. +destruct (Rle_lt_dec 0 x) as [Hx|Hx]. +(* . *) +revert Hxf. +rewrite Rabs_pos_eq with (1 := Hx). +rewrite 2!Rabs_pos_eq ; try ( apply (Rnd_N_pt_ge_0 F HF x) ; assumption ). +intros Hxf. +rewrite H0. +apply Rplus_le_reg_r with f. +ring_simplify. +apply Rmult_le_compat_l with (2 := Hxf). +now apply IZR_le. +(* . *) +revert Hxf. +apply Rlt_le in Hx. +rewrite Rabs_left1 with (1 := Hx). +rewrite 2!Rabs_left1 ; try ( apply (Rnd_N_pt_le_0 F HF x) ; assumption ). +intros Hxf. +rewrite H0. +apply Ropp_le_contravar. +apply Rplus_le_reg_r with f. +ring_simplify. +apply Rmult_le_compat_l. +now apply IZR_le. +now apply Ropp_le_cancel. +Qed. + +Theorem Rnd_NA_unique : + forall (F : R -> Prop), + F 0 -> + forall rnd1 rnd2 : R -> R, + Rnd_NA F rnd1 -> Rnd_NA F rnd2 -> + forall x, rnd1 x = rnd2 x. +Proof. +intros F HF rnd1 rnd2 H1 H2 x. +now apply Rnd_NA_pt_unique with F x. +Qed. + +Theorem Rnd_NA_pt_monotone : + forall F : R -> Prop, + F 0 -> + round_pred_monotone (Rnd_NA_pt F). +Proof. +intros F HF x y f g Hxf Hyg Hxy. +apply (Rnd_NG_pt_monotone F _ (Rnd_NA_pt_unique_prop F HF) x y). +now apply -> Rnd_NA_NG_pt. +now apply -> Rnd_NA_NG_pt. +exact Hxy. +Qed. + +Theorem Rnd_NA_pt_refl : + forall F : R -> Prop, + forall x : R, F x -> + Rnd_NA_pt F x x. +Proof. +intros F x Hx. +split. +now apply Rnd_N_pt_refl. +intros f Hxf. +apply Req_le. +apply f_equal. +now apply Rnd_N_pt_idempotent with (1 := Hxf). +Qed. + +Theorem Rnd_NA_pt_idempotent : + forall F : R -> Prop, + forall x f : R, + Rnd_NA_pt F x f -> F x -> + f = x. +Proof. +intros F x f (Hf,_) Hx. +now apply Rnd_N_pt_idempotent with F. +Qed. + +Theorem round_pred_ge_0 : + forall P : R -> R -> Prop, + round_pred_monotone P -> + P 0 0 -> + forall x f, P x f -> 0 <= x -> 0 <= f. +Proof. +intros P HP HP0 x f Hxf Hx. +now apply (HP 0 x). +Qed. + +Theorem round_pred_gt_0 : + forall P : R -> R -> Prop, + round_pred_monotone P -> + P 0 0 -> + forall x f, P x f -> 0 < f -> 0 < x. +Proof. +intros P HP HP0 x f Hxf Hf. +apply Rnot_le_lt. +intros Hx. +apply Rlt_not_le with (1 := Hf). +now apply (HP x 0). +Qed. + +Theorem round_pred_le_0 : + forall P : R -> R -> Prop, + round_pred_monotone P -> + P 0 0 -> + forall x f, P x f -> x <= 0 -> f <= 0. +Proof. +intros P HP HP0 x f Hxf Hx. +now apply (HP x 0). +Qed. + +Theorem round_pred_lt_0 : + forall P : R -> R -> Prop, + round_pred_monotone P -> + P 0 0 -> + forall x f, P x f -> f < 0 -> x < 0. +Proof. +intros P HP HP0 x f Hxf Hf. +apply Rnot_le_lt. +intros Hx. +apply Rlt_not_le with (1 := Hf). +now apply (HP 0 x). +Qed. + +Theorem Rnd_DN_pt_equiv_format : + forall F1 F2 : R -> Prop, + forall a b : R, + F1 a -> + ( forall x, a <= x <= b -> (F1 x <-> F2 x) ) -> + forall x f, a <= x <= b -> Rnd_DN_pt F1 x f -> Rnd_DN_pt F2 x f. +Proof. +intros F1 F2 a b Ha HF x f Hx (H1, (H2, H3)). +split. +apply -> HF. +exact H1. +split. +now apply H3. +now apply Rle_trans with (1 := H2). +split. +exact H2. +intros k Hk Hl. +destruct (Rlt_or_le k a) as [H|H]. +apply Rlt_le. +apply Rlt_le_trans with (1 := H). +now apply H3. +apply H3. +apply <- HF. +exact Hk. +split. +exact H. +now apply Rle_trans with (1 := Hl). +exact Hl. +Qed. + +Theorem Rnd_UP_pt_equiv_format : + forall F1 F2 : R -> Prop, + forall a b : R, + F1 b -> + ( forall x, a <= x <= b -> (F1 x <-> F2 x) ) -> + forall x f, a <= x <= b -> Rnd_UP_pt F1 x f -> Rnd_UP_pt F2 x f. +Proof. +intros F1 F2 a b Hb HF x f Hx (H1, (H2, H3)). +split. +apply -> HF. +exact H1. +split. +now apply Rle_trans with (2 := H2). +now apply H3. +split. +exact H2. +intros k Hk Hl. +destruct (Rle_or_lt k b) as [H|H]. +apply H3. +apply <- HF. +exact Hk. +split. +now apply Rle_trans with (2 := Hl). +exact H. +exact Hl. +apply Rlt_le. +apply Rle_lt_trans with (2 := H). +now apply H3. +Qed. + +(** ensures a real number can always be rounded *) +Inductive satisfies_any (F : R -> Prop) := + Satisfies_any : + F 0 -> ( forall x : R, F x -> F (-x) ) -> + round_pred_total (Rnd_DN_pt F) -> satisfies_any F. + +Theorem satisfies_any_eq : + forall F1 F2 : R -> Prop, + ( forall x, F1 x <-> F2 x ) -> + satisfies_any F1 -> + satisfies_any F2. +Proof. +intros F1 F2 Heq (Hzero, Hsym, Hrnd). +split. +now apply -> Heq. +intros x Hx. +apply -> Heq. +apply Hsym. +now apply <- Heq. +intros x. +destruct (Hrnd x) as (f, (H1, (H2, H3))). +exists f. +split. +now apply -> Heq. +split. +exact H2. +intros g Hg Hgx. +apply H3. +now apply <- Heq. +exact Hgx. +Qed. + +Theorem satisfies_any_imp_DN : + forall F : R -> Prop, + satisfies_any F -> + round_pred (Rnd_DN_pt F). +Proof. +intros F (_,_,Hrnd). +split. +apply Hrnd. +apply Rnd_DN_pt_monotone. +Qed. + +Theorem satisfies_any_imp_UP : + forall F : R -> Prop, + satisfies_any F -> + round_pred (Rnd_UP_pt F). +Proof. +intros F Hany. +split. +intros x. +destruct (proj1 (satisfies_any_imp_DN F Hany) (-x)) as (f, Hf). +exists (-f). +rewrite <- (Ropp_involutive x). +apply Rnd_UP_pt_opp. +apply Hany. +exact Hf. +apply Rnd_UP_pt_monotone. +Qed. + +Theorem satisfies_any_imp_ZR : + forall F : R -> Prop, + satisfies_any F -> + round_pred (Rnd_ZR_pt F). +Proof. +intros F Hany. +split. +intros x. +destruct (Rle_or_lt 0 x) as [Hx|Hx]. +(* positive *) +destruct (proj1 (satisfies_any_imp_DN F Hany) x) as (f, Hf). +exists f. +split. +now intros _. +intros Hx'. +(* zero *) +assert (x = 0). +now apply Rle_antisym. +rewrite H in Hf |- *. +clear H Hx Hx'. +rewrite Rnd_DN_pt_idempotent with (1 := Hf). +apply Rnd_UP_pt_refl. +apply Hany. +apply Hany. +(* negative *) +destruct (proj1 (satisfies_any_imp_UP F Hany) x) as (f, Hf). +exists f. +split. +intros Hx'. +elim (Rlt_irrefl 0). +now apply Rle_lt_trans with x. +now intros _. +(* . *) +apply Rnd_ZR_pt_monotone. +apply Hany. +Qed. + +Definition NG_existence_prop (F : R -> Prop) (P : R -> R -> Prop) := + forall x d u, ~F x -> Rnd_DN_pt F x d -> Rnd_UP_pt F x u -> P x u \/ P x d. + +Theorem satisfies_any_imp_NG : + forall (F : R -> Prop) (P : R -> R -> Prop), + satisfies_any F -> + NG_existence_prop F P -> + round_pred_total (Rnd_NG_pt F P). +Proof. +intros F P Hany HP x. +destruct (proj1 (satisfies_any_imp_DN F Hany) x) as (d, Hd). +destruct (proj1 (satisfies_any_imp_UP F Hany) x) as (u, Hu). +destruct (total_order_T (Rabs (u - x)) (Rabs (d - x))) as [[H|H]|H]. +(* |up(x) - x| < |dn(x) - x| *) +exists u. +split. +(* - . *) +split. +apply Hu. +intros g Hg. +destruct (Rle_or_lt x g) as [Hxg|Hxg]. +rewrite 2!Rabs_pos_eq. +apply Rplus_le_compat_r. +now apply Hu. +now apply Rle_0_minus. +apply Rle_0_minus. +apply Hu. +apply Rlt_le in Hxg. +apply Rlt_le. +apply Rlt_le_trans with (1 := H). +do 2 rewrite <- (Rabs_minus_sym x). +rewrite 2!Rabs_pos_eq. +apply Rplus_le_compat_l. +apply Ropp_le_contravar. +now apply Hd. +now apply Rle_0_minus. +apply Rle_0_minus. +apply Hd. +(* - . *) +right. +intros f Hf. +destruct (Rnd_N_pt_DN_or_UP_eq F x _ _ _ Hd Hu Hf) as [K|K] ; rewrite K. +elim Rlt_not_le with (1 := H). +rewrite <- K. +apply Hf. +apply Hu. +apply refl_equal. +(* |up(x) - x| = |dn(x) - x| *) +destruct (Req_dec x d) as [He|Hne]. +(* - x = d = u *) +exists x. +split. +apply Rnd_N_pt_refl. +rewrite He. +apply Hd. +right. +intros. +apply Rnd_N_pt_idempotent with (1 := H0). +rewrite He. +apply Hd. +assert (Hf : ~F x). +intros Hf. +apply Hne. +apply sym_eq. +now apply Rnd_DN_pt_idempotent with (1 := Hd). +destruct (HP x _ _ Hf Hd Hu) as [H'|H']. +(* - u >> d *) +exists u. +split. +split. +apply Hu. +intros g Hg. +destruct (Rle_or_lt x g) as [Hxg|Hxg]. +rewrite 2!Rabs_pos_eq. +apply Rplus_le_compat_r. +now apply Hu. +now apply Rle_0_minus. +apply Rle_0_minus. +apply Hu. +apply Rlt_le in Hxg. +rewrite H. +rewrite 2!Rabs_left1. +apply Ropp_le_contravar. +apply Rplus_le_compat_r. +now apply Hd. +now apply Rle_minus. +apply Rle_minus. +apply Hd. +now left. +(* - d >> u *) +exists d. +split. +split. +apply Hd. +intros g Hg. +destruct (Rle_or_lt x g) as [Hxg|Hxg]. +rewrite <- H. +rewrite 2!Rabs_pos_eq. +apply Rplus_le_compat_r. +now apply Hu. +now apply Rle_0_minus. +apply Rle_0_minus. +apply Hu. +apply Rlt_le in Hxg. +rewrite 2!Rabs_left1. +apply Ropp_le_contravar. +apply Rplus_le_compat_r. +now apply Hd. +now apply Rle_minus. +apply Rle_minus. +apply Hd. +now left. +(* |up(x) - x| > |dn(x) - x| *) +exists d. +split. +split. +apply Hd. +intros g Hg. +destruct (Rle_or_lt x g) as [Hxg|Hxg]. +apply Rlt_le. +apply Rlt_le_trans with (1 := H). +rewrite 2!Rabs_pos_eq. +apply Rplus_le_compat_r. +now apply Hu. +now apply Rle_0_minus. +apply Rle_0_minus. +apply Hu. +apply Rlt_le in Hxg. +rewrite 2!Rabs_left1. +apply Ropp_le_contravar. +apply Rplus_le_compat_r. +now apply Hd. +now apply Rle_minus. +apply Rle_minus. +apply Hd. +right. +intros f Hf. +destruct (Rnd_N_pt_DN_or_UP_eq F x _ _ _ Hd Hu Hf) as [K|K] ; rewrite K. +apply refl_equal. +elim Rlt_not_le with (1 := H). +rewrite <- K. +apply Hf. +apply Hd. +Qed. + +Theorem satisfies_any_imp_NA : + forall F : R -> Prop, + satisfies_any F -> + round_pred (Rnd_NA_pt F). +Proof. +intros F Hany. +split. +assert (H : round_pred_total (Rnd_NG_pt F (fun a b => (Rabs a <= Rabs b)%R))). +apply satisfies_any_imp_NG. +apply Hany. +intros x d u Hf Hd Hu. +destruct (Rle_lt_dec 0 x) as [Hx|Hx]. +left. +rewrite Rabs_pos_eq with (1 := Hx). +rewrite Rabs_pos_eq. +apply Hu. +apply Rle_trans with (1 := Hx). +apply Hu. +right. +rewrite Rabs_left with (1 := Hx). +rewrite Rabs_left1. +apply Ropp_le_contravar. +apply Hd. +apply Rlt_le in Hx. +apply Rle_trans with (2 := Hx). +apply Hd. +intros x. +destruct (H x) as (f, Hf). +exists f. +apply <- Rnd_NA_NG_pt. +apply Hf. +apply Hany. +apply Rnd_NA_pt_monotone. +apply Hany. +Qed. + +End RND_prop. diff --git a/flocq/Core/Ulp.v b/flocq/Core/Ulp.v new file mode 100644 index 00000000..4f4a5674 --- /dev/null +++ b/flocq/Core/Ulp.v @@ -0,0 +1,2521 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2009-2018 Sylvie Boldo +#
# +Copyright (C) 2009-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +(** * Unit in the Last Place: our definition using fexp and its properties, successor and predecessor *) +Require Import Reals Psatz. +Require Import Raux Defs Round_pred Generic_fmt Float_prop. + +Section Fcore_ulp. + +Variable beta : radix. + +Notation bpow e := (bpow beta e). + +Variable fexp : Z -> Z. + +(** Definition and basic properties about the minimal exponent, when it exists *) + +Lemma Z_le_dec_aux: forall x y : Z, (x <= y)%Z \/ ~ (x <= y)%Z. +Proof. +intros. +destruct (Z_le_dec x y). +now left. +now right. +Qed. + +(** [negligible_exp] is either none (as in FLX) or Some n such that n <= fexp n. *) +Definition negligible_exp: option Z := + match (LPO_Z _ (fun z => Z_le_dec_aux z (fexp z))) with + | inleft N => Some (proj1_sig N) + | inright _ => None + end. + + +Inductive negligible_exp_prop: option Z -> Prop := + | negligible_None: (forall n, (fexp n < n)%Z) -> negligible_exp_prop None + | negligible_Some: forall n, (n <= fexp n)%Z -> negligible_exp_prop (Some n). + + +Lemma negligible_exp_spec: negligible_exp_prop negligible_exp. +Proof. +unfold negligible_exp; destruct LPO_Z as [(n,Hn)|Hn]. +now apply negligible_Some. +apply negligible_None. +intros n; specialize (Hn n); omega. +Qed. + +Lemma negligible_exp_spec': (negligible_exp = None /\ forall n, (fexp n < n)%Z) + \/ exists n, (negligible_exp = Some n /\ (n <= fexp n)%Z). +Proof. +unfold negligible_exp; destruct LPO_Z as [(n,Hn)|Hn]. +right; simpl; exists n; now split. +left; split; trivial. +intros n; specialize (Hn n); omega. +Qed. + +Context { valid_exp : Valid_exp fexp }. + +Lemma fexp_negligible_exp_eq: forall n m, (n <= fexp n)%Z -> (m <= fexp m)%Z -> fexp n = fexp m. +Proof. +intros n m Hn Hm. +case (Zle_or_lt n m); intros H. +apply valid_exp; omega. +apply sym_eq, valid_exp; omega. +Qed. + + +(** Definition and basic properties about the ulp *) +(** Now includes a nice ulp(0): ulp(0) is now 0 when there is no minimal + exponent, such as in FLX, and beta^(fexp n) when there is a n such + that n <= fexp n. For instance, the value of ulp(O) is then + beta^emin in FIX and FLT. The main lemma to use is ulp_neq_0 that + is equivalent to the previous "unfold ulp" provided the value is + not zero. *) + +Definition ulp x := match Req_bool x 0 with + | true => match negligible_exp with + | Some n => bpow (fexp n) + | None => 0%R + end + | false => bpow (cexp beta fexp x) + end. + +Lemma ulp_neq_0 : + forall x, x <> 0%R -> + ulp x = bpow (cexp beta fexp x). +Proof. +intros x Hx. +unfold ulp; case (Req_bool_spec x); trivial. +intros H; now contradict H. +Qed. + +Notation F := (generic_format beta fexp). + +Theorem ulp_opp : + forall x, ulp (- x) = ulp x. +Proof. +intros x. +unfold ulp. +case Req_bool_spec; intros H1. +rewrite Req_bool_true; trivial. +rewrite <- (Ropp_involutive x), H1; ring. +rewrite Req_bool_false. +now rewrite cexp_opp. +intros H2; apply H1; rewrite H2; ring. +Qed. + +Theorem ulp_abs : + forall x, ulp (Rabs x) = ulp x. +Proof. +intros x. +unfold ulp; case (Req_bool_spec x 0); intros H1. +rewrite Req_bool_true; trivial. +now rewrite H1, Rabs_R0. +rewrite Req_bool_false. +now rewrite cexp_abs. +now apply Rabs_no_R0. +Qed. + +Theorem ulp_ge_0: + forall x, (0 <= ulp x)%R. +Proof. +intros x; unfold ulp; case Req_bool_spec; intros. +case negligible_exp; intros. +apply bpow_ge_0. +apply Rle_refl. +apply bpow_ge_0. +Qed. + + +Theorem ulp_le_id: + forall x, + (0 < x)%R -> + F x -> + (ulp x <= x)%R. +Proof. +intros x Zx Fx. +rewrite <- (Rmult_1_l (ulp x)). +pattern x at 2; rewrite Fx. +rewrite ulp_neq_0. +2: now apply Rgt_not_eq. +unfold F2R; simpl. +apply Rmult_le_compat_r. +apply bpow_ge_0. +apply IZR_le, (Zlt_le_succ 0). +apply gt_0_F2R with beta (cexp beta fexp x). +now rewrite <- Fx. +Qed. + +Theorem ulp_le_abs: + forall x, + (x <> 0)%R -> + F x -> + (ulp x <= Rabs x)%R. +Proof. +intros x Zx Fx. +rewrite <- ulp_abs. +apply ulp_le_id. +now apply Rabs_pos_lt. +now apply generic_format_abs. +Qed. + +Theorem round_UP_DN_ulp : + forall x, ~ F x -> + round beta fexp Zceil x = (round beta fexp Zfloor x + ulp x)%R. +Proof. +intros x Fx. +rewrite ulp_neq_0. +unfold round. simpl. +unfold F2R. simpl. +rewrite Zceil_floor_neq. +rewrite plus_IZR. simpl. +ring. +intros H. +apply Fx. +unfold generic_format, F2R. simpl. +rewrite <- H. +rewrite Ztrunc_IZR. +rewrite H. +now rewrite scaled_mantissa_mult_bpow. +intros V; apply Fx. +rewrite V. +apply generic_format_0. +Qed. + + +Theorem ulp_bpow : + forall e, ulp (bpow e) = bpow (fexp (e + 1)). +Proof. +intros e. +rewrite ulp_neq_0. +apply f_equal. +apply cexp_fexp. +rewrite Rabs_pos_eq. +split. +ring_simplify (e + 1 - 1)%Z. +apply Rle_refl. +apply bpow_lt. +apply Zlt_succ. +apply bpow_ge_0. +apply Rgt_not_eq, Rlt_gt, bpow_gt_0. +Qed. + + +Lemma generic_format_ulp_0 : + F (ulp 0). +Proof. +unfold ulp. +rewrite Req_bool_true; trivial. +case negligible_exp_spec. +intros _; apply generic_format_0. +intros n H1. +apply generic_format_bpow. +now apply valid_exp. +Qed. + +Lemma generic_format_bpow_ge_ulp_0 : + forall e, (ulp 0 <= bpow e)%R -> + F (bpow e). +Proof. +intros e; unfold ulp. +rewrite Req_bool_true; trivial. +case negligible_exp_spec. +intros H1 _. +apply generic_format_bpow. +specialize (H1 (e+1)%Z); omega. +intros n H1 H2. +apply generic_format_bpow. +case (Zle_or_lt (e+1) (fexp (e+1))); intros H4. +absurd (e+1 <= e)%Z. +omega. +apply Z.le_trans with (1:=H4). +replace (fexp (e+1)) with (fexp n). +now apply le_bpow with beta. +now apply fexp_negligible_exp_eq. +omega. +Qed. + +(** The three following properties are equivalent: + [Exp_not_FTZ] ; forall x, F (ulp x) ; forall x, ulp 0 <= ulp x *) + +Lemma generic_format_ulp : + Exp_not_FTZ fexp -> + forall x, F (ulp x). +Proof. +unfold Exp_not_FTZ; intros H x. +case (Req_dec x 0); intros Hx. +rewrite Hx; apply generic_format_ulp_0. +rewrite (ulp_neq_0 _ Hx). +apply generic_format_bpow. +apply H. +Qed. + +Lemma not_FTZ_generic_format_ulp : + (forall x, F (ulp x)) -> + Exp_not_FTZ fexp. +Proof. +intros H e. +specialize (H (bpow (e-1))). +rewrite ulp_neq_0 in H. +2: apply Rgt_not_eq, bpow_gt_0. +unfold cexp in H. +rewrite mag_bpow in H. +apply generic_format_bpow_inv' in H. +now replace (e-1+1)%Z with e in H by ring. +Qed. + + +Lemma ulp_ge_ulp_0 : + Exp_not_FTZ fexp -> + forall x, (ulp 0 <= ulp x)%R. +Proof. +unfold Exp_not_FTZ; intros H x. +case (Req_dec x 0); intros Hx. +rewrite Hx; now right. +unfold ulp at 1. +rewrite Req_bool_true; trivial. +case negligible_exp_spec'. +intros (H1,H2); rewrite H1; apply ulp_ge_0. +intros (n,(H1,H2)); rewrite H1. +rewrite ulp_neq_0; trivial. +apply bpow_le; unfold cexp. +generalize (mag beta x); intros l. +case (Zle_or_lt l (fexp l)); intros Hl. +rewrite (fexp_negligible_exp_eq n l); trivial; apply Z.le_refl. +case (Zle_or_lt (fexp n) (fexp l)); trivial; intros K. +absurd (fexp n <= fexp l)%Z. +omega. +apply Z.le_trans with (2:= H _). +apply Zeq_le, sym_eq, valid_exp; trivial. +omega. +Qed. + +Lemma not_FTZ_ulp_ge_ulp_0: + (forall x, (ulp 0 <= ulp x)%R) -> + Exp_not_FTZ fexp. +Proof. +intros H e. +apply generic_format_bpow_inv' with beta. +apply generic_format_bpow_ge_ulp_0. +replace e with ((e-1)+1)%Z by ring. +rewrite <- ulp_bpow. +apply H. +Qed. + +Lemma ulp_le_pos : + forall { Hm : Monotone_exp fexp }, + forall x y: R, + (0 <= x)%R -> (x <= y)%R -> + (ulp x <= ulp y)%R. +Proof with auto with typeclass_instances. +intros Hm x y Hx Hxy. +destruct Hx as [Hx|Hx]. +rewrite ulp_neq_0. +rewrite ulp_neq_0. +apply bpow_le. +apply Hm. +now apply mag_le. +apply Rgt_not_eq, Rlt_gt. +now apply Rlt_le_trans with (1:=Hx). +now apply Rgt_not_eq. +rewrite <- Hx. +apply ulp_ge_ulp_0. +apply monotone_exp_not_FTZ... +Qed. + +Theorem ulp_le : + forall { Hm : Monotone_exp fexp }, + forall x y: R, + (Rabs x <= Rabs y)%R -> + (ulp x <= ulp y)%R. +Proof. +intros Hm x y Hxy. +rewrite <- ulp_abs. +rewrite <- (ulp_abs y). +apply ulp_le_pos; trivial. +apply Rabs_pos. +Qed. + +(** Properties when there is no minimal exponent *) +Theorem eq_0_round_0_negligible_exp : + negligible_exp = None -> forall rnd {Vr: Valid_rnd rnd} x, + round beta fexp rnd x = 0%R -> x = 0%R. +Proof. +intros H rnd Vr x Hx. +case (Req_dec x 0); try easy; intros Hx2. +absurd (Rabs (round beta fexp rnd x) = 0%R). +2: rewrite Hx, Rabs_R0; easy. +apply Rgt_not_eq. +apply Rlt_le_trans with (bpow (mag beta x - 1)). +apply bpow_gt_0. +apply abs_round_ge_generic; try assumption. +apply generic_format_bpow. +case negligible_exp_spec'; [intros (K1,K2)|idtac]. +ring_simplify (mag beta x-1+1)%Z. +specialize (K2 (mag beta x)); now auto with zarith. +intros (n,(Hn1,Hn2)). +rewrite Hn1 in H; discriminate. +now apply bpow_mag_le. +Qed. + + + +(** Definition and properties of pred and succ *) + +Definition pred_pos x := + if Req_bool x (bpow (mag beta x - 1)) then + (x - bpow (fexp (mag beta x - 1)))%R + else + (x - ulp x)%R. + +Definition succ x := + if (Rle_bool 0 x) then + (x+ulp x)%R + else + (- pred_pos (-x))%R. + +Definition pred x := (- succ (-x))%R. + +Theorem pred_eq_pos : + forall x, (0 <= x)%R -> + pred x = pred_pos x. +Proof. +intros x Hx; unfold pred, succ. +case Rle_bool_spec; intros Hx'. +assert (K:(x = 0)%R). +apply Rle_antisym; try assumption. +apply Ropp_le_cancel. +now rewrite Ropp_0. +rewrite K; unfold pred_pos. +rewrite Req_bool_false. +2: apply Rlt_not_eq, bpow_gt_0. +rewrite Ropp_0; ring. +now rewrite 2!Ropp_involutive. +Qed. + +Theorem succ_eq_pos : + forall x, (0 <= x)%R -> + succ x = (x + ulp x)%R. +Proof. +intros x Hx; unfold succ. +now rewrite Rle_bool_true. +Qed. + +Theorem succ_opp : + forall x, succ (-x) = (- pred x)%R. +Proof. +intros x. +now apply sym_eq, Ropp_involutive. +Qed. + +Theorem pred_opp : + forall x, pred (-x) = (- succ x)%R. +Proof. +intros x. +unfold pred. +now rewrite Ropp_involutive. +Qed. + +(** pred and succ are in the format *) + +(* cannont be x <> ulp 0, due to the counter-example 1-bit FP format fexp: e -> e-1 *) +(* was pred_ge_bpow *) +Theorem id_m_ulp_ge_bpow : + forall x e, F x -> + x <> ulp x -> + (bpow e < x)%R -> + (bpow e <= x - ulp x)%R. +Proof. +intros x e Fx Hx' Hx. +(* *) +assert (1 <= Ztrunc (scaled_mantissa beta fexp x))%Z. +assert (0 < Ztrunc (scaled_mantissa beta fexp x))%Z. +apply gt_0_F2R with beta (cexp beta fexp x). +rewrite <- Fx. +apply Rle_lt_trans with (2:=Hx). +apply bpow_ge_0. +omega. +case (Zle_lt_or_eq _ _ H); intros Hm. +(* *) +pattern x at 1 ; rewrite Fx. +rewrite ulp_neq_0. +unfold F2R. simpl. +pattern (bpow (cexp beta fexp x)) at 2 ; rewrite <- Rmult_1_l. +rewrite <- Rmult_minus_distr_r. +rewrite <- minus_IZR. +apply bpow_le_F2R_m1. +easy. +now rewrite <- Fx. +apply Rgt_not_eq, Rlt_gt. +apply Rlt_trans with (2:=Hx), bpow_gt_0. +(* *) +contradict Hx'. +pattern x at 1; rewrite Fx. +rewrite <- Hm. +rewrite ulp_neq_0. +unfold F2R; simpl. +now rewrite Rmult_1_l. +apply Rgt_not_eq, Rlt_gt. +apply Rlt_trans with (2:=Hx), bpow_gt_0. +Qed. + +(* was succ_le_bpow *) +Theorem id_p_ulp_le_bpow : + forall x e, (0 < x)%R -> F x -> + (x < bpow e)%R -> + (x + ulp x <= bpow e)%R. +Proof. +intros x e Zx Fx Hx. +pattern x at 1 ; rewrite Fx. +rewrite ulp_neq_0. +unfold F2R. simpl. +pattern (bpow (cexp beta fexp x)) at 2 ; rewrite <- Rmult_1_l. +rewrite <- Rmult_plus_distr_r. +rewrite <- plus_IZR. +apply F2R_p1_le_bpow. +apply gt_0_F2R with beta (cexp beta fexp x). +now rewrite <- Fx. +now rewrite <- Fx. +now apply Rgt_not_eq. +Qed. + +Lemma generic_format_pred_aux1: + forall x, (0 < x)%R -> F x -> + x <> bpow (mag beta x - 1) -> + F (x - ulp x). +Proof. +intros x Zx Fx Hx. +destruct (mag beta x) as (ex, Ex). +simpl in Hx. +specialize (Ex (Rgt_not_eq _ _ Zx)). +assert (Ex' : (bpow (ex - 1) < x < bpow ex)%R). +rewrite Rabs_pos_eq in Ex. +destruct Ex as (H,H'); destruct H; split; trivial. +contradict Hx; easy. +now apply Rlt_le. +unfold generic_format, scaled_mantissa, cexp. +rewrite mag_unique with beta (x - ulp x)%R ex. +pattern x at 1 3 ; rewrite Fx. +rewrite ulp_neq_0. +unfold scaled_mantissa. +rewrite cexp_fexp with (1 := Ex). +unfold F2R. simpl. +rewrite Rmult_minus_distr_r. +rewrite Rmult_assoc. +rewrite <- bpow_plus, Zplus_opp_r, Rmult_1_r. +change (bpow 0) with 1%R. +rewrite <- minus_IZR. +rewrite Ztrunc_IZR. +rewrite minus_IZR. +rewrite Rmult_minus_distr_r. +now rewrite Rmult_1_l. +now apply Rgt_not_eq. +rewrite Rabs_pos_eq. +split. +apply id_m_ulp_ge_bpow; trivial. +rewrite ulp_neq_0. +intro H. +assert (ex-1 < cexp beta fexp x < ex)%Z. +split ; apply (lt_bpow beta) ; rewrite <- H ; easy. +clear -H0. omega. +now apply Rgt_not_eq. +apply Ex'. +apply Rle_lt_trans with (2 := proj2 Ex'). +pattern x at 3 ; rewrite <- Rplus_0_r. +apply Rplus_le_compat_l. +rewrite <-Ropp_0. +apply Ropp_le_contravar. +apply ulp_ge_0. +apply Rle_0_minus. +pattern x at 2; rewrite Fx. +rewrite ulp_neq_0. +unfold F2R; simpl. +pattern (bpow (cexp beta fexp x)) at 1; rewrite <- Rmult_1_l. +apply Rmult_le_compat_r. +apply bpow_ge_0. +apply IZR_le. +assert (0 < Ztrunc (scaled_mantissa beta fexp x))%Z. +apply gt_0_F2R with beta (cexp beta fexp x). +rewrite <- Fx. +apply Rle_lt_trans with (2:=proj1 Ex'). +apply bpow_ge_0. +omega. +now apply Rgt_not_eq. +Qed. + +Lemma generic_format_pred_aux2 : + forall x, (0 < x)%R -> F x -> + let e := mag_val beta x (mag beta x) in + x = bpow (e - 1) -> + F (x - bpow (fexp (e - 1))). +Proof. +intros x Zx Fx e Hx. +pose (f:=(x - bpow (fexp (e - 1)))%R). +fold f. +assert (He:(fexp (e-1) <= e-1)%Z). +apply generic_format_bpow_inv with beta; trivial. +rewrite <- Hx; assumption. +case (Zle_lt_or_eq _ _ He); clear He; intros He. +assert (f = F2R (Float beta (Zpower beta (e-1-(fexp (e-1))) -1) (fexp (e-1))))%R. +unfold f; rewrite Hx. +unfold F2R; simpl. +rewrite minus_IZR, IZR_Zpower. +rewrite Rmult_minus_distr_r, Rmult_1_l. +rewrite <- bpow_plus. +now replace (e - 1 - fexp (e - 1) + fexp (e - 1))%Z with (e-1)%Z by ring. +omega. +rewrite H. +apply generic_format_F2R. +intros _. +apply Zeq_le. +apply cexp_fexp. +rewrite <- H. +unfold f; rewrite Hx. +rewrite Rabs_right. +split. +apply Rplus_le_reg_l with (bpow (fexp (e-1))). +ring_simplify. +apply Rle_trans with (bpow (e - 2) + bpow (e - 2))%R. +apply Rplus_le_compat ; apply bpow_le ; omega. +apply Rle_trans with (2*bpow (e - 2))%R;[right; ring|idtac]. +apply Rle_trans with (bpow 1*bpow (e - 2))%R. +apply Rmult_le_compat_r. +apply bpow_ge_0. +replace (bpow 1) with (IZR beta). +apply IZR_le. +apply <- Zle_is_le_bool. +now destruct beta. +simpl. +unfold Zpower_pos; simpl. +now rewrite Zmult_1_r. +rewrite <- bpow_plus. +replace (1+(e-2))%Z with (e-1)%Z by ring. +now right. +rewrite <- Rplus_0_r. +apply Rplus_lt_compat_l. +rewrite <- Ropp_0. +apply Ropp_lt_contravar. +apply bpow_gt_0. +apply Rle_ge; apply Rle_0_minus. +apply bpow_le. +omega. +replace f with 0%R. +apply generic_format_0. +unfold f. +rewrite Hx, He. +ring. +Qed. + +Lemma generic_format_succ_aux1 : + forall x, (0 < x)%R -> F x -> + F (x + ulp x). +Proof. +intros x Zx Fx. +destruct (mag beta x) as (ex, Ex). +specialize (Ex (Rgt_not_eq _ _ Zx)). +assert (Ex' := Ex). +rewrite Rabs_pos_eq in Ex'. +destruct (id_p_ulp_le_bpow x ex) ; try easy. +unfold generic_format, scaled_mantissa, cexp. +rewrite mag_unique with beta (x + ulp x)%R ex. +pattern x at 1 3 ; rewrite Fx. +rewrite ulp_neq_0. +unfold scaled_mantissa. +rewrite cexp_fexp with (1 := Ex). +unfold F2R. simpl. +rewrite Rmult_plus_distr_r. +rewrite Rmult_assoc. +rewrite <- bpow_plus, Zplus_opp_r, Rmult_1_r. +change (bpow 0) with 1%R. +rewrite <- plus_IZR. +rewrite Ztrunc_IZR. +rewrite plus_IZR. +rewrite Rmult_plus_distr_r. +now rewrite Rmult_1_l. +now apply Rgt_not_eq. +rewrite Rabs_pos_eq. +split. +apply Rle_trans with (1 := proj1 Ex'). +pattern x at 1 ; rewrite <- Rplus_0_r. +apply Rplus_le_compat_l. +apply ulp_ge_0. +exact H. +apply Rplus_le_le_0_compat. +now apply Rlt_le. +apply ulp_ge_0. +rewrite H. +apply generic_format_bpow. +apply valid_exp. +destruct (Zle_or_lt ex (fexp ex)) ; trivial. +elim Rlt_not_le with (1 := Zx). +rewrite Fx. +replace (Ztrunc (scaled_mantissa beta fexp x)) with Z0. +rewrite F2R_0. +apply Rle_refl. +unfold scaled_mantissa. +rewrite cexp_fexp with (1 := Ex). +destruct (mantissa_small_pos beta fexp x ex) ; trivial. +rewrite Ztrunc_floor. +apply sym_eq. +apply Zfloor_imp. +split. +now apply Rlt_le. +exact H2. +now apply Rlt_le. +now apply Rlt_le. +Qed. + +Lemma generic_format_pred_pos : + forall x, F x -> (0 < x)%R -> + F (pred_pos x). +Proof. +intros x Fx Zx. +unfold pred_pos; case Req_bool_spec; intros H. +now apply generic_format_pred_aux2. +now apply generic_format_pred_aux1. +Qed. + +Theorem generic_format_succ : + forall x, F x -> + F (succ x). +Proof. +intros x Fx. +unfold succ; case Rle_bool_spec; intros Zx. +destruct Zx as [Zx|Zx]. +now apply generic_format_succ_aux1. +rewrite <- Zx, Rplus_0_l. +apply generic_format_ulp_0. +apply generic_format_opp. +apply generic_format_pred_pos. +now apply generic_format_opp. +now apply Ropp_0_gt_lt_contravar. +Qed. + +Theorem generic_format_pred : + forall x, F x -> + F (pred x). +Proof. +intros x Fx. +unfold pred. +apply generic_format_opp. +apply generic_format_succ. +now apply generic_format_opp. +Qed. + +Lemma pred_pos_lt_id : + forall x, (x <> 0)%R -> + (pred_pos x < x)%R. +Proof. +intros x Zx. +unfold pred_pos. +case Req_bool_spec; intros H. +(* *) +rewrite <- Rplus_0_r. +apply Rplus_lt_compat_l. +rewrite <- Ropp_0. +apply Ropp_lt_contravar. +apply bpow_gt_0. +(* *) +rewrite <- Rplus_0_r. +apply Rplus_lt_compat_l. +rewrite <- Ropp_0. +apply Ropp_lt_contravar. +rewrite ulp_neq_0; trivial. +apply bpow_gt_0. +Qed. + +Theorem succ_gt_id : + forall x, (x <> 0)%R -> + (x < succ x)%R. +Proof. +intros x Zx; unfold succ. +case Rle_bool_spec; intros Hx. +pattern x at 1; rewrite <- (Rplus_0_r x). +apply Rplus_lt_compat_l. +rewrite ulp_neq_0; trivial. +apply bpow_gt_0. +pattern x at 1; rewrite <- (Ropp_involutive x). +apply Ropp_lt_contravar. +apply pred_pos_lt_id. +auto with real. +Qed. + + +Theorem pred_lt_id : + forall x, (x <> 0)%R -> + (pred x < x)%R. +Proof. +intros x Zx; unfold pred. +pattern x at 2; rewrite <- (Ropp_involutive x). +apply Ropp_lt_contravar. +apply succ_gt_id. +auto with real. +Qed. + +Theorem succ_ge_id : + forall x, (x <= succ x)%R. +Proof. +intros x; case (Req_dec x 0). +intros V; rewrite V. +unfold succ; rewrite Rle_bool_true;[idtac|now right]. +rewrite Rplus_0_l; apply ulp_ge_0. +intros; left; now apply succ_gt_id. +Qed. + + +Theorem pred_le_id : + forall x, (pred x <= x)%R. +Proof. +intros x; unfold pred. +pattern x at 2; rewrite <- (Ropp_involutive x). +apply Ropp_le_contravar. +apply succ_ge_id. +Qed. + + +Lemma pred_pos_ge_0 : + forall x, + (0 < x)%R -> F x -> (0 <= pred_pos x)%R. +Proof. +intros x Zx Fx. +unfold pred_pos. +case Req_bool_spec; intros H. +(* *) +apply Rle_0_minus. +rewrite H. +apply bpow_le. +destruct (mag beta x) as (ex,Ex) ; simpl. +rewrite mag_bpow. +ring_simplify (ex - 1 + 1 - 1)%Z. +apply generic_format_bpow_inv with beta; trivial. +simpl in H. +rewrite <- H; assumption. +apply Rle_0_minus. +now apply ulp_le_id. +Qed. + +Theorem pred_ge_0 : + forall x, + (0 < x)%R -> F x -> (0 <= pred x)%R. +Proof. +intros x Zx Fx. +rewrite pred_eq_pos. +now apply pred_pos_ge_0. +now left. +Qed. + + +Lemma pred_pos_plus_ulp_aux1 : + forall x, (0 < x)%R -> F x -> + x <> bpow (mag beta x - 1) -> + ((x - ulp x) + ulp (x-ulp x) = x)%R. +Proof. +intros x Zx Fx Hx. +replace (ulp (x - ulp x)) with (ulp x). +ring. +assert (H : x <> 0%R) by now apply Rgt_not_eq. +assert (H' : x <> bpow (cexp beta fexp x)). +unfold cexp ; intros M. +case_eq (mag beta x); intros ex Hex T. +assert (Lex:(mag_val beta x (mag beta x) = ex)%Z). +rewrite T; reflexivity. +rewrite Lex in *. +clear T; simpl in *; specialize (Hex H). +rewrite Rabs_pos_eq in Hex by now apply Rlt_le. +assert (ex - 1 < fexp ex < ex)%Z. + split ; apply (lt_bpow beta) ; rewrite <- M by easy. + lra. + apply Hex. +omega. +rewrite 2!ulp_neq_0 by lra. +apply f_equal. +unfold cexp ; apply f_equal. +case_eq (mag beta x); intros ex Hex T. +assert (Lex:(mag_val beta x (mag beta x) = ex)%Z). +rewrite T; reflexivity. +rewrite Lex in *; simpl in *; clear T. +specialize (Hex H). +apply sym_eq, mag_unique. +rewrite Rabs_right. +rewrite Rabs_right in Hex. +2: apply Rle_ge; apply Rlt_le; easy. +split. +destruct Hex as ([H1|H1],H2). +apply Rle_trans with (x-ulp x)%R. +apply id_m_ulp_ge_bpow; trivial. +rewrite ulp_neq_0; trivial. +rewrite ulp_neq_0; trivial. +right; unfold cexp; now rewrite Lex. +lra. +apply Rle_lt_trans with (2:=proj2 Hex). +rewrite <- Rplus_0_r. +apply Rplus_le_compat_l. +rewrite <- Ropp_0. +apply Ropp_le_contravar. +apply bpow_ge_0. +apply Rle_ge. +apply Rle_0_minus. +rewrite Fx. +unfold F2R, cexp; simpl. +rewrite Lex. +pattern (bpow (fexp ex)) at 1; rewrite <- Rmult_1_l. +apply Rmult_le_compat_r. +apply bpow_ge_0. +apply IZR_le, (Zlt_le_succ 0). +apply gt_0_F2R with beta (cexp beta fexp x). +now rewrite <- Fx. +Qed. + +Lemma pred_pos_plus_ulp_aux2 : + forall x, (0 < x)%R -> F x -> + let e := mag_val beta x (mag beta x) in + x = bpow (e - 1) -> + (x - bpow (fexp (e-1)) <> 0)%R -> + ((x - bpow (fexp (e-1))) + ulp (x - bpow (fexp (e-1))) = x)%R. +Proof. +intros x Zx Fx e Hxe Zp. +replace (ulp (x - bpow (fexp (e - 1)))) with (bpow (fexp (e - 1))). +ring. +assert (He:(fexp (e-1) <= e-1)%Z). +apply generic_format_bpow_inv with beta; trivial. +rewrite <- Hxe; assumption. +case (Zle_lt_or_eq _ _ He); clear He; intros He. +(* *) +rewrite ulp_neq_0; trivial. +apply f_equal. +unfold cexp ; apply f_equal. +apply sym_eq. +apply mag_unique. +rewrite Rabs_right. +split. +apply Rplus_le_reg_l with (bpow (fexp (e-1))). +ring_simplify. +apply Rle_trans with (bpow (e - 2) + bpow (e - 2))%R. +apply Rplus_le_compat; apply bpow_le; omega. +apply Rle_trans with (2*bpow (e - 2))%R;[right; ring|idtac]. +apply Rle_trans with (bpow 1*bpow (e - 2))%R. +apply Rmult_le_compat_r. +apply bpow_ge_0. +replace (bpow 1) with (IZR beta). +apply IZR_le. +apply <- Zle_is_le_bool. +now destruct beta. +simpl. +unfold Zpower_pos; simpl. +now rewrite Zmult_1_r. +rewrite <- bpow_plus. +replace (1+(e-2))%Z with (e-1)%Z by ring. +now right. +rewrite <- Rplus_0_r, Hxe. +apply Rplus_lt_compat_l. +rewrite <- Ropp_0. +apply Ropp_lt_contravar. +apply bpow_gt_0. +apply Rle_ge; apply Rle_0_minus. +rewrite Hxe. +apply bpow_le. +omega. +(* *) +contradict Zp. +rewrite Hxe, He; ring. +Qed. + +Lemma pred_pos_plus_ulp_aux3 : + forall x, (0 < x)%R -> F x -> + let e := mag_val beta x (mag beta x) in + x = bpow (e - 1) -> + (x - bpow (fexp (e-1)) = 0)%R -> + (ulp 0 = x)%R. +Proof. +intros x Hx Fx e H1 H2. +assert (H3:(x = bpow (fexp (e - 1)))). +now apply Rminus_diag_uniq. +assert (H4: (fexp (e-1) = e-1)%Z). +apply bpow_inj with beta. +now rewrite <- H1. +unfold ulp; rewrite Req_bool_true; trivial. +case negligible_exp_spec. +intros K. +specialize (K (e-1)%Z). +contradict K; omega. +intros n Hn. +rewrite H3; apply f_equal. +case (Zle_or_lt n (e-1)); intros H6. +apply valid_exp; omega. +apply sym_eq, valid_exp; omega. +Qed. + +(** The following one is false for x = 0 in FTZ *) + +Lemma pred_pos_plus_ulp : + forall x, (0 < x)%R -> F x -> + (pred_pos x + ulp (pred_pos x) = x)%R. +Proof. +intros x Zx Fx. +unfold pred_pos. +case Req_bool_spec; intros H. +case (Req_EM_T (x - bpow (fexp (mag_val beta x (mag beta x) -1))) 0); intros H1. +rewrite H1, Rplus_0_l. +now apply pred_pos_plus_ulp_aux3. +now apply pred_pos_plus_ulp_aux2. +now apply pred_pos_plus_ulp_aux1. +Qed. + +Theorem pred_plus_ulp : + forall x, (0 < x)%R -> F x -> + (pred x + ulp (pred x))%R = x. +Proof. +intros x Hx Fx. +rewrite pred_eq_pos. +now apply pred_pos_plus_ulp. +now apply Rlt_le. +Qed. + +(** Rounding x + small epsilon *) + +Theorem mag_plus_eps : + forall x, (0 < x)%R -> F x -> + forall eps, (0 <= eps < ulp x)%R -> + mag beta (x + eps) = mag beta x :> Z. +Proof. +intros x Zx Fx eps Heps. +destruct (mag beta x) as (ex, He). +simpl. +specialize (He (Rgt_not_eq _ _ Zx)). +apply mag_unique. +rewrite Rabs_pos_eq. +rewrite Rabs_pos_eq in He. +split. +apply Rle_trans with (1 := proj1 He). +pattern x at 1 ; rewrite <- Rplus_0_r. +now apply Rplus_le_compat_l. +apply Rlt_le_trans with (x + ulp x)%R. +now apply Rplus_lt_compat_l. +pattern x at 1 ; rewrite Fx. +rewrite ulp_neq_0. +unfold F2R. simpl. +pattern (bpow (cexp beta fexp x)) at 2 ; rewrite <- Rmult_1_l. +rewrite <- Rmult_plus_distr_r. +rewrite <- plus_IZR. +apply F2R_p1_le_bpow. +apply gt_0_F2R with beta (cexp beta fexp x). +now rewrite <- Fx. +now rewrite <- Fx. +now apply Rgt_not_eq. +now apply Rlt_le. +apply Rplus_le_le_0_compat. +now apply Rlt_le. +apply Heps. +Qed. + +Theorem round_DN_plus_eps_pos : + forall x, (0 <= x)%R -> F x -> + forall eps, (0 <= eps < ulp x)%R -> + round beta fexp Zfloor (x + eps) = x. +Proof. +intros x Zx Fx eps Heps. +destruct Zx as [Zx|Zx]. +(* . 0 < x *) +pattern x at 2 ; rewrite Fx. +unfold round. +unfold scaled_mantissa. simpl. +unfold cexp at 1 2. +rewrite mag_plus_eps ; trivial. +apply (f_equal (fun m => F2R (Float beta m _))). +rewrite Ztrunc_floor. +apply Zfloor_imp. +split. +apply (Rle_trans _ _ _ (Zfloor_lb _)). +apply Rmult_le_compat_r. +apply bpow_ge_0. +pattern x at 1 ; rewrite <- Rplus_0_r. +now apply Rplus_le_compat_l. +apply Rlt_le_trans with ((x + ulp x) * bpow (- cexp beta fexp x))%R. +apply Rmult_lt_compat_r. +apply bpow_gt_0. +now apply Rplus_lt_compat_l. +rewrite Rmult_plus_distr_r. +rewrite plus_IZR. +apply Rplus_le_compat. +pattern x at 1 3 ; rewrite Fx. +unfold F2R. simpl. +rewrite Rmult_assoc. +rewrite <- bpow_plus. +rewrite Zplus_opp_r. +rewrite Rmult_1_r. +rewrite Zfloor_IZR. +apply Rle_refl. +rewrite ulp_neq_0. +2: now apply Rgt_not_eq. +rewrite <- bpow_plus. +rewrite Zplus_opp_r. +apply Rle_refl. +apply Rmult_le_pos. +now apply Rlt_le. +apply bpow_ge_0. +(* . x=0 *) +rewrite <- Zx, Rplus_0_l; rewrite <- Zx in Heps. +case (proj1 Heps); intros P. +unfold round, scaled_mantissa, cexp. +revert Heps; unfold ulp. +rewrite Req_bool_true; trivial. +case negligible_exp_spec. +intros _ (H1,H2). +exfalso ; lra. +intros n Hn H. +assert (fexp (mag beta eps) = fexp n). +apply valid_exp; try assumption. +assert(mag beta eps-1 < fexp n)%Z;[idtac|omega]. +apply lt_bpow with beta. +apply Rle_lt_trans with (2:=proj2 H). +destruct (mag beta eps) as (e,He). +simpl; rewrite Rabs_pos_eq in He. +now apply He, Rgt_not_eq. +now left. +replace (Zfloor (eps * bpow (- fexp (mag beta eps)))) with 0%Z. +unfold F2R; simpl; ring. +apply sym_eq, Zfloor_imp. +split. +apply Rmult_le_pos. +now left. +apply bpow_ge_0. +apply Rmult_lt_reg_r with (bpow (fexp n)). +apply bpow_gt_0. +rewrite Rmult_assoc, <- bpow_plus. +rewrite H0; ring_simplify (-fexp n + fexp n)%Z. +simpl; rewrite Rmult_1_l, Rmult_1_r. +apply H. +rewrite <- P, round_0; trivial. +apply valid_rnd_DN. +Qed. + + +Theorem round_UP_plus_eps_pos : + forall x, (0 <= x)%R -> F x -> + forall eps, (0 < eps <= ulp x)%R -> + round beta fexp Zceil (x + eps) = (x + ulp x)%R. +Proof with auto with typeclass_instances. +intros x Zx Fx eps. +case Zx; intros Zx1. +(* . 0 < x *) +intros (Heps1,[Heps2|Heps2]). +assert (Heps: (0 <= eps < ulp x)%R). +split. +now apply Rlt_le. +exact Heps2. +assert (Hd := round_DN_plus_eps_pos x Zx Fx eps Heps). +rewrite round_UP_DN_ulp. +rewrite Hd. +rewrite 2!ulp_neq_0. +unfold cexp. +now rewrite mag_plus_eps. +now apply Rgt_not_eq. +now apply Rgt_not_eq, Rplus_lt_0_compat. +intros Fs. +rewrite round_generic in Hd... +apply Rgt_not_eq with (2 := Hd). +pattern x at 2 ; rewrite <- Rplus_0_r. +now apply Rplus_lt_compat_l. +rewrite Heps2. +apply round_generic... +now apply generic_format_succ_aux1. +(* . x=0 *) +rewrite <- Zx1, 2!Rplus_0_l. +intros Heps. +case (proj2 Heps). +unfold round, scaled_mantissa, cexp. +unfold ulp. +rewrite Req_bool_true; trivial. +case negligible_exp_spec. +lra. +intros n Hn H. +assert (fexp (mag beta eps) = fexp n). +apply valid_exp; try assumption. +assert(mag beta eps-1 < fexp n)%Z;[idtac|omega]. +apply lt_bpow with beta. +apply Rle_lt_trans with (2:=H). +destruct (mag beta eps) as (e,He). +simpl; rewrite Rabs_pos_eq in He. +now apply He, Rgt_not_eq. +now left. +replace (Zceil (eps * bpow (- fexp (mag beta eps)))) with 1%Z. +unfold F2R; simpl; rewrite H0; ring. +apply sym_eq, Zceil_imp. +split. +simpl; apply Rmult_lt_0_compat. +apply Heps. +apply bpow_gt_0. +apply Rmult_le_reg_r with (bpow (fexp n)). +apply bpow_gt_0. +rewrite Rmult_assoc, <- bpow_plus. +rewrite H0; ring_simplify (-fexp n + fexp n)%Z. +simpl; rewrite Rmult_1_l, Rmult_1_r. +now left. +intros P; rewrite P. +apply round_generic... +apply generic_format_ulp_0. +Qed. + + +Theorem round_UP_pred_plus_eps_pos : + forall x, (0 < x)%R -> F x -> + forall eps, (0 < eps <= ulp (pred x) )%R -> + round beta fexp Zceil (pred x + eps) = x. +Proof. +intros x Hx Fx eps Heps. +rewrite round_UP_plus_eps_pos; trivial. +rewrite pred_eq_pos. +apply pred_pos_plus_ulp; trivial. +now left. +now apply pred_ge_0. +apply generic_format_pred; trivial. +Qed. + +Theorem round_DN_minus_eps_pos : + forall x, (0 < x)%R -> F x -> + forall eps, (0 < eps <= ulp (pred x))%R -> + round beta fexp Zfloor (x - eps) = pred x. +Proof. +intros x Hpx Fx eps. +rewrite pred_eq_pos;[intros Heps|now left]. +replace (x-eps)%R with (pred_pos x + (ulp (pred_pos x)-eps))%R. +2: pattern x at 3; rewrite <- (pred_pos_plus_ulp x); trivial. +2: ring. +rewrite round_DN_plus_eps_pos; trivial. +now apply pred_pos_ge_0. +now apply generic_format_pred_pos. +split. +apply Rle_0_minus. +now apply Heps. +rewrite <- Rplus_0_r. +apply Rplus_lt_compat_l. +rewrite <- Ropp_0. +apply Ropp_lt_contravar. +now apply Heps. +Qed. + + +Theorem round_DN_plus_eps: + forall x, F x -> + forall eps, (0 <= eps < if (Rle_bool 0 x) then (ulp x) + else (ulp (pred (-x))))%R -> + round beta fexp Zfloor (x + eps) = x. +Proof. +intros x Fx eps Heps. +case (Rle_or_lt 0 x); intros Zx. +apply round_DN_plus_eps_pos; try assumption. +split; try apply Heps. +rewrite Rle_bool_true in Heps; trivial. +now apply Heps. +(* *) +rewrite Rle_bool_false in Heps; trivial. +rewrite <- (Ropp_involutive (x+eps)). +pattern x at 2; rewrite <- (Ropp_involutive x). +rewrite round_DN_opp. +apply f_equal. +replace (-(x+eps))%R with (pred (-x) + (ulp (pred (-x)) - eps))%R. +rewrite round_UP_pred_plus_eps_pos; try reflexivity. +now apply Ropp_0_gt_lt_contravar. +now apply generic_format_opp. +split. +apply Rplus_lt_reg_l with eps; ring_simplify. +apply Heps. +apply Rplus_le_reg_l with (eps-ulp (pred (- x)))%R; ring_simplify. +apply Heps. +unfold pred. +rewrite Ropp_involutive. +unfold succ; rewrite Rle_bool_false; try assumption. +rewrite Ropp_involutive; unfold Rminus. +rewrite <- Rplus_assoc, pred_pos_plus_ulp. +ring. +now apply Ropp_0_gt_lt_contravar. +now apply generic_format_opp. +Qed. + + +Theorem round_UP_plus_eps : + forall x, F x -> + forall eps, (0 < eps <= if (Rle_bool 0 x) then (ulp x) + else (ulp (pred (-x))))%R -> + round beta fexp Zceil (x + eps) = (succ x)%R. +Proof with auto with typeclass_instances. +intros x Fx eps Heps. +case (Rle_or_lt 0 x); intros Zx. +rewrite succ_eq_pos; try assumption. +rewrite Rle_bool_true in Heps; trivial. +apply round_UP_plus_eps_pos; assumption. +(* *) +rewrite Rle_bool_false in Heps; trivial. +rewrite <- (Ropp_involutive (x+eps)). +rewrite <- (Ropp_involutive (succ x)). +rewrite round_UP_opp. +apply f_equal. +replace (-(x+eps))%R with (-succ x + (-eps + ulp (pred (-x))))%R. +apply round_DN_plus_eps_pos. +rewrite <- pred_opp. +apply pred_ge_0. +now apply Ropp_0_gt_lt_contravar. +now apply generic_format_opp. +now apply generic_format_opp, generic_format_succ. +split. +apply Rplus_le_reg_l with eps; ring_simplify. +apply Heps. +unfold pred; rewrite Ropp_involutive. +apply Rplus_lt_reg_l with (eps-ulp (- succ x))%R; ring_simplify. +apply Heps. +unfold succ; rewrite Rle_bool_false; try assumption. +apply trans_eq with (-x +-eps)%R;[idtac|ring]. +pattern (-x)%R at 3; rewrite <- (pred_pos_plus_ulp (-x)). +rewrite pred_eq_pos. +ring. +left; now apply Ropp_0_gt_lt_contravar. +now apply Ropp_0_gt_lt_contravar. +now apply generic_format_opp. +Qed. + + +Lemma le_pred_pos_lt : + forall x y, + F x -> F y -> + (0 <= x < y)%R -> + (x <= pred_pos y)%R. +Proof with auto with typeclass_instances. +intros x y Fx Fy H. +case (proj1 H); intros V. +assert (Zy:(0 < y)%R). +apply Rle_lt_trans with (1:=proj1 H). +apply H. +(* *) +assert (Zp: (0 < pred y)%R). +assert (Zp:(0 <= pred y)%R). +apply pred_ge_0 ; trivial. +destruct Zp; trivial. +generalize H0. +rewrite pred_eq_pos;[idtac|now left]. +unfold pred_pos. +destruct (mag beta y) as (ey,Hey); simpl. +case Req_bool_spec; intros Hy2. +(* . *) +intros Hy3. +assert (ey-1 = fexp (ey -1))%Z. +apply bpow_inj with beta. +rewrite <- Hy2, <- Rplus_0_l, Hy3. +ring. +assert (Zx: (x <> 0)%R). +now apply Rgt_not_eq. +destruct (mag beta x) as (ex,Hex). +specialize (Hex Zx). +assert (ex <= ey)%Z. +apply bpow_lt_bpow with beta. +apply Rle_lt_trans with (1:=proj1 Hex). +apply Rlt_trans with (Rabs y). +rewrite 2!Rabs_right. +apply H. +now apply Rgt_ge. +now apply Rgt_ge. +apply Hey. +now apply Rgt_not_eq. +case (Zle_lt_or_eq _ _ H2); intros Hexy. +assert (fexp ex = fexp (ey-1))%Z. +apply valid_exp. +omega. +rewrite <- H1. +omega. +absurd (0 < Ztrunc (scaled_mantissa beta fexp x) < 1)%Z. +omega. +split. +apply gt_0_F2R with beta (cexp beta fexp x). +now rewrite <- Fx. +apply lt_IZR. +apply Rmult_lt_reg_r with (bpow (cexp beta fexp x)). +apply bpow_gt_0. +replace (IZR (Ztrunc (scaled_mantissa beta fexp x)) * + bpow (cexp beta fexp x))%R with x. +rewrite Rmult_1_l. +unfold cexp. +rewrite mag_unique with beta x ex. +rewrite H3,<-H1, <- Hy2. +apply H. +exact Hex. +absurd (y <= x)%R. +now apply Rlt_not_le. +rewrite Rabs_right in Hex. +apply Rle_trans with (2:=proj1 Hex). +rewrite Hexy, Hy2. +now apply Rle_refl. +now apply Rgt_ge. +(* . *) +intros Hy3. +assert (y = bpow (fexp ey))%R. +apply Rminus_diag_uniq. +rewrite Hy3. +rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq]. +unfold cexp. +rewrite (mag_unique beta y ey); trivial. +apply Hey. +now apply Rgt_not_eq. +contradict Hy2. +rewrite H1. +apply f_equal. +apply Zplus_reg_l with 1%Z. +ring_simplify. +apply trans_eq with (mag beta y). +apply sym_eq; apply mag_unique. +rewrite H1, Rabs_right. +split. +apply bpow_le. +omega. +apply bpow_lt. +omega. +apply Rle_ge; apply bpow_ge_0. +apply mag_unique. +apply Hey. +now apply Rgt_not_eq. +(* *) +case (Rle_or_lt (ulp (pred_pos y)) (y-x)); intros H1. +(* . *) +apply Rplus_le_reg_r with (-x + ulp (pred_pos y))%R. +ring_simplify (x+(-x+ulp (pred_pos y)))%R. +apply Rle_trans with (1:=H1). +rewrite <- (pred_pos_plus_ulp y) at 1; trivial. +apply Req_le; ring. +(* . *) +replace x with (y-(y-x))%R by ring. +rewrite <- pred_eq_pos;[idtac|now left]. +rewrite <- round_DN_minus_eps_pos with (eps:=(y-x)%R); try easy. +ring_simplify (y-(y-x))%R. +apply Req_le. +apply sym_eq. +apply round_generic... +split; trivial. +now apply Rlt_Rminus. +rewrite pred_eq_pos;[idtac|now left]. +now apply Rlt_le. +rewrite <- V; apply pred_pos_ge_0; trivial. +apply Rle_lt_trans with (1:=proj1 H); apply H. +Qed. + +Lemma succ_le_lt_aux: + forall x y, + F x -> F y -> + (0 <= x)%R -> (x < y)%R -> + (succ x <= y)%R. +Proof with auto with typeclass_instances. +intros x y Hx Hy Zx H. +rewrite succ_eq_pos; trivial. +case (Rle_or_lt (ulp x) (y-x)); intros H1. +apply Rplus_le_reg_r with (-x)%R. +now ring_simplify (x+ulp x + -x)%R. +replace y with (x+(y-x))%R by ring. +absurd (x < y)%R. +2: apply H. +apply Rle_not_lt; apply Req_le. +rewrite <- round_DN_plus_eps_pos with (eps:=(y-x)%R); try easy. +ring_simplify (x+(y-x))%R. +apply sym_eq. +apply round_generic... +split; trivial. +apply Rlt_le; now apply Rlt_Rminus. +Qed. + +Theorem succ_le_lt: + forall x y, + F x -> F y -> + (x < y)%R -> + (succ x <= y)%R. +Proof with auto with typeclass_instances. +intros x y Fx Fy H. +destruct (Rle_or_lt 0 x) as [Hx|Hx]. +now apply succ_le_lt_aux. +unfold succ; rewrite Rle_bool_false; try assumption. +case (Rle_or_lt y 0); intros Hy. +rewrite <- (Ropp_involutive y). +apply Ropp_le_contravar. +apply le_pred_pos_lt. +now apply generic_format_opp. +now apply generic_format_opp. +split. +rewrite <- Ropp_0; now apply Ropp_le_contravar. +now apply Ropp_lt_contravar. +apply Rle_trans with (-0)%R. +apply Ropp_le_contravar. +apply pred_pos_ge_0. +rewrite <- Ropp_0; now apply Ropp_lt_contravar. +now apply generic_format_opp. +rewrite Ropp_0; now left. +Qed. + +Theorem pred_ge_gt : + forall x y, + F x -> F y -> + (x < y)%R -> + (x <= pred y)%R. +Proof. +intros x y Fx Fy Hxy. +rewrite <- (Ropp_involutive x). +unfold pred; apply Ropp_le_contravar. +apply succ_le_lt. +now apply generic_format_opp. +now apply generic_format_opp. +now apply Ropp_lt_contravar. +Qed. + +Theorem succ_gt_ge : + forall x y, + (y <> 0)%R -> + (x <= y)%R -> + (x < succ y)%R. +Proof. +intros x y Zy Hxy. +apply Rle_lt_trans with (1 := Hxy). +now apply succ_gt_id. +Qed. + +Theorem pred_lt_le : + forall x y, + (x <> 0)%R -> + (x <= y)%R -> + (pred x < y)%R. +Proof. +intros x y Zy Hxy. +apply Rlt_le_trans with (2 := Hxy). +now apply pred_lt_id. +Qed. + +Lemma succ_pred_pos : + forall x, F x -> (0 < x)%R -> succ (pred x) = x. +Proof. +intros x Fx Hx. +rewrite pred_eq_pos by now left. +rewrite succ_eq_pos by now apply pred_pos_ge_0. +now apply pred_pos_plus_ulp. +Qed. + +Theorem pred_ulp_0 : + pred (ulp 0) = 0%R. +Proof. +rewrite pred_eq_pos. +2: apply ulp_ge_0. +unfold ulp; rewrite Req_bool_true; trivial. +case negligible_exp_spec'. +(* *) +intros [H1 _]; rewrite H1. +unfold pred_pos; rewrite Req_bool_false. +2: apply Rlt_not_eq, bpow_gt_0. +unfold ulp; rewrite Req_bool_true; trivial. +rewrite H1; ring. +(* *) +intros (n,(H1,H2)); rewrite H1. +unfold pred_pos. +rewrite mag_bpow. +replace (fexp n + 1 - 1)%Z with (fexp n) by ring. +rewrite Req_bool_true; trivial. +apply Rminus_diag_eq, f_equal. +apply sym_eq, valid_exp; omega. +Qed. + +Theorem succ_0 : + succ 0 = ulp 0. +Proof. +unfold succ. +rewrite Rle_bool_true. +apply Rplus_0_l. +apply Rle_refl. +Qed. + +Theorem pred_0 : + pred 0 = Ropp (ulp 0). +Proof. +rewrite <- succ_0. +rewrite <- Ropp_0 at 1. +apply pred_opp. +Qed. + +Lemma pred_succ_pos : + forall x, F x -> (0 < x)%R -> + pred (succ x) = x. +Proof. +intros x Fx Hx. +apply Rle_antisym. +- apply Rnot_lt_le. + intros H. + apply succ_le_lt with (1 := Fx) in H. + revert H. + apply Rlt_not_le. + apply pred_lt_id. + apply Rgt_not_eq. + apply Rlt_le_trans with (1 := Hx). + apply succ_ge_id. + now apply generic_format_pred, generic_format_succ. +- apply pred_ge_gt with (1 := Fx). + now apply generic_format_succ. + apply succ_gt_id. + now apply Rgt_not_eq. +Qed. + +Theorem succ_pred : + forall x, F x -> + succ (pred x) = x. +Proof. +intros x Fx. +destruct (Rle_or_lt 0 x) as [[Hx|Hx]|Hx]. +now apply succ_pred_pos. +rewrite <- Hx. +rewrite pred_0, succ_opp, pred_ulp_0. +apply Ropp_0. +unfold pred. +rewrite succ_opp, pred_succ_pos. +apply Ropp_involutive. +now apply generic_format_opp. +now apply Ropp_0_gt_lt_contravar. +Qed. + +Theorem pred_succ : + forall x, F x -> + pred (succ x) = x. +Proof. +intros x Fx. +rewrite <- (Ropp_involutive x). +rewrite succ_opp, pred_opp. +apply f_equal, succ_pred. +now apply generic_format_opp. +Qed. + +Theorem round_UP_pred_plus_eps : + forall x, F x -> + forall eps, (0 < eps <= if Rle_bool x 0 then ulp x + else ulp (pred x))%R -> + round beta fexp Zceil (pred x + eps) = x. +Proof. +intros x Fx eps Heps. +rewrite round_UP_plus_eps. +now apply succ_pred. +now apply generic_format_pred. +unfold pred at 4. +rewrite Ropp_involutive, pred_succ. +rewrite ulp_opp. +generalize Heps; case (Rle_bool_spec x 0); intros H1 H2. +rewrite Rle_bool_false; trivial. +case H1; intros H1'. +apply Rlt_le_trans with (2:=H1). +apply pred_lt_id. +now apply Rlt_not_eq. +rewrite H1'; unfold pred, succ. +rewrite Ropp_0; rewrite Rle_bool_true;[idtac|now right]. +rewrite Rplus_0_l. +rewrite <- Ropp_0; apply Ropp_lt_contravar. +apply Rlt_le_trans with (1:=proj1 H2). +apply Rle_trans with (1:=proj2 H2). +rewrite Ropp_0, H1'. +now right. +rewrite Rle_bool_true; trivial. +now apply pred_ge_0. +now apply generic_format_opp. +Qed. + +Theorem round_DN_minus_eps: + forall x, F x -> + forall eps, (0 < eps <= if (Rle_bool x 0) then (ulp x) + else (ulp (pred x)))%R -> + round beta fexp Zfloor (x - eps) = pred x. +Proof. +intros x Fx eps Heps. +replace (x-eps)%R with (-(-x+eps))%R by ring. +rewrite round_DN_opp. +unfold pred; apply f_equal. +pattern (-x)%R at 1; rewrite <- (pred_succ (-x)). +apply round_UP_pred_plus_eps. +now apply generic_format_succ, generic_format_opp. +rewrite pred_succ. +rewrite ulp_opp. +generalize Heps; case (Rle_bool_spec x 0); intros H1 H2. +rewrite Rle_bool_false; trivial. +case H1; intros H1'. +apply Rlt_le_trans with (-x)%R. +now apply Ropp_0_gt_lt_contravar. +apply succ_ge_id. +rewrite H1', Ropp_0, succ_eq_pos;[idtac|now right]. +rewrite Rplus_0_l. +apply Rlt_le_trans with (1:=proj1 H2). +rewrite H1' in H2; apply H2. +rewrite Rle_bool_true. +now rewrite succ_opp, ulp_opp. +rewrite succ_opp. +rewrite <- Ropp_0; apply Ropp_le_contravar. +now apply pred_ge_0. +now apply generic_format_opp. +now apply generic_format_opp. +Qed. + +(** Error of a rounding, expressed in number of ulps *) +(** false for x=0 in the FLX format *) +(* was ulp_error *) +Theorem error_lt_ulp : + forall rnd { Zrnd : Valid_rnd rnd } x, + (x <> 0)%R -> + (Rabs (round beta fexp rnd x - x) < ulp x)%R. +Proof with auto with typeclass_instances. +intros rnd Zrnd x Zx. +destruct (generic_format_EM beta fexp x) as [Hx|Hx]. +(* x = rnd x *) +rewrite round_generic... +unfold Rminus. +rewrite Rplus_opp_r, Rabs_R0. +rewrite ulp_neq_0; trivial. +apply bpow_gt_0. +(* x <> rnd x *) +destruct (round_DN_or_UP beta fexp rnd x) as [H|H] ; rewrite H ; clear H. +(* . *) +rewrite Rabs_left1. +rewrite Ropp_minus_distr. +apply Rplus_lt_reg_l with (round beta fexp Zfloor x). +rewrite <- round_UP_DN_ulp with (1 := Hx). +ring_simplify. +assert (Hu: (x <= round beta fexp Zceil x)%R). +apply round_UP_pt... +destruct Hu as [Hu|Hu]. +exact Hu. +elim Hx. +rewrite Hu. +apply generic_format_round... +apply Rle_minus. +apply round_DN_pt... +(* . *) +rewrite Rabs_pos_eq. +rewrite round_UP_DN_ulp with (1 := Hx). +apply Rplus_lt_reg_r with (x - ulp x)%R. +ring_simplify. +assert (Hd: (round beta fexp Zfloor x <= x)%R). +apply round_DN_pt... +destruct Hd as [Hd|Hd]. +exact Hd. +elim Hx. +rewrite <- Hd. +apply generic_format_round... +apply Rle_0_minus. +apply round_UP_pt... +Qed. + +(* was ulp_error_le *) +Theorem error_le_ulp : + forall rnd { Zrnd : Valid_rnd rnd } x, + (Rabs (round beta fexp rnd x - x) <= ulp x)%R. +Proof with auto with typeclass_instances. +intros rnd Zrnd x. +case (Req_dec x 0). +intros Zx; rewrite Zx, round_0... +unfold Rminus; rewrite Rplus_0_l, Ropp_0, Rabs_R0. +apply ulp_ge_0. +intros Zx; left. +now apply error_lt_ulp. +Qed. + +Theorem error_le_half_ulp : + forall choice x, + (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * ulp x)%R. +Proof with auto with typeclass_instances. +intros choice x. +destruct (generic_format_EM beta fexp x) as [Hx|Hx]. +(* x = rnd x *) +rewrite round_generic... +unfold Rminus. +rewrite Rplus_opp_r, Rabs_R0. +apply Rmult_le_pos. +apply Rlt_le. +apply Rinv_0_lt_compat. +now apply IZR_lt. +apply ulp_ge_0. +(* x <> rnd x *) +set (d := round beta fexp Zfloor x). +destruct (round_N_pt beta fexp choice x) as (Hr1, Hr2). +destruct (Rle_or_lt (x - d) (d + ulp x - x)) as [H|H]. +(* . rnd(x) = rndd(x) *) +apply Rle_trans with (Rabs (d - x)). +apply Hr2. +apply (round_DN_pt beta fexp x). +rewrite Rabs_left1. +rewrite Ropp_minus_distr. +apply Rmult_le_reg_r with 2%R. +now apply IZR_lt. +apply Rplus_le_reg_r with (d - x)%R. +ring_simplify. +apply Rle_trans with (1 := H). +right. field. +apply Rle_minus. +apply (round_DN_pt beta fexp x). +(* . rnd(x) = rndu(x) *) +assert (Hu: (d + ulp x)%R = round beta fexp Zceil x). +unfold d. +now rewrite <- round_UP_DN_ulp. +apply Rle_trans with (Rabs (d + ulp x - x)). +apply Hr2. +rewrite Hu. +apply (round_UP_pt beta fexp x). +rewrite Rabs_pos_eq. +apply Rmult_le_reg_r with 2%R. +now apply IZR_lt. +apply Rplus_le_reg_r with (- (d + ulp x - x))%R. +ring_simplify. +apply Rlt_le. +apply Rlt_le_trans with (1 := H). +right. field. +apply Rle_0_minus. +rewrite Hu. +apply (round_UP_pt beta fexp x). +Qed. + +Theorem ulp_DN : + forall x, (0 <= x)%R -> + ulp (round beta fexp Zfloor x) = ulp x. +Proof with auto with typeclass_instances. +intros x [Hx|Hx]. +- rewrite (ulp_neq_0 x) by now apply Rgt_not_eq. + destruct (round_ge_generic beta fexp Zfloor 0 x) as [Hd|Hd]. + apply generic_format_0. + now apply Rlt_le. + + rewrite ulp_neq_0 by now apply Rgt_not_eq. + now rewrite cexp_DN with (2 := Hd). + + rewrite <- Hd. + unfold cexp. + destruct (mag beta x) as [e He]. + simpl. + specialize (He (Rgt_not_eq _ _ Hx)). + apply sym_eq in Hd. + assert (H := exp_small_round_0 _ _ _ _ _ He Hd). + unfold ulp. + rewrite Req_bool_true by easy. + destruct negligible_exp_spec as [H0|k Hk]. + now elim Zlt_not_le with (1 := H0 e). + now apply f_equal, fexp_negligible_exp_eq. +- rewrite <- Hx, round_0... +Qed. + +Theorem round_neq_0_negligible_exp : + negligible_exp = None -> forall rnd { Zrnd : Valid_rnd rnd } x, + (x <> 0)%R -> (round beta fexp rnd x <> 0)%R. +Proof with auto with typeclass_instances. +intros H rndn Hrnd x Hx K. +case negligible_exp_spec'. +intros (_,Hn). +destruct (mag beta x) as (e,He). +absurd (fexp e < e)%Z. +apply Zle_not_lt. +apply exp_small_round_0 with beta rndn x... +apply (Hn e). +intros (n,(H1,_)). +rewrite H in H1; discriminate. +Qed. + +(** allows rnd x to be 0 *) +Theorem error_lt_ulp_round : + forall { Hm : Monotone_exp fexp } rnd { Zrnd : Valid_rnd rnd } x, + (x <> 0)%R -> + (Rabs (round beta fexp rnd x - x) < ulp (round beta fexp rnd x))%R. +Proof with auto with typeclass_instances. +intros Hm. +(* wlog *) +cut (forall rnd : R -> Z, Valid_rnd rnd -> forall x : R, (0 < x)%R -> + (Rabs (round beta fexp rnd x - x) < ulp (round beta fexp rnd x))%R). +intros M rnd Hrnd x Zx. +case (Rle_or_lt 0 x). +intros H; destruct H. +now apply M. +contradict H; now apply sym_not_eq. +intros H. +rewrite <- (Ropp_involutive x). +rewrite round_opp, ulp_opp. +replace (- round beta fexp (Zrnd_opp rnd) (- x) - - - x)%R with + (-(round beta fexp (Zrnd_opp rnd) (- x) - (-x)))%R by ring. +rewrite Rabs_Ropp. +apply M. +now apply valid_rnd_opp. +now apply Ropp_0_gt_lt_contravar. +(* 0 < x *) +intros rnd Hrnd x Hx. +apply Rlt_le_trans with (ulp x). +apply error_lt_ulp... +now apply Rgt_not_eq. +rewrite <- ulp_DN; trivial. +apply ulp_le_pos. +apply round_ge_generic... +apply generic_format_0. +now apply Rlt_le. +case (round_DN_or_UP beta fexp rnd x); intros V; rewrite V. +apply Rle_refl. +apply Rle_trans with x. +apply round_DN_pt... +apply round_UP_pt... +now apply Rlt_le. +Qed. + +Lemma error_le_ulp_round : + forall { Hm : Monotone_exp fexp } rnd { Zrnd : Valid_rnd rnd } x, + (Rabs (round beta fexp rnd x - x) <= ulp (round beta fexp rnd x))%R. +Proof. +intros Mexp rnd Vrnd x. +destruct (Req_dec x 0) as [Zx|Nzx]. +{ rewrite Zx, round_0; [|exact Vrnd]. + unfold Rminus; rewrite Ropp_0, Rplus_0_l, Rabs_R0; apply ulp_ge_0. } +now apply Rlt_le, error_lt_ulp_round. +Qed. + +(** allows both x and rnd x to be 0 *) +Theorem error_le_half_ulp_round : + forall { Hm : Monotone_exp fexp }, + forall choice x, + (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * ulp (round beta fexp (Znearest choice) x))%R. +Proof with auto with typeclass_instances. +intros Hm choice x. +case (Req_dec (round beta fexp (Znearest choice) x) 0); intros Hfx. +(* *) +case (Req_dec x 0); intros Hx. +apply Rle_trans with (1:=error_le_half_ulp _ _). +rewrite Hx, round_0... +right; ring. +generalize (error_le_half_ulp choice x). +rewrite Hfx. +unfold Rminus; rewrite Rplus_0_l, Rabs_Ropp. +intros N. +unfold ulp; rewrite Req_bool_true; trivial. +case negligible_exp_spec'. +intros (H1,H2). +contradict Hfx. +apply round_neq_0_negligible_exp... +intros (n,(H1,Hn)); rewrite H1. +apply Rle_trans with (1:=N). +right; apply f_equal. +rewrite ulp_neq_0; trivial. +apply f_equal. +unfold cexp. +apply valid_exp; trivial. +assert (mag beta x -1 < fexp n)%Z;[idtac|omega]. +apply lt_bpow with beta. +destruct (mag beta x) as (e,He). +simpl. +apply Rle_lt_trans with (Rabs x). +now apply He. +apply Rle_lt_trans with (Rabs (round beta fexp (Znearest choice) x - x)). +right; rewrite Hfx; unfold Rminus; rewrite Rplus_0_l. +apply sym_eq, Rabs_Ropp. +apply Rlt_le_trans with (ulp 0). +rewrite <- Hfx. +apply error_lt_ulp_round... +unfold ulp; rewrite Req_bool_true, H1; trivial. +now right. +(* *) +case (round_DN_or_UP beta fexp (Znearest choice) x); intros Hx. +(* . *) +destruct (Rle_or_lt 0 x) as [H|H]. +rewrite Hx at 2. +rewrite ulp_DN by easy. +apply error_le_half_ulp. +apply Rle_trans with (1:=error_le_half_ulp _ _). +apply Rmult_le_compat_l. +apply Rlt_le, pos_half_prf. +apply ulp_le. +rewrite Rabs_left1 by now apply Rlt_le. +rewrite Hx. +rewrite Rabs_left1. +apply Ropp_le_contravar. +apply round_DN_pt... +apply round_le_generic... +apply generic_format_0. +now apply Rlt_le. +(* . *) +destruct (Rle_or_lt 0 x) as [H|H]. +apply Rle_trans with (1:=error_le_half_ulp _ _). +apply Rmult_le_compat_l. +apply Rlt_le, pos_half_prf. +apply ulp_le_pos; trivial. +rewrite Hx; apply (round_UP_pt beta fexp x). +rewrite Hx at 2; rewrite <- (ulp_opp (round beta fexp Zceil x)). +rewrite <- round_DN_opp. +rewrite ulp_DN; trivial. +pattern x at 1 2; rewrite <- Ropp_involutive. +rewrite round_N_opp. +unfold Rminus. +rewrite <- Ropp_plus_distr, Rabs_Ropp. +apply error_le_half_ulp. +rewrite <- Ropp_0. +apply Ropp_le_contravar. +now apply Rlt_le. +Qed. + +Theorem pred_le : + forall x y, F x -> F y -> (x <= y)%R -> + (pred x <= pred y)%R. +Proof. +intros x y Fx Fy [Hxy| ->]. +2: apply Rle_refl. +apply pred_ge_gt with (2 := Fy). +now apply generic_format_pred. +apply Rle_lt_trans with (2 := Hxy). +apply pred_le_id. +Qed. + +Theorem succ_le : + forall x y, F x -> F y -> (x <= y)%R -> + (succ x <= succ y)%R. +Proof. +intros x y Fx Fy Hxy. +apply Ropp_le_cancel. +rewrite <- 2!pred_opp. +apply pred_le. +now apply generic_format_opp. +now apply generic_format_opp. +now apply Ropp_le_contravar. +Qed. + +Theorem pred_le_inv: forall x y, F x -> F y + -> (pred x <= pred y)%R -> (x <= y)%R. +Proof. +intros x y Fx Fy Hxy. +rewrite <- (succ_pred x), <- (succ_pred y); try assumption. +apply succ_le; trivial; now apply generic_format_pred. +Qed. + +Theorem succ_le_inv: forall x y, F x -> F y + -> (succ x <= succ y)%R -> (x <= y)%R. +Proof. +intros x y Fx Fy Hxy. +rewrite <- (pred_succ x), <- (pred_succ y); try assumption. +apply pred_le; trivial; now apply generic_format_succ. +Qed. + +Theorem pred_lt : + forall x y, F x -> F y -> (x < y)%R -> + (pred x < pred y)%R. +Proof. +intros x y Fx Fy Hxy. +apply Rnot_le_lt. +intros H. +apply Rgt_not_le with (1 := Hxy). +now apply pred_le_inv. +Qed. + +Theorem succ_lt : + forall x y, F x -> F y -> (x < y)%R -> + (succ x < succ y)%R. +Proof. +intros x y Fx Fy Hxy. +apply Rnot_le_lt. +intros H. +apply Rgt_not_le with (1 := Hxy). +now apply succ_le_inv. +Qed. + +(** Adding [ulp] is a, somewhat reasonable, overapproximation of [succ]. *) +Lemma succ_le_plus_ulp : + forall { Hm : Monotone_exp fexp } x, + (succ x <= x + ulp x)%R. +Proof. +intros Mexp x. +destruct (Rle_or_lt 0 x) as [Px|Nx]; [now right; apply succ_eq_pos|]. +replace (_ + _)%R with (- (-x - ulp x))%R by ring. +unfold succ; rewrite (Rle_bool_false _ _ Nx), <-ulp_opp. +apply Ropp_le_contravar; unfold pred_pos. +destruct (Req_dec (-x) (bpow (mag beta (-x) - 1))) as [Hx|Hx]. +{ rewrite (Req_bool_true _ _ Hx). + apply (Rplus_le_reg_r x); ring_simplify; apply Ropp_le_contravar. + unfold ulp; rewrite Req_bool_false; [|lra]. + apply bpow_le, Mexp; lia. } + now rewrite (Req_bool_false _ _ Hx); right. +Qed. + +(** And it also lies in the format. *) +Lemma generic_format_plus_ulp : + forall { Hm : Monotone_exp fexp } x, + generic_format beta fexp x -> + generic_format beta fexp (x + ulp x). +Proof. +intros Mexp x Fx. +destruct (Rle_or_lt 0 x) as [Px|Nx]. +{ now rewrite <-(succ_eq_pos _ Px); apply generic_format_succ. } +apply generic_format_opp in Fx. +replace (_ + _)%R with (- (-x - ulp x))%R by ring. +apply generic_format_opp; rewrite <-ulp_opp. +destruct (Req_dec (-x) (bpow (mag beta (-x) - 1))) as [Hx|Hx]. +{ unfold ulp; rewrite Req_bool_false; [|lra]. + rewrite Hx at 1. + unfold cexp. + set (e := mag _ _). + assert (Hfe : (fexp e < e)%Z). + { now apply mag_generic_gt; [|lra|]. } + replace (e - 1)%Z with (e - 1 - fexp e + fexp e)%Z by ring. + rewrite bpow_plus. + set (m := bpow (_ - _)). + replace (_ - _)%R with ((m - 1) * bpow (fexp e))%R; [|unfold m; ring]. + case_eq (e - 1 - fexp e)%Z. + { intro He; unfold m; rewrite He; simpl; ring_simplify (1 - 1)%R. + rewrite Rmult_0_l; apply generic_format_0. } + { intros p Hp; unfold m; rewrite Hp; simpl. + pose (f := {| Defs.Fnum := (Z.pow_pos beta p - 1)%Z; + Defs.Fexp := fexp e |} : Defs.float beta). + apply (generic_format_F2R' _ _ _ f); [|intro Hm'; unfold f; simpl]. + { now unfold Defs.F2R; simpl; rewrite minus_IZR. } + unfold cexp. + replace (IZR _) with (bpow (Z.pos p)); [|now simpl]. + rewrite <-Hp. + assert (He : (1 <= e - 1 - fexp e)%Z); [lia|]. + set (e' := mag _ (_ * _)). + assert (H : (e' = e - 1 :> Z)%Z); [|rewrite H; apply Mexp; lia]. + unfold e'; apply mag_unique. + rewrite Rabs_mult, (Rabs_pos_eq (bpow _)); [|apply bpow_ge_0]. + rewrite Rabs_pos_eq; + [|apply (Rplus_le_reg_r 1); ring_simplify; + change 1%R with (bpow 0); apply bpow_le; lia]. + assert (beta_pos : (0 < IZR beta)%R). + { apply (Rlt_le_trans _ 2); [lra|]. + apply IZR_le, Z.leb_le, radix_prop. } + split. + { replace (e - 1 - 1)%Z with (e - 1 - fexp e + -1 + fexp e)%Z by ring. + rewrite bpow_plus. + apply Rmult_le_compat_r; [apply bpow_ge_0|]. + rewrite bpow_plus; simpl; unfold Z.pow_pos; simpl. + rewrite Zmult_1_r. + apply (Rmult_le_reg_r _ _ _ beta_pos). + rewrite Rmult_assoc, Rinv_l; [|lra]; rewrite Rmult_1_r. + apply (Rplus_le_reg_r (IZR beta)); ring_simplify. + apply (Rle_trans _ (2 * bpow (e - 1 - fexp e))). + { change 2%R with (1 + 1)%R; rewrite Rmult_plus_distr_r, Rmult_1_l. + apply Rplus_le_compat_l. + rewrite <-bpow_1; apply bpow_le; lia. } + rewrite Rmult_comm; apply Rmult_le_compat_l; [apply bpow_ge_0|]. + apply IZR_le, Z.leb_le, radix_prop. } + apply (Rmult_lt_reg_r (bpow (- fexp e))); [apply bpow_gt_0|]. + rewrite Rmult_assoc, <-!bpow_plus. + replace (fexp e + - fexp e)%Z with 0%Z by ring; simpl. + rewrite Rmult_1_r; unfold Zminus; lra. } + intros p Hp; exfalso; lia. } +replace (_ - _)%R with (pred_pos (-x)). +{ now apply generic_format_pred_pos; [|lra]. } +now unfold pred_pos; rewrite Req_bool_false. +Qed. + +Theorem round_DN_ge_UP_gt : + forall x y, F y -> + (y < round beta fexp Zceil x -> y <= round beta fexp Zfloor x)%R. +Proof with auto with typeclass_instances. +intros x y Fy Hlt. +apply round_DN_pt... +apply Rnot_lt_le. +contradict Hlt. +apply RIneq.Rle_not_lt. +apply round_UP_pt... +now apply Rlt_le. +Qed. + +Theorem round_UP_le_DN_lt : + forall x y, F y -> + (round beta fexp Zfloor x < y -> round beta fexp Zceil x <= y)%R. +Proof with auto with typeclass_instances. +intros x y Fy Hlt. +apply round_UP_pt... +apply Rnot_lt_le. +contradict Hlt. +apply RIneq.Rle_not_lt. +apply round_DN_pt... +now apply Rlt_le. +Qed. + +Theorem pred_UP_le_DN : + forall x, (pred (round beta fexp Zceil x) <= round beta fexp Zfloor x)%R. +Proof with auto with typeclass_instances. +intros x. +destruct (generic_format_EM beta fexp x) as [Fx|Fx]. +rewrite !round_generic... +apply pred_le_id. +case (Req_dec (round beta fexp Zceil x) 0); intros Zx. +rewrite Zx; unfold pred; rewrite Ropp_0. +unfold succ; rewrite Rle_bool_true;[idtac|now right]. +rewrite Rplus_0_l; unfold ulp; rewrite Req_bool_true; trivial. +case negligible_exp_spec'. +intros (H1,H2). +contradict Zx; apply round_neq_0_negligible_exp... +intros L; apply Fx; rewrite L; apply generic_format_0. +intros (n,(H1,Hn)); rewrite H1. +case (Rle_or_lt (- bpow (fexp n)) (round beta fexp Zfloor x)); trivial; intros K. +absurd (round beta fexp Zceil x <= - bpow (fexp n))%R. +apply Rlt_not_le. +rewrite Zx, <- Ropp_0. +apply Ropp_lt_contravar, bpow_gt_0. +apply round_UP_le_DN_lt; try assumption. +apply generic_format_opp, generic_format_bpow. +now apply valid_exp. +assert (let u := round beta fexp Zceil x in pred u < u)%R as Hup. +now apply pred_lt_id. +apply round_DN_ge_UP_gt... +apply generic_format_pred... +now apply round_UP_pt. +Qed. + +Theorem UP_le_succ_DN : + forall x, (round beta fexp Zceil x <= succ (round beta fexp Zfloor x))%R. +Proof. +intros x. +rewrite <- (Ropp_involutive x). +rewrite round_DN_opp, round_UP_opp, succ_opp. +apply Ropp_le_contravar. +apply pred_UP_le_DN. +Qed. + +Theorem pred_UP_eq_DN : + forall x, ~ F x -> + (pred (round beta fexp Zceil x) = round beta fexp Zfloor x)%R. +Proof with auto with typeclass_instances. +intros x Fx. +apply Rle_antisym. +now apply pred_UP_le_DN. +apply pred_ge_gt; try apply generic_format_round... +pose proof round_DN_UP_lt _ _ _ Fx as HE. +now apply Rlt_trans with (1 := proj1 HE) (2 := proj2 HE). +Qed. + +Theorem succ_DN_eq_UP : + forall x, ~ F x -> + (succ (round beta fexp Zfloor x) = round beta fexp Zceil x)%R. +Proof with auto with typeclass_instances. +intros x Fx. +rewrite <- pred_UP_eq_DN; trivial. +rewrite succ_pred; trivial. +apply generic_format_round... +Qed. + +Theorem round_DN_eq : + forall x d, F d -> (d <= x < succ d)%R -> + round beta fexp Zfloor x = d. +Proof with auto with typeclass_instances. +intros x d Fd (Hxd1,Hxd2). +generalize (round_DN_pt beta fexp x); intros (T1,(T2,T3)). +apply sym_eq, Rle_antisym. +now apply T3. +destruct (generic_format_EM beta fexp x) as [Fx|NFx]. +rewrite round_generic... +apply succ_le_inv; try assumption. +apply succ_le_lt; try assumption. +apply generic_format_succ... +apply succ_le_inv; try assumption. +rewrite succ_DN_eq_UP; trivial. +apply round_UP_pt... +apply generic_format_succ... +now left. +Qed. + +Theorem round_UP_eq : + forall x u, F u -> (pred u < x <= u)%R -> + round beta fexp Zceil x = u. +Proof with auto with typeclass_instances. +intros x u Fu Hux. +rewrite <- (Ropp_involutive (round beta fexp Zceil x)). +rewrite <- round_DN_opp. +rewrite <- (Ropp_involutive u). +apply f_equal. +apply round_DN_eq; try assumption. +now apply generic_format_opp. +split;[now apply Ropp_le_contravar|idtac]. +rewrite succ_opp. +now apply Ropp_lt_contravar. +Qed. + +Lemma ulp_ulp_0 : forall {H : Exp_not_FTZ fexp}, + ulp (ulp 0) = ulp 0. +Proof. +intros H; case (negligible_exp_spec'). +intros (K1,K2). +replace (ulp 0) with 0%R at 1; try easy. +apply sym_eq; unfold ulp; rewrite Req_bool_true; try easy. +now rewrite K1. +intros (n,(Hn1,Hn2)). +apply Rle_antisym. +replace (ulp 0) with (bpow (fexp n)). +rewrite ulp_bpow. +apply bpow_le. +now apply valid_exp. +unfold ulp; rewrite Req_bool_true; try easy. +rewrite Hn1; easy. +now apply ulp_ge_ulp_0. +Qed. + + +Lemma ulp_succ_pos : forall x, F x -> (0 < x)%R -> + ulp (succ x) = ulp x \/ succ x = bpow (mag beta x). +Proof with auto with typeclass_instances. +intros x Fx Hx. +generalize (Rlt_le _ _ Hx); intros Hx'. +rewrite succ_eq_pos;[idtac|now left]. +destruct (mag beta x) as (e,He); simpl. +rewrite Rabs_pos_eq in He; try easy. +specialize (He (Rgt_not_eq _ _ Hx)). +assert (H:(x+ulp x <= bpow e)%R). +apply id_p_ulp_le_bpow; try assumption. +apply He. +destruct H;[left|now right]. +rewrite ulp_neq_0 at 1. +2: apply Rgt_not_eq, Rgt_lt, Rlt_le_trans with x... +2: rewrite <- (Rplus_0_r x) at 1; apply Rplus_le_compat_l. +2: apply ulp_ge_0. +rewrite ulp_neq_0 at 2. +2: now apply Rgt_not_eq. +f_equal; unfold cexp; f_equal. +apply trans_eq with e. +apply mag_unique_pos; split; try assumption. +apply Rle_trans with (1:=proj1 He). +rewrite <- (Rplus_0_r x) at 1; apply Rplus_le_compat_l. +apply ulp_ge_0. +now apply sym_eq, mag_unique_pos. +Qed. + + +Lemma ulp_round_pos : + forall { Not_FTZ_ : Exp_not_FTZ fexp}, + forall rnd { Zrnd : Valid_rnd rnd } x, + (0 < x)%R -> ulp (round beta fexp rnd x) = ulp x + \/ round beta fexp rnd x = bpow (mag beta x). +Proof with auto with typeclass_instances. +intros Not_FTZ_ rnd Zrnd x Hx. +case (generic_format_EM beta fexp x); intros Fx. +rewrite round_generic... +case (round_DN_or_UP beta fexp rnd x); intros Hr; rewrite Hr. +left. +apply ulp_DN; now left... +assert (M:(0 <= round beta fexp Zfloor x)%R). +apply round_ge_generic... +apply generic_format_0... +apply Rlt_le... +destruct M as [M|M]. +rewrite <- (succ_DN_eq_UP x)... +case (ulp_succ_pos (round beta fexp Zfloor x)); try intros Y. +apply generic_format_round... +assumption. +rewrite ulp_DN in Y... +now apply Rlt_le. +right; rewrite Y. +apply f_equal, mag_DN... +left; rewrite <- (succ_DN_eq_UP x)... +rewrite <- M, succ_0. +rewrite ulp_ulp_0... +case (negligible_exp_spec'). +intros (K1,K2). +absurd (x = 0)%R. +now apply Rgt_not_eq. +apply eq_0_round_0_negligible_exp with Zfloor... +intros (n,(Hn1,Hn2)). +replace (ulp 0) with (bpow (fexp n)). +2: unfold ulp; rewrite Req_bool_true; try easy. +2: now rewrite Hn1. +rewrite ulp_neq_0. +2: apply Rgt_not_eq... +unfold cexp; f_equal. +destruct (mag beta x) as (e,He); simpl. +apply sym_eq, valid_exp... +assert (e <= fexp e)%Z. +apply exp_small_round_0_pos with beta Zfloor x... +rewrite <- (Rabs_pos_eq x). +apply He, Rgt_not_eq... +apply Rlt_le... +replace (fexp n) with (fexp e); try assumption. +now apply fexp_negligible_exp_eq. +Qed. + + +Theorem ulp_round : forall { Not_FTZ_ : Exp_not_FTZ fexp}, + forall rnd { Zrnd : Valid_rnd rnd } x, + ulp (round beta fexp rnd x) = ulp x + \/ Rabs (round beta fexp rnd x) = bpow (mag beta x). +Proof with auto with typeclass_instances. +intros Not_FTZ_ rnd Zrnd x. +case (Rtotal_order x 0); intros Zx. +case (ulp_round_pos (Zrnd_opp rnd) (-x)). +now apply Ropp_0_gt_lt_contravar. +rewrite ulp_opp, <- ulp_opp. +rewrite <- round_opp, Ropp_involutive. +intros Y;now left. +rewrite mag_opp. +intros Y; right. +rewrite <- (Ropp_involutive x) at 1. +rewrite round_opp, Y. +rewrite Rabs_Ropp, Rabs_right... +apply Rle_ge, bpow_ge_0. +destruct Zx as [Zx|Zx]. +left; rewrite Zx; rewrite round_0... +rewrite Rabs_right. +apply ulp_round_pos... +apply Rle_ge, round_ge_generic... +apply generic_format_0... +now apply Rlt_le. +Qed. + +Lemma succ_round_ge_id : + forall rnd { Zrnd : Valid_rnd rnd } x, + (x <= succ (round beta fexp rnd x))%R. +Proof. +intros rnd Vrnd x. +apply (Rle_trans _ (round beta fexp Raux.Zceil x)). +{ now apply round_UP_pt. } +destruct (round_DN_or_UP beta fexp rnd x) as [Hr|Hr]; rewrite Hr. +{ now apply UP_le_succ_DN. } +apply succ_ge_id. +Qed. + +(** Properties of rounding to nearest and ulp *) + +Theorem round_N_le_midp: forall choice u v, + F u -> (v < (u + succ u)/2)%R + -> (round beta fexp (Znearest choice) v <= u)%R. +Proof with auto with typeclass_instances. +intros choice u v Fu H. +(* . *) +assert (V: ((succ u = 0 /\ u = 0) \/ u < succ u)%R). +specialize (succ_ge_id u); intros P; destruct P as [P|P]. +now right. +case (Req_dec u 0); intros Zu. +left; split; trivial. +now rewrite <- P. +right; now apply succ_gt_id. +(* *) +destruct V as [(V1,V2)|V]. +rewrite V2; apply round_le_generic... +apply generic_format_0. +left; apply Rlt_le_trans with (1:=H). +rewrite V1,V2; right; field. +(* *) +assert (T: (u < (u + succ u) / 2 < succ u)%R) by lra. +destruct T as (T1,T2). +apply Rnd_N_pt_monotone with F v ((u + succ u) / 2)%R... +apply round_N_pt... +apply Rnd_N_pt_DN with (succ u)%R. +pattern u at 3; replace u with (round beta fexp Zfloor ((u + succ u) / 2)). +apply round_DN_pt... +apply round_DN_eq; trivial. +split; try left; assumption. +pattern (succ u) at 2; replace (succ u) with (round beta fexp Zceil ((u + succ u) / 2)). +apply round_UP_pt... +apply round_UP_eq; trivial. +apply generic_format_succ... +rewrite pred_succ; trivial. +split; try left; assumption. +right; field. +Qed. + + +Theorem round_N_ge_midp: forall choice u v, + F u -> ((u + pred u)/2 < v)%R + -> (u <= round beta fexp (Znearest choice) v)%R. +Proof with auto with typeclass_instances. +intros choice u v Fu H. +rewrite <- (Ropp_involutive v). +rewrite round_N_opp. +rewrite <- (Ropp_involutive u). +apply Ropp_le_contravar. +apply round_N_le_midp. +now apply generic_format_opp. +apply Ropp_lt_cancel. +rewrite Ropp_involutive. +apply Rle_lt_trans with (2:=H). +unfold pred. +right; field. +Qed. + + +Lemma round_N_eq_DN: forall choice x, + let d:=round beta fexp Zfloor x in + let u:=round beta fexp Zceil x in + (x<(d+u)/2)%R -> + round beta fexp (Znearest choice) x = d. +Proof with auto with typeclass_instances. +intros choice x d u H. +apply Rle_antisym. +destruct (generic_format_EM beta fexp x) as [Fx|Fx]. +rewrite round_generic... +apply round_DN_pt; trivial; now right. +apply round_N_le_midp. +apply round_DN_pt... +apply Rlt_le_trans with (1:=H). +right; apply f_equal2; trivial; apply f_equal. +now apply sym_eq, succ_DN_eq_UP. +apply round_ge_generic; try apply round_DN_pt... +Qed. + +Lemma round_N_eq_DN_pt: forall choice x d u, + Rnd_DN_pt F x d -> Rnd_UP_pt F x u -> + (x<(d+u)/2)%R -> + round beta fexp (Znearest choice) x = d. +Proof with auto with typeclass_instances. +intros choice x d u Hd Hu H. +assert (H0:(d = round beta fexp Zfloor x)%R). +apply Rnd_DN_pt_unique with (1:=Hd). +apply round_DN_pt... +rewrite H0. +apply round_N_eq_DN. +rewrite <- H0. +rewrite Rnd_UP_pt_unique with F x (round beta fexp Zceil x) u; try assumption. +apply round_UP_pt... +Qed. + +Lemma round_N_eq_UP: forall choice x, + let d:=round beta fexp Zfloor x in + let u:=round beta fexp Zceil x in + ((d+u)/2 < x)%R -> + round beta fexp (Znearest choice) x = u. +Proof with auto with typeclass_instances. +intros choice x d u H. +apply Rle_antisym. +apply round_le_generic; try apply round_UP_pt... +destruct (generic_format_EM beta fexp x) as [Fx|Fx]. +rewrite round_generic... +apply round_UP_pt; trivial; now right. +apply round_N_ge_midp. +apply round_UP_pt... +apply Rle_lt_trans with (2:=H). +right; apply f_equal2; trivial; rewrite Rplus_comm; apply f_equal2; trivial. +now apply pred_UP_eq_DN. +Qed. + +Lemma round_N_eq_UP_pt: forall choice x d u, + Rnd_DN_pt F x d -> Rnd_UP_pt F x u -> + ((d+u)/2 < x)%R -> + round beta fexp (Znearest choice) x = u. +Proof with auto with typeclass_instances. +intros choice x d u Hd Hu H. +assert (H0:(u = round beta fexp Zceil x)%R). +apply Rnd_UP_pt_unique with (1:=Hu). +apply round_UP_pt... +rewrite H0. +apply round_N_eq_UP. +rewrite <- H0. +rewrite Rnd_DN_pt_unique with F x (round beta fexp Zfloor x) d; try assumption. +apply round_DN_pt... +Qed. + +Lemma round_N_plus_ulp_ge : + forall { Hm : Monotone_exp fexp } choice1 choice2 x, + let rx := round beta fexp (Znearest choice2) x in + (x <= round beta fexp (Znearest choice1) (rx + ulp rx))%R. +Proof. +intros Hm choice1 choice2 x. +simpl. +set (rx := round _ _ _ x). +assert (Vrnd1 : Valid_rnd (Znearest choice1)) by now apply valid_rnd_N. +assert (Vrnd2 : Valid_rnd (Znearest choice2)) by now apply valid_rnd_N. +apply (Rle_trans _ (succ rx)); [now apply succ_round_ge_id|]. +rewrite round_generic; [now apply succ_le_plus_ulp|now simpl|]. +now apply generic_format_plus_ulp, generic_format_round. +Qed. + +End Fcore_ulp. diff --git a/flocq/Core/Zaux.v b/flocq/Core/Zaux.v new file mode 100644 index 00000000..e21d93a4 --- /dev/null +++ b/flocq/Core/Zaux.v @@ -0,0 +1,951 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2011-2018 Sylvie Boldo +#
# +Copyright (C) 2011-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +Require Import ZArith Omega. +Require Import Zquot. + +Section Zmissing. + +(** About Z *) +Theorem Zopp_le_cancel : + forall x y : Z, + (-y <= -x)%Z -> Z.le x y. +Proof. +intros x y Hxy. +apply Zplus_le_reg_r with (-x - y)%Z. +now ring_simplify. +Qed. + +Theorem Zgt_not_eq : + forall x y : Z, + (y < x)%Z -> (x <> y)%Z. +Proof. +intros x y H Hn. +apply Z.lt_irrefl with x. +now rewrite Hn at 1. +Qed. + +End Zmissing. + +Section Proof_Irrelevance. + +Scheme eq_dep_elim := Induction for eq Sort Type. + +Definition eqbool_dep P (h1 : P true) b := + match b return P b -> Prop with + | true => fun (h2 : P true) => h1 = h2 + | false => fun (h2 : P false) => False + end. + +Lemma eqbool_irrelevance : forall (b : bool) (h1 h2 : b = true), h1 = h2. +Proof. +assert (forall (h : true = true), refl_equal true = h). +apply (eq_dep_elim bool true (eqbool_dep _ _) (refl_equal _)). +intros b. +case b. +intros h1 h2. +now rewrite <- (H h1). +intros h. +discriminate h. +Qed. + +End Proof_Irrelevance. + +Section Even_Odd. + +Theorem Zeven_ex : + forall x, exists p, x = (2 * p + if Z.even x then 0 else 1)%Z. +Proof. +intros [|[n|n|]|[n|n|]]. +now exists Z0. +now exists (Zpos n). +now exists (Zpos n). +now exists Z0. +exists (Zneg n - 1)%Z. +change (2 * Zneg n - 1 = 2 * (Zneg n - 1) + 1)%Z. +ring. +now exists (Zneg n). +now exists (-1)%Z. +Qed. + +End Even_Odd. + +Section Zpower. + +Theorem Zpower_plus : + forall n k1 k2, (0 <= k1)%Z -> (0 <= k2)%Z -> + Zpower n (k1 + k2) = (Zpower n k1 * Zpower n k2)%Z. +Proof. +intros n k1 k2 H1 H2. +now apply Zpower_exp ; apply Z.le_ge. +Qed. + +Theorem Zpower_Zpower_nat : + forall b e, (0 <= e)%Z -> + Zpower b e = Zpower_nat b (Z.abs_nat e). +Proof. +intros b [|e|e] He. +apply refl_equal. +apply Zpower_pos_nat. +elim He. +apply refl_equal. +Qed. + +Theorem Zpower_nat_S : + forall b e, + Zpower_nat b (S e) = (b * Zpower_nat b e)%Z. +Proof. +intros b e. +rewrite (Zpower_nat_is_exp 1 e). +apply (f_equal (fun x => x * _)%Z). +apply Zmult_1_r. +Qed. + +Theorem Zpower_pos_gt_0 : + forall b p, (0 < b)%Z -> + (0 < Zpower_pos b p)%Z. +Proof. +intros b p Hb. +rewrite Zpower_pos_nat. +induction (nat_of_P p). +easy. +rewrite Zpower_nat_S. +now apply Zmult_lt_0_compat. +Qed. + +Theorem Zeven_Zpower_odd : + forall b e, (0 <= e)%Z -> Z.even b = false -> + Z.even (Zpower b e) = false. +Proof. +intros b e He Hb. +destruct (Z_le_lt_eq_dec _ _ He) as [He'|He']. +rewrite <- Hb. +now apply Z.even_pow. +now rewrite <- He'. +Qed. + +(** The radix must be greater than 1 *) +Record radix := { radix_val :> Z ; radix_prop : Zle_bool 2 radix_val = true }. + +Theorem radix_val_inj : + forall r1 r2, radix_val r1 = radix_val r2 -> r1 = r2. +Proof. +intros (r1, H1) (r2, H2) H. +simpl in H. +revert H1. +rewrite H. +intros H1. +apply f_equal. +apply eqbool_irrelevance. +Qed. + +Definition radix2 := Build_radix 2 (refl_equal _). + +Variable r : radix. + +Theorem radix_gt_0 : (0 < r)%Z. +Proof. +apply Z.lt_le_trans with 2%Z. +easy. +apply Zle_bool_imp_le. +apply r. +Qed. + +Theorem radix_gt_1 : (1 < r)%Z. +Proof. +destruct r as (v, Hr). simpl. +apply Z.lt_le_trans with 2%Z. +easy. +now apply Zle_bool_imp_le. +Qed. + +Theorem Zpower_gt_1 : + forall p, + (0 < p)%Z -> + (1 < Zpower r p)%Z. +Proof. +intros [|p|p] Hp ; try easy. +simpl. +rewrite Zpower_pos_nat. +generalize (lt_O_nat_of_P p). +induction (nat_of_P p). +easy. +intros _. +rewrite Zpower_nat_S. +assert (0 < Zpower_nat r n)%Z. +clear. +induction n. +easy. +rewrite Zpower_nat_S. +apply Zmult_lt_0_compat with (2 := IHn). +apply radix_gt_0. +apply Z.le_lt_trans with (1 * Zpower_nat r n)%Z. +rewrite Zmult_1_l. +now apply (Zlt_le_succ 0). +apply Zmult_lt_compat_r with (1 := H). +apply radix_gt_1. +Qed. + +Theorem Zpower_gt_0 : + forall p, + (0 <= p)%Z -> + (0 < Zpower r p)%Z. +Proof. +intros p Hp. +rewrite Zpower_Zpower_nat with (1 := Hp). +induction (Z.abs_nat p). +easy. +rewrite Zpower_nat_S. +apply Zmult_lt_0_compat with (2 := IHn). +apply radix_gt_0. +Qed. + +Theorem Zpower_ge_0 : + forall e, + (0 <= Zpower r e)%Z. +Proof. +intros [|e|e] ; try easy. +apply Zlt_le_weak. +now apply Zpower_gt_0. +Qed. + +Theorem Zpower_le : + forall e1 e2, (e1 <= e2)%Z -> + (Zpower r e1 <= Zpower r e2)%Z. +Proof. +intros e1 e2 He. +destruct (Zle_or_lt 0 e1)%Z as [H1|H1]. +replace e2 with (e2 - e1 + e1)%Z by ring. +rewrite Zpower_plus with (2 := H1). +rewrite <- (Zmult_1_l (r ^ e1)) at 1. +apply Zmult_le_compat_r. +apply (Zlt_le_succ 0). +apply Zpower_gt_0. +now apply Zle_minus_le_0. +apply Zpower_ge_0. +now apply Zle_minus_le_0. +clear He. +destruct e1 as [|e1|e1] ; try easy. +apply Zpower_ge_0. +Qed. + +Theorem Zpower_lt : + forall e1 e2, (0 <= e2)%Z -> (e1 < e2)%Z -> + (Zpower r e1 < Zpower r e2)%Z. +Proof. +intros e1 e2 He2 He. +destruct (Zle_or_lt 0 e1)%Z as [H1|H1]. +replace e2 with (e2 - e1 + e1)%Z by ring. +rewrite Zpower_plus with (2 := H1). +rewrite Zmult_comm. +rewrite <- (Zmult_1_r (r ^ e1)) at 1. +apply Zmult_lt_compat2. +split. +now apply Zpower_gt_0. +apply Z.le_refl. +split. +easy. +apply Zpower_gt_1. +clear -He ; omega. +apply Zle_minus_le_0. +now apply Zlt_le_weak. +revert H1. +clear -He2. +destruct e1 ; try easy. +intros _. +now apply Zpower_gt_0. +Qed. + +Theorem Zpower_lt_Zpower : + forall e1 e2, + (Zpower r (e1 - 1) < Zpower r e2)%Z -> + (e1 <= e2)%Z. +Proof. +intros e1 e2 He. +apply Znot_gt_le. +intros H. +apply Zlt_not_le with (1 := He). +apply Zpower_le. +clear -H ; omega. +Qed. + +Theorem Zpower_gt_id : + forall n, (n < Zpower r n)%Z. +Proof. +intros [|n|n] ; try easy. +simpl. +rewrite Zpower_pos_nat. +rewrite Zpos_eq_Z_of_nat_o_nat_of_P. +induction (nat_of_P n). +easy. +rewrite inj_S. +change (Zpower_nat r (S n0)) with (r * Zpower_nat r n0)%Z. +unfold Z.succ. +apply Z.lt_le_trans with (r * (Z_of_nat n0 + 1))%Z. +clear. +apply Zlt_0_minus_lt. +replace (r * (Z_of_nat n0 + 1) - (Z_of_nat n0 + 1))%Z with ((r - 1) * (Z_of_nat n0 + 1))%Z by ring. +apply Zmult_lt_0_compat. +cut (2 <= r)%Z. omega. +apply Zle_bool_imp_le. +apply r. +apply (Zle_lt_succ 0). +apply Zle_0_nat. +apply Zmult_le_compat_l. +now apply Zlt_le_succ. +apply Z.le_trans with 2%Z. +easy. +apply Zle_bool_imp_le. +apply r. +Qed. + +End Zpower. + +Section Div_Mod. + +Theorem Zmod_mod_mult : + forall n a b, (0 < a)%Z -> (0 <= b)%Z -> + Zmod (Zmod n (a * b)) b = Zmod n b. +Proof. +intros n a [|b|b] Ha Hb. +now rewrite 2!Zmod_0_r. +rewrite (Zmod_eq n (a * Zpos b)). +rewrite Zmult_assoc. +unfold Zminus. +rewrite Zopp_mult_distr_l. +apply Z_mod_plus. +easy. +apply Zmult_gt_0_compat. +now apply Z.lt_gt. +easy. +now elim Hb. +Qed. + +Theorem ZOmod_eq : + forall a b, + Z.rem a b = (a - Z.quot a b * b)%Z. +Proof. +intros a b. +rewrite (Z.quot_rem' a b) at 2. +ring. +Qed. + +Theorem ZOmod_mod_mult : + forall n a b, + Z.rem (Z.rem n (a * b)) b = Z.rem n b. +Proof. +intros n a b. +assert (Z.rem n (a * b) = n + - (Z.quot n (a * b) * a) * b)%Z. +rewrite <- Zopp_mult_distr_l. +rewrite <- Zmult_assoc. +apply ZOmod_eq. +rewrite H. +apply Z_rem_plus. +rewrite <- H. +apply Zrem_sgn2. +Qed. + +Theorem Zdiv_mod_mult : + forall n a b, (0 <= a)%Z -> (0 <= b)%Z -> + (Z.div (Zmod n (a * b)) a) = Zmod (Z.div n a) b. +Proof. +intros n a b Ha Hb. +destruct (Zle_lt_or_eq _ _ Ha) as [Ha'|Ha']. +destruct (Zle_lt_or_eq _ _ Hb) as [Hb'|Hb']. +rewrite (Zmod_eq n (a * b)). +rewrite (Zmult_comm a b) at 2. +rewrite Zmult_assoc. +unfold Zminus. +rewrite Zopp_mult_distr_l. +rewrite Z_div_plus by now apply Z.lt_gt. +rewrite <- Zdiv_Zdiv by easy. +apply sym_eq. +apply Zmod_eq. +now apply Z.lt_gt. +now apply Zmult_gt_0_compat ; apply Z.lt_gt. +rewrite <- Hb'. +rewrite Zmult_0_r, 2!Zmod_0_r. +apply Zdiv_0_l. +rewrite <- Ha'. +now rewrite 2!Zdiv_0_r, Zmod_0_l. +Qed. + +Theorem ZOdiv_mod_mult : + forall n a b, + (Z.quot (Z.rem n (a * b)) a) = Z.rem (Z.quot n a) b. +Proof. +intros n a b. +destruct (Z.eq_dec a 0) as [Za|Za]. +rewrite Za. +now rewrite 2!Zquot_0_r, Zrem_0_l. +assert (Z.rem n (a * b) = n + - (Z.quot (Z.quot n a) b * b) * a)%Z. +rewrite (ZOmod_eq n (a * b)) at 1. +rewrite Zquot_Zquot. +ring. +rewrite H. +rewrite Z_quot_plus with (2 := Za). +apply sym_eq. +apply ZOmod_eq. +rewrite <- H. +apply Zrem_sgn2. +Qed. + +Theorem ZOdiv_small_abs : + forall a b, + (Z.abs a < b)%Z -> Z.quot a b = Z0. +Proof. +intros a b Ha. +destruct (Zle_or_lt 0 a) as [H|H]. +apply Z.quot_small. +split. +exact H. +now rewrite Z.abs_eq in Ha. +apply Z.opp_inj. +rewrite <- Zquot_opp_l, Z.opp_0. +apply Z.quot_small. +generalize (Zabs_non_eq a). +omega. +Qed. + +Theorem ZOmod_small_abs : + forall a b, + (Z.abs a < b)%Z -> Z.rem a b = a. +Proof. +intros a b Ha. +destruct (Zle_or_lt 0 a) as [H|H]. +apply Z.rem_small. +split. +exact H. +now rewrite Z.abs_eq in Ha. +apply Z.opp_inj. +rewrite <- Zrem_opp_l. +apply Z.rem_small. +generalize (Zabs_non_eq a). +omega. +Qed. + +Theorem ZOdiv_plus : + forall a b c, (0 <= a * b)%Z -> + (Z.quot (a + b) c = Z.quot a c + Z.quot b c + Z.quot (Z.rem a c + Z.rem b c) c)%Z. +Proof. +intros a b c Hab. +destruct (Z.eq_dec c 0) as [Zc|Zc]. +now rewrite Zc, 4!Zquot_0_r. +apply Zmult_reg_r with (1 := Zc). +rewrite 2!Zmult_plus_distr_l. +assert (forall d, Z.quot d c * c = d - Z.rem d c)%Z. +intros d. +rewrite ZOmod_eq. +ring. +rewrite 4!H. +rewrite <- Zplus_rem with (1 := Hab). +ring. +Qed. + +End Div_Mod. + +Section Same_sign. + +Theorem Zsame_sign_trans : + forall v u w, v <> Z0 -> + (0 <= u * v)%Z -> (0 <= v * w)%Z -> (0 <= u * w)%Z. +Proof. +intros [|v|v] [|u|u] [|w|w] Zv Huv Hvw ; try easy ; now elim Zv. +Qed. + +Theorem Zsame_sign_trans_weak : + forall v u w, (v = Z0 -> w = Z0) -> + (0 <= u * v)%Z -> (0 <= v * w)%Z -> (0 <= u * w)%Z. +Proof. +intros [|v|v] [|u|u] [|w|w] Zv Huv Hvw ; try easy ; now discriminate Zv. +Qed. + +Theorem Zsame_sign_imp : + forall u v, + (0 < u -> 0 <= v)%Z -> + (0 < -u -> 0 <= -v)%Z -> + (0 <= u * v)%Z. +Proof. +intros [|u|u] v Hp Hn. +easy. +apply Zmult_le_0_compat. +easy. +now apply Hp. +replace (Zneg u * v)%Z with (Zpos u * (-v))%Z. +apply Zmult_le_0_compat. +easy. +now apply Hn. +rewrite <- Zopp_mult_distr_r. +apply Zopp_mult_distr_l. +Qed. + +Theorem Zsame_sign_odiv : + forall u v, (0 <= v)%Z -> + (0 <= u * Z.quot u v)%Z. +Proof. +intros u v Hv. +apply Zsame_sign_imp ; intros Hu. +apply Z_quot_pos with (2 := Hv). +now apply Zlt_le_weak. +rewrite <- Zquot_opp_l. +apply Z_quot_pos with (2 := Hv). +now apply Zlt_le_weak. +Qed. + +End Same_sign. + +(** Boolean comparisons *) + +Section Zeq_bool. + +Inductive Zeq_bool_prop (x y : Z) : bool -> Prop := + | Zeq_bool_true_ : x = y -> Zeq_bool_prop x y true + | Zeq_bool_false_ : x <> y -> Zeq_bool_prop x y false. + +Theorem Zeq_bool_spec : + forall x y, Zeq_bool_prop x y (Zeq_bool x y). +Proof. +intros x y. +generalize (Zeq_is_eq_bool x y). +case (Zeq_bool x y) ; intros (H1, H2) ; constructor. +now apply H2. +intros H. +specialize (H1 H). +discriminate H1. +Qed. + +Theorem Zeq_bool_true : + forall x y, x = y -> Zeq_bool x y = true. +Proof. +intros x y. +apply -> Zeq_is_eq_bool. +Qed. + +Theorem Zeq_bool_false : + forall x y, x <> y -> Zeq_bool x y = false. +Proof. +intros x y. +generalize (proj2 (Zeq_is_eq_bool x y)). +case Zeq_bool. +intros He Hn. +elim Hn. +now apply He. +now intros _ _. +Qed. + +End Zeq_bool. + +Section Zle_bool. + +Inductive Zle_bool_prop (x y : Z) : bool -> Prop := + | Zle_bool_true_ : (x <= y)%Z -> Zle_bool_prop x y true + | Zle_bool_false_ : (y < x)%Z -> Zle_bool_prop x y false. + +Theorem Zle_bool_spec : + forall x y, Zle_bool_prop x y (Zle_bool x y). +Proof. +intros x y. +generalize (Zle_is_le_bool x y). +case Zle_bool ; intros (H1, H2) ; constructor. +now apply H2. +destruct (Zle_or_lt x y) as [H|H]. +now specialize (H1 H). +exact H. +Qed. + +Theorem Zle_bool_true : + forall x y : Z, + (x <= y)%Z -> Zle_bool x y = true. +Proof. +intros x y. +apply (proj1 (Zle_is_le_bool x y)). +Qed. + +Theorem Zle_bool_false : + forall x y : Z, + (y < x)%Z -> Zle_bool x y = false. +Proof. +intros x y Hxy. +generalize (Zle_cases x y). +case Zle_bool ; intros H. +elim (Z.lt_irrefl x). +now apply Z.le_lt_trans with y. +apply refl_equal. +Qed. + +End Zle_bool. + +Section Zlt_bool. + +Inductive Zlt_bool_prop (x y : Z) : bool -> Prop := + | Zlt_bool_true_ : (x < y)%Z -> Zlt_bool_prop x y true + | Zlt_bool_false_ : (y <= x)%Z -> Zlt_bool_prop x y false. + +Theorem Zlt_bool_spec : + forall x y, Zlt_bool_prop x y (Zlt_bool x y). +Proof. +intros x y. +generalize (Zlt_is_lt_bool x y). +case Zlt_bool ; intros (H1, H2) ; constructor. +now apply H2. +destruct (Zle_or_lt y x) as [H|H]. +exact H. +now specialize (H1 H). +Qed. + +Theorem Zlt_bool_true : + forall x y : Z, + (x < y)%Z -> Zlt_bool x y = true. +Proof. +intros x y. +apply (proj1 (Zlt_is_lt_bool x y)). +Qed. + +Theorem Zlt_bool_false : + forall x y : Z, + (y <= x)%Z -> Zlt_bool x y = false. +Proof. +intros x y Hxy. +generalize (Zlt_cases x y). +case Zlt_bool ; intros H. +elim (Z.lt_irrefl x). +now apply Z.lt_le_trans with y. +apply refl_equal. +Qed. + +Theorem negb_Zle_bool : + forall x y : Z, + negb (Zle_bool x y) = Zlt_bool y x. +Proof. +intros x y. +case Zle_bool_spec ; intros H. +now rewrite Zlt_bool_false. +now rewrite Zlt_bool_true. +Qed. + +Theorem negb_Zlt_bool : + forall x y : Z, + negb (Zlt_bool x y) = Zle_bool y x. +Proof. +intros x y. +case Zlt_bool_spec ; intros H. +now rewrite Zle_bool_false. +now rewrite Zle_bool_true. +Qed. + +End Zlt_bool. + +Section Zcompare. + +Inductive Zcompare_prop (x y : Z) : comparison -> Prop := + | Zcompare_Lt_ : (x < y)%Z -> Zcompare_prop x y Lt + | Zcompare_Eq_ : x = y -> Zcompare_prop x y Eq + | Zcompare_Gt_ : (y < x)%Z -> Zcompare_prop x y Gt. + +Theorem Zcompare_spec : + forall x y, Zcompare_prop x y (Z.compare x y). +Proof. +intros x y. +destruct (Z_dec x y) as [[H|H]|H]. +generalize (Zlt_compare _ _ H). +case (Z.compare x y) ; try easy. +now constructor. +generalize (Zgt_compare _ _ H). +case (Z.compare x y) ; try easy. +constructor. +now apply Z.gt_lt. +generalize (proj2 (Zcompare_Eq_iff_eq _ _) H). +case (Z.compare x y) ; try easy. +now constructor. +Qed. + +Theorem Zcompare_Lt : + forall x y, + (x < y)%Z -> Z.compare x y = Lt. +Proof. +easy. +Qed. + +Theorem Zcompare_Eq : + forall x y, + (x = y)%Z -> Z.compare x y = Eq. +Proof. +intros x y. +apply <- Zcompare_Eq_iff_eq. +Qed. + +Theorem Zcompare_Gt : + forall x y, + (y < x)%Z -> Z.compare x y = Gt. +Proof. +intros x y. +apply Z.lt_gt. +Qed. + +End Zcompare. + +Section cond_Zopp. + +Definition cond_Zopp (b : bool) m := if b then Z.opp m else m. + +Theorem cond_Zopp_negb : + forall x y, cond_Zopp (negb x) y = Z.opp (cond_Zopp x y). +Proof. +intros [|] y. +apply sym_eq, Z.opp_involutive. +easy. +Qed. + +Theorem abs_cond_Zopp : + forall b m, + Z.abs (cond_Zopp b m) = Z.abs m. +Proof. +intros [|] m. +apply Zabs_Zopp. +apply refl_equal. +Qed. + +Theorem cond_Zopp_Zlt_bool : + forall m, + cond_Zopp (Zlt_bool m 0) m = Z.abs m. +Proof. +intros m. +apply sym_eq. +case Zlt_bool_spec ; intros Hm. +apply Zabs_non_eq. +now apply Zlt_le_weak. +now apply Z.abs_eq. +Qed. + +End cond_Zopp. + +Section fast_pow_pos. + +Fixpoint Zfast_pow_pos (v : Z) (e : positive) : Z := + match e with + | xH => v + | xO e' => Z.square (Zfast_pow_pos v e') + | xI e' => Zmult v (Z.square (Zfast_pow_pos v e')) + end. + +Theorem Zfast_pow_pos_correct : + forall v e, Zfast_pow_pos v e = Zpower_pos v e. +Proof. +intros v e. +rewrite <- (Zmult_1_r (Zfast_pow_pos v e)). +unfold Z.pow_pos. +generalize 1%Z. +revert v. +induction e ; intros v f ; simpl. +- rewrite <- 2!IHe. + rewrite Z.square_spec. + ring. +- rewrite <- 2!IHe. + rewrite Z.square_spec. + apply eq_sym, Zmult_assoc. +- apply eq_refl. +Qed. + +End fast_pow_pos. + +Section faster_div. + +Lemma Zdiv_eucl_unique : + forall a b, + Z.div_eucl a b = (Z.div a b, Zmod a b). +Proof. +intros a b. +unfold Z.div, Zmod. +now case Z.div_eucl. +Qed. + +Fixpoint Zpos_div_eucl_aux1 (a b : positive) {struct b} := + match b with + | xO b' => + match a with + | xO a' => let (q, r) := Zpos_div_eucl_aux1 a' b' in (q, 2 * r)%Z + | xI a' => let (q, r) := Zpos_div_eucl_aux1 a' b' in (q, 2 * r + 1)%Z + | xH => (Z0, Zpos a) + end + | xH => (Zpos a, Z0) + | xI _ => Z.pos_div_eucl a (Zpos b) + end. + +Lemma Zpos_div_eucl_aux1_correct : + forall a b, + Zpos_div_eucl_aux1 a b = Z.pos_div_eucl a (Zpos b). +Proof. +intros a b. +revert a. +induction b ; intros a. +- easy. +- change (Z.pos_div_eucl a (Zpos b~0)) with (Z.div_eucl (Zpos a) (Zpos b~0)). + rewrite Zdiv_eucl_unique. + change (Zpos b~0) with (2 * Zpos b)%Z. + rewrite Z.rem_mul_r by easy. + rewrite <- Zdiv_Zdiv by easy. + destruct a as [a|a|]. + + change (Zpos_div_eucl_aux1 a~1 b~0) with (let (q, r) := Zpos_div_eucl_aux1 a b in (q, 2 * r + 1)%Z). + rewrite IHb. clear IHb. + change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)). + rewrite Zdiv_eucl_unique. + change (Zpos a~1) with (1 + 2 * Zpos a)%Z. + rewrite (Zmult_comm 2 (Zpos a)). + rewrite Z_div_plus_full by easy. + apply f_equal. + rewrite Z_mod_plus_full. + apply Zplus_comm. + + change (Zpos_div_eucl_aux1 a~0 b~0) with (let (q, r) := Zpos_div_eucl_aux1 a b in (q, 2 * r)%Z). + rewrite IHb. clear IHb. + change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)). + rewrite Zdiv_eucl_unique. + change (Zpos a~0) with (2 * Zpos a)%Z. + rewrite (Zmult_comm 2 (Zpos a)). + rewrite Z_div_mult_full by easy. + apply f_equal. + now rewrite Z_mod_mult. + + easy. +- change (Z.pos_div_eucl a 1) with (Z.div_eucl (Zpos a) 1). + rewrite Zdiv_eucl_unique. + now rewrite Zdiv_1_r, Zmod_1_r. +Qed. + +Definition Zpos_div_eucl_aux (a b : positive) := + match Pos.compare a b with + | Lt => (Z0, Zpos a) + | Eq => (1%Z, Z0) + | Gt => Zpos_div_eucl_aux1 a b + end. + +Lemma Zpos_div_eucl_aux_correct : + forall a b, + Zpos_div_eucl_aux a b = Z.pos_div_eucl a (Zpos b). +Proof. +intros a b. +unfold Zpos_div_eucl_aux. +change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)). +rewrite Zdiv_eucl_unique. +case Pos.compare_spec ; intros H. +now rewrite H, Z_div_same, Z_mod_same. +now rewrite Zdiv_small, Zmod_small by (split ; easy). +rewrite Zpos_div_eucl_aux1_correct. +change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)). +apply Zdiv_eucl_unique. +Qed. + +Definition Zfast_div_eucl (a b : Z) := + match a with + | Z0 => (0, 0)%Z + | Zpos a' => + match b with + | Z0 => (0, 0)%Z + | Zpos b' => Zpos_div_eucl_aux a' b' + | Zneg b' => + let (q, r) := Zpos_div_eucl_aux a' b' in + match r with + | Z0 => (-q, 0)%Z + | Zpos _ => (-(q + 1), (b + r))%Z + | Zneg _ => (-(q + 1), (b + r))%Z + end + end + | Zneg a' => + match b with + | Z0 => (0, 0)%Z + | Zpos b' => + let (q, r) := Zpos_div_eucl_aux a' b' in + match r with + | Z0 => (-q, 0)%Z + | Zpos _ => (-(q + 1), (b - r))%Z + | Zneg _ => (-(q + 1), (b - r))%Z + end + | Zneg b' => let (q, r) := Zpos_div_eucl_aux a' b' in (q, (-r)%Z) + end + end. + +Theorem Zfast_div_eucl_correct : + forall a b : Z, + Zfast_div_eucl a b = Z.div_eucl a b. +Proof. +unfold Zfast_div_eucl. +intros [|a|a] [|b|b] ; try rewrite Zpos_div_eucl_aux_correct ; easy. +Qed. + +End faster_div. + +Section Iter. + +Context {A : Type}. +Variable (f : A -> A). + +Fixpoint iter_nat (n : nat) (x : A) {struct n} : A := + match n with + | S n' => iter_nat n' (f x) + | O => x + end. + +Lemma iter_nat_plus : + forall (p q : nat) (x : A), + iter_nat (p + q) x = iter_nat p (iter_nat q x). +Proof. +induction q. +now rewrite plus_0_r. +intros x. +rewrite <- plus_n_Sm. +apply IHq. +Qed. + +Lemma iter_nat_S : + forall (p : nat) (x : A), + iter_nat (S p) x = f (iter_nat p x). +Proof. +induction p. +easy. +simpl. +intros x. +apply IHp. +Qed. + +Fixpoint iter_pos (n : positive) (x : A) {struct n} : A := + match n with + | xI n' => iter_pos n' (iter_pos n' (f x)) + | xO n' => iter_pos n' (iter_pos n' x) + | xH => f x + end. + +Lemma iter_pos_nat : + forall (p : positive) (x : A), + iter_pos p x = iter_nat (Pos.to_nat p) x. +Proof. +induction p ; intros x. +rewrite Pos2Nat.inj_xI. +simpl. +rewrite plus_0_r. +rewrite iter_nat_plus. +rewrite (IHp (f x)). +apply IHp. +rewrite Pos2Nat.inj_xO. +simpl. +rewrite plus_0_r. +rewrite iter_nat_plus. +rewrite (IHp x). +apply IHp. +easy. +Qed. + +End Iter. -- cgit