diff options
Diffstat (limited to 'flocq')
-rw-r--r-- | flocq/Appli/Fappli_IEEE.v | 1920 | ||||
-rw-r--r-- | flocq/Calc/Bracket.v (renamed from flocq/Calc/Fcalc_bracket.v) | 148 | ||||
-rw-r--r-- | flocq/Calc/Div.v | 159 | ||||
-rw-r--r-- | flocq/Calc/Fcalc_digits.v | 63 | ||||
-rw-r--r-- | flocq/Calc/Fcalc_div.v | 165 | ||||
-rw-r--r-- | flocq/Calc/Fcalc_sqrt.v | 244 | ||||
-rw-r--r-- | flocq/Calc/Operations.v (renamed from flocq/Calc/Fcalc_ops.v) | 23 | ||||
-rw-r--r-- | flocq/Calc/Round.v (renamed from flocq/Calc/Fcalc_round.v) | 565 | ||||
-rw-r--r-- | flocq/Calc/Sqrt.v | 201 | ||||
-rw-r--r-- | flocq/Core/Core.v (renamed from flocq/Core/Fcore.v) | 16 | ||||
-rw-r--r-- | flocq/Core/Defs.v (renamed from flocq/Core/Fcore_defs.v) | 36 | ||||
-rw-r--r-- | flocq/Core/Digits.v (renamed from flocq/Core/Fcore_digits.v) | 211 | ||||
-rw-r--r-- | flocq/Core/FIX.v (renamed from flocq/Core/Fcore_FIX.v) | 30 | ||||
-rw-r--r-- | flocq/Core/FLT.v (renamed from flocq/Core/Fcore_FLT.v) | 182 | ||||
-rw-r--r-- | flocq/Core/FLX.v | 362 | ||||
-rw-r--r-- | flocq/Core/FTZ.v (renamed from flocq/Core/Fcore_FTZ.v) | 109 | ||||
-rw-r--r-- | flocq/Core/Fcore_FLX.v | 271 | ||||
-rw-r--r-- | flocq/Core/Float_prop.v (renamed from flocq/Core/Fcore_float_prop.v) | 228 | ||||
-rw-r--r-- | flocq/Core/Generic_fmt.v (renamed from flocq/Core/Fcore_generic_fmt.v) | 793 | ||||
-rw-r--r-- | flocq/Core/Raux.v (renamed from flocq/Core/Fcore_Raux.v) | 964 | ||||
-rw-r--r-- | flocq/Core/Round_NE.v (renamed from flocq/Core/Fcore_rnd_ne.v) | 185 | ||||
-rw-r--r-- | flocq/Core/Round_pred.v (renamed from flocq/Core/Fcore_rnd.v) | 176 | ||||
-rw-r--r-- | flocq/Core/Ulp.v (renamed from flocq/Core/Fcore_ulp.v) | 925 | ||||
-rw-r--r-- | flocq/Core/Zaux.v (renamed from flocq/Core/Fcore_Zaux.v) | 238 | ||||
-rw-r--r-- | flocq/IEEE754/Binary.v | 2814 | ||||
-rw-r--r-- | flocq/IEEE754/Bits.v (renamed from flocq/Appli/Fappli_IEEE_bits.v) | 327 | ||||
-rw-r--r-- | flocq/Prop/Div_sqrt_error.v | 872 | ||||
-rw-r--r-- | flocq/Prop/Double_rounding.v (renamed from flocq/Appli/Fappli_double_round.v) | 2598 | ||||
-rw-r--r-- | flocq/Prop/Fprop_div_sqrt_error.v | 300 | ||||
-rw-r--r-- | flocq/Prop/Mult_error.v (renamed from flocq/Prop/Fprop_mult_error.v) | 175 | ||||
-rw-r--r-- | flocq/Prop/Plus_error.v (renamed from flocq/Prop/Fprop_plus_error.v) | 394 | ||||
-rw-r--r-- | flocq/Prop/Relative.v (renamed from flocq/Prop/Fprop_relative.v) | 505 | ||||
-rw-r--r-- | flocq/Prop/Round_odd.v (renamed from flocq/Appli/Fappli_rnd_odd.v) | 618 | ||||
-rw-r--r-- | flocq/Prop/Sterbenz.v (renamed from flocq/Prop/Fprop_Sterbenz.v) | 64 | ||||
-rw-r--r-- | flocq/Version.v (renamed from flocq/Flocq_version.v) | 6 |
35 files changed, 9493 insertions, 7394 deletions
diff --git a/flocq/Appli/Fappli_IEEE.v b/flocq/Appli/Fappli_IEEE.v deleted file mode 100644 index 7503dc1d..00000000 --- a/flocq/Appli/Fappli_IEEE.v +++ /dev/null @@ -1,1920 +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 -#<br /># -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. -*) - -(** * IEEE-754 arithmetic *) -Require Import Fcore. -Require Import Fcore_digits. -Require Import Fcalc_digits. -Require Import Fcalc_round. -Require Import Fcalc_bracket. -Require Import Fcalc_ops. -Require Import Fcalc_div. -Require Import Fcalc_sqrt. -Require Import Fprop_relative. - -Section AnyRadix. - -Inductive full_float := - | F754_zero : bool -> full_float - | F754_infinity : bool -> full_float - | F754_nan : bool -> positive -> full_float - | F754_finite : bool -> positive -> Z -> full_float. - -Definition FF2R beta x := - match x with - | F754_finite s m e => F2R (Float beta (cond_Zopp s (Zpos m)) e) - | _ => 0%R - end. - -End AnyRadix. - -Section Binary. - -Arguments exist {A P} x _. - -(** [prec] is the number of bits of the mantissa including the implicit one; - [emax] is the exponent of the infinities. - For instance, binary32 is defined by [prec = 24] and [emax = 128]. *) -Variable prec emax : Z. -Context (prec_gt_0_ : Prec_gt_0 prec). -Hypothesis Hmax : (prec < emax)%Z. - -Let emin := (3 - emax - prec)%Z. -Let fexp := FLT_exp emin prec. -Instance fexp_correct : Valid_exp fexp := FLT_exp_valid emin prec. -Instance fexp_monotone : Monotone_exp fexp := FLT_exp_monotone emin prec. - -Definition canonic_mantissa m e := - Zeq_bool (fexp (Zpos (digits2_pos m) + e)) e. - -Definition bounded m e := - andb (canonic_mantissa m e) (Zle_bool e (emax - prec)). - -Definition valid_binary x := - match x with - | F754_finite _ m e => bounded m e - | F754_nan _ pl => (Zpos (digits2_pos pl) <? prec)%Z - | _ => true - end. - -(** Basic type used for representing binary FP numbers. - Note that there is exactly one such object per FP datum. *) - -Definition nan_pl := {pl | (Zpos (digits2_pos pl) <? prec)%Z = true}. - -Inductive binary_float := - | B754_zero : bool -> binary_float - | B754_infinity : bool -> binary_float - | B754_nan : bool -> nan_pl -> binary_float - | B754_finite : bool -> - forall (m : positive) (e : Z), bounded m e = true -> binary_float. - -Definition FF2B x := - match x as x return valid_binary x = true -> binary_float with - | F754_finite s m e => B754_finite s m e - | F754_infinity s => fun _ => B754_infinity s - | F754_zero s => fun _ => B754_zero s - | F754_nan b pl => fun H => B754_nan b (exist pl H) - end. - -Definition B2FF x := - match x with - | B754_finite s m e _ => F754_finite s m e - | B754_infinity s => F754_infinity s - | B754_zero s => F754_zero s - | B754_nan b (exist pl _) => F754_nan b pl - end. - -Definition B2R f := - match f with - | B754_finite s m e _ => F2R (Float radix2 (cond_Zopp s (Zpos m)) e) - | _ => 0%R - end. - -Theorem FF2R_B2FF : - forall x, - FF2R radix2 (B2FF x) = B2R x. -Proof. -now intros [sx|sx|sx [plx Hplx]|sx mx ex Hx]. -Qed. - -Theorem B2FF_FF2B : - forall x Hx, - B2FF (FF2B x Hx) = x. -Proof. -now intros [sx|sx|sx plx|sx mx ex] Hx. -Qed. - -Theorem valid_binary_B2FF : - forall x, - valid_binary (B2FF x) = true. -Proof. -now intros [sx|sx|sx [plx Hplx]|sx mx ex Hx]. -Qed. - -Theorem FF2B_B2FF : - forall x H, - FF2B (B2FF x) H = x. -Proof. -intros [sx|sx|sx [plx Hplx]|sx mx ex Hx] H ; try easy. -simpl. apply f_equal, f_equal, eqbool_irrelevance. -apply f_equal, eqbool_irrelevance. -Qed. - -Theorem FF2B_B2FF_valid : - forall x, - FF2B (B2FF x) (valid_binary_B2FF x) = x. -Proof. -intros x. -apply FF2B_B2FF. -Qed. - -Theorem B2R_FF2B : - forall x Hx, - B2R (FF2B x Hx) = FF2R radix2 x. -Proof. -now intros [sx|sx|sx plx|sx mx ex] Hx. -Qed. - -Theorem match_FF2B : - forall {T} fz fi fn ff x Hx, - match FF2B x Hx return T with - | B754_zero sx => fz sx - | B754_infinity sx => fi sx - | B754_nan b (exist p _) => fn b p - | B754_finite sx mx ex _ => ff sx mx ex - end = - match x with - | F754_zero sx => fz sx - | F754_infinity sx => fi sx - | F754_nan b p => fn b p - | F754_finite sx mx ex => ff sx mx ex - end. -Proof. -now intros T fz fi fn ff [sx|sx|sx plx|sx mx ex] Hx. -Qed. - -Theorem canonic_canonic_mantissa : - forall (sx : bool) mx ex, - canonic_mantissa mx ex = true -> - canonic radix2 fexp (Float radix2 (cond_Zopp sx (Zpos mx)) ex). -Proof. -intros sx mx ex H. -assert (Hx := Zeq_bool_eq _ _ H). clear H. -apply sym_eq. -simpl. -pattern ex at 2 ; rewrite <- Hx. -apply (f_equal fexp). -rewrite ln_beta_F2R_Zdigits. -rewrite <- Zdigits_abs. -rewrite Zpos_digits2_pos. -now case sx. -now case sx. -Qed. - -Theorem generic_format_B2R : - forall x, - generic_format radix2 fexp (B2R x). -Proof. -intros [sx|sx|sx plx|sx mx ex Hx] ; try apply generic_format_0. -simpl. -apply generic_format_canonic. -apply canonic_canonic_mantissa. -now destruct (andb_prop _ _ Hx) as (H, _). -Qed. - -Theorem FLT_format_B2R : - forall x, - FLT_format radix2 emin prec (B2R x). -Proof with auto with typeclass_instances. -intros x. -apply FLT_format_generic... -apply generic_format_B2R. -Qed. - -Theorem B2FF_inj : - forall x y : binary_float, - B2FF x = B2FF y -> - x = y. -Proof. -intros [sx|sx|sx [plx Hplx]|sx mx ex Hx] [sy|sy|sy [ply Hply]|sy my ey Hy] ; try easy. -(* *) -intros H. -now inversion H. -(* *) -intros H. -now inversion H. -(* *) -intros H. -inversion H. -clear H. -revert Hplx. -rewrite H2. -intros Hx. -apply f_equal, f_equal, eqbool_irrelevance. -(* *) -intros H. -inversion H. -clear H. -revert Hx. -rewrite H2, H3. -intros Hx. -apply f_equal, eqbool_irrelevance. -Qed. - -Definition is_finite_strict f := - match f with - | B754_finite _ _ _ _ => true - | _ => false - end. - -Theorem B2R_inj: - forall x y : binary_float, - is_finite_strict x = true -> - is_finite_strict y = true -> - B2R x = B2R y -> - x = y. -Proof. -intros [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] ; try easy. -simpl. -intros _ _ Heq. -assert (Hs: sx = sy). -(* *) -revert Heq. clear. -case sx ; case sy ; try easy ; - intros Heq ; apply False_ind ; revert Heq. -apply Rlt_not_eq. -apply Rlt_trans with R0. -now apply F2R_lt_0_compat. -now apply F2R_gt_0_compat. -apply Rgt_not_eq. -apply Rgt_trans with R0. -now apply F2R_gt_0_compat. -now apply F2R_lt_0_compat. -assert (mx = my /\ ex = ey). -(* *) -refine (_ (canonic_unicity _ fexp _ _ _ _ Heq)). -rewrite Hs. -now case sy ; intro H ; injection H ; split. -apply canonic_canonic_mantissa. -exact (proj1 (andb_prop _ _ Hx)). -apply canonic_canonic_mantissa. -exact (proj1 (andb_prop _ _ Hy)). -(* *) -revert Hx. -rewrite Hs, (proj1 H), (proj2 H). -intros Hx. -apply f_equal. -apply eqbool_irrelevance. -Qed. - -Definition Bsign x := - match x with - | B754_nan s _ => s - | B754_zero s => s - | B754_infinity s => s - | B754_finite s _ _ _ => s - end. - -Definition sign_FF x := - match x with - | F754_nan s _ => s - | F754_zero s => s - | F754_infinity s => s - | F754_finite s _ _ => s - end. - -Theorem Bsign_FF2B : - forall x H, - Bsign (FF2B x H) = sign_FF x. -Proof. -now intros [sx|sx|sx plx|sx mx ex] H. -Qed. - -Definition is_finite f := - match f with - | B754_finite _ _ _ _ => true - | B754_zero _ => true - | _ => false - end. - -Definition is_finite_FF f := - match f with - | F754_finite _ _ _ => true - | F754_zero _ => true - | _ => false - end. - -Theorem is_finite_FF2B : - forall x Hx, - is_finite (FF2B x Hx) = is_finite_FF x. -Proof. -now intros [| | |]. -Qed. - -Theorem is_finite_FF_B2FF : - forall x, - is_finite_FF (B2FF x) = is_finite x. -Proof. -now intros [| |? []|]. -Qed. - -Theorem B2R_Bsign_inj: - forall x y : binary_float, - is_finite x = true -> - is_finite y = true -> - B2R x = B2R y -> - Bsign x = Bsign y -> - x = y. -Proof. -intros. destruct x, y; try (apply B2R_inj; now eauto). -- simpl in H2. congruence. -- symmetry in H1. apply Rmult_integral in H1. - destruct H1. apply (eq_Z2R _ 0) in H1. destruct b0; discriminate H1. - simpl in H1. pose proof (bpow_gt_0 radix2 e). - rewrite H1 in H3. apply Rlt_irrefl in H3. destruct H3. -- apply Rmult_integral in H1. - destruct H1. apply (eq_Z2R _ 0) in H1. destruct b; discriminate H1. - simpl in H1. pose proof (bpow_gt_0 radix2 e). - rewrite H1 in H3. apply Rlt_irrefl in H3. destruct H3. -Qed. - -Definition is_nan f := - match f with - | B754_nan _ _ => true - | _ => false - end. - -Definition is_nan_FF f := - match f with - | F754_nan _ _ => true - | _ => false - end. - -Theorem is_nan_FF2B : - forall x Hx, - is_nan (FF2B x Hx) = is_nan_FF x. -Proof. -now intros [| | |]. -Qed. - -Theorem is_nan_FF_B2FF : - forall x, - is_nan_FF (B2FF x) = is_nan x. -Proof. -now intros [| |? []|]. -Qed. - -(** Opposite *) - -Definition Bopp opp_nan x := - match x with - | B754_nan sx plx => - let '(sres, plres) := opp_nan sx plx in B754_nan sres plres - | B754_infinity sx => B754_infinity (negb sx) - | B754_finite sx mx ex Hx => B754_finite (negb sx) mx ex Hx - | B754_zero sx => B754_zero (negb sx) - end. - -Theorem Bopp_involutive : - forall opp_nan x, - is_nan x = false -> - Bopp opp_nan (Bopp opp_nan x) = x. -Proof. -now intros opp_nan [sx|sx|sx plx|sx mx ex Hx] ; simpl ; try rewrite Bool.negb_involutive. -Qed. - -Theorem B2R_Bopp : - forall opp_nan x, - B2R (Bopp opp_nan x) = (- B2R x)%R. -Proof. -intros opp_nan [sx|sx|sx plx|sx mx ex Hx]; apply sym_eq ; try apply Ropp_0. -simpl. destruct opp_nan. apply Ropp_0. -simpl. -rewrite <- F2R_opp. -now case sx. -Qed. - -Theorem is_finite_Bopp : - forall opp_nan x, - is_finite (Bopp opp_nan x) = is_finite x. -Proof. -intros opp_nan [| |s pl|] ; try easy. -simpl. -now case opp_nan. -Qed. - -(** Absolute value *) - -Definition Babs abs_nan (x : binary_float) : binary_float := - match x with - | B754_nan sx plx => - let '(sres, plres) := abs_nan sx plx in B754_nan sres plres - | B754_infinity sx => B754_infinity false - | B754_finite sx mx ex Hx => B754_finite false mx ex Hx - | B754_zero sx => B754_zero false - end. - -Theorem B2R_Babs : - forall abs_nan x, - B2R (Babs abs_nan x) = Rabs (B2R x). -Proof. - intros abs_nan [sx|sx|sx plx|sx mx ex Hx]; apply sym_eq ; try apply Rabs_R0. - simpl. destruct abs_nan. simpl. apply Rabs_R0. - simpl. rewrite <- F2R_abs. now destruct sx. -Qed. - -Theorem is_finite_Babs : - forall abs_nan x, - is_finite (Babs abs_nan x) = is_finite x. -Proof. - intros abs_nan [| |s pl|] ; try easy. - simpl. - now case abs_nan. -Qed. - -Theorem Bsign_Babs : - forall abs_nan x, - is_nan x = false -> - Bsign (Babs abs_nan x) = false. -Proof. - now intros abs_nan [| | |]. -Qed. - -Theorem Babs_idempotent : - forall abs_nan (x: binary_float), - is_nan x = false -> - Babs abs_nan (Babs abs_nan x) = Babs abs_nan x. -Proof. - now intros abs_nan [sx|sx|sx plx|sx mx ex Hx]. -Qed. - -Theorem Babs_Bopp : - forall abs_nan opp_nan x, - is_nan x = false -> - Babs abs_nan (Bopp opp_nan x) = Babs abs_nan x. -Proof. - now intros abs_nan opp_nan [| | |]. -Qed. - -(** Comparison - -[Some c] means ordered as per [c]; [None] means unordered. *) - -Definition Bcompare (f1 f2 : binary_float) : option comparison := - match f1, f2 with - | B754_nan _ _,_ | _,B754_nan _ _ => None - | B754_infinity true, B754_infinity true - | B754_infinity false, B754_infinity false => Some Eq - | B754_infinity true, _ => Some Lt - | B754_infinity false, _ => Some Gt - | _, B754_infinity true => Some Gt - | _, B754_infinity false => Some Lt - | B754_finite true _ _ _, B754_zero _ => Some Lt - | B754_finite false _ _ _, B754_zero _ => Some Gt - | B754_zero _, B754_finite true _ _ _ => Some Gt - | B754_zero _, B754_finite false _ _ _ => Some Lt - | B754_zero _, B754_zero _ => Some Eq - | B754_finite s1 m1 e1 _, B754_finite s2 m2 e2 _ => - match s1, s2 with - | true, false => Some Lt - | false, true => Some Gt - | false, false => - match Zcompare e1 e2 with - | Lt => Some Lt - | Gt => Some Gt - | Eq => Some (Pcompare m1 m2 Eq) - end - | true, true => - match Zcompare e1 e2 with - | Lt => Some Gt - | Gt => Some Lt - | Eq => Some (CompOpp (Pcompare m1 m2 Eq)) - end - end - end. - -Theorem Bcompare_correct : - forall f1 f2, - is_finite f1 = true -> is_finite f2 = true -> - Bcompare f1 f2 = Some (Rcompare (B2R f1) (B2R f2)). -Proof. - Ltac apply_Rcompare := - match goal with - | [ |- Some Lt = Some (Rcompare _ _) ] => f_equal; symmetry; apply Rcompare_Lt - | [ |- Some Eq = Some (Rcompare _ _) ] => f_equal; symmetry; apply Rcompare_Eq - | [ |- Some Gt = Some (Rcompare _ _) ] => f_equal; symmetry; apply Rcompare_Gt - end. - unfold Bcompare; intros. - destruct f1, f2 ; try easy. - now rewrite Rcompare_Eq. - destruct b0 ; apply_Rcompare. - now apply F2R_lt_0_compat. - now apply F2R_gt_0_compat. - destruct b ; apply_Rcompare. - now apply F2R_lt_0_compat. - now apply F2R_gt_0_compat. - simpl. - clear H H0. - apply andb_prop in e0; destruct e0; apply (canonic_canonic_mantissa false) in H. - apply andb_prop in e2; destruct e2; apply (canonic_canonic_mantissa false) in H1. - pose proof (Zcompare_spec e e1); unfold canonic, Fexp in H1, H. - assert (forall m1 m2 e1 e2, - let x := (Z2R (Zpos m1) * bpow radix2 e1)%R in - let y := (Z2R (Zpos m2) * bpow radix2 e2)%R in - (canonic_exp radix2 fexp x < canonic_exp radix2 fexp y)%Z -> (x < y)%R). - { - intros; apply Rnot_le_lt; intro; apply (ln_beta_le radix2) in H5. - apply Zlt_not_le with (1 := H4). - now apply fexp_monotone. - now apply (F2R_gt_0_compat _ (Float radix2 (Zpos m2) e2)). - } - assert (forall m1 m2 e1 e2, (Z2R (- Zpos m1) * bpow radix2 e1 < Z2R (Zpos m2) * bpow radix2 e2)%R). - { - intros; apply (Rlt_trans _ 0%R). - now apply (F2R_lt_0_compat _ (Float radix2 (Zneg m1) e0)). - now apply (F2R_gt_0_compat _ (Float radix2 (Zpos m2) e2)). - } - unfold F2R, Fnum, Fexp. - destruct b, b0; try (now apply_Rcompare; apply H5); inversion H3; - try (apply_Rcompare; apply H4; rewrite H, H1 in H7; assumption); - try (apply_Rcompare; do 2 rewrite Z2R_opp, Ropp_mult_distr_l_reverse; - apply Ropp_lt_contravar; apply H4; rewrite H, H1 in H7; assumption); - rewrite H7, Rcompare_mult_r, Rcompare_Z2R by (apply bpow_gt_0); reflexivity. -Qed. - -Theorem Bcompare_swap : - forall x y, - Bcompare y x = match Bcompare x y with Some c => Some (CompOpp c) | None => None end. -Proof. - intros. - destruct x as [ ? | [] | ? ? | [] mx ex Bx ]; - destruct y as [ ? | [] | ? ? | [] my ey By ]; simpl; try easy. -- rewrite <- (Zcompare_antisym ex ey). destruct (ex ?= ey)%Z; try easy. - now rewrite (Pcompare_antisym mx my). -- rewrite <- (Zcompare_antisym ex ey). destruct (ex ?= ey)%Z; try easy. - now rewrite Pcompare_antisym. -Qed. - -Theorem bounded_lt_emax : - forall mx ex, - bounded mx ex = true -> - (F2R (Float radix2 (Zpos mx) ex) < bpow radix2 emax)%R. -Proof. -intros mx ex Hx. -destruct (andb_prop _ _ Hx) as (H1,H2). -generalize (Zeq_bool_eq _ _ H1). clear H1. intro H1. -generalize (Zle_bool_imp_le _ _ H2). clear H2. intro H2. -generalize (ln_beta_F2R_Zdigits radix2 (Zpos mx) ex). -destruct (ln_beta radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex). -unfold ln_beta_val. -intros H. -apply Rlt_le_trans with (bpow radix2 e'). -change (Zpos mx) with (Zabs (Zpos mx)). -rewrite F2R_Zabs. -apply Ex. -apply Rgt_not_eq. -now apply F2R_gt_0_compat. -apply bpow_le. -rewrite H. 2: discriminate. -revert H1. clear -H2. -rewrite Zpos_digits2_pos. -unfold fexp, FLT_exp. -generalize (Zdigits radix2 (Zpos mx)). -clearbody emin. -intros ; zify ; omega. -Qed. - -Theorem abs_B2R_lt_emax : - forall x, - (Rabs (B2R x) < bpow radix2 emax)%R. -Proof. -intros [sx|sx|sx plx|sx mx ex Hx] ; simpl ; try ( rewrite Rabs_R0 ; apply bpow_gt_0 ). -rewrite <- F2R_Zabs, abs_cond_Zopp. -now apply bounded_lt_emax. -Qed. - -Theorem bounded_canonic_lt_emax : - forall mx ex, - canonic radix2 fexp (Float radix2 (Zpos mx) ex) -> - (F2R (Float radix2 (Zpos mx) ex) < bpow radix2 emax)%R -> - bounded mx ex = true. -Proof. -intros mx ex Cx Bx. -apply andb_true_intro. -split. -unfold canonic_mantissa. -unfold canonic, Fexp in Cx. -rewrite Cx at 2. -rewrite Zpos_digits2_pos. -unfold canonic_exp. -rewrite ln_beta_F2R_Zdigits. 2: discriminate. -now apply -> Zeq_is_eq_bool. -apply Zle_bool_true. -unfold canonic, Fexp in Cx. -rewrite Cx. -unfold canonic_exp, fexp, FLT_exp. -destruct (ln_beta radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex). simpl. -apply Zmax_lub. -cut (e' - 1 < emax)%Z. clear ; omega. -apply lt_bpow with radix2. -apply Rle_lt_trans with (2 := Bx). -change (Zpos mx) with (Zabs (Zpos mx)). -rewrite F2R_Zabs. -apply Ex. -apply Rgt_not_eq. -now apply F2R_gt_0_compat. -unfold emin. -generalize (prec_gt_0 prec). -clear -Hmax ; omega. -Qed. - -(** Truncation *) - -Record shr_record := { shr_m : Z ; shr_r : bool ; shr_s : bool }. - -Definition shr_1 mrs := - let '(Build_shr_record m r s) := mrs in - let s := orb r s in - match m with - | Z0 => Build_shr_record Z0 false s - | Zpos xH => Build_shr_record Z0 true s - | Zpos (xO p) => Build_shr_record (Zpos p) false s - | Zpos (xI p) => Build_shr_record (Zpos p) true s - | Zneg xH => Build_shr_record Z0 true s - | Zneg (xO p) => Build_shr_record (Zneg p) false s - | Zneg (xI p) => Build_shr_record (Zneg p) true s - end. - -Definition loc_of_shr_record mrs := - match mrs with - | Build_shr_record _ false false => loc_Exact - | Build_shr_record _ false true => loc_Inexact Lt - | Build_shr_record _ true false => loc_Inexact Eq - | Build_shr_record _ true true => loc_Inexact Gt - end. - -Definition shr_record_of_loc m l := - match l with - | loc_Exact => Build_shr_record m false false - | loc_Inexact Lt => Build_shr_record m false true - | loc_Inexact Eq => Build_shr_record m true false - | loc_Inexact Gt => Build_shr_record m true true - end. - -Theorem shr_m_shr_record_of_loc : - forall m l, - shr_m (shr_record_of_loc m l) = m. -Proof. -now intros m [|[| |]]. -Qed. - -Theorem loc_of_shr_record_of_loc : - forall m l, - loc_of_shr_record (shr_record_of_loc m l) = l. -Proof. -now intros m [|[| |]]. -Qed. - -Definition shr mrs e n := - match n with - | Zpos p => (iter_pos shr_1 p mrs, (e + n)%Z) - | _ => (mrs, e) - end. - -Lemma inbetween_shr_1 : - forall x mrs e, - (0 <= shr_m mrs)%Z -> - inbetween_float radix2 (shr_m mrs) e x (loc_of_shr_record mrs) -> - inbetween_float radix2 (shr_m (shr_1 mrs)) (e + 1) x (loc_of_shr_record (shr_1 mrs)). -Proof. -intros x mrs e Hm Hl. -refine (_ (new_location_even_correct (F2R (Float radix2 (shr_m (shr_1 mrs)) (e + 1))) (bpow radix2 e) 2 _ _ _ x (if shr_r (shr_1 mrs) then 1 else 0) (loc_of_shr_record mrs) _ _)) ; try easy. -2: apply bpow_gt_0. -2: now case (shr_r (shr_1 mrs)) ; split. -change (Z2R 2) with (bpow radix2 1). -rewrite <- bpow_plus. -rewrite (Zplus_comm 1), <- (F2R_bpow radix2 (e + 1)). -unfold inbetween_float, F2R. simpl. -rewrite Z2R_plus, Rmult_plus_distr_r. -replace (new_location_even 2 (if shr_r (shr_1 mrs) then 1%Z else 0%Z) (loc_of_shr_record mrs)) with (loc_of_shr_record (shr_1 mrs)). -easy. -clear -Hm. -destruct mrs as (m, r, s). -now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|]. -rewrite (F2R_change_exp radix2 e). -2: apply Zle_succ. -unfold F2R. simpl. -rewrite <- 2!Rmult_plus_distr_r, <- 2!Z2R_plus. -rewrite Zplus_assoc. -replace (shr_m (shr_1 mrs) * 2 ^ (e + 1 - e) + (if shr_r (shr_1 mrs) then 1%Z else 0%Z))%Z with (shr_m mrs). -exact Hl. -ring_simplify (e + 1 - e)%Z. -change (2^1)%Z with 2%Z. -rewrite Zmult_comm. -clear -Hm. -destruct mrs as (m, r, s). -now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|]. -Qed. - -Theorem inbetween_shr : - forall x m e l n, - (0 <= m)%Z -> - inbetween_float radix2 m e x l -> - let '(mrs, e') := shr (shr_record_of_loc m l) e n in - inbetween_float radix2 (shr_m mrs) e' x (loc_of_shr_record mrs). -Proof. -intros x m e l n Hm Hl. -destruct n as [|n|n]. -now destruct l as [|[| |]]. -2: now destruct l as [|[| |]]. -unfold shr. -rewrite iter_pos_nat. -rewrite Zpos_eq_Z_of_nat_o_nat_of_P. -induction (nat_of_P n). -simpl. -rewrite Zplus_0_r. -now destruct l as [|[| |]]. -rewrite iter_nat_S. -rewrite inj_S. -unfold Zsucc. -rewrite Zplus_assoc. -revert IHn0. -apply inbetween_shr_1. -clear -Hm. -induction n0. -now destruct l as [|[| |]]. -rewrite iter_nat_S. -revert IHn0. -generalize (iter_nat shr_1 n0 (shr_record_of_loc m l)). -clear. -intros (m, r, s) Hm. -now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|]. -Qed. - -Definition shr_fexp m e l := - shr (shr_record_of_loc m l) e (fexp (Zdigits2 m + e) - e). - -Theorem shr_truncate : - forall m e l, - (0 <= m)%Z -> - shr_fexp m e l = - let '(m', e', l') := truncate radix2 fexp (m, e, l) in (shr_record_of_loc m' l', e'). -Proof. -intros m e l Hm. -case_eq (truncate radix2 fexp (m, e, l)). -intros (m', e') l'. -unfold shr_fexp. -rewrite Zdigits2_Zdigits. -case_eq (fexp (Zdigits radix2 m + e) - e)%Z. -(* *) -intros He. -unfold truncate. -rewrite He. -simpl. -intros H. -now inversion H. -(* *) -intros p Hp. -assert (He: (e <= fexp (Zdigits radix2 m + e))%Z). -clear -Hp ; zify ; omega. -destruct (inbetween_float_ex radix2 m e l) as (x, Hx). -generalize (inbetween_shr x m e l (fexp (Zdigits radix2 m + e) - e) Hm Hx). -assert (Hx0 : (0 <= x)%R). -apply Rle_trans with (F2R (Float radix2 m e)). -now apply F2R_ge_0_compat. -exact (proj1 (inbetween_float_bounds _ _ _ _ _ Hx)). -case_eq (shr (shr_record_of_loc m l) e (fexp (Zdigits radix2 m + e) - e)). -intros mrs e'' H3 H4 H1. -generalize (truncate_correct radix2 _ x m e l Hx0 Hx (or_introl _ He)). -rewrite H1. -intros (H2,_). -rewrite <- Hp, H3. -assert (e'' = e'). -change (snd (mrs, e'') = snd (fst (m',e',l'))). -rewrite <- H1, <- H3. -unfold truncate. -now rewrite Hp. -rewrite H in H4 |- *. -apply (f_equal (fun v => (v, _))). -destruct (inbetween_float_unique _ _ _ _ _ _ _ H2 H4) as (H5, H6). -rewrite H5, H6. -case mrs. -now intros m0 [|] [|]. -(* *) -intros p Hp. -unfold truncate. -rewrite Hp. -simpl. -intros H. -now inversion H. -Qed. - -(** Rounding modes *) - -Inductive mode := mode_NE | mode_ZR | mode_DN | mode_UP | mode_NA. - -Definition round_mode m := - match m with - | mode_NE => ZnearestE - | mode_ZR => Ztrunc - | mode_DN => Zfloor - | mode_UP => Zceil - | mode_NA => ZnearestA - end. - -Definition choice_mode m sx mx lx := - match m with - | mode_NE => cond_incr (round_N (negb (Zeven mx)) lx) mx - | mode_ZR => mx - | mode_DN => cond_incr (round_sign_DN sx lx) mx - | mode_UP => cond_incr (round_sign_UP sx lx) mx - | mode_NA => cond_incr (round_N true lx) mx - end. - -Global Instance valid_rnd_round_mode : forall m, Valid_rnd (round_mode m). -Proof. -destruct m ; unfold round_mode ; auto with typeclass_instances. -Qed. - -Definition overflow_to_inf m s := - match m with - | mode_NE => true - | mode_NA => true - | mode_ZR => false - | mode_UP => negb s - | mode_DN => s - end. - -Definition binary_overflow m s := - if overflow_to_inf m s then F754_infinity s - else F754_finite s (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end) (emax - prec). - -Definition binary_round_aux mode sx mx ex lx := - let '(mrs', e') := shr_fexp (Zpos mx) ex lx in - let '(mrs'', e'') := shr_fexp (choice_mode mode sx (shr_m mrs') (loc_of_shr_record mrs')) e' loc_Exact in - match shr_m mrs'' with - | Z0 => F754_zero sx - | Zpos m => if Zle_bool e'' (emax - prec) then F754_finite sx m e'' else binary_overflow mode sx - | _ => F754_nan false xH (* dummy *) - end. - -Theorem binary_round_aux_correct : - forall mode x mx ex lx, - inbetween_float radix2 (Zpos mx) ex (Rabs x) lx -> - (ex <= fexp (Zdigits radix2 (Zpos mx) + ex))%Z -> - let z := binary_round_aux mode (Rlt_bool x 0) mx ex lx in - valid_binary z = true /\ - if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) x)) (bpow radix2 emax) then - FF2R radix2 z = round radix2 fexp (round_mode mode) x /\ - is_finite_FF z = true /\ sign_FF z = Rlt_bool x 0 - else - z = binary_overflow mode (Rlt_bool x 0). -Proof with auto with typeclass_instances. -intros m x mx ex lx Bx Ex z. -unfold binary_round_aux in z. -revert z. -rewrite shr_truncate. 2: easy. -refine (_ (round_trunc_sign_any_correct _ _ (round_mode m) (choice_mode m) _ x (Zpos mx) ex lx Bx (or_introl _ Ex))). -refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Bx Ex)). -destruct (truncate radix2 fexp (Zpos mx, ex, lx)) as ((m1, e1), l1). -rewrite loc_of_shr_record_of_loc, shr_m_shr_record_of_loc. -set (m1' := choice_mode m (Rlt_bool x 0) m1 l1). -intros (H1a,H1b) H1c. -rewrite H1c. -assert (Hm: (m1 <= m1')%Z). -(* . *) -unfold m1', choice_mode, cond_incr. -case m ; - try apply Zle_refl ; - match goal with |- (m1 <= if ?b then _ else _)%Z => - case b ; [ apply Zle_succ | apply Zle_refl ] end. -assert (Hr: Rabs (round radix2 fexp (round_mode m) x) = F2R (Float radix2 m1' e1)). -(* . *) -rewrite <- (Zabs_eq m1'). -replace (Zabs m1') with (Zabs (cond_Zopp (Rlt_bool x 0) m1')). -rewrite F2R_Zabs. -now apply f_equal. -apply abs_cond_Zopp. -apply Zle_trans with (2 := Hm). -apply Zlt_succ_le. -apply F2R_gt_0_reg with radix2 e1. -apply Rle_lt_trans with (1 := Rabs_pos x). -exact (proj2 (inbetween_float_bounds _ _ _ _ _ H1a)). -(* . *) -assert (Br: inbetween_float radix2 m1' e1 (Rabs (round radix2 fexp (round_mode m) x)) loc_Exact). -now apply inbetween_Exact. -destruct m1' as [|m1'|m1']. -(* . m1' = 0 *) -rewrite shr_truncate. 2: apply Zle_refl. -generalize (truncate_0 radix2 fexp e1 loc_Exact). -destruct (truncate radix2 fexp (Z0, e1, loc_Exact)) as ((m2, e2), l2). -rewrite shr_m_shr_record_of_loc. -intros Hm2. -rewrite Hm2. -repeat split. -rewrite Rlt_bool_true. -repeat split. -apply sym_eq. -case Rlt_bool ; apply F2R_0. -rewrite <- F2R_Zabs, abs_cond_Zopp, F2R_0. -apply bpow_gt_0. -(* . 0 < m1' *) -assert (He: (e1 <= fexp (Zdigits radix2 (Zpos m1') + e1))%Z). -rewrite <- ln_beta_F2R_Zdigits, <- Hr, ln_beta_abs. -2: discriminate. -rewrite H1b. -rewrite canonic_exp_abs. -fold (canonic_exp radix2 fexp (round radix2 fexp (round_mode m) x)). -apply canonic_exp_round_ge... -rewrite H1c. -case (Rlt_bool x 0). -apply Rlt_not_eq. -now apply F2R_lt_0_compat. -apply Rgt_not_eq. -now apply F2R_gt_0_compat. -refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Br He)). -2: now rewrite Hr ; apply F2R_gt_0_compat. -refine (_ (truncate_correct_format radix2 fexp (Zpos m1') e1 _ _ He)). -2: discriminate. -rewrite shr_truncate. 2: easy. -destruct (truncate radix2 fexp (Zpos m1', e1, loc_Exact)) as ((m2, e2), l2). -rewrite shr_m_shr_record_of_loc. -intros (H3,H4) (H2,_). -destruct m2 as [|m2|m2]. -elim Rgt_not_eq with (2 := H3). -rewrite F2R_0. -now apply F2R_gt_0_compat. -rewrite F2R_cond_Zopp, H3, abs_cond_Ropp, <- F2R_abs. -simpl Zabs. -case_eq (Zle_bool e2 (emax - prec)) ; intros He2. -assert (bounded m2 e2 = true). -apply andb_true_intro. -split. -unfold canonic_mantissa. -apply Zeq_bool_true. -rewrite Zpos_digits2_pos. -rewrite <- ln_beta_F2R_Zdigits. -apply sym_eq. -now rewrite H3 in H4. -discriminate. -exact He2. -apply (conj H). -rewrite Rlt_bool_true. -repeat split. -apply F2R_cond_Zopp. -now apply bounded_lt_emax. -rewrite (Rlt_bool_false _ (bpow radix2 emax)). -refine (conj _ (refl_equal _)). -unfold binary_overflow. -case overflow_to_inf. -apply refl_equal. -unfold valid_binary, bounded. -rewrite Zle_bool_refl. -rewrite Bool.andb_true_r. -apply Zeq_bool_true. -rewrite Zpos_digits2_pos. -replace (Zdigits radix2 (Zpos (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end))) with prec. -unfold fexp, FLT_exp, emin. -generalize (prec_gt_0 prec). -clear -Hmax ; zify ; omega. -change 2%Z with (radix_val radix2). -case_eq (Zpower radix2 prec - 1)%Z. -simpl Zdigits. -generalize (Zpower_gt_1 radix2 prec (prec_gt_0 prec)). -clear ; omega. -intros p Hp. -apply Zle_antisym. -cut (prec - 1 < Zdigits radix2 (Zpos p))%Z. clear ; omega. -apply Zdigits_gt_Zpower. -simpl Zabs. rewrite <- Hp. -cut (Zpower radix2 (prec - 1) < Zpower radix2 prec)%Z. clear ; omega. -apply lt_Z2R. -rewrite 2!Z2R_Zpower. 2: now apply Zlt_le_weak. -apply bpow_lt. -apply Zlt_pred. -now apply Zlt_0_le_0_pred. -apply Zdigits_le_Zpower. -simpl Zabs. rewrite <- Hp. -apply Zlt_pred. -intros p Hp. -generalize (Zpower_gt_1 radix2 _ (prec_gt_0 prec)). -clear -Hp ; zify ; omega. -apply Rnot_lt_le. -intros Hx. -generalize (refl_equal (bounded m2 e2)). -unfold bounded at 2. -rewrite He2. -rewrite Bool.andb_false_r. -rewrite bounded_canonic_lt_emax with (2 := Hx). -discriminate. -unfold canonic. -now rewrite <- H3. -elim Rgt_not_eq with (2 := H3). -apply Rlt_trans with R0. -now apply F2R_lt_0_compat. -now apply F2R_gt_0_compat. -rewrite <- Hr. -apply generic_format_abs... -apply generic_format_round... -(* . not m1' < 0 *) -elim Rgt_not_eq with (2 := Hr). -apply Rlt_le_trans with R0. -now apply F2R_lt_0_compat. -apply Rabs_pos. -(* *) -apply Rlt_le_trans with (2 := proj1 (inbetween_float_bounds _ _ _ _ _ Bx)). -now apply F2R_gt_0_compat. -(* all the modes are valid *) -clear. case m. -exact inbetween_int_NE_sign. -exact inbetween_int_ZR_sign. -exact inbetween_int_DN_sign. -exact inbetween_int_UP_sign. -exact inbetween_int_NA_sign. -Qed. - -(** Multiplication *) - -Lemma Bmult_correct_aux : - forall m sx mx ex (Hx : bounded mx ex = true) sy my ey (Hy : bounded my ey = true), - let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in - let y := F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey) in - let z := binary_round_aux m (xorb sx sy) (mx * my) (ex + ey) loc_Exact in - valid_binary z = true /\ - if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x * y))) (bpow radix2 emax) then - FF2R radix2 z = round radix2 fexp (round_mode m) (x * y) /\ - is_finite_FF z = true /\ sign_FF z = xorb sx sy - else - z = binary_overflow m (xorb sx sy). -Proof. -intros m sx mx ex Hx sy my ey Hy x y. -unfold x, y. -rewrite <- F2R_mult. -simpl. -replace (xorb sx sy) with (Rlt_bool (F2R (Float radix2 (cond_Zopp sx (Zpos mx) * cond_Zopp sy (Zpos my)) (ex + ey))) 0). -apply binary_round_aux_correct. -constructor. -rewrite <- F2R_abs. -apply F2R_eq_compat. -rewrite Zabs_Zmult. -now rewrite 2!abs_cond_Zopp. -(* *) -change (Zpos (mx * my)) with (Zpos mx * Zpos my)%Z. -assert (forall m e, bounded m e = true -> fexp (Zdigits radix2 (Zpos m) + e) = e)%Z. -clear. intros m e Hb. -destruct (andb_prop _ _ Hb) as (H,_). -apply Zeq_bool_eq. -now rewrite <- Zpos_digits2_pos. -generalize (H _ _ Hx) (H _ _ Hy). -clear x y sx sy Hx Hy H. -unfold fexp, FLT_exp. -refine (_ (Zdigits_mult_ge radix2 (Zpos mx) (Zpos my) _ _)) ; try discriminate. -refine (_ (Zdigits_gt_0 radix2 (Zpos mx) _) (Zdigits_gt_0 radix2 (Zpos my) _)) ; try discriminate. -generalize (Zdigits radix2 (Zpos mx)) (Zdigits radix2 (Zpos my)) (Zdigits radix2 (Zpos mx * Zpos my)). -clear -Hmax. -unfold emin. -intros dx dy dxy Hx Hy Hxy. -zify ; intros ; subst. -omega. -(* *) -case sx ; case sy. -apply Rlt_bool_false. -now apply F2R_ge_0_compat. -apply Rlt_bool_true. -now apply F2R_lt_0_compat. -apply Rlt_bool_true. -now apply F2R_lt_0_compat. -apply Rlt_bool_false. -now apply F2R_ge_0_compat. -Qed. - -Definition Bmult mult_nan m x y := - let f pl := B754_nan (fst pl) (snd pl) in - match x, y with - | B754_nan _ _, _ | _, B754_nan _ _ => f (mult_nan x y) - | B754_infinity sx, B754_infinity sy => B754_infinity (xorb sx sy) - | B754_infinity sx, B754_finite sy _ _ _ => B754_infinity (xorb sx sy) - | B754_finite sx _ _ _, B754_infinity sy => B754_infinity (xorb sx sy) - | B754_infinity _, B754_zero _ => f (mult_nan x y) - | B754_zero _, B754_infinity _ => f (mult_nan x y) - | B754_finite sx _ _ _, B754_zero sy => B754_zero (xorb sx sy) - | B754_zero sx, B754_finite sy _ _ _ => B754_zero (xorb sx sy) - | B754_zero sx, B754_zero sy => B754_zero (xorb sx sy) - | B754_finite sx mx ex Hx, B754_finite sy my ey Hy => - FF2B _ (proj1 (Bmult_correct_aux m sx mx ex Hx sy my ey Hy)) - end. - -Theorem Bmult_correct : - forall mult_nan m x y, - if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x * B2R y))) (bpow radix2 emax) then - B2R (Bmult mult_nan m x y) = round radix2 fexp (round_mode m) (B2R x * B2R y) /\ - is_finite (Bmult mult_nan m x y) = andb (is_finite x) (is_finite y) /\ - (is_nan (Bmult mult_nan m x y) = false -> - Bsign (Bmult mult_nan m x y) = xorb (Bsign x) (Bsign y)) - else - B2FF (Bmult mult_nan m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)). -Proof. -intros mult_nan m [sx|sx|sx plx|sx mx ex Hx] [sy|sy|sy ply|sy my ey Hy] ; - try ( rewrite ?Rmult_0_r, ?Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ now repeat constructor | apply bpow_gt_0 | now auto with typeclass_instances ] ). -simpl. -case Bmult_correct_aux. -intros H1. -case Rlt_bool. -intros (H2, (H3, H4)). -split. -now rewrite B2R_FF2B. -split. -now rewrite is_finite_FF2B. -rewrite Bsign_FF2B. auto. -intros H2. -now rewrite B2FF_FF2B. -Qed. - -Definition Bmult_FF mult_nan m x y := - let f pl := F754_nan (fst pl) (snd pl) in - match x, y with - | F754_nan _ _, _ | _, F754_nan _ _ => f (mult_nan x y) - | F754_infinity sx, F754_infinity sy => F754_infinity (xorb sx sy) - | F754_infinity sx, F754_finite sy _ _ => F754_infinity (xorb sx sy) - | F754_finite sx _ _, F754_infinity sy => F754_infinity (xorb sx sy) - | F754_infinity _, F754_zero _ => f (mult_nan x y) - | F754_zero _, F754_infinity _ => f (mult_nan x y) - | F754_finite sx _ _, F754_zero sy => F754_zero (xorb sx sy) - | F754_zero sx, F754_finite sy _ _ => F754_zero (xorb sx sy) - | F754_zero sx, F754_zero sy => F754_zero (xorb sx sy) - | F754_finite sx mx ex, F754_finite sy my ey => - binary_round_aux m (xorb sx sy) (mx * my) (ex + ey) loc_Exact - end. - -Theorem B2FF_Bmult : - forall mult_nan mult_nan_ff, - forall m x y, - mult_nan_ff (B2FF x) (B2FF y) = (let '(sr, exist plr _) := mult_nan x y in (sr, plr)) -> - B2FF (Bmult mult_nan m x y) = Bmult_FF mult_nan_ff m (B2FF x) (B2FF y). -Proof. -intros mult_nan mult_nan_ff m x y Hmult_nan. -unfold Bmult_FF. rewrite Hmult_nan. -destruct x as [sx|sx|sx [plx Hplx]|sx mx ex Hx], y as [sy|sy|sy [ply Hply]|sy my ey Hy] ; - simpl; try match goal with |- context [mult_nan ?x ?y] => - destruct (mult_nan x y) as [? []] end; - try easy. -apply B2FF_FF2B. -Qed. - -(** Normalization and rounding *) - -Definition shl_align mx ex ex' := - match (ex' - ex)%Z with - | Zneg d => (shift_pos d mx, ex') - | _ => (mx, ex) - end. - -Theorem shl_align_correct : - forall mx ex ex', - let (mx', ex'') := shl_align mx ex ex' in - F2R (Float radix2 (Zpos mx) ex) = F2R (Float radix2 (Zpos mx') ex'') /\ - (ex'' <= ex')%Z. -Proof. -intros mx ex ex'. -unfold shl_align. -case_eq (ex' - ex)%Z. -(* d = 0 *) -intros H. -repeat split. -rewrite Zminus_eq with (1 := H). -apply Zle_refl. -(* d > 0 *) -intros d Hd. -repeat split. -replace ex' with (ex' - ex + ex)%Z by ring. -rewrite Hd. -pattern ex at 1 ; rewrite <- Zplus_0_l. -now apply Zplus_le_compat_r. -(* d < 0 *) -intros d Hd. -rewrite shift_pos_correct, Zmult_comm. -change (Zpower_pos 2 d) with (Zpower radix2 (Zpos d)). -change (Zpos d) with (Zopp (Zneg d)). -rewrite <- Hd. -split. -replace (- (ex' - ex))%Z with (ex - ex')%Z by ring. -apply F2R_change_exp. -apply Zle_0_minus_le. -replace (ex - ex')%Z with (- (ex' - ex))%Z by ring. -now rewrite Hd. -apply Zle_refl. -Qed. - -Theorem snd_shl_align : - forall mx ex ex', - (ex' <= ex)%Z -> - snd (shl_align mx ex ex') = ex'. -Proof. -intros mx ex ex' He. -unfold shl_align. -case_eq (ex' - ex)%Z ; simpl. -intros H. -now rewrite Zminus_eq with (1 := H). -intros p. -clear -He ; zify ; omega. -intros. -apply refl_equal. -Qed. - -Definition shl_align_fexp mx ex := - shl_align mx ex (fexp (Zpos (digits2_pos mx) + ex)). - -Theorem shl_align_fexp_correct : - forall mx ex, - let (mx', ex') := shl_align_fexp mx ex in - F2R (Float radix2 (Zpos mx) ex) = F2R (Float radix2 (Zpos mx') ex') /\ - (ex' <= fexp (Zdigits radix2 (Zpos mx') + ex'))%Z. -Proof. -intros mx ex. -unfold shl_align_fexp. -generalize (shl_align_correct mx ex (fexp (Zpos (digits2_pos mx) + ex))). -rewrite Zpos_digits2_pos. -case shl_align. -intros mx' ex' (H1, H2). -split. -exact H1. -rewrite <- ln_beta_F2R_Zdigits. 2: easy. -rewrite <- H1. -now rewrite ln_beta_F2R_Zdigits. -Qed. - -Definition binary_round m sx mx ex := - let '(mz, ez) := shl_align_fexp mx ex in binary_round_aux m sx mz ez loc_Exact. - -Theorem binary_round_correct : - forall m sx mx ex, - let z := binary_round m sx mx ex in - valid_binary z = true /\ - let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in - if Rlt_bool (Rabs (round radix2 fexp (round_mode m) x)) (bpow radix2 emax) then - FF2R radix2 z = round radix2 fexp (round_mode m) x /\ - is_finite_FF z = true /\ - sign_FF z = sx - else - z = binary_overflow m sx. -Proof. -intros m sx mx ex. -unfold binary_round. -generalize (shl_align_fexp_correct mx ex). -destruct (shl_align_fexp mx ex) as (mz, ez). -intros (H1, H2). -set (x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex)). -replace sx with (Rlt_bool x 0). -apply binary_round_aux_correct. -constructor. -unfold x. -now rewrite <- F2R_Zabs, abs_cond_Zopp. -exact H2. -unfold x. -case sx. -apply Rlt_bool_true. -now apply F2R_lt_0_compat. -apply Rlt_bool_false. -now apply F2R_ge_0_compat. -Qed. - -Definition binary_normalize mode m e szero := - match m with - | Z0 => B754_zero szero - | Zpos m => FF2B _ (proj1 (binary_round_correct mode false m e)) - | Zneg m => FF2B _ (proj1 (binary_round_correct mode true m e)) - end. - -Theorem binary_normalize_correct : - forall m mx ex szero, - if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (F2R (Float radix2 mx ex)))) (bpow radix2 emax) then - B2R (binary_normalize m mx ex szero) = round radix2 fexp (round_mode m) (F2R (Float radix2 mx ex)) /\ - is_finite (binary_normalize m mx ex szero) = true /\ - Bsign (binary_normalize m mx ex szero) = - match Rcompare (F2R (Float radix2 mx ex)) 0 with - | Eq => szero - | Lt => true - | Gt => false - end - else - B2FF (binary_normalize m mx ex szero) = binary_overflow m (Rlt_bool (F2R (Float radix2 mx ex)) 0). -Proof with auto with typeclass_instances. -intros m mx ez szero. -destruct mx as [|mz|mz] ; simpl. -rewrite F2R_0, round_0, Rabs_R0, Rlt_bool_true... -split... split... -rewrite Rcompare_Eq... -apply bpow_gt_0. -(* . mz > 0 *) -generalize (binary_round_correct m false mz ez). -simpl. -case Rlt_bool_spec. -intros _ (Vz, (Rz, (Rz', Rz''))). -split. -now rewrite B2R_FF2B. -split. -now rewrite is_finite_FF2B. -rewrite Bsign_FF2B, Rz''. -rewrite Rcompare_Gt... -apply F2R_gt_0_compat. -simpl. zify; omega. -intros Hz' (Vz, Rz). -rewrite B2FF_FF2B, Rz. -apply f_equal. -apply sym_eq. -apply Rlt_bool_false. -now apply F2R_ge_0_compat. -(* . mz < 0 *) -generalize (binary_round_correct m true mz ez). -simpl. -case Rlt_bool_spec. -intros _ (Vz, (Rz, (Rz', Rz''))). -split. -now rewrite B2R_FF2B. -split. -now rewrite is_finite_FF2B. -rewrite Bsign_FF2B, Rz''. -rewrite Rcompare_Lt... -apply F2R_lt_0_compat. -simpl. zify; omega. -intros Hz' (Vz, Rz). -rewrite B2FF_FF2B, Rz. -apply f_equal. -apply sym_eq. -apply Rlt_bool_true. -now apply F2R_lt_0_compat. -Qed. - -(** Addition *) - -Definition Bplus plus_nan m x y := - let f pl := B754_nan (fst pl) (snd pl) in - match x, y with - | B754_nan _ _, _ | _, B754_nan _ _ => f (plus_nan x y) - | B754_infinity sx, B754_infinity sy => - if Bool.eqb sx sy then x else f (plus_nan x y) - | B754_infinity _, _ => x - | _, B754_infinity _ => y - | B754_zero sx, B754_zero sy => - if Bool.eqb sx sy then x else - match m with mode_DN => B754_zero true | _ => B754_zero false end - | B754_zero _, _ => y - | _, B754_zero _ => x - | B754_finite sx mx ex Hx, B754_finite sy my ey Hy => - let ez := Zmin ex ey in - binary_normalize m (Zplus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez))))) - ez (match m with mode_DN => true | _ => false end) - end. - -Theorem Bplus_correct : - forall plus_nan m x y, - is_finite x = true -> - is_finite y = true -> - if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x + B2R y))) (bpow radix2 emax) then - B2R (Bplus plus_nan m x y) = round radix2 fexp (round_mode m) (B2R x + B2R y) /\ - is_finite (Bplus plus_nan m x y) = true /\ - Bsign (Bplus plus_nan m x y) = - match Rcompare (B2R x + B2R y) 0 with - | Eq => match m with mode_DN => orb (Bsign x) (Bsign y) - | _ => andb (Bsign x) (Bsign y) end - | Lt => true - | Gt => false - end - else - (B2FF (Bplus plus_nan m x y) = binary_overflow m (Bsign x) /\ Bsign x = Bsign y). -Proof with auto with typeclass_instances. -intros plus_nan m [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] Fx Fy ; try easy. -(* *) -rewrite Rplus_0_r, round_0, Rabs_R0, Rlt_bool_true... -simpl. -rewrite Rcompare_Eq by auto. -destruct sx, sy; try easy; now case m. -apply bpow_gt_0. -(* *) -rewrite Rplus_0_l, round_generic, Rlt_bool_true... -split... split... -simpl. unfold F2R. -erewrite <- Rmult_0_l, Rcompare_mult_r. -rewrite Rcompare_Z2R with (y:=0%Z). -destruct sy... -apply bpow_gt_0. -apply abs_B2R_lt_emax. -apply generic_format_B2R. -(* *) -rewrite Rplus_0_r, round_generic, Rlt_bool_true... -split... split... -simpl. unfold F2R. -erewrite <- Rmult_0_l, Rcompare_mult_r. -rewrite Rcompare_Z2R with (y:=0%Z). -destruct sx... -apply bpow_gt_0. -apply abs_B2R_lt_emax. -apply generic_format_B2R. -(* *) -clear Fx Fy. -simpl. -set (szero := match m with mode_DN => true | _ => false end). -set (ez := Zmin ex ey). -set (mz := (cond_Zopp sx (Zpos (fst (shl_align mx ex ez))) + cond_Zopp sy (Zpos (fst (shl_align my ey ez))))%Z). -assert (Hp: (F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) + - F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey))%R = F2R (Float radix2 mz ez)). -rewrite 2!F2R_cond_Zopp. -generalize (shl_align_correct mx ex ez). -generalize (shl_align_correct my ey ez). -generalize (snd_shl_align mx ex ez (Zle_min_l ex ey)). -generalize (snd_shl_align my ey ez (Zle_min_r ex ey)). -destruct (shl_align mx ex ez) as (mx', ex'). -destruct (shl_align my ey ez) as (my', ey'). -simpl. -intros H1 H2. -rewrite H1, H2. -clear H1 H2. -intros (H1, _) (H2, _). -rewrite H1, H2. -clear H1 H2. -rewrite <- 2!F2R_cond_Zopp. -unfold F2R. simpl. -now rewrite <- Rmult_plus_distr_r, <- Z2R_plus. -rewrite Hp. -assert (Sz: (bpow radix2 emax <= Rabs (round radix2 fexp (round_mode m) (F2R (Float radix2 mz ez))))%R -> sx = Rlt_bool (F2R (Float radix2 mz ez)) 0 /\ sx = sy). -(* . *) -rewrite <- Hp. -intros Bz. -destruct (Bool.bool_dec sx sy) as [Hs|Hs]. -(* .. *) -refine (conj _ Hs). -rewrite Hs. -apply sym_eq. -case sy. -apply Rlt_bool_true. -rewrite <- (Rplus_0_r 0). -apply Rplus_lt_compat. -now apply F2R_lt_0_compat. -now apply F2R_lt_0_compat. -apply Rlt_bool_false. -rewrite <- (Rplus_0_r 0). -apply Rplus_le_compat. -now apply F2R_ge_0_compat. -now apply F2R_ge_0_compat. -(* .. *) -elim Rle_not_lt with (1 := Bz). -generalize (bounded_lt_emax _ _ Hx) (bounded_lt_emax _ _ Hy) (andb_prop _ _ Hx) (andb_prop _ _ Hy). -intros Bx By (Hx',_) (Hy',_). -generalize (canonic_canonic_mantissa sx _ _ Hx') (canonic_canonic_mantissa sy _ _ Hy'). -clear -Bx By Hs prec_gt_0_. -intros Cx Cy. -destruct sx. -(* ... *) -destruct sy. -now elim Hs. -clear Hs. -apply Rabs_lt. -split. -apply Rlt_le_trans with (F2R (Float radix2 (cond_Zopp true (Zpos mx)) ex)). -rewrite F2R_Zopp. -now apply Ropp_lt_contravar. -apply round_ge_generic... -now apply generic_format_canonic. -pattern (F2R (Float radix2 (cond_Zopp true (Zpos mx)) ex)) at 1 ; rewrite <- Rplus_0_r. -apply Rplus_le_compat_l. -now apply F2R_ge_0_compat. -apply Rle_lt_trans with (2 := By). -apply round_le_generic... -now apply generic_format_canonic. -rewrite <- (Rplus_0_l (F2R (Float radix2 (Zpos my) ey))). -apply Rplus_le_compat_r. -now apply F2R_le_0_compat. -(* ... *) -destruct sy. -2: now elim Hs. -clear Hs. -apply Rabs_lt. -split. -apply Rlt_le_trans with (F2R (Float radix2 (cond_Zopp true (Zpos my)) ey)). -rewrite F2R_Zopp. -now apply Ropp_lt_contravar. -apply round_ge_generic... -now apply generic_format_canonic. -pattern (F2R (Float radix2 (cond_Zopp true (Zpos my)) ey)) at 1 ; rewrite <- Rplus_0_l. -apply Rplus_le_compat_r. -now apply F2R_ge_0_compat. -apply Rle_lt_trans with (2 := Bx). -apply round_le_generic... -now apply generic_format_canonic. -rewrite <- (Rplus_0_r (F2R (Float radix2 (Zpos mx) ex))). -apply Rplus_le_compat_l. -now apply F2R_le_0_compat. -(* . *) -generalize (binary_normalize_correct m mz ez szero). -case Rlt_bool_spec. -split; try easy. split; try easy. -destruct (Rcompare_spec (F2R (beta:=radix2) {| Fnum := mz; Fexp := ez |}) 0); try easy. -rewrite H1 in Hp. -apply Rplus_opp_r_uniq in Hp. -rewrite <- F2R_Zopp in Hp. -eapply canonic_unicity in Hp. -inversion Hp. destruct sy, sx, m; try discriminate H3; easy. -apply canonic_canonic_mantissa. -apply Bool.andb_true_iff in Hy. easy. -replace (-cond_Zopp sx (Z.pos mx))%Z with (cond_Zopp (negb sx) (Z.pos mx)) - by (destruct sx; auto). -apply canonic_canonic_mantissa. -apply Bool.andb_true_iff in Hx. easy. -intros Hz' Vz. -specialize (Sz Hz'). -split. -rewrite Vz. -now apply f_equal. -apply Sz. -Qed. - -(** Subtraction *) - -Definition Bminus minus_nan m x y := Bplus minus_nan m x (Bopp pair y). - -Theorem Bminus_correct : - forall minus_nan m x y, - is_finite x = true -> - is_finite y = true -> - if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x - B2R y))) (bpow radix2 emax) then - B2R (Bminus minus_nan m x y) = round radix2 fexp (round_mode m) (B2R x - B2R y) /\ - is_finite (Bminus minus_nan m x y) = true /\ - Bsign (Bminus minus_nan m x y) = - match Rcompare (B2R x - B2R y) 0 with - | Eq => match m with mode_DN => orb (Bsign x) (negb (Bsign y)) - | _ => andb (Bsign x) (negb (Bsign y)) end - | Lt => true - | Gt => false - end - else - (B2FF (Bminus minus_nan m x y) = binary_overflow m (Bsign x) /\ Bsign x = negb (Bsign y)). -Proof with auto with typeclass_instances. -intros m minus_nan x y Fx Fy. -replace (negb (Bsign y)) with (Bsign (Bopp pair y)). -unfold Rminus. -erewrite <- B2R_Bopp. -apply Bplus_correct. -exact Fx. -rewrite is_finite_Bopp. auto. now destruct y as [ | | | ]. -Qed. - -(** Division *) - -Definition Fdiv_core_binary m1 e1 m2 e2 := - let d1 := Zdigits2 m1 in - let d2 := Zdigits2 m2 in - let e := (e1 - e2)%Z in - let (m, e') := - match (d2 + prec - d1)%Z with - | Zpos p => (Z.shiftl m1 (Zpos p), e + Zneg p)%Z - | _ => (m1, e) - end in - let '(q, r) := Zfast_div_eucl m m2 in - (q, e', new_location m2 r loc_Exact). - -Lemma Bdiv_correct_aux : - forall m sx mx ex sy my ey, - let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in - let y := F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey) in - let z := - let '(mz, ez, lz) := Fdiv_core_binary (Zpos mx) ex (Zpos my) ey in - match mz with - | Zpos mz => binary_round_aux m (xorb sx sy) mz ez lz - | _ => F754_nan false xH (* dummy *) - end in - valid_binary z = true /\ - if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x / y))) (bpow radix2 emax) then - FF2R radix2 z = round radix2 fexp (round_mode m) (x / y) /\ - is_finite_FF z = true /\ sign_FF z = xorb sx sy - else - z = binary_overflow m (xorb sx sy). -Proof. -intros m sx mx ex sy my ey. -replace (Fdiv_core_binary (Zpos mx) ex (Zpos my) ey) with (Fdiv_core radix2 prec (Zpos mx) ex (Zpos my) ey). -refine (_ (Fdiv_core_correct radix2 prec (Zpos mx) ex (Zpos my) ey _ _ _)) ; try easy. -destruct (Fdiv_core radix2 prec (Zpos mx) ex (Zpos my) ey) as ((mz, ez), lz). -intros (Pz, Bz). -simpl. -replace (xorb sx sy) with (Rlt_bool (F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) * - / F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey)) 0). -unfold Rdiv. -destruct mz as [|mz|mz]. -(* . mz = 0 *) -elim (Zlt_irrefl prec). -now apply Zle_lt_trans with Z0. -(* . mz > 0 *) -apply binary_round_aux_correct. -rewrite Rabs_mult, Rabs_Rinv. -now rewrite <- 2!F2R_Zabs, 2!abs_cond_Zopp. -case sy. -apply Rlt_not_eq. -now apply F2R_lt_0_compat. -apply Rgt_not_eq. -now apply F2R_gt_0_compat. -revert Pz. -generalize (Zdigits radix2 (Zpos mz)). -unfold fexp, FLT_exp. -clear. -intros ; zify ; subst. -omega. -(* . mz < 0 *) -elim Rlt_not_le with (1 := proj2 (inbetween_float_bounds _ _ _ _ _ Bz)). -apply Rle_trans with R0. -apply F2R_le_0_compat. -now case mz. -apply Rmult_le_pos. -now apply F2R_ge_0_compat. -apply Rlt_le. -apply Rinv_0_lt_compat. -now apply F2R_gt_0_compat. -(* *) -case sy ; simpl. -change (Zneg my) with (Zopp (Zpos my)). -rewrite F2R_Zopp. -rewrite <- Ropp_inv_permute. -rewrite Ropp_mult_distr_r_reverse. -case sx ; simpl. -apply Rlt_bool_false. -rewrite <- Ropp_mult_distr_l_reverse. -apply Rmult_le_pos. -rewrite <- F2R_opp. -now apply F2R_ge_0_compat. -apply Rlt_le. -apply Rinv_0_lt_compat. -now apply F2R_gt_0_compat. -apply Rlt_bool_true. -rewrite <- Ropp_0. -apply Ropp_lt_contravar. -apply Rmult_lt_0_compat. -now apply F2R_gt_0_compat. -apply Rinv_0_lt_compat. -now apply F2R_gt_0_compat. -apply Rgt_not_eq. -now apply F2R_gt_0_compat. -case sx. -apply Rlt_bool_true. -rewrite F2R_Zopp. -rewrite Ropp_mult_distr_l_reverse. -rewrite <- Ropp_0. -apply Ropp_lt_contravar. -apply Rmult_lt_0_compat. -now apply F2R_gt_0_compat. -apply Rinv_0_lt_compat. -now apply F2R_gt_0_compat. -apply Rlt_bool_false. -apply Rmult_le_pos. -now apply F2R_ge_0_compat. -apply Rlt_le. -apply Rinv_0_lt_compat. -now apply F2R_gt_0_compat. -(* *) -unfold Fdiv_core_binary, Fdiv_core. -rewrite 2!Zdigits2_Zdigits. -change 2%Z with (radix_val radix2). -destruct (Zdigits radix2 (Z.pos my) + prec - Zdigits radix2 (Z.pos mx))%Z as [|p|p]. -now rewrite Zfast_div_eucl_correct. -rewrite Z.shiftl_mul_pow2 by easy. -now rewrite Zfast_div_eucl_correct. -now rewrite Zfast_div_eucl_correct. -Qed. - -Definition Bdiv div_nan m x y := - let f pl := B754_nan (fst pl) (snd pl) in - match x, y with - | B754_nan _ _, _ | _, B754_nan _ _ => f (div_nan x y) - | B754_infinity sx, B754_infinity sy => f (div_nan x y) - | B754_infinity sx, B754_finite sy _ _ _ => B754_infinity (xorb sx sy) - | B754_finite sx _ _ _, B754_infinity sy => B754_zero (xorb sx sy) - | B754_infinity sx, B754_zero sy => B754_infinity (xorb sx sy) - | B754_zero sx, B754_infinity sy => B754_zero (xorb sx sy) - | B754_finite sx _ _ _, B754_zero sy => B754_infinity (xorb sx sy) - | B754_zero sx, B754_finite sy _ _ _ => B754_zero (xorb sx sy) - | B754_zero sx, B754_zero sy => f (div_nan x y) - | B754_finite sx mx ex _, B754_finite sy my ey _ => - FF2B _ (proj1 (Bdiv_correct_aux m sx mx ex sy my ey)) - end. - -Theorem Bdiv_correct : - forall div_nan m x y, - B2R y <> 0%R -> - if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x / B2R y))) (bpow radix2 emax) then - B2R (Bdiv div_nan m x y) = round radix2 fexp (round_mode m) (B2R x / B2R y) /\ - is_finite (Bdiv div_nan m x y) = is_finite x /\ - (is_nan (Bdiv div_nan m x y) = false -> - Bsign (Bdiv div_nan m x y) = xorb (Bsign x) (Bsign y)) - else - B2FF (Bdiv div_nan m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)). -Proof. -intros div_nan m x [sy|sy|sy ply|sy my ey Hy] Zy ; try now elim Zy. -revert x. -unfold Rdiv. -intros [sx|sx|sx plx|sx mx ex Hx] ; - try ( rewrite Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ now repeat constructor | apply bpow_gt_0 | auto with typeclass_instances ] ). -simpl. -case Bdiv_correct_aux. -intros H1. -unfold Rdiv. -case Rlt_bool. -intros (H2, (H3, H4)). -split. -now rewrite B2R_FF2B. -split. -now rewrite is_finite_FF2B. -rewrite Bsign_FF2B. congruence. -intros H2. -now rewrite B2FF_FF2B. -Qed. - -(** Square root *) - -Definition Fsqrt_core_binary m e := - let d := Zdigits2 m in - let s := Zmax (2 * prec - d) 0 in - let e' := (e - s)%Z in - let (s', e'') := if Zeven e' then (s, e') else (s + 1, e' - 1)%Z in - let m' := - match s' with - | Zpos p => Z.shiftl m (Zpos p) - | _ => m - end in - let (q, r) := Z.sqrtrem m' in - let l := - if Zeq_bool r 0 then loc_Exact - else loc_Inexact (if Zle_bool r q then Lt else Gt) in - (q, Zdiv2 e'', l). - -Lemma Bsqrt_correct_aux : - forall m mx ex (Hx : bounded mx ex = true), - let x := F2R (Float radix2 (Zpos mx) ex) in - let z := - let '(mz, ez, lz) := Fsqrt_core_binary (Zpos mx) ex in - match mz with - | Zpos mz => binary_round_aux m false mz ez lz - | _ => F754_nan false xH (* dummy *) - end in - valid_binary z = true /\ - FF2R radix2 z = round radix2 fexp (round_mode m) (sqrt x) /\ - is_finite_FF z = true /\ sign_FF z = false. -Proof with auto with typeclass_instances. -intros m mx ex Hx. -replace (Fsqrt_core_binary (Zpos mx) ex) with (Fsqrt_core radix2 prec (Zpos mx) ex). -simpl. -refine (_ (Fsqrt_core_correct radix2 prec (Zpos mx) ex _)) ; try easy. -destruct (Fsqrt_core radix2 prec (Zpos mx) ex) as ((mz, ez), lz). -intros (Pz, Bz). -destruct mz as [|mz|mz]. -(* . mz = 0 *) -elim (Zlt_irrefl prec). -now apply Zle_lt_trans with Z0. -(* . mz > 0 *) -refine (_ (binary_round_aux_correct m (sqrt (F2R (Float radix2 (Zpos mx) ex))) mz ez lz _ _)). -rewrite Rlt_bool_false. 2: apply sqrt_ge_0. -rewrite Rlt_bool_true. -easy. -(* .. *) -rewrite Rabs_pos_eq. -refine (_ (relative_error_FLT_ex radix2 emin prec (prec_gt_0 prec) (round_mode m) (sqrt (F2R (Float radix2 (Zpos mx) ex))) _)). -fold fexp. -intros (eps, (Heps, Hr)). -rewrite Hr. -assert (Heps': (Rabs eps < 1)%R). -apply Rlt_le_trans with (1 := Heps). -fold (bpow radix2 0). -apply bpow_le. -generalize (prec_gt_0 prec). -clear ; omega. -apply Rsqr_incrst_0. -3: apply bpow_ge_0. -rewrite Rsqr_mult. -rewrite Rsqr_sqrt. -2: now apply F2R_ge_0_compat. -unfold Rsqr. -apply Rmult_ge_0_gt_0_lt_compat. -apply Rle_ge. -apply Rle_0_sqr. -apply bpow_gt_0. -now apply bounded_lt_emax. -apply Rlt_le_trans with 4%R. -apply Rsqr_incrst_1. -apply Rplus_lt_compat_l. -apply (Rabs_lt_inv _ _ Heps'). -rewrite <- (Rplus_opp_r 1). -apply Rplus_le_compat_l. -apply Rlt_le. -apply (Rabs_lt_inv _ _ Heps'). -now apply (Z2R_le 0 2). -change 4%R with (bpow radix2 2). -apply bpow_le. -generalize (prec_gt_0 prec). -clear -Hmax ; omega. -apply Rmult_le_pos. -apply sqrt_ge_0. -rewrite <- (Rplus_opp_r 1). -apply Rplus_le_compat_l. -apply Rlt_le. -apply (Rabs_lt_inv _ _ Heps'). -rewrite Rabs_pos_eq. -2: apply sqrt_ge_0. -apply Rsqr_incr_0. -2: apply bpow_ge_0. -2: apply sqrt_ge_0. -rewrite Rsqr_sqrt. -2: now apply F2R_ge_0_compat. -apply Rle_trans with (bpow radix2 emin). -unfold Rsqr. -rewrite <- bpow_plus. -apply bpow_le. -unfold emin. -clear -Hmax ; omega. -apply generic_format_ge_bpow with fexp. -intros. -apply Zle_max_r. -now apply F2R_gt_0_compat. -apply generic_format_canonic. -apply (canonic_canonic_mantissa false). -apply (andb_prop _ _ Hx). -(* .. *) -apply round_ge_generic... -apply generic_format_0. -apply sqrt_ge_0. -rewrite Rabs_pos_eq. -exact Bz. -apply sqrt_ge_0. -revert Pz. -generalize (Zdigits radix2 (Zpos mz)). -unfold fexp, FLT_exp. -clear. -intros ; zify ; subst. -omega. -(* . mz < 0 *) -elim Rlt_not_le with (1 := proj2 (inbetween_float_bounds _ _ _ _ _ Bz)). -apply Rle_trans with R0. -apply F2R_le_0_compat. -now case mz. -apply sqrt_ge_0. -(* *) -unfold Fsqrt_core, Fsqrt_core_binary. -rewrite Zdigits2_Zdigits. -destruct (if Zeven _ then _ else _) as [[|s'|s'] e''] ; try easy. -now rewrite Z.shiftl_mul_pow2. -Qed. - -Definition Bsqrt sqrt_nan m x := - let f pl := B754_nan (fst pl) (snd pl) in - match x with - | B754_nan sx plx => f (sqrt_nan x) - | B754_infinity false => x - | B754_infinity true => f (sqrt_nan x) - | B754_finite true _ _ _ => f (sqrt_nan x) - | B754_zero _ => x - | B754_finite sx mx ex Hx => - FF2B _ (proj1 (Bsqrt_correct_aux m mx ex Hx)) - end. - -Theorem Bsqrt_correct : - forall sqrt_nan m x, - B2R (Bsqrt sqrt_nan m x) = round radix2 fexp (round_mode m) (sqrt (B2R x)) /\ - is_finite (Bsqrt sqrt_nan m x) = match x with B754_zero _ => true | B754_finite false _ _ _ => true | _ => false end /\ - (is_nan (Bsqrt sqrt_nan m x) = false -> Bsign (Bsqrt sqrt_nan m x) = Bsign x). -Proof. -intros sqrt_nan m [sx|[|]| |sx mx ex Hx] ; try ( now simpl ; rewrite sqrt_0, round_0 ; intuition auto with typeclass_instances ). -simpl. -case Bsqrt_correct_aux. -intros H1 (H2, (H3, H4)). -case sx. -refine (conj _ (conj (refl_equal false) _)). -apply sym_eq. -unfold sqrt. -case Rcase_abs. -intros _. -apply round_0. -auto with typeclass_instances. -intros H. -elim Rge_not_lt with (1 := H). -now apply F2R_lt_0_compat. -easy. -split. -now rewrite B2R_FF2B. -split. -now rewrite is_finite_FF2B. -intro. rewrite Bsign_FF2B. auto. -Qed. - -End Binary. diff --git a/flocq/Calc/Fcalc_bracket.v b/flocq/Calc/Bracket.v index 03ef7bd3..83714e87 100644 --- a/flocq/Calc/Fcalc_bracket.v +++ b/flocq/Calc/Bracket.v @@ -2,9 +2,9 @@ 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-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +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 @@ -19,9 +19,7 @@ COPYING file for more details. (** * Locations: where a real number is positioned with respect to its rounded-down value in an arbitrary format. *) -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_float_prop. +Require Import Raux Defs Float_prop. Section Fcalc_bracket. @@ -146,23 +144,17 @@ assert (0 < v < 1)%R. split. unfold v, Rdiv. apply Rmult_lt_0_compat. -case l. -now apply (Z2R_lt 0 2). -now apply (Z2R_lt 0 1). -now apply (Z2R_lt 0 3). +case l ; now apply IZR_lt. apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 4). +now apply IZR_lt. unfold v, Rdiv. apply Rmult_lt_reg_r with 4%R. -now apply (Z2R_lt 0 4). +now apply IZR_lt. rewrite Rmult_assoc, Rinv_l. rewrite Rmult_1_r, Rmult_1_l. -case l. -now apply (Z2R_lt 2 4). -now apply (Z2R_lt 1 4). -now apply (Z2R_lt 3 4). +case l ; now apply IZR_lt. apply Rgt_not_eq. -now apply (Z2R_lt 0 4). +now apply IZR_lt. split. apply Rplus_lt_reg_r with (d * (v - 1))%R. ring_simplify. @@ -179,7 +171,7 @@ exact Hdu. set (v := (match l with Lt => 1 | Eq => 2 | Gt => 3 end)%R). rewrite <- (Rcompare_plus_r (- (d + u) / 2)). rewrite <- (Rcompare_mult_r 4). -2: now apply (Z2R_lt 0 4). +2: now apply IZR_lt. replace (((d + u) / 2 + - (d + u) / 2) * 4)%R with ((u - d) * 0)%R by field. replace ((d + v / 4 * (u - d) + - (d + u) / 2) * 4)%R with ((u - d) * (v - 2))%R by field. rewrite Rcompare_mult_l. @@ -187,10 +179,7 @@ rewrite Rcompare_mult_l. rewrite <- (Rcompare_plus_r 2). ring_simplify (v - 2 + 2)%R (0 + 2)%R. unfold v. -case l. -exact (Rcompare_Z2R 2 2). -exact (Rcompare_Z2R 1 2). -exact (Rcompare_Z2R 3 2). +case l ; apply Rcompare_IZR. Qed. Section Fcalc_bracket_step. @@ -201,19 +190,19 @@ Variable Hstep : (0 < step)%R. Lemma ordered_steps : forall k, - (start + Z2R k * step < start + Z2R (k + 1) * step)%R. + (start + IZR k * step < start + IZR (k + 1) * step)%R. Proof. intros k. apply Rplus_lt_compat_l. apply Rmult_lt_compat_r. exact Hstep. -apply Z2R_lt. +apply IZR_lt. apply Zlt_succ. Qed. Lemma middle_range : forall k, - ((start + (start + Z2R k * step)) / 2 = start + (Z2R k / 2 * step))%R. + ((start + (start + IZR k * step)) / 2 = start + (IZR k / 2 * step))%R. Proof. intros k. field. @@ -223,10 +212,10 @@ Hypothesis (Hnb_steps : (1 < nb_steps)%Z). Lemma inbetween_step_not_Eq : forall x k l l', - inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l -> + inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l -> (0 < k < nb_steps)%Z -> - Rcompare x (start + (Z2R nb_steps / 2 * step))%R = l' -> - inbetween start (start + Z2R nb_steps * step) x (loc_Inexact l'). + Rcompare x (start + (IZR nb_steps / 2 * step))%R = l' -> + inbetween start (start + IZR nb_steps * step) x (loc_Inexact l'). Proof. intros x k l l' Hx Hk Hl'. constructor. @@ -237,13 +226,13 @@ apply Rlt_le_trans with (2 := proj1 Hx'). rewrite <- (Rplus_0_r start) at 1. apply Rplus_lt_compat_l. apply Rmult_lt_0_compat. -now apply (Z2R_lt 0). +now apply IZR_lt. exact Hstep. apply Rlt_le_trans with (1 := proj2 Hx'). apply Rplus_le_compat_l. apply Rmult_le_compat_r. now apply Rlt_le. -apply Z2R_le. +apply IZR_le. omega. (* . *) now rewrite middle_range. @@ -251,9 +240,9 @@ Qed. Theorem inbetween_step_Lo : forall x k l, - inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l -> + inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l -> (0 < k)%Z -> (2 * k + 1 < nb_steps)%Z -> - inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Lt). + inbetween start (start + IZR nb_steps * step) x (loc_Inexact Lt). Proof. intros x k l Hx Hk1 Hk2. apply inbetween_step_not_Eq with (1 := Hx). @@ -264,18 +253,17 @@ apply Rlt_le_trans with (1 := proj2 Hx'). apply Rcompare_not_Lt_inv. rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_l. apply Rcompare_not_Lt. -change 2%R with (Z2R 2). -rewrite <- Z2R_mult. -apply Z2R_le. +rewrite <- mult_IZR. +apply IZR_le. omega. exact Hstep. Qed. Theorem inbetween_step_Hi : forall x k l, - inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l -> + inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l -> (nb_steps < 2 * k)%Z -> (k < nb_steps)%Z -> - inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Gt). + inbetween start (start + IZR nb_steps * step) x (loc_Inexact Gt). Proof. intros x k l Hx Hk1 Hk2. apply inbetween_step_not_Eq with (1 := Hx). @@ -286,9 +274,8 @@ apply Rlt_le_trans with (2 := proj1 Hx'). apply Rcompare_Lt_inv. rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_l. apply Rcompare_Lt. -change 2%R with (Z2R 2). -rewrite <- Z2R_mult. -apply Z2R_lt. +rewrite <- mult_IZR. +apply IZR_lt. omega. exact Hstep. Qed. @@ -297,7 +284,7 @@ Theorem inbetween_step_Lo_not_Eq : forall x l, inbetween start (start + step) x l -> l <> loc_Exact -> - inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Lt). + inbetween start (start + IZR nb_steps * step) x (loc_Inexact Lt). Proof. intros x l Hx Hl. assert (Hx' := inbetween_bounds_not_Eq _ _ _ _ Hx Hl). @@ -310,7 +297,7 @@ apply Rplus_lt_compat_l. rewrite <- (Rmult_1_l step) at 1. apply Rmult_lt_compat_r. exact Hstep. -now apply (Z2R_lt 1). +now apply IZR_lt. (* . *) apply Rcompare_Lt. apply Rlt_le_trans with (1 := proj2 Hx'). @@ -320,7 +307,7 @@ rewrite <- (Rmult_1_l step) at 2. rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_l. rewrite Rmult_1_r. apply Rcompare_not_Lt. -apply (Z2R_le 2). +apply IZR_le. now apply (Zlt_le_succ 1). exact Hstep. Qed. @@ -328,19 +315,19 @@ Qed. Lemma middle_odd : forall k, (2 * k + 1 = nb_steps)%Z -> - (((start + Z2R k * step) + (start + Z2R (k + 1) * step))/2 = start + Z2R nb_steps /2 * step)%R. + (((start + IZR k * step) + (start + IZR (k + 1) * step))/2 = start + IZR nb_steps /2 * step)%R. Proof. intros k Hk. rewrite <- Hk. -rewrite 2!Z2R_plus, Z2R_mult. +rewrite 2!plus_IZR, mult_IZR. simpl. field. Qed. Theorem inbetween_step_any_Mi_odd : forall x k l, - inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x (loc_Inexact l) -> + inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x (loc_Inexact l) -> (2 * k + 1 = nb_steps)%Z -> - inbetween start (start + Z2R nb_steps * step) x (loc_Inexact l). + inbetween start (start + IZR nb_steps * step) x (loc_Inexact l). Proof. intros x k l Hx Hk. apply inbetween_step_not_Eq with (1 := Hx). @@ -351,9 +338,9 @@ Qed. Theorem inbetween_step_Lo_Mi_Eq_odd : forall x k, - inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x loc_Exact -> + inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x loc_Exact -> (2 * k + 1 = nb_steps)%Z -> - inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Lt). + inbetween start (start + IZR nb_steps * step) x (loc_Inexact Lt). Proof. intros x k Hx Hk. apply inbetween_step_not_Eq with (1 := Hx). @@ -362,9 +349,8 @@ inversion_clear Hx as [Hl|]. rewrite Hl. rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_r. apply Rcompare_Lt. -change 2%R with (Z2R 2). -rewrite <- Z2R_mult. -apply Z2R_lt. +rewrite <- mult_IZR. +apply IZR_lt. rewrite <- Hk. apply Zlt_succ. exact Hstep. @@ -372,10 +358,10 @@ Qed. Theorem inbetween_step_Hi_Mi_even : forall x k l, - inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l -> + inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l -> l <> loc_Exact -> (2 * k = nb_steps)%Z -> - inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Gt). + inbetween start (start + IZR nb_steps * step) x (loc_Inexact Gt). Proof. intros x k l Hx Hl Hk. apply inbetween_step_not_Eq with (1 := Hx). @@ -385,28 +371,26 @@ assert (Hx' := inbetween_bounds_not_Eq _ _ _ _ Hx Hl). apply Rle_lt_trans with (2 := proj1 Hx'). apply Rcompare_not_Lt_inv. rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_r. -change 2%R with (Z2R 2). -rewrite <- Z2R_mult. +rewrite <- mult_IZR. apply Rcompare_not_Lt. -apply Z2R_le. +apply IZR_le. rewrite Hk. -apply Zle_refl. +apply Z.le_refl. exact Hstep. Qed. Theorem inbetween_step_Mi_Mi_even : forall x k, - inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x loc_Exact -> + inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x loc_Exact -> (2 * k = nb_steps)%Z -> - inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Eq). + inbetween start (start + IZR nb_steps * step) x (loc_Inexact Eq). Proof. intros x k Hx Hk. apply inbetween_step_not_Eq with (1 := Hx). omega. apply Rcompare_Eq. inversion_clear Hx as [Hx'|]. -rewrite Hx', <- Hk, Z2R_mult. -simpl (Z2R 2). +rewrite Hx', <- Hk, mult_IZR. field. Qed. @@ -419,17 +403,17 @@ Definition new_location_even k l := match l with loc_Exact => l | _ => loc_Inexact Lt end else loc_Inexact - match Zcompare (2 * k) nb_steps with + match Z.compare (2 * k) nb_steps with | Lt => Lt | Eq => match l with loc_Exact => Eq | _ => Gt end | Gt => Gt end. Theorem new_location_even_correct : - Zeven nb_steps = true -> + Z.even nb_steps = true -> forall x k l, (0 <= k < nb_steps)%Z -> - inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l -> - inbetween start (start + Z2R nb_steps * step) x (new_location_even k l). + inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l -> + inbetween start (start + IZR nb_steps * step) x (new_location_even k l). Proof. intros He x k l Hk Hx. unfold new_location_even. @@ -476,17 +460,17 @@ Definition new_location_odd k l := match l with loc_Exact => l | _ => loc_Inexact Lt end else loc_Inexact - match Zcompare (2 * k + 1) nb_steps with + match Z.compare (2 * k + 1) nb_steps with | Lt => Lt | Eq => match l with loc_Inexact l => l | loc_Exact => Lt end | Gt => Gt end. Theorem new_location_odd_correct : - Zeven nb_steps = false -> + Z.even nb_steps = false -> forall x k l, (0 <= k < nb_steps)%Z -> - inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l -> - inbetween start (start + Z2R nb_steps * step) x (new_location_odd k l). + inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l -> + inbetween start (start + IZR nb_steps * step) x (new_location_odd k l). Proof. intros Ho x k l Hk Hx. unfold new_location_odd. @@ -520,16 +504,16 @@ apply Hk. Qed. Definition new_location := - if Zeven nb_steps then new_location_even else new_location_odd. + if Z.even nb_steps then new_location_even else new_location_odd. Theorem new_location_correct : forall x k l, (0 <= k < nb_steps)%Z -> - inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l -> - inbetween start (start + Z2R nb_steps * step) x (new_location k l). + inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l -> + inbetween start (start + IZR nb_steps * step) x (new_location k l). Proof. intros x k l Hk Hx. unfold new_location. -generalize (refl_equal nb_steps) (Zle_lt_trans _ _ _ (proj1 Hk) (proj2 Hk)). +generalize (refl_equal nb_steps) (Z.le_lt_trans _ _ _ (proj1 Hk) (proj2 Hk)). pattern nb_steps at 2 3 5 ; case nb_steps. now intros _. (* . *) @@ -603,7 +587,7 @@ intros x m e l [Hx|l' Hx Hl]. rewrite Hx. split. apply Rle_refl. -apply F2R_lt_compat. +apply F2R_lt. apply Zlt_succ. split. now apply Rlt_le. @@ -613,13 +597,13 @@ Qed. (** Specialization of inbetween for two consecutive integers. *) Definition inbetween_int m x l := - inbetween (Z2R m) (Z2R (m + 1)) x l. + inbetween (IZR m) (IZR (m + 1)) x l. Theorem inbetween_float_new_location : forall x m e l k, (0 < k)%Z -> inbetween_float m e x l -> - inbetween_float (Zdiv m (Zpower beta k)) (e + k) x (new_location (Zpower beta k) (Zmod m (Zpower beta k)) l). + inbetween_float (Z.div m (Zpower beta k)) (e + k) x (new_location (Zpower beta k) (Zmod m (Zpower beta k)) l). Proof. intros x m e l k Hk Hx. unfold inbetween_float in *. @@ -630,19 +614,19 @@ apply (f_equal (fun r => F2R (Float beta (m * Zpower _ r) e))). ring. omega. assert (Hp: (Zpower beta k > 0)%Z). -apply Zlt_gt. +apply Z.lt_gt. apply Zpower_gt_0. now apply Zlt_le_weak. (* . *) rewrite 2!Hr. rewrite Zmult_plus_distr_l, Zmult_1_l. unfold F2R at 2. simpl. -rewrite Z2R_plus, Rmult_plus_distr_r. +rewrite plus_IZR, Rmult_plus_distr_r. apply new_location_correct. apply bpow_gt_0. now apply Zpower_gt_1. now apply Z_mod_lt. -rewrite <- 2!Rmult_plus_distr_r, <- 2!Z2R_plus. +rewrite <- 2!Rmult_plus_distr_r, <- 2!plus_IZR. rewrite Zmult_comm, Zplus_assoc. now rewrite <- Z_div_mod_eq. Qed. @@ -650,7 +634,7 @@ Qed. Theorem inbetween_float_new_location_single : forall x m e l, inbetween_float m e x l -> - inbetween_float (Zdiv m beta) (e + 1) x (new_location beta (Zmod m beta) l). + inbetween_float (Z.div m beta) (e + 1) x (new_location beta (Zmod m beta) l). Proof. intros x m e l Hx. replace (radix_val beta) with (Zpower beta 1). @@ -665,7 +649,7 @@ Theorem inbetween_float_ex : Proof. intros m e l. apply inbetween_ex. -apply F2R_lt_compat. +apply F2R_lt. apply Zlt_succ. Qed. @@ -682,7 +666,7 @@ apply inbetween_unique with (1 := H) (2 := H'). destruct (inbetween_float_bounds x m e l H) as (H1,H2). destruct (inbetween_float_bounds x m' e l' H') as (H3,H4). cut (m < m' + 1 /\ m' < m + 1)%Z. clear ; omega. -now split ; apply F2R_lt_reg with beta e ; apply Rle_lt_trans with x. +now split ; apply lt_F2R with beta e ; apply Rle_lt_trans with x. Qed. End Fcalc_bracket_generic. diff --git a/flocq/Calc/Div.v b/flocq/Calc/Div.v new file mode 100644 index 00000000..65195562 --- /dev/null +++ b/flocq/Calc/Div.v @@ -0,0 +1,159 @@ +(** +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 +#<br /># +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. +*) + +(** * Helper function and theorem for computing the rounded quotient of two floating-point numbers. *) + +Require Import Raux Defs Generic_fmt Float_prop Digits Bracket. + +Set Implicit Arguments. +Set Strongly Strict Implicit. + +Section Fcalc_div. + +Variable beta : radix. +Notation bpow e := (bpow beta e). + +Variable fexp : Z -> Z. + +(** Computes a mantissa of precision p, the corresponding exponent, + and the position with respect to the real quotient of the + input floating-point numbers. + +The algorithm performs the following steps: +- Shift dividend mantissa so that it has at least p2 + p digits. +- Perform the Euclidean division. +- Compute the position according to the division remainder. + +Complexity is fine as long as p1 <= 2p and p2 <= p. +*) + +Lemma mag_div_F2R : + forall m1 e1 m2 e2, + (0 < m1)%Z -> (0 < m2)%Z -> + let e := ((Zdigits beta m1 + e1) - (Zdigits beta m2 + e2))%Z in + (e <= mag beta (F2R (Float beta m1 e1) / F2R (Float beta m2 e2)) <= e + 1)%Z. +Proof. +intros m1 e1 m2 e2 Hm1 Hm2. +rewrite <- (mag_F2R_Zdigits beta m1 e1) by now apply Zgt_not_eq. +rewrite <- (mag_F2R_Zdigits beta m2 e2) by now apply Zgt_not_eq. +apply mag_div. +now apply F2R_neq_0, Zgt_not_eq. +now apply F2R_neq_0, Zgt_not_eq. +Qed. + +Definition Fdiv_core m1 e1 m2 e2 e := + let (m1', m2') := + if Zle_bool e (e1 - e2)%Z + then (m1 * Zpower beta (e1 - e2 - e), m2)%Z + else (m1, m2 * Zpower beta (e - (e1 - e2)))%Z in + let '(q, r) := Z.div_eucl m1' m2' in + (q, new_location m2' r loc_Exact). + +Theorem Fdiv_core_correct : + forall m1 e1 m2 e2 e, + (0 < m1)%Z -> (0 < m2)%Z -> + let '(m, l) := Fdiv_core m1 e1 m2 e2 e in + inbetween_float beta m e (F2R (Float beta m1 e1) / F2R (Float beta m2 e2)) l. +Proof. +intros m1 e1 m2 e2 e Hm1 Hm2. +unfold Fdiv_core. +match goal with |- context [if ?b then ?b1 else ?b2] => set (m12 := if b then b1 else b2) end. +case_eq m12 ; intros m1' m2' Hm. +assert ((F2R (Float beta m1 e1) / F2R (Float beta m2 e2) = IZR m1' / IZR m2' * bpow e)%R /\ (0 < m2')%Z) as [Hf Hm2']. +{ unfold F2R, Zminus ; simpl. + destruct (Zle_bool e (e1 - e2)) eqn:He' ; injection Hm ; intros ; subst. + - split ; try easy. + apply Zle_bool_imp_le in He'. + rewrite mult_IZR, IZR_Zpower by omega. + unfold Zminus ; rewrite 2!bpow_plus, 2!bpow_opp. + field. + repeat split ; try apply Rgt_not_eq, bpow_gt_0. + now apply IZR_neq, Zgt_not_eq. + - apply Z.leb_gt in He'. + split ; cycle 1. + { apply Z.mul_pos_pos with (1 := Hm2). + apply Zpower_gt_0 ; omega. } + rewrite mult_IZR, IZR_Zpower by omega. + unfold Zminus ; rewrite bpow_plus, bpow_opp, bpow_plus, bpow_opp. + field. + repeat split ; try apply Rgt_not_eq, bpow_gt_0. + now apply IZR_neq, Zgt_not_eq. } +clearbody m12 ; clear Hm Hm1 Hm2. +generalize (Z_div_mod m1' m2' (Z.lt_gt _ _ Hm2')). +destruct (Z.div_eucl m1' m2') as (q, r). +intros (Hq, Hr). +rewrite Hf. +unfold inbetween_float, F2R. simpl. +rewrite Hq, 2!plus_IZR, mult_IZR. +apply inbetween_mult_compat. + apply bpow_gt_0. +destruct (Z_lt_le_dec 1 m2') as [Hm2''|Hm2'']. +- replace 1%R with (IZR m2' * /IZR m2')%R. + apply new_location_correct ; try easy. + apply Rinv_0_lt_compat. + now apply IZR_lt. + constructor. + field. + now apply IZR_neq, Zgt_not_eq. + field. + now apply IZR_neq, Zgt_not_eq. +- assert (r = 0 /\ m2' = 1)%Z as [-> ->] by (clear -Hr Hm2'' ; omega). + unfold Rdiv. + rewrite Rmult_1_l, Rplus_0_r, Rinv_1, Rmult_1_r. + now constructor. +Qed. + +Definition Fdiv (x y : float beta) := + let (m1, e1) := x in + let (m2, e2) := y in + let e' := ((Zdigits beta m1 + e1) - (Zdigits beta m2 + e2))%Z in + let e := Z.min (Z.min (fexp e') (fexp (e' + 1))) (e1 - e2) in + let '(m, l) := Fdiv_core m1 e1 m2 e2 e in + (m, e, l). + +Theorem Fdiv_correct : + forall x y, + (0 < F2R x)%R -> (0 < F2R y)%R -> + let '(m, e, l) := Fdiv x y in + (e <= cexp beta fexp (F2R x / F2R y))%Z /\ + inbetween_float beta m e (F2R x / F2R y) l. +Proof. +intros [m1 e1] [m2 e2] Hm1 Hm2. +apply gt_0_F2R in Hm1. +apply gt_0_F2R in Hm2. +unfold Fdiv. +generalize (mag_div_F2R m1 e1 m2 e2 Hm1 Hm2). +set (e := Zminus _ _). +set (e' := Z.min (Z.min (fexp e) (fexp (e + 1))) (e1 - e2)). +intros [H1 H2]. +generalize (Fdiv_core_correct m1 e1 m2 e2 e' Hm1 Hm2). +destruct Fdiv_core as [m' l]. +apply conj. +apply Z.le_trans with (1 := Z.le_min_l _ _). +unfold cexp. +destruct (Zle_lt_or_eq _ _ H1) as [H|H]. +- replace (fexp (mag _ _)) with (fexp (e + 1)). + apply Z.le_min_r. + clear -H1 H2 H ; apply f_equal ; omega. +- replace (fexp (mag _ _)) with (fexp e). + apply Z.le_min_l. + clear -H1 H2 H ; apply f_equal ; omega. +Qed. + +End Fcalc_div. diff --git a/flocq/Calc/Fcalc_digits.v b/flocq/Calc/Fcalc_digits.v deleted file mode 100644 index 45133e81..00000000 --- a/flocq/Calc/Fcalc_digits.v +++ /dev/null @@ -1,63 +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 -#<br /># -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. -*) - -(** * Functions for computing the number of digits of integers and related theorems. *) - -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_float_prop. -Require Import Fcore_digits. - -Section Fcalc_digits. - -Variable beta : radix. -Notation bpow e := (bpow beta e). - -Theorem Zdigits_ln_beta : - forall n, - n <> Z0 -> - Zdigits beta n = ln_beta beta (Z2R n). -Proof. -intros n Hn. -destruct (ln_beta beta (Z2R n)) as (e, He) ; simpl. -specialize (He (Z2R_neq _ _ Hn)). -rewrite <- Z2R_abs 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 <- Z2R_Zpower by omega. -now apply Z2R_le. -apply Rle_lt_trans with (1 := proj1 He). -rewrite <- Z2R_Zpower by omega. -now apply Z2R_lt. -Qed. - -Theorem ln_beta_F2R_Zdigits : - forall m e, m <> Z0 -> - (ln_beta beta (F2R (Float beta m e)) = Zdigits beta m + e :> Z)%Z. -Proof. -intros m e Hm. -rewrite ln_beta_F2R with (1 := Hm). -apply (f_equal (fun v => Zplus v e)). -apply sym_eq. -now apply Zdigits_ln_beta. -Qed. - -End Fcalc_digits. diff --git a/flocq/Calc/Fcalc_div.v b/flocq/Calc/Fcalc_div.v deleted file mode 100644 index c8f1f9fc..00000000 --- a/flocq/Calc/Fcalc_div.v +++ /dev/null @@ -1,165 +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 -#<br /># -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. -*) - -(** * Helper function and theorem for computing the rounded quotient of two floating-point numbers. *) - -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_float_prop. -Require Import Fcore_digits. -Require Import Fcalc_bracket. -Require Import Fcalc_digits. - -Section Fcalc_div. - -Variable beta : radix. -Notation bpow e := (bpow beta e). - -(** Computes a mantissa of precision p, the corresponding exponent, - and the position with respect to the real quotient of the - input floating-point numbers. - -The algorithm performs the following steps: -- Shift dividend mantissa so that it has at least p2 + p digits. -- Perform the Euclidean division. -- Compute the position according to the division remainder. - -Complexity is fine as long as p1 <= 2p and p2 <= p. -*) - -Definition Fdiv_core prec m1 e1 m2 e2 := - let d1 := Zdigits beta m1 in - let d2 := Zdigits beta m2 in - let e := (e1 - e2)%Z in - let (m, e') := - match (d2 + prec - d1)%Z with - | Zpos p => (m1 * Zpower_pos beta p, e + Zneg p)%Z - | _ => (m1, e) - end in - let '(q, r) := Zdiv_eucl m m2 in - (q, e', new_location m2 r loc_Exact). - -Theorem Fdiv_core_correct : - forall prec m1 e1 m2 e2, - (0 < prec)%Z -> - (0 < m1)%Z -> (0 < m2)%Z -> - let '(m, e, l) := Fdiv_core prec m1 e1 m2 e2 in - (prec <= Zdigits beta m)%Z /\ - inbetween_float beta m e (F2R (Float beta m1 e1) / F2R (Float beta m2 e2)) l. -Proof. -intros prec m1 e1 m2 e2 Hprec Hm1 Hm2. -unfold Fdiv_core. -set (d1 := Zdigits beta m1). -set (d2 := Zdigits beta m2). -case_eq - (match (d2 + prec - d1)%Z with - | Zpos p => ((m1 * Zpower_pos beta p)%Z, (e1 - e2 + Zneg p)%Z) - | _ => (m1, (e1 - e2)%Z) - end). -intros m' e' Hme. -(* . the shifted mantissa m' has enough digits *) -assert (Hs: F2R (Float beta m' (e' + e2)) = F2R (Float beta m1 e1) /\ (0 < m')%Z /\ (d2 + prec <= Zdigits beta m')%Z). -replace (d2 + prec)%Z with (d2 + prec - d1 + d1)%Z by ring. -destruct (d2 + prec - d1)%Z as [|p|p] ; - unfold d1 ; - inversion Hme. -ring_simplify (e1 - e2 + e2)%Z. -repeat split. -now rewrite <- H0. -apply Zle_refl. -replace (e1 - e2 + Zneg p + e2)%Z with (e1 - Zpos p)%Z by (unfold Zminus ; simpl ; ring). -fold (Zpower beta (Zpos p)). -split. -pattern (Zpos p) at 1 ; replace (Zpos p) with (e1 - (e1 - Zpos p))%Z by ring. -apply sym_eq. -apply F2R_change_exp. -assert (0 < Zpos p)%Z by easy. -omega. -split. -apply Zmult_lt_0_compat. -exact Hm1. -now apply Zpower_gt_0. -rewrite Zdigits_mult_Zpower. -rewrite Zplus_comm. -apply Zle_refl. -apply sym_not_eq. -now apply Zlt_not_eq. -easy. -split. -now ring_simplify (e1 - e2 + e2)%Z. -assert (Zneg p < 0)%Z by easy. -omega. -(* . *) -destruct Hs as (Hs1, (Hs2, Hs3)). -rewrite <- Hs1. -generalize (Z_div_mod m' m2 (Zlt_gt _ _ Hm2)). -destruct (Zdiv_eucl m' m2) as (q, r). -intros (Hq, Hr). -split. -(* . the result mantissa q has enough digits *) -cut (Zdigits beta m' <= d2 + Zdigits beta q)%Z. omega. -unfold d2. -rewrite Hq. -assert (Hq': (0 < q)%Z). -apply Zmult_lt_reg_r with (1 := Hm2). -assert (m2 < m')%Z. -apply lt_Zdigits with beta. -now apply Zlt_le_weak. -unfold d2 in Hs3. -clear -Hprec Hs3 ; omega. -cut (q * m2 = m' - r)%Z. clear -Hr H ; omega. -rewrite Hq. -ring. -apply Zle_trans with (Zdigits beta (m2 + q + m2 * q)). -apply Zdigits_le. -rewrite <- Hq. -now apply Zlt_le_weak. -clear -Hr Hq'. omega. -apply Zdigits_mult_strong ; apply Zlt_le_weak. -now apply Zle_lt_trans with r. -exact Hq'. -(* . the location is correctly computed *) -unfold inbetween_float, F2R. simpl. -rewrite bpow_plus, Z2R_plus. -rewrite Hq, Z2R_plus, Z2R_mult. -replace ((Z2R m2 * Z2R q + Z2R r) * (bpow e' * bpow e2) / (Z2R m2 * bpow e2))%R - with ((Z2R q + Z2R r / Z2R m2) * bpow e')%R. -apply inbetween_mult_compat. -apply bpow_gt_0. -destruct (Z_lt_le_dec 1 m2) as [Hm2''|Hm2'']. -replace (Z2R 1) with (Z2R m2 * /Z2R m2)%R. -apply new_location_correct ; try easy. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0). -now constructor. -apply Rinv_r. -apply Rgt_not_eq. -now apply (Z2R_lt 0). -assert (r = 0 /\ m2 = 1)%Z by (clear -Hr Hm2'' ; omega). -rewrite (proj1 H), (proj2 H). -unfold Rdiv. -rewrite Rmult_0_l, Rplus_0_r. -now constructor. -field. -split ; apply Rgt_not_eq. -apply bpow_gt_0. -now apply (Z2R_lt 0). -Qed. - -End Fcalc_div. diff --git a/flocq/Calc/Fcalc_sqrt.v b/flocq/Calc/Fcalc_sqrt.v deleted file mode 100644 index 5f541d83..00000000 --- a/flocq/Calc/Fcalc_sqrt.v +++ /dev/null @@ -1,244 +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 -#<br /># -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. -*) - -(** * Helper functions and theorems for computing the rounded square root of a floating-point number. *) - -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_digits. -Require Import Fcore_float_prop. -Require Import Fcalc_bracket. -Require Import Fcalc_digits. - -Section Fcalc_sqrt. - -Variable beta : radix. -Notation bpow e := (bpow beta e). - -(** Computes a mantissa of precision p, the corresponding exponent, - and the position with respect to the real square root of the - input floating-point number. - -The algorithm performs the following steps: -- Shift the mantissa so that it has at least 2p-1 digits; - shift it one digit more if the new exponent is not even. -- Compute the square root s (at least p digits) of the new - mantissa, and its remainder r. -- Compute the position according to the remainder: - -- r == 0 => Eq, - -- r <= s => Lo, - -- r >= s => Up. - -Complexity is fine as long as p1 <= 2p-1. -*) - -Definition Fsqrt_core prec m e := - let d := Zdigits beta m in - let s := Zmax (2 * prec - d) 0 in - let e' := (e - s)%Z in - let (s', e'') := if Zeven e' then (s, e') else (s + 1, e' - 1)%Z in - let m' := - match s' with - | Zpos p => (m * Zpower_pos beta p)%Z - | _ => m - end in - let (q, r) := Z.sqrtrem m' in - let l := - if Zeq_bool r 0 then loc_Exact - else loc_Inexact (if Zle_bool r q then Lt else Gt) in - (q, Zdiv2 e'', l). - -Theorem Fsqrt_core_correct : - forall prec m e, - (0 < m)%Z -> - let '(m', e', l) := Fsqrt_core prec m e in - (prec <= Zdigits beta m')%Z /\ - inbetween_float beta m' e' (sqrt (F2R (Float beta m e))) l. -Proof. -intros prec m e Hm. -unfold Fsqrt_core. -set (d := Zdigits beta m). -set (s := Zmax (2 * prec - d) 0). -(* . exponent *) -case_eq (if Zeven (e - s) then (s, (e - s)%Z) else ((s + 1)%Z, (e - s - 1)%Z)). -intros s' e' Hse. -assert (He: (Zeven e' = true /\ 0 <= s' /\ 2 * prec - d <= s' /\ s' + e' = e)%Z). -revert Hse. -case_eq (Zeven (e - s)) ; intros He Hse ; inversion Hse. -repeat split. -exact He. -unfold s. -apply Zle_max_r. -apply Zle_max_l. -ring. -assert (H: (Zmax (2 * prec - d) 0 <= s + 1)%Z). -fold s. -apply Zle_succ. -repeat split. -unfold Zminus at 1. -now rewrite Zeven_plus, He. -apply Zle_trans with (2 := H). -apply Zle_max_r. -apply Zle_trans with (2 := H). -apply Zle_max_l. -ring. -clear -Hm He. -destruct He as (He1, (He2, (He3, He4))). -(* . shift *) -set (m' := match s' with - | Z0 => m - | Zpos p => (m * Zpower_pos beta p)%Z - | Zneg _ => m - end). -assert (Hs: F2R (Float beta m' e') = F2R (Float beta m e) /\ (2 * prec <= Zdigits beta m')%Z /\ (0 < m')%Z). -rewrite <- He4. -unfold m'. -destruct s' as [|p|p]. -repeat split ; try easy. -fold d. -omega. -fold (Zpower beta (Zpos p)). -split. -replace (Zpos p) with (Zpos p + e' - e')%Z by ring. -rewrite <- F2R_change_exp. -apply (f_equal (fun v => F2R (Float beta m v))). -ring. -assert (0 < Zpos p)%Z by easy. -omega. -split. -rewrite Zdigits_mult_Zpower. -fold d. -omega. -apply sym_not_eq. -now apply Zlt_not_eq. -easy. -apply Zmult_lt_0_compat. -exact Hm. -now apply Zpower_gt_0. -now elim He2. -clearbody m'. -destruct Hs as (Hs1, (Hs2, Hs3)). -generalize (Z.sqrtrem_spec m' (Zlt_le_weak _ _ Hs3)). -destruct (Z.sqrtrem m') as (q, r). -intros (Hq, Hr). -rewrite <- Hs1. clear Hs1. -split. -(* . mantissa width *) -apply Zmult_le_reg_r with 2%Z. -easy. -rewrite Zmult_comm. -apply Zle_trans with (1 := Hs2). -rewrite Hq. -apply Zle_trans with (Zdigits beta (q + q + q * q)). -apply Zdigits_le. -rewrite <- Hq. -now apply Zlt_le_weak. -omega. -replace (Zdigits beta q * 2)%Z with (Zdigits beta q + Zdigits beta q)%Z by ring. -apply Zdigits_mult_strong. -omega. -omega. -(* . round *) -unfold inbetween_float, F2R. simpl. -rewrite sqrt_mult. -2: now apply (Z2R_le 0) ; apply Zlt_le_weak. -2: apply Rlt_le ; apply bpow_gt_0. -destruct (Zeven_ex e') as (e2, Hev). -rewrite He1, Zplus_0_r in Hev. clear He1. -rewrite Hev. -replace (Zdiv2 (2 * e2)) with e2 by now case e2. -replace (2 * e2)%Z with (e2 + e2)%Z by ring. -rewrite bpow_plus. -fold (Rsqr (bpow e2)). -rewrite sqrt_Rsqr. -2: apply Rlt_le ; apply bpow_gt_0. -apply inbetween_mult_compat. -apply bpow_gt_0. -rewrite Hq. -case Zeq_bool_spec ; intros Hr'. -(* .. r = 0 *) -rewrite Hr', Zplus_0_r, Z2R_mult. -fold (Rsqr (Z2R q)). -rewrite sqrt_Rsqr. -now constructor. -apply (Z2R_le 0). -omega. -(* .. r <> 0 *) -constructor. -split. -(* ... bounds *) -apply Rle_lt_trans with (sqrt (Z2R (q * q))). -rewrite Z2R_mult. -fold (Rsqr (Z2R q)). -rewrite sqrt_Rsqr. -apply Rle_refl. -apply (Z2R_le 0). -omega. -apply sqrt_lt_1. -rewrite Z2R_mult. -apply Rle_0_sqr. -rewrite <- Hq. -apply (Z2R_le 0). -now apply Zlt_le_weak. -apply Z2R_lt. -omega. -apply Rlt_le_trans with (sqrt (Z2R ((q + 1) * (q + 1)))). -apply sqrt_lt_1. -rewrite <- Hq. -apply (Z2R_le 0). -now apply Zlt_le_weak. -rewrite Z2R_mult. -apply Rle_0_sqr. -apply Z2R_lt. -ring_simplify. -omega. -rewrite Z2R_mult. -fold (Rsqr (Z2R (q + 1))). -rewrite sqrt_Rsqr. -apply Rle_refl. -apply (Z2R_le 0). -omega. -(* ... location *) -rewrite Rcompare_half_r. -rewrite <- Rcompare_sqr. -replace ((2 * sqrt (Z2R (q * q + r))) * (2 * sqrt (Z2R (q * q + r))))%R - with (4 * Rsqr (sqrt (Z2R (q * q + r))))%R by (unfold Rsqr ; ring). -rewrite Rsqr_sqrt. -change 4%R with (Z2R 4). -rewrite <- Z2R_plus, <- 2!Z2R_mult. -rewrite Rcompare_Z2R. -replace ((q + (q + 1)) * (q + (q + 1)))%Z with (4 * (q * q) + 4 * q + 1)%Z by ring. -generalize (Zle_cases r q). -case (Zle_bool r q) ; intros Hr''. -change (4 * (q * q + r) < 4 * (q * q) + 4 * q + 1)%Z. -omega. -change (4 * (q * q + r) > 4 * (q * q) + 4 * q + 1)%Z. -omega. -rewrite <- Hq. -apply (Z2R_le 0). -now apply Zlt_le_weak. -apply Rmult_le_pos. -now apply (Z2R_le 0 2). -apply sqrt_ge_0. -rewrite <- Z2R_plus. -apply (Z2R_le 0). -omega. -Qed. - -End Fcalc_sqrt. diff --git a/flocq/Calc/Fcalc_ops.v b/flocq/Calc/Operations.v index e834c044..3416cb4e 100644 --- a/flocq/Calc/Fcalc_ops.v +++ b/flocq/Calc/Operations.v @@ -2,9 +2,9 @@ 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) 2009-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +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 @@ -18,9 +18,10 @@ COPYING file for more details. *) (** Basic operations on floats: alignment, addition, multiplication *) -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_float_prop. +Require Import Raux Defs Float_prop. + +Set Implicit Arguments. +Set Strongly Strict Implicit. Section Float_ops. @@ -28,7 +29,7 @@ Variable beta : radix. Notation bpow e := (bpow beta e). -Arguments Float {beta} Fnum Fexp. +Arguments Float {beta}. Definition Falign (f1 f2 : float beta) := let '(Float m1 e1) := f1 in @@ -54,7 +55,7 @@ Qed. Theorem Falign_spec_exp: forall f1 f2 : float beta, - snd (Falign f1 f2) = Zmin (Fexp f1) (Fexp f2). + snd (Falign f1 f2) = Z.min (Fexp f1) (Fexp f2). Proof. intros (m1,e1) (m2,e2). unfold Falign; simpl. @@ -76,7 +77,7 @@ Qed. Definition Fabs (f1 : float beta) : float beta := let '(Float m1 e1) := f1 in - Float (Zabs m1)%Z e1. + Float (Z.abs m1)%Z e1. Theorem F2R_abs : forall f1 : float beta, @@ -100,7 +101,7 @@ destruct (Falign f1 f2) as ((m1, m2), e). intros (H1, H2). rewrite H1, H2. unfold F2R. simpl. -rewrite Z2R_plus. +rewrite plus_IZR. apply Rmult_plus_distr_r. Qed. @@ -116,7 +117,7 @@ Qed. Theorem Fexp_Fplus : forall f1 f2 : float beta, - Fexp (Fplus f1 f2) = Zmin (Fexp f1) (Fexp f2). + Fexp (Fplus f1 f2) = Z.min (Fexp f1) (Fexp f2). Proof. intros f1 f2. unfold Fplus. @@ -156,7 +157,7 @@ Theorem F2R_mult : Proof. intros (m1, e1) (m2, e2). unfold Fmult, F2R. simpl. -rewrite Z2R_mult, bpow_plus. +rewrite mult_IZR, bpow_plus. ring. Qed. diff --git a/flocq/Calc/Fcalc_round.v b/flocq/Calc/Round.v index 86422247..5bde6af4 100644 --- a/flocq/Calc/Fcalc_round.v +++ b/flocq/Calc/Round.v @@ -2,9 +2,9 @@ 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-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +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 @@ -19,10 +19,7 @@ COPYING file for more details. (** * Helper function for computing the rounded value of a real number. *) -Require Import Fcore. -Require Import Fcore_digits. -Require Import Fcalc_bracket. -Require Import Fcalc_digits. +Require Import Core Digits Float_prop Bracket. Section Fcalc_round. @@ -35,19 +32,78 @@ Variable fexp : Z -> Z. Context { valid_exp : Valid_exp fexp }. Notation format := (generic_format beta fexp). +Theorem cexp_inbetween_float : + forall x m e l, + (0 < x)%R -> + inbetween_float beta m e x l -> + (e <= cexp beta fexp x \/ e <= fexp (Zdigits beta m + e))%Z -> + cexp beta fexp x = fexp (Zdigits beta m + e). +Proof. +intros x m e l Px Bx He. +unfold cexp. +apply inbetween_float_bounds in Bx. +assert (0 <= m)%Z as Hm. +{ apply Zlt_succ_le. + eapply gt_0_F2R. + apply Rlt_trans with (1 := Px). + apply Bx. } +destruct (Zle_lt_or_eq _ _ Hm) as [Hm'|<-]. + now erewrite <- mag_F2R_bounds_Zdigits with (1 := Hm'). +clear Hm. +assert (mag beta x <= e)%Z as Hx. +{ apply mag_le_bpow. + now apply Rgt_not_eq. + rewrite Rabs_pos_eq. + now rewrite <- F2R_bpow. + now apply Rlt_le. } +simpl in He |- *. +clear Bx. +destruct He as [He|He]. +- apply eq_sym, valid_exp with (2 := He). + now apply Z.le_trans with e. +- apply valid_exp with (1 := He). + now apply Z.le_trans with e. +Qed. + +Theorem cexp_inbetween_float_loc_Exact : + forall x m e l, + (0 <= x)%R -> + inbetween_float beta m e x l -> + (e <= cexp beta fexp x \/ l = loc_Exact <-> + e <= fexp (Zdigits beta m + e) \/ l = loc_Exact)%Z. +Proof. +intros x m e l Px Bx. +destruct Px as [Px|Px]. +- split ; (intros [H|H] ; [left|now right]). + rewrite <- cexp_inbetween_float with (1 := Px) (2 := Bx). + exact H. + now left. + rewrite cexp_inbetween_float with (1 := Px) (2 := Bx). + exact H. + now right. +- assert (H := Bx). + destruct Bx as [|c Bx _]. + now split ; right. + rewrite <- Px in Bx. + destruct Bx as [Bx1 Bx2]. + apply lt_0_F2R in Bx1. + apply gt_0_F2R in Bx2. + omega. +Qed. + (** Relates location and rounding. *) Theorem inbetween_float_round : forall rnd choice, ( forall x m l, inbetween_int m x l -> rnd x = choice m l ) -> forall x m l, - let e := canonic_exp beta fexp x in + let e := cexp beta fexp x in inbetween_float beta m e x l -> round beta fexp rnd x = F2R (Float beta (choice m l) e). Proof. intros rnd choice Hc x m l e Hl. unfold round, F2R. simpl. -apply (f_equal (fun m => (Z2R m * bpow e)%R)). +apply (f_equal (fun m => (IZR m * bpow e)%R)). apply Hc. apply inbetween_mult_reg with (bpow e). apply bpow_gt_0. @@ -61,12 +117,12 @@ Theorem inbetween_float_round_sign : ( forall x m l, inbetween_int m (Rabs x) l -> rnd x = cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m l) ) -> forall x m l, - let e := canonic_exp beta fexp x in + let e := cexp beta fexp x in inbetween_float beta m e (Rabs x) l -> round beta fexp rnd x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m l)) e). Proof. intros rnd choice Hc x m l e Hx. -apply (f_equal (fun m => (Z2R m * bpow e)%R)). +apply (f_equal (fun m => (IZR m * bpow e)%R)). simpl. replace (Rlt_bool x 0) with (Rlt_bool (scaled_mantissa beta fexp x) 0). (* *) @@ -99,13 +155,13 @@ Proof. intros x m l Hl. refine (Zfloor_imp m _ _). apply inbetween_bounds with (2 := Hl). -apply Z2R_lt. +apply IZR_lt. apply Zlt_succ. Qed. Theorem inbetween_float_DN : forall x m l, - let e := canonic_exp beta fexp x in + let e := cexp beta fexp x in inbetween_float beta m e x l -> round beta fexp Zfloor x = F2R (Float beta m e). Proof. @@ -131,23 +187,23 @@ destruct (Rcase_abs x) as [Zx|Zx] . rewrite Rlt_bool_true with (1 := Zx). inversion_clear Hl ; simpl. rewrite <- (Ropp_involutive x). -rewrite H, <- Z2R_opp. -apply Zfloor_Z2R. +rewrite H, <- opp_IZR. +apply Zfloor_IZR. apply Zfloor_imp. split. apply Rlt_le. -rewrite Z2R_opp. +rewrite opp_IZR. apply Ropp_lt_cancel. now rewrite Ropp_involutive. ring_simplify (- (m + 1) + 1)%Z. -rewrite Z2R_opp. +rewrite opp_IZR. apply Ropp_lt_cancel. now rewrite Ropp_involutive. (* *) rewrite Rlt_bool_false. inversion_clear Hl ; simpl. rewrite H. -apply Zfloor_Z2R. +apply Zfloor_IZR. apply Zfloor_imp. split. now apply Rlt_le. @@ -157,7 +213,7 @@ Qed. Theorem inbetween_float_DN_sign : forall x m l, - let e := canonic_exp beta fexp x in + let e := cexp beta fexp x in inbetween_float beta m e (Rabs x) l -> round beta fexp Zfloor x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (cond_incr (round_sign_DN (Rlt_bool x 0) l) m)) e). Proof. @@ -186,7 +242,7 @@ destruct Hl' as [Hl'|(Hl1, Hl2)]. rewrite Hl'. destruct Hl ; try easy. rewrite H. -exact (Zceil_Z2R _). +exact (Zceil_IZR _). (* not Exact *) rewrite Hl2. simpl. @@ -198,7 +254,7 @@ Qed. Theorem inbetween_float_UP : forall x m l, - let e := canonic_exp beta fexp x in + let e := cexp beta fexp x in inbetween_float beta m e x l -> round beta fexp Zceil x = F2R (Float beta (cond_incr (round_UP l) m) e). Proof. @@ -227,7 +283,7 @@ unfold Zceil. apply f_equal. inversion_clear Hl ; simpl. rewrite H. -apply Zfloor_Z2R. +apply Zfloor_IZR. apply Zfloor_imp. split. now apply Rlt_le. @@ -237,10 +293,10 @@ rewrite Rlt_bool_false. simpl. inversion_clear Hl ; simpl. rewrite H. -apply Zceil_Z2R. +apply Zceil_IZR. apply Zceil_imp. split. -change (m + 1 - 1)%Z with (Zpred (Zsucc m)). +change (m + 1 - 1)%Z with (Z.pred (Z.succ m)). now rewrite <- Zpred_succ. now apply Rlt_le. now apply Rge_le. @@ -248,7 +304,7 @@ Qed. Theorem inbetween_float_UP_sign : forall x m l, - let e := canonic_exp beta fexp x in + let e := cexp beta fexp x in inbetween_float beta m e (Rabs x) l -> round beta fexp Zceil x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (cond_incr (round_sign_UP (Rlt_bool x 0) l) m)) e). Proof. @@ -273,7 +329,7 @@ intros x m l Hl. inversion_clear Hl as [Hx|l' Hx Hl']. (* Exact *) rewrite Hx. -rewrite Zrnd_Z2R... +rewrite Zrnd_IZR... (* not Exact *) unfold Ztrunc. assert (Hm: Zfloor x = m). @@ -288,10 +344,10 @@ case Rlt_bool_spec ; intros Hx' ; elim Rlt_not_le with (1 := Hx'). apply Rlt_le. apply Rle_lt_trans with (2 := proj1 Hx). -now apply (Z2R_le 0). +now apply IZR_le. elim Rle_not_lt with (1 := Hx'). apply Rlt_le_trans with (1 := proj2 Hx). -apply (Z2R_le _ 0). +apply IZR_le. now apply Zlt_le_succ. rewrite Hm. now apply Rlt_not_eq. @@ -299,7 +355,7 @@ Qed. Theorem inbetween_float_ZR : forall x m l, - let e := canonic_exp beta fexp x in + let e := cexp beta fexp x in inbetween_float beta m e x l -> round beta fexp Ztrunc x = F2R (Float beta (cond_incr (round_ZR (Zlt_bool m 0) l) m) e). Proof. @@ -324,7 +380,7 @@ apply f_equal. apply Zfloor_imp. rewrite <- Rabs_left with (1 := Zx). apply inbetween_bounds with (2 := Hl). -apply Z2R_lt. +apply IZR_lt. apply Zlt_succ. (* *) rewrite Rlt_bool_false with (1 := Zx). @@ -332,13 +388,13 @@ simpl. apply Zfloor_imp. rewrite <- Rabs_pos_eq with (1 := Zx). apply inbetween_bounds with (2 := Hl). -apply Z2R_lt. +apply IZR_lt. apply Zlt_succ. Qed. Theorem inbetween_float_ZR_sign : forall x m l, - let e := canonic_exp beta fexp x in + let e := cexp beta fexp x in inbetween_float beta m e (Rabs x) l -> round beta fexp Ztrunc x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) m) e). Proof. @@ -365,7 +421,7 @@ intros choice x m l Hl. inversion_clear Hl as [Hx|l' Hx Hl']. (* Exact *) rewrite Hx. -rewrite Zrnd_Z2R... +rewrite Zrnd_IZR... (* not Exact *) unfold Znearest. assert (Hm: Zfloor x = m). @@ -373,13 +429,12 @@ apply Zfloor_imp. exact (conj (Rlt_le _ _ (proj1 Hx)) (proj2 Hx)). rewrite Zceil_floor_neq. rewrite Hm. -replace (Rcompare (x - Z2R m) (/2)) with l'. +replace (Rcompare (x - IZR m) (/2)) with l'. now case l'. rewrite <- Hl'. -rewrite Z2R_plus. -rewrite <- (Rcompare_plus_r (- Z2R m) x). +rewrite plus_IZR. +rewrite <- (Rcompare_plus_r (- IZR m) x). apply f_equal. -simpl (Z2R 1). field. rewrite Hm. now apply Rlt_not_eq. @@ -402,20 +457,19 @@ rewrite Znearest_opp. apply f_equal. inversion_clear Hl as [Hx|l' Hx Hl']. rewrite Hx. -apply Zrnd_Z2R... +apply Zrnd_IZR... assert (Hm: Zfloor (-x) = m). apply Zfloor_imp. exact (conj (Rlt_le _ _ (proj1 Hx)) (proj2 Hx)). unfold Znearest. rewrite Zceil_floor_neq. rewrite Hm. -replace (Rcompare (- x - Z2R m) (/2)) with l'. +replace (Rcompare (- x - IZR m) (/2)) with l'. now case l'. rewrite <- Hl'. -rewrite Z2R_plus. -rewrite <- (Rcompare_plus_r (- Z2R m) (-x)). +rewrite plus_IZR. +rewrite <- (Rcompare_plus_r (- IZR m) (-x)). apply f_equal. -simpl (Z2R 1). field. rewrite Hm. now apply Rlt_not_eq. @@ -426,20 +480,19 @@ rewrite Rlt_bool_false with (1 := Zx). simpl. inversion_clear Hl as [Hx|l' Hx Hl']. rewrite Hx. -apply Zrnd_Z2R... +apply Zrnd_IZR... assert (Hm: Zfloor x = m). apply Zfloor_imp. exact (conj (Rlt_le _ _ (proj1 Hx)) (proj2 Hx)). unfold Znearest. rewrite Zceil_floor_neq. rewrite Hm. -replace (Rcompare (x - Z2R m) (/2)) with l'. +replace (Rcompare (x - IZR m) (/2)) with l'. now case l'. rewrite <- Hl'. -rewrite Z2R_plus. -rewrite <- (Rcompare_plus_r (- Z2R m) x). +rewrite plus_IZR. +rewrite <- (Rcompare_plus_r (- IZR m) x). apply f_equal. -simpl (Z2R 1). field. rewrite Hm. now apply Rlt_not_eq. @@ -450,44 +503,44 @@ Qed. Theorem inbetween_int_NE : forall x m l, inbetween_int m x l -> - ZnearestE x = cond_incr (round_N (negb (Zeven m)) l) m. + ZnearestE x = cond_incr (round_N (negb (Z.even m)) l) m. Proof. intros x m l Hl. -now apply inbetween_int_N with (choice := fun x => negb (Zeven x)). +now apply inbetween_int_N with (choice := fun x => negb (Z.even x)). Qed. Theorem inbetween_float_NE : forall x m l, - let e := canonic_exp beta fexp x in + let e := cexp beta fexp x in inbetween_float beta m e x l -> - round beta fexp ZnearestE x = F2R (Float beta (cond_incr (round_N (negb (Zeven m)) l) m) e). + round beta fexp ZnearestE x = F2R (Float beta (cond_incr (round_N (negb (Z.even m)) l) m) e). Proof. -apply inbetween_float_round with (choice := fun m l => cond_incr (round_N (negb (Zeven m)) l) m). +apply inbetween_float_round with (choice := fun m l => cond_incr (round_N (negb (Z.even m)) l) m). exact inbetween_int_NE. Qed. Theorem inbetween_int_NE_sign : forall x m l, inbetween_int m (Rabs x) l -> - ZnearestE x = cond_Zopp (Rlt_bool x 0) (cond_incr (round_N (negb (Zeven m)) l) m). + ZnearestE x = cond_Zopp (Rlt_bool x 0) (cond_incr (round_N (negb (Z.even m)) l) m). Proof. intros x m l Hl. -erewrite inbetween_int_N_sign with (choice := fun x => negb (Zeven x)). +erewrite inbetween_int_N_sign with (choice := fun x => negb (Z.even x)). 2: eexact Hl. apply f_equal. case Rlt_bool. -rewrite Zeven_opp, Zeven_plus. -now case (Zeven m). +rewrite Z.even_opp, Z.even_add. +now case (Z.even m). apply refl_equal. Qed. Theorem inbetween_float_NE_sign : forall x m l, - let e := canonic_exp beta fexp x in + let e := cexp beta fexp x in inbetween_float beta m e (Rabs x) l -> - round beta fexp ZnearestE x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (cond_incr (round_N (negb (Zeven m)) l) m)) e). + round beta fexp ZnearestE x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (cond_incr (round_N (negb (Z.even m)) l) m)) e). Proof. -apply inbetween_float_round_sign with (choice := fun s m l => cond_incr (round_N (negb (Zeven m)) l) m). +apply inbetween_float_round_sign with (choice := fun s m l => cond_incr (round_N (negb (Z.even m)) l) m). exact inbetween_int_NE_sign. Qed. @@ -504,7 +557,7 @@ Qed. Theorem inbetween_float_NA : forall x m l, - let e := canonic_exp beta fexp x in + let e := cexp beta fexp x in inbetween_float beta m e x l -> round beta fexp ZnearestA x = F2R (Float beta (cond_incr (round_N (Zle_bool 0 m) l) m) e). Proof. @@ -523,11 +576,11 @@ erewrite inbetween_int_N_sign with (choice := Zle_bool 0). apply f_equal. assert (Hm: (0 <= m)%Z). apply Zlt_succ_le. -apply lt_Z2R. +apply lt_IZR. apply Rle_lt_trans with (Rabs x). apply Rabs_pos. refine (proj2 (inbetween_bounds _ _ _ _ _ Hl)). -apply Z2R_lt. +apply IZR_lt. apply Zlt_succ. rewrite Zle_bool_true with (1 := Hm). rewrite Zle_bool_false. @@ -538,7 +591,7 @@ Qed. Definition truncate_aux t k := let '(m, e, l) := t in let p := Zpower beta k in - (Zdiv m p, (e + k)%Z, new_location p (Zmod m p) l). + (Z.div m p, (e + k)%Z, new_location p (Zmod m p) l). Theorem truncate_aux_comp : forall t k1 k2, @@ -597,28 +650,28 @@ case Zlt_bool_spec ; intros Hk. unfold truncate_aux. apply generic_format_F2R. intros Hd. -unfold canonic_exp. -rewrite ln_beta_F2R_Zdigits with (1 := Hd). +unfold cexp. +rewrite mag_F2R_Zdigits with (1 := Hd). rewrite Zdigits_div_Zpower with (1 := Hm). replace (Zdigits beta m - k + (e + k))%Z with (Zdigits beta m + e)%Z by ring. unfold k. ring_simplify. -apply Zle_refl. +apply Z.le_refl. split. now apply Zlt_le_weak. apply Znot_gt_le. contradict Hd. apply Zdiv_small. apply conj with (1 := Hm). -rewrite <- Zabs_eq with (1 := Hm). +rewrite <- Z.abs_eq with (1 := Hm). apply Zpower_gt_Zdigits. apply Zlt_le_weak. -now apply Zgt_lt. +now apply Z.gt_lt. (* *) destruct (Zle_lt_or_eq _ _ Hm) as [Hm'|Hm']. apply generic_format_F2R. -unfold canonic_exp. -rewrite ln_beta_F2R_Zdigits. +unfold cexp. +rewrite mag_F2R_Zdigits. 2: now apply Zgt_not_eq. unfold k in Hk. clear -Hk. omega. @@ -633,26 +686,26 @@ Theorem truncate_correct_format : generic_format beta fexp x -> (e <= fexp (Zdigits beta m + e))%Z -> let '(m', e', l') := truncate (m, e, loc_Exact) in - x = F2R (Float beta m' e') /\ e' = canonic_exp beta fexp x. + x = F2R (Float beta m' e') /\ e' = cexp beta fexp x. Proof. intros m e Hm x Fx He. -assert (Hc: canonic_exp beta fexp x = fexp (Zdigits beta m + e)). -unfold canonic_exp, x. -now rewrite ln_beta_F2R_Zdigits. +assert (Hc: cexp beta fexp x = fexp (Zdigits beta m + e)). +unfold cexp, x. +now rewrite mag_F2R_Zdigits. unfold truncate. rewrite <- Hc. -set (k := (canonic_exp beta fexp x - e)%Z). +set (k := (cexp beta fexp x - e)%Z). case Zlt_bool_spec ; intros Hk. (* *) unfold truncate_aux. rewrite Fx at 1. -assert (H: (e + k)%Z = canonic_exp beta fexp x). +assert (H: (e + k)%Z = cexp beta fexp x). unfold k. ring. refine (conj _ H). rewrite <- H. -apply F2R_eq_compat. -replace (scaled_mantissa beta fexp x) with (Z2R (Zfloor (scaled_mantissa beta fexp x))). -rewrite Ztrunc_Z2R. +apply F2R_eq. +replace (scaled_mantissa beta fexp x) with (IZR (Zfloor (scaled_mantissa beta fexp x))). +rewrite Ztrunc_IZR. unfold scaled_mantissa. rewrite <- H. unfold x, F2R. simpl. @@ -666,7 +719,7 @@ intros H. generalize (Zpower_pos_gt_0 beta k) (Zle_bool_imp_le _ _ (radix_prop beta)). omega. rewrite scaled_mantissa_generic with (1 := Fx). -now rewrite Zfloor_Z2R. +now rewrite Zfloor_IZR. (* *) split. apply refl_equal. @@ -674,73 +727,111 @@ unfold k in Hk. omega. Qed. +Theorem truncate_correct_partial' : + forall x m e l, + (0 < x)%R -> + inbetween_float beta m e x l -> + (e <= cexp beta fexp x)%Z -> + let '(m', e', l') := truncate (m, e, l) in + inbetween_float beta m' e' x l' /\ e' = cexp beta fexp x. +Proof. +intros x m e l Hx H1 H2. +unfold truncate. +rewrite <- cexp_inbetween_float with (1 := Hx) (2 := H1) by now left. +generalize (Zlt_cases 0 (cexp beta fexp x - e)). +destruct Zlt_bool ; intros Hk. +- split. + now apply inbetween_float_new_location. + ring. +- apply (conj H1). + omega. +Qed. + Theorem truncate_correct_partial : forall x m e l, (0 < x)%R -> inbetween_float beta m e x l -> (e <= fexp (Zdigits beta m + e))%Z -> let '(m', e', l') := truncate (m, e, l) in - inbetween_float beta m' e' x l' /\ e' = canonic_exp beta fexp x. + inbetween_float beta m' e' x l' /\ e' = cexp beta fexp x. Proof. intros x m e l Hx H1 H2. -unfold truncate. -set (k := (fexp (Zdigits beta m + e) - e)%Z). -set (p := Zpower beta k). -(* *) -assert (Hx': (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R). -apply inbetween_float_bounds with (1 := H1). -(* *) -assert (Hm: (0 <= m)%Z). -cut (0 < m + 1)%Z. omega. -apply F2R_lt_reg with beta e. -rewrite F2R_0. -apply Rlt_trans with (1 := Hx). -apply Hx'. -assert (He: (e + k = canonic_exp beta fexp x)%Z). -(* . *) -unfold canonic_exp. -destruct (Zle_lt_or_eq _ _ Hm) as [Hm'|Hm']. -(* .. 0 < m *) -rewrite ln_beta_F2R_bounds with (1 := Hm') (2 := Hx'). -assert (H: m <> Z0). -apply sym_not_eq. -now apply Zlt_not_eq. -rewrite ln_beta_F2R with (1 := H). -rewrite <- Zdigits_ln_beta with (1 := H). -unfold k. -ring. -(* .. m = 0 *) -rewrite <- Hm' in H2. -destruct (ln_beta beta x) as (ex, Hex). -simpl. -specialize (Hex (Rgt_not_eq _ _ Hx)). -unfold k. -ring_simplify. -rewrite <- Hm'. -simpl. -apply sym_eq. -apply valid_exp. -exact H2. -apply Zle_trans with e. -eapply bpow_lt_bpow. -apply Rle_lt_trans with (1 := proj1 Hex). -rewrite Rabs_pos_eq. -rewrite <- F2R_bpow. -rewrite <- Hm' in Hx'. -apply Hx'. -now apply Rlt_le. +apply truncate_correct_partial' with (1 := Hx) (2 := H1). +rewrite cexp_inbetween_float with (1 := Hx) (2 := H1). exact H2. -(* . *) -generalize (Zlt_cases 0 k). -case (Zlt_bool 0 k) ; intros Hk ; unfold k in Hk. -split. -now apply inbetween_float_new_location. -exact He. -split. -exact H1. -rewrite <- He. -unfold k. -omega. +now right. +Qed. + +Theorem truncate_correct' : + forall x m e l, + (0 <= x)%R -> + inbetween_float beta m e x l -> + (e <= cexp beta fexp x)%Z \/ l = loc_Exact -> + let '(m', e', l') := truncate (m, e, l) in + inbetween_float beta m' e' x l' /\ + (e' = cexp beta fexp x \/ (l' = loc_Exact /\ format x)). +Proof. +intros x m e l [Hx|Hx] H1 H2. +- destruct (Zle_or_lt e (fexp (Zdigits beta m + e))) as [H3|H3]. + + generalize (truncate_correct_partial x m e l Hx H1 H3). + destruct (truncate (m, e, l)) as [[m' e'] l']. + intros [H4 H5]. + apply (conj H4). + now left. + + destruct H2 as [H2|H2]. + generalize (truncate_correct_partial' x m e l Hx H1 H2). + destruct (truncate (m, e, l)) as [[m' e'] l']. + intros [H4 H5]. + apply (conj H4). + now left. + rewrite H2 in H1 |- *. + simpl. + generalize (Zlt_cases 0 (fexp (Zdigits beta m + e) - e)). + destruct Zlt_bool. + intros H. + apply False_ind. + omega. + intros _. + apply (conj H1). + right. + repeat split. + inversion_clear H1. + rewrite H. + apply generic_format_F2R. + intros Zm. + unfold cexp. + rewrite mag_F2R_Zdigits with (1 := Zm). + now apply Zlt_le_weak. +- assert (Hm: m = 0%Z). + cut (m <= 0 < m + 1)%Z. omega. + assert (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R as Hx'. + apply inbetween_float_bounds with (1 := H1). + rewrite <- Hx in Hx'. + split. + apply le_0_F2R with (1 := proj1 Hx'). + apply gt_0_F2R with (1 := proj2 Hx'). + rewrite Hm, <- Hx in H1 |- *. + clear -H1. + destruct H1 as [_ | l' [H _] _]. + + assert (exists e', truncate (Z0, e, loc_Exact) = (Z0, e', loc_Exact)). + unfold truncate, truncate_aux. + case Zlt_bool. + rewrite Zdiv_0_l, Zmod_0_l. + eexists. + apply f_equal. + unfold new_location. + now case Z.even. + now eexists. + destruct H as [e' H]. + rewrite H. + split. + constructor. + apply eq_sym, F2R_0. + right. + repeat split. + apply generic_format_0. + + rewrite F2R_0 in H. + elim Rlt_irrefl with (1 := H). Qed. Theorem truncate_correct : @@ -750,78 +841,11 @@ Theorem truncate_correct : (e <= fexp (Zdigits beta m + e))%Z \/ l = loc_Exact -> let '(m', e', l') := truncate (m, e, l) in inbetween_float beta m' e' x l' /\ - (e' = canonic_exp beta fexp x \/ (l' = loc_Exact /\ format x)). + (e' = cexp beta fexp x \/ (l' = loc_Exact /\ format x)). Proof. -intros x m e l [Hx|Hx] H1 H2. -(* 0 < x *) -destruct (Zle_or_lt e (fexp (Zdigits beta m + e))) as [H3|H3]. -(* . enough digits *) -generalize (truncate_correct_partial x m e l Hx H1 H3). -destruct (truncate (m, e, l)) as ((m', e'), l'). -intros (H4, H5). -split. -exact H4. -now left. -(* . not enough digits but loc_Exact *) -destruct H2 as [H2|H2]. -elim (Zlt_irrefl e). -now apply Zle_lt_trans with (1 := H2). -rewrite H2 in H1 |- *. -unfold truncate. -generalize (Zlt_cases 0 (fexp (Zdigits beta m + e) - e)). -case Zlt_bool. -intros H. -apply False_ind. -omega. -intros _. -split. -exact H1. -right. -split. -apply refl_equal. -inversion_clear H1. -rewrite H. -apply generic_format_F2R. -intros Zm. -unfold canonic_exp. -rewrite ln_beta_F2R_Zdigits with (1 := Zm). -now apply Zlt_le_weak. -(* x = 0 *) -assert (Hm: m = Z0). -cut (m <= 0 < m + 1)%Z. omega. -assert (Hx': (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R). -apply inbetween_float_bounds with (1 := H1). -rewrite <- Hx in Hx'. -split. -apply F2R_le_0_reg with (1 := proj1 Hx'). -apply F2R_gt_0_reg with (1 := proj2 Hx'). -rewrite Hm, <- Hx in H1 |- *. -clear -H1. -case H1. -(* . *) -intros _. -assert (exists e', truncate (Z0, e, loc_Exact) = (Z0, e', loc_Exact)). -unfold truncate, truncate_aux. -case Zlt_bool. -rewrite Zdiv_0_l, Zmod_0_l. -eexists. -apply f_equal. -unfold new_location. -now case Zeven. -now eexists. -destruct H as (e', H). -rewrite H. -split. -constructor. -apply sym_eq. -apply F2R_0. -right. -repeat split. -apply generic_format_0. -(* . *) -intros l' (H, _) _. -rewrite F2R_0 in H. -elim Rlt_irrefl with (1 := H). +intros x m e l Hx H1 H2. +apply truncate_correct' with (1 := Hx) (2 := H1). +now apply cexp_inbetween_float_loc_Exact with (2 := H1). Qed. Section round_dir. @@ -838,7 +862,7 @@ Hypothesis inbetween_int_valid : Theorem round_any_correct : forall x m e l, inbetween_float beta m e x l -> - (e = canonic_exp beta fexp x \/ (l = loc_Exact /\ format x)) -> + (e = cexp beta fexp x \/ (l = loc_Exact /\ format x)) -> round beta fexp rnd x = F2R (Float beta (choice m l) e). Proof with auto with typeclass_instances. intros x m e l Hin [He|(Hl,Hf)]. @@ -851,7 +875,7 @@ rewrite Hl. replace (choice m loc_Exact) with m. rewrite <- H. apply round_generic... -rewrite <- (Zrnd_Z2R rnd m) at 1. +rewrite <- (Zrnd_IZR rnd m) at 1. apply inbetween_int_valid. now constructor. Qed. @@ -872,6 +896,20 @@ intros (H1, H2). now apply round_any_correct. Qed. +Theorem round_trunc_any_correct' : + forall x m e l, + (0 <= x)%R -> + inbetween_float beta m e x l -> + (e <= cexp beta fexp x)%Z \/ l = loc_Exact -> + round beta fexp rnd x = let '(m', e', l') := truncate (m, e, l) in F2R (Float beta (choice m' l') e'). +Proof. +intros x m e l Hx Hl He. +generalize (truncate_correct' x m e l Hx Hl He). +destruct (truncate (m, e, l)) as [[m' e'] l']. +intros [H1 H2]. +now apply round_any_correct. +Qed. + End round_dir. Section round_dir_sign. @@ -888,7 +926,7 @@ Hypothesis inbetween_int_valid : Theorem round_sign_any_correct : forall x m e l, inbetween_float beta m e (Rabs x) l -> - (e = canonic_exp beta fexp x \/ (l = loc_Exact /\ format x)) -> + (e = cexp beta fexp x \/ (l = loc_Exact /\ format x)) -> round beta fexp rnd x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m l)) e). Proof with auto with typeclass_instances. intros x m e l Hin [He|(Hl,Hf)]. @@ -915,14 +953,14 @@ now apply Rge_le. (* *) destruct (Rlt_bool_spec x 0) as [Zx|Zx]. (* . *) -apply Zopp_inj. +apply Z.opp_inj. change (- m = cond_Zopp true (choice true m loc_Exact))%Z. -rewrite <- (Zrnd_Z2R rnd (-m)) at 1. -assert (Z2R (-m) < 0)%R. -rewrite Z2R_opp. +rewrite <- (Zrnd_IZR rnd (-m)) at 1. +assert (IZR (-m) < 0)%R. +rewrite opp_IZR. apply Ropp_lt_gt_0_contravar. -apply (Z2R_lt 0). -apply F2R_gt_0_reg with beta e. +apply IZR_lt. +apply gt_0_F2R with beta e. rewrite <- H. apply Rabs_pos_lt. now apply Rlt_not_eq. @@ -930,14 +968,14 @@ rewrite <- Rlt_bool_true with (1 := H0). apply inbetween_int_valid. constructor. rewrite Rabs_left with (1 := H0). -rewrite Z2R_opp. +rewrite opp_IZR. apply Ropp_involutive. (* . *) change (m = cond_Zopp false (choice false m loc_Exact))%Z. -rewrite <- (Zrnd_Z2R rnd m) at 1. -assert (0 <= Z2R m)%R. -apply (Z2R_le 0). -apply F2R_ge_0_reg with beta e. +rewrite <- (Zrnd_IZR rnd m) at 1. +assert (0 <= IZR m)%R. +apply IZR_le. +apply ge_0_F2R with beta e. rewrite <- H. apply Rabs_pos. rewrite <- Rlt_bool_false with (1 := H0). @@ -948,29 +986,38 @@ Qed. (** Truncating a triple is sufficient to round a real number. *) -Theorem round_trunc_sign_any_correct : +Theorem round_trunc_sign_any_correct' : forall x m e l, inbetween_float beta m e (Rabs x) l -> - (e <= fexp (Zdigits beta m + e))%Z \/ l = loc_Exact -> + (e <= cexp beta fexp x)%Z \/ l = loc_Exact -> round beta fexp rnd x = let '(m', e', l') := truncate (m, e, l) in F2R (Float beta (cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m' l')) e'). Proof. intros x m e l Hl He. -generalize (truncate_correct (Rabs x) m e l (Rabs_pos _) Hl He). -destruct (truncate (m, e, l)) as ((m', e'), l'). -intros (H1, H2). +rewrite <- cexp_abs in He. +generalize (truncate_correct' (Rabs x) m e l (Rabs_pos _) Hl He). +destruct (truncate (m, e, l)) as [[m' e'] l']. +intros [H1 H2]. apply round_sign_any_correct. exact H1. -destruct H2 as [H2|(H2,H3)]. +destruct H2 as [H2|[H2 H3]]. left. -now rewrite <- canonic_exp_abs. +now rewrite <- cexp_abs. right. -split. -exact H2. -unfold Rabs in H3. -destruct (Rcase_abs x) in H3. -rewrite <- Ropp_involutive. -now apply generic_format_opp. -exact H3. +apply (conj H2). +now apply generic_format_abs_inv. +Qed. + +Theorem round_trunc_sign_any_correct : + forall x m e l, + inbetween_float beta m e (Rabs x) l -> + (e <= fexp (Zdigits beta m + e))%Z \/ l = loc_Exact -> + round beta fexp rnd x = let '(m', e', l') := truncate (m, e, l) in F2R (Float beta (cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m' l')) e'). +Proof. +intros x m e l Hl He. +apply round_trunc_sign_any_correct' with (1 := Hl). +rewrite <- cexp_abs. +apply cexp_inbetween_float_loc_Exact with (2 := Hl) (3 := He). +apply Rabs_pos. Qed. End round_dir_sign. @@ -983,47 +1030,71 @@ Definition round_DN_correct := Definition round_trunc_DN_correct := round_trunc_any_correct _ (fun m _ => m) inbetween_int_DN. +Definition round_trunc_DN_correct' := + round_trunc_any_correct' _ (fun m _ => m) inbetween_int_DN. + Definition round_sign_DN_correct := round_sign_any_correct _ (fun s m l => cond_incr (round_sign_DN s l) m) inbetween_int_DN_sign. Definition round_trunc_sign_DN_correct := round_trunc_sign_any_correct _ (fun s m l => cond_incr (round_sign_DN s l) m) inbetween_int_DN_sign. +Definition round_trunc_sign_DN_correct' := + round_trunc_sign_any_correct' _ (fun s m l => cond_incr (round_sign_DN s l) m) inbetween_int_DN_sign. + Definition round_UP_correct := round_any_correct _ (fun m l => cond_incr (round_UP l) m) inbetween_int_UP. Definition round_trunc_UP_correct := round_trunc_any_correct _ (fun m l => cond_incr (round_UP l) m) inbetween_int_UP. +Definition round_trunc_UP_correct' := + round_trunc_any_correct' _ (fun m l => cond_incr (round_UP l) m) inbetween_int_UP. + Definition round_sign_UP_correct := round_sign_any_correct _ (fun s m l => cond_incr (round_sign_UP s l) m) inbetween_int_UP_sign. Definition round_trunc_sign_UP_correct := round_trunc_sign_any_correct _ (fun s m l => cond_incr (round_sign_UP s l) m) inbetween_int_UP_sign. +Definition round_trunc_sign_UP_correct' := + round_trunc_sign_any_correct' _ (fun s m l => cond_incr (round_sign_UP s l) m) inbetween_int_UP_sign. + Definition round_ZR_correct := round_any_correct _ (fun m l => cond_incr (round_ZR (Zlt_bool m 0) l) m) inbetween_int_ZR. Definition round_trunc_ZR_correct := round_trunc_any_correct _ (fun m l => cond_incr (round_ZR (Zlt_bool m 0) l) m) inbetween_int_ZR. +Definition round_trunc_ZR_correct' := + round_trunc_any_correct' _ (fun m l => cond_incr (round_ZR (Zlt_bool m 0) l) m) inbetween_int_ZR. + Definition round_sign_ZR_correct := round_sign_any_correct _ (fun s m l => m) inbetween_int_ZR_sign. Definition round_trunc_sign_ZR_correct := round_trunc_sign_any_correct _ (fun s m l => m) inbetween_int_ZR_sign. +Definition round_trunc_sign_ZR_correct' := + round_trunc_sign_any_correct' _ (fun s m l => m) inbetween_int_ZR_sign. + Definition round_NE_correct := - round_any_correct _ (fun m l => cond_incr (round_N (negb (Zeven m)) l) m) inbetween_int_NE. + round_any_correct _ (fun m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE. Definition round_trunc_NE_correct := - round_trunc_any_correct _ (fun m l => cond_incr (round_N (negb (Zeven m)) l) m) inbetween_int_NE. + round_trunc_any_correct _ (fun m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE. + +Definition round_trunc_NE_correct' := + round_trunc_any_correct' _ (fun m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE. Definition round_sign_NE_correct := - round_sign_any_correct _ (fun s m l => cond_incr (round_N (negb (Zeven m)) l) m) inbetween_int_NE_sign. + round_sign_any_correct _ (fun s m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE_sign. Definition round_trunc_sign_NE_correct := - round_trunc_sign_any_correct _ (fun s m l => cond_incr (round_N (negb (Zeven m)) l) m) inbetween_int_NE_sign. + round_trunc_sign_any_correct _ (fun s m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE_sign. + +Definition round_trunc_sign_NE_correct' := + round_trunc_sign_any_correct' _ (fun s m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE_sign. Definition round_NA_correct := round_any_correct _ (fun m l => cond_incr (round_N (Zle_bool 0 m) l) m) inbetween_int_NA. @@ -1031,12 +1102,18 @@ Definition round_NA_correct := Definition round_trunc_NA_correct := round_trunc_any_correct _ (fun m l => cond_incr (round_N (Zle_bool 0 m) l) m) inbetween_int_NA. +Definition round_trunc_NA_correct' := + round_trunc_any_correct' _ (fun m l => cond_incr (round_N (Zle_bool 0 m) l) m) inbetween_int_NA. + Definition round_sign_NA_correct := round_sign_any_correct _ (fun s m l => cond_incr (round_N true l) m) inbetween_int_NA_sign. Definition round_trunc_sign_NA_correct := round_trunc_sign_any_correct _ (fun s m l => cond_incr (round_N true l) m) inbetween_int_NA_sign. +Definition round_trunc_sign_NA_correct' := + round_trunc_sign_any_correct' _ (fun s m l => cond_incr (round_N true l) m) inbetween_int_NA_sign. + End Fcalc_round_fexp. (** Specialization of truncate for FIX formats. *) @@ -1048,7 +1125,7 @@ Definition truncate_FIX t := let k := (emin - e)%Z in if Zlt_bool 0 k then let p := Zpower beta k in - (Zdiv m p, (e + k)%Z, new_location p (Zmod m p) l) + (Z.div m p, (e + k)%Z, new_location p (Zmod m p) l) else t. Theorem truncate_FIX_correct : @@ -1057,13 +1134,13 @@ Theorem truncate_FIX_correct : (e <= emin)%Z \/ l = loc_Exact -> let '(m', e', l') := truncate_FIX (m, e, l) in inbetween_float beta m' e' x l' /\ - (e' = canonic_exp beta (FIX_exp emin) x \/ (l' = loc_Exact /\ generic_format beta (FIX_exp emin) x)). + (e' = cexp beta (FIX_exp emin) x \/ (l' = loc_Exact /\ generic_format beta (FIX_exp emin) x)). Proof. intros x m e l H1 H2. unfold truncate_FIX. set (k := (emin - e)%Z). set (p := Zpower beta k). -unfold canonic_exp, FIX_exp. +unfold cexp, FIX_exp. generalize (Zlt_cases 0 k). case (Zlt_bool 0 k) ; intros Hk. (* shift *) @@ -1087,7 +1164,7 @@ rewrite H2 in H1. inversion_clear H1. rewrite H. apply generic_format_F2R. -unfold canonic_exp. +unfold cexp. omega. Qed. diff --git a/flocq/Calc/Sqrt.v b/flocq/Calc/Sqrt.v new file mode 100644 index 00000000..8843d21e --- /dev/null +++ b/flocq/Calc/Sqrt.v @@ -0,0 +1,201 @@ +(** +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 +#<br /># +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. +*) + +(** * Helper functions and theorems for computing the rounded square root of a floating-point number. *) + +Require Import Raux Defs Digits Generic_fmt Float_prop Bracket. + +Set Implicit Arguments. +Set Strongly Strict Implicit. + +Section Fcalc_sqrt. + +Variable beta : radix. +Notation bpow e := (bpow beta e). + +Variable fexp : Z -> Z. + +(** Computes a mantissa of precision p, the corresponding exponent, + and the position with respect to the real square root of the + input floating-point number. + +The algorithm performs the following steps: +- Shift the mantissa so that it has at least 2p-1 digits; + shift it one digit more if the new exponent is not even. +- Compute the square root s (at least p digits) of the new + mantissa, and its remainder r. +- Compute the position according to the remainder: + -- r == 0 => Eq, + -- r <= s => Lo, + -- r >= s => Up. + +Complexity is fine as long as p1 <= 2p-1. +*) + +Lemma mag_sqrt_F2R : + forall m1 e1, + (0 < m1)%Z -> + mag beta (sqrt (F2R (Float beta m1 e1))) = Z.div2 (Zdigits beta m1 + e1 + 1) :> Z. +Proof. +intros m1 e1 Hm1. +rewrite <- (mag_F2R_Zdigits beta m1 e1) by now apply Zgt_not_eq. +apply mag_sqrt. +now apply F2R_gt_0. +Qed. + +Definition Fsqrt_core m1 e1 e := + let d1 := Zdigits beta m1 in + let m1' := (m1 * Zpower beta (e1 - 2 * e))%Z in + let (q, r) := Z.sqrtrem m1' in + let l := + if Zeq_bool r 0 then loc_Exact + else loc_Inexact (if Zle_bool r q then Lt else Gt) in + (q, l). + +Theorem Fsqrt_core_correct : + forall m1 e1 e, + (0 < m1)%Z -> + (2 * e <= e1)%Z -> + let '(m, l) := Fsqrt_core m1 e1 e in + inbetween_float beta m e (sqrt (F2R (Float beta m1 e1))) l. +Proof. +intros m1 e1 e Hm1 He. +unfold Fsqrt_core. +set (m' := Zmult _ _). +assert (0 <= m')%Z as Hm'. +{ apply Z.mul_nonneg_nonneg. + now apply Zlt_le_weak. + apply Zpower_ge_0. } +assert (sqrt (F2R (Float beta m1 e1)) = sqrt (IZR m') * bpow e)%R as Hf. +{ rewrite <- (sqrt_Rsqr (bpow e)) by apply bpow_ge_0. + rewrite <- sqrt_mult. + unfold Rsqr, m'. + rewrite mult_IZR, IZR_Zpower by omega. + rewrite Rmult_assoc, <- 2!bpow_plus. + now replace (_ + _)%Z with e1 by ring. + now apply IZR_le. + apply Rle_0_sqr. } +generalize (Z.sqrtrem_spec m' Hm'). +destruct Z.sqrtrem as [q r]. +intros [Hq Hr]. +rewrite Hf. +unfold inbetween_float, F2R. simpl Fnum. +apply inbetween_mult_compat. +apply bpow_gt_0. +rewrite Hq. +case Zeq_bool_spec ; intros Hr'. +(* .. r = 0 *) +rewrite Hr', Zplus_0_r, mult_IZR. +fold (Rsqr (IZR q)). +rewrite sqrt_Rsqr. +now constructor. +apply IZR_le. +clear -Hr ; omega. +(* .. r <> 0 *) +constructor. +split. +(* ... bounds *) +apply Rle_lt_trans with (sqrt (IZR (q * q))). +rewrite mult_IZR. +fold (Rsqr (IZR q)). +rewrite sqrt_Rsqr. +apply Rle_refl. +apply IZR_le. +clear -Hr ; omega. +apply sqrt_lt_1. +rewrite mult_IZR. +apply Rle_0_sqr. +rewrite <- Hq. +now apply IZR_le. +apply IZR_lt. +omega. +apply Rlt_le_trans with (sqrt (IZR ((q + 1) * (q + 1)))). +apply sqrt_lt_1. +rewrite <- Hq. +now apply IZR_le. +rewrite mult_IZR. +apply Rle_0_sqr. +apply IZR_lt. +ring_simplify. +omega. +rewrite mult_IZR. +fold (Rsqr (IZR (q + 1))). +rewrite sqrt_Rsqr. +apply Rle_refl. +apply IZR_le. +clear -Hr ; omega. +(* ... location *) +rewrite Rcompare_half_r. +generalize (Rcompare_sqr (2 * sqrt (IZR (q * q + r))) (IZR q + IZR (q + 1))). +rewrite 2!Rabs_pos_eq. +intros <-. +replace ((2 * sqrt (IZR (q * q + r))) * (2 * sqrt (IZR (q * q + r))))%R + with (4 * Rsqr (sqrt (IZR (q * q + r))))%R by (unfold Rsqr ; ring). +rewrite Rsqr_sqrt. +rewrite <- plus_IZR, <- 2!mult_IZR. +rewrite Rcompare_IZR. +replace ((q + (q + 1)) * (q + (q + 1)))%Z with (4 * (q * q) + 4 * q + 1)%Z by ring. +generalize (Zle_cases r q). +case (Zle_bool r q) ; intros Hr''. +change (4 * (q * q + r) < 4 * (q * q) + 4 * q + 1)%Z. +omega. +change (4 * (q * q + r) > 4 * (q * q) + 4 * q + 1)%Z. +omega. +rewrite <- Hq. +now apply IZR_le. +rewrite <- plus_IZR. +apply IZR_le. +clear -Hr ; omega. +apply Rmult_le_pos. +now apply IZR_le. +apply sqrt_ge_0. +Qed. + +Definition Fsqrt (x : float beta) := + let (m1, e1) := x in + let e' := (Zdigits beta m1 + e1 + 1)%Z in + let e := Z.min (fexp (Z.div2 e')) (Z.div2 e1) in + let '(m, l) := Fsqrt_core m1 e1 e in + (m, e, l). + +Theorem Fsqrt_correct : + forall x, + (0 < F2R x)%R -> + let '(m, e, l) := Fsqrt x in + (e <= cexp beta fexp (sqrt (F2R x)))%Z /\ + inbetween_float beta m e (sqrt (F2R x)) l. +Proof. +intros [m1 e1] Hm1. +apply gt_0_F2R in Hm1. +unfold Fsqrt. +set (e := Z.min _ _). +assert (2 * e <= e1)%Z as He. +{ assert (e <= Z.div2 e1)%Z by apply Z.le_min_r. + rewrite (Zdiv2_odd_eqn e1). + destruct Z.odd ; omega. } +generalize (Fsqrt_core_correct m1 e1 e Hm1 He). +destruct Fsqrt_core as [m l]. +apply conj. +apply Z.le_trans with (1 := Z.le_min_l _ _). +unfold cexp. +rewrite (mag_sqrt_F2R m1 e1 Hm1). +apply Z.le_refl. +Qed. + +End Fcalc_sqrt. diff --git a/flocq/Core/Fcore.v b/flocq/Core/Core.v index 2a5a5f02..78a140e1 100644 --- a/flocq/Core/Fcore.v +++ b/flocq/Core/Core.v @@ -2,9 +2,9 @@ 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-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +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 @@ -18,13 +18,5 @@ 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. +Require Export Raux Defs Float_prop Round_pred Generic_fmt Round_NE. +Require Export FIX FLX FLT Ulp. diff --git a/flocq/Core/Fcore_defs.v b/flocq/Core/Defs.v index 01b868ab..f5c6f33b 100644 --- a/flocq/Core/Fcore_defs.v +++ b/flocq/Core/Defs.v @@ -2,9 +2,9 @@ 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) 2009-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +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 @@ -18,20 +18,20 @@ COPYING file for more details. *) (** * Basic definitions: float and rounding property *) -Require Import Fcore_Raux. +Require Import 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. +Arguments Fnum {beta}. +Arguments Fexp {beta}. Variable beta : radix. Definition F2R (f : float beta) := - (Z2R (Fnum f) * bpow beta (Fexp f))%R. + (IZR (Fnum f) * bpow beta (Fexp f))%R. (** Requirements on a rounding mode *) Definition round_pred_total (P : R -> R -> Prop) := @@ -46,9 +46,9 @@ Definition round_pred (P : R -> R -> Prop) := End Def. -Arguments Fnum {beta} f. -Arguments Fexp {beta} f. -Arguments F2R {beta} f. +Arguments Fnum {beta}. +Arguments Fexp {beta}. +Arguments F2R {beta}. Section RND. @@ -57,45 +57,27 @@ 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/Digits.v index 53743035..bed2e20a 100644 --- a/flocq/Core/Fcore_digits.v +++ b/flocq/Core/Digits.v @@ -2,9 +2,9 @@ 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-2018 Sylvie Boldo #<br /># -Copyright (C) 2011-2013 Guillaume Melquiond +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 @@ -17,9 +17,8 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the COPYING file for more details. *) -Require Import ZArith. -Require Import Zquot. -Require Import Fcore_Zaux. +Require Import ZArith Zquot. +Require Import Zaux. (** Number of bits (radix 2) of a positive integer. @@ -74,7 +73,7 @@ Qed. Theorem Zdigit_opp : forall n k, - Zdigit (-n) k = Zopp (Zdigit n k). + Zdigit (-n) k = Z.opp (Zdigit n k). Proof. intros n k. unfold Zdigit. @@ -89,11 +88,11 @@ Theorem Zdigit_ge_Zpower_pos : Proof. intros e n Hn k Hk. unfold Zdigit. -rewrite Zquot_small. +rewrite Z.quot_small. apply Zrem_0_l. split. apply Hn. -apply Zlt_le_trans with (1 := proj2 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. @@ -102,8 +101,8 @@ 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)). +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. @@ -111,7 +110,7 @@ Qed. Theorem Zdigit_ge_Zpower : forall e n, - (Zabs n < Zpower beta e)%Z -> + (Z.abs n < Zpower beta e)%Z -> forall k, (e <= k)%Z -> Zdigit n k = Z0. Proof. intros e [|n|n] Hn k. @@ -119,10 +118,10 @@ easy. apply Zdigit_ge_Zpower_pos. now split. intros He. -change (Zneg n) with (Zopp (Zpos n)). +change (Zneg n) with (Z.opp (Zpos n)). rewrite Zdigit_opp. rewrite Zdigit_ge_Zpower_pos with (2 := He). -apply Zopp_0. +apply Z.opp_0. now split. Qed. @@ -134,17 +133,17 @@ Proof. intros e n He (Hn1,Hn2). unfold Zdigit. rewrite <- ZOdiv_mod_mult. -rewrite Zrem_small. +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 Zle_trans with (2 := Hn1). +apply Z.le_trans with (2 := Hn1). apply Zpower_ge_0. now apply Zpower_gt_0. split. -apply Zle_trans with (2 := Hn1). +apply Z.le_trans with (2 := Hn1). apply Zpower_ge_0. replace (beta ^ e * beta)%Z with (beta ^ (e + 1))%Z. exact Hn2. @@ -154,12 +153,12 @@ Qed. Theorem Zdigit_not_0 : forall e n, (0 <= e)%Z -> - (Zpower beta e <= Zabs n < Zpower beta (e + 1))%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 (Zabs_eq _ Hn') in 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. @@ -245,8 +244,8 @@ 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 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. @@ -266,7 +265,7 @@ Proof. intros n. induction k. apply sym_eq. -apply Zrem_1_r. +apply Z.rem_1_r. simpl Zsum_digit. rewrite IHk. unfold Zdigit. @@ -284,65 +283,35 @@ 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 <- (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 (Zabs_nat (Zmax (Zabs n1) (Zabs n2))). +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 Zabs_eq. -apply Zle_trans with (Zabs n1). +apply Z.abs_eq. +apply Z.le_trans with (Z.abs n1). apply Zabs_pos. -apply Zle_max_l. -apply Zlt_le_trans with (Zpower beta (Zabs n2)). +apply Z.le_max_l. +apply Z.lt_le_trans with (Zpower beta (Z.abs n2)). apply Zpower_gt_id. apply Zpower_le. -apply Zle_max_r. -apply Zlt_le_trans with (Zpower beta (Zabs n1)). +apply Z.le_max_r. +apply Z.lt_le_trans with (Zpower beta (Z.abs n1)). apply Zpower_gt_id. apply Zpower_le. -apply Zle_max_l. +apply Z.le_max_l. Qed. Theorem ZOmod_plus_pow_digit : @@ -354,11 +323,11 @@ 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). +generalize (Z.le_refl n). +pattern n at -2 ; rewrite <- Z.abs_eq with (1 := Hn). rewrite <- (inj_Zabs_nat n). -induction (Zabs_nat n) as [|p IHp]. -now rewrite 2!Zrem_1_r. +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. @@ -367,39 +336,39 @@ 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 (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 (Zabs_eq (beta ^ Z_of_nat p)) by apply Zpower_ge_0. +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, Zabs (Zdigit u v) < Zsucc (beta - 1))%Z. +assert (forall u v, Z.abs (Zdigit u v) < Z.succ (beta - 1))%Z. clear ; intros n k. assert (0 < beta)%Z. -apply Zlt_le_trans with 2%Z. +apply Z.lt_le_trans with 2%Z. apply refl_equal. apply Zle_bool_imp_le. apply beta. -replace (Zsucc (beta - 1)) with (Zabs beta). +replace (Z.succ (beta - 1)) with (Z.abs beta). apply Zrem_lt. now apply Zgt_not_eq. -rewrite Zabs_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 Zgt_lt. +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 Zsucc. +unfold Z.succ. ring_simplify. rewrite Zpower_plus. change (beta ^1)%Z with (beta * 1)%Z. @@ -422,7 +391,7 @@ 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. +rewrite <- Z.abs_eq. apply Zrem_lt. apply Zgt_not_eq. now apply Zpower_gt_0. @@ -562,7 +531,7 @@ 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. +now rewrite Z.opp_involutive, Zplus_comm. omega. Qed. @@ -608,13 +577,13 @@ 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'). + 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 (Zmin (k2 - k1') k2') k) as [Hk'|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. @@ -627,7 +596,7 @@ rewrite Zdigit_slice. now rewrite Zplus_assoc. zify ; omega. unfold Zslice. -rewrite Zmin_r. +rewrite Z.min_r. now rewrite Zle_bool_false. omega. Qed. @@ -659,11 +628,11 @@ 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. +now rewrite Z.quot_1_r. +rewrite Z.opp_involutive. apply Zmult_1_r. rewrite Zle_bool_false by omega. -rewrite 2!Zopp_involutive, Zplus_comm. +rewrite 2!Z.opp_involutive, Zplus_comm. rewrite Zpower_plus by assumption. apply Zquot_Zquot. Qed. @@ -689,7 +658,7 @@ apply Zdigit_ext. intros k' Hk'. rewrite Zdigit_scale with (1 := Hk'). unfold Zminus. -rewrite (Zplus_comm k'), Zopp_involutive. +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. @@ -770,7 +739,7 @@ Definition Zdigits n := Theorem Zdigits_correct : forall n, - (Zpower beta (Zdigits n - 1) <= Zabs n < Zpower beta (Zdigits n))%Z. + (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). @@ -779,7 +748,7 @@ 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)). +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)). @@ -797,7 +766,7 @@ apply Zle_0_nat. (* *) revert U. rewrite inj_S. -unfold Zsucc. +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. @@ -805,12 +774,12 @@ 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 (Z.le_refl 1). generalize 1%Z at 2 3 5 6 7 9 10. (* *) induction u. easy. -rewrite inj_S; unfold Zsucc. +rewrite inj_S; unfold Z.succ. simpl Zdigits_aux. intros v Hv U. case Zlt_bool_spec ; intros K. @@ -829,20 +798,20 @@ Qed. Theorem Zdigits_unique : forall n d, - (Zpower beta (d - 1) <= Zabs n < Zpower beta d)%Z -> + (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 Zle_lt_trans with (Zabs n). +now apply Z.le_lt_trans with (Z.abs n). apply (Zpower_lt_Zpower beta). -now apply Zle_lt_trans with (Zabs n). +now apply Z.le_lt_trans with (Z.abs n). Qed. Theorem Zdigits_abs : - forall n, Zdigits (Zabs n) = Zdigits n. + forall n, Zdigits (Z.abs n) = Zdigits n. Proof. now intros [|n|n]. Qed. @@ -852,10 +821,10 @@ Theorem Zdigits_gt_0 : Proof. intros n Zn. rewrite <- (Zdigits_abs n). -assert (Hn: (0 < Zabs n)%Z). +assert (Hn: (0 < Z.abs n)%Z). destruct n ; [|easy|easy]. now elim Zn. -destruct (Zabs n) as [|p|p] ; try easy ; clear. +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). @@ -872,7 +841,7 @@ Theorem Zdigits_ge_0 : forall n, (0 <= Zdigits n)%Z. Proof. intros n. -destruct (Z_eq_dec n 0) as [H|H]. +destruct (Z.eq_dec n 0) as [H|H]. now rewrite H. apply Zlt_le_weak. now apply Zdigits_gt_0. @@ -908,8 +877,8 @@ 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 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. @@ -923,7 +892,7 @@ Proof. intros m e Hm He. assert (H := Zdigits_correct m). apply Zdigits_unique. -rewrite Z.abs_mul, Z.abs_pow, (Zabs_eq beta). +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. @@ -976,18 +945,18 @@ Qed. Theorem Zpower_le_Zdigits : forall e x, (e < Zdigits x)%Z -> - (Zpower beta e <= Zabs x)%Z. + (Zpower beta e <= Z.abs x)%Z. Proof. intros e x Hex. destruct (Zdigits_correct x) as [H1 H2]. -apply Zle_trans with (2 := H1). +apply Z.le_trans with (2 := H1). apply Zpower_le. clear -Hex ; omega. Qed. Theorem Zdigits_le_Zpower : forall e x, - (Zabs x < Zpower beta e)%Z -> + (Z.abs x < Zpower beta e)%Z -> (Zdigits x <= e)%Z. Proof. intros e x. @@ -998,17 +967,17 @@ Qed. Theorem Zpower_gt_Zdigits : forall e x, (Zdigits x <= e)%Z -> - (Zabs x < Zpower beta e)%Z. + (Z.abs x < Zpower beta e)%Z. Proof. intros e x Hex. destruct (Zdigits_correct x) as [H1 H2]. -apply Zlt_le_trans with (1 := H2). +apply Z.lt_le_trans with (1 := H2). now apply Zpower_le. Qed. Theorem Zdigits_gt_Zpower : forall e x, - (Zpower beta e <= Zabs x)%Z -> + (Zpower beta e <= Z.abs x)%Z -> (e < Zdigits x)%Z. Proof. intros e x Hex. @@ -1029,17 +998,17 @@ Theorem Zdigits_mult_strong : Proof. intros x y Hx Hy. apply Zdigits_le_Zpower. -rewrite Zabs_eq. -apply Zlt_le_trans with ((x + 1) * (y + 1))%Z. +rewrite Z.abs_eq. +apply Z.lt_le_trans with ((x + 1) * (y + 1))%Z. ring_simplify. -apply Zle_lt_succ, Zle_refl. +apply Zle_lt_succ, Z.le_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. +rewrite <- (Z.abs_eq x) at 1 by easy. apply Zdigits_correct. apply Zlt_le_succ. -rewrite <- (Zabs_eq y) at 1 by easy. +rewrite <- (Z.abs_eq y) at 1 by easy. apply Zdigits_correct. clear -Hx ; omega. clear -Hy ; omega. @@ -1057,7 +1026,7 @@ 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 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. @@ -1097,28 +1066,28 @@ 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. + rewrite Z.abs_eq in H by easy. destruct H as [H1 H2]. - rewrite Zabs_eq. + 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 Zlt_gt, Zpower_gt_0. + now apply Z.lt_gt, Zpower_gt_0. apply Zmult_lt_reg_r with (Zpower beta e). now apply Zpower_gt_0. - apply Zle_lt_trans with m. + apply Z.le_lt_trans with m. rewrite Zmult_comm. apply Z_mult_div_ge. - now apply Zlt_gt, Zpower_gt_0. + 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 Zlt_gt, Zpower_gt_0. + now apply Z.lt_gt, Zpower_gt_0. rewrite He'. rewrite (Zeq_minus _ (Zdigits m)) by reflexivity. simpl. @@ -1126,7 +1095,7 @@ rewrite Zdiv_small. easy. split. exact Hm. -now rewrite <- (Zabs_eq m) at 1. +now rewrite <- (Z.abs_eq m) at 1. Qed. End Fcore_digits. @@ -1143,7 +1112,7 @@ 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)))). +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. @@ -1152,8 +1121,8 @@ Qed. Fixpoint digits2_pos (n : positive) : positive := match n with | xH => xH - | xO p => Psucc (digits2_pos p) - | xI p => Psucc (digits2_pos p) + | xO p => Pos.succ (digits2_pos p) + | xI p => Pos.succ (digits2_pos p) end. Theorem Zpos_digits2_pos : diff --git a/flocq/Core/Fcore_FIX.v b/flocq/Core/FIX.v index e224a64a..4e0a25e6 100644 --- a/flocq/Core/Fcore_FIX.v +++ b/flocq/Core/FIX.v @@ -2,9 +2,9 @@ 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) 2009-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +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 @@ -18,12 +18,7 @@ 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. +Require Import Raux Defs Round_pred Generic_fmt Ulp Round_NE. Section RND_FIX. @@ -33,10 +28,9 @@ 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. +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. @@ -49,16 +43,16 @@ unfold FIX_exp. split ; intros H. now apply Zlt_le_weak. split. -apply Zle_refl. +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)). +intros x [[xm xe] Hx1 Hx2]. rewrite Hx1. -now apply generic_format_canonic. +now apply generic_format_canonical. Qed. Theorem FIX_format_generic : @@ -82,10 +76,11 @@ Qed. Global Instance FIX_exp_monotone : Monotone_exp FIX_exp. Proof. intros ex ey H. -apply Zle_refl. +apply Z.le_refl. Qed. -Theorem ulp_FIX: forall x, ulp beta FIX_exp x = bpow emin. +Theorem ulp_FIX : + forall x, ulp beta FIX_exp x = bpow emin. Proof. intros x; unfold ulp. case Req_bool_spec; intros Zx. @@ -96,5 +91,4 @@ intros n _; reflexivity. reflexivity. Qed. - End RND_FIX. diff --git a/flocq/Core/Fcore_FLT.v b/flocq/Core/FLT.v index 2258b1d9..bd48d4b7 100644 --- a/flocq/Core/Fcore_FLT.v +++ b/flocq/Core/FLT.v @@ -2,9 +2,9 @@ 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) 2009-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +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 @@ -18,15 +18,9 @@ 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. +Require Import Raux Defs Round_pred Generic_fmt Float_prop. +Require Import FLX FIX Ulp Round_NE. +Require Import Psatz. Section RND_FLT. @@ -38,12 +32,12 @@ 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. +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 := Zmax (e - prec) emin. +Definition FLT_exp e := Z.max (e - prec) emin. (** Properties of the FLT format *) Global Instance FLT_exp_valid : Valid_exp FLT_exp. @@ -59,17 +53,17 @@ 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))). +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). +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 ln_beta_le_Zpower. +now apply mag_le_Zpower. Qed. Theorem FLT_format_generic : @@ -77,32 +71,32 @@ Theorem FLT_format_generic : Proof. intros x. unfold generic_format. -set (ex := canonic_exp beta FLT_exp x). +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_Z2R. -rewrite Z2R_Zpower. 2: now apply Zlt_le_weak. +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 (Zabs mx) ex) < bpow (prec + ex))%R. +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 canonic_exp in ex. -destruct (ln_beta beta x) as (ex', He). +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 Zle_max_l. -apply Zle_max_r. +apply Z.le_max_l. +apply Z.le_max_r. Qed. @@ -128,18 +122,18 @@ apply FLT_format_generic. apply generic_format_FLT. Qed. -Theorem canonic_exp_FLT_FLX : +Theorem cexp_FLT_FLX : forall x, (bpow (emin + prec - 1) <= Rabs x)%R -> - canonic_exp beta FLT_exp x = canonic_exp beta (FLX_exp prec) x. + 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 canonic_exp. +unfold cexp. apply Zmax_left. -destruct (ln_beta beta x) as (ex, He). +destruct (mag beta x) as (ex, He). unfold FLX_exp. simpl. specialize (He Hx0). cut (emin + prec - 1 < ex)%Z. omega. @@ -160,7 +154,7 @@ 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. +now rewrite cexp_FLT_FLX. Qed. Theorem generic_format_FLX_FLT : @@ -173,29 +167,30 @@ 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. +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 canonic_exp_FLT_FLX ; trivial. +rewrite cexp_FLT_FLX ; trivial. Qed. (** Links between FLT and FIX (underflow) *) -Theorem canonic_exp_FLT_FIX : +Theorem cexp_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. + cexp beta FLT_exp x = cexp beta (FIX_exp emin) x. Proof. intros x Hx0 Hx. -unfold canonic_exp. +unfold cexp. apply Zmax_right. unfold FIX_exp. -destruct (ln_beta beta x) as (ex, Hex). +destruct (mag beta x) as (ex, Hex). simpl. cut (ex - 1 < emin + prec)%Z. omega. apply (lt_bpow beta). @@ -214,7 +209,7 @@ rewrite Hx. apply generic_format_F2R. intros _. rewrite <- Hx. -apply Zle_max_r. +apply Z.le_max_r. Qed. Theorem generic_format_FLT_FIX : @@ -226,9 +221,37 @@ Proof with auto with typeclass_instances. apply generic_inclusion_le... intros e He. unfold FIX_exp. -apply Zmax_lub. +apply Z.max_lub. omega. -apply Zle_refl. +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 -> @@ -240,7 +263,7 @@ unfold ulp; case Req_bool_spec; intros Hx2. 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. +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. @@ -248,10 +271,10 @@ intros n H2; rewrite <-V. apply f_equal, fexp_negligible_exp_eq... omega. (* x <> 0 *) -apply f_equal; unfold canonic_exp, FLT_exp. +apply f_equal; unfold cexp, 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. +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. @@ -266,8 +289,8 @@ 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). +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. @@ -289,17 +312,68 @@ 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. +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_ln_beta_gt. +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. @@ -310,7 +384,7 @@ zify ; omega. Qed. (** and it allows a rounding to nearest, ties to even. *) -Hypothesis NE_prop : Zeven beta = false \/ (1 < prec)%Z. +Hypothesis NE_prop : Z.even beta = false \/ (1 < prec)%Z. Global Instance exists_NE_FLT : Exists_NE beta FLT_exp. Proof. 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 +#<br /># +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/Fcore_FTZ.v b/flocq/Core/FTZ.v index a2fab00b..1a93bcd9 100644 --- a/flocq/Core/Fcore_FTZ.v +++ b/flocq/Core/FTZ.v @@ -2,9 +2,9 @@ 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) 2009-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +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 @@ -18,13 +18,8 @@ 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. +Require Import Raux Defs Round_pred Generic_fmt. +Require Import Float_prop Ulp FLX. Section RND_FTZ. @@ -36,11 +31,12 @@ 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. +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. @@ -73,9 +69,10 @@ Qed. Theorem FLXN_format_FTZ : forall x, FTZ_format x -> FLXN_format beta prec x. Proof. -intros x ((xm, xe), (Hx1, (Hx2, Hx3))). +intros x [[xm xe] Hx1 Hx2 Hx3]. eexists. -apply (conj Hx1 Hx2). +exact Hx1. +exact Hx2. Qed. Theorem generic_format_FTZ : @@ -83,9 +80,9 @@ Theorem generic_format_FTZ : Proof. intros x Hx. cut (generic_format beta (FLX_exp prec) x). -apply generic_inclusion_ln_beta. +apply generic_inclusion_mag. intros Zx. -destruct Hx as ((xm, xe), (Hx1, (Hx2, Hx3))). +destruct Hx as [[xm xe] Hx1 Hx2 Hx3]. simpl in Hx2, Hx3. specialize (Hx2 Zx). assert (Zxm: xm <> Z0). @@ -94,11 +91,11 @@ 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. +apply Z.le_refl. +rewrite Hx1, mag_F2R with (1 := Zxm). +cut (prec - 1 < mag beta (IZR xm))%Z. clear -Hx3 ; omega. -apply ln_beta_gt_Zpower with (1 := Zxm). +apply mag_gt_Zpower with (1 := Zxm). apply Hx2. apply generic_format_FLXN. now apply FLXN_format_FTZ. @@ -108,17 +105,14 @@ 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]. +destruct (Req_dec x 0) as [->|Hx3]. exists (Float beta 0 emin). -split. -unfold F2R. simpl. -now rewrite Rmult_0_l. -split. +apply sym_eq, F2R_0. 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). +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. @@ -129,43 +123,43 @@ rewrite Hx2, <- F2R_Zabs. rewrite <- (Rmult_1_l (bpow ex)). unfold F2R. simpl. apply Rmult_le_compat. -now apply (Z2R_le 0 1). +now apply IZR_le. apply bpow_ge_0. -apply (Z2R_le 1). +apply IZR_le. apply (Zlt_le_succ 0). -apply lt_Z2R. +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 (Zabs (Ztrunc (x * bpow (- (emin + prec - 1))))) (emin + prec - 1)))%R. +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_Z2R. -rewrite Z2R_Zpower. +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 (Zabs (Ztrunc (x * bpow (- (ex - prec))))) (ex - prec)))%R. +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_Z2R. -rewrite Z2R_Zpower. +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 (Zabs (Ztrunc (x * bpow (- (ex - prec))))) (ex - prec)) < bpow ex)%R. +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 Zge_le. +now apply Z.ge_le. Qed. Theorem FTZ_format_satisfies_any : @@ -191,11 +185,12 @@ apply generic_inclusion_ge. intros e He. unfold FTZ_exp. rewrite Zlt_bool_false. -apply Zle_refl. +apply Z.le_refl. omega. Qed. -Theorem ulp_FTZ_0: ulp beta FTZ_exp 0 = bpow (emin+prec-1). +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). @@ -230,9 +225,9 @@ case Rle_bool_spec ; intros Hx ; 4: easy. (* 1 <= |x| *) now apply Zrnd_le. -rewrite <- (Zrnd_Z2R rnd 0). +rewrite <- (Zrnd_IZR rnd 0). apply Zrnd_le... -apply Rle_trans with (Z2R (-1)). 2: now apply Z2R_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). @@ -240,10 +235,10 @@ apply Rle_lt_trans with (2 := Hy). apply Rle_trans with (1 := Hxy). apply RRle_abs. (* |x| < 1 *) -rewrite <- (Zrnd_Z2R rnd 0). +rewrite <- (Zrnd_IZR rnd 0). apply Zrnd_le... -apply Rle_trans with (Z2R 1). -now apply Z2R_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). @@ -252,12 +247,12 @@ exact Hy1. (* *) intros n. unfold Zrnd_FTZ. -rewrite Zrnd_Z2R... +rewrite Zrnd_IZR... case Rle_bool_spec. easy. -rewrite <- Z2R_abs. +rewrite <- abs_IZR. intros H. -generalize (lt_Z2R _ 1 H). +generalize (lt_IZR _ 1 H). clear. now case n ; trivial ; simpl ; intros [p|p|]. Qed. @@ -268,8 +263,8 @@ Theorem round_FTZ_FLX : 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. +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). @@ -306,14 +301,14 @@ Qed. Theorem round_FTZ_small : forall x : R, (Rabs x < bpow (emin + prec - 1))%R -> - round beta FTZ_exp Zrnd_FTZ x = R0. + 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, canonic_exp. -destruct (ln_beta beta x) as (ex, He). simpl. +unfold round, scaled_mantissa, cexp. +destruct (mag beta x) as (ex, He). simpl. specialize (He Hx0). unfold Zrnd_FTZ. rewrite Rle_bool_false. @@ -331,7 +326,7 @@ unfold FTZ_exp. generalize (Zlt_cases (ex - prec) emin). case Zlt_bool. intros _. -apply Zle_refl. +apply Z.le_refl. intros He'. elim Rlt_not_le with (1 := Hx). apply Rle_trans with (2 := proj1 He). 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 -#<br /># -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_float_prop.v b/flocq/Core/Float_prop.v index a183bf0a..804dd397 100644 --- a/flocq/Core/Fcore_float_prop.v +++ b/flocq/Core/Float_prop.v @@ -2,9 +2,9 @@ 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) 2009-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +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 @@ -18,40 +18,38 @@ COPYING file for more details. *) (** * Basic properties of floating-point formats: lemmas about mantissa, exponent... *) -Require Import Fcore_Raux. -Require Import Fcore_defs. +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)) = Zcompare m1 m2. + 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_Z2R. +apply Rcompare_IZR. apply bpow_gt_0. Qed. (** Basic facts *) -Theorem F2R_le_reg : +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_Z2R. +apply le_IZR. apply Rmult_le_reg_r with (bpow e). apply bpow_gt_0. exact H. Qed. -Theorem F2R_le_compat : +Theorem F2R_le : forall m1 m2 e : Z, (m1 <= m2)%Z -> (F2R (Float beta m1 e) <= F2R (Float beta m2 e))%R. @@ -60,22 +58,22 @@ intros m1 m2 e H. unfold F2R. simpl. apply Rmult_le_compat_r. apply bpow_ge_0. -now apply Z2R_le. +now apply IZR_le. Qed. -Theorem F2R_lt_reg : +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_Z2R. +apply lt_IZR. apply Rmult_lt_reg_r with (bpow e). apply bpow_gt_0. exact H. Qed. -Theorem F2R_lt_compat : +Theorem F2R_lt : forall e m1 m2 : Z, (m1 < m2)%Z -> (F2R (Float beta m1 e) < F2R (Float beta m2 e))%R. @@ -84,10 +82,10 @@ intros e m1 m2 H. unfold F2R. simpl. apply Rmult_lt_compat_r. apply bpow_gt_0. -now apply Z2R_lt. +now apply IZR_lt. Qed. -Theorem F2R_eq_compat : +Theorem F2R_eq : forall e m1 m2 : Z, (m1 = m2)%Z -> (F2R (Float beta m1 e) = F2R (Float beta m2 e))%R. @@ -96,26 +94,26 @@ intros e m1 m2 H. now apply (f_equal (fun m => F2R (Float beta m e))). Qed. -Theorem F2R_eq_reg : +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 F2R_le_reg with e ; + apply le_F2R 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)). + F2R (Float beta (Z.abs m) e) = Rabs (F2R (Float beta m e)). Proof. intros m e. unfold F2R. rewrite Rabs_mult. -rewrite <- Z2R_abs. +rewrite <- abs_IZR. simpl. apply f_equal. apply sym_eq; apply Rabs_right. @@ -125,12 +123,21 @@ Qed. Theorem F2R_Zopp : forall m e : Z, - F2R (Float beta (Zopp m) e) = Ropp (F2R (Float beta m e)). + 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 Z2R_opp. +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 *) @@ -143,125 +150,125 @@ unfold F2R. simpl. apply Rmult_0_l. Qed. -Theorem F2R_eq_0_reg : +Theorem eq_0_F2R : forall m e : Z, F2R (Float beta m e) = 0%R -> m = Z0. Proof. intros m e H. -apply F2R_eq_reg with e. +apply eq_F2R with e. now rewrite F2R_0. Qed. -Theorem F2R_ge_0_reg : +Theorem ge_0_F2R : 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. +apply le_F2R with e. now rewrite F2R_0. Qed. -Theorem F2R_le_0_reg : +Theorem le_0_F2R : 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. +apply le_F2R with e. now rewrite F2R_0. Qed. -Theorem F2R_gt_0_reg : +Theorem gt_0_F2R : 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. +apply lt_F2R with e. now rewrite F2R_0. Qed. -Theorem F2R_lt_0_reg : +Theorem lt_0_F2R : 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. +apply lt_F2R with e. now rewrite F2R_0. Qed. -Theorem F2R_ge_0_compat : +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_compat. +now apply F2R_le. Qed. -Theorem F2R_le_0_compat : +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_compat. +now apply F2R_le. Qed. -Theorem F2R_gt_0_compat : +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_compat. +now apply F2R_lt. Qed. -Theorem F2R_lt_0_compat : +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_compat. +now apply F2R_lt. Qed. -Theorem F2R_neq_0_compat : +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 F2R_eq_0_reg with (Fexp f). +now apply eq_0_F2R with (Fexp f). Qed. -Lemma Fnum_ge_0_compat: forall (f : float beta), +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_compat. +now apply F2R_lt_0. Qed. -Lemma Fnum_le_0_compat: forall (f : float beta), +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_compat. +now apply F2R_gt_0. Qed. (** Floats and bpow *) @@ -281,7 +288,7 @@ Theorem bpow_le_F2R : Proof. intros m e H. rewrite <- F2R_bpow. -apply F2R_le_compat. +apply F2R_le. now apply (Zlt_le_succ 0). Qed. @@ -301,7 +308,7 @@ unfold F2R. simpl. rewrite <- (Rmult_1_l (bpow e1)) at 1. apply Rmult_le_compat_r. apply bpow_ge_0. -apply (Z2R_le 1). +apply IZR_le. now apply (Zlt_le_succ 0). now apply Rlt_le. (* . *) @@ -309,14 +316,14 @@ revert H. replace e2 with (e2 - e1 + e1)%Z by ring. rewrite bpow_plus. unfold F2R. simpl. -rewrite <- (Z2R_Zpower beta (e2 - e1)). +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 Z2R_le. +apply IZR_le. apply Zlt_le_succ. -now apply lt_Z2R. +now apply lt_IZR. apply bpow_gt_0. now apply Zle_minus_le_0. Qed. @@ -332,16 +339,16 @@ 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)). +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 Z2R_le. +apply IZR_le. rewrite (Zpred_succ (Zpower _ _)). apply Zplus_le_compat_r. apply Zlt_le_succ. -now apply lt_Z2R. +now apply lt_IZR. apply bpow_gt_0. now apply Zle_minus_le_0. intros H. @@ -352,14 +359,13 @@ 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. +apply IZR_le. omega. Qed. Theorem F2R_lt_bpow : forall f : float beta, forall e', - (Zabs (Fnum f) < Zpower beta (e' - Fexp f))%Z -> + (Z.abs (Fnum f) < Zpower beta (e' - Fexp f))%Z -> (Rabs (F2R f) < bpow e')%R. Proof. intros (m, e) e' Hm. @@ -369,8 +375,8 @@ 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. +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. @@ -387,7 +393,7 @@ Theorem F2R_change_exp : Proof. intros e' m e He. unfold F2R. simpl. -rewrite Z2R_mult, Z2R_Zpower, Rmult_assoc. +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. @@ -396,7 +402,7 @@ Qed. Theorem F2R_prec_normalize : forall m e e' p : Z, - (Zabs m < Zpower beta 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. @@ -413,23 +419,23 @@ 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. +rewrite <- IZR_Zpower. +now apply IZR_lt. exact Hp. Qed. -(** Floats and ln_beta *) -Theorem ln_beta_F2R_bounds : +(** 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 -> - ln_beta beta x = ln_beta beta (F2R (Float beta m e)) :> Z. + mag beta x = mag 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). +destruct (mag beta (F2R (Float beta m e))) as (ex, He). simpl. -apply ln_beta_unique. +apply mag_unique. assert (Hp1: (0 < F2R (Float beta m e))%R). -now apply F2R_gt_0_compat. +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). @@ -442,22 +448,65 @@ apply Rlt_le_trans with (1 := Hx2). now apply F2R_p1_le_bpow. Qed. -Theorem ln_beta_F2R : +Theorem mag_F2R : forall m e : Z, m <> Z0 -> - (ln_beta beta (F2R (Float beta m e)) = ln_beta beta (Z2R m) + e :> Z)%Z. + (mag beta (F2R (Float beta m e)) = mag beta (IZR m) + e :> Z)%Z. Proof. intros m e H. unfold F2R ; simpl. -apply ln_beta_mult_bpow. -exact (Z2R_neq m 0 H). +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 + ln_beta beta (Z2R m1) = e2 + ln_beta beta (Z2R m2))%Z. + (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). @@ -465,35 +514,35 @@ assert (He: (e2 < e1)%Z). apply Znot_ge_lt. intros H0. elim Rlt_not_le with (1 := H21). -apply Zge_le in H0. +apply Z.ge_le in H0. apply (F2R_change_exp e1 m2 e2) in H0. rewrite H0. -apply F2R_le_compat. +apply F2R_le. apply Zlt_le_succ. -apply (F2R_lt_reg e1). +apply (lt_F2R 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 (gt_0_F2R 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). +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 ln_beta_unique. +apply mag_unique. assert (H2 : (bpow (e1' - 1) <= F2R (Float beta m1 e1) < bpow e1')%R). -rewrite <- (Zabs_eq m1), F2R_Zabs. +rewrite <- (Z.abs_eq m1), F2R_Zabs. apply H1. apply Rgt_not_eq. apply Rlt_gt. -now apply F2R_gt_0_compat. +now apply F2R_gt_0. now apply Zlt_le_weak. clear H1. -rewrite <- F2R_Zabs, Zabs_eq. +rewrite <- F2R_Zabs, Z.abs_eq. split. apply Rlt_le. apply Rle_lt_trans with (2 := H12). @@ -507,13 +556,4 @@ 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/Generic_fmt.v index 668b4da2..cb37bd91 100644 --- a/flocq/Core/Fcore_generic_fmt.v +++ b/flocq/Core/Generic_fmt.v @@ -2,9 +2,9 @@ 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) 2009-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +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 @@ -18,10 +18,7 @@ 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. +Require Import Raux Defs Round_pred Float_prop. Section Generic. @@ -53,7 +50,7 @@ Proof. intros k l Hk H. apply Znot_ge_lt. intros Hl. -apply Zge_le in Hl. +apply Z.ge_le in Hl. assert (H' := proj2 (proj2 (valid_exp l) Hl) k). omega. Qed. @@ -66,24 +63,24 @@ Proof. intros k l Hk H. apply Znot_ge_lt. intros H'. -apply Zge_le in H'. -assert (Hl := Zle_trans _ _ _ H 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 canonic_exp x := - fexp (ln_beta beta x). +Definition cexp x := + fexp (mag beta x). -Definition canonic (f : float beta) := - Fexp f = canonic_exp (F2R f). +Definition canonical (f : float beta) := + Fexp f = cexp (F2R f). Definition scaled_mantissa x := - (x * bpow (- canonic_exp x))%R. + (x * bpow (- cexp x))%R. Definition generic_format (x : R) := - x = F2R (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x)). + x = F2R (Float beta (Ztrunc (scaled_mantissa x)) (cexp x)). (** Basic facts *) Theorem generic_format_0 : @@ -91,26 +88,39 @@ Theorem 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. +now rewrite Ztrunc_IZR, F2R_0. Qed. -Theorem canonic_exp_opp : +Theorem cexp_opp : forall x, - canonic_exp (-x) = canonic_exp x. + cexp (-x) = cexp x. Proof. intros x. -unfold canonic_exp. -now rewrite ln_beta_opp. +unfold cexp. +now rewrite mag_opp. Qed. -Theorem canonic_exp_abs : +Theorem cexp_abs : forall x, - canonic_exp (Rabs x) = canonic_exp x. + cexp (Rabs x) = cexp x. Proof. intros x. -unfold canonic_exp. -now rewrite ln_beta_abs. +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 : @@ -118,11 +128,11 @@ Theorem generic_format_bpow : generic_format (bpow e). Proof. intros e H. -unfold generic_format, scaled_mantissa, canonic_exp. -rewrite ln_beta_bpow. +unfold generic_format, scaled_mantissa, cexp. +rewrite mag_bpow. rewrite <- bpow_plus. -rewrite <- (Z2R_Zpower beta (e + - fexp (e + 1))). -rewrite Ztrunc_Z2R. +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. @@ -140,110 +150,107 @@ now apply valid_exp_. rewrite <- H. apply valid_exp. rewrite H. -apply Zle_refl. +apply Z.le_refl. Qed. Theorem generic_format_F2R : forall m e, - ( m <> 0 -> canonic_exp (F2R (Float beta m e)) <= e )%Z -> + ( 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]. +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))). +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_compat. -rewrite Rmult_assoc, <- bpow_plus, <- Z2R_Zpower, <- Z2R_mult. -now rewrite Ztrunc_Z2R. +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 -> - (canonic_exp x <= Fexp f)%Z) -> - generic_format x. +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. +apply generic_format_F2R. simpl in *; intros H3. rewrite H1; apply H2. intros Y; apply H3. -apply F2R_eq_0_reg with beta e. +apply eq_0_F2R with beta e. now rewrite H1. Qed. - -Theorem canonic_opp : +Theorem canonical_opp : forall m e, - canonic (Float beta m e) -> - canonic (Float beta (-m) e). + canonical (Float beta m e) -> + canonical (Float beta (-m) e). Proof. intros m e H. -unfold canonic. -now rewrite F2R_Zopp, canonic_exp_opp. +unfold canonical. +now rewrite F2R_Zopp, cexp_opp. Qed. -Theorem canonic_abs : +Theorem canonical_abs : forall m e, - canonic (Float beta m e) -> - canonic (Float beta (Zabs m) e). + canonical (Float beta m e) -> + canonical (Float beta (Z.abs m) e). Proof. intros m e H. -unfold canonic. -now rewrite F2R_Zabs, canonic_exp_abs. +unfold canonical. +now rewrite F2R_Zabs, cexp_abs. Qed. -Theorem canonic_0: canonic (Float beta 0 (fexp (ln_beta beta 0%R))). +Theorem canonical_0 : + canonical (Float beta 0 (fexp (mag 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. +unfold canonical; simpl ; unfold cexp. +now rewrite F2R_0. Qed. - - -Theorem canonic_unicity : +Theorem canonical_unique : forall f1 f2, - canonic f1 -> - canonic f2 -> + canonical f1 -> + canonical f2 -> F2R f1 = F2R f2 -> f1 = f2. Proof. intros (m1, e1) (m2, e2). -unfold canonic. simpl. +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 F2R_eq_reg with (1 := H). +apply eq_F2R with (1 := H). Qed. Theorem scaled_mantissa_generic : forall x, generic_format x -> - scaled_mantissa x = Z2R (Ztrunc (scaled_mantissa 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_Z2R. +now rewrite Ztrunc_IZR. Qed. Theorem scaled_mantissa_mult_bpow : forall x, - (scaled_mantissa x * bpow (canonic_exp x))%R = x. + (scaled_mantissa x * bpow (cexp x))%R = x. Proof. intros x. unfold scaled_mantissa. @@ -263,7 +270,7 @@ Theorem scaled_mantissa_opp : Proof. intros x. unfold scaled_mantissa. -rewrite canonic_exp_opp. +rewrite cexp_opp. now rewrite Ropp_mult_distr_l_reverse. Qed. @@ -273,7 +280,7 @@ Theorem scaled_mantissa_abs : Proof. intros x. unfold scaled_mantissa. -rewrite canonic_exp_abs, Rabs_mult. +rewrite cexp_abs, Rabs_mult. apply f_equal. apply sym_eq. apply Rabs_pos_eq. @@ -285,7 +292,7 @@ Theorem generic_format_opp : Proof. intros x Hx. unfold generic_format. -rewrite scaled_mantissa_opp, canonic_exp_opp. +rewrite scaled_mantissa_opp, cexp_opp. rewrite Ztrunc_opp. rewrite F2R_Zopp. now apply f_equal. @@ -296,7 +303,7 @@ Theorem generic_format_abs : Proof. intros x Hx. unfold generic_format. -rewrite scaled_mantissa_abs, canonic_exp_abs. +rewrite scaled_mantissa_abs, cexp_abs. rewrite Ztrunc_abs. rewrite F2R_Zabs. now apply f_equal. @@ -308,7 +315,7 @@ Proof. intros x. unfold generic_format, Rabs. case Rcase_abs ; intros _. -rewrite scaled_mantissa_opp, canonic_exp_opp, Ztrunc_opp. +rewrite scaled_mantissa_opp, cexp_opp, Ztrunc_opp. intros H. rewrite <- (Ropp_involutive x) at 1. rewrite H, F2R_Zopp. @@ -316,23 +323,23 @@ apply Ropp_involutive. easy. Qed. -Theorem canonic_exp_fexp : +Theorem cexp_fexp : forall x ex, (bpow (ex - 1) <= Rabs x < bpow ex)%R -> - canonic_exp x = fexp ex. + cexp x = fexp ex. Proof. intros x ex Hx. -unfold canonic_exp. -now rewrite ln_beta_unique with (1 := Hx). +unfold cexp. +now rewrite mag_unique with (1 := Hx). Qed. -Theorem canonic_exp_fexp_pos : +Theorem cexp_fexp_pos : forall x ex, (bpow (ex - 1) <= x < bpow ex)%R -> - canonic_exp x = fexp ex. + cexp x = fexp ex. Proof. intros x ex Hx. -apply canonic_exp_fexp. +apply cexp_fexp. rewrite Rabs_pos_eq. exact Hx. apply Rle_trans with (2 := proj1 Hx). @@ -360,7 +367,7 @@ apply Rlt_le_trans with (1 := proj2 Hx). now apply bpow_le. Qed. -Theorem scaled_mantissa_small : +Theorem scaled_mantissa_lt_1 : forall x ex, (Rabs x < bpow ex)%R -> (ex <= fexp ex)%Z -> @@ -369,62 +376,62 @@ 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). +now apply IZR_lt. rewrite <- scaled_mantissa_abs. unfold scaled_mantissa. -rewrite canonic_exp_abs. -unfold canonic_exp. -destruct (ln_beta beta x) as (ex', Ex'). +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 Zle_trans with (2 := He). +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 abs_scaled_mantissa_lt_bpow : +Theorem scaled_mantissa_lt_bpow : forall x, - (Rabs (scaled_mantissa x) < bpow (ln_beta beta x - canonic_exp x))%R. + (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_ln_beta_gt beta _). +apply Rlt_le_trans with (1 := bpow_mag_gt beta _). apply bpow_le. unfold scaled_mantissa. -rewrite ln_beta_mult_bpow with (1 := Zx). -apply Zle_refl. +rewrite mag_mult_bpow with (1 := Zx). +apply Z.le_refl. Qed. -Theorem ln_beta_generic_gt : +Theorem mag_generic_gt : forall x, (x <> 0)%R -> generic_format x -> - (canonic_exp x < ln_beta beta x)%Z. + (cexp x < mag beta x)%Z. Proof. intros x Zx Gx. apply Znot_ge_lt. -unfold canonic_exp. -destruct (ln_beta beta x) as (ex,Ex) ; simpl. +unfold cexp. +destruct (mag 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). +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 (Zabs (Ztrunc (scaled_mantissa x)) < 1)%Z. +cut (Z.abs (Ztrunc (scaled_mantissa x)) < 1)%Z. clear ; zify ; omega. -apply lt_Z2R. -rewrite Z2R_abs. +apply lt_IZR. +rewrite abs_IZR. now rewrite <- scaled_mantissa_generic. Qed. -Theorem mantissa_DN_small_pos : +Lemma mantissa_DN_small_pos : forall x ex, (bpow (ex - 1) <= x < bpow ex)%R -> (ex <= fexp ex)%Z -> @@ -436,7 +443,7 @@ assert (H := mantissa_small_pos x ex Hx He). split ; try apply Rlt_le ; apply H. Qed. -Theorem mantissa_UP_small_pos : +Lemma mantissa_UP_small_pos : forall x ex, (bpow (ex - 1) <= x < bpow ex)%R -> (ex <= fexp ex)%Z -> @@ -451,7 +458,7 @@ Qed. (** Generic facts about any format *) Theorem generic_format_discrete : forall x m, - let e := canonic_exp x in + let e := cexp x in (F2R (Float beta m e) < x < F2R (Float beta (m + 1) e))%R -> ~ generic_format x. Proof. @@ -459,27 +466,27 @@ 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 F2R_le. apply Zlt_le_succ. -apply lt_Z2R. +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_canonic : - forall f, canonic f -> +Theorem generic_format_canonical : + forall f, canonical f -> generic_format (F2R f). Proof. intros (m, e) Hf. -unfold canonic in Hf. simpl in Hf. +unfold canonical in Hf. simpl in Hf. unfold generic_format, scaled_mantissa. rewrite <- Hf. -apply F2R_eq_compat. +apply F2R_eq. unfold F2R. simpl. rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r. -now rewrite Ztrunc_Z2R. +now rewrite Ztrunc_IZR. Qed. Theorem generic_format_ge_bpow : @@ -492,10 +499,10 @@ Theorem generic_format_ge_bpow : Proof. intros emin Emin x Hx Fx. rewrite Fx. -apply Rle_trans with (bpow (fexp (ln_beta beta x))). +apply Rle_trans with (bpow (fexp (mag beta x))). now apply bpow_le. apply bpow_le_F2R. -apply F2R_gt_0_reg with beta (canonic_exp x). +apply gt_0_F2R with beta (cexp x). now rewrite <- Fx. Qed. @@ -504,13 +511,13 @@ Theorem abs_lt_bpow_prec: (forall e, (e - prec <= fexp e)%Z) -> (* OK with FLX, FLT and FTZ *) forall x, - (Rabs x < bpow (prec + canonic_exp x))%R. + (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 canonic_exp. -destruct (ln_beta beta x) as (ex,Ex) ; simpl. +unfold cexp. +destruct (mag beta x) as (ex,Ex) ; simpl. specialize (Ex Hxz). apply Rlt_le_trans with (1 := proj2 Ex). apply bpow_le. @@ -526,8 +533,8 @@ 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. +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. @@ -559,7 +566,7 @@ 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 + Zrnd_IZR : forall n, rnd (IZR n) = n }. Context { valid_rnd : Valid_rnd }. @@ -571,20 +578,20 @@ 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)). +rewrite <- (Zrnd_IZR (Zfloor x)). apply Zrnd_le. apply Zfloor_lb. right. apply Zle_antisym. -rewrite <- (Zrnd_Z2R (Zceil x)). +rewrite <- (Zrnd_IZR (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). +rewrite Zfloor_IZR, Zrnd_IZR in Hx. +apply Z.lt_irrefl with (1 := Hx). Qed. Theorem Zrnd_ZR_or_AW : @@ -602,7 +609,7 @@ Qed. (** the most useful one: R -> F *) Definition round x := - F2R (Float beta (rnd (scaled_mantissa x)) (canonic_exp x)). + F2R (Float beta (rnd (scaled_mantissa x)) (cexp x)). Theorem round_bounded_large_pos : forall x ex, @@ -612,7 +619,7 @@ Theorem round_bounded_large_pos : Proof. intros x ex He Hx. unfold round, scaled_mantissa. -rewrite (canonic_exp_fexp_pos _ _ Hx). +rewrite (cexp_fexp_pos _ _ Hx). unfold F2R. simpl. destruct (Zrnd_DN_or_UP (x * bpow (- fexp ex))) as [Hr|Hr] ; rewrite Hr. (* DN *) @@ -621,11 +628,11 @@ 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. +assert (Hf: IZR (Zpower beta (ex - 1 - fexp ex)) = bpow (ex - 1 + - fexp ex)). +apply IZR_Zpower. omega. rewrite <- Hf. -apply Z2R_le. +apply IZR_le. apply Zfloor_lub. rewrite Hf. rewrite bpow_plus. @@ -648,11 +655,11 @@ 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. +assert (Hf: IZR (Zpower beta (ex - fexp ex)) = bpow (ex - fexp ex)). +apply IZR_Zpower. omega. rewrite <- Hf. -apply Z2R_le. +apply IZR_le. apply Zceil_glb. rewrite Hf. unfold Zminus. @@ -671,13 +678,13 @@ Theorem round_bounded_small_pos : Proof. intros x ex He Hx. unfold round, scaled_mantissa. -rewrite (canonic_exp_fexp_pos _ _ Hx). +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 (@f_equal _ _ Z2R _ Z0). +apply IZR_eq. apply Zfloor_imp. refine (let H := _ in conj (Rlt_le _ _ (proj1 H)) (proj2 H)). now apply mantissa_small_pos. @@ -685,18 +692,18 @@ now apply mantissa_small_pos. 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 IZR_eq. apply Zceil_imp. refine (let H := _ in conj (proj1 H) (Rlt_le _ _ (proj2 H))). now apply mantissa_small_pos. Qed. -Theorem round_le_pos : +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 (ln_beta beta x) as [ex Hex]. -destruct (ln_beta beta y) as [ey Hey]. +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. @@ -709,18 +716,18 @@ assert (He: (ex <= ey)%Z). 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). + unfold round, scaled_mantissa, cexp. + rewrite mag_unique_pos with (1 := Hex). + rewrite mag_unique_pos with (1 := Hey). rewrite H. - apply F2R_le_compat. + 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 Zle_trans with ey. + 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)). @@ -746,7 +753,7 @@ Proof. intros x Hx. unfold round. rewrite scaled_mantissa_generic with (1 := Hx). -rewrite Zrnd_Z2R. +rewrite Zrnd_IZR. now apply sym_eq. Qed. @@ -755,8 +762,7 @@ Theorem round_0 : Proof. unfold round, scaled_mantissa. rewrite Rmult_0_l. -change 0%R with (Z2R 0). -rewrite Zrnd_Z2R. +rewrite Zrnd_IZR. apply F2R_0. Qed. @@ -774,13 +780,13 @@ apply bpow_gt_0. apply (round_bounded_large_pos); assumption. Qed. -Theorem generic_format_round_pos : +Lemma 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). +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]. @@ -798,8 +804,8 @@ 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). +rewrite (cexp_fexp_pos (F2R _) _ (conj Hr1 Hr)). +rewrite (cexp_fexp_pos _ _ Hex). now apply Zeq_le. Qed. @@ -821,7 +827,7 @@ Section Zround_opp. Variable rnd : R -> Z. Context { valid_rnd : Valid_rnd rnd }. -Definition Zrnd_opp x := Zopp (rnd (-x)). +Definition Zrnd_opp x := Z.opp (rnd (-x)). Global Instance valid_rnd_opp : Valid_rnd Zrnd_opp. Proof with auto with typeclass_instances. @@ -830,14 +836,14 @@ split. intros x y Hxy. unfold Zrnd_opp. apply Zopp_le_cancel. -rewrite 2!Zopp_involutive. +rewrite 2!Z.opp_involutive. apply Zrnd_le... now apply Ropp_le_contravar. (* *) intros n. unfold Zrnd_opp. -rewrite <- Z2R_opp, Zrnd_Z2R... -apply Zopp_involutive. +rewrite <- opp_IZR, Zrnd_IZR... +apply Z.opp_involutive. Qed. Theorem round_opp : @@ -846,10 +852,10 @@ Theorem round_opp : Proof. intros x. unfold round. -rewrite <- F2R_Zopp, canonic_exp_opp, scaled_mantissa_opp. -apply F2R_eq_compat. +rewrite <- F2R_Zopp, cexp_opp, scaled_mantissa_opp. +apply F2R_eq. apply sym_eq. -exact (Zopp_involutive _). +exact (Z.opp_involutive _). Qed. End Zround_opp. @@ -860,28 +866,28 @@ Global Instance valid_rnd_DN : Valid_rnd Zfloor. Proof. split. apply Zfloor_le. -apply Zfloor_Z2R. +apply Zfloor_IZR. Qed. Global Instance valid_rnd_UP : Valid_rnd Zceil. Proof. split. apply Zceil_le. -apply Zceil_Z2R. +apply Zceil_IZR. Qed. Global Instance valid_rnd_ZR : Valid_rnd Ztrunc. Proof. split. apply Ztrunc_le. -apply Ztrunc_Z2R. +apply Ztrunc_IZR. Qed. Global Instance valid_rnd_AW : Valid_rnd Zaway. Proof. split. apply Zaway_le. -apply Zaway_Z2R. +apply Zaway_IZR. Qed. Section monotone. @@ -923,7 +929,7 @@ 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)). +rewrite (cexp_opp (-x)), (cexp_opp (-y)). apply Ropp_le_cancel. rewrite <- 2!F2R_Zopp. apply (round_le_pos (Zrnd_opp rnd) (-y) (-x)). @@ -932,16 +938,16 @@ 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 F2R_le_0. simpl. +rewrite <- (Zrnd_IZR rnd 0). apply Zrnd_le... simpl. -rewrite <- (Rmult_0_l (bpow (- fexp (ln_beta beta x)))). +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_compat. simpl. -rewrite <- (Zrnd_Z2R rnd 0). +apply F2R_ge_0. simpl. +rewrite <- (Zrnd_IZR rnd 0). apply Zrnd_le... apply Rmult_le_pos. exact Hy. @@ -949,9 +955,9 @@ apply bpow_ge_0. (* x = 0 *) rewrite Hx. rewrite round_0... -apply F2R_ge_0_compat. +apply F2R_ge_0. simpl. -rewrite <- (Zrnd_Z2R rnd 0). +rewrite <- (Zrnd_IZR rnd 0). apply Zrnd_le... apply Rmult_le_pos. now rewrite <- Hx. @@ -1071,8 +1077,8 @@ unfold round. rewrite scaled_mantissa_opp. rewrite <- F2R_Zopp. unfold Zceil. -rewrite Zopp_involutive. -now rewrite canonic_exp_opp. +rewrite Z.opp_involutive. +now rewrite cexp_opp. Qed. Theorem round_UP_opp : @@ -1085,7 +1091,7 @@ rewrite scaled_mantissa_opp. rewrite <- F2R_Zopp. unfold Zceil. rewrite Ropp_involutive. -now rewrite canonic_exp_opp. +now rewrite cexp_opp. Qed. Theorem round_ZR_opp : @@ -1094,7 +1100,7 @@ Theorem round_ZR_opp : Proof. intros x. unfold round. -rewrite scaled_mantissa_opp, canonic_exp_opp, Ztrunc_opp. +rewrite scaled_mantissa_opp, cexp_opp, Ztrunc_opp. apply F2R_Zopp. Qed. @@ -1123,7 +1129,7 @@ Theorem round_AW_opp : Proof. intros x. unfold round. -rewrite scaled_mantissa_opp, canonic_exp_opp, Zaway_opp. +rewrite scaled_mantissa_opp, cexp_opp, Zaway_opp. apply F2R_Zopp. Qed. @@ -1146,7 +1152,7 @@ apply round_le... now apply Rge_le. Qed. -Theorem round_ZR_pos : +Theorem round_ZR_DN : forall x, (0 <= x)%R -> round Ztrunc x = round Zfloor x. @@ -1156,13 +1162,13 @@ unfold round, Ztrunc. case Rlt_bool_spec. intros H. elim Rlt_not_le with (1 := H). -rewrite <- (Rmult_0_l (bpow (- canonic_exp x))). +rewrite <- (Rmult_0_l (bpow (- cexp x))). apply Rmult_le_compat_r with (2 := Hx). apply bpow_ge_0. easy. Qed. -Theorem round_ZR_neg : +Theorem round_ZR_UP : forall x, (x <= 0)%R -> round Ztrunc x = round Zceil x. @@ -1173,15 +1179,14 @@ case Rlt_bool_spec. easy. intros [H|H]. elim Rlt_not_le with (1 := H). -rewrite <- (Rmult_0_l (bpow (- canonic_exp x))). +rewrite <- (Rmult_0_l (bpow (- cexp 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. +now rewrite Zfloor_IZR, Zceil_IZR. Qed. -Theorem round_AW_pos : +Theorem round_AW_UP : forall x, (0 <= x)%R -> round Zaway x = round Zceil x. @@ -1191,13 +1196,13 @@ unfold round, Zaway. case Rlt_bool_spec. intros H. elim Rlt_not_le with (1 := H). -rewrite <- (Rmult_0_l (bpow (- canonic_exp x))). +rewrite <- (Rmult_0_l (bpow (- cexp x))). apply Rmult_le_compat_r with (2 := Hx). apply bpow_ge_0. easy. Qed. -Theorem round_AW_neg : +Theorem round_AW_DN : forall x, (x <= 0)%R -> round Zaway x = round Zfloor x. @@ -1208,12 +1213,11 @@ case Rlt_bool_spec. easy. intros [H|H]. elim Rlt_not_le with (1 := H). -rewrite <- (Rmult_0_l (bpow (- canonic_exp x))). +rewrite <- (Rmult_0_l (bpow (- cexp 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. +now rewrite Zfloor_IZR, Zceil_IZR. Qed. Theorem generic_format_round : @@ -1275,7 +1279,7 @@ Proof. intros x. rewrite <- (Ropp_involutive x). rewrite round_UP_opp. -apply Rnd_DN_UP_pt_sym. +apply Rnd_UP_pt_opp. apply generic_format_opp. apply round_DN_pt. Qed. @@ -1286,22 +1290,22 @@ Theorem round_ZR_pt : Proof. intros x. split ; intros Hx. -rewrite round_ZR_pos with (1 := Hx). +rewrite round_ZR_DN with (1 := Hx). apply round_DN_pt. -rewrite round_ZR_neg with (1 := Hx). +rewrite round_ZR_UP with (1 := Hx). apply round_UP_pt. Qed. -Theorem round_DN_small_pos : +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 (canonic_exp x)). +rewrite <- (F2R_0 beta (cexp x)). rewrite <- mantissa_DN_small_pos with (1 := Hx) (2 := He). -now rewrite <- canonic_exp_fexp_pos with (1 := Hx). +now rewrite <- cexp_fexp_pos with (1 := Hx). Qed. @@ -1329,7 +1333,7 @@ contradict Fx. apply generic_format_round... Qed. -Theorem round_UP_small_pos : +Lemma round_UP_small_pos : forall x ex, (bpow (ex - 1) <= x < bpow ex)%R -> (ex <= fexp ex)%Z -> @@ -1338,7 +1342,7 @@ 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). +now rewrite <- cexp_fexp_pos with (1 := Hx). Qed. Theorem generic_format_EM : @@ -1361,14 +1365,14 @@ Section round_large. Variable rnd : R -> Z. Context { valid_rnd : Valid_rnd rnd }. -Theorem round_large_pos_ge_pow : +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 (ln_beta beta x) as (ex, He). +destruct (mag beta x) as (ex, He). assert (Hx: (0 < x)%R). apply Rlt_le_trans with (2 := Hex). apply bpow_gt_0. @@ -1391,95 +1395,95 @@ Qed. End round_large. -Theorem ln_beta_round_ZR : +Theorem mag_round_ZR : forall x, (round Ztrunc x <> 0)%R -> - (ln_beta beta (round Ztrunc x) = ln_beta beta x :> Z). + (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 ln_beta_unique. -destruct (ln_beta beta x) as (ex, Ex) ; simpl. +apply mag_unique. +destruct (mag beta x) as (ex, Ex) ; simpl. specialize (Ex Zx). rewrite <- round_ZR_abs. split. -apply round_large_pos_ge_pow... +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_pos. +rewrite round_ZR_DN. apply round_DN_pt. apply Rabs_pos. Qed. -Theorem ln_beta_round : +Theorem mag_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))). + (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 ln_beta_round_ZR. +now apply mag_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. +destruct (mag beta x) as (ex, Ex) ; simpl. specialize (Ex Zx). -rewrite <- ln_beta_abs. +rewrite <- mag_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 _). +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 ln_beta_unique. +apply mag_unique. rewrite <- round_AW_abs, Rabs_Rabsolu. now split. right. -now rewrite Zmax_l with (1 := Zlt_le_weak _ _ He). +now rewrite Z.max_l with (1 := Zlt_le_weak _ _ He). Qed. -Theorem ln_beta_DN : +Theorem mag_DN : forall x, (0 < round Zfloor x)%R -> - (ln_beta beta (round Zfloor x) = ln_beta beta x :> Z). + (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_pos. +rewrite <- round_ZR_DN. intros Hd. -apply ln_beta_round_ZR. +apply mag_round_ZR. now apply Rgt_not_eq. now apply Rlt_le. Qed. -Theorem canonic_exp_DN : +Theorem cexp_DN : forall x, (0 < round Zfloor x)%R -> - canonic_exp (round Zfloor x) = canonic_exp x. + cexp (round Zfloor x) = cexp x. Proof. intros x Hd. apply (f_equal fexp). -now apply ln_beta_DN. +now apply mag_DN. Qed. Theorem scaled_mantissa_DN : forall x, (0 < round Zfloor x)%R -> - scaled_mantissa (round Zfloor x) = Z2R (Zfloor (scaled_mantissa x)). + scaled_mantissa (round Zfloor x) = IZR (Zfloor (scaled_mantissa x)). Proof. intros x Hd. unfold scaled_mantissa. -rewrite canonic_exp_DN with (1 := Hd). +rewrite cexp_DN with (1 := Hd). unfold round, F2R. simpl. now rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r. Qed. @@ -1492,10 +1496,10 @@ Proof. intros x f Hxf. destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf). left. -apply Rnd_DN_pt_unicity with (1 := H). +apply Rnd_DN_pt_unique with (1 := H). apply round_DN_pt. right. -apply Rnd_UP_pt_unicity with (1 := H). +apply Rnd_UP_pt_unique with (1 := H). apply round_UP_pt. Qed. @@ -1516,20 +1520,20 @@ 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). +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 <- Z2R_mult, Ztrunc_Z2R. +rewrite <- mult_IZR, Ztrunc_IZR. unfold F2R. simpl. -rewrite Z2R_mult. +rewrite mult_IZR. rewrite H. rewrite Rmult_assoc, <- bpow_plus. -now ring_simplify (canonic_exp x + - fexp e + fexp e)%Z. +now ring_simplify (cexp x + - fexp e + fexp e)%Z. Qed. End not_FTZ. @@ -1550,60 +1554,60 @@ now apply Zlt_le_succ. now apply valid_exp. Qed. -Lemma canonic_exp_le_bpow : +Lemma cexp_le_bpow : forall (x : R) (e : Z), x <> 0%R -> (Rabs x < bpow e)%R -> - (canonic_exp x <= fexp e)%Z. + (cexp x <= fexp e)%Z. Proof. intros x e Zx Hx. apply monotone_exp. -now apply ln_beta_le_bpow. +now apply mag_le_bpow. Qed. -Lemma canonic_exp_ge_bpow : +Lemma cexp_ge_bpow : forall (x : R) (e : Z), (bpow (e - 1) <= Rabs x)%R -> - (fexp e <= canonic_exp x)%Z. + (fexp e <= cexp x)%Z. Proof. intros x e Hx. apply monotone_exp. rewrite (Zsucc_pred e). apply Zlt_le_succ. -now apply ln_beta_gt_bpow. +now apply mag_gt_bpow. Qed. Variable rnd : R -> Z. Context { valid_rnd : Valid_rnd rnd }. -Theorem ln_beta_round_ge : +Theorem mag_round_ge : forall x, round rnd x <> 0%R -> - (ln_beta beta x <= ln_beta beta (round rnd x))%Z. + (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 ln_beta_round_ZR with (1 := Zr). -apply Zle_refl. -apply ln_beta_le_abs. +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_pos. +rewrite round_AW_UP. apply round_UP_pt. apply Rabs_pos. Qed. -Theorem canonic_exp_round_ge : +Theorem cexp_round_ge : forall x, round rnd x <> 0%R -> - (canonic_exp x <= canonic_exp (round rnd x))%Z. + (cexp x <= cexp (round rnd x))%Z. Proof with auto with typeclass_instances. intros x Zr. -unfold canonic_exp. +unfold cexp. apply monotone_exp. -now apply ln_beta_round_ge. +now apply mag_round_ge. Qed. End monotone_exp. @@ -1614,7 +1618,7 @@ Section Znearest. Variable choice : Z -> bool. Definition Znearest x := - match Rcompare (x - Z2R (Zfloor x)) (/2) with + 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 @@ -1640,8 +1644,8 @@ Theorem Znearest_ge_floor : Proof. intros x. destruct (Znearest_DN_or_UP x) as [Hx|Hx] ; rewrite Hx. -apply Zle_refl. -apply le_Z2R. +apply Z.le_refl. +apply le_IZR. apply Rle_trans with x. apply Zfloor_lb. apply Zceil_ub. @@ -1653,11 +1657,11 @@ Theorem Znearest_le_ceil : Proof. intros x. destruct (Znearest_DN_or_UP x) as [Hx|Hx] ; rewrite Hx. -apply le_Z2R. +apply le_IZR. apply Rle_trans with x. apply Zfloor_lb. apply Zceil_ub. -apply Zle_refl. +apply Z.le_refl. Qed. Global Instance valid_rnd_N : Valid_rnd Znearest. @@ -1665,22 +1669,22 @@ 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). +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 Z2R_le. +apply IZR_le. now apply Zfloor_le. apply Rlt_le_trans with (1 := H). -apply Z2R_le. +apply IZR_le. apply Zceil_glb. apply Rlt_le. -rewrite Z2R_plus. +rewrite plus_IZR. apply Zfloor_ub. (* . *) unfold Znearest at 1. @@ -1696,15 +1700,15 @@ 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. +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 Zle_trans with (Zceil x). +apply Z.le_trans with (Zceil x). case choice. -apply Zle_refl. -apply le_Z2R. +apply Z.le_refl. +apply le_IZR. apply Rle_trans with x. apply Zfloor_lb. apply Zceil_ub. @@ -1719,79 +1723,19 @@ now apply Rplus_le_compat_r. (* *) intros n. unfold Znearest. -rewrite Zfloor_Z2R. +rewrite Zfloor_IZR. 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). +now apply IZR_lt. Qed. Theorem Znearest_N_strict : forall x, - (x - Z2R (Zfloor x) <> /2)%R -> - (Rabs (x - Z2R (Znearest x)) < /2)%R. + (x - IZR (Zfloor x) <> /2)%R -> + (Rabs (x - IZR (Znearest x)) < /2)%R. Proof. intros x Hx. unfold Znearest. @@ -1804,72 +1748,70 @@ now elim Hx. rewrite Rabs_left1. rewrite Ropp_minus_distr. rewrite Zceil_floor_neq. -rewrite Z2R_plus. -simpl. +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 + - (Z2R (Zfloor x) + 1 - x))%R with (x - Z2R (Zfloor x))%R by ring. +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 (- Z2R (Zfloor x))%R. +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 (Z2R_lt 0 2). +now apply IZR_lt. now rewrite <- (Rplus_comm x). apply Rle_minus. apply Zceil_ub. Qed. -Theorem Znearest_N : +Theorem Znearest_half : forall x, - (Rabs (x - Z2R (Znearest x)) <= /2)%R. + (Rabs (x - IZR (Znearest x)) <= /2)%R. Proof. intros x. -destruct (Req_dec (x - Z2R (Zfloor x)) (/2)) as [Hx|Hx]. +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 (Z2R_lt 0 2). +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 Z2R_plus. -simpl. -replace (x - (Z2R (Zfloor x) + 1))%R with (x - Z2R (Zfloor x) - 1)%R by ring. +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 (- Z2R (Zfloor x))%R. +apply Rplus_lt_reg_l with (- IZR (Zfloor x))%R. rewrite Rplus_opp_l, Rplus_comm. -fold (x - Z2R (Zfloor x))%R. +fold (x - IZR (Zfloor x))%R. rewrite Hx. apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). +now apply IZR_lt. apply Rlt_le. now apply Znearest_N_strict. Qed. Theorem Znearest_imp : forall x n, - (Rabs (x - Z2R n) < /2)%R -> + (Rabs (x - IZR n) < /2)%R -> Znearest x = n. Proof. intros x n Hd. -cut (Zabs (Znearest x - n) < 1)%Z. +cut (Z.abs (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 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_N. +apply Znearest_half. Qed. Theorem round_N_pt : @@ -1880,7 +1822,7 @@ intros x. set (d := round Zfloor x). set (u := round Zceil x). set (mx := scaled_mantissa x). -set (bx := bpow (canonic_exp 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. @@ -1892,7 +1834,7 @@ 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]. +destruct (Req_dec (IZR (Zfloor mx)) mx) as [Hm|Hm]. (* .. *) rewrite Hm. unfold Rminus at 2. @@ -1903,16 +1845,16 @@ unfold Rminus at -3. rewrite Rplus_opp_r. rewrite Rabs_R0. unfold Rmin. -destruct (Rle_dec 0 (Z2R (Zceil mx) - mx)) as [H|H]. +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 (Z2R_lt 0 2). +now apply IZR_lt. (* .. *) -rewrite Rcompare_floor_ceil_mid with (1 := Hm). +rewrite Rcompare_floor_ceil_middle with (1 := Hm). rewrite Rmin_compare. -assert (H: (Rabs (mx - Z2R (Zfloor mx)) <= mx - Z2R (Zfloor mx))%R). +assert (H: (Rabs (mx - IZR (Zfloor mx)) <= mx - IZR (Zfloor mx))%R). rewrite Rabs_pos_eq. apply Rle_refl. apply Rle_0_minus. @@ -1928,7 +1870,7 @@ apply Rle_refl. apply Rle_0_minus. apply Zceil_ub. (* . *) -apply Rnd_DN_UP_pt_N with d u. +apply Rnd_N_pt_DN_UP with d u. apply generic_format_round. auto with typeclass_instances. now apply round_DN_pt. @@ -1947,63 +1889,63 @@ 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]. +destruct (Req_dec (IZR (Zfloor (scaled_mantissa x))) (scaled_mantissa x)) as [Fx|Fx]. (* *) intros _. rewrite <- Fx. -rewrite Zceil_Z2R, Zfloor_Z2R. +rewrite Zceil_IZR, Zfloor_IZR. set (m := Zfloor (scaled_mantissa x)). -now case (Rcompare (Z2R m - Z2R m) (/ 2)) ; case (choice m). +now case (Rcompare (IZR m - IZR m) (/ 2)) ; case (choice m). (* *) intros H. -rewrite Rcompare_floor_ceil_mid with (1 := Fx). +rewrite Rcompare_floor_ceil_middle with (1 := Fx). rewrite Rcompare_Eq. now case choice. -apply Rmult_eq_reg_r with (bpow (canonic_exp x)). +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_really_small_pos : +Lemma round_N_small_pos : forall x, forall ex, - (Fcore_Raux.bpow beta (ex - 1) <= x < Fcore_Raux.bpow beta ex)%R -> + (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, canonic_exp; simpl. -apply (Rmult_eq_reg_r (bpow (- fexp (ln_beta beta x)))); +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. -change 0%R with (Z2R 0); apply f_equal. +apply IZR_eq. apply Znearest_imp. -simpl; unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r. +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). +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 (ln_beta beta x)))); [now apply bpow_gt_0|]. +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 (ln_beta beta x) - 1)). +apply Rle_trans with (bpow (fexp (mag beta x) - 1)). - apply bpow_le. - rewrite (ln_beta_unique beta x ex); [omega|]. + 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 Fcore_Raux.bpow, Z.pow_pos; simpl. + unfold 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. + apply IZR_le. destruct beta as (beta_val,beta_prop). now apply Zle_bool_imp_le. Qed. @@ -2024,7 +1966,7 @@ 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. +apply Rnd_NA_pt_N. exact generic_format_0. exact Rxf. destruct (Rle_or_lt 0 x) as [Hx|Hx]. @@ -2038,7 +1980,7 @@ 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). +apply Rnd_N_pt_ge_0 with (2 := Hx) (3 := Rxf). exact generic_format_0. (* . *) rewrite Rabs_left with (1 := Hx). @@ -2048,21 +1990,21 @@ unfold f. rewrite round_N_middle with (1 := Hm). rewrite Zle_bool_false. apply (round_DN_pt x). -apply lt_Z2R. +apply lt_IZR. apply Rle_lt_trans with (scaled_mantissa x). apply Zfloor_lb. simpl. -rewrite <- (Rmult_0_l (bpow (- canonic_exp x))). +rewrite <- (Rmult_0_l (bpow (- cexp x))). apply Rmult_lt_compat_r with (2 := Hx). apply bpow_gt_0. -apply Rnd_N_pt_neg with (3 := Rxf). +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_unicity with (3 := Hm) (4 := Rxf) (5 := Rxg). +rewrite Rnd_N_pt_unique with (3 := Hm) (4 := Rxf) (5 := Rxg). apply Rle_refl. apply round_DN_pt. apply round_UP_pt. @@ -2077,25 +2019,25 @@ Theorem Znearest_opp : 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]. +destruct (Req_dec (IZR (Zfloor x)) x) as [Hx|Hx]. rewrite <- Hx. -rewrite <- Z2R_opp. -rewrite 2!Zrnd_Z2R... +rewrite <- opp_IZR. +rewrite 2!Zrnd_IZR... 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). +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 Zopp_involutive. +rewrite Z.opp_involutive. case (choice (Zfloor (- x))) ; simpl ; trivial. -now rewrite Zopp_involutive. -now rewrite Zopp_involutive. +now rewrite Z.opp_involutive. +now rewrite Z.opp_involutive. unfold Zceil. -rewrite Z2R_opp. +rewrite opp_IZR. apply Rplus_comm. Qed. @@ -2106,15 +2048,30 @@ Theorem round_N_opp : Proof. intros choice x. unfold round, F2R. simpl. -rewrite canonic_exp_opp. +rewrite cexp_opp. rewrite scaled_mantissa_opp. rewrite Znearest_opp. -rewrite Z2R_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 *) @@ -2125,9 +2082,9 @@ Variables fexp1 fexp2 : Z -> Z. Context { valid_exp1 : Valid_exp fexp1 }. Context { valid_exp2 : Valid_exp fexp2 }. -Theorem generic_inclusion_ln_beta : +Theorem generic_inclusion_mag : forall x, - ( x <> R0 -> (fexp2 (ln_beta beta x) <= fexp1 (ln_beta beta x))%Z ) -> + ( x <> 0%R -> (fexp2 (mag beta x) <= fexp1 (mag beta x))%Z ) -> generic_format fexp1 x -> generic_format fexp2 x. Proof. @@ -2139,7 +2096,7 @@ rewrite <- Fx. apply He. contradict Zx. rewrite Zx, scaled_mantissa_0. -apply (Ztrunc_Z2R 0). +apply Ztrunc_IZR. Qed. Theorem generic_inclusion_lt_ge : @@ -2151,12 +2108,12 @@ Theorem generic_inclusion_lt_ge : generic_format fexp2 x. Proof. intros e1 e2 He x (Hx1,Hx2). -apply generic_inclusion_ln_beta. +apply generic_inclusion_mag. intros Zx. apply He. split. -now apply ln_beta_gt_bpow. -now apply ln_beta_le_bpow. +now apply mag_gt_bpow. +now apply mag_le_bpow. Qed. Theorem generic_inclusion : @@ -2168,13 +2125,13 @@ Theorem generic_inclusion : 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). +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 Zle_trans with (1 := He). +apply Z.le_trans with (1 := He). apply generic_format_bpow_inv... rewrite <- Hx2. now apply generic_format_abs. @@ -2191,18 +2148,18 @@ Theorem generic_inclusion_le_ge : Proof. intros e1 e2 He' He x (Hx1,[Hx2|Hx2]). (* *) -apply generic_inclusion_ln_beta. +apply generic_inclusion_mag. intros Zx. apply He. split. -now apply ln_beta_gt_bpow. -now apply ln_beta_le_bpow. +now apply mag_gt_bpow. +now apply mag_le_bpow. (* *) apply generic_inclusion with (e := e2). apply He. split. apply He'. -apply Zle_refl. +apply Z.le_refl. rewrite Hx2. split. apply bpow_le. @@ -2219,13 +2176,13 @@ Theorem generic_inclusion_le : generic_format fexp2 x. Proof. intros e2 He x [Hx|Hx]. -apply generic_inclusion_ln_beta. +apply generic_inclusion_mag. intros Zx. apply He. -now apply ln_beta_le_bpow. +now apply mag_le_bpow. apply generic_inclusion with (e := e2). apply He. -apply Zle_refl. +apply Z.le_refl. rewrite Hx. split. apply bpow_le. @@ -2242,10 +2199,10 @@ Theorem generic_inclusion_ge : generic_format fexp2 x. Proof. intros e1 He x Hx. -apply generic_inclusion_ln_beta. +apply generic_inclusion_mag. intros Zx. apply He. -now apply ln_beta_gt_bpow. +now apply mag_gt_bpow. Qed. Variable rnd : R -> Z. @@ -2263,9 +2220,9 @@ 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. +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. @@ -2279,25 +2236,25 @@ 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'']. +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 canonic_exp at 1. -rewrite ln_beta_round_ZR... +unfold cexp at 1. +rewrite mag_round_ZR... contradict Zx. -apply F2R_eq_0_reg with (1 := 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 canonic_exp at 1. -rewrite ln_beta_unique_pos with (1 := conj Hr1 Hr2). -rewrite <- ln_beta_unique_pos with (1 := Ex). +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'... @@ -2327,7 +2284,7 @@ apply Ropp_eq_compat. apply round_ext. clear x; intro x. unfold Znearest. -case_eq (Rcompare (x - Z2R (Zfloor x)) (/ 2)); intro C; +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); diff --git a/flocq/Core/Fcore_Raux.v b/flocq/Core/Raux.v index 77235e63..8273a55b 100644 --- a/flocq/Core/Fcore_Raux.v +++ b/flocq/Core/Raux.v @@ -2,9 +2,9 @@ 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) 2009-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +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 @@ -18,9 +18,9 @@ COPYING file for more details. *) (** * Missing definitions/lemmas *) -Require Export Reals. -Require Export ZArith. -Require Export Fcore_Zaux. +Require Import Psatz. +Require Export Reals ZArith. +Require Export Zaux. Section Rmissing. @@ -58,12 +58,13 @@ Theorem Rabs_minus_le: (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. +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. @@ -73,53 +74,6 @@ 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 -> @@ -135,16 +89,6 @@ apply Rle_lt_trans with (r1 * r4)%R. + 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. @@ -154,13 +98,18 @@ 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. +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. +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. @@ -227,7 +176,6 @@ 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. @@ -288,6 +236,14 @@ destruct (Req_dec x 0) as [Zx|Nzx]. 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. @@ -387,187 +343,35 @@ Qed. End Rmissing. -Section Z2R. +Section IZR. -(** 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. +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 Z2R_le. -now apply Z2R_lt. +now apply IZR_le. +now apply IZR_lt. Qed. -Theorem le_lt_Z2R : - forall m n p, (Z2R m <= Z2R n < Z2R p)%R -> (m <= n < p)%Z. +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_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. +now apply le_IZR. +now apply lt_IZR. Qed. -Theorem neq_Z2R : - forall m n, (Z2R m <> Z2R n)%R -> (m <> n)%Z. +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. -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. +End IZR. (** Decidable comparison on reals *) Section Rcompare. @@ -691,17 +495,17 @@ contradict H. now apply Rcompare_Gt. Qed. -Theorem Rcompare_Z2R : - forall x y, Rcompare (Z2R x) (Z2R y) = Zcompare x y. +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_Z2R. +now apply lt_IZR. apply Zcompare_Eq. -now apply eq_Z2R. +now apply eq_IZR. apply Zcompare_Gt. -now apply lt_Z2R. +now apply lt_IZR. Qed. Theorem Rcompare_sym : @@ -715,6 +519,16 @@ 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. @@ -773,7 +587,7 @@ 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). +now apply IZR_lt. Qed. Theorem Rcompare_half_l : @@ -784,8 +598,8 @@ 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). +now apply IZR_neq. +now apply IZR_lt. Qed. Theorem Rcompare_half_r : @@ -796,23 +610,23 @@ 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). +now apply IZR_neq. +now apply IZR_lt. Qed. Theorem Rcompare_sqr : forall x y, - (0 <= x)%R -> (0 <= y)%R -> - Rcompare (x * x) (y * y) = Rcompare x y. + Rcompare (x * x) (y * y) = Rcompare (Rabs x) (Rabs y). Proof. -intros x y Hx Hy. -destruct (Rcompare_spec x y) as [H|H|H]. +intros x y. +destruct (Rcompare_spec (Rabs x) (Rabs y)) as [H|H|H]. apply Rcompare_Lt. -now apply Rsqr_incrst_1. -rewrite H. +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_incrst_1. +now apply Rsqr_lt_abs_1. Qed. Theorem Rmin_compare : @@ -941,6 +755,14 @@ 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. @@ -997,13 +819,12 @@ Definition Zfloor (x : R) := (up x - 1)%Z. Theorem Zfloor_lb : forall x : R, - (Z2R (Zfloor x) <= x)%R. + (IZR (Zfloor x) <= x)%R. Proof. intros x. unfold Zfloor. -rewrite Z2R_minus. +rewrite minus_IZR. simpl. -rewrite Z2R_IZR. apply Rplus_le_reg_r with (1 - x)%R. ring_simplify. exact (proj2 (archimed x)). @@ -1011,55 +832,54 @@ Qed. Theorem Zfloor_ub : forall x : R, - (x < Z2R (Zfloor x) + 1)%R. + (x < IZR (Zfloor x) + 1)%R. Proof. intros x. unfold Zfloor. -rewrite Z2R_minus. +rewrite minus_IZR. 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 -> + (IZR n <= x)%R -> (n <= Zfloor x)%Z. Proof. intros n x Hnx. apply Zlt_succ_le. -apply lt_Z2R. +apply lt_IZR. apply Rle_lt_trans with (1 := Hnx). -unfold Zsucc. -rewrite Z2R_plus. +unfold Z.succ. +rewrite plus_IZR. apply Zfloor_ub. Qed. Theorem Zfloor_imp : forall n x, - (Z2R n <= x < Z2R (n + 1))%R -> + (IZR n <= x < IZR (n + 1))%R -> Zfloor x = n. Proof. intros n x Hnx. apply Zle_antisym. apply Zlt_succ_le. -apply lt_Z2R. +apply lt_IZR. apply Rle_lt_trans with (2 := proj2 Hnx). apply Zfloor_lb. now apply Zfloor_lub. Qed. -Theorem Zfloor_Z2R : +Theorem Zfloor_IZR : forall n, - Zfloor (Z2R n) = n. + Zfloor (IZR n) = n. Proof. intros n. apply Zfloor_imp. split. apply Rle_refl. -apply Z2R_lt. +apply IZR_lt. apply Zlt_succ. Qed. @@ -1077,11 +897,11 @@ Definition Zceil (x : R) := (- Zfloor (- x))%Z. Theorem Zceil_ub : forall x : R, - (x <= Z2R (Zceil x))%R. + (x <= IZR (Zceil x))%R. Proof. intros x. unfold Zceil. -rewrite Z2R_opp. +rewrite opp_IZR. apply Ropp_le_cancel. rewrite Ropp_involutive. apply Zfloor_lb. @@ -1089,45 +909,45 @@ Qed. Theorem Zceil_glb : forall n x, - (x <= Z2R n)%R -> + (x <= IZR n)%R -> (Zceil x <= n)%Z. Proof. intros n x Hnx. unfold Zceil. apply Zopp_le_cancel. -rewrite Zopp_involutive. +rewrite Z.opp_involutive. apply Zfloor_lub. -rewrite Z2R_opp. +rewrite opp_IZR. now apply Ropp_le_contravar. Qed. Theorem Zceil_imp : forall n x, - (Z2R (n - 1) < x <= Z2R n)%R -> + (IZR (n - 1) < x <= IZR n)%R -> Zceil x = n. Proof. intros n x Hnx. unfold Zceil. -rewrite <- (Zopp_involutive n). +rewrite <- (Z.opp_involutive n). apply f_equal. apply Zfloor_imp. split. -rewrite Z2R_opp. +rewrite opp_IZR. now apply Ropp_le_contravar. -rewrite <- (Zopp_involutive 1). +rewrite <- (Z.opp_involutive 1). rewrite <- Zopp_plus_distr. -rewrite Z2R_opp. +rewrite opp_IZR. now apply Ropp_lt_contravar. Qed. -Theorem Zceil_Z2R : +Theorem Zceil_IZR : forall n, - Zceil (Z2R n) = n. + Zceil (IZR n) = n. Proof. intros n. unfold Zceil. -rewrite <- Z2R_opp, Zfloor_Z2R. -apply Zopp_involutive. +rewrite <- opp_IZR, Zfloor_IZR. +apply Z.opp_involutive. Qed. Theorem Zceil_le : @@ -1142,7 +962,7 @@ Qed. Theorem Zceil_floor_neq : forall x : R, - (Z2R (Zfloor x) <> x)%R -> + (IZR (Zfloor x) <> x)%R -> (Zceil x = Zfloor x + 1)%Z. Proof. intros x Hx. @@ -1156,21 +976,21 @@ apply Rle_antisym. apply Zfloor_lb. exact H. apply Rlt_le. -rewrite Z2R_plus. +rewrite plus_IZR. apply Zfloor_ub. Qed. Definition Ztrunc x := if Rlt_bool x 0 then Zceil x else Zfloor x. -Theorem Ztrunc_Z2R : +Theorem Ztrunc_IZR : forall n, - Ztrunc (Z2R n) = n. + Ztrunc (IZR n) = n. Proof. intros n. unfold Ztrunc. case Rlt_bool_spec ; intro H. -apply Zceil_Z2R. -apply Zfloor_Z2R. +apply Zceil_IZR. +apply Zfloor_IZR. Qed. Theorem Ztrunc_floor : @@ -1196,9 +1016,8 @@ 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. +rewrite Zceil_IZR. +apply Zfloor_IZR. Qed. Theorem Ztrunc_le : @@ -1211,7 +1030,7 @@ 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 Z.le_trans with 0%Z. apply Zceil_glb. now apply Rlt_le. now apply Zfloor_lub. @@ -1222,14 +1041,14 @@ Qed. Theorem Ztrunc_opp : forall x, - Ztrunc (- x) = Zopp (Ztrunc 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 Zopp_involutive. +apply Z.opp_involutive. rewrite <- Ropp_0. apply Ropp_le_contravar. now apply Rlt_le. @@ -1242,7 +1061,7 @@ Qed. Theorem Ztrunc_abs : forall x, - Ztrunc (Rabs x) = Zabs (Ztrunc x). + Ztrunc (Rabs x) = Z.abs (Ztrunc x). Proof. intros x. rewrite Ztrunc_floor. 2: apply Rabs_pos. @@ -1251,19 +1070,19 @@ case Rlt_bool_spec ; intro H. rewrite Rabs_left with (1 := H). rewrite Zabs_non_eq. apply sym_eq. -apply Zopp_involutive. +apply Z.opp_involutive. apply Zceil_glb. now apply Rlt_le. rewrite Rabs_pos_eq with (1 := H). apply sym_eq. -apply Zabs_eq. +apply Z.abs_eq. now apply Zfloor_lub. Qed. Theorem Ztrunc_lub : forall n x, - (Z2R n <= Rabs x)%R -> - (n <= Zabs (Ztrunc x))%Z. + (IZR n <= Rabs x)%R -> + (n <= Z.abs (Ztrunc x))%Z. Proof. intros n x H. rewrite <- Ztrunc_abs. @@ -1273,15 +1092,15 @@ Qed. Definition Zaway x := if Rlt_bool x 0 then Zfloor x else Zceil x. -Theorem Zaway_Z2R : +Theorem Zaway_IZR : forall n, - Zaway (Z2R n) = n. + Zaway (IZR n) = n. Proof. intros n. unfold Zaway. case Rlt_bool_spec ; intro H. -apply Zfloor_Z2R. -apply Zceil_Z2R. +apply Zfloor_IZR. +apply Zceil_IZR. Qed. Theorem Zaway_ceil : @@ -1307,9 +1126,8 @@ 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. +rewrite Zfloor_IZR. +apply Zceil_IZR. Qed. Theorem Zaway_le : @@ -1322,7 +1140,7 @@ case Rlt_bool_spec ; intro Hx. unfold Zaway. case Rlt_bool_spec ; intro Hy. now apply Zfloor_le. -apply le_Z2R. +apply le_IZR. apply Rle_trans with 0%R. apply Rlt_le. apply Rle_lt_trans with (2 := Hx). @@ -1336,7 +1154,7 @@ Qed. Theorem Zaway_opp : forall x, - Zaway (- x) = Zopp (Zaway x). + Zaway (- x) = Z.opp (Zaway x). Proof. intros x. unfold Zaway at 2. @@ -1348,14 +1166,14 @@ apply Rlt_le. now apply Ropp_0_gt_lt_contravar. rewrite Zaway_floor. apply sym_eq. -apply Zopp_involutive. +apply Z.opp_involutive. rewrite <- Ropp_0. now apply Ropp_le_contravar. Qed. Theorem Zaway_abs : forall x, - Zaway (Rabs x) = Zabs (Zaway x). + Zaway (Rabs x) = Z.abs (Zaway x). Proof. intros x. rewrite Zaway_ceil. 2: apply Rabs_pos. @@ -1365,66 +1183,126 @@ 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 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 Zabs_eq. -apply le_Z2R. +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 (Z2R x / Z2R y) = (x / y)%Z. + 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': Z2R y <> R0). +assert (Zy': IZR y <> 0%R). contradict Zy. -now apply eq_Z2R. +now apply eq_IZR. 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. +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 Z2R_plus. -assert (0 <= Z2R (x mod y) * / Z2R y < 1)%R. +rewrite plus_IZR. +assert (0 <= IZR (x mod y) * / IZR y < 1)%R. (* *) -assert (forall x' y', (0 < y')%Z -> 0 <= Z2R (x' mod y') * / Z2R 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 (Z2R_le 0). +apply IZR_le. refine (proj1 (Z_mod_lt _ _ _)). -now apply Zlt_gt. +now apply Z.lt_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). +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 Z2R_lt. +apply IZR_lt. eapply Z_mod_lt. -now apply Zlt_gt. +now apply Z.lt_gt. apply Rgt_not_eq. -now apply (Z2R_lt 0). +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!Z2R_opp. +rewrite <- 2!opp_IZR. rewrite <- Zmod_opp_opp. apply H. clear -Hy. omega. @@ -1432,7 +1310,7 @@ apply H. clear -Zy Hy. omega. (* *) split. -pattern (Z2R (x / y)) at 1 ; rewrite <- Rplus_0_r. +pattern (IZR (x / y)) at 1 ; rewrite <- Rplus_0_r. apply Rplus_le_compat_l. apply H. apply Rplus_lt_compat_l. @@ -1445,11 +1323,11 @@ Section pow. Variable r : radix. -Theorem radix_pos : (0 < Z2R r)%R. +Theorem radix_pos : (0 < IZR r)%R. Proof. destruct r as (v, Hr). simpl. -apply (Z2R_lt 0). -apply Zlt_le_trans with 2%Z. +apply IZR_lt. +apply Z.lt_le_trans with 2%Z. easy. now apply Zle_bool_imp_le. Qed. @@ -1457,14 +1335,14 @@ 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)) + | Zpos p => IZR (Zpower_pos r p) + | Zneg p => Rinv (IZR (Zpower_pos r p)) | Z0 => 1%R end. -Theorem Z2R_Zpower_pos : +Theorem IZR_Zpower_pos : forall n m, - Z2R (Zpower_pos n m) = powerRZ (Z2R n) (Zpos m). + IZR (Zpower_pos n m) = powerRZ (IZR n) (Zpos m). Proof. intros. rewrite Zpower_pos_nat. @@ -1473,19 +1351,19 @@ induction (nat_of_P m). apply refl_equal. unfold Zpower_nat. simpl. -rewrite Z2R_mult. +rewrite mult_IZR. apply Rmult_eq_compat_l. exact IHn0. Qed. Theorem bpow_powerRZ : forall e, - bpow e = powerRZ (Z2R r) e. + bpow e = powerRZ (IZR r) e. Proof. destruct e ; unfold bpow. reflexivity. -now rewrite Z2R_Zpower_pos. -now rewrite Z2R_Zpower_pos. +now rewrite IZR_Zpower_pos. +now rewrite IZR_Zpower_pos. Qed. Theorem bpow_ge_0 : @@ -1517,14 +1395,14 @@ apply radix_pos. Qed. Theorem bpow_1 : - bpow 1 = Z2R r. + bpow 1 = IZR 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. +Theorem bpow_plus_1 : + forall e : Z, (bpow (e + 1) = IZR r * bpow e)%R. Proof. intros. rewrite <- bpow_1. @@ -1544,9 +1422,9 @@ apply Rgt_not_eq. apply (bpow_gt_0 (Zpos p)). Qed. -Theorem Z2R_Zpower_nat : +Theorem IZR_Zpower_nat : forall e : nat, - Z2R (Zpower_nat r e) = bpow (Z_of_nat e). + IZR (Zpower_nat r e) = bpow (Z_of_nat e). Proof. intros [|e]. split. @@ -1555,10 +1433,10 @@ rewrite <- Zpower_pos_nat. now rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P. Qed. -Theorem Z2R_Zpower : +Theorem IZR_Zpower : forall e : Z, (0 <= e)%Z -> - Z2R (Zpower r e) = bpow e. + IZR (Zpower r e) = bpow e. Proof. intros [|e|e] H. split. @@ -1579,8 +1457,8 @@ 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). +rewrite <- IZR_Zpower by easy. +apply IZR_lt. now apply Zpower_gt_1. Qed. @@ -1589,7 +1467,7 @@ Theorem lt_bpow : (bpow e1 < bpow e2)%R -> (e1 < e2)%Z. Proof. intros e1 e2 H. -apply Zgt_lt. +apply Z.gt_lt. apply Znot_le_gt. intros H'. apply Rlt_not_le with (1 := H). @@ -1608,7 +1486,7 @@ intros e1 e2 H. apply Rnot_lt_le. intros H'. apply Zle_not_gt with (1 := H). -apply Zlt_gt. +apply Z.lt_gt. now apply lt_bpow. Qed. @@ -1621,7 +1499,7 @@ apply Znot_gt_le. intros H'. apply Rle_not_lt with (1 := H). apply bpow_lt. -now apply Zgt_lt. +now apply Z.gt_lt. Qed. Theorem bpow_inj : @@ -1638,15 +1516,15 @@ Qed. Theorem bpow_exp : forall e : Z, - bpow e = exp (Z2R e * ln (Z2R r)). + bpow e = exp (IZR e * ln (IZR r)). Proof. (* positive case *) -assert (forall e, bpow (Zpos e) = exp (Z2R (Zpos e) * ln (Z2R r))). +assert (forall e, bpow (Zpos e) = exp (IZR (Zpos e) * ln (IZR r))). intros e. unfold bpow. rewrite Zpower_pos_nat. -unfold Z2R at 2. -rewrite P2R_INR. +rewrite <- positive_nat_Z. +rewrite <- INR_IZR_INZ. induction (nat_of_P e). rewrite Rmult_0_l. now rewrite exp_0. @@ -1657,7 +1535,7 @@ rewrite exp_plus. rewrite Rmult_1_l. rewrite exp_ln. rewrite <- IHn. -rewrite <- Z2R_mult. +rewrite <- mult_IZR. now rewrite Zmult_comm. apply radix_pos. (* general case *) @@ -1666,31 +1544,50 @@ rewrite Rmult_0_l. now rewrite exp_0. apply H. unfold bpow. -change (Z2R (Zpower_pos r e)) with (bpow (Zpos e)). +change (IZR (Zpower_pos r e)) with (bpow (Zpos e)). rewrite H. rewrite <- exp_Ropp. rewrite <- Ropp_mult_distr_l_reverse. -now rewrite <- Z2R_opp. +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. -(** 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 +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 ln_beta : - forall x : R, ln_beta_prop x. +Definition mag : + forall x : R, mag_prop x. Proof. intros x. -set (fact := ln (Z2R r)). +set (fact := ln (IZR r)). (* . *) assert (0 < fact)%R. apply exp_lt_inv. rewrite exp_0. unfold fact. rewrite exp_ln. -apply (Z2R_lt 1). +apply IZR_lt. apply radix_gt_1. apply radix_pos. (* . *) @@ -1703,19 +1600,19 @@ rewrite 2!bpow_exp. fold fact. pattern x at 2 3 ; replace x with (exp (ln x * / fact * fact)). split. -rewrite Z2R_minus. +rewrite minus_IZR. apply exp_le. apply Rmult_le_compat_r. now apply Rlt_le. unfold Rminus. -rewrite Z2R_plus. +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 Z2R_plus. +rewrite plus_IZR. apply Zfloor_ub. rewrite Rmult_assoc. rewrite Rinv_l. @@ -1748,55 +1645,55 @@ apply Zle_antisym ; assumption. Qed. -Theorem ln_beta_unique : +Theorem mag_unique : forall (x : R) (e : Z), (bpow (e - 1) <= Rabs x < bpow e)%R -> - ln_beta x = e :> Z. + 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 (ln_beta x) as (e2, Hx2). +destruct (mag x) as (e2, Hx2). simpl. apply bpow_unique with (2 := He). now apply Hx2. Qed. -Theorem ln_beta_opp : +Theorem mag_opp : forall x, - ln_beta (-x) = ln_beta x :> Z. + mag (-x) = mag 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). +destruct (mag x) as (e, He). simpl. specialize (He Hx). -apply ln_beta_unique. +apply mag_unique. now rewrite Rabs_Ropp. Qed. -Theorem ln_beta_abs : +Theorem mag_abs : forall x, - ln_beta (Rabs x) = ln_beta x :> Z. + mag (Rabs x) = mag x :> Z. Proof. intros x. unfold Rabs. case Rcase_abs ; intros _. -apply ln_beta_opp. +apply mag_opp. apply refl_equal. Qed. -Theorem ln_beta_unique_pos : +Theorem mag_unique_pos : forall (x : R) (e : Z), (bpow (e - 1) <= x < bpow e)%R -> - ln_beta x = e :> Z. + mag x = e :> Z. Proof. intros x e1 He1. -rewrite <- ln_beta_abs. -apply ln_beta_unique. +rewrite <- mag_abs. +apply mag_unique. rewrite 2!Rabs_pos_eq. exact He1. apply Rle_trans with (2 := proj1 He1). @@ -1804,14 +1701,14 @@ apply bpow_ge_0. apply Rabs_pos. Qed. -Theorem ln_beta_le_abs : +Theorem mag_le_abs : forall x y, (x <> 0)%R -> (Rabs x <= Rabs y)%R -> - (ln_beta x <= ln_beta y)%Z. + (mag x <= mag y)%Z. Proof. intros x y H0x Hxy. -destruct (ln_beta x) as (ex, Hx). -destruct (ln_beta y) as (ey, Hy). +destruct (mag x) as (ex, Hx). +destruct (mag y) as (ey, Hy). simpl. apply bpow_lt_bpow. specialize (Hx H0x). @@ -1825,13 +1722,13 @@ rewrite Hy', Rabs_R0. apply Rle_refl. Qed. -Theorem ln_beta_le : +Theorem mag_le : forall x y, (0 < x)%R -> (x <= y)%R -> - (ln_beta x <= ln_beta y)%Z. + (mag x <= mag y)%Z. Proof. intros x y H0x Hxy. -apply ln_beta_le_abs. +apply mag_le_abs. now apply Rgt_not_eq. rewrite 2!Rabs_pos_eq. exact Hxy. @@ -1840,17 +1737,17 @@ now apply Rlt_le. now apply Rlt_le. Qed. -Lemma ln_beta_lt_pos : +Lemma lt_mag : forall x y, (0 < y)%R -> - (ln_beta x < ln_beta y)%Z -> (x < 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 (ln_beta x) as (ex, Hex). -destruct (ln_beta y) as (ey, Hey). +destruct (mag x) as (ex, Hex). +destruct (mag y) as (ey, Hey). simpl. intro H. destruct Hex as (_,Hex); [now apply Rgt_not_eq|]. @@ -1862,11 +1759,11 @@ 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. +Theorem mag_bpow : + forall e, (mag (bpow e) = e + 1 :> Z)%Z. Proof. intros e. -apply ln_beta_unique. +apply mag_unique. rewrite Rabs_right. replace (e + 1 - 1)%Z with e by ring. split. @@ -1877,14 +1774,14 @@ apply Rle_ge. apply bpow_ge_0. Qed. -Theorem ln_beta_mult_bpow : +Theorem mag_mult_bpow : forall x e, x <> 0%R -> - (ln_beta (x * bpow e) = ln_beta x + e :>Z)%Z. + (mag (x * bpow e) = mag x + e :>Z)%Z. Proof. intros x e Zx. -destruct (ln_beta x) as (ex, Ex) ; simpl. +destruct (mag x) as (ex, Ex) ; simpl. specialize (Ex Zx). -apply ln_beta_unique. +apply mag_unique. rewrite Rabs_mult. rewrite (Rabs_pos_eq (bpow e)) by apply bpow_ge_0. split. @@ -1899,26 +1796,26 @@ apply bpow_gt_0. apply Ex. Qed. -Theorem ln_beta_le_bpow : +Theorem mag_le_bpow : forall x e, x <> 0%R -> (Rabs x < bpow e)%R -> - (ln_beta x <= e)%Z. + (mag x <= e)%Z. Proof. intros x e Zx Hx. -destruct (ln_beta x) as (ex, Ex) ; simpl. +destruct (mag 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 : +Theorem mag_gt_bpow : forall x e, (bpow e <= Rabs x)%R -> - (e < ln_beta x)%Z. + (e < mag x)%Z. Proof. intros x e Hx. -destruct (ln_beta x) as (ex, Ex) ; simpl. +destruct (mag x) as (ex, Ex) ; simpl. apply lt_bpow. apply Rle_lt_trans with (1 := Hx). apply Ex. @@ -1928,92 +1825,92 @@ rewrite Zx, Rabs_R0. apply bpow_gt_0. Qed. -Theorem ln_beta_ge_bpow : +Theorem mag_ge_bpow : forall x e, (bpow (e - 1) <= Rabs x)%R -> - (e <= ln_beta x)%Z. + (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 (ln_beta x = e :> Z) as Hln. - now apply ln_beta_unique; split. + 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 ln_beta_gt_bpow. + now apply mag_gt_bpow. Qed. -Theorem bpow_ln_beta_gt : +Theorem bpow_mag_gt : forall x, - (Rabs x < bpow (ln_beta x))%R. + (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 (ln_beta x) as (ex, Ex) ; simpl. +destruct (mag x) as (ex, Ex) ; simpl. now apply Ex. Qed. -Theorem bpow_ln_beta_le : +Theorem bpow_mag_le : forall x, (x <> 0)%R -> - (bpow (ln_beta x-1) <= Rabs x)%R. + (bpow (mag x-1) <= Rabs x)%R. Proof. intros x Hx. -destruct (ln_beta x) as (ex, Ex) ; simpl. +destruct (mag x) as (ex, Ex) ; simpl. now apply Ex. Qed. -Theorem ln_beta_le_Zpower : +Theorem mag_le_Zpower : forall m e, m <> Z0 -> - (Zabs m < Zpower r e)%Z-> - (ln_beta (Z2R m) <= e)%Z. + (Z.abs m < Zpower r e)%Z-> + (mag (IZR m) <= e)%Z. Proof. intros m e Zm Hm. -apply ln_beta_le_bpow. -exact (Z2R_neq m 0 Zm). +apply mag_le_bpow. +now apply IZR_neq. destruct (Zle_or_lt 0 e). -rewrite <- Z2R_abs, <- Z2R_Zpower with (1 := H). -now apply Z2R_lt. +rewrite <- abs_IZR, <- IZR_Zpower with (1 := H). +now apply IZR_lt. elim Zm. -cut (Zabs m < 0)%Z. +cut (Z.abs m < 0)%Z. now case m. clear -Hm H. now destruct e. Qed. -Theorem ln_beta_gt_Zpower : +Theorem mag_gt_Zpower : forall m e, m <> Z0 -> - (Zpower r e <= Zabs m)%Z -> - (e < ln_beta (Z2R m))%Z. + (Zpower r e <= Z.abs m)%Z -> + (e < mag (IZR m))%Z. Proof. intros m e Zm Hm. -apply ln_beta_gt_bpow. -rewrite <- Z2R_abs. +apply mag_gt_bpow. +rewrite <- abs_IZR. destruct (Zle_or_lt 0 e). -rewrite <- Z2R_Zpower with (1 := H). -now apply Z2R_le. +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 (Z2R_le 1). +apply IZR_le. clear -Zm. zify ; omega. Qed. -Lemma ln_beta_mult : +Lemma mag_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. + (mag x + mag y - 1 <= mag (x * y) <= mag x + mag y)%Z. Proof. intros x y Hx Hy. -destruct (ln_beta x) as (ex, Hx2). -destruct (ln_beta y) as (ey, Hy2). +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. @@ -2029,26 +1926,26 @@ assert (Hxy2 : (Rabs (x * y) < bpow (ex + ey))%R). 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 mag_ge_bpow. +- apply mag_le_bpow. + now apply Rmult_integral_contrapositive_currified. + assumption. Qed. -Lemma ln_beta_plus : +Lemma mag_plus : forall x y, (0 < y)%R -> (y <= x)%R -> - (ln_beta x <= ln_beta (x + y) <= ln_beta x + 1)%Z. + (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 (ln_beta x) as (ex,Hex); simpl. +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_plus1. +{ 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. @@ -2062,7 +1959,7 @@ assert (Haxy : (Rabs (x + y) < bpow (ex + 1))%R). now apply Rlt_le, Rplus_lt_compat. - apply Rmult_le_compat_r. now apply bpow_ge_0. - now apply (Z2R_le 2). } + now apply IZR_le. } assert (Haxy2 : (bpow (ex - 1) <= Rabs (x + y))%R). { apply (Rle_trans _ _ _ Hex0). rewrite Rabs_right; [|now apply Rgt_ge]. @@ -2071,20 +1968,20 @@ assert (Haxy2 : (bpow (ex - 1) <= Rabs (x + y))%R). apply Rplus_le_compat_l. now apply Rlt_le. } split. -- now apply ln_beta_ge_bpow. -- apply ln_beta_le_bpow. +- now apply mag_ge_bpow. +- apply mag_le_bpow. + now apply tech_Rplus; [apply Rlt_le|]. + exact Haxy. Qed. -Lemma ln_beta_minus : +Lemma mag_minus : forall x y, (0 < y)%R -> (y < x)%R -> - (ln_beta (x - y) <= ln_beta x)%Z. + (mag (x - y) <= mag x)%Z. Proof. intros x y Py Hxy. assert (Px : (0 < x)%R) by apply (Rlt_trans _ _ _ Py Hxy). -apply ln_beta_le. +apply mag_le. - now apply Rlt_Rminus. - rewrite <- (Rplus_0_r x) at 2. apply Rplus_le_compat_l. @@ -2092,19 +1989,19 @@ apply ln_beta_le. now apply Ropp_le_contravar; apply Rlt_le. Qed. -Lemma ln_beta_minus_lb : +Lemma mag_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. + (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 ln_beta_lt_pos;[assumption|omega]|]. -destruct (ln_beta x) as (ex,Hex). -destruct (ln_beta y) as (ey,Hey). +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|]. @@ -2112,9 +2009,9 @@ 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. + rewrite bpow_plus_1. apply Rmult_le_compat_r; [now apply bpow_ge_0|]. - now change 2%R with (Z2R 2); apply Z2R_le. + 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). @@ -2126,98 +2023,95 @@ assert (Hbxy : (bpow (ex - 2) <= x - y)%R). 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. +apply mag_ge_bpow. replace (ex - 1 - 1)%Z with (ex - 2)%Z by ring. now apply Rabs_ge; right. Qed. -Lemma ln_beta_div : +Lemma mag_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. + 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 (ln_beta x) as (ex,Hex). -destruct (ln_beta y) as (ey,Hey). +destruct (mag x) as (ex,Hex). +destruct (mag 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. +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; [exact Py|]. + + apply Rmult_lt_0_compat. + now apply Rabs_pos_lt. now apply bpow_gt_0. - + apply Hey. - now apply Rgt_not_eq. + + now apply Hey. - 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. } + now apply Hey. } split. -- apply ln_beta_ge_bpow. - apply Rabs_ge; right. +- 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. - + 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. + + 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 * / y)%R. - * apply Rmult_lt_compat_r; [now apply Rinv_0_lt_compat|]. - apply Hex. - now apply Rgt_not_eq. + 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 ln_beta_sqrt : +Lemma mag_sqrt : forall x, (0 < x)%R -> - (2 * ln_beta (sqrt x) - 1 <= ln_beta x <= 2 * ln_beta (sqrt x))%Z. + mag (sqrt x) = Z.div2 (mag x + 1) :> 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| |]. } +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. -- now apply ln_beta_ge_bpow. -- now apply ln_beta_le_bpow; [now apply Rgt_not_eq|]. +- 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. @@ -2248,12 +2142,12 @@ Section cond_Ropp. Definition cond_Ropp (b : bool) m := if b then Ropp m else m. -Theorem Z2R_cond_Zopp : +Theorem IZR_cond_Zopp : forall b m, - Z2R (cond_Zopp b m) = cond_Ropp b (Z2R m). + IZR (cond_Zopp b m) = cond_Ropp b (IZR m). Proof. intros [|] m. -apply Z2R_opp. +apply opp_IZR. apply refl_equal. Qed. @@ -2286,22 +2180,6 @@ 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. @@ -2391,7 +2269,7 @@ destruct (Rle_lt_dec l 0) as [Hl|Hl]. apply ub. now apply HE. left. -set (N := Zabs_nat (up (/l) - 2)). +set (N := Z.abs_nat (up (/l) - 2)). exists N. assert (HN: (INR N + 1 = IZR (up (/ l)) - 1)%R). unfold N. @@ -2399,7 +2277,7 @@ assert (HN: (INR N + 1 = IZR (up (/ l)) - 1)%R). 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 Z.abs_eq. apply Zle_minus_le_0. apply (Zlt_le_succ 1). apply lt_IZR. @@ -2484,10 +2362,10 @@ 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 <- (Z.abs_eq n); trivial. rewrite <- Zabs2Nat.id_abs. apply J. -rewrite <- (Zopp_involutive n). +rewrite <- (Z.opp_involutive n). rewrite <- (Z.abs_neq n). rewrite <- Zabs2Nat.id_abs. apply K. diff --git a/flocq/Core/Fcore_rnd_ne.v b/flocq/Core/Round_NE.v index 2d67e709..20b60ef5 100644 --- a/flocq/Core/Fcore_rnd_ne.v +++ b/flocq/Core/Round_NE.v @@ -2,9 +2,9 @@ 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) 2009-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +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 @@ -18,14 +18,9 @@ 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. +Require Import Raux Defs Round_pred Generic_fmt Float_prop Ulp. -Notation ZnearestE := (Znearest (fun x => negb (Zeven x))). +Notation ZnearestE := (Znearest (fun x => negb (Z.even x))). Section Fcore_rnd_NE. @@ -38,10 +33,10 @@ Variable fexp : Z -> Z. Context { valid_exp : Valid_exp fexp }. Notation format := (generic_format beta fexp). -Notation canonic := (canonic beta fexp). +Notation canonical := (canonical beta fexp). Definition NE_prop (_ : R) f := - exists g : float beta, f = F2R g /\ canonic g /\ Zeven (Fnum g) = true. + exists g : float beta, f = F2R g /\ canonical g /\ Z.even (Fnum g) = true. Definition Rnd_NE_pt := Rnd_NG_pt format NE_prop. @@ -50,20 +45,20 @@ Definition DN_UP_parity_pos_prop := forall x xd xu, (0 < x)%R -> ~ format x -> - canonic xd -> - canonic xu -> + canonical xd -> + canonical xu -> F2R xd = round beta fexp Zfloor x -> F2R xu = round beta fexp Zceil x -> - Zeven (Fnum xu) = negb (Zeven (Fnum xd)). + Z.even (Fnum xu) = negb (Z.even (Fnum xd)). Definition DN_UP_parity_prop := forall x xd xu, ~ format x -> - canonic xd -> - canonic xu -> + canonical xd -> + canonical xu -> F2R xd = round beta fexp Zfloor x -> F2R xu = round beta fexp Zceil x -> - Zeven (Fnum xu) = negb (Zeven (Fnum xd)). + Z.even (Fnum xu) = negb (Z.even (Fnum xd)). Lemma DN_UP_parity_aux : DN_UP_parity_pos_prop -> @@ -83,18 +78,18 @@ now rewrite Ropp_involutive, Ropp_0. destruct xd as (md, ed). destruct xu as (mu, eu). simpl. -rewrite <- (Bool.negb_involutive (Zeven mu)). +rewrite <- (Bool.negb_involutive (Z.even 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)))). +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 canonic_opp. -now apply canonic_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. @@ -102,7 +97,7 @@ now apply f_equal. Qed. Class Exists_NE := - exists_NE : Zeven beta = false \/ forall e, + 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 }. @@ -111,22 +106,22 @@ 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). +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 F2R_eq_0_reg with beta (Fexp xd). +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 canonic_unicity with (1 := Hu). +apply canonical_unique with (1 := Hu). apply (f_equal fexp). rewrite <- F2R_change_exp. -now rewrite F2R_bpow, ln_beta_bpow. +now rewrite F2R_bpow, mag_bpow. now apply valid_exp. rewrite <- F2R_change_exp. rewrite F2R_bpow. @@ -172,10 +167,10 @@ 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 canonical_unique with (1 := Hu). apply (f_equal fexp). rewrite <- F2R_change_exp. -now rewrite F2R_bpow, ln_beta_bpow. +now rewrite F2R_bpow, mag_bpow. now apply valid_exp. rewrite <- Hu2. apply sym_eq. @@ -185,15 +180,15 @@ 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. +rewrite minus_IZR. unfold Rminus. rewrite Rmult_plus_distr_r. -rewrite Z2R_Zpower, <- bpow_plus. +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 canonic_exp. -rewrite ln_beta_unique with beta x ex. +unfold cexp. +rewrite mag_unique with beta x ex. unfold F2R. simpl. ring. rewrite Rabs_pos_eq. @@ -201,25 +196,25 @@ 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 canonical_unique with (1 := Hd) (3 := H). apply (f_equal fexp). rewrite <- H. apply sym_eq. -now apply ln_beta_unique. +now apply mag_unique. rewrite Hd3, Hu3. unfold Fnum. -rewrite Zeven_mult. simpl. +rewrite Z.even_mul. simpl. unfold Zminus at 2. -rewrite Zeven_plus. +rewrite Z.even_add. rewrite eqb_sym. simpl. -fold (negb (Zeven (beta ^ (ex - fexp ex)))). +fold (negb (Z.even (beta ^ (ex - fexp ex)))). rewrite Bool.negb_involutive. -rewrite (Zeven_Zpower beta (ex - fexp ex)). 2: omega. +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 Zeven_Zpower. +apply Z.even_pow. specialize (H ex). omega. (* - xu < bpow ex *) @@ -227,17 +222,17 @@ 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). +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 Zeven_plus. +rewrite Z.even_add. now apply eqb_sym. apply sym_eq. -apply eq_Z2R. -rewrite Z2R_plus. +apply eq_IZR. +rewrite plus_IZR. apply Rmult_eq_reg_r with (bpow (fexp ex)). rewrite H. simpl. ring. @@ -270,38 +265,38 @@ 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 (ed := cexp beta fexp d). set (md := Ztrunc (scaled_mantissa beta fexp d)). intros Hd1. -case_eq (Zeven md) ; [ intros He | intros Ho ]. +case_eq (Z.even md) ; [ intros He | intros Ho ]. right. exists (Float beta md ed). -unfold Fcore_generic_fmt.canonic. +unfold Generic_fmt.canonical. rewrite <- Hd1. now repeat split. left. generalize (proj1 Hu). unfold generic_format. -set (eu := canonic_exp beta fexp u). +set (eu := cexp beta fexp u). set (mu := Ztrunc (scaled_mantissa beta fexp u)). intros Hu1. rewrite Hu1. eexists ; repeat split. -unfold Fcore_generic_fmt.canonic. +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 Fcore_generic_fmt.canonic. +unfold Generic_fmt.canonical. now rewrite <- Hd1. -unfold Fcore_generic_fmt.canonic. +unfold Generic_fmt.canonical. now rewrite <- Hu1. rewrite <- Hd1. -apply Rnd_DN_pt_unicity with (1 := Hd). +apply Rnd_DN_pt_unique with (1 := Hd). now apply round_DN_pt. rewrite <- Hu1. -apply Rnd_UP_pt_unicity with (1 := Hu). +apply Rnd_UP_pt_unique with (1 := Hu). now apply round_UP_pt. Qed. @@ -323,15 +318,16 @@ apply Hx. apply sym_eq. now apply Rnd_DN_pt_idempotent with (1 := Hd). rewrite <- Hd1. -apply Rnd_DN_pt_unicity with (1 := Hd). +apply Rnd_DN_pt_unique with (1 := Hd). now apply round_DN_pt. rewrite <- Hu1. -apply Rnd_UP_pt_unicity with (1 := Hu). +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. @@ -348,14 +344,14 @@ 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]. +destruct (Req_dec (mx - IZR (Zfloor mx)) (/2)) as [Hm|Hm]. (* midpoint *) left. -exists (Float beta (Ztrunc (scaled_mantissa beta fexp xr)) (canonic_exp beta fexp xr)). +exists (Float beta (Ztrunc (scaled_mantissa beta fexp xr)) (cexp beta fexp xr)). split. apply round_N_pt... split. -unfold Fcore_generic_fmt.canonic. simpl. +unfold Generic_fmt.canonical. simpl. apply f_equal. apply round_N_pt... simpl. @@ -363,23 +359,22 @@ unfold xr, round, Znearest. fold mx. rewrite Hm. rewrite Rcompare_Eq. 2: apply refl_equal. -case_eq (Zeven (Zfloor mx)) ; intros Hmx. +case_eq (Z.even (Zfloor mx)) ; intros Hmx. (* . even floor *) -change (Zeven (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zfloor x))) = true). +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. -change 0%R with (Z2R 0). -now rewrite (Ztrunc_Z2R 0). +now rewrite Ztrunc_IZR. rewrite <- (round_0 beta fexp Zfloor). apply round_le... now apply Rlt_le. rewrite scaled_mantissa_DN... -now rewrite Ztrunc_Z2R. +now rewrite Ztrunc_IZR. (* . odd floor *) -change (Zeven (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zceil x))) = true). -destruct (ln_beta beta x) as (ex, Hex). +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]. @@ -394,56 +389,56 @@ 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). +now apply IZR_lt. destruct (proj2 Hu) as [Hu'|Hu']. (* ... u <> bpow *) unfold scaled_mantissa. -rewrite canonic_exp_fexp_pos with (1 := conj (proj1 Hu) Hu'). +rewrite cexp_fexp_pos with (1 := conj (proj1 Hu) Hu'). unfold round, F2R. simpl. -rewrite canonic_exp_fexp_pos with (1 := Hex). +rewrite cexp_fexp_pos with (1 := Hex). rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r. -rewrite Ztrunc_Z2R. +rewrite Ztrunc_IZR. fold mx. rewrite Hfc. -now rewrite Zeven_plus, Hmx. +now rewrite Z.even_add, 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. +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 Zeven_Zpower. +rewrite Z.even_pow. exact Hr. omega. -assert (Zeven (Zfloor mx) = true). 2: now rewrite H in Hmx. +assert (Z.even (Zfloor mx) = true). 2: now rewrite H in Hmx. replace (Zfloor mx) with (Zceil mx + -1)%Z by omega. -rewrite Zeven_plus. +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_Z2R. -rewrite Z2R_Zpower. 2: 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 <- canonic_exp_fexp_pos with (1 := Hex). +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 (Zeven (Zfloor mx) = true). 2: now rewrite H in Hmx. +assert (Z.even (Zfloor mx) = true). 2: now rewrite H in Hmx. unfold mx, scaled_mantissa. -rewrite canonic_exp_fexp_pos with (1 := Hex). +rewrite cexp_fexp_pos with (1 := Hex). now rewrite mantissa_DN_small_pos. (* not midpoint *) right. @@ -456,7 +451,7 @@ 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). +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. @@ -467,7 +462,7 @@ intros H. apply Rmult_eq_reg_r in H. apply Hm. apply Rcompare_Eq_inv. -rewrite Rcompare_floor_ceil_mid. +rewrite Rcompare_floor_ceil_middle. now apply Rcompare_Eq. contradict Hxg. apply sym_eq. @@ -475,7 +470,7 @@ 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. +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. @@ -487,7 +482,7 @@ Theorem round_NE_opp : Proof. intros x. unfold round. simpl. -rewrite scaled_mantissa_opp, canonic_exp_opp. +rewrite scaled_mantissa_opp, cexp_opp. rewrite Znearest_opp. rewrite <- F2R_Zopp. apply (f_equal (fun v => F2R (Float beta (-v) _))). @@ -496,8 +491,8 @@ 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. +rewrite Z.even_opp. +rewrite Z.even_add. now rewrite eqb_sym. Qed. @@ -526,7 +521,7 @@ Theorem round_NE_pt : Proof with auto with typeclass_instances. intros x. destruct (total_order_T x 0) as [[Hx|Hx]|Hx]. -apply Rnd_NG_pt_sym. +apply Rnd_NG_pt_opp_inv. apply generic_format_opp. unfold NE_prop. intros _ f ((mg,eg),(H1,(H2,H3))). @@ -534,9 +529,9 @@ exists (Float beta (- mg) eg). repeat split. rewrite H1. now rewrite F2R_Zopp. -now apply canonic_opp. +now apply canonical_opp. simpl. -now rewrite Zeven_opp. +now rewrite Z.even_opp. rewrite <- round_NE_opp. apply round_NE_pt_pos. now apply Ropp_0_gt_lt_contravar. diff --git a/flocq/Core/Fcore_rnd.v b/flocq/Core/Round_pred.v index e5091684..428a4bac 100644 --- a/flocq/Core/Fcore_rnd.v +++ b/flocq/Core/Round_pred.v @@ -2,9 +2,9 @@ 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) 2009-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +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 @@ -18,13 +18,30 @@ COPYING file for more details. *) (** * Roundings: properties and/or functions *) -Require Import Fcore_Raux. -Require Import Fcore_defs. +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 -> @@ -63,7 +80,7 @@ intros x. now destruct round_val_of_pred as (f, H1). Qed. -Theorem round_unicity : +Theorem round_unique : forall rnd : R -> R -> Prop, round_pred_monotone rnd -> forall x f1 f2, @@ -87,25 +104,25 @@ apply Hx1. now apply Rle_trans with (2 := Hxy). Qed. -Theorem Rnd_DN_pt_unicity : +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_unicity. +apply round_unique. apply Rnd_DN_pt_monotone. Qed. -Theorem Rnd_DN_unicity : +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_unicity. +now eapply Rnd_DN_pt_unique. Qed. Theorem Rnd_UP_pt_monotone : @@ -118,28 +135,28 @@ apply Hy1. now apply Rle_trans with (1 := Hxy). Qed. -Theorem Rnd_UP_pt_unicity : +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_unicity. +apply round_unique. apply Rnd_UP_pt_monotone. Qed. -Theorem Rnd_UP_unicity : +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_unicity. +now eapply Rnd_UP_pt_unique. Qed. -Theorem Rnd_DN_UP_pt_sym : +Theorem Rnd_UP_pt_opp : forall F : R -> Prop, ( forall x, F x -> F (- x) ) -> forall x f : R, @@ -160,7 +177,7 @@ now apply HF. now apply Ropp_le_cancel. Qed. -Theorem Rnd_UP_DN_pt_sym : +Theorem Rnd_DN_pt_opp : forall F : R -> Prop, ( forall x, F x -> F (- x) ) -> forall x f : R, @@ -181,7 +198,7 @@ now apply HF. now apply Ropp_le_cancel. Qed. -Theorem Rnd_DN_UP_sym : +Theorem Rnd_DN_opp : forall F : R -> Prop, ( forall x, F x -> F (- x) ) -> forall rnd1 rnd2 : R -> R, @@ -191,10 +208,10 @@ 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. +apply (Rnd_UP_unique F (fun x => - rnd1 (-x))) ; trivial. intros y. pattern y at 1 ; rewrite <- Ropp_involutive. -apply Rnd_DN_UP_pt_sym. +apply Rnd_UP_pt_opp. apply HF. apply H1. Qed. @@ -303,18 +320,17 @@ apply Rle_refl. (* . *) destruct (Rle_or_lt 0 x). (* positive *) -rewrite Rabs_right. -rewrite Rabs_right; auto with real. +rewrite Rabs_pos_eq with (1 := H1). +rewrite Rabs_pos_eq. now apply (proj1 (H x)). -apply Rle_ge. now apply (proj1 (H x)). (* negative *) +apply Rlt_le in H1. +rewrite Rabs_left1 with (1 := H1). 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. +now apply (proj2 (H x)). +now apply (proj2 (H x)). Qed. Theorem Rnd_ZR_pt_monotone : @@ -385,12 +401,12 @@ 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). +apply Rnd_DN_pt_unique with (1 := H) (2 := Hd). right. -apply Rnd_UP_pt_unicity with (1 := H) (2 := Hu). +apply Rnd_UP_pt_unique with (1 := H) (2 := Hu). Qed. -Theorem Rnd_N_pt_sym : +Theorem Rnd_N_pt_opp_inv : forall F : R -> Prop, ( forall x, F x -> F (- x) ) -> forall x f : R, @@ -449,7 +465,7 @@ apply Rminus_lt. ring_simplify. apply Rlt_minus. apply Rmult_lt_compat_l. -now apply (Z2R_lt 0 2). +now apply IZR_lt. exact Hxy. now apply Rlt_minus. apply Rle_0_minus. @@ -460,7 +476,7 @@ now apply Rlt_le. now apply Rlt_minus. Qed. -Theorem Rnd_N_pt_unicity : +Theorem Rnd_N_pt_unique : forall F : R -> Prop, forall x d u f1 f2 : R, Rnd_DN_pt F x d -> @@ -476,10 +492,10 @@ 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). +now apply Rnd_DN_pt_unique 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 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. @@ -495,7 +511,7 @@ 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). +now apply Rnd_UP_pt_unique with (1 := Hu2). intros Hf1 Hf2. now apply Rle_antisym ; apply Rnot_lt_le ; refine (H _ _ _ _). Qed. @@ -547,7 +563,7 @@ rewrite 2!Rminus_0_r, Rabs_R0. apply Rabs_pos. Qed. -Theorem Rnd_N_pt_pos : +Theorem Rnd_N_pt_ge_0 : forall F : R -> Prop, F 0 -> forall x f, 0 <= x -> Rnd_N_pt F x f -> @@ -563,7 +579,7 @@ now rewrite Hx. exact HF. Qed. -Theorem Rnd_N_pt_neg : +Theorem Rnd_N_pt_le_0 : forall F : R -> Prop, F 0 -> forall x f, x <= 0 -> Rnd_N_pt F x f -> @@ -589,20 +605,20 @@ 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. +apply Rnd_N_pt_opp_inv. exact HF. now rewrite 2!Ropp_involutive. -apply Rnd_N_pt_neg with (3 := Hxf). +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_pos with (3 := Hxf). +apply Rnd_N_pt_ge_0 with (3 := Hxf). exact HF0. now apply Rge_le. Qed. -Theorem Rnd_DN_UP_pt_N : +Theorem Rnd_N_pt_DN_UP : forall F : R -> Prop, forall x d u f : R, F f -> @@ -635,7 +651,7 @@ apply Rle_trans with (2 := Hgu). apply Hxu. Qed. -Theorem Rnd_DN_pt_N : +Theorem Rnd_N_pt_DN : forall F : R -> Prop, forall x d u : R, Rnd_DN_pt F x d -> @@ -649,14 +665,14 @@ 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 Rnd_N_pt_DN_UP with (2 := Hd) (3 := Hu). apply Hd. rewrite Hdx. apply Rle_refl. now rewrite Hdx. Qed. -Theorem Rnd_UP_pt_N : +Theorem Rnd_N_pt_UP : forall F : R -> Prop, forall x d u : R, Rnd_DN_pt F x d -> @@ -669,22 +685,22 @@ 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 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_unicity_prop F P := +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_unicity : +Theorem Rnd_NG_pt_unique : forall (F : R -> Prop) (P : R -> R -> Prop), - Rnd_NG_pt_unicity_prop F P -> + 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. @@ -694,11 +710,11 @@ 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. +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_unicity ; eassumption. +eapply Rnd_UP_pt_unique ; eassumption. now apply H2b. apply sym_eq. now apply H1b. @@ -706,14 +722,14 @@ Qed. Theorem Rnd_NG_pt_monotone : forall (F : R -> Prop) (P : R -> R -> Prop), - Rnd_NG_pt_unicity_prop F P -> + 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_unicity ; try split ; eassumption. +eapply Rnd_NG_pt_unique ; try split ; eassumption. Qed. Theorem Rnd_NG_pt_refl : @@ -728,7 +744,7 @@ intros f2 Hf2. now apply Rnd_N_pt_idempotent with F. Qed. -Theorem Rnd_NG_pt_sym : +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) ) -> @@ -737,7 +753,7 @@ Theorem Rnd_NG_pt_sym : Proof. intros F P HF HP x f (H1,H2). split. -now apply Rnd_N_pt_sym. +now apply Rnd_N_pt_opp_inv. destruct H2 as [H2|H2]. left. rewrite <- (Ropp_involutive x), <- (Ropp_involutive f). @@ -748,20 +764,20 @@ rewrite <- (Ropp_involutive f). rewrite <- H2 with (-f2). apply sym_eq. apply Ropp_involutive. -apply Rnd_N_pt_sym. +apply Rnd_N_pt_opp_inv. exact HF. now rewrite 2!Ropp_involutive. Qed. -Theorem Rnd_NG_unicity : +Theorem Rnd_NG_unique : forall (F : R -> Prop) (P : R -> R -> Prop), - Rnd_NG_pt_unicity_prop F P -> + 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_unicity with F P x. +now apply Rnd_NG_pt_unique with F P x. Qed. Theorem Rnd_NA_NG_pt : @@ -775,7 +791,7 @@ 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). +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]. @@ -784,12 +800,12 @@ right. intros f2 Hxf2. specialize (H2 _ Hxf2). destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H4|H4]. -eapply Rnd_DN_pt_unicity ; eassumption. +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_pos with F x. +now apply Rnd_N_pt_ge_0 with F x. apply Rle_trans with x. apply H3. apply H4. @@ -803,8 +819,8 @@ 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). +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]. @@ -820,7 +836,7 @@ 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). +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]. @@ -842,15 +858,15 @@ 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. +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_neg F HF x f Hx H1). -assert (Hf2 := Rnd_N_pt_neg F HF x f2 Hx Hxf2). +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. @@ -865,10 +881,10 @@ rewrite (H2 _ Hxf2). apply Rle_refl. Qed. -Theorem Rnd_NA_pt_unicity_prop : +Lemma Rnd_NA_pt_unique_prop : forall F : R -> Prop, F 0 -> - Rnd_NG_pt_unicity_prop F (fun a b => (Rabs a <= Rabs b)%R). + 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. @@ -892,7 +908,7 @@ apply HF. now apply Rlt_le. Qed. -Theorem Rnd_NA_pt_unicity : +Theorem Rnd_NA_pt_unique : forall F : R -> Prop, F 0 -> forall x f1 f2 : R, @@ -900,12 +916,12 @@ Theorem Rnd_NA_pt_unicity : 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). +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_N_pt : +Theorem Rnd_NA_pt_N : forall F : R -> Prop, F 0 -> forall x f : R, @@ -936,29 +952,29 @@ 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 ). +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 (Z2R_le 0 2). +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_neg F HF x) ; assumption ). +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 (Z2R_le 0 2). +now apply IZR_le. now apply Ropp_le_cancel. Qed. -Theorem Rnd_NA_unicity : +Theorem Rnd_NA_unique : forall (F : R -> Prop), F 0 -> forall rnd1 rnd2 : R -> R, @@ -966,7 +982,7 @@ Theorem Rnd_NA_unicity : forall x, rnd1 x = rnd2 x. Proof. intros F HF rnd1 rnd2 H1 H2 x. -now apply Rnd_NA_pt_unicity with F x. +now apply Rnd_NA_pt_unique with F x. Qed. Theorem Rnd_NA_pt_monotone : @@ -975,7 +991,7 @@ Theorem Rnd_NA_pt_monotone : 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). +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. @@ -1165,7 +1181,7 @@ 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 Rnd_UP_pt_opp. apply Hany. exact Hf. apply Rnd_UP_pt_monotone. diff --git a/flocq/Core/Fcore_ulp.v b/flocq/Core/Ulp.v index 4fdd319e..4f4a5674 100644 --- a/flocq/Core/Fcore_ulp.v +++ b/flocq/Core/Ulp.v @@ -2,9 +2,9 @@ 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) 2009-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +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 @@ -19,11 +19,7 @@ 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. +Require Import Raux Defs Round_pred Generic_fmt Float_prop. Section Fcore_ulp. @@ -97,10 +93,12 @@ Definition ulp x := match Req_bool x 0 with | Some n => bpow (fexp n) | None => 0%R end - | false => bpow (canonic_exp beta fexp x) + | false => bpow (cexp beta fexp x) end. -Lemma ulp_neq_0 : forall x:R, (x <> 0)%R -> ulp x = bpow (canonic_exp beta fexp x). +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. @@ -118,7 +116,7 @@ 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. +now rewrite cexp_opp. intros H2; apply H1; rewrite H2; ring. Qed. @@ -130,7 +128,7 @@ 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 rewrite cexp_abs. now apply Rabs_no_R0. Qed. @@ -159,9 +157,8 @@ rewrite ulp_neq_0. 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). +apply IZR_le, (Zlt_le_succ 0). +apply gt_0_F2R with beta (cexp beta fexp x). now rewrite <- Fx. Qed. @@ -178,8 +175,6 @@ 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. @@ -189,13 +184,13 @@ rewrite ulp_neq_0. unfold round. simpl. unfold F2R. simpl. rewrite Zceil_floor_neq. -rewrite Z2R_plus. simpl. +rewrite plus_IZR. simpl. ring. intros H. apply Fx. unfold generic_format, F2R. simpl. rewrite <- H. -rewrite Ztrunc_Z2R. +rewrite Ztrunc_IZR. rewrite H. now rewrite scaled_mantissa_mult_bpow. intros V; apply Fx. @@ -210,7 +205,7 @@ Proof. intros e. rewrite ulp_neq_0. apply f_equal. -apply canonic_exp_fexp. +apply cexp_fexp. rewrite Rabs_pos_eq. split. ring_simplify (e + 1 - 1)%Z. @@ -222,7 +217,7 @@ apply Rgt_not_eq, Rlt_gt, bpow_gt_0. Qed. -Lemma generic_format_ulp_0: +Lemma generic_format_ulp_0 : F (ulp 0). Proof. unfold ulp. @@ -234,8 +229,9 @@ 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). +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. @@ -248,7 +244,7 @@ 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). +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. @@ -258,33 +254,36 @@ 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). +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 generic_format_bpow. apply H. Qed. -Lemma not_FTZ_generic_format_ulp: - (forall x, F (ulp x)) -> Exp_not_FTZ fexp. +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... +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. +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. @@ -295,20 +294,21 @@ 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. +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 Zle_refl. +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 Zle_trans with (2:= H _). +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. + (forall x, (ulp 0 <= ulp x)%R) -> + Exp_not_FTZ fexp. Proof. intros H e. apply generic_format_bpow_inv' with beta. @@ -318,9 +318,7 @@ rewrite <- ulp_bpow. apply H. Qed. - - -Theorem ulp_le_pos : +Lemma ulp_le_pos : forall { Hm : Monotone_exp fexp }, forall x y: R, (0 <= x)%R -> (x <= y)%R -> @@ -332,7 +330,7 @@ rewrite ulp_neq_0. rewrite ulp_neq_0. apply bpow_le. apply Hm. -now apply ln_beta_le. +now apply mag_le. apply Rgt_not_eq, Rlt_gt. now apply Rlt_le_trans with (1:=Hx). now apply Rgt_not_eq. @@ -341,7 +339,6 @@ apply ulp_ge_ulp_0. apply monotone_exp_not_FTZ... Qed. - Theorem ulp_le : forall { Hm : Monotone_exp fexp }, forall x y: R, @@ -355,26 +352,49 @@ 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 (ln_beta beta x - 1)) then - (x - bpow (fexp (ln_beta beta x - 1)))%R + 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. + 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. +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'. @@ -389,39 +409,29 @@ 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. +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. +Theorem succ_opp : + forall x, succ (-x) = (- pred 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. +intros x. +now apply sym_eq, Ropp_involutive. Qed. -Lemma pred_opp: forall x, (pred (-x) = - succ x)%R. +Theorem pred_opp : + forall x, pred (-x) = (- succ x)%R. Proof. -intros x; rewrite pred_eq_opp_succ_opp. +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 *) @@ -436,7 +446,7 @@ 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). +apply gt_0_F2R with beta (cexp beta fexp x). rewrite <- Fx. apply Rle_lt_trans with (2:=Hx). apply bpow_ge_0. @@ -446,12 +456,11 @@ 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. +pattern (bpow (cexp 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. +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. @@ -476,27 +485,23 @@ 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. +pattern (bpow (cexp 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. +rewrite <- plus_IZR. apply F2R_p1_le_bpow. -apply F2R_gt_0_reg with beta (canonic_exp beta fexp x). +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 (ln_beta beta x - 1) -> + x <> bpow (mag beta x - 1) -> F (x - ulp x). Proof. intros x Zx Fx Hx. -destruct (ln_beta beta x) as (ex, Ex). +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). @@ -504,20 +509,20 @@ 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. +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 canonic_exp_fexp with (1 := Ex). +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 (Z2R 1). -rewrite <- Z2R_minus. -rewrite Ztrunc_Z2R. -rewrite Z2R_minus. +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. @@ -526,7 +531,7 @@ split. apply id_m_ulp_ge_bpow; trivial. rewrite ulp_neq_0. intro H. -assert (ex-1 < canonic_exp beta fexp x < ex)%Z. +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. @@ -541,13 +546,12 @@ 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. +pattern (bpow (cexp 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. +apply IZR_le. assert (0 < Ztrunc (scaled_mantissa beta fexp x))%Z. -apply F2R_gt_0_reg with beta (canonic_exp beta fexp x). +apply gt_0_F2R with beta (cexp beta fexp x). rewrite <- Fx. apply Rle_lt_trans with (2:=proj1 Ex'). apply bpow_ge_0. @@ -557,8 +561,8 @@ 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) -> + 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. @@ -571,7 +575,7 @@ 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 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. @@ -580,7 +584,7 @@ rewrite H. apply generic_format_F2R. intros _. apply Zeq_le. -apply canonic_exp_fexp. +apply cexp_fexp. rewrite <- H. unfold f; rewrite Hx. rewrite Rabs_right. @@ -593,9 +597,8 @@ 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. +replace (bpow 1) with (IZR beta). +apply IZR_le. apply <- Zle_is_le_bool. now destruct beta. simpl. @@ -619,31 +622,30 @@ rewrite Hx, He. ring. Qed. - -Theorem generic_format_succ_aux1 : +Lemma 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). +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, canonic_exp. -rewrite ln_beta_unique with beta (x + ulp x)%R ex. +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 canonic_exp_fexp with (1 := Ex). +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 (Z2R 1). -rewrite <- Z2R_plus. -rewrite Ztrunc_Z2R. -rewrite Z2R_plus. +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. @@ -667,7 +669,7 @@ 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). +rewrite cexp_fexp with (1 := Ex). destruct (mantissa_small_pos beta fexp x ex) ; trivial. rewrite Ztrunc_floor. apply sym_eq. @@ -679,7 +681,7 @@ now apply Rlt_le. now apply Rlt_le. Qed. -Theorem generic_format_pred_pos : +Lemma generic_format_pred_pos : forall x, F x -> (0 < x)%R -> F (pred_pos x). Proof. @@ -689,7 +691,6 @@ now apply generic_format_pred_aux2. now apply generic_format_pred_aux1. Qed. - Theorem generic_format_succ : forall x, F x -> F (succ x). @@ -717,9 +718,7 @@ apply generic_format_succ. now apply generic_format_opp. Qed. - - -Theorem pred_pos_lt_id : +Lemma pred_pos_lt_id : forall x, (x <> 0)%R -> (pred_pos x < x)%R. Proof. @@ -754,7 +753,7 @@ 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. +auto with real. Qed. @@ -766,7 +765,7 @@ 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. +auto with real. Qed. Theorem succ_ge_id : @@ -781,7 +780,7 @@ Qed. Theorem pred_le_id : - forall x, (pred x <= x)%R. + forall x, (pred x <= x)%R. Proof. intros x; unfold pred. pattern x at 2; rewrite <- (Ropp_involutive x). @@ -790,7 +789,7 @@ apply succ_ge_id. Qed. -Theorem pred_pos_ge_0 : +Lemma pred_pos_ge_0 : forall x, (0 < x)%R -> F x -> (0 <= pred_pos x)%R. Proof. @@ -801,8 +800,8 @@ 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. +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. @@ -824,36 +823,35 @@ Qed. Lemma pred_pos_plus_ulp_aux1 : forall x, (0 < x)%R -> F x -> - x <> bpow (ln_beta beta x - 1) -> + 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 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). +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_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. +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; try auto with real. +rewrite 2!ulp_neq_0 by lra. 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). +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, ln_beta_unique. +apply sym_eq, mag_unique. rewrite Rabs_right. rewrite Rabs_right in Hex. 2: apply Rle_ge; apply Rlt_le; easy. @@ -863,8 +861,8 @@ 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. +right; unfold cexp; now rewrite Lex. +lra. apply Rle_lt_trans with (2:=proj2 Hex). rewrite <- Rplus_0_r. apply Rplus_le_compat_l. @@ -874,22 +872,19 @@ apply bpow_ge_0. apply Rle_ge. apply Rle_0_minus. rewrite Fx. -unfold F2R, canonic_exp; simpl. +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. -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). +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 := ln_beta_val beta x (ln_beta beta x) in + 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. @@ -904,9 +899,9 @@ case (Zle_lt_or_eq _ _ He); clear He; intros He. (* *) rewrite ulp_neq_0; trivial. apply f_equal. -unfold canonic_exp; apply f_equal. +unfold cexp ; apply f_equal. apply sym_eq. -apply ln_beta_unique. +apply mag_unique. rewrite Rabs_right. split. apply Rplus_le_reg_l with (bpow (fexp (e-1))). @@ -917,9 +912,8 @@ 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. +replace (bpow 1) with (IZR beta). +apply IZR_le. apply <- Zle_is_le_bool. now destruct beta. simpl. @@ -944,7 +938,7 @@ 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 + 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. @@ -967,40 +961,44 @@ 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 : +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 (ln_beta_val beta x (ln_beta beta x) -1))) 0); intros H1. +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 ln_beta_plus_eps: +Theorem mag_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. + mag beta (x + eps) = mag beta x :> Z. Proof. intros x Zx Fx eps Heps. -destruct (ln_beta beta x) as (ex, He). +destruct (mag beta x) as (ex, He). simpl. specialize (He (Rgt_not_eq _ _ Zx)). -apply ln_beta_unique. +apply mag_unique. rewrite Rabs_pos_eq. rewrite Rabs_pos_eq in He. split. @@ -1012,13 +1010,11 @@ 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. +pattern (bpow (cexp 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. +rewrite <- plus_IZR. apply F2R_p1_le_bpow. -apply F2R_gt_0_reg with beta (canonic_exp beta fexp x). +apply gt_0_F2R with beta (cexp beta fexp x). now rewrite <- Fx. now rewrite <- Fx. now apply Rgt_not_eq. @@ -1028,7 +1024,7 @@ now apply Rlt_le. apply Heps. Qed. -Theorem round_DN_plus_eps_pos: +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. @@ -1039,8 +1035,8 @@ destruct Zx as [Zx|Zx]. pattern x at 2 ; rewrite Fx. unfold round. unfold scaled_mantissa. simpl. -unfold canonic_exp at 1 2. -rewrite ln_beta_plus_eps ; trivial. +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. @@ -1050,12 +1046,12 @@ 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 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 Z2R_plus. +rewrite plus_IZR. apply Rplus_le_compat. pattern x at 1 3 ; rewrite Fx. unfold F2R. simpl. @@ -1063,7 +1059,7 @@ rewrite Rmult_assoc. rewrite <- bpow_plus. rewrite Zplus_opp_r. rewrite Rmult_1_r. -rewrite Zfloor_Z2R. +rewrite Zfloor_IZR. apply Rle_refl. rewrite ulp_neq_0. 2: now apply Rgt_not_eq. @@ -1076,24 +1072,23 @@ 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. +unfold round, scaled_mantissa, cexp. 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). +exfalso ; lra. intros n Hn H. -assert (fexp (ln_beta beta eps) = fexp n). +assert (fexp (mag beta eps) = fexp n). apply valid_exp; try assumption. -assert(ln_beta beta eps-1 < fexp n)%Z;[idtac|omega]. +assert(mag 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). +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 (ln_beta beta eps)))) with 0%Z. +replace (Zfloor (eps * bpow (- fexp (mag beta eps)))) with 0%Z. unfold F2R; simpl; ring. apply sym_eq, Zfloor_imp. split. @@ -1128,8 +1123,8 @@ 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. +unfold cexp. +now rewrite mag_plus_eps. now apply Rgt_not_eq. now apply Rgt_not_eq, Rplus_lt_0_compat. intros Fs. @@ -1144,24 +1139,22 @@ now apply generic_format_succ_aux1. rewrite <- Zx1, 2!Rplus_0_l. intros Heps. case (proj2 Heps). -unfold round, scaled_mantissa, canonic_exp. +unfold round, scaled_mantissa, cexp. 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. +lra. intros n Hn H. -assert (fexp (ln_beta beta eps) = fexp n). +assert (fexp (mag beta eps) = fexp n). apply valid_exp; try assumption. -assert(ln_beta beta eps-1 < fexp n)%Z;[idtac|omega]. +assert(mag 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). +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 (ln_beta beta eps)))) with 1%Z. +replace (Zceil (eps * bpow (- fexp (mag beta eps)))) with 1%Z. unfold F2R; simpl; rewrite H0; ring. apply sym_eq, Zceil_imp. split. @@ -1316,7 +1309,7 @@ destruct Zp; trivial. generalize H0. rewrite pred_eq_pos;[idtac|now left]. unfold pred_pos. -destruct (ln_beta beta y) as (ey,Hey); simpl. +destruct (mag beta y) as (ey,Hey); simpl. case Req_bool_spec; intros Hy2. (* . *) intros Hy3. @@ -1326,7 +1319,7 @@ 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). +destruct (mag beta x) as (ex,Hex). specialize (Hex Zx). assert (ex <= ey)%Z. apply bpow_lt_bpow with beta. @@ -1347,16 +1340,16 @@ 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). +apply gt_0_F2R with beta (cexp beta fexp x). now rewrite <- Fx. -apply lt_Z2R. -apply Rmult_lt_reg_r with (bpow (canonic_exp beta fexp x)). +apply lt_IZR. +apply Rmult_lt_reg_r with (bpow (cexp beta fexp x)). apply bpow_gt_0. -replace (Z2R (Ztrunc (scaled_mantissa beta fexp x)) * - bpow (canonic_exp beta fexp x))%R with x. +replace (IZR (Ztrunc (scaled_mantissa beta fexp x)) * + bpow (cexp beta fexp x))%R with x. rewrite Rmult_1_l. -unfold canonic_exp. -rewrite ln_beta_unique with beta x ex. +unfold cexp. +rewrite mag_unique with beta x ex. rewrite H3,<-H1, <- Hy2. apply H. exact Hex. @@ -1373,8 +1366,8 @@ 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. +unfold cexp. +rewrite (mag_unique beta y ey); trivial. apply Hey. now apply Rgt_not_eq. contradict Hy2. @@ -1382,8 +1375,8 @@ 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. +apply trans_eq with (mag beta y). +apply sym_eq; apply mag_unique. rewrite H1, Rabs_right. split. apply bpow_le. @@ -1391,7 +1384,7 @@ omega. apply bpow_lt. omega. apply Rle_ge; apply bpow_ge_0. -apply ln_beta_unique. +apply mag_unique. apply Hey. now apply Rgt_not_eq. (* *) @@ -1418,7 +1411,7 @@ rewrite <- V; apply pred_pos_ge_0; trivial. apply Rle_lt_trans with (1:=proj1 H); apply H. Qed. -Theorem succ_le_lt_aux: +Lemma succ_le_lt_aux: forall x y, F x -> F y -> (0 <= x)%R -> (x < y)%R -> @@ -1468,7 +1461,7 @@ now apply generic_format_opp. rewrite Ropp_0; now left. Qed. -Theorem le_pred_lt : +Theorem pred_ge_gt : forall x y, F x -> F y -> (x < y)%R -> @@ -1483,7 +1476,7 @@ now apply generic_format_opp. now apply Ropp_lt_contravar. Qed. -Theorem lt_succ_le : +Theorem succ_gt_ge : forall x y, (y <> 0)%R -> (x <= y)%R -> @@ -1505,12 +1498,12 @@ 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. +Lemma succ_pred_pos : + 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. +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. @@ -1530,7 +1523,7 @@ rewrite H1; ring. (* *) intros (n,(H1,H2)); rewrite H1. unfold pred_pos. -rewrite ln_beta_bpow. +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. @@ -1554,7 +1547,7 @@ rewrite <- Ropp_0 at 1. apply pred_opp. Qed. -Theorem pred_succ_aux : +Lemma pred_succ_pos : forall x, F x -> (0 < x)%R -> pred (succ x) = x. Proof. @@ -1570,7 +1563,7 @@ apply Rle_antisym. 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). +- apply pred_ge_gt with (1 := Fx). now apply generic_format_succ. apply succ_gt_id. now apply Rgt_not_eq. @@ -1582,12 +1575,12 @@ Theorem succ_pred : Proof. intros x Fx. destruct (Rle_or_lt 0 x) as [[Hx|Hx]|Hx]. -now apply succ_pred_aux. +now apply succ_pred_pos. 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. +unfold pred. +rewrite succ_opp, pred_succ_pos. apply Ropp_involutive. now apply generic_format_opp. now apply Ropp_0_gt_lt_contravar. @@ -1606,8 +1599,8 @@ 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 -> + 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. @@ -1636,7 +1629,6 @@ 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) @@ -1676,7 +1668,7 @@ Qed. (* was ulp_error *) Theorem error_lt_ulp : forall rnd { Zrnd : Valid_rnd rnd } x, - (x <> 0)%R -> + (x <> 0)%R -> (Rabs (round beta fexp rnd x - x) < ulp x)%R. Proof with auto with typeclass_instances. intros rnd Zrnd x Zx. @@ -1734,7 +1726,6 @@ 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. @@ -1748,7 +1739,7 @@ rewrite Rplus_opp_r, Rabs_R0. apply Rmult_le_pos. apply Rlt_le. apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). +now apply IZR_lt. apply ulp_ge_0. (* x <> rnd x *) set (d := round beta fexp Zfloor x). @@ -1761,7 +1752,7 @@ 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). +now apply IZR_lt. apply Rplus_le_reg_r with (d - x)%R. ring_simplify. apply Rle_trans with (1 := H). @@ -1778,7 +1769,7 @@ 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). +now apply IZR_lt. apply Rplus_le_reg_r with (- (d + ulp x - x))%R. ring_simplify. apply Rlt_le. @@ -1789,28 +1780,40 @@ rewrite Hu. apply (round_UP_pt beta fexp x). Qed. - Theorem ulp_DN : - forall x, - (0 < round beta fexp Zfloor x)%R -> + forall x, (0 <= 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. +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 (ln_beta beta x) as (e,He). +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... @@ -1819,12 +1822,10 @@ 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 -> + (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. @@ -1847,72 +1848,34 @@ 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. +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... -(* . 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... +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 *) -(* was ulp_half_error_f *) Theorem error_le_half_ulp_round : forall { Hm : Monotone_exp fexp }, forall choice x, @@ -1939,11 +1902,11 @@ apply Rle_trans with (1:=N). right; apply f_equal. rewrite ulp_neq_0; trivial. apply f_equal. -unfold canonic_exp. +unfold cexp. apply valid_exp; trivial. -assert (ln_beta beta x -1 < fexp n)%Z;[idtac|omega]. +assert (mag beta x -1 < fexp n)%Z;[idtac|omega]. apply lt_bpow with beta. -destruct (ln_beta beta x) as (e,He). +destruct (mag beta x) as (e,He). simpl. apply Rle_lt_trans with (Rabs x). now apply He. @@ -1958,42 +1921,29 @@ 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. +destruct (Rle_or_lt 0 x) as [H|H]. rewrite Hx at 2. -rewrite ulp_DN; trivial. +rewrite ulp_DN by easy. 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. +rewrite Rabs_left1 by now apply Rlt_le. +rewrite Hx. +rewrite Rabs_left1. 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 round_DN_pt... +apply round_le_generic... apply generic_format_0. -now left. +now apply Rlt_le. (* . *) -case (Rle_or_lt 0 (round beta fexp Zceil x)). -intros H; destruct H. +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. -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. @@ -2002,7 +1952,9 @@ 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. +rewrite <- Ropp_0. +apply Ropp_le_contravar. +now apply Rlt_le. Qed. Theorem pred_le : @@ -2011,18 +1963,22 @@ Theorem pred_le : Proof. intros x y Fx Fy [Hxy| ->]. 2: apply Rle_refl. -apply le_pred_lt with (2 := Fy). +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. +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. +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. @@ -2064,8 +2020,95 @@ apply Rgt_not_le with (1 := Hxy). now apply succ_le_inv. Qed. -(* was lt_UP_le_DN *) -Theorem le_round_DN_lt_UP : +(** 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. @@ -2078,10 +2121,9 @@ apply round_UP_pt... now apply Rlt_le. Qed. -(* was lt_DN_le_UP *) -Theorem round_UP_le_gt_DN : +Theorem round_UP_le_DN_lt : forall x y, F y -> - (round beta fexp Zfloor x < y -> round beta fexp Zceil x <= y)%R. + (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... @@ -2092,8 +2134,6 @@ 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. @@ -2115,16 +2155,26 @@ 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 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 le_round_DN_lt_UP... +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. @@ -2132,7 +2182,7 @@ 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... +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. @@ -2147,11 +2197,9 @@ 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. +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)). @@ -2169,25 +2217,161 @@ 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. +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_betw; try assumption. +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 *) @@ -2215,14 +2399,14 @@ 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. +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_betw; trivial. +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_betw; trivial. +apply round_UP_eq; trivial. apply generic_format_succ... rewrite pred_succ; trivial. split; try left; assumption. @@ -2275,12 +2459,12 @@ Lemma round_N_eq_DN_pt: forall choice x d u, 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 Rnd_DN_pt_unique 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. +rewrite Rnd_UP_pt_unique with F x (round beta fexp Zceil x) u; try assumption. apply round_UP_pt... Qed. @@ -2310,13 +2494,28 @@ Lemma round_N_eq_UP_pt: forall choice x d 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 Rnd_UP_pt_unique 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. +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/Fcore_Zaux.v b/flocq/Core/Zaux.v index f6731b4c..e21d93a4 100644 --- a/flocq/Core/Fcore_Zaux.v +++ b/flocq/Core/Zaux.v @@ -2,9 +2,9 @@ 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-2018 Sylvie Boldo #<br /># -Copyright (C) 2011-2013 Guillaume Melquiond +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 @@ -17,7 +17,7 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the COPYING file for more details. *) -Require Import ZArith. +Require Import ZArith Omega. Require Import Zquot. Section Zmissing. @@ -25,7 +25,7 @@ Section Zmissing. (** About Z *) Theorem Zopp_le_cancel : forall x y : Z, - (-y <= -x)%Z -> Zle x y. + (-y <= -x)%Z -> Z.le x y. Proof. intros x y Hxy. apply Zplus_le_reg_r with (-x - y)%Z. @@ -37,7 +37,7 @@ Theorem Zgt_not_eq : (y < x)%Z -> (x <> y)%Z. Proof. intros x y H Hn. -apply Zlt_irrefl with x. +apply Z.lt_irrefl with x. now rewrite Hn at 1. Qed. @@ -69,29 +69,8 @@ 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. + 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. @@ -105,37 +84,6 @@ 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. @@ -145,12 +93,12 @@ Theorem Zpower_plus : 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. +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 (Zabs_nat e). + Zpower b e = Zpower_nat b (Z.abs_nat e). Proof. intros b [|e|e] He. apply refl_equal. @@ -181,40 +129,14 @@ 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. + 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 Zeven_Zpower. +now apply Z.even_pow. now rewrite <- He'. Qed. @@ -239,7 +161,7 @@ Variable r : radix. Theorem radix_gt_0 : (0 < r)%Z. Proof. -apply Zlt_le_trans with 2%Z. +apply Z.lt_le_trans with 2%Z. easy. apply Zle_bool_imp_le. apply r. @@ -248,7 +170,7 @@ Qed. Theorem radix_gt_1 : (1 < r)%Z. Proof. destruct r as (v, Hr). simpl. -apply Zlt_le_trans with 2%Z. +apply Z.lt_le_trans with 2%Z. easy. now apply Zle_bool_imp_le. Qed. @@ -273,7 +195,7 @@ 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. +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). @@ -287,7 +209,7 @@ Theorem Zpower_gt_0 : Proof. intros p Hp. rewrite Zpower_Zpower_nat with (1 := Hp). -induction (Zabs_nat p). +induction (Z.abs_nat p). easy. rewrite Zpower_nat_S. apply Zmult_lt_0_compat with (2 := IHn). @@ -336,7 +258,7 @@ rewrite <- (Zmult_1_r (r ^ e1)) at 1. apply Zmult_lt_compat2. split. now apply Zpower_gt_0. -apply Zle_refl. +apply Z.le_refl. split. easy. apply Zpower_gt_1. @@ -363,6 +285,36 @@ 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. @@ -380,7 +332,7 @@ rewrite Zopp_mult_distr_l. apply Z_mod_plus. easy. apply Zmult_gt_0_compat. -now apply Zlt_gt. +now apply Z.lt_gt. easy. now elim Hb. Qed. @@ -411,7 +363,7 @@ 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. + (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']. @@ -421,12 +373,12 @@ 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 Z_div_plus by now apply Z.lt_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. +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. @@ -439,7 +391,7 @@ Theorem ZOdiv_mod_mult : (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]. +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. @@ -456,34 +408,34 @@ Qed. Theorem ZOdiv_small_abs : forall a b, - (Zabs a < b)%Z -> Z.quot a b = Z0. + (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 Zquot_small. +apply Z.quot_small. split. exact H. -now rewrite Zabs_eq in Ha. -apply Zopp_inj. -rewrite <- Zquot_opp_l, Zopp_0. -apply Zquot_small. +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, - (Zabs a < b)%Z -> Z.rem a b = a. + (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 Zrem_small. +apply Z.rem_small. split. exact H. -now rewrite Zabs_eq in Ha. -apply Zopp_inj. +now rewrite Z.abs_eq in Ha. +apply Z.opp_inj. rewrite <- Zrem_opp_l. -apply Zrem_small. +apply Z.rem_small. generalize (Zabs_non_eq a). omega. Qed. @@ -493,7 +445,7 @@ Theorem ZOdiv_plus : (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]. +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. @@ -632,8 +584,8 @@ 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. +elim (Z.lt_irrefl x). +now apply Z.le_lt_trans with y. apply refl_equal. Qed. @@ -672,8 +624,8 @@ 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. +elim (Z.lt_irrefl x). +now apply Z.lt_le_trans with y. apply refl_equal. Qed. @@ -707,32 +659,32 @@ Inductive Zcompare_prop (x y : Z) : comparison -> Prop := | Zcompare_Gt_ : (y < x)%Z -> Zcompare_prop x y Gt. Theorem Zcompare_spec : - forall x y, Zcompare_prop x y (Zcompare x y). + 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 (Zcompare x y) ; try easy. +case (Z.compare x y) ; try easy. now constructor. generalize (Zgt_compare _ _ H). -case (Zcompare x y) ; try easy. +case (Z.compare x y) ; try easy. constructor. -now apply Zgt_lt. +now apply Z.gt_lt. generalize (proj2 (Zcompare_Eq_iff_eq _ _) H). -case (Zcompare x y) ; try easy. +case (Z.compare x y) ; try easy. now constructor. Qed. Theorem Zcompare_Lt : forall x y, - (x < y)%Z -> Zcompare x y = Lt. + (x < y)%Z -> Z.compare x y = Lt. Proof. easy. Qed. Theorem Zcompare_Eq : forall x y, - (x = y)%Z -> Zcompare x y = Eq. + (x = y)%Z -> Z.compare x y = Eq. Proof. intros x y. apply <- Zcompare_Eq_iff_eq. @@ -740,21 +692,29 @@ Qed. Theorem Zcompare_Gt : forall x y, - (y < x)%Z -> Zcompare x y = Gt. + (y < x)%Z -> Z.compare x y = Gt. Proof. intros x y. -apply Zlt_gt. +apply Z.lt_gt. Qed. End Zcompare. Section cond_Zopp. -Definition cond_Zopp (b : bool) m := if b then Zopp m else m. +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, - Zabs (cond_Zopp b m) = Zabs m. + Z.abs (cond_Zopp b m) = Z.abs m. Proof. intros [|] m. apply Zabs_Zopp. @@ -763,14 +723,14 @@ Qed. Theorem cond_Zopp_Zlt_bool : forall m, - cond_Zopp (Zlt_bool m 0) m = Zabs 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 Zabs_eq. +now apply Z.abs_eq. Qed. End cond_Zopp. @@ -808,11 +768,11 @@ Section faster_div. Lemma Zdiv_eucl_unique : forall a b, - Zdiv_eucl a b = (Zdiv a b, Zmod a b). + Z.div_eucl a b = (Z.div a b, Zmod a b). Proof. intros a b. -unfold Zdiv, Zmod. -now case Zdiv_eucl. +unfold Z.div, Zmod. +now case Z.div_eucl. Qed. Fixpoint Zpos_div_eucl_aux1 (a b : positive) {struct b} := @@ -835,7 +795,7 @@ 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)). +- 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. @@ -843,7 +803,7 @@ induction b ; intros a. 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)). + 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)). @@ -853,7 +813,7 @@ induction b ; intros a. 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)). + 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)). @@ -861,7 +821,7 @@ induction b ; intros a. apply f_equal. now rewrite Z_mod_mult. + easy. -- change (Z.pos_div_eucl a 1) with (Zdiv_eucl (Zpos a) 1). +- 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. @@ -879,13 +839,13 @@ Lemma Zpos_div_eucl_aux_correct : Proof. intros a b. unfold Zpos_div_eucl_aux. -change (Z.pos_div_eucl a (Zpos b)) with (Zdiv_eucl (Zpos a) (Zpos b)). +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 (Zdiv_eucl (Zpos a) (Zpos b)). +change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)). apply Zdiv_eucl_unique. Qed. @@ -920,7 +880,7 @@ Definition Zfast_div_eucl (a b : Z) := Theorem Zfast_div_eucl_correct : forall a b : Z, - Zfast_div_eucl a b = Zdiv_eucl a b. + 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. diff --git a/flocq/IEEE754/Binary.v b/flocq/IEEE754/Binary.v new file mode 100644 index 00000000..0ec3a297 --- /dev/null +++ b/flocq/IEEE754/Binary.v @@ -0,0 +1,2814 @@ +(** +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 +#<br /># +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. +*) + +(** * IEEE-754 arithmetic *) +Require Import Core Digits Round Bracket Operations Div Sqrt Relative. +Require Import Psatz. + +Section AnyRadix. + +Inductive full_float := + | F754_zero (s : bool) + | F754_infinity (s : bool) + | F754_nan (s : bool) (m : positive) + | F754_finite (s : bool) (m : positive) (e : Z). + +Definition FF2R beta x := + match x with + | F754_finite s m e => F2R (Float beta (cond_Zopp s (Zpos m)) e) + | _ => 0%R + end. + +End AnyRadix. + +Section Binary. + +Arguments exist {A} {P}. + +(** [prec] is the number of bits of the mantissa including the implicit one; + [emax] is the exponent of the infinities. + For instance, binary32 is defined by [prec = 24] and [emax = 128]. *) +Variable prec emax : Z. +Context (prec_gt_0_ : Prec_gt_0 prec). +Hypothesis Hmax : (prec < emax)%Z. + +Let emin := (3 - emax - prec)%Z. +Let fexp := FLT_exp emin prec. +Instance fexp_correct : Valid_exp fexp := FLT_exp_valid emin prec. +Instance fexp_monotone : Monotone_exp fexp := FLT_exp_monotone emin prec. + +Definition canonical_mantissa m e := + Zeq_bool (fexp (Zpos (digits2_pos m) + e)) e. + +Definition bounded m e := + andb (canonical_mantissa m e) (Zle_bool e (emax - prec)). + +Definition nan_pl pl := + Zlt_bool (Zpos (digits2_pos pl)) prec. + +Definition valid_binary x := + match x with + | F754_finite _ m e => bounded m e + | F754_nan _ pl => nan_pl pl + | _ => true + end. + +(** Basic type used for representing binary FP numbers. + Note that there is exactly one such object per FP datum. *) + +Inductive binary_float := + | B754_zero (s : bool) + | B754_infinity (s : bool) + | B754_nan (s : bool) (pl : positive) : + nan_pl pl = true -> binary_float + | B754_finite (s : bool) (m : positive) (e : Z) : + bounded m e = true -> binary_float. + +Definition FF2B x := + match x as x return valid_binary x = true -> binary_float with + | F754_finite s m e => B754_finite s m e + | F754_infinity s => fun _ => B754_infinity s + | F754_zero s => fun _ => B754_zero s + | F754_nan b pl => fun H => B754_nan b pl H + end. + +Definition B2FF x := + match x with + | B754_finite s m e _ => F754_finite s m e + | B754_infinity s => F754_infinity s + | B754_zero s => F754_zero s + | B754_nan b pl _ => F754_nan b pl + end. + +Definition B2R f := + match f with + | B754_finite s m e _ => F2R (Float radix2 (cond_Zopp s (Zpos m)) e) + | _ => 0%R + end. + +Theorem FF2R_B2FF : + forall x, + FF2R radix2 (B2FF x) = B2R x. +Proof. +now intros [sx|sx|sx plx Hplx|sx mx ex Hx]. +Qed. + +Theorem B2FF_FF2B : + forall x Hx, + B2FF (FF2B x Hx) = x. +Proof. +now intros [sx|sx|sx plx|sx mx ex] Hx. +Qed. + +Theorem valid_binary_B2FF : + forall x, + valid_binary (B2FF x) = true. +Proof. +now intros [sx|sx|sx plx Hplx|sx mx ex Hx]. +Qed. + +Theorem FF2B_B2FF : + forall x H, + FF2B (B2FF x) H = x. +Proof. +intros [sx|sx|sx plx Hplx|sx mx ex Hx] H ; try easy. +apply f_equal, eqbool_irrelevance. +apply f_equal, eqbool_irrelevance. +Qed. + +Theorem FF2B_B2FF_valid : + forall x, + FF2B (B2FF x) (valid_binary_B2FF x) = x. +Proof. +intros x. +apply FF2B_B2FF. +Qed. + +Theorem B2R_FF2B : + forall x Hx, + B2R (FF2B x Hx) = FF2R radix2 x. +Proof. +now intros [sx|sx|sx plx|sx mx ex] Hx. +Qed. + +Theorem match_FF2B : + forall {T} fz fi fn ff x Hx, + match FF2B x Hx return T with + | B754_zero sx => fz sx + | B754_infinity sx => fi sx + | B754_nan b p _ => fn b p + | B754_finite sx mx ex _ => ff sx mx ex + end = + match x with + | F754_zero sx => fz sx + | F754_infinity sx => fi sx + | F754_nan b p => fn b p + | F754_finite sx mx ex => ff sx mx ex + end. +Proof. +now intros T fz fi fn ff [sx|sx|sx plx|sx mx ex] Hx. +Qed. + +Theorem canonical_canonical_mantissa : + forall (sx : bool) mx ex, + canonical_mantissa mx ex = true -> + canonical radix2 fexp (Float radix2 (cond_Zopp sx (Zpos mx)) ex). +Proof. +intros sx mx ex H. +assert (Hx := Zeq_bool_eq _ _ H). clear H. +apply sym_eq. +simpl. +pattern ex at 2 ; rewrite <- Hx. +apply (f_equal fexp). +rewrite mag_F2R_Zdigits. +rewrite <- Zdigits_abs. +rewrite Zpos_digits2_pos. +now case sx. +now case sx. +Qed. + +Theorem generic_format_B2R : + forall x, + generic_format radix2 fexp (B2R x). +Proof. +intros [sx|sx|sx plx Hx |sx mx ex Hx] ; try apply generic_format_0. +simpl. +apply generic_format_canonical. +apply canonical_canonical_mantissa. +now destruct (andb_prop _ _ Hx) as (H, _). +Qed. + +Theorem FLT_format_B2R : + forall x, + FLT_format radix2 emin prec (B2R x). +Proof with auto with typeclass_instances. +intros x. +apply FLT_format_generic... +apply generic_format_B2R. +Qed. + +Theorem B2FF_inj : + forall x y : binary_float, + B2FF x = B2FF y -> + x = y. +Proof. +intros [sx|sx|sx plx Hplx|sx mx ex Hx] [sy|sy|sy ply Hply|sy my ey Hy] ; try easy. +(* *) +intros H. +now inversion H. +(* *) +intros H. +now inversion H. +(* *) +intros H. +inversion H. +clear H. +revert Hplx. +rewrite H2. +intros Hx. +apply f_equal, eqbool_irrelevance. +(* *) +intros H. +inversion H. +clear H. +revert Hx. +rewrite H2, H3. +intros Hx. +apply f_equal, eqbool_irrelevance. +Qed. + +Definition is_finite_strict f := + match f with + | B754_finite _ _ _ _ => true + | _ => false + end. + +Theorem B2R_inj: + forall x y : binary_float, + is_finite_strict x = true -> + is_finite_strict y = true -> + B2R x = B2R y -> + x = y. +Proof. +intros [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] ; try easy. +simpl. +intros _ _ Heq. +assert (Hs: sx = sy). +(* *) +revert Heq. clear. +case sx ; case sy ; try easy ; + intros Heq ; apply False_ind ; revert Heq. +apply Rlt_not_eq. +apply Rlt_trans with R0. +now apply F2R_lt_0. +now apply F2R_gt_0. +apply Rgt_not_eq. +apply Rgt_trans with R0. +now apply F2R_gt_0. +now apply F2R_lt_0. +assert (mx = my /\ ex = ey). +(* *) +refine (_ (canonical_unique _ fexp _ _ _ _ Heq)). +rewrite Hs. +now case sy ; intro H ; injection H ; split. +apply canonical_canonical_mantissa. +exact (proj1 (andb_prop _ _ Hx)). +apply canonical_canonical_mantissa. +exact (proj1 (andb_prop _ _ Hy)). +(* *) +revert Hx. +rewrite Hs, (proj1 H), (proj2 H). +intros Hx. +apply f_equal. +apply eqbool_irrelevance. +Qed. + +Definition Bsign x := + match x with + | B754_nan s _ _ => s + | B754_zero s => s + | B754_infinity s => s + | B754_finite s _ _ _ => s + end. + +Definition sign_FF x := + match x with + | F754_nan s _ => s + | F754_zero s => s + | F754_infinity s => s + | F754_finite s _ _ => s + end. + +Theorem Bsign_FF2B : + forall x H, + Bsign (FF2B x H) = sign_FF x. +Proof. +now intros [sx|sx|sx plx|sx mx ex] H. +Qed. + +Definition is_finite f := + match f with + | B754_finite _ _ _ _ => true + | B754_zero _ => true + | _ => false + end. + +Definition is_finite_FF f := + match f with + | F754_finite _ _ _ => true + | F754_zero _ => true + | _ => false + end. + +Theorem is_finite_FF2B : + forall x Hx, + is_finite (FF2B x Hx) = is_finite_FF x. +Proof. +now intros [| | |]. +Qed. + +Theorem is_finite_FF_B2FF : + forall x, + is_finite_FF (B2FF x) = is_finite x. +Proof. +now intros [| |? []|]. +Qed. + +Theorem B2R_Bsign_inj: + forall x y : binary_float, + is_finite x = true -> + is_finite y = true -> + B2R x = B2R y -> + Bsign x = Bsign y -> + x = y. +Proof. +intros. destruct x, y; try (apply B2R_inj; now eauto). +- simpl in H2. congruence. +- symmetry in H1. apply Rmult_integral in H1. + destruct H1. apply (eq_IZR _ 0) in H1. destruct s0; discriminate H1. + simpl in H1. pose proof (bpow_gt_0 radix2 e). + rewrite H1 in H3. apply Rlt_irrefl in H3. destruct H3. +- apply Rmult_integral in H1. + destruct H1. apply (eq_IZR _ 0) in H1. destruct s; discriminate H1. + simpl in H1. pose proof (bpow_gt_0 radix2 e). + rewrite H1 in H3. apply Rlt_irrefl in H3. destruct H3. +Qed. + +Definition is_nan f := + match f with + | B754_nan _ _ _ => true + | _ => false + end. + +Definition is_nan_FF f := + match f with + | F754_nan _ _ => true + | _ => false + end. + +Theorem is_nan_FF2B : + forall x Hx, + is_nan (FF2B x Hx) = is_nan_FF x. +Proof. +now intros [| | |]. +Qed. + +Theorem is_nan_FF_B2FF : + forall x, + is_nan_FF (B2FF x) = is_nan x. +Proof. +now intros [| |? []|]. +Qed. + +Definition get_nan_pl (x : binary_float) : positive := + match x with B754_nan _ pl _ => pl | _ => xH end. + +Definition build_nan (x : { x | is_nan x = true }) : binary_float. +Proof. +apply (B754_nan (Bsign (proj1_sig x)) (get_nan_pl (proj1_sig x))). +destruct x as [x H]. +simpl. +revert H. +assert (H: false = true -> nan_pl 1 = true) by now destruct (nan_pl 1). +destruct x; try apply H. +intros _. +apply e. +Defined. + +Theorem build_nan_correct : + forall x : { x | is_nan x = true }, + build_nan x = proj1_sig x. +Proof. +intros [x H]. +now destruct x. +Qed. + +Theorem B2R_build_nan : + forall x, B2R (build_nan x) = 0%R. +Proof. +easy. +Qed. + +Theorem is_finite_build_nan : + forall x, is_finite (build_nan x) = false. +Proof. +easy. +Qed. + +Theorem is_nan_build_nan : + forall x, is_nan (build_nan x) = true. +Proof. +easy. +Qed. + +Definition erase (x : binary_float) : binary_float. +Proof. +destruct x as [s|s|s pl H|s m e H]. +- exact (B754_zero s). +- exact (B754_infinity s). +- apply (B754_nan s pl). + destruct nan_pl. + apply eq_refl. + exact H. +- apply (B754_finite s m e). + destruct bounded. + apply eq_refl. + exact H. +Defined. + +Theorem erase_correct : + forall x, erase x = x. +Proof. +destruct x as [s|s|s pl H|s m e H] ; try easy ; simpl. +- apply f_equal, eqbool_irrelevance. +- apply f_equal, eqbool_irrelevance. +Qed. + +(** Opposite *) + +Definition Bopp opp_nan x := + match x with + | B754_nan _ _ _ => build_nan (opp_nan x) + | B754_infinity sx => B754_infinity (negb sx) + | B754_finite sx mx ex Hx => B754_finite (negb sx) mx ex Hx + | B754_zero sx => B754_zero (negb sx) + end. + +Theorem Bopp_involutive : + forall opp_nan x, + is_nan x = false -> + Bopp opp_nan (Bopp opp_nan x) = x. +Proof. +now intros opp_nan [sx|sx|sx plx|sx mx ex Hx] ; simpl ; try rewrite Bool.negb_involutive. +Qed. + +Theorem B2R_Bopp : + forall opp_nan x, + B2R (Bopp opp_nan x) = (- B2R x)%R. +Proof. +intros opp_nan [sx|sx|sx plx Hplx|sx mx ex Hx]; apply sym_eq ; try apply Ropp_0. +simpl. +rewrite <- F2R_opp. +now case sx. +Qed. + +Theorem is_finite_Bopp : + forall opp_nan x, + is_finite (Bopp opp_nan x) = is_finite x. +Proof. +now intros opp_nan [| | |]. +Qed. + +Lemma Bsign_Bopp : + forall opp_nan x, is_nan x = false -> Bsign (Bopp opp_nan x) = negb (Bsign x). +Proof. now intros opp_nan [s|s|s pl H|s m e H]. Qed. + +(** Absolute value *) + +Definition Babs abs_nan (x : binary_float) : binary_float := + match x with + | B754_nan _ _ _ => build_nan (abs_nan x) + | B754_infinity sx => B754_infinity false + | B754_finite sx mx ex Hx => B754_finite false mx ex Hx + | B754_zero sx => B754_zero false + end. + +Theorem B2R_Babs : + forall abs_nan x, + B2R (Babs abs_nan x) = Rabs (B2R x). +Proof. + intros abs_nan [sx|sx|sx plx Hx|sx mx ex Hx]; apply sym_eq ; try apply Rabs_R0. + simpl. rewrite <- F2R_abs. now destruct sx. +Qed. + +Theorem is_finite_Babs : + forall abs_nan x, + is_finite (Babs abs_nan x) = is_finite x. +Proof. + now intros abs_nan [| | |]. +Qed. + +Theorem Bsign_Babs : + forall abs_nan x, + is_nan x = false -> + Bsign (Babs abs_nan x) = false. +Proof. + now intros abs_nan [| | |]. +Qed. + +Theorem Babs_idempotent : + forall abs_nan (x: binary_float), + is_nan x = false -> + Babs abs_nan (Babs abs_nan x) = Babs abs_nan x. +Proof. + now intros abs_nan [sx|sx|sx plx|sx mx ex Hx]. +Qed. + +Theorem Babs_Bopp : + forall abs_nan opp_nan x, + is_nan x = false -> + Babs abs_nan (Bopp opp_nan x) = Babs abs_nan x. +Proof. + now intros abs_nan opp_nan [| | |]. +Qed. + +(** Comparison + +[Some c] means ordered as per [c]; [None] means unordered. *) + +Definition Bcompare (f1 f2 : binary_float) : option comparison := + match f1, f2 with + | B754_nan _ _ _,_ | _,B754_nan _ _ _ => None + | B754_infinity s1, B754_infinity s2 => + Some match s1, s2 with + | true, true => Eq + | false, false => Eq + | true, false => Lt + | false, true => Gt + end + | B754_infinity s, _ => Some (if s then Lt else Gt) + | _, B754_infinity s => Some (if s then Gt else Lt) + | B754_finite s _ _ _, B754_zero _ => Some (if s then Lt else Gt) + | B754_zero _, B754_finite s _ _ _ => Some (if s then Gt else Lt) + | B754_zero _, B754_zero _ => Some Eq + | B754_finite s1 m1 e1 _, B754_finite s2 m2 e2 _ => + Some match s1, s2 with + | true, false => Lt + | false, true => Gt + | false, false => + match Z.compare e1 e2 with + | Lt => Lt + | Gt => Gt + | Eq => Pcompare m1 m2 Eq + end + | true, true => + match Z.compare e1 e2 with + | Lt => Gt + | Gt => Lt + | Eq => CompOpp (Pcompare m1 m2 Eq) + end + end + end. + +Theorem Bcompare_correct : + forall f1 f2, + is_finite f1 = true -> is_finite f2 = true -> + Bcompare f1 f2 = Some (Rcompare (B2R f1) (B2R f2)). +Proof. + Ltac apply_Rcompare := + match goal with + | [ |- Lt = Rcompare _ _ ] => symmetry; apply Rcompare_Lt + | [ |- Eq = Rcompare _ _ ] => symmetry; apply Rcompare_Eq + | [ |- Gt = Rcompare _ _ ] => symmetry; apply Rcompare_Gt + end. + unfold Bcompare; intros f1 f2 H1 H2. + destruct f1, f2; try easy; apply f_equal; clear H1 H2. + now rewrite Rcompare_Eq. + destruct s0 ; apply_Rcompare. + now apply F2R_lt_0. + now apply F2R_gt_0. + destruct s ; apply_Rcompare. + now apply F2R_lt_0. + now apply F2R_gt_0. + simpl. + apply andb_prop in e0; destruct e0; apply (canonical_canonical_mantissa false) in H. + apply andb_prop in e2; destruct e2; apply (canonical_canonical_mantissa false) in H1. + pose proof (Zcompare_spec e e1); unfold canonical, Fexp in H1, H. + assert (forall m1 m2 e1 e2, + let x := (IZR (Zpos m1) * bpow radix2 e1)%R in + let y := (IZR (Zpos m2) * bpow radix2 e2)%R in + (cexp radix2 fexp x < cexp radix2 fexp y)%Z -> (x < y)%R). + { + intros; apply Rnot_le_lt; intro; apply (mag_le radix2) in H5. + apply Zlt_not_le with (1 := H4). + now apply fexp_monotone. + now apply (F2R_gt_0 _ (Float radix2 (Zpos m2) e2)). + } + assert (forall m1 m2 e1 e2, (IZR (- Zpos m1) * bpow radix2 e1 < IZR (Zpos m2) * bpow radix2 e2)%R). + { + intros; apply (Rlt_trans _ 0%R). + now apply (F2R_lt_0 _ (Float radix2 (Zneg m1) e0)). + now apply (F2R_gt_0 _ (Float radix2 (Zpos m2) e2)). + } + unfold F2R, Fnum, Fexp. + destruct s, s0; try (now apply_Rcompare; apply H5); inversion H3; + try (apply_Rcompare; apply H4; rewrite H, H1 in H7; assumption); + try (apply_Rcompare; do 2 rewrite opp_IZR, Ropp_mult_distr_l_reverse; + apply Ropp_lt_contravar; apply H4; rewrite H, H1 in H7; assumption); + rewrite H7, Rcompare_mult_r, Rcompare_IZR by (apply bpow_gt_0); reflexivity. +Qed. + +Theorem Bcompare_swap : + forall x y, + Bcompare y x = match Bcompare x y with Some c => Some (CompOpp c) | None => None end. +Proof. + intros. + destruct x as [ ? | [] | ? ? | [] mx ex Bx ]; + destruct y as [ ? | [] | ? ? | [] my ey By ]; simpl; try easy. +- rewrite <- (Zcompare_antisym ex ey). destruct (ex ?= ey)%Z; try easy. + now rewrite (Pcompare_antisym mx my). +- rewrite <- (Zcompare_antisym ex ey). destruct (ex ?= ey)%Z; try easy. + now rewrite Pcompare_antisym. +Qed. + +Theorem bounded_lt_emax : + forall mx ex, + bounded mx ex = true -> + (F2R (Float radix2 (Zpos mx) ex) < bpow radix2 emax)%R. +Proof. +intros mx ex Hx. +destruct (andb_prop _ _ Hx) as (H1,H2). +generalize (Zeq_bool_eq _ _ H1). clear H1. intro H1. +generalize (Zle_bool_imp_le _ _ H2). clear H2. intro H2. +generalize (mag_F2R_Zdigits radix2 (Zpos mx) ex). +destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex). +unfold mag_val. +intros H. +apply Rlt_le_trans with (bpow radix2 e'). +change (Zpos mx) with (Z.abs (Zpos mx)). +rewrite F2R_Zabs. +apply Ex. +apply Rgt_not_eq. +now apply F2R_gt_0. +apply bpow_le. +rewrite H. 2: discriminate. +revert H1. clear -H2. +rewrite Zpos_digits2_pos. +unfold fexp, FLT_exp. +intros ; zify ; omega. +Qed. + +Theorem bounded_ge_emin : + forall mx ex, + bounded mx ex = true -> + (bpow radix2 emin <= F2R (Float radix2 (Zpos mx) ex))%R. +Proof. +intros mx ex Hx. +destruct (andb_prop _ _ Hx) as [H1 _]. +apply Zeq_bool_eq in H1. +generalize (mag_F2R_Zdigits radix2 (Zpos mx) ex). +destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as [e' Ex]. +unfold mag_val. +intros H. +assert (H0 : Zpos mx <> 0%Z) by easy. +rewrite Rabs_pos_eq in Ex by now apply F2R_ge_0. +refine (Rle_trans _ _ _ _ (proj1 (Ex _))). +2: now apply F2R_neq_0. +apply bpow_le. +rewrite H by easy. +revert H1. +rewrite Zpos_digits2_pos. +generalize (Zdigits radix2 (Zpos mx)) (Zdigits_gt_0 radix2 (Zpos mx) H0). +unfold fexp, FLT_exp. +clear -prec_gt_0_. +unfold Prec_gt_0 in prec_gt_0_. +clearbody emin. +intros ; zify ; omega. +Qed. + +Theorem abs_B2R_lt_emax : + forall x, + (Rabs (B2R x) < bpow radix2 emax)%R. +Proof. +intros [sx|sx|sx plx Hx|sx mx ex Hx] ; simpl ; try ( rewrite Rabs_R0 ; apply bpow_gt_0 ). +rewrite <- F2R_Zabs, abs_cond_Zopp. +now apply bounded_lt_emax. +Qed. + +Theorem abs_B2R_ge_emin : + forall x, + is_finite_strict x = true -> + (bpow radix2 emin <= Rabs (B2R x))%R. +Proof. +intros [sx|sx|sx plx Hx|sx mx ex Hx] ; simpl ; try discriminate. +intros; case sx; simpl. +- unfold F2R; simpl; rewrite Rabs_mult, <-abs_IZR; simpl. + rewrite Rabs_pos_eq; [|apply bpow_ge_0]. + now apply bounded_ge_emin. +- unfold F2R; simpl; rewrite Rabs_mult, <-abs_IZR; simpl. + rewrite Rabs_pos_eq; [|apply bpow_ge_0]. + now apply bounded_ge_emin. +Qed. + +Theorem bounded_canonical_lt_emax : + forall mx ex, + canonical radix2 fexp (Float radix2 (Zpos mx) ex) -> + (F2R (Float radix2 (Zpos mx) ex) < bpow radix2 emax)%R -> + bounded mx ex = true. +Proof. +intros mx ex Cx Bx. +apply andb_true_intro. +split. +unfold canonical_mantissa. +unfold canonical, Fexp in Cx. +rewrite Cx at 2. +rewrite Zpos_digits2_pos. +unfold cexp. +rewrite mag_F2R_Zdigits. 2: discriminate. +now apply -> Zeq_is_eq_bool. +apply Zle_bool_true. +unfold canonical, Fexp in Cx. +rewrite Cx. +unfold cexp, fexp, FLT_exp. +destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex). simpl. +apply Z.max_lub. +cut (e' - 1 < emax)%Z. clear ; omega. +apply lt_bpow with radix2. +apply Rle_lt_trans with (2 := Bx). +change (Zpos mx) with (Z.abs (Zpos mx)). +rewrite F2R_Zabs. +apply Ex. +apply Rgt_not_eq. +now apply F2R_gt_0. +unfold emin. +generalize (prec_gt_0 prec). +clear -Hmax ; omega. +Qed. + +(** Truncation *) + +Record shr_record := { shr_m : Z ; shr_r : bool ; shr_s : bool }. + +Definition shr_1 mrs := + let '(Build_shr_record m r s) := mrs in + let s := orb r s in + match m with + | Z0 => Build_shr_record Z0 false s + | Zpos xH => Build_shr_record Z0 true s + | Zpos (xO p) => Build_shr_record (Zpos p) false s + | Zpos (xI p) => Build_shr_record (Zpos p) true s + | Zneg xH => Build_shr_record Z0 true s + | Zneg (xO p) => Build_shr_record (Zneg p) false s + | Zneg (xI p) => Build_shr_record (Zneg p) true s + end. + +Definition loc_of_shr_record mrs := + match mrs with + | Build_shr_record _ false false => loc_Exact + | Build_shr_record _ false true => loc_Inexact Lt + | Build_shr_record _ true false => loc_Inexact Eq + | Build_shr_record _ true true => loc_Inexact Gt + end. + +Definition shr_record_of_loc m l := + match l with + | loc_Exact => Build_shr_record m false false + | loc_Inexact Lt => Build_shr_record m false true + | loc_Inexact Eq => Build_shr_record m true false + | loc_Inexact Gt => Build_shr_record m true true + end. + +Theorem shr_m_shr_record_of_loc : + forall m l, + shr_m (shr_record_of_loc m l) = m. +Proof. +now intros m [|[| |]]. +Qed. + +Theorem loc_of_shr_record_of_loc : + forall m l, + loc_of_shr_record (shr_record_of_loc m l) = l. +Proof. +now intros m [|[| |]]. +Qed. + +Definition shr mrs e n := + match n with + | Zpos p => (iter_pos shr_1 p mrs, (e + n)%Z) + | _ => (mrs, e) + end. + +Lemma inbetween_shr_1 : + forall x mrs e, + (0 <= shr_m mrs)%Z -> + inbetween_float radix2 (shr_m mrs) e x (loc_of_shr_record mrs) -> + inbetween_float radix2 (shr_m (shr_1 mrs)) (e + 1) x (loc_of_shr_record (shr_1 mrs)). +Proof. +intros x mrs e Hm Hl. +refine (_ (new_location_even_correct (F2R (Float radix2 (shr_m (shr_1 mrs)) (e + 1))) (bpow radix2 e) 2 _ _ _ x (if shr_r (shr_1 mrs) then 1 else 0) (loc_of_shr_record mrs) _ _)) ; try easy. +2: apply bpow_gt_0. +2: now case (shr_r (shr_1 mrs)) ; split. +change 2%R with (bpow radix2 1). +rewrite <- bpow_plus. +rewrite (Zplus_comm 1), <- (F2R_bpow radix2 (e + 1)). +unfold inbetween_float, F2R. simpl. +rewrite plus_IZR, Rmult_plus_distr_r. +replace (new_location_even 2 (if shr_r (shr_1 mrs) then 1%Z else 0%Z) (loc_of_shr_record mrs)) with (loc_of_shr_record (shr_1 mrs)). +easy. +clear -Hm. +destruct mrs as (m, r, s). +now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|]. +rewrite (F2R_change_exp radix2 e). +2: apply Zle_succ. +unfold F2R. simpl. +rewrite <- 2!Rmult_plus_distr_r, <- 2!plus_IZR. +rewrite Zplus_assoc. +replace (shr_m (shr_1 mrs) * 2 ^ (e + 1 - e) + (if shr_r (shr_1 mrs) then 1%Z else 0%Z))%Z with (shr_m mrs). +exact Hl. +ring_simplify (e + 1 - e)%Z. +change (2^1)%Z with 2%Z. +rewrite Zmult_comm. +clear -Hm. +destruct mrs as (m, r, s). +now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|]. +Qed. + +Theorem inbetween_shr : + forall x m e l n, + (0 <= m)%Z -> + inbetween_float radix2 m e x l -> + let '(mrs, e') := shr (shr_record_of_loc m l) e n in + inbetween_float radix2 (shr_m mrs) e' x (loc_of_shr_record mrs). +Proof. +intros x m e l n Hm Hl. +destruct n as [|n|n]. +now destruct l as [|[| |]]. +2: now destruct l as [|[| |]]. +unfold shr. +rewrite iter_pos_nat. +rewrite Zpos_eq_Z_of_nat_o_nat_of_P. +induction (nat_of_P n). +simpl. +rewrite Zplus_0_r. +now destruct l as [|[| |]]. +rewrite iter_nat_S. +rewrite inj_S. +unfold Z.succ. +rewrite Zplus_assoc. +revert IHn0. +apply inbetween_shr_1. +clear -Hm. +induction n0. +now destruct l as [|[| |]]. +rewrite iter_nat_S. +revert IHn0. +generalize (iter_nat shr_1 n0 (shr_record_of_loc m l)). +clear. +intros (m, r, s) Hm. +now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|]. +Qed. + +Definition shr_fexp m e l := + shr (shr_record_of_loc m l) e (fexp (Zdigits2 m + e) - e). + +Theorem shr_truncate : + forall m e l, + (0 <= m)%Z -> + shr_fexp m e l = + let '(m', e', l') := truncate radix2 fexp (m, e, l) in (shr_record_of_loc m' l', e'). +Proof. +intros m e l Hm. +case_eq (truncate radix2 fexp (m, e, l)). +intros (m', e') l'. +unfold shr_fexp. +rewrite Zdigits2_Zdigits. +case_eq (fexp (Zdigits radix2 m + e) - e)%Z. +(* *) +intros He. +unfold truncate. +rewrite He. +simpl. +intros H. +now inversion H. +(* *) +intros p Hp. +assert (He: (e <= fexp (Zdigits radix2 m + e))%Z). +clear -Hp ; zify ; omega. +destruct (inbetween_float_ex radix2 m e l) as (x, Hx). +generalize (inbetween_shr x m e l (fexp (Zdigits radix2 m + e) - e) Hm Hx). +assert (Hx0 : (0 <= x)%R). +apply Rle_trans with (F2R (Float radix2 m e)). +now apply F2R_ge_0. +exact (proj1 (inbetween_float_bounds _ _ _ _ _ Hx)). +case_eq (shr (shr_record_of_loc m l) e (fexp (Zdigits radix2 m + e) - e)). +intros mrs e'' H3 H4 H1. +generalize (truncate_correct radix2 _ x m e l Hx0 Hx (or_introl _ He)). +rewrite H1. +intros (H2,_). +rewrite <- Hp, H3. +assert (e'' = e'). +change (snd (mrs, e'') = snd (fst (m',e',l'))). +rewrite <- H1, <- H3. +unfold truncate. +now rewrite Hp. +rewrite H in H4 |- *. +apply (f_equal (fun v => (v, _))). +destruct (inbetween_float_unique _ _ _ _ _ _ _ H2 H4) as (H5, H6). +rewrite H5, H6. +case mrs. +now intros m0 [|] [|]. +(* *) +intros p Hp. +unfold truncate. +rewrite Hp. +simpl. +intros H. +now inversion H. +Qed. + +(** Rounding modes *) + +Inductive mode := mode_NE | mode_ZR | mode_DN | mode_UP | mode_NA. + +Definition round_mode m := + match m with + | mode_NE => ZnearestE + | mode_ZR => Ztrunc + | mode_DN => Zfloor + | mode_UP => Zceil + | mode_NA => ZnearestA + end. + +Definition choice_mode m sx mx lx := + match m with + | mode_NE => cond_incr (round_N (negb (Z.even mx)) lx) mx + | mode_ZR => mx + | mode_DN => cond_incr (round_sign_DN sx lx) mx + | mode_UP => cond_incr (round_sign_UP sx lx) mx + | mode_NA => cond_incr (round_N true lx) mx + end. + +Global Instance valid_rnd_round_mode : forall m, Valid_rnd (round_mode m). +Proof. +destruct m ; unfold round_mode ; auto with typeclass_instances. +Qed. + +Definition overflow_to_inf m s := + match m with + | mode_NE => true + | mode_NA => true + | mode_ZR => false + | mode_UP => negb s + | mode_DN => s + end. + +Definition binary_overflow m s := + if overflow_to_inf m s then F754_infinity s + else F754_finite s (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end) (emax - prec). + +Definition binary_round_aux mode sx mx ex lx := + let '(mrs', e') := shr_fexp mx ex lx in + let '(mrs'', e'') := shr_fexp (choice_mode mode sx (shr_m mrs') (loc_of_shr_record mrs')) e' loc_Exact in + match shr_m mrs'' with + | Z0 => F754_zero sx + | Zpos m => if Zle_bool e'' (emax - prec) then F754_finite sx m e'' else binary_overflow mode sx + | _ => F754_nan false xH (* dummy *) + end. + +Theorem binary_round_aux_correct' : + forall mode x mx ex lx, + (x <> 0)%R -> + inbetween_float radix2 mx ex (Rabs x) lx -> + (ex <= cexp radix2 fexp x)%Z -> + let z := binary_round_aux mode (Rlt_bool x 0) mx ex lx in + valid_binary z = true /\ + if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) x)) (bpow radix2 emax) then + FF2R radix2 z = round radix2 fexp (round_mode mode) x /\ + is_finite_FF z = true /\ sign_FF z = Rlt_bool x 0 + else + z = binary_overflow mode (Rlt_bool x 0). +Proof with auto with typeclass_instances. +intros m x mx ex lx Px Bx Ex z. +unfold binary_round_aux in z. +revert z. +rewrite shr_truncate. +refine (_ (round_trunc_sign_any_correct' _ _ (round_mode m) (choice_mode m) _ x mx ex lx Bx (or_introl _ Ex))). +rewrite <- cexp_abs in Ex. +refine (_ (truncate_correct_partial' _ fexp _ _ _ _ _ Bx Ex)). +destruct (truncate radix2 fexp (mx, ex, lx)) as ((m1, e1), l1). +rewrite loc_of_shr_record_of_loc, shr_m_shr_record_of_loc. +set (m1' := choice_mode m (Rlt_bool x 0) m1 l1). +intros (H1a,H1b) H1c. +rewrite H1c. +assert (Hm: (m1 <= m1')%Z). +(* . *) +unfold m1', choice_mode, cond_incr. +case m ; + try apply Z.le_refl ; + match goal with |- (m1 <= if ?b then _ else _)%Z => + case b ; [ apply Zle_succ | apply Z.le_refl ] end. +assert (Hr: Rabs (round radix2 fexp (round_mode m) x) = F2R (Float radix2 m1' e1)). +(* . *) +rewrite <- (Z.abs_eq m1'). +replace (Z.abs m1') with (Z.abs (cond_Zopp (Rlt_bool x 0) m1')). +rewrite F2R_Zabs. +now apply f_equal. +apply abs_cond_Zopp. +apply Z.le_trans with (2 := Hm). +apply Zlt_succ_le. +apply gt_0_F2R with radix2 e1. +apply Rle_lt_trans with (1 := Rabs_pos x). +exact (proj2 (inbetween_float_bounds _ _ _ _ _ H1a)). +(* . *) +assert (Br: inbetween_float radix2 m1' e1 (Rabs (round radix2 fexp (round_mode m) x)) loc_Exact). +now apply inbetween_Exact. +destruct m1' as [|m1'|m1']. +(* . m1' = 0 *) +rewrite shr_truncate. 2: apply Z.le_refl. +generalize (truncate_0 radix2 fexp e1 loc_Exact). +destruct (truncate radix2 fexp (Z0, e1, loc_Exact)) as ((m2, e2), l2). +rewrite shr_m_shr_record_of_loc. +intros Hm2. +rewrite Hm2. +repeat split. +rewrite Rlt_bool_true. +repeat split. +apply sym_eq. +case Rlt_bool ; apply F2R_0. +rewrite <- F2R_Zabs, abs_cond_Zopp, F2R_0. +apply bpow_gt_0. +(* . 0 < m1' *) +assert (He: (e1 <= fexp (Zdigits radix2 (Zpos m1') + e1))%Z). +rewrite <- mag_F2R_Zdigits, <- Hr, mag_abs. +2: discriminate. +rewrite H1b. +rewrite cexp_abs. +fold (cexp radix2 fexp (round radix2 fexp (round_mode m) x)). +apply cexp_round_ge... +rewrite H1c. +case (Rlt_bool x 0). +apply Rlt_not_eq. +now apply F2R_lt_0. +apply Rgt_not_eq. +now apply F2R_gt_0. +refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Br He)). +2: now rewrite Hr ; apply F2R_gt_0. +refine (_ (truncate_correct_format radix2 fexp (Zpos m1') e1 _ _ He)). +2: discriminate. +rewrite shr_truncate. 2: easy. +destruct (truncate radix2 fexp (Zpos m1', e1, loc_Exact)) as ((m2, e2), l2). +rewrite shr_m_shr_record_of_loc. +intros (H3,H4) (H2,_). +destruct m2 as [|m2|m2]. +elim Rgt_not_eq with (2 := H3). +rewrite F2R_0. +now apply F2R_gt_0. +rewrite F2R_cond_Zopp, H3, abs_cond_Ropp, <- F2R_abs. +simpl Z.abs. +case_eq (Zle_bool e2 (emax - prec)) ; intros He2. +assert (bounded m2 e2 = true). +apply andb_true_intro. +split. +unfold canonical_mantissa. +apply Zeq_bool_true. +rewrite Zpos_digits2_pos. +rewrite <- mag_F2R_Zdigits. +apply sym_eq. +now rewrite H3 in H4. +discriminate. +exact He2. +apply (conj H). +rewrite Rlt_bool_true. +repeat split. +apply F2R_cond_Zopp. +now apply bounded_lt_emax. +rewrite (Rlt_bool_false _ (bpow radix2 emax)). +refine (conj _ (refl_equal _)). +unfold binary_overflow. +case overflow_to_inf. +apply refl_equal. +unfold valid_binary, bounded. +rewrite Zle_bool_refl. +rewrite Bool.andb_true_r. +apply Zeq_bool_true. +rewrite Zpos_digits2_pos. +replace (Zdigits radix2 (Zpos (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end))) with prec. +unfold fexp, FLT_exp, emin. +generalize (prec_gt_0 prec). +clear -Hmax ; zify ; omega. +change 2%Z with (radix_val radix2). +case_eq (Zpower radix2 prec - 1)%Z. +simpl Zdigits. +generalize (Zpower_gt_1 radix2 prec (prec_gt_0 prec)). +clear ; omega. +intros p Hp. +apply Zle_antisym. +cut (prec - 1 < Zdigits radix2 (Zpos p))%Z. clear ; omega. +apply Zdigits_gt_Zpower. +simpl Z.abs. rewrite <- Hp. +cut (Zpower radix2 (prec - 1) < Zpower radix2 prec)%Z. clear ; omega. +apply lt_IZR. +rewrite 2!IZR_Zpower. 2: now apply Zlt_le_weak. +apply bpow_lt. +apply Zlt_pred. +now apply Zlt_0_le_0_pred. +apply Zdigits_le_Zpower. +simpl Z.abs. rewrite <- Hp. +apply Zlt_pred. +intros p Hp. +generalize (Zpower_gt_1 radix2 _ (prec_gt_0 prec)). +clear -Hp ; zify ; omega. +apply Rnot_lt_le. +intros Hx. +generalize (refl_equal (bounded m2 e2)). +unfold bounded at 2. +rewrite He2. +rewrite Bool.andb_false_r. +rewrite bounded_canonical_lt_emax with (2 := Hx). +discriminate. +unfold canonical. +now rewrite <- H3. +elim Rgt_not_eq with (2 := H3). +apply Rlt_trans with R0. +now apply F2R_lt_0. +now apply F2R_gt_0. +rewrite <- Hr. +apply generic_format_abs... +apply generic_format_round... +(* . not m1' < 0 *) +elim Rgt_not_eq with (2 := Hr). +apply Rlt_le_trans with R0. +now apply F2R_lt_0. +apply Rabs_pos. +(* *) +now apply Rabs_pos_lt. +(* all the modes are valid *) +clear. case m. +exact inbetween_int_NE_sign. +exact inbetween_int_ZR_sign. +exact inbetween_int_DN_sign. +exact inbetween_int_UP_sign. +exact inbetween_int_NA_sign. +(* *) +apply inbetween_float_bounds in Bx. +apply Zlt_succ_le. +eapply gt_0_F2R. +apply Rle_lt_trans with (2 := proj2 Bx). +apply Rabs_pos. +Qed. + +Theorem binary_round_aux_correct : + forall mode x mx ex lx, + inbetween_float radix2 (Zpos mx) ex (Rabs x) lx -> + (ex <= fexp (Zdigits radix2 (Zpos mx) + ex))%Z -> + let z := binary_round_aux mode (Rlt_bool x 0) (Zpos mx) ex lx in + valid_binary z = true /\ + if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) x)) (bpow radix2 emax) then + FF2R radix2 z = round radix2 fexp (round_mode mode) x /\ + is_finite_FF z = true /\ sign_FF z = Rlt_bool x 0 + else + z = binary_overflow mode (Rlt_bool x 0). +Proof with auto with typeclass_instances. +intros m x mx ex lx Bx Ex z. +unfold binary_round_aux in z. +revert z. +rewrite shr_truncate. 2: easy. +refine (_ (round_trunc_sign_any_correct _ _ (round_mode m) (choice_mode m) _ x (Zpos mx) ex lx Bx (or_introl _ Ex))). +refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Bx Ex)). +destruct (truncate radix2 fexp (Zpos mx, ex, lx)) as ((m1, e1), l1). +rewrite loc_of_shr_record_of_loc, shr_m_shr_record_of_loc. +set (m1' := choice_mode m (Rlt_bool x 0) m1 l1). +intros (H1a,H1b) H1c. +rewrite H1c. +assert (Hm: (m1 <= m1')%Z). +(* . *) +unfold m1', choice_mode, cond_incr. +case m ; + try apply Z.le_refl ; + match goal with |- (m1 <= if ?b then _ else _)%Z => + case b ; [ apply Zle_succ | apply Z.le_refl ] end. +assert (Hr: Rabs (round radix2 fexp (round_mode m) x) = F2R (Float radix2 m1' e1)). +(* . *) +rewrite <- (Z.abs_eq m1'). +replace (Z.abs m1') with (Z.abs (cond_Zopp (Rlt_bool x 0) m1')). +rewrite F2R_Zabs. +now apply f_equal. +apply abs_cond_Zopp. +apply Z.le_trans with (2 := Hm). +apply Zlt_succ_le. +apply gt_0_F2R with radix2 e1. +apply Rle_lt_trans with (1 := Rabs_pos x). +exact (proj2 (inbetween_float_bounds _ _ _ _ _ H1a)). +(* . *) +assert (Br: inbetween_float radix2 m1' e1 (Rabs (round radix2 fexp (round_mode m) x)) loc_Exact). +now apply inbetween_Exact. +destruct m1' as [|m1'|m1']. +(* . m1' = 0 *) +rewrite shr_truncate. 2: apply Z.le_refl. +generalize (truncate_0 radix2 fexp e1 loc_Exact). +destruct (truncate radix2 fexp (Z0, e1, loc_Exact)) as ((m2, e2), l2). +rewrite shr_m_shr_record_of_loc. +intros Hm2. +rewrite Hm2. +repeat split. +rewrite Rlt_bool_true. +repeat split. +apply sym_eq. +case Rlt_bool ; apply F2R_0. +rewrite <- F2R_Zabs, abs_cond_Zopp, F2R_0. +apply bpow_gt_0. +(* . 0 < m1' *) +assert (He: (e1 <= fexp (Zdigits radix2 (Zpos m1') + e1))%Z). +rewrite <- mag_F2R_Zdigits, <- Hr, mag_abs. +2: discriminate. +rewrite H1b. +rewrite cexp_abs. +fold (cexp radix2 fexp (round radix2 fexp (round_mode m) x)). +apply cexp_round_ge... +rewrite H1c. +case (Rlt_bool x 0). +apply Rlt_not_eq. +now apply F2R_lt_0. +apply Rgt_not_eq. +now apply F2R_gt_0. +refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Br He)). +2: now rewrite Hr ; apply F2R_gt_0. +refine (_ (truncate_correct_format radix2 fexp (Zpos m1') e1 _ _ He)). +2: discriminate. +rewrite shr_truncate. 2: easy. +destruct (truncate radix2 fexp (Zpos m1', e1, loc_Exact)) as ((m2, e2), l2). +rewrite shr_m_shr_record_of_loc. +intros (H3,H4) (H2,_). +destruct m2 as [|m2|m2]. +elim Rgt_not_eq with (2 := H3). +rewrite F2R_0. +now apply F2R_gt_0. +rewrite F2R_cond_Zopp, H3, abs_cond_Ropp, <- F2R_abs. +simpl Z.abs. +case_eq (Zle_bool e2 (emax - prec)) ; intros He2. +assert (bounded m2 e2 = true). +apply andb_true_intro. +split. +unfold canonical_mantissa. +apply Zeq_bool_true. +rewrite Zpos_digits2_pos. +rewrite <- mag_F2R_Zdigits. +apply sym_eq. +now rewrite H3 in H4. +discriminate. +exact He2. +apply (conj H). +rewrite Rlt_bool_true. +repeat split. +apply F2R_cond_Zopp. +now apply bounded_lt_emax. +rewrite (Rlt_bool_false _ (bpow radix2 emax)). +refine (conj _ (refl_equal _)). +unfold binary_overflow. +case overflow_to_inf. +apply refl_equal. +unfold valid_binary, bounded. +rewrite Zle_bool_refl. +rewrite Bool.andb_true_r. +apply Zeq_bool_true. +rewrite Zpos_digits2_pos. +replace (Zdigits radix2 (Zpos (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end))) with prec. +unfold fexp, FLT_exp, emin. +generalize (prec_gt_0 prec). +clear -Hmax ; zify ; omega. +change 2%Z with (radix_val radix2). +case_eq (Zpower radix2 prec - 1)%Z. +simpl Zdigits. +generalize (Zpower_gt_1 radix2 prec (prec_gt_0 prec)). +clear ; omega. +intros p Hp. +apply Zle_antisym. +cut (prec - 1 < Zdigits radix2 (Zpos p))%Z. clear ; omega. +apply Zdigits_gt_Zpower. +simpl Z.abs. rewrite <- Hp. +cut (Zpower radix2 (prec - 1) < Zpower radix2 prec)%Z. clear ; omega. +apply lt_IZR. +rewrite 2!IZR_Zpower. 2: now apply Zlt_le_weak. +apply bpow_lt. +apply Zlt_pred. +now apply Zlt_0_le_0_pred. +apply Zdigits_le_Zpower. +simpl Z.abs. rewrite <- Hp. +apply Zlt_pred. +intros p Hp. +generalize (Zpower_gt_1 radix2 _ (prec_gt_0 prec)). +clear -Hp ; zify ; omega. +apply Rnot_lt_le. +intros Hx. +generalize (refl_equal (bounded m2 e2)). +unfold bounded at 2. +rewrite He2. +rewrite Bool.andb_false_r. +rewrite bounded_canonical_lt_emax with (2 := Hx). +discriminate. +unfold canonical. +now rewrite <- H3. +elim Rgt_not_eq with (2 := H3). +apply Rlt_trans with R0. +now apply F2R_lt_0. +now apply F2R_gt_0. +rewrite <- Hr. +apply generic_format_abs... +apply generic_format_round... +(* . not m1' < 0 *) +elim Rgt_not_eq with (2 := Hr). +apply Rlt_le_trans with R0. +now apply F2R_lt_0. +apply Rabs_pos. +(* *) +apply Rlt_le_trans with (2 := proj1 (inbetween_float_bounds _ _ _ _ _ Bx)). +now apply F2R_gt_0. +(* all the modes are valid *) +clear. case m. +exact inbetween_int_NE_sign. +exact inbetween_int_ZR_sign. +exact inbetween_int_DN_sign. +exact inbetween_int_UP_sign. +exact inbetween_int_NA_sign. +Qed. + +(** Multiplication *) + +Lemma Bmult_correct_aux : + forall m sx mx ex (Hx : bounded mx ex = true) sy my ey (Hy : bounded my ey = true), + let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in + let y := F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey) in + let z := binary_round_aux m (xorb sx sy) (Zpos (mx * my)) (ex + ey) loc_Exact in + valid_binary z = true /\ + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x * y))) (bpow radix2 emax) then + FF2R radix2 z = round radix2 fexp (round_mode m) (x * y) /\ + is_finite_FF z = true /\ sign_FF z = xorb sx sy + else + z = binary_overflow m (xorb sx sy). +Proof. +intros m sx mx ex Hx sy my ey Hy x y. +unfold x, y. +rewrite <- F2R_mult. +simpl. +replace (xorb sx sy) with (Rlt_bool (F2R (Float radix2 (cond_Zopp sx (Zpos mx) * cond_Zopp sy (Zpos my)) (ex + ey))) 0). +apply binary_round_aux_correct. +constructor. +rewrite <- F2R_abs. +apply F2R_eq. +rewrite Zabs_Zmult. +now rewrite 2!abs_cond_Zopp. +(* *) +change (Zpos (mx * my)) with (Zpos mx * Zpos my)%Z. +assert (forall m e, bounded m e = true -> fexp (Zdigits radix2 (Zpos m) + e) = e)%Z. +clear. intros m e Hb. +destruct (andb_prop _ _ Hb) as (H,_). +apply Zeq_bool_eq. +now rewrite <- Zpos_digits2_pos. +generalize (H _ _ Hx) (H _ _ Hy). +clear x y sx sy Hx Hy H. +unfold fexp, FLT_exp. +refine (_ (Zdigits_mult_ge radix2 (Zpos mx) (Zpos my) _ _)) ; try discriminate. +refine (_ (Zdigits_gt_0 radix2 (Zpos mx) _) (Zdigits_gt_0 radix2 (Zpos my) _)) ; try discriminate. +generalize (Zdigits radix2 (Zpos mx)) (Zdigits radix2 (Zpos my)) (Zdigits radix2 (Zpos mx * Zpos my)). +clear -Hmax. +unfold emin. +intros dx dy dxy Hx Hy Hxy. +zify ; intros ; subst. +omega. +(* *) +case sx ; case sy. +apply Rlt_bool_false. +now apply F2R_ge_0. +apply Rlt_bool_true. +now apply F2R_lt_0. +apply Rlt_bool_true. +now apply F2R_lt_0. +apply Rlt_bool_false. +now apply F2R_ge_0. +Qed. + +Definition Bmult mult_nan m x y := + match x, y with + | B754_nan _ _ _, _ | _, B754_nan _ _ _ => build_nan (mult_nan x y) + | B754_infinity sx, B754_infinity sy => B754_infinity (xorb sx sy) + | B754_infinity sx, B754_finite sy _ _ _ => B754_infinity (xorb sx sy) + | B754_finite sx _ _ _, B754_infinity sy => B754_infinity (xorb sx sy) + | B754_infinity _, B754_zero _ => build_nan (mult_nan x y) + | B754_zero _, B754_infinity _ => build_nan (mult_nan x y) + | B754_finite sx _ _ _, B754_zero sy => B754_zero (xorb sx sy) + | B754_zero sx, B754_finite sy _ _ _ => B754_zero (xorb sx sy) + | B754_zero sx, B754_zero sy => B754_zero (xorb sx sy) + | B754_finite sx mx ex Hx, B754_finite sy my ey Hy => + FF2B _ (proj1 (Bmult_correct_aux m sx mx ex Hx sy my ey Hy)) + end. + +Theorem Bmult_correct : + forall mult_nan m x y, + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x * B2R y))) (bpow radix2 emax) then + B2R (Bmult mult_nan m x y) = round radix2 fexp (round_mode m) (B2R x * B2R y) /\ + is_finite (Bmult mult_nan m x y) = andb (is_finite x) (is_finite y) /\ + (is_nan (Bmult mult_nan m x y) = false -> + Bsign (Bmult mult_nan m x y) = xorb (Bsign x) (Bsign y)) + else + B2FF (Bmult mult_nan m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)). +Proof. +intros mult_nan m [sx|sx|sx plx Hplx|sx mx ex Hx] [sy|sy|sy ply Hply|sy my ey Hy] ; + try ( rewrite ?Rmult_0_r, ?Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ simpl ; try easy ; now rewrite B2R_build_nan, is_finite_build_nan, is_nan_build_nan | apply bpow_gt_0 | now auto with typeclass_instances ] ). +simpl. +case Bmult_correct_aux. +intros H1. +case Rlt_bool. +intros (H2, (H3, H4)). +split. +now rewrite B2R_FF2B. +split. +now rewrite is_finite_FF2B. +rewrite Bsign_FF2B. auto. +intros H2. +now rewrite B2FF_FF2B. +Qed. + +(** Normalization and rounding *) + +Definition shl_align mx ex ex' := + match (ex' - ex)%Z with + | Zneg d => (shift_pos d mx, ex') + | _ => (mx, ex) + end. + +Theorem shl_align_correct : + forall mx ex ex', + let (mx', ex'') := shl_align mx ex ex' in + F2R (Float radix2 (Zpos mx) ex) = F2R (Float radix2 (Zpos mx') ex'') /\ + (ex'' <= ex')%Z. +Proof. +intros mx ex ex'. +unfold shl_align. +case_eq (ex' - ex)%Z. +(* d = 0 *) +intros H. +repeat split. +rewrite Zminus_eq with (1 := H). +apply Z.le_refl. +(* d > 0 *) +intros d Hd. +repeat split. +replace ex' with (ex' - ex + ex)%Z by ring. +rewrite Hd. +pattern ex at 1 ; rewrite <- Zplus_0_l. +now apply Zplus_le_compat_r. +(* d < 0 *) +intros d Hd. +rewrite shift_pos_correct, Zmult_comm. +change (Zpower_pos 2 d) with (Zpower radix2 (Zpos d)). +change (Zpos d) with (Z.opp (Zneg d)). +rewrite <- Hd. +split. +replace (- (ex' - ex))%Z with (ex - ex')%Z by ring. +apply F2R_change_exp. +apply Zle_0_minus_le. +replace (ex - ex')%Z with (- (ex' - ex))%Z by ring. +now rewrite Hd. +apply Z.le_refl. +Qed. + +Theorem snd_shl_align : + forall mx ex ex', + (ex' <= ex)%Z -> + snd (shl_align mx ex ex') = ex'. +Proof. +intros mx ex ex' He. +unfold shl_align. +case_eq (ex' - ex)%Z ; simpl. +intros H. +now rewrite Zminus_eq with (1 := H). +intros p. +clear -He ; zify ; omega. +intros. +apply refl_equal. +Qed. + +Definition shl_align_fexp mx ex := + shl_align mx ex (fexp (Zpos (digits2_pos mx) + ex)). + +Theorem shl_align_fexp_correct : + forall mx ex, + let (mx', ex') := shl_align_fexp mx ex in + F2R (Float radix2 (Zpos mx) ex) = F2R (Float radix2 (Zpos mx') ex') /\ + (ex' <= fexp (Zdigits radix2 (Zpos mx') + ex'))%Z. +Proof. +intros mx ex. +unfold shl_align_fexp. +generalize (shl_align_correct mx ex (fexp (Zpos (digits2_pos mx) + ex))). +rewrite Zpos_digits2_pos. +case shl_align. +intros mx' ex' (H1, H2). +split. +exact H1. +rewrite <- mag_F2R_Zdigits. 2: easy. +rewrite <- H1. +now rewrite mag_F2R_Zdigits. +Qed. + +Definition binary_round m sx mx ex := + let '(mz, ez) := shl_align_fexp mx ex in binary_round_aux m sx (Zpos mz) ez loc_Exact. + +Theorem binary_round_correct : + forall m sx mx ex, + let z := binary_round m sx mx ex in + valid_binary z = true /\ + let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) x)) (bpow radix2 emax) then + FF2R radix2 z = round radix2 fexp (round_mode m) x /\ + is_finite_FF z = true /\ + sign_FF z = sx + else + z = binary_overflow m sx. +Proof. +intros m sx mx ex. +unfold binary_round. +generalize (shl_align_fexp_correct mx ex). +destruct (shl_align_fexp mx ex) as (mz, ez). +intros (H1, H2). +set (x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex)). +replace sx with (Rlt_bool x 0). +apply binary_round_aux_correct. +constructor. +unfold x. +now rewrite <- F2R_Zabs, abs_cond_Zopp. +exact H2. +unfold x. +case sx. +apply Rlt_bool_true. +now apply F2R_lt_0. +apply Rlt_bool_false. +now apply F2R_ge_0. +Qed. + +Definition binary_normalize mode m e szero := + match m with + | Z0 => B754_zero szero + | Zpos m => FF2B _ (proj1 (binary_round_correct mode false m e)) + | Zneg m => FF2B _ (proj1 (binary_round_correct mode true m e)) + end. + +Theorem binary_normalize_correct : + forall m mx ex szero, + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (F2R (Float radix2 mx ex)))) (bpow radix2 emax) then + B2R (binary_normalize m mx ex szero) = round radix2 fexp (round_mode m) (F2R (Float radix2 mx ex)) /\ + is_finite (binary_normalize m mx ex szero) = true /\ + Bsign (binary_normalize m mx ex szero) = + match Rcompare (F2R (Float radix2 mx ex)) 0 with + | Eq => szero + | Lt => true + | Gt => false + end + else + B2FF (binary_normalize m mx ex szero) = binary_overflow m (Rlt_bool (F2R (Float radix2 mx ex)) 0). +Proof with auto with typeclass_instances. +intros m mx ez szero. +destruct mx as [|mz|mz] ; simpl. +rewrite F2R_0, round_0, Rabs_R0, Rlt_bool_true... +split... split... +rewrite Rcompare_Eq... +apply bpow_gt_0. +(* . mz > 0 *) +generalize (binary_round_correct m false mz ez). +simpl. +case Rlt_bool_spec. +intros _ (Vz, (Rz, (Rz', Rz''))). +split. +now rewrite B2R_FF2B. +split. +now rewrite is_finite_FF2B. +rewrite Bsign_FF2B, Rz''. +rewrite Rcompare_Gt... +apply F2R_gt_0. +simpl. zify; omega. +intros Hz' (Vz, Rz). +rewrite B2FF_FF2B, Rz. +apply f_equal. +apply sym_eq. +apply Rlt_bool_false. +now apply F2R_ge_0. +(* . mz < 0 *) +generalize (binary_round_correct m true mz ez). +simpl. +case Rlt_bool_spec. +intros _ (Vz, (Rz, (Rz', Rz''))). +split. +now rewrite B2R_FF2B. +split. +now rewrite is_finite_FF2B. +rewrite Bsign_FF2B, Rz''. +rewrite Rcompare_Lt... +apply F2R_lt_0. +simpl. zify; omega. +intros Hz' (Vz, Rz). +rewrite B2FF_FF2B, Rz. +apply f_equal. +apply sym_eq. +apply Rlt_bool_true. +now apply F2R_lt_0. +Qed. + +(** Addition *) + +Definition Bplus plus_nan m x y := + match x, y with + | B754_nan _ _ _, _ | _, B754_nan _ _ _ => build_nan (plus_nan x y) + | B754_infinity sx, B754_infinity sy => + if Bool.eqb sx sy then x else build_nan (plus_nan x y) + | B754_infinity _, _ => x + | _, B754_infinity _ => y + | B754_zero sx, B754_zero sy => + if Bool.eqb sx sy then x else + match m with mode_DN => B754_zero true | _ => B754_zero false end + | B754_zero _, _ => y + | _, B754_zero _ => x + | B754_finite sx mx ex Hx, B754_finite sy my ey Hy => + let ez := Z.min ex ey in + binary_normalize m (Zplus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez))))) + ez (match m with mode_DN => true | _ => false end) + end. + +Theorem Bplus_correct : + forall plus_nan m x y, + is_finite x = true -> + is_finite y = true -> + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x + B2R y))) (bpow radix2 emax) then + B2R (Bplus plus_nan m x y) = round radix2 fexp (round_mode m) (B2R x + B2R y) /\ + is_finite (Bplus plus_nan m x y) = true /\ + Bsign (Bplus plus_nan m x y) = + match Rcompare (B2R x + B2R y) 0 with + | Eq => match m with mode_DN => orb (Bsign x) (Bsign y) + | _ => andb (Bsign x) (Bsign y) end + | Lt => true + | Gt => false + end + else + (B2FF (Bplus plus_nan m x y) = binary_overflow m (Bsign x) /\ Bsign x = Bsign y). +Proof with auto with typeclass_instances. +intros plus_nan m [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] Fx Fy ; try easy. +(* *) +rewrite Rplus_0_r, round_0, Rabs_R0, Rlt_bool_true... +simpl. +rewrite Rcompare_Eq by auto. +destruct sx, sy; try easy; now case m. +apply bpow_gt_0. +(* *) +rewrite Rplus_0_l, round_generic, Rlt_bool_true... +split... split... +simpl. unfold F2R. +erewrite <- Rmult_0_l, Rcompare_mult_r. +rewrite Rcompare_IZR with (y:=0%Z). +destruct sy... +apply bpow_gt_0. +apply abs_B2R_lt_emax. +apply generic_format_B2R. +(* *) +rewrite Rplus_0_r, round_generic, Rlt_bool_true... +split... split... +simpl. unfold F2R. +erewrite <- Rmult_0_l, Rcompare_mult_r. +rewrite Rcompare_IZR with (y:=0%Z). +destruct sx... +apply bpow_gt_0. +apply abs_B2R_lt_emax. +apply generic_format_B2R. +(* *) +clear Fx Fy. +simpl. +set (szero := match m with mode_DN => true | _ => false end). +set (ez := Z.min ex ey). +set (mz := (cond_Zopp sx (Zpos (fst (shl_align mx ex ez))) + cond_Zopp sy (Zpos (fst (shl_align my ey ez))))%Z). +assert (Hp: (F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) + + F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey))%R = F2R (Float radix2 mz ez)). +rewrite 2!F2R_cond_Zopp. +generalize (shl_align_correct mx ex ez). +generalize (shl_align_correct my ey ez). +generalize (snd_shl_align mx ex ez (Z.le_min_l ex ey)). +generalize (snd_shl_align my ey ez (Z.le_min_r ex ey)). +destruct (shl_align mx ex ez) as (mx', ex'). +destruct (shl_align my ey ez) as (my', ey'). +simpl. +intros H1 H2. +rewrite H1, H2. +clear H1 H2. +intros (H1, _) (H2, _). +rewrite H1, H2. +clear H1 H2. +rewrite <- 2!F2R_cond_Zopp. +unfold F2R. simpl. +now rewrite <- Rmult_plus_distr_r, <- plus_IZR. +rewrite Hp. +assert (Sz: (bpow radix2 emax <= Rabs (round radix2 fexp (round_mode m) (F2R (Float radix2 mz ez))))%R -> sx = Rlt_bool (F2R (Float radix2 mz ez)) 0 /\ sx = sy). +(* . *) +rewrite <- Hp. +intros Bz. +destruct (Bool.bool_dec sx sy) as [Hs|Hs]. +(* .. *) +refine (conj _ Hs). +rewrite Hs. +apply sym_eq. +case sy. +apply Rlt_bool_true. +rewrite <- (Rplus_0_r 0). +apply Rplus_lt_compat. +now apply F2R_lt_0. +now apply F2R_lt_0. +apply Rlt_bool_false. +rewrite <- (Rplus_0_r 0). +apply Rplus_le_compat. +now apply F2R_ge_0. +now apply F2R_ge_0. +(* .. *) +elim Rle_not_lt with (1 := Bz). +generalize (bounded_lt_emax _ _ Hx) (bounded_lt_emax _ _ Hy) (andb_prop _ _ Hx) (andb_prop _ _ Hy). +intros Bx By (Hx',_) (Hy',_). +generalize (canonical_canonical_mantissa sx _ _ Hx') (canonical_canonical_mantissa sy _ _ Hy'). +clear -Bx By Hs prec_gt_0_. +intros Cx Cy. +destruct sx. +(* ... *) +destruct sy. +now elim Hs. +clear Hs. +apply Rabs_lt. +split. +apply Rlt_le_trans with (F2R (Float radix2 (cond_Zopp true (Zpos mx)) ex)). +rewrite F2R_Zopp. +now apply Ropp_lt_contravar. +apply round_ge_generic... +now apply generic_format_canonical. +pattern (F2R (Float radix2 (cond_Zopp true (Zpos mx)) ex)) at 1 ; rewrite <- Rplus_0_r. +apply Rplus_le_compat_l. +now apply F2R_ge_0. +apply Rle_lt_trans with (2 := By). +apply round_le_generic... +now apply generic_format_canonical. +rewrite <- (Rplus_0_l (F2R (Float radix2 (Zpos my) ey))). +apply Rplus_le_compat_r. +now apply F2R_le_0. +(* ... *) +destruct sy. +2: now elim Hs. +clear Hs. +apply Rabs_lt. +split. +apply Rlt_le_trans with (F2R (Float radix2 (cond_Zopp true (Zpos my)) ey)). +rewrite F2R_Zopp. +now apply Ropp_lt_contravar. +apply round_ge_generic... +now apply generic_format_canonical. +pattern (F2R (Float radix2 (cond_Zopp true (Zpos my)) ey)) at 1 ; rewrite <- Rplus_0_l. +apply Rplus_le_compat_r. +now apply F2R_ge_0. +apply Rle_lt_trans with (2 := Bx). +apply round_le_generic... +now apply generic_format_canonical. +rewrite <- (Rplus_0_r (F2R (Float radix2 (Zpos mx) ex))). +apply Rplus_le_compat_l. +now apply F2R_le_0. +(* . *) +generalize (binary_normalize_correct m mz ez szero). +case Rlt_bool_spec. +split; try easy. split; try easy. +destruct (Rcompare_spec (F2R (beta:=radix2) {| Fnum := mz; Fexp := ez |}) 0); try easy. +rewrite H1 in Hp. +apply Rplus_opp_r_uniq in Hp. +rewrite <- F2R_Zopp in Hp. +eapply canonical_unique in Hp. +inversion Hp. destruct sy, sx, m; try discriminate H3; easy. +apply canonical_canonical_mantissa. +apply Bool.andb_true_iff in Hy. easy. +replace (-cond_Zopp sx (Z.pos mx))%Z with (cond_Zopp (negb sx) (Z.pos mx)) + by (destruct sx; auto). +apply canonical_canonical_mantissa. +apply Bool.andb_true_iff in Hx. easy. +intros Hz' Vz. +specialize (Sz Hz'). +split. +rewrite Vz. +now apply f_equal. +apply Sz. +Qed. + +(** Subtraction *) + +Definition Bminus minus_nan m x y := + match x, y with + | B754_nan _ _ _, _ | _, B754_nan _ _ _ => build_nan (minus_nan x y) + | B754_infinity sx, B754_infinity sy => + if Bool.eqb sx (negb sy) then x else build_nan (minus_nan x y) + | B754_infinity _, _ => x + | _, B754_infinity sy => B754_infinity (negb sy) + | B754_zero sx, B754_zero sy => + if Bool.eqb sx (negb sy) then x else + match m with mode_DN => B754_zero true | _ => B754_zero false end + | B754_zero _, B754_finite sy my ey Hy => B754_finite (negb sy) my ey Hy + | _, B754_zero _ => x + | B754_finite sx mx ex Hx, B754_finite sy my ey Hy => + let ez := Z.min ex ey in + binary_normalize m (Zminus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez))))) + ez (match m with mode_DN => true | _ => false end) + end. + +Theorem Bminus_correct : + forall minus_nan m x y, + is_finite x = true -> + is_finite y = true -> + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x - B2R y))) (bpow radix2 emax) then + B2R (Bminus minus_nan m x y) = round radix2 fexp (round_mode m) (B2R x - B2R y) /\ + is_finite (Bminus minus_nan m x y) = true /\ + Bsign (Bminus minus_nan m x y) = + match Rcompare (B2R x - B2R y) 0 with + | Eq => match m with mode_DN => orb (Bsign x) (negb (Bsign y)) + | _ => andb (Bsign x) (negb (Bsign y)) end + | Lt => true + | Gt => false + end + else + (B2FF (Bminus minus_nan m x y) = binary_overflow m (Bsign x) /\ Bsign x = negb (Bsign y)). +Proof with auto with typeclass_instances. +intros minus_nan m x y Fx Fy. +generalize (Bplus_correct minus_nan m x (Bopp (fun n => minus_nan n (B754_zero false)) y) Fx). +rewrite is_finite_Bopp, B2R_Bopp. +intros H. +specialize (H Fy). +replace (negb (Bsign y)) with (Bsign (Bopp (fun n => minus_nan n (B754_zero false)) y)). +destruct x as [| | |sx mx ex Hx], y as [| | |sy my ey Hy] ; try easy. +unfold Bminus, Zminus. +now rewrite <- cond_Zopp_negb. +now destruct y as [ | | | ]. +Qed. + +(** Division *) + +Definition Fdiv_core_binary m1 e1 m2 e2 := + let d1 := Zdigits2 m1 in + let d2 := Zdigits2 m2 in + let e' := Z.min (fexp (d1 + e1 - (d2 + e2))) (e1 - e2) in + let s := (e1 - e2 - e')%Z in + let m' := + match s with + | Zpos _ => Z.shiftl m1 s + | Z0 => m1 + | Zneg _ => Z0 + end in + let '(q, r) := Zfast_div_eucl m' m2 in + (q, e', new_location m2 r loc_Exact). + +Lemma Bdiv_correct_aux : + forall m sx mx ex sy my ey, + let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in + let y := F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey) in + let z := + let '(mz, ez, lz) := Fdiv_core_binary (Zpos mx) ex (Zpos my) ey in + binary_round_aux m (xorb sx sy) mz ez lz in + valid_binary z = true /\ + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x / y))) (bpow radix2 emax) then + FF2R radix2 z = round radix2 fexp (round_mode m) (x / y) /\ + is_finite_FF z = true /\ sign_FF z = xorb sx sy + else + z = binary_overflow m (xorb sx sy). +Proof. +intros m sx mx ex sy my ey. +unfold Fdiv_core_binary. +rewrite 2!Zdigits2_Zdigits. +set (e' := Z.min _ _). +generalize (Fdiv_core_correct radix2 (Zpos mx) ex (Zpos my) ey e' eq_refl eq_refl). +unfold Fdiv_core. +rewrite Zle_bool_true by apply Z.le_min_r. +match goal with |- context [Zfast_div_eucl ?m _] => set (mx' := m) end. +assert (mx' = Zpos mx * Zpower radix2 (ex - ey - e'))%Z as <-. +{ unfold mx'. + destruct (ex - ey - e')%Z as [|p|p]. + now rewrite Zmult_1_r. + now rewrite Z.shiftl_mul_pow2. + easy. } +clearbody mx'. +rewrite Zfast_div_eucl_correct. +destruct Z.div_eucl as [q r]. +intros Bz. +assert (xorb sx sy = Rlt_bool (F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) * + / F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey)) 0) as ->. +{ apply eq_sym. +case sy ; simpl. +change (Zneg my) with (Z.opp (Zpos my)). +rewrite F2R_Zopp. +rewrite <- Ropp_inv_permute. +rewrite Ropp_mult_distr_r_reverse. +case sx ; simpl. +apply Rlt_bool_false. +rewrite <- Ropp_mult_distr_l_reverse. +apply Rmult_le_pos. +rewrite <- F2R_opp. +now apply F2R_ge_0. +apply Rlt_le. +apply Rinv_0_lt_compat. +now apply F2R_gt_0. +apply Rlt_bool_true. +rewrite <- Ropp_0. +apply Ropp_lt_contravar. +apply Rmult_lt_0_compat. +now apply F2R_gt_0. +apply Rinv_0_lt_compat. +now apply F2R_gt_0. +apply Rgt_not_eq. +now apply F2R_gt_0. +case sx. +apply Rlt_bool_true. +rewrite F2R_Zopp. +rewrite Ropp_mult_distr_l_reverse. +rewrite <- Ropp_0. +apply Ropp_lt_contravar. +apply Rmult_lt_0_compat. +now apply F2R_gt_0. +apply Rinv_0_lt_compat. +now apply F2R_gt_0. +apply Rlt_bool_false. +apply Rmult_le_pos. +now apply F2R_ge_0. +apply Rlt_le. +apply Rinv_0_lt_compat. +now apply F2R_gt_0. } +unfold Rdiv. +apply binary_round_aux_correct'. +- apply Rmult_integral_contrapositive_currified. + now apply F2R_neq_0 ; case sx. + apply Rinv_neq_0_compat. + now apply F2R_neq_0 ; case sy. +- rewrite Rabs_mult, Rabs_Rinv. + now rewrite <- 2!F2R_Zabs, 2!abs_cond_Zopp. + now apply F2R_neq_0 ; case sy. +- rewrite <- cexp_abs, Rabs_mult, Rabs_Rinv. + rewrite 2!F2R_cond_Zopp, 2!abs_cond_Ropp, <- Rabs_Rinv. + rewrite <- Rabs_mult, cexp_abs. + apply Z.le_trans with (1 := Z.le_min_l _ _). + apply FLT_exp_monotone. + now apply mag_div_F2R. + now apply F2R_neq_0. + now apply F2R_neq_0 ; case sy. +Qed. + +Definition Bdiv div_nan m x y := + match x, y with + | B754_nan _ _ _, _ | _, B754_nan _ _ _ => build_nan (div_nan x y) + | B754_infinity sx, B754_infinity sy => build_nan (div_nan x y) + | B754_infinity sx, B754_finite sy _ _ _ => B754_infinity (xorb sx sy) + | B754_finite sx _ _ _, B754_infinity sy => B754_zero (xorb sx sy) + | B754_infinity sx, B754_zero sy => B754_infinity (xorb sx sy) + | B754_zero sx, B754_infinity sy => B754_zero (xorb sx sy) + | B754_finite sx _ _ _, B754_zero sy => B754_infinity (xorb sx sy) + | B754_zero sx, B754_finite sy _ _ _ => B754_zero (xorb sx sy) + | B754_zero sx, B754_zero sy => build_nan (div_nan x y) + | B754_finite sx mx ex _, B754_finite sy my ey _ => + FF2B _ (proj1 (Bdiv_correct_aux m sx mx ex sy my ey)) + end. + +Theorem Bdiv_correct : + forall div_nan m x y, + B2R y <> 0%R -> + if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x / B2R y))) (bpow radix2 emax) then + B2R (Bdiv div_nan m x y) = round radix2 fexp (round_mode m) (B2R x / B2R y) /\ + is_finite (Bdiv div_nan m x y) = is_finite x /\ + (is_nan (Bdiv div_nan m x y) = false -> + Bsign (Bdiv div_nan m x y) = xorb (Bsign x) (Bsign y)) + else + B2FF (Bdiv div_nan m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)). +Proof. +intros div_nan m x [sy|sy|sy ply|sy my ey Hy] Zy ; try now elim Zy. +revert x. +unfold Rdiv. +intros [sx|sx|sx plx Hx|sx mx ex Hx] ; + try ( rewrite Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ simpl ; try easy ; now rewrite B2R_build_nan, is_finite_build_nan, is_nan_build_nan | apply bpow_gt_0 | auto with typeclass_instances ] ). +simpl. +case Bdiv_correct_aux. +intros H1. +unfold Rdiv. +case Rlt_bool. +intros (H2, (H3, H4)). +split. +now rewrite B2R_FF2B. +split. +now rewrite is_finite_FF2B. +rewrite Bsign_FF2B. congruence. +intros H2. +now rewrite B2FF_FF2B. +Qed. + +(** Square root *) + +Definition Fsqrt_core_binary m e := + let d := Zdigits2 m in + let e' := Z.min (fexp (Z.div2 (d + e + 1))) (Z.div2 e) in + let s := (e - 2 * e')%Z in + let m' := + match s with + | Zpos p => Z.shiftl m s + | Z0 => m + | Zneg _ => Z0 + end in + let (q, r) := Z.sqrtrem m' in + let l := + if Zeq_bool r 0 then loc_Exact + else loc_Inexact (if Zle_bool r q then Lt else Gt) in + (q, e', l). + +Lemma Bsqrt_correct_aux : + forall m mx ex (Hx : bounded mx ex = true), + let x := F2R (Float radix2 (Zpos mx) ex) in + let z := + let '(mz, ez, lz) := Fsqrt_core_binary (Zpos mx) ex in + binary_round_aux m false mz ez lz in + valid_binary z = true /\ + FF2R radix2 z = round radix2 fexp (round_mode m) (sqrt x) /\ + is_finite_FF z = true /\ sign_FF z = false. +Proof with auto with typeclass_instances. +intros m mx ex Hx. +unfold Fsqrt_core_binary. +rewrite Zdigits2_Zdigits. +set (e' := Z.min _ _). +assert (2 * e' <= ex)%Z as He. +{ assert (e' <= Z.div2 ex)%Z by apply Z.le_min_r. + rewrite (Zdiv2_odd_eqn ex). + destruct Z.odd ; omega. } +generalize (Fsqrt_core_correct radix2 (Zpos mx) ex e' eq_refl He). +unfold Fsqrt_core. +set (mx' := match (ex - 2 * e')%Z with Z0 => _ | _ => _ end). +assert (mx' = Zpos mx * Zpower radix2 (ex - 2 * e'))%Z as <-. +{ unfold mx'. + destruct (ex - 2 * e')%Z as [|p|p]. + now rewrite Zmult_1_r. + now rewrite Z.shiftl_mul_pow2. + easy. } +clearbody mx'. +destruct Z.sqrtrem as [mz r]. +set (lz := if Zeq_bool r 0 then _ else _). +clearbody lz. +intros Bz. +refine (_ (binary_round_aux_correct' m (sqrt (F2R (Float radix2 (Zpos mx) ex))) mz e' lz _ _ _)) ; cycle 1. + now apply Rgt_not_eq, sqrt_lt_R0, F2R_gt_0. + rewrite Rabs_pos_eq. + exact Bz. + apply sqrt_ge_0. + apply Z.le_trans with (1 := Z.le_min_l _ _). + apply FLT_exp_monotone. + rewrite mag_sqrt_F2R by easy. + apply Z.le_refl. +rewrite Rlt_bool_false by apply sqrt_ge_0. +rewrite Rlt_bool_true. +easy. +rewrite Rabs_pos_eq. +refine (_ (relative_error_FLT_ex radix2 emin prec (prec_gt_0 prec) (round_mode m) (sqrt (F2R (Float radix2 (Zpos mx) ex))) _)). +fold fexp. +intros (eps, (Heps, Hr)). +rewrite Hr. +assert (Heps': (Rabs eps < 1)%R). +apply Rlt_le_trans with (1 := Heps). +fold (bpow radix2 0). +apply bpow_le. +generalize (prec_gt_0 prec). +clear ; omega. +apply Rsqr_incrst_0. +3: apply bpow_ge_0. +rewrite Rsqr_mult. +rewrite Rsqr_sqrt. +2: now apply F2R_ge_0. +unfold Rsqr. +apply Rmult_ge_0_gt_0_lt_compat. +apply Rle_ge. +apply Rle_0_sqr. +apply bpow_gt_0. +now apply bounded_lt_emax. +apply Rlt_le_trans with 4%R. +apply (Rsqr_incrst_1 _ 2). +apply Rplus_lt_compat_l. +apply (Rabs_lt_inv _ _ Heps'). +rewrite <- (Rplus_opp_r 1). +apply Rplus_le_compat_l. +apply Rlt_le. +apply (Rabs_lt_inv _ _ Heps'). +now apply IZR_le. +change 4%R with (bpow radix2 2). +apply bpow_le. +generalize (prec_gt_0 prec). +clear -Hmax ; omega. +apply Rmult_le_pos. +apply sqrt_ge_0. +rewrite <- (Rplus_opp_r 1). +apply Rplus_le_compat_l. +apply Rlt_le. +apply (Rabs_lt_inv _ _ Heps'). +rewrite Rabs_pos_eq. +2: apply sqrt_ge_0. +apply Rsqr_incr_0. +2: apply bpow_ge_0. +2: apply sqrt_ge_0. +rewrite Rsqr_sqrt. +2: now apply F2R_ge_0. +apply Rle_trans with (bpow radix2 emin). +unfold Rsqr. +rewrite <- bpow_plus. +apply bpow_le. +unfold emin. +clear -Hmax ; omega. +apply generic_format_ge_bpow with fexp. +intros. +apply Z.le_max_r. +now apply F2R_gt_0. +apply generic_format_canonical. +apply (canonical_canonical_mantissa false). +apply (andb_prop _ _ Hx). +apply round_ge_generic... +apply generic_format_0. +apply sqrt_ge_0. +Qed. + +Definition Bsqrt sqrt_nan m x := + match x with + | B754_nan sx plx _ => build_nan (sqrt_nan x) + | B754_infinity false => x + | B754_infinity true => build_nan (sqrt_nan x) + | B754_finite true _ _ _ => build_nan (sqrt_nan x) + | B754_zero _ => x + | B754_finite sx mx ex Hx => + FF2B _ (proj1 (Bsqrt_correct_aux m mx ex Hx)) + end. + +Theorem Bsqrt_correct : + forall sqrt_nan m x, + B2R (Bsqrt sqrt_nan m x) = round radix2 fexp (round_mode m) (sqrt (B2R x)) /\ + is_finite (Bsqrt sqrt_nan m x) = match x with B754_zero _ => true | B754_finite false _ _ _ => true | _ => false end /\ + (is_nan (Bsqrt sqrt_nan m x) = false -> Bsign (Bsqrt sqrt_nan m x) = Bsign x). +Proof. +intros sqrt_nan m [sx|[|]|sx plx Hplx|sx mx ex Hx] ; + try ( simpl ; rewrite sqrt_0, round_0, ?B2R_build_nan, ?is_finite_build_nan, ?is_nan_build_nan ; intuition auto with typeclass_instances ; easy). +simpl. +case Bsqrt_correct_aux. +intros H1 (H2, (H3, H4)). +case sx. +rewrite B2R_build_nan, is_finite_build_nan, is_nan_build_nan. +refine (conj _ (conj (refl_equal false) _)). +apply sym_eq. +unfold sqrt. +case Rcase_abs. +intros _. +apply round_0. +auto with typeclass_instances. +intros H. +elim Rge_not_lt with (1 := H). +now apply F2R_lt_0. +easy. +split. +now rewrite B2R_FF2B. +split. +now rewrite is_finite_FF2B. +intros _. +now rewrite Bsign_FF2B. +Qed. + +(** A few values *) + +Definition Bone := FF2B _ (proj1 (binary_round_correct mode_NE false 1 0)). + +Theorem Bone_correct : B2R Bone = 1%R. +Proof. +unfold Bone; simpl. +set (Hr := binary_round_correct _ _ _ _). +unfold Hr; rewrite B2R_FF2B. +destruct Hr as (Vz, Hr). +revert Hr. +fold emin; simpl. +rewrite round_generic; [|now apply valid_rnd_N|]. +- unfold F2R; simpl; rewrite Rmult_1_r. + rewrite Rlt_bool_true. + + now intros (Hr, Hr'); rewrite Hr. + + rewrite Rabs_pos_eq; [|lra]. + change 1%R with (bpow radix2 0); apply bpow_lt. + unfold Prec_gt_0 in prec_gt_0_; lia. +- apply generic_format_F2R; intros _. + unfold cexp, fexp, FLT_exp, F2R; simpl; rewrite Rmult_1_r, mag_1. + unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. +Qed. + +Lemma is_finite_Bone : is_finite Bone = true. +Proof. +generalize Bone_correct; case Bone; simpl; + try (intros; reflexivity); intros; exfalso; lra. +Qed. + +Lemma Bsign_Bone : Bsign Bone = false. +Proof. +generalize Bone_correct; case Bone; simpl; + try (intros; exfalso; lra); intros s' m e _. +case s'; [|now intro]; unfold F2R; simpl. +intro H; exfalso; revert H; apply Rlt_not_eq, (Rle_lt_trans _ 0); [|lra]. +rewrite <-Ropp_0, <-(Ropp_involutive (_ * _)); apply Ropp_le_contravar. +rewrite Ropp_mult_distr_l; apply Rmult_le_pos; [|now apply bpow_ge_0]. +unfold IZR; rewrite <-INR_IPR; generalize (INR_pos m); lra. +Qed. + +Lemma Bmax_float_proof : + valid_binary + (F754_finite false (shift_pos (Z.to_pos prec) 1 - 1) (emax - prec)) + = true. +Proof. +unfold valid_binary, bounded; apply andb_true_intro; split. +- unfold canonical_mantissa; apply Zeq_bool_true. + set (p := Z.pos (digits2_pos _)). + assert (H : p = prec). + { unfold p; rewrite Zpos_digits2_pos, Pos2Z.inj_sub. + - rewrite shift_pos_correct, Z.mul_1_r. + assert (P2pm1 : (0 <= 2 ^ prec - 1)%Z). + { apply (Zplus_le_reg_r _ _ 1); ring_simplify. + change 1%Z with (2 ^ 0)%Z; change 2%Z with (radix2 : Z). + apply Zpower_le; unfold Prec_gt_0 in prec_gt_0_; lia. } + apply Zdigits_unique; + rewrite Z.pow_pos_fold, Z2Pos.id; [|exact prec_gt_0_]; simpl; split. + + rewrite (Z.abs_eq _ P2pm1). + replace prec with (prec - 1 + 1)%Z at 2 by ring. + rewrite Zpower_plus; [| unfold Prec_gt_0 in prec_gt_0_; lia|lia]. + simpl; unfold Z.pow_pos; simpl. + assert (1 <= 2 ^ (prec - 1))%Z; [|lia]. + change 1%Z with (2 ^ 0)%Z; change 2%Z with (radix2 : Z). + apply Zpower_le; simpl; unfold Prec_gt_0 in prec_gt_0_; lia. + + now rewrite Z.abs_eq; [lia|]. + - change (_ < _)%positive + with (Z.pos 1 < Z.pos (shift_pos (Z.to_pos prec) 1))%Z. + rewrite shift_pos_correct, Z.mul_1_r, Z.pow_pos_fold. + rewrite Z2Pos.id; [|exact prec_gt_0_]. + change 1%Z with (2 ^ 0)%Z; change 2%Z with (radix2 : Z). + apply Zpower_lt; unfold Prec_gt_0 in prec_gt_0_; lia. } + unfold fexp, FLT_exp; rewrite H, Z.max_l; [ring|]. + unfold Prec_gt_0 in prec_gt_0_; unfold emin; lia. +- apply Zle_bool_true; unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. +Qed. + +Definition Bmax_float := FF2B _ Bmax_float_proof. + +(** Extraction/modification of mantissa/exponent *) + +Definition Bnormfr_mantissa x := + match x with + | B754_finite _ mx ex _ => + if Z.eqb ex (-prec)%Z then Npos mx else 0%N + | _ => 0%N + end. + +Definition Bldexp mode f e := + match f with + | B754_finite sx mx ex _ => + FF2B _ (proj1 (binary_round_correct mode sx mx (ex+e))) + | _ => f + end. + +Theorem Bldexp_correct : + forall m (f : binary_float) e, + if Rlt_bool + (Rabs (round radix2 fexp (round_mode m) (B2R f * bpow radix2 e))) + (bpow radix2 emax) then + (B2R (Bldexp m f e) + = round radix2 fexp (round_mode m) (B2R f * bpow radix2 e))%R /\ + is_finite (Bldexp m f e) = is_finite f /\ + Bsign (Bldexp m f e) = Bsign f + else + B2FF (Bldexp m f e) = binary_overflow m (Bsign f). +Proof. +intros m f e. +case f. +- intro s; simpl; rewrite Rmult_0_l, round_0; [|apply valid_rnd_round_mode]. + now rewrite Rabs_R0, Rlt_bool_true; [|now apply bpow_gt_0]. +- intro s; simpl; rewrite Rmult_0_l, round_0; [|apply valid_rnd_round_mode]. + now rewrite Rabs_R0, Rlt_bool_true; [|now apply bpow_gt_0]. +- intro s; simpl; rewrite Rmult_0_l, round_0; [|apply valid_rnd_round_mode]. + now rewrite Rabs_R0, Rlt_bool_true; [|now apply bpow_gt_0]. +- intros s mf ef Hmef. + case (Rlt_bool_spec _ _); intro Hover. + + unfold Bldexp; rewrite B2R_FF2B, is_finite_FF2B, Bsign_FF2B. + simpl; unfold F2R; simpl; rewrite Rmult_assoc, <-bpow_plus. + destruct (binary_round_correct m s mf (ef + e)) as (Hf, Hr). + fold emin in Hr; simpl in Hr; rewrite Rlt_bool_true in Hr. + * now destruct Hr as (Hr, (Hfr, Hsr)); rewrite Hr, Hfr, Hsr. + * now revert Hover; unfold B2R, F2R; simpl; rewrite Rmult_assoc, bpow_plus. + + unfold Bldexp; rewrite B2FF_FF2B; simpl. + destruct (binary_round_correct m s mf (ef + e)) as (Hf, Hr). + fold emin in Hr; simpl in Hr; rewrite Rlt_bool_false in Hr; [exact Hr|]. + now revert Hover; unfold B2R, F2R; simpl; rewrite Rmult_assoc, bpow_plus. +Qed. + +(** This hypothesis is needed to implement Bfrexp + (otherwise, we have emin > - prec + and Bfrexp cannot fit the mantissa in interval [0.5, 1)) *) +Hypothesis Hemax : (3 <= emax)%Z. + +Definition Ffrexp_core_binary s m e := + if (Z.to_pos prec <=? digits2_pos m)%positive then + (F754_finite s m (-prec), (e + prec)%Z) + else + let d := (prec - Z.pos (digits2_pos m))%Z in + (F754_finite s (shift_pos (Z.to_pos d) m) (-prec), (e + prec - d)%Z). + +Lemma Bfrexp_correct_aux : + forall sx mx ex (Hx : bounded mx ex = true), + let x := F2R (Float radix2 (cond_Zopp sx (Z.pos mx)) ex) in + let z := fst (Ffrexp_core_binary sx mx ex) in + let e := snd (Ffrexp_core_binary sx mx ex) in + valid_binary z = true /\ + (/2 <= Rabs (FF2R radix2 z) < 1)%R /\ + (x = FF2R radix2 z * bpow radix2 e)%R. +Proof. +intros sx mx ex Bx. +set (x := F2R _). +set (z := fst _). +set (e := snd _); simpl. +assert (Dmx_le_prec : (Z.pos (digits2_pos mx) <= prec)%Z). +{ revert Bx; unfold bounded; rewrite Bool.andb_true_iff. + unfold canonical_mantissa; rewrite <-Zeq_is_eq_bool; unfold fexp, FLT_exp. + case (Z.max_spec (Z.pos (digits2_pos mx) + ex - prec) emin); lia. } +assert (Dmx_le_prec' : (digits2_pos mx <= Z.to_pos prec)%positive). +{ change (_ <= _)%positive + with (Z.pos (digits2_pos mx) <= Z.pos (Z.to_pos prec))%Z. + now rewrite Z2Pos.id; [|now apply prec_gt_0_]. } +unfold z, e, Ffrexp_core_binary. +case (Pos.leb_spec _ _); simpl; intro Dmx. +- unfold bounded, F2R; simpl. + assert (Dmx' : digits2_pos mx = Z.to_pos prec). + { now apply Pos.le_antisym. } + assert (Dmx'' : Z.pos (digits2_pos mx) = prec). + { now rewrite Dmx', Z2Pos.id; [|apply prec_gt_0_]. } + split; [|split]. + + apply andb_true_intro. + split; [|apply Zle_bool_true; lia]. + apply Zeq_bool_true; unfold fexp, FLT_exp. + rewrite Dmx', Z2Pos.id; [|now apply prec_gt_0_]. + rewrite Z.max_l; [ring|unfold emin; lia]. + + rewrite Rabs_mult, (Rabs_pos_eq (bpow _ _)); [|now apply bpow_ge_0]. + rewrite <-abs_IZR, abs_cond_Zopp; simpl; split. + * apply (Rmult_le_reg_r (bpow radix2 prec)); [now apply bpow_gt_0|]. + rewrite Rmult_assoc, <-bpow_plus, Z.add_opp_diag_l; simpl. + rewrite Rmult_1_r. + change (/ 2)%R with (bpow radix2 (- 1)); rewrite <-bpow_plus. + rewrite <-Dmx'', Z.add_comm, Zpos_digits2_pos, Zdigits_mag; [|lia]. + set (b := bpow _ _). + rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia]. + apply bpow_mag_le; apply IZR_neq; lia. + * apply (Rmult_lt_reg_r (bpow radix2 prec)); [now apply bpow_gt_0|]. + rewrite Rmult_assoc, <-bpow_plus, Z.add_opp_diag_l; simpl. + rewrite Rmult_1_l, Rmult_1_r. + rewrite <-Dmx'', Zpos_digits2_pos, Zdigits_mag; [|lia]. + set (b := bpow _ _). + rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia]. + apply bpow_mag_gt; apply IZR_neq; lia. + + unfold x, F2R; simpl; rewrite Rmult_assoc, <-bpow_plus. + now replace (_ + _)%Z with ex by ring. +- unfold bounded, F2R; simpl. + assert (Dmx' : (Z.pos (digits2_pos mx) < prec)%Z). + { now rewrite <-(Z2Pos.id prec); [|now apply prec_gt_0_]. } + split; [|split]. + + unfold bounded; apply andb_true_intro. + split; [|apply Zle_bool_true; lia]. + apply Zeq_bool_true; unfold fexp, FLT_exp. + rewrite Zpos_digits2_pos, shift_pos_correct, Z.pow_pos_fold. + rewrite Z2Pos.id; [|lia]. + rewrite Z.mul_comm; change 2%Z with (radix2 : Z). + rewrite Zdigits_mult_Zpower; [|lia|lia]. + rewrite Zpos_digits2_pos; replace (_ - _)%Z with (- prec)%Z by ring. + now rewrite Z.max_l; [|unfold emin; lia]. + + rewrite Rabs_mult, (Rabs_pos_eq (bpow _ _)); [|now apply bpow_ge_0]. + rewrite <-abs_IZR, abs_cond_Zopp; simpl. + rewrite shift_pos_correct, mult_IZR. + change (IZR (Z.pow_pos _ _)) + with (bpow radix2 (Z.pos (Z.to_pos ((prec - Z.pos (digits2_pos mx)))))). + rewrite Z2Pos.id; [|lia]. + rewrite Rmult_comm, <-Rmult_assoc, <-bpow_plus. + set (d := Z.pos (digits2_pos mx)). + replace (_ + _)%Z with (- d)%Z by ring; split. + * apply (Rmult_le_reg_l (bpow radix2 d)); [now apply bpow_gt_0|]. + rewrite <-Rmult_assoc, <-bpow_plus, Z.add_opp_diag_r. + rewrite Rmult_1_l. + change (/ 2)%R with (bpow radix2 (- 1)); rewrite <-bpow_plus. + rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia]. + unfold d; rewrite Zpos_digits2_pos, Zdigits_mag; [|lia]. + apply bpow_mag_le; apply IZR_neq; lia. + * apply (Rmult_lt_reg_l (bpow radix2 d)); [now apply bpow_gt_0|]. + rewrite <-Rmult_assoc, <-bpow_plus, Z.add_opp_diag_r. + rewrite Rmult_1_l, Rmult_1_r. + rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia]. + unfold d; rewrite Zpos_digits2_pos, Zdigits_mag; [|lia]. + apply bpow_mag_gt; apply IZR_neq; lia. + + rewrite Rmult_assoc, <-bpow_plus, shift_pos_correct. + rewrite IZR_cond_Zopp, mult_IZR, cond_Ropp_mult_r, <-IZR_cond_Zopp. + change (IZR (Z.pow_pos _ _)) + with (bpow radix2 (Z.pos (Z.to_pos (prec - Z.pos (digits2_pos mx))))). + rewrite Z2Pos.id; [|lia]. + rewrite Rmult_comm, <-Rmult_assoc, <-bpow_plus. + now replace (_ + _)%Z with ex by ring; rewrite Rmult_comm. +Qed. + +Definition Bfrexp f := + match f with + | B754_finite s m e H => + let e' := snd (Ffrexp_core_binary s m e) in + (FF2B _ (proj1 (Bfrexp_correct_aux s m e H)), e') + | _ => (f, (-2*emax-prec)%Z) + end. + +Theorem Bfrexp_correct : + forall f, + is_finite_strict f = true -> + let x := B2R f in + let z := fst (Bfrexp f) in + let e := snd (Bfrexp f) in + (/2 <= Rabs (B2R z) < 1)%R /\ + (x = B2R z * bpow radix2 e)%R /\ + e = mag radix2 x. +Proof. +intro f; case f; intro s; try discriminate; intros m e Hf _. +generalize (Bfrexp_correct_aux s m e Hf). +intros (_, (Hb, Heq)); simpl; rewrite B2R_FF2B. +split; [now simpl|]; split; [now simpl|]. +rewrite Heq, mag_mult_bpow. +- apply (Z.add_reg_l (- (snd (Ffrexp_core_binary s m e)))). + now ring_simplify; symmetry; apply mag_unique. +- intro H; destruct Hb as (Hb, _); revert Hb; rewrite H, Rabs_R0; lra. +Qed. + +(** Ulp *) + +Definition Bulp x := Bldexp mode_NE Bone (fexp (snd (Bfrexp x))). + +Theorem Bulp_correct : + forall x, + is_finite x = true -> + B2R (Bulp x) = ulp radix2 fexp (B2R x) /\ + is_finite (Bulp x) = true /\ + Bsign (Bulp x) = false. +Proof. +intro x; case x. +- intros s _; unfold Bulp. + replace (fexp _) with emin. + + generalize (Bldexp_correct mode_NE Bone emin). + rewrite Bone_correct, Rmult_1_l, round_generic; + [|now apply valid_rnd_N|apply generic_format_bpow; unfold fexp, FLT_exp; + rewrite Z.max_r; unfold Prec_gt_0 in prec_gt_0_; lia]. + rewrite Rlt_bool_true. + * intros (Hr, (Hf, Hs)); rewrite Hr, Hf, Hs. + split; [|now split; [apply is_finite_Bone|apply Bsign_Bone]]. + simpl; unfold ulp; rewrite Req_bool_true; [|reflexivity]. + destruct (negligible_exp_FLT emin prec) as (n, (Hn, Hn')). + change fexp with (FLT_exp emin prec); rewrite Hn. + now unfold FLT_exp; rewrite Z.max_r; + [|unfold Prec_gt_0 in prec_gt_0_; lia]. + * rewrite Rabs_pos_eq; [|now apply bpow_ge_0]; apply bpow_lt. + unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. + + simpl; change (fexp _) with (fexp (-2 * emax - prec)). + unfold fexp, FLT_exp; rewrite Z.max_r; [reflexivity|]. + unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. +- intro; discriminate. +- intros s pl Hpl; discriminate. +- intros s m e Hme _; unfold Bulp, ulp, cexp. + set (f := B754_finite _ _ _ _). + rewrite Req_bool_false. + + destruct (Bfrexp_correct f (eq_refl _)) as (Hfr1, (Hfr2, Hfr3)). + rewrite Hfr3. + set (e' := fexp _). + generalize (Bldexp_correct mode_NE Bone e'). + rewrite Bone_correct, Rmult_1_l, round_generic; [|now apply valid_rnd_N|]. + { rewrite Rlt_bool_true. + - intros (Hr, (Hf, Hs)); rewrite Hr, Hf, Hs. + now split; [|split; [apply is_finite_Bone|apply Bsign_Bone]]. + - rewrite Rabs_pos_eq; [|now apply bpow_ge_0]. + unfold e', fexp, FLT_exp. + case (Z.max_spec (mag radix2 (B2R f) - prec) emin) + as [(_, Hm)|(_, Hm)]; rewrite Hm; apply bpow_lt; + [now unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia|]. + apply (Zplus_lt_reg_r _ _ prec); ring_simplify. + assert (mag radix2 (B2R f) <= emax)%Z; + [|now unfold Prec_gt_0 in prec_gt_0_; lia]. + apply mag_le_bpow; [|now apply abs_B2R_lt_emax]. + now unfold f, B2R; apply F2R_neq_0; case s. } + apply generic_format_bpow, Z.max_lub. + * unfold Prec_gt_0 in prec_gt_0_; lia. + * apply Z.le_max_r. + + now unfold f, B2R; apply F2R_neq_0; case s. +Qed. + +(** Successor (and predecessor) *) + +Definition Bpred_pos pred_pos_nan x := + match x with + | B754_finite _ mx _ _ => + let d := + if (mx~0 =? shift_pos (Z.to_pos prec) 1)%positive then + Bldexp mode_NE Bone (fexp (snd (Bfrexp x) - 1)) + else + Bulp x in + Bminus (fun _ => pred_pos_nan) mode_NE x d + | _ => x + end. + +Theorem Bpred_pos_correct : + forall pred_pos_nan x, + (0 < B2R x)%R -> + B2R (Bpred_pos pred_pos_nan x) = pred_pos radix2 fexp (B2R x) /\ + is_finite (Bpred_pos pred_pos_nan x) = true /\ + Bsign (Bpred_pos pred_pos_nan x) = false. +Proof. +intros pred_pos_nan x. +generalize (Bfrexp_correct x). +case x. +- simpl; intros s _ Bx; exfalso; apply (Rlt_irrefl _ Bx). +- simpl; intros s _ Bx; exfalso; apply (Rlt_irrefl _ Bx). +- simpl; intros s pl Hpl _ Bx; exfalso; apply (Rlt_irrefl _ Bx). +- intros sx mx ex Hmex Hfrexpx Px. + assert (Hsx : sx = false). + { revert Px; case sx; unfold B2R, F2R; simpl; [|now intro]. + intro Px; exfalso; revert Px; apply Rle_not_lt. + rewrite <-(Rmult_0_l (bpow radix2 ex)). + apply Rmult_le_compat_r; [apply bpow_ge_0|apply IZR_le; lia]. } + clear Px; rewrite Hsx in Hfrexpx |- *; clear Hsx sx. + specialize (Hfrexpx (eq_refl _)). + simpl in Hfrexpx; rewrite B2R_FF2B in Hfrexpx. + destruct Hfrexpx as (Hfrexpx_bounds, (Hfrexpx_eq, Hfrexpx_exp)). + unfold Bpred_pos, Bfrexp. + simpl (snd (_, snd _)). + rewrite Hfrexpx_exp. + set (x' := B754_finite _ _ _ _). + set (xr := F2R _). + assert (Nzxr : xr <> 0%R). + { unfold xr, F2R; simpl. + rewrite <-(Rmult_0_l (bpow radix2 ex)); intro H. + apply Rmult_eq_reg_r in H; [|apply Rgt_not_eq, bpow_gt_0]. + apply eq_IZR in H; lia. } + assert (Hulp := Bulp_correct x'). + specialize (Hulp (eq_refl _)). + assert (Hldexp := Bldexp_correct mode_NE Bone (fexp (mag radix2 xr - 1))). + rewrite Bone_correct, Rmult_1_l in Hldexp. + assert (Fbpowxr : generic_format radix2 fexp + (bpow radix2 (fexp (mag radix2 xr - 1)))). + { apply generic_format_bpow, Z.max_lub. + - unfold Prec_gt_0 in prec_gt_0_; lia. + - apply Z.le_max_r. } + assert (H : Rlt_bool (Rabs + (round radix2 fexp (round_mode mode_NE) + (bpow radix2 (fexp (mag radix2 xr - 1))))) + (bpow radix2 emax) = true); [|rewrite H in Hldexp; clear H]. + { apply Rlt_bool_true; rewrite round_generic; + [|apply valid_rnd_round_mode|apply Fbpowxr]. + rewrite Rabs_pos_eq; [|apply bpow_ge_0]; apply bpow_lt. + apply Z.max_lub_lt; [|unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia]. + apply (Zplus_lt_reg_r _ _ (prec + 1)); ring_simplify. + rewrite Z.add_1_r; apply Zle_lt_succ, mag_le_bpow. + - exact Nzxr. + - apply (Rlt_le_trans _ (bpow radix2 emax)). + + change xr with (B2R x'); apply abs_B2R_lt_emax. + + apply bpow_le; unfold Prec_gt_0 in prec_gt_0_; lia. } + set (d := if (mx~0 =? _)%positive then _ else _). + set (minus_nan := fun _ => _). + assert (Hminus := Bminus_correct minus_nan mode_NE x' d (eq_refl _)). + assert (Fd : is_finite d = true). + { unfold d; case (_ =? _)%positive. + - now rewrite (proj1 (proj2 Hldexp)), is_finite_Bone. + - now rewrite (proj1 (proj2 Hulp)). } + specialize (Hminus Fd). + assert (Px : (0 <= B2R x')%R). + { unfold B2R, x', F2R; simpl. + now apply Rmult_le_pos; [apply IZR_le|apply bpow_ge_0]. } + assert (Pd : (0 <= B2R d)%R). + { unfold d; case (_ =? _)%positive. + - rewrite (proj1 Hldexp). + now rewrite round_generic; [apply bpow_ge_0|apply valid_rnd_N|]. + - rewrite (proj1 Hulp); apply ulp_ge_0. } + assert (Hdlex : (B2R d <= B2R x')%R). + { unfold d; case (_ =? _)%positive. + - rewrite (proj1 Hldexp). + rewrite round_generic; [|now apply valid_rnd_N|now simpl]. + apply (Rle_trans _ (bpow radix2 (mag radix2 xr - 1))). + + apply bpow_le, Z.max_lub. + * unfold Prec_gt_0 in prec_gt_0_; lia. + * apply (Zplus_le_reg_r _ _ 1); ring_simplify. + apply mag_ge_bpow. + replace (_ - 1)%Z with emin by ring. + now change xr with (B2R x'); apply abs_B2R_ge_emin. + + rewrite <-(Rabs_pos_eq _ Px). + now change xr with (B2R x'); apply bpow_mag_le. + - rewrite (proj1 Hulp); apply ulp_le_id. + + assert (B2R x' <> 0%R); [exact Nzxr|lra]. + + apply generic_format_B2R. } + assert (H : Rlt_bool + (Rabs + (round radix2 fexp + (round_mode mode_NE) (B2R x' - B2R d))) + (bpow radix2 emax) = true); [|rewrite H in Hminus; clear H]. + { apply Rlt_bool_true. + rewrite <-round_NE_abs; [|now apply FLT_exp_valid]. + rewrite Rabs_pos_eq; [|lra]. + apply (Rle_lt_trans _ (B2R x')). + - apply round_le_generic; + [now apply FLT_exp_valid|now apply valid_rnd_N| |lra]. + apply generic_format_B2R. + - apply (Rle_lt_trans _ _ _ (Rle_abs _)), abs_B2R_lt_emax. } + rewrite (proj1 Hminus). + rewrite (proj1 (proj2 Hminus)). + rewrite (proj2 (proj2 Hminus)). + split; [|split; [reflexivity|now case (Rcompare_spec _ _); [lra| |]]]. + unfold pred_pos, d. + case (Pos.eqb_spec _ _); intro Hd; case (Req_bool_spec _ _); intro Hpred. + + rewrite (proj1 Hldexp). + rewrite (round_generic _ _ _ _ Fbpowxr). + change xr with (B2R x'). + replace (_ - _)%R with (pred_pos radix2 fexp (B2R x')). + * rewrite round_generic; [reflexivity|now apply valid_rnd_N|]. + apply generic_format_pred_pos; + [now apply FLT_exp_valid|apply generic_format_B2R|]. + change xr with (B2R x') in Nzxr; lra. + * now unfold pred_pos; rewrite Req_bool_true. + + exfalso; apply Hpred. + assert (Hmx : IZR (Z.pos mx) = bpow radix2 (prec - 1)). + { apply (Rmult_eq_reg_l 2); [|lra]; rewrite <-mult_IZR. + change (2 * Z.pos mx)%Z with (Z.pos mx~0); rewrite Hd. + rewrite shift_pos_correct, Z.mul_1_r. + change (IZR (Z.pow_pos _ _)) with (bpow radix2 (Z.pos (Z.to_pos prec))). + rewrite Z2Pos.id; [|exact prec_gt_0_]. + change 2%R with (bpow radix2 1); rewrite <-bpow_plus. + f_equal; ring. } + unfold x' at 1; unfold B2R at 1; unfold F2R; simpl. + rewrite Hmx, <-bpow_plus; f_equal. + apply (Z.add_reg_l 1); ring_simplify; symmetry; apply mag_unique_pos. + unfold F2R; simpl; rewrite Hmx, <-bpow_plus; split. + * right; f_equal; ring. + * apply bpow_lt; lia. + + rewrite (proj1 Hulp). + assert (H : ulp radix2 fexp (B2R x') + = bpow radix2 (fexp (mag radix2 (B2R x') - 1))); + [|rewrite H; clear H]. + { unfold ulp; rewrite Req_bool_false; [|now simpl]. + unfold cexp; f_equal. + assert (H : (mag radix2 (B2R x') <= emin + prec)%Z). + { assert (Hcm : canonical_mantissa mx ex = true). + { now generalize Hmex; unfold bounded; rewrite Bool.andb_true_iff. } + apply (canonical_canonical_mantissa false) in Hcm. + revert Hcm; fold emin; unfold canonical, cexp; simpl. + change (F2R _) with (B2R x'); intro Hex. + apply Z.nlt_ge; intro H'; apply Hd. + apply Pos2Z.inj_pos; rewrite shift_pos_correct, Z.mul_1_r. + apply eq_IZR; change (IZR (Z.pow_pos _ _)) + with (bpow radix2 (Z.pos (Z.to_pos prec))). + rewrite Z2Pos.id; [|exact prec_gt_0_]. + change (Z.pos mx~0) with (2 * Z.pos mx)%Z. + rewrite Z.mul_comm, mult_IZR. + apply (Rmult_eq_reg_r (bpow radix2 (ex - 1))); + [|apply Rgt_not_eq, bpow_gt_0]. + change 2%R with (bpow radix2 1); rewrite Rmult_assoc, <-!bpow_plus. + replace (1 + _)%Z with ex by ring. + unfold B2R at 1, F2R in Hpred; simpl in Hpred; rewrite Hpred. + change (F2R _) with (B2R x'); rewrite Hex. + unfold fexp, FLT_exp; rewrite Z.max_l; [f_equal; ring|lia]. } + now unfold fexp, FLT_exp; do 2 (rewrite Z.max_r; [|lia]). } + replace (_ - _)%R with (pred_pos radix2 fexp (B2R x')). + * rewrite round_generic; [reflexivity|apply valid_rnd_N|]. + apply generic_format_pred_pos; + [now apply FLT_exp_valid| |change xr with (B2R x') in Nzxr; lra]. + apply generic_format_B2R. + * now unfold pred_pos; rewrite Req_bool_true. + + rewrite (proj1 Hulp). + replace (_ - _)%R with (pred_pos radix2 fexp (B2R x')). + * rewrite round_generic; [reflexivity|now apply valid_rnd_N|]. + apply generic_format_pred_pos; + [now apply FLT_exp_valid|apply generic_format_B2R|]. + change xr with (B2R x') in Nzxr; lra. + * now unfold pred_pos; rewrite Req_bool_false. +Qed. + +Definition Bsucc succ_nan x := + match x with + | B754_zero _ => Bldexp mode_NE Bone emin + | B754_infinity false => x + | B754_infinity true => Bopp succ_nan Bmax_float + | B754_nan _ _ _ => build_nan (succ_nan x) + | B754_finite false _ _ _ => + Bplus (fun _ => succ_nan) mode_NE x (Bulp x) + | B754_finite true _ _ _ => + Bopp succ_nan (Bpred_pos succ_nan (Bopp succ_nan x)) + end. + +Lemma Bsucc_correct : + forall succ_nan x, + is_finite x = true -> + if Rlt_bool (succ radix2 fexp (B2R x)) (bpow radix2 emax) then + B2R (Bsucc succ_nan x) = succ radix2 fexp (B2R x) /\ + is_finite (Bsucc succ_nan x) = true /\ + (Bsign (Bsucc succ_nan x) = Bsign x && is_finite_strict x)%bool + else + B2FF (Bsucc succ_nan x) = F754_infinity false. +Proof. +assert (Hsucc : succ radix2 fexp 0 = bpow radix2 emin). +{ unfold succ; rewrite Rle_bool_true; [|now right]; rewrite Rplus_0_l. + unfold ulp; rewrite Req_bool_true; [|now simpl]. + destruct (negligible_exp_FLT emin prec) as (n, (Hne, Hn)). + now unfold fexp; rewrite Hne; unfold FLT_exp; rewrite Z.max_r; + [|unfold Prec_gt_0 in prec_gt_0_; lia]. } +intros succ_nan [s|s|s pl Hpl|sx mx ex Hmex]; try discriminate; intros _. +- generalize (Bldexp_correct mode_NE Bone emin); unfold Bsucc; simpl. + assert (Hbemin : round radix2 fexp ZnearestE (bpow radix2 emin) + = bpow radix2 emin). + { rewrite round_generic; [reflexivity|apply valid_rnd_N|]. + apply generic_format_bpow. + unfold fexp, FLT_exp; rewrite Z.max_r; [now simpl|]. + unfold Prec_gt_0 in prec_gt_0_; lia. } + rewrite Hsucc, Rlt_bool_true. + + intros (Hr, (Hf, Hs)); rewrite Hr, Hf, Hs. + rewrite Bone_correct, Rmult_1_l, is_finite_Bone, Bsign_Bone. + case Rlt_bool_spec; intro Hover. + * now rewrite Bool.andb_false_r. + * exfalso; revert Hover; apply Rlt_not_le, bpow_lt. + unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. + + rewrite Bone_correct, Rmult_1_l, Hbemin, Rabs_pos_eq; [|apply bpow_ge_0]. + apply bpow_lt; unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. +- unfold Bsucc; case sx. + + case Rlt_bool_spec; intro Hover. + * rewrite B2R_Bopp; simpl (Bopp _ (B754_finite _ _ _ _)). + rewrite is_finite_Bopp. + set (ox := B754_finite false mx ex Hmex). + assert (Hpred := Bpred_pos_correct succ_nan ox). + assert (Hox : (0 < B2R ox)%R); [|specialize (Hpred Hox); clear Hox]. + { now apply Rmult_lt_0_compat; [apply IZR_lt|apply bpow_gt_0]. } + rewrite (proj1 Hpred), (proj1 (proj2 Hpred)). + unfold succ; rewrite Rle_bool_false; [split; [|split]|]. + { now unfold B2R, F2R, ox; simpl; rewrite Ropp_mult_distr_l, <-opp_IZR. } + { now simpl. } + { simpl (Bsign (B754_finite _ _ _ _)); simpl (true && _)%bool. + rewrite Bsign_Bopp, (proj2 (proj2 Hpred)); [now simpl|]. + now destruct Hpred as (_, (H, _)); revert H; case (Bpred_pos _ _). } + unfold B2R, F2R; simpl; change (Z.neg mx) with (- Z.pos mx)%Z. + rewrite opp_IZR, <-Ropp_mult_distr_l, <-Ropp_0; apply Ropp_lt_contravar. + now apply Rmult_lt_0_compat; [apply IZR_lt|apply bpow_gt_0]. + * exfalso; revert Hover; apply Rlt_not_le. + apply (Rle_lt_trans _ (succ radix2 fexp 0)). + { apply succ_le; [now apply FLT_exp_valid|apply generic_format_B2R| + apply generic_format_0|]. + unfold B2R, F2R; simpl; change (Z.neg mx) with (- Z.pos mx)%Z. + rewrite opp_IZR, <-Ropp_mult_distr_l, <-Ropp_0; apply Ropp_le_contravar. + now apply Rmult_le_pos; [apply IZR_le|apply bpow_ge_0]. } + rewrite Hsucc; apply bpow_lt. + unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia. + + set (x := B754_finite _ _ _ _). + set (plus_nan := fun _ => succ_nan). + assert (Hulp := Bulp_correct x (eq_refl _)). + assert (Hplus := Bplus_correct plus_nan mode_NE x (Bulp x) (eq_refl _)). + rewrite (proj1 (proj2 Hulp)) in Hplus; specialize (Hplus (eq_refl _)). + assert (Px : (0 <= B2R x)%R). + { now apply Rmult_le_pos; [apply IZR_le|apply bpow_ge_0]. } + assert (Hsucc' : (succ radix2 fexp (B2R x) + = B2R x + ulp radix2 fexp (B2R x))%R). + { now unfold succ; rewrite (Rle_bool_true _ _ Px). } + rewrite (proj1 Hulp), <- Hsucc' in Hplus. + rewrite round_generic in Hplus; + [|apply valid_rnd_N| now apply generic_format_succ; + [apply FLT_exp_valid|apply generic_format_B2R]]. + rewrite Rabs_pos_eq in Hplus; [|apply (Rle_trans _ _ _ Px), succ_ge_id]. + revert Hplus; case Rlt_bool_spec; intros Hover Hplus. + * split; [now simpl|split; [now simpl|]]. + rewrite (proj2 (proj2 Hplus)); case Rcompare_spec. + { intro H; exfalso; revert H. + apply Rle_not_lt, (Rle_trans _ _ _ Px), succ_ge_id. } + { intro H; exfalso; revert H; apply Rgt_not_eq, Rlt_gt. + apply (Rlt_le_trans _ (B2R x)); [|apply succ_ge_id]. + now apply Rmult_lt_0_compat; [apply IZR_lt|apply bpow_gt_0]. } + now simpl. + * now rewrite (proj1 Hplus). +Qed. + +Definition Bpred pred_nan x := + Bopp pred_nan (Bsucc pred_nan (Bopp pred_nan x)). + +Lemma Bpred_correct : + forall pred_nan x, + is_finite x = true -> + if Rlt_bool (- bpow radix2 emax) (pred radix2 fexp (B2R x)) then + B2R (Bpred pred_nan x) = pred radix2 fexp (B2R x) /\ + is_finite (Bpred pred_nan x) = true /\ + (Bsign (Bpred pred_nan x) = Bsign x || negb (is_finite_strict x))%bool + else + B2FF (Bpred pred_nan x) = F754_infinity true. +Proof. +intros pred_nan x Fx. +assert (Fox : is_finite (Bopp pred_nan x) = true). +{ now rewrite is_finite_Bopp. } +rewrite <-(Ropp_involutive (B2R x)), <-(B2R_Bopp pred_nan). +rewrite pred_opp, Rlt_bool_opp. +generalize (Bsucc_correct pred_nan _ Fox). +case (Rlt_bool _ _). +- intros (HR, (HF, HS)); unfold Bpred. + rewrite B2R_Bopp, HR, is_finite_Bopp. + rewrite <-(Bool.negb_involutive (Bsign x)), <-Bool.negb_andb. + split; [reflexivity|split; [exact HF|]]. + replace (is_finite_strict x) with (is_finite_strict (Bopp pred_nan x)); + [|now case x; try easy; intros s pl Hpl; simpl; + rewrite is_finite_strict_build_nan]. + rewrite Bsign_Bopp, <-(Bsign_Bopp pred_nan x), HS. + + now simpl. + + now revert Fx; case x. + + now revert HF; case (Bsucc _ _). +- now unfold Bpred; case (Bsucc _ _); intro s; case s. +Qed. + +End Binary. diff --git a/flocq/Appli/Fappli_IEEE_bits.v b/flocq/IEEE754/Bits.v index e6a012cf..3a84edfe 100644 --- a/flocq/Appli/Fappli_IEEE_bits.v +++ b/flocq/IEEE754/Bits.v @@ -2,9 +2,9 @@ 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-2018 Sylvie Boldo #<br /># -Copyright (C) 2011-2013 Guillaume Melquiond +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 @@ -18,46 +18,18 @@ COPYING file for more details. *) (** * IEEE-754 encoding of binary floating-point data *) -Require Import Fcore. -Require Import Fcore_digits. -Require Import Fcalc_digits. -Require Import Fappli_IEEE. +Require Import Core Digits Binary. Section Binary_Bits. -Arguments exist {A P} x _. -Arguments B754_zero {prec emax} _. -Arguments B754_infinity {prec emax} _. -Arguments B754_nan {prec emax} _ _. -Arguments B754_finite {prec emax} _ m e _. +Arguments exist {A} {P}. +Arguments B754_zero {prec} {emax}. +Arguments B754_infinity {prec} {emax}. +Arguments B754_nan {prec} {emax}. +Arguments B754_finite {prec} {emax}. (** Number of bits for the fraction and exponent *) Variable mw ew : Z. -Hypothesis Hmw : (0 < mw)%Z. -Hypothesis Hew : (0 < ew)%Z. - -Let emax := Zpower 2 (ew - 1). -Let prec := (mw + 1)%Z. -Let emin := (3 - emax - prec)%Z. -Let binary_float := binary_float prec emax. - -Let Hprec : (0 < prec)%Z. -unfold prec. -apply Zle_lt_succ. -now apply Zlt_le_weak. -Qed. - -Let Hm_gt_0 : (0 < 2^mw)%Z. -apply (Zpower_gt_0 radix2). -now apply Zlt_le_weak. -Qed. - -Let He_gt_0 : (0 < 2^ew)%Z. -apply (Zpower_gt_0 radix2). -now apply Zlt_le_weak. -Qed. - -Hypothesis Hmax : (prec < emax)%Z. Definition join_bits (s : bool) m e := (Z.shiftl ((if s then Zpower 2 ew else 0) + e) mw + m)%Z. @@ -69,8 +41,14 @@ Lemma join_bits_range : (0 <= join_bits s m e < 2 ^ (mw + ew + 1))%Z. Proof. intros s m e Hm He. +assert (0 <= mw)%Z as Hmw. + destruct mw as [|mw'|mw'] ; try easy. + clear -Hm ; simpl in Hm ; omega. +assert (0 <= ew)%Z as Hew. + destruct ew as [|ew'|ew'] ; try easy. + clear -He ; simpl in He ; omega. unfold join_bits. -rewrite Z.shiftl_mul_pow2 by now apply Zlt_le_weak. +rewrite Z.shiftl_mul_pow2 by easy. split. - apply (Zplus_le_compat 0 _ 0) with (2 := proj1 Hm). rewrite <- (Zmult_0_l (2^mw)). @@ -79,26 +57,24 @@ split. clear -He ; omega. now rewrite Zmult_0_l. clear -Hm ; omega. -- apply Zlt_le_trans with (((if s then 2 ^ ew else 0) + e + 1) * 2 ^ mw)%Z. +- apply Z.lt_le_trans with (((if s then 2 ^ ew else 0) + e + 1) * 2 ^ mw)%Z. rewrite (Zmult_plus_distr_l _ 1). apply Zplus_lt_compat_l. now rewrite Zmult_1_l. rewrite <- (Zplus_assoc mw), (Zplus_comm mw), Zpower_plus. apply Zmult_le_compat_r. - rewrite Zpower_plus. + rewrite Zpower_plus by easy. change (2^1)%Z with 2%Z. case s ; clear -He ; omega. - now apply Zlt_le_weak. - easy. clear -Hm ; omega. clear -Hew ; omega. - now apply Zlt_le_weak. + easy. Qed. Definition split_bits x := let mm := Zpower 2 mw in let em := Zpower 2 ew in - (Zle_bool (mm * em) x, Zmod x mm, Zmod (Zdiv x mm) em)%Z. + (Zle_bool (mm * em) x, Zmod x mm, Zmod (Z.div x mm) em)%Z. Theorem split_join_bits : forall s m e, @@ -107,45 +83,75 @@ Theorem split_join_bits : split_bits (join_bits s m e) = (s, m, e). Proof. intros s m e Hm He. +assert (0 <= mw)%Z as Hmw. + destruct mw as [|mw'|mw'] ; try easy. + clear -Hm ; simpl in Hm ; omega. +assert (0 <= ew)%Z as Hew. + destruct ew as [|ew'|ew'] ; try easy. + clear -He ; simpl in He ; omega. unfold split_bits, join_bits. -rewrite Z.shiftl_mul_pow2 by now apply Zlt_le_weak. -apply f_equal2. -apply f_equal2. -(* *) -case s. -apply Zle_bool_true. -apply Zle_0_minus_le. -ring_simplify. -apply Zplus_le_0_compat. -apply Zmult_le_0_compat. -apply He. +rewrite Z.shiftl_mul_pow2 by easy. +apply f_equal2 ; [apply f_equal2|]. +- case s. + + apply Zle_bool_true. + apply Zle_0_minus_le. + ring_simplify. + apply Zplus_le_0_compat. + apply Zmult_le_0_compat. + apply He. + clear -Hm ; omega. + apply Hm. + + apply Zle_bool_false. + apply Zplus_lt_reg_l with (2^mw * (-e))%Z. + replace (2 ^ mw * - e + ((0 + e) * 2 ^ mw + m))%Z with (m * 1)%Z by ring. + rewrite <- Zmult_plus_distr_r. + apply Z.lt_le_trans with (2^mw * 1)%Z. + now apply Zmult_lt_compat_r. + apply Zmult_le_compat_l. + clear -He ; omega. + clear -Hm ; omega. +- rewrite Zplus_comm. + rewrite Z_mod_plus_full. + now apply Zmod_small. +- rewrite Z_div_plus_full_l by (clear -Hm ; omega). + rewrite Zdiv_small with (1 := Hm). + rewrite Zplus_0_r. + case s. + + replace (2^ew + e)%Z with (e + 1 * 2^ew)%Z by ring. + rewrite Z_mod_plus_full. + now apply Zmod_small. + + now apply Zmod_small. +Qed. + +Hypothesis Hmw : (0 < mw)%Z. +Hypothesis Hew : (0 < ew)%Z. + +Let emax := Zpower 2 (ew - 1). +Let prec := (mw + 1)%Z. +Let emin := (3 - emax - prec)%Z. +Let binary_float := binary_float prec emax. + +Let Hprec : (0 < prec)%Z. +Proof. +unfold prec. +apply Zle_lt_succ. now apply Zlt_le_weak. -apply Hm. -apply Zle_bool_false. -apply Zplus_lt_reg_l with (2^mw * (-e))%Z. -replace (2 ^ mw * - e + ((0 + e) * 2 ^ mw + m))%Z with (m * 1)%Z by ring. -rewrite <- Zmult_plus_distr_r. -apply Zlt_le_trans with (2^mw * 1)%Z. -now apply Zmult_lt_compat_r. -apply Zmult_le_compat_l. -clear -He. omega. +Qed. + +Let Hm_gt_0 : (0 < 2^mw)%Z. +Proof. +apply (Zpower_gt_0 radix2). now apply Zlt_le_weak. -(* *) -rewrite Zplus_comm. -rewrite Z_mod_plus_full. -now apply Zmod_small. -(* *) -rewrite Z_div_plus_full_l. -rewrite Zdiv_small with (1 := Hm). -rewrite Zplus_0_r. -case s. -replace (2^ew + e)%Z with (e + 1 * 2^ew)%Z by ring. -rewrite Z_mod_plus_full. -now apply Zmod_small. -now apply Zmod_small. -now apply Zgt_not_eq. Qed. +Let He_gt_0 : (0 < 2^ew)%Z. +Proof. +apply (Zpower_gt_0 radix2). +now apply Zlt_le_weak. +Qed. + +Hypothesis Hmax : (prec < emax)%Z. + Theorem join_split_bits : forall x, (0 <= x < Zpower 2 (mw + ew + 1))%Z -> @@ -171,17 +177,15 @@ case Zle_bool_spec ; intros Hs. apply Zle_antisym. cut (x / (2^mw * 2^ew) < 2)%Z. clear ; omega. apply Zdiv_lt_upper_bound. -try apply Hx. (* 8.2/8.3 compatibility *) now apply Zmult_lt_0_compat. -rewrite <- Zpower_exp ; try ( apply Zle_ge ; apply Zlt_le_weak ; assumption ). +rewrite <- Zpower_exp ; try ( apply Z.le_ge ; apply Zlt_le_weak ; assumption ). change 2%Z at 1 with (Zpower 2 1). rewrite <- Zpower_exp. now rewrite Zplus_comm. discriminate. -apply Zle_ge. +apply Z.le_ge. now apply Zplus_le_0_compat ; apply Zlt_le_weak. apply Zdiv_le_lower_bound. -try apply Hx. (* 8.2/8.3 compatibility *) now apply Zmult_lt_0_compat. now rewrite Zmult_1_l. apply Zdiv_small. @@ -213,7 +217,7 @@ Definition bits_of_binary_float (x : binary_float) := match x with | B754_zero sx => join_bits sx 0 0 | B754_infinity sx => join_bits sx 0 (Zpower 2 ew - 1) - | B754_nan sx (exist plx _) => join_bits sx (Zpos plx) (Zpower 2 ew - 1) + | B754_nan sx plx _ => join_bits sx (Zpos plx) (Zpower 2 ew - 1) | B754_finite sx mx ex _ => let m := (Zpos mx - Zpower 2 mw)%Z in if Zle_bool 0 m then @@ -226,7 +230,7 @@ Definition split_bits_of_binary_float (x : binary_float) := match x with | B754_zero sx => (sx, 0, 0)%Z | B754_infinity sx => (sx, 0, Zpower 2 ew - 1)%Z - | B754_nan sx (exist plx _) => (sx, Zpos plx, Zpower 2 ew - 1)%Z + | B754_nan sx plx _ => (sx, Zpos plx, Zpower 2 ew - 1)%Z | B754_finite sx mx ex _ => let m := (Zpos mx - Zpower 2 mw)%Z in if Zle_bool 0 m then @@ -239,13 +243,14 @@ Theorem split_bits_of_binary_float_correct : forall x, split_bits (bits_of_binary_float x) = split_bits_of_binary_float x. Proof. -intros [sx|sx|sx [plx Hplx]|sx mx ex Hx] ; - try ( simpl ; apply split_join_bits ; split ; try apply Zle_refl ; try apply Zlt_pred ; trivial ; omega ). +intros [sx|sx|sx plx Hplx|sx mx ex Hx] ; + try ( simpl ; apply split_join_bits ; split ; try apply Z.le_refl ; try apply Zlt_pred ; trivial ; omega ). simpl. apply split_join_bits; split; try (zify; omega). destruct (digits2_Pnat_correct plx). +unfold nan_pl in Hplx. rewrite Zpos_digits2_pos, <- Z_of_nat_S_digits2_Pnat in Hplx. rewrite Zpower_nat_Z in H0. -eapply Zlt_le_trans. apply H0. +eapply Z.lt_le_trans. apply H0. change 2%Z with (radix_val radix2). apply Zpower_le. rewrite Z.ltb_lt in Hplx. unfold prec in *. zify; omega. @@ -253,7 +258,7 @@ unfold prec in *. zify; omega. unfold bits_of_binary_float, split_bits_of_binary_float. assert (Hf: (emin <= ex /\ Zdigits radix2 (Zpos mx) <= prec)%Z). destruct (andb_prop _ _ Hx) as (Hx', _). -unfold canonic_mantissa in Hx'. +unfold canonical_mantissa in Hx'. rewrite Zpos_digits2_pos in Hx'. generalize (Zeq_bool_eq _ _ Hx'). unfold FLT_exp. @@ -271,7 +276,7 @@ apply (Zpower_gt_Zdigits radix2 _ (Zpos mx)). apply Hf. unfold prec. rewrite Zplus_comm. -apply Zpower_exp ; apply Zle_ge. +apply Zpower_exp ; apply Z.le_ge. discriminate. now apply Zlt_le_weak. (* *) @@ -285,9 +290,9 @@ generalize (Zle_bool_imp_le _ _ Hx'). clear ; omega. apply sym_eq. rewrite (Zsucc_pred ew). -unfold Zsucc. +unfold Z.succ. rewrite Zplus_comm. -apply Zpower_exp ; apply Zle_ge. +apply Zpower_exp ; apply Z.le_ge. discriminate. now apply Zlt_0_le_0_pred. Qed. @@ -296,7 +301,7 @@ Theorem bits_of_binary_float_range: forall x, (0 <= bits_of_binary_float x < 2^(mw+ew+1))%Z. Proof. unfold bits_of_binary_float. -intros [sx|sx|sx [pl pl_range]|sx mx ex H]. +intros [sx|sx|sx pl pl_range|sx mx ex H]. - apply join_bits_range ; now split. - apply join_bits_range. now split. @@ -312,7 +317,7 @@ intros [sx|sx|sx [pl pl_range]|sx mx ex H]. - unfold bounded in H. apply Bool.andb_true_iff in H ; destruct H as [A B]. apply Z.leb_le in B. - unfold canonic_mantissa, FLT_exp in A. apply Zeq_bool_eq in A. + unfold canonical_mantissa, FLT_exp in A. apply Zeq_bool_eq in A. case Zle_bool_spec ; intros H. + apply join_bits_range. * split. @@ -362,6 +367,10 @@ Lemma binary_float_of_bits_aux_correct : Proof. intros x. unfold binary_float_of_bits_aux, split_bits. +assert (Hnan: nan_pl prec 1 = true). + apply Z.ltb_lt. + simpl. unfold prec. + clear -Hmw ; omega. case Zeq_bool_spec ; intros He1. case_eq (x mod 2^mw)%Z ; try easy. (* subnormal *) @@ -371,11 +380,11 @@ apply Zdigits_le_Zpower. simpl. rewrite <- Hm. eapply Z_mod_lt. -now apply Zlt_gt. -apply bounded_canonic_lt_emax ; try assumption. -unfold canonic, canonic_exp. +now apply Z.lt_gt. +apply bounded_canonical_lt_emax ; try assumption. +unfold canonical, cexp. fold emin. -rewrite ln_beta_F2R_Zdigits. 2: discriminate. +rewrite mag_F2R_Zdigits. 2: discriminate. unfold Fexp, FLT_exp. apply sym_eq. apply Zmax_right. @@ -383,16 +392,15 @@ clear -H Hprec. unfold prec ; omega. apply Rnot_le_lt. intros H0. -refine (_ (ln_beta_le radix2 _ _ _ H0)). -rewrite ln_beta_bpow. -rewrite ln_beta_F2R_Zdigits. 2: discriminate. +refine (_ (mag_le radix2 _ _ _ H0)). +rewrite mag_bpow. +rewrite mag_F2R_Zdigits. 2: discriminate. unfold emin, prec. apply Zlt_not_le. cut (0 < emax)%Z. clear -H Hew ; omega. apply (Zpower_gt_0 radix2). clear -Hew ; omega. apply bpow_gt_0. -simpl. intros. rewrite Z.ltb_lt. unfold prec. zify; omega. case Zeq_bool_spec ; intros He2. case_eq (x mod 2 ^ mw)%Z; try easy. (* nan *) @@ -403,39 +411,37 @@ apply Zdigits_le_Zpower. simpl. rewrite <- Eqplx. edestruct Z_mod_lt; eauto. change 2%Z with (radix_val radix2). apply Z.lt_gt, Zpower_gt_0. omega. -simpl. intros. rewrite Z.ltb_lt. unfold prec. zify; omega. case_eq (x mod 2^mw + 2^mw)%Z ; try easy. -simpl. intros. rewrite Z.ltb_lt. unfold prec. zify; omega. (* normal *) intros px Hm. assert (prec = Zdigits radix2 (Zpos px)). (* . *) -rewrite Zdigits_ln_beta. 2: discriminate. +rewrite Zdigits_mag. 2: discriminate. apply sym_eq. -apply ln_beta_unique. -rewrite <- Z2R_abs. -unfold Zabs. +apply mag_unique. +rewrite <- abs_IZR. +unfold Z.abs. replace (prec - 1)%Z with mw by ( unfold prec ; ring ). -rewrite <- Z2R_Zpower with (1 := Zlt_le_weak _ _ Hmw). -rewrite <- Z2R_Zpower. 2: now apply Zlt_le_weak. +rewrite <- IZR_Zpower with (1 := Zlt_le_weak _ _ Hmw). +rewrite <- IZR_Zpower. 2: now apply Zlt_le_weak. rewrite <- Hm. split. -apply Z2R_le. +apply IZR_le. change (radix2^mw)%Z with (0 + 2^mw)%Z. apply Zplus_le_compat_r. eapply Z_mod_lt. -now apply Zlt_gt. -apply Z2R_lt. +now apply Z.lt_gt. +apply IZR_lt. unfold prec. -rewrite Zpower_exp. 2: now apply Zle_ge ; apply Zlt_le_weak. 2: discriminate. +rewrite Zpower_exp. 2: now apply Z.le_ge ; apply Zlt_le_weak. 2: discriminate. rewrite <- Zplus_diag_eq_mult_2. apply Zplus_lt_compat_r. eapply Z_mod_lt. -now apply Zlt_gt. +now apply Z.lt_gt. (* . *) -apply bounded_canonic_lt_emax ; try assumption. -unfold canonic, canonic_exp. -rewrite ln_beta_F2R_Zdigits. 2: discriminate. +apply bounded_canonical_lt_emax ; try assumption. +unfold canonical, cexp. +rewrite mag_F2R_Zdigits. 2: discriminate. unfold Fexp, FLT_exp. rewrite <- H. set (ex := ((x / 2^mw) mod 2^ew)%Z). @@ -448,14 +454,14 @@ cut (0 <= ex)%Z. unfold emin. clear ; intros H1 H2 ; omega. eapply Z_mod_lt. -apply Zlt_gt. +apply Z.lt_gt. apply (Zpower_gt_0 radix2). now apply Zlt_le_weak. apply Rnot_le_lt. intros H0. -refine (_ (ln_beta_le radix2 _ _ _ H0)). -rewrite ln_beta_bpow. -rewrite ln_beta_F2R_Zdigits. 2: discriminate. +refine (_ (mag_le radix2 _ _ _ H0)). +rewrite mag_bpow. +rewrite mag_F2R_Zdigits. 2: discriminate. rewrite <- H. apply Zlt_not_le. unfold emin. @@ -472,11 +478,10 @@ apply refl_equal. discriminate. clear -Hew ; omega. eapply Z_mod_lt. -apply Zlt_gt. +apply Z.lt_gt. apply (Zpower_gt_0 radix2). now apply Zlt_le_weak. apply bpow_gt_0. -simpl. intros. rewrite Z.ltb_lt. unfold prec. zify; omega. Qed. Definition binary_float_of_bits x := @@ -492,7 +497,7 @@ unfold binary_float_of_bits. rewrite B2FF_FF2B. unfold binary_float_of_bits_aux. rewrite split_bits_of_binary_float_correct. -destruct x as [sx|sx|sx [plx Hplx]|sx mx ex Bx]. +destruct x as [sx|sx|sx plx Hplx|sx mx ex Bx]. apply refl_equal. (* *) simpl. @@ -563,7 +568,7 @@ intros (sx, mx) ex Sx. assert (Bm: (0 <= mx < 2^mw)%Z). inversion_clear Sx. apply Z_mod_lt. -now apply Zlt_gt. +now apply Z.lt_gt. case Zeq_bool_spec ; intros He1. (* subnormal *) case_eq mx. @@ -604,41 +609,47 @@ End Binary_Bits. (** Specialization for IEEE single precision operations *) Section B32_Bits. -Arguments B754_nan {prec emax} _ _. +Arguments B754_nan {prec} {emax}. Definition binary32 := binary_float 24 128. Let Hprec : (0 < 24)%Z. +Proof. apply refl_equal. Qed. Let Hprec_emax : (24 < 128)%Z. +Proof. apply refl_equal. Qed. -Definition default_nan_pl32 : bool * nan_pl 24 := - (false, exist _ (iter_nat xO 22 xH) (refl_equal true)). +Definition default_nan_pl32 : { nan : binary32 | is_nan 24 128 nan = true } := + exist _ (@B754_nan 24 128 false (iter_nat xO 22 xH) (refl_equal true)) (refl_equal true). -Definition unop_nan_pl32 (f : binary32) : bool * nan_pl 24 := - match f with - | B754_nan s pl => (s, pl) +Definition unop_nan_pl32 (f : binary32) : { nan : binary32 | is_nan 24 128 nan = true } := + match f as f with + | B754_nan s pl Hpl => exist _ (B754_nan s pl Hpl) (refl_equal true) | _ => default_nan_pl32 end. -Definition binop_nan_pl32 (f1 f2 : binary32) : bool * nan_pl 24 := +Definition binop_nan_pl32 (f1 f2 : binary32) : { nan : binary32 | is_nan 24 128 nan = true } := match f1, f2 with - | B754_nan s1 pl1, _ => (s1, pl1) - | _, B754_nan s2 pl2 => (s2, pl2) + | B754_nan s1 pl1 Hpl1, _ => exist _ (B754_nan s1 pl1 Hpl1) (refl_equal true) + | _, B754_nan s2 pl2 Hpl2 => exist _ (B754_nan s2 pl2 Hpl2) (refl_equal true) | _, _ => default_nan_pl32 end. -Definition b32_opp := Bopp 24 128 pair. -Definition b32_plus := Bplus _ _ Hprec Hprec_emax binop_nan_pl32. -Definition b32_minus := Bminus _ _ Hprec Hprec_emax binop_nan_pl32. -Definition b32_mult := Bmult _ _ Hprec Hprec_emax binop_nan_pl32. -Definition b32_div := Bdiv _ _ Hprec Hprec_emax binop_nan_pl32. -Definition b32_sqrt := Bsqrt _ _ Hprec Hprec_emax unop_nan_pl32. +Definition b32_erase : binary32 -> binary32 := erase 24 128. +Definition b32_opp : binary32 -> binary32 := Bopp 24 128 unop_nan_pl32. +Definition b32_abs : binary32 -> binary32 := Babs 24 128 unop_nan_pl32. +Definition b32_sqrt : mode -> binary32 -> binary32 := Bsqrt _ _ Hprec Hprec_emax unop_nan_pl32. + +Definition b32_plus : mode -> binary32 -> binary32 -> binary32 := Bplus _ _ Hprec Hprec_emax binop_nan_pl32. +Definition b32_minus : mode -> binary32 -> binary32 -> binary32 := Bminus _ _ Hprec Hprec_emax binop_nan_pl32. +Definition b32_mult : mode -> binary32 -> binary32 -> binary32 := Bmult _ _ Hprec Hprec_emax binop_nan_pl32. +Definition b32_div : mode -> binary32 -> binary32 -> binary32 := Bdiv _ _ Hprec Hprec_emax binop_nan_pl32. +Definition b32_compare : binary32 -> binary32 -> option comparison := Bcompare 24 128. Definition b32_of_bits : Z -> binary32 := binary_float_of_bits 23 8 (refl_equal _) (refl_equal _) (refl_equal _). Definition bits_of_b32 : binary32 -> Z := bits_of_binary_float 23 8. @@ -647,41 +658,47 @@ End B32_Bits. (** Specialization for IEEE double precision operations *) Section B64_Bits. -Arguments B754_nan {prec emax} _ _. +Arguments B754_nan {prec} {emax}. Definition binary64 := binary_float 53 1024. Let Hprec : (0 < 53)%Z. +Proof. apply refl_equal. Qed. Let Hprec_emax : (53 < 1024)%Z. +Proof. apply refl_equal. Qed. -Definition default_nan_pl64 : bool * nan_pl 53 := - (false, exist _ (iter_nat xO 51 xH) (refl_equal true)). +Definition default_nan_pl64 : { nan : binary64 | is_nan 53 1024 nan = true } := + exist _ (@B754_nan 53 1024 false (iter_nat xO 51 xH) (refl_equal true)) (refl_equal true). -Definition unop_nan_pl64 (f : binary64) : bool * nan_pl 53 := - match f with - | B754_nan s pl => (s, pl) +Definition unop_nan_pl64 (f : binary64) : { nan : binary64 | is_nan 53 1024 nan = true } := + match f as f with + | B754_nan s pl Hpl => exist _ (B754_nan s pl Hpl) (refl_equal true) | _ => default_nan_pl64 end. -Definition binop_nan_pl64 (pl1 pl2 : binary64) : bool * nan_pl 53 := - match pl1, pl2 with - | B754_nan s1 pl1, _ => (s1, pl1) - | _, B754_nan s2 pl2 => (s2, pl2) +Definition binop_nan_pl64 (f1 f2 : binary64) : { nan : binary64 | is_nan 53 1024 nan = true } := + match f1, f2 with + | B754_nan s1 pl1 Hpl1, _ => exist _ (B754_nan s1 pl1 Hpl1) (refl_equal true) + | _, B754_nan s2 pl2 Hpl2 => exist _ (B754_nan s2 pl2 Hpl2) (refl_equal true) | _, _ => default_nan_pl64 end. -Definition b64_opp := Bopp 53 1024 pair. -Definition b64_plus := Bplus _ _ Hprec Hprec_emax binop_nan_pl64. -Definition b64_minus := Bminus _ _ Hprec Hprec_emax binop_nan_pl64. -Definition b64_mult := Bmult _ _ Hprec Hprec_emax binop_nan_pl64. -Definition b64_div := Bdiv _ _ Hprec Hprec_emax binop_nan_pl64. -Definition b64_sqrt := Bsqrt _ _ Hprec Hprec_emax unop_nan_pl64. +Definition b64_erase : binary64 -> binary64 := erase 53 1024. +Definition b64_opp : binary64 -> binary64 := Bopp 53 1024 unop_nan_pl64. +Definition b64_abs : binary64 -> binary64 := Babs 53 1024 unop_nan_pl64. +Definition b64_sqrt : mode -> binary64 -> binary64 := Bsqrt _ _ Hprec Hprec_emax unop_nan_pl64. + +Definition b64_plus : mode -> binary64 -> binary64 -> binary64 := Bplus _ _ Hprec Hprec_emax binop_nan_pl64. +Definition b64_minus : mode -> binary64 -> binary64 -> binary64 := Bminus _ _ Hprec Hprec_emax binop_nan_pl64. +Definition b64_mult : mode -> binary64 -> binary64 -> binary64 := Bmult _ _ Hprec Hprec_emax binop_nan_pl64. +Definition b64_div : mode -> binary64 -> binary64 -> binary64 := Bdiv _ _ Hprec Hprec_emax binop_nan_pl64. +Definition b64_compare : binary64 -> binary64 -> option comparison := Bcompare 53 1024. Definition b64_of_bits : Z -> binary64 := binary_float_of_bits 52 11 (refl_equal _) (refl_equal _) (refl_equal _). Definition bits_of_b64 : binary64 -> Z := bits_of_binary_float 52 11. diff --git a/flocq/Prop/Div_sqrt_error.v b/flocq/Prop/Div_sqrt_error.v new file mode 100644 index 00000000..76c7af95 --- /dev/null +++ b/flocq/Prop/Div_sqrt_error.v @@ -0,0 +1,872 @@ +(** +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 +#<br /># +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. +*) + +(** * Remainder of the division and square root are in the FLX format *) + +Require Import Psatz. +Require Import Core Operations Relative Sterbenz Mult_error. + +Section Fprop_divsqrt_error. + +Variable beta : radix. +Notation bpow e := (bpow beta e). + +Variable prec : Z. + +Lemma generic_format_plus_prec : + forall fexp, (forall e, (fexp e <= e - prec)%Z) -> + forall x y (fx fy: float beta), + (x = F2R fx)%R -> (y = F2R fy)%R -> (Rabs (x+y) < bpow (prec+Fexp fx))%R -> + (Rabs (x+y) < bpow (prec+Fexp fy))%R -> + generic_format beta fexp (x+y)%R. +Proof. +intros fexp Hfexp x y fx fy Hx Hy H1 H2. +case (Req_dec (x+y) 0); intros H. +rewrite H; apply generic_format_0. +rewrite Hx, Hy, <- F2R_plus. +apply generic_format_F2R. +intros _. +case_eq (Fplus fx fy). +intros mz ez Hz. +rewrite <- Hz. +apply Z.le_trans with (Z.min (Fexp fx) (Fexp fy)). +rewrite F2R_plus, <- Hx, <- Hy. +unfold cexp. +apply Z.le_trans with (1:=Hfexp _). +apply Zplus_le_reg_l with prec; ring_simplify. +apply mag_le_bpow with (1 := H). +now apply Z.min_case. +rewrite <- Fexp_Fplus, Hz. +apply Z.le_refl. +Qed. + +Context { prec_gt_0_ : Prec_gt_0 prec }. + +Notation format := (generic_format beta (FLX_exp prec)). +Notation cexp := (cexp beta (FLX_exp prec)). + +Variable choice : Z -> bool. + + +(** Remainder of the division in FLX *) +Theorem div_error_FLX : + forall rnd { Zrnd : Valid_rnd rnd } x y, + format x -> format y -> + format (x - round beta (FLX_exp prec) rnd (x/y) * y)%R. +Proof with auto with typeclass_instances. +intros rnd Zrnd x y Hx Hy. +destruct (Req_dec y 0) as [Zy|Zy]. +now rewrite Zy, Rmult_0_r, Rminus_0_r. +destruct (Req_dec (round beta (FLX_exp prec) rnd (x/y)) 0) as [Hr|Hr]. +rewrite Hr; ring_simplify (x-0*y)%R; assumption. +assert (Zx: x <> R0). +contradict Hr. +rewrite Hr. +unfold Rdiv. +now rewrite Rmult_0_l, round_0. +destruct (canonical_generic_format _ _ x Hx) as (fx,(Hx1,Hx2)). +destruct (canonical_generic_format _ _ y Hy) as (fy,(Hy1,Hy2)). +destruct (canonical_generic_format beta (FLX_exp prec) (round beta (FLX_exp prec) rnd (x / y))) as (fr,(Hr1,Hr2)). +apply generic_format_round... +unfold Rminus; apply generic_format_plus_prec with fx (Fopp (Fmult fr fy)); trivial. +intros e; apply Z.le_refl. +now rewrite F2R_opp, F2R_mult, <- Hr1, <- Hy1. +(* *) +destruct (relative_error_FLX_ex beta prec (prec_gt_0 prec) rnd (x / y)%R) as (eps,(Heps1,Heps2)). +rewrite Heps2. +rewrite <- Rabs_Ropp. +replace (-(x + - (x / y * (1 + eps) * y)))%R with (x * eps)%R by now field. +rewrite Rabs_mult. +apply Rlt_le_trans with (Rabs x * 1)%R. +apply Rmult_lt_compat_l. +now apply Rabs_pos_lt. +apply Rlt_le_trans with (1 := Heps1). +change 1%R with (bpow 0). +apply bpow_le. +generalize (prec_gt_0 prec). +clear ; omega. +rewrite Rmult_1_r. +rewrite Hx2, <- Hx1. +unfold cexp. +destruct (mag beta x) as (ex, Hex). +simpl. +specialize (Hex Zx). +apply Rlt_le. +apply Rlt_le_trans with (1 := proj2 Hex). +apply bpow_le. +unfold FLX_exp. +ring_simplify. +apply Z.le_refl. +(* *) +replace (Fexp (Fopp (Fmult fr fy))) with (Fexp fr + Fexp fy)%Z. +2: unfold Fopp, Fmult; destruct fr; destruct fy; now simpl. +replace (x + - (round beta (FLX_exp prec) rnd (x / y) * y))%R with + (y * (-(round beta (FLX_exp prec) rnd (x / y) - x/y)))%R. +2: field; assumption. +rewrite Rabs_mult. +apply Rlt_le_trans with (Rabs y * bpow (Fexp fr))%R. +apply Rmult_lt_compat_l. +now apply Rabs_pos_lt. +rewrite Rabs_Ropp. +replace (bpow (Fexp fr)) with (ulp beta (FLX_exp prec) (F2R fr)). +rewrite <- Hr1. +apply error_lt_ulp_round... +apply Rmult_integral_contrapositive_currified; try apply Rinv_neq_0_compat; assumption. +rewrite ulp_neq_0. +2: now rewrite <- Hr1. +apply f_equal. +now rewrite Hr2, <- Hr1. +replace (prec+(Fexp fr+Fexp fy))%Z with ((prec+Fexp fy)+Fexp fr)%Z by ring. +rewrite bpow_plus. +apply Rmult_le_compat_r. +apply bpow_ge_0. +rewrite Hy2, <- Hy1 ; unfold cexp, FLX_exp. +ring_simplify (prec + (mag beta y - prec))%Z. +destruct (mag beta y); simpl. +left; now apply a. +Qed. + +(** Remainder of the square in FLX (with p>1) and rounding to nearest *) +Variable Hp1 : Z.lt 1 prec. + +Theorem sqrt_error_FLX_N : + forall x, format x -> + format (x - Rsqr (round beta (FLX_exp prec) (Znearest choice) (sqrt x)))%R. +Proof with auto with typeclass_instances. +intros x Hx. +destruct (total_order_T x 0) as [[Hxz|Hxz]|Hxz]. +unfold sqrt. +destruct (Rcase_abs x). +rewrite round_0... +unfold Rsqr. +now rewrite Rmult_0_l, Rminus_0_r. +elim (Rlt_irrefl 0). +now apply Rgt_ge_trans with x. +rewrite Hxz, sqrt_0, round_0... +unfold Rsqr. +rewrite Rmult_0_l, Rminus_0_r. +apply generic_format_0. +case (Req_dec (round beta (FLX_exp prec) (Znearest choice) (sqrt x)) 0); intros Hr. +rewrite Hr; unfold Rsqr; ring_simplify (x-0*0)%R; assumption. +destruct (canonical_generic_format _ _ x Hx) as (fx,(Hx1,Hx2)). +destruct (canonical_generic_format beta (FLX_exp prec) (round beta (FLX_exp prec) (Znearest choice) (sqrt x))) as (fr,(Hr1,Hr2)). +apply generic_format_round... +unfold Rminus; apply generic_format_plus_prec with fx (Fopp (Fmult fr fr)); trivial. +intros e; apply Z.le_refl. +unfold Rsqr; now rewrite F2R_opp,F2R_mult, <- Hr1. +(* *) +apply Rle_lt_trans with x. +apply Rabs_minus_le. +apply Rle_0_sqr. +destruct (relative_error_N_FLX_ex beta prec (prec_gt_0 prec) choice (sqrt x)) as (eps,(Heps1,Heps2)). +rewrite Heps2. +rewrite Rsqr_mult, Rsqr_sqrt, Rmult_comm. 2: now apply Rlt_le. +apply Rmult_le_compat_r. +now apply Rlt_le. +apply Rle_trans with (5²/4²)%R. +rewrite <- Rsqr_div. +apply Rsqr_le_abs_1. +apply Rle_trans with (1 := Rabs_triang _ _). +rewrite Rabs_R1. +apply Rplus_le_reg_l with (-1)%R. +replace (-1 + (1 + Rabs eps))%R with (Rabs eps) by ring. +apply Rle_trans with (1 := Heps1). +rewrite Rabs_pos_eq. +apply Rmult_le_reg_l with 2%R. +now apply IZR_lt. +rewrite <- Rmult_assoc, Rinv_r, Rmult_1_l. +apply Rle_trans with (bpow (-1)). +apply bpow_le. +omega. +replace (2 * (-1 + 5 / 4))%R with (/2)%R by field. +apply Rinv_le. +now apply IZR_lt. +apply IZR_le. +unfold Zpower_pos. simpl. +rewrite Zmult_1_r. +apply Zle_bool_imp_le. +apply beta. +now apply IZR_neq. +unfold Rdiv. +apply Rmult_le_pos. +now apply IZR_le. +apply Rlt_le. +apply Rinv_0_lt_compat. +now apply IZR_lt. +now apply IZR_neq. +unfold Rsqr. +replace (5 * 5 / (4 * 4))%R with (25 * /16)%R by field. +apply Rmult_le_reg_r with 16%R. +now apply IZR_lt. +rewrite Rmult_assoc, Rinv_l, Rmult_1_r. +now apply (IZR_le _ 32). +now apply IZR_neq. +rewrite Hx2, <- Hx1; unfold cexp, FLX_exp. +ring_simplify (prec + (mag beta x - prec))%Z. +destruct (mag beta x); simpl. +rewrite <- (Rabs_right x). +apply a. +now apply Rgt_not_eq. +now apply Rgt_ge. +(* *) +replace (Fexp (Fopp (Fmult fr fr))) with (Fexp fr + Fexp fr)%Z. +2: unfold Fopp, Fmult; destruct fr; now simpl. +rewrite Hr1. +replace (x + - Rsqr (F2R fr))%R with (-((F2R fr - sqrt x)*(F2R fr + sqrt x)))%R. +2: rewrite <- (sqrt_sqrt x) at 3; auto. +2: unfold Rsqr; ring. +rewrite Rabs_Ropp, Rabs_mult. +apply Rle_lt_trans with ((/2*bpow (Fexp fr))* Rabs (F2R fr + sqrt x))%R. +apply Rmult_le_compat_r. +apply Rabs_pos. +apply Rle_trans with (/2*ulp beta (FLX_exp prec) (F2R fr))%R. +rewrite <- Hr1. +apply error_le_half_ulp_round... +right; rewrite ulp_neq_0. +2: now rewrite <- Hr1. +apply f_equal. +rewrite Hr2, <- Hr1; trivial. +rewrite Rmult_assoc, Rmult_comm. +replace (prec+(Fexp fr+Fexp fr))%Z with (Fexp fr + (prec+Fexp fr))%Z by ring. +rewrite bpow_plus, Rmult_assoc. +apply Rmult_lt_compat_l. +apply bpow_gt_0. +apply Rmult_lt_reg_l with (1 := Rlt_0_2). +apply Rle_lt_trans with (Rabs (F2R fr + sqrt x)). +right; field. +apply Rle_lt_trans with (1:=Rabs_triang _ _). +(* . *) +assert (Rabs (F2R fr) < bpow (prec + Fexp fr))%R. +rewrite Hr2. +unfold cexp, FLX_exp. +ring_simplify (prec + (mag beta (F2R fr) - prec))%Z. +destruct (mag beta (F2R fr)); simpl. +apply a. +rewrite <- Hr1; auto. +(* . *) +apply Rlt_le_trans with (bpow (prec + Fexp fr)+ Rabs (sqrt x))%R. +now apply Rplus_lt_compat_r. +(* . *) +replace (2 * bpow (prec + Fexp fr))%R with (bpow (prec + Fexp fr) + bpow (prec + Fexp fr))%R by ring. +apply Rplus_le_compat_l. +assert (sqrt x <> 0)%R. +apply Rgt_not_eq. +now apply sqrt_lt_R0. +destruct (mag beta (sqrt x)) as (es,Es). +specialize (Es H0). +apply Rle_trans with (bpow es). +now apply Rlt_le. +apply bpow_le. +case (Zle_or_lt es (prec + Fexp fr)) ; trivial. +intros H1. +absurd (Rabs (F2R fr) < bpow (es - 1))%R. +apply Rle_not_lt. +rewrite <- Hr1. +apply abs_round_ge_generic... +apply generic_format_bpow. +unfold FLX_exp; omega. +apply Es. +apply Rlt_le_trans with (1:=H). +apply bpow_le. +omega. +now apply Rlt_le. +Qed. + +Lemma sqrt_error_N_FLX_aux1 x (Fx : format x) (Px : (0 < x)%R) : + exists (mu : R) (e : Z), (format mu /\ x = mu * bpow (2 * e) :> R + /\ 1 <= mu < bpow 2)%R. +Proof. +set (e := ((mag beta x - 1) / 2)%Z). +set (mu := (x * bpow (-2 * e)%Z)%R). +assert (Hbe : (bpow (-2 * e) * bpow (2 * e) = 1)%R). +{ now rewrite <- bpow_plus; case e; simpl; [reflexivity| |]; intro p; + rewrite Z.pos_sub_diag. } +assert (Fmu : format mu); [now apply mult_bpow_exact_FLX|]. +exists mu, e; split; [exact Fmu|split; [|split]]. +{ set (e2 := (2 * e)%Z); simpl; unfold mu; rewrite Rmult_assoc. + now unfold e2; rewrite Hbe, Rmult_1_r. } +{ apply (Rmult_le_reg_r (bpow (2 * e))). + { apply bpow_gt_0. } + rewrite Rmult_1_l; set (e2 := (2 * e)%Z); simpl; unfold mu. + unfold e2; rewrite Rmult_assoc, Hbe, Rmult_1_r. + apply (Rle_trans _ (bpow (mag beta x - 1))). + { now apply bpow_le; unfold e; apply Z_mult_div_ge. } + set (l := mag _ _); rewrite <- (Rabs_pos_eq _ (Rlt_le _ _ Px)). + unfold l; apply bpow_mag_le. + intro Hx; revert Px; rewrite Hx; apply Rlt_irrefl. } +simpl; unfold mu; change (IZR _) with (bpow 2). +apply (Rmult_lt_reg_r (bpow (2 * e))); [now apply bpow_gt_0|]. +rewrite Rmult_assoc, Hbe, Rmult_1_r. +apply (Rlt_le_trans _ (bpow (mag beta x))). +{ rewrite <- (Rabs_pos_eq _ (Rlt_le _ _ Px)) at 1; apply bpow_mag_gt. } +rewrite <- bpow_plus; apply bpow_le; unfold e; set (mxm1 := (_ - 1)%Z). +replace (_ * _)%Z with (2 * (mxm1 / 2) + mxm1 mod 2 - mxm1 mod 2)%Z by ring. +rewrite <- Z.div_mod; [|now simpl]. +apply (Zplus_le_reg_r _ _ (mxm1 mod 2 - mag beta x)%Z). +unfold mxm1; destruct (Z.mod_bound_or (mag beta x - 1) 2); omega. +Qed. + +Notation u_ro := (u_ro beta prec). + +Lemma sqrt_error_N_FLX_aux2 x (Fx : format x) : + (1 <= x)%R -> + (x = 1 :> R \/ x = 1 + 2 * u_ro :> R \/ 1 + 4 * u_ro <= x)%R. +Proof. +intro HxGe1. +assert (Pu_ro : (0 <= u_ro)%R); [apply Rmult_le_pos; [lra|apply bpow_ge_0]|]. +destruct (Rle_or_lt x 1) as [HxLe1|HxGt1]; [now left; apply Rle_antisym|right]. +assert (F1 : format 1); [now apply generic_format_FLX_1|]. +assert (H2eps : (2 * u_ro = bpow (-prec + 1))%R). +{ unfold u_ro; rewrite bpow_plus; field. } +assert (HmuGe1p2eps : (1 + 2 * u_ro <= x)%R). +{ rewrite H2eps, <- succ_FLX_1. + now apply succ_le_lt; [now apply FLX_exp_valid| | |]. } +destruct (Rle_or_lt x (1 + 2 * u_ro)) as [HxLe1p2eps|HxGt1p2eps]; + [now left; apply Rle_antisym|right]. +assert (Hulp1p2eps : (ulp beta (FLX_exp prec) (1 + 2 * u_ro) = 2 * u_ro)%R). +{ destruct (ulp_succ_pos _ _ _ F1 Rlt_0_1) as [Hsucc|Hsucc]. + { now rewrite H2eps, <- succ_FLX_1, <- ulp_FLX_1. } + exfalso; revert Hsucc; apply Rlt_not_eq. + rewrite succ_FLX_1, mag_1, bpow_1, <- H2eps; simpl. + apply (Rlt_le_trans _ 2); [apply Rplus_lt_compat_l|]. + { unfold u_ro; rewrite <-Rmult_assoc, Rinv_r, Rmult_1_l; [|lra]. + change R1 with (bpow 0); apply bpow_lt; omega. } + apply IZR_le, Zle_bool_imp_le, radix_prop. } +assert (Hsucc1p2eps : + (succ beta (FLX_exp prec) (1 + 2 * u_ro) = 1 + 4 * u_ro)%R). +{ unfold succ; rewrite Rle_bool_true; [rewrite Hulp1p2eps; ring|]. + apply Rplus_le_le_0_compat; lra. } +rewrite <- Hsucc1p2eps. +apply succ_le_lt; [now apply FLX_exp_valid| |exact Fx|now simpl]. +rewrite H2eps, <- succ_FLX_1. +now apply generic_format_succ; [apply FLX_exp_valid|]. +Qed. + +Lemma sqrt_error_N_FLX_aux3 : + (u_ro / sqrt (1 + 4 * u_ro) <= 1 - 1 / sqrt (1 + 2 * u_ro))%R. +Proof. +assert (Pu_ro : (0 <= u_ro)%R); [apply Rmult_le_pos; [lra|apply bpow_ge_0]|]. +unfold Rdiv; apply (Rplus_le_reg_r (/ sqrt (1 + 2 * u_ro))); ring_simplify. +apply (Rmult_le_reg_r (sqrt (1 + 4 * u_ro) * sqrt (1 + 2 * u_ro))). +{ apply Rmult_lt_0_compat; apply sqrt_lt_R0; lra. } +field_simplify; [|split; apply Rgt_not_eq, Rlt_gt, sqrt_lt_R0; lra]. +unfold Rdiv; rewrite Rinv_1, !Rmult_1_r. +apply Rsqr_incr_0_var; [|now apply Rmult_le_pos; apply sqrt_pos]. +rewrite <-sqrt_mult; [|lra|lra]. +rewrite Rsqr_sqrt; [|apply Rmult_le_pos; lra]. +unfold Rsqr; ring_simplify; unfold pow; rewrite !Rmult_1_r. +rewrite !sqrt_def; [|lra|lra]. +apply (Rplus_le_reg_r (-u_ro * u_ro - 1 -4 * u_ro - 2 * u_ro ^ 3)). +ring_simplify; apply Rsqr_incr_0_var. +{ unfold Rsqr; ring_simplify. + unfold pow; rewrite !Rmult_1_r, !sqrt_def; [|lra|lra]. + apply (Rplus_le_reg_r (-32 * u_ro ^ 4 - 24 * u_ro ^ 3 - 4 * u_ro ^ 2)). + ring_simplify. + replace (_ + _)%R + with (((4 * u_ro ^ 2 - 28 * u_ro + 9) * u_ro + 4) * u_ro ^ 3)%R by ring. + apply Rmult_le_pos; [|now apply pow_le]. + assert (Heps_le_half : (u_ro <= 1 / 2)%R). + { unfold u_ro, Rdiv; rewrite Rmult_comm; apply Rmult_le_compat_r; [lra|]. + change 1%R with (bpow 0); apply bpow_le; omega. } + apply (Rle_trans _ (-8 * u_ro + 4)); [lra|]. + apply Rplus_le_compat_r, Rmult_le_compat_r; [apply Pu_ro|]. + now assert (H : (0 <= u_ro ^ 2)%R); [apply pow2_ge_0|lra]. } +assert (H : (u_ro ^ 3 <= u_ro ^ 2)%R). +{ unfold pow; rewrite <-!Rmult_assoc, Rmult_1_r. + apply Rmult_le_compat_l; [now apply Rmult_le_pos; apply Pu_ro|]. + now apply Rlt_le, u_ro_lt_1. } +now assert (H' : (0 <= u_ro ^ 2)%R); [apply pow2_ge_0|lra]. +Qed. + +Lemma om1ds1p2u_ro_pos : (0 <= 1 - 1 / sqrt (1 + 2 * u_ro))%R. +Proof. +unfold Rdiv; rewrite Rmult_1_l, <-Rinv_1 at 1. +apply Rle_0_minus, Rinv_le; [lra|]. +rewrite <- sqrt_1 at 1; apply sqrt_le_1_alt. +assert (H := u_ro_pos beta prec); lra. +Qed. + +Lemma om1ds1p2u_ro_le_u_rod1pu_ro : + (1 - 1 / sqrt (1 + 2 * u_ro) <= u_ro / (1 + u_ro))%R. +Proof. +assert (Pu_ro := u_ro_pos beta prec). +apply (Rmult_le_reg_r (sqrt (1 + 2 * u_ro) * (1 + u_ro))). +{ apply Rmult_lt_0_compat; [apply sqrt_lt_R0|]; lra. } +field_simplify; [|lra|intro H; apply sqrt_eq_0 in H; lra]. +unfold Rdiv, Rminus; rewrite Rinv_1, !Rmult_1_r, !Rplus_assoc. +rewrite <-(Rplus_0_r (sqrt _ * _)) at 2; apply Rplus_le_compat_l. +apply (Rplus_le_reg_r (1 + u_ro)); ring_simplify. +rewrite <-(sqrt_square (_ + 1)); [|lra]; apply sqrt_le_1_alt. +assert (H : (0 <= u_ro * u_ro)%R); [apply Rmult_le_pos|]; lra. +Qed. + +Lemma s1p2u_rom1_pos : (0 <= sqrt (1 + 2 * u_ro) - 1)%R. +apply (Rplus_le_reg_r 1); ring_simplify. +rewrite <-sqrt_1 at 1; apply sqrt_le_1_alt. +assert (H := u_ro_pos beta prec); lra. +Qed. + +Theorem sqrt_error_N_FLX x (Fx : format x) : + (Rabs (round beta (FLX_exp prec) (Znearest choice) (sqrt x) - sqrt x) + <= (1 - 1 / sqrt (1 + 2 * u_ro)) * Rabs (sqrt x))%R. +Proof. +assert (Peps := u_ro_pos beta prec). +assert (Peps' : (0 < u_ro)%R). +{ unfold u_ro; apply Rmult_lt_0_compat; [lra|apply bpow_gt_0]. } +assert (Pb := om1ds1p2u_ro_pos). +assert (Pb' := s1p2u_rom1_pos). +destruct (Rle_or_lt x 0) as [Nx|Px]. +{ rewrite (sqrt_neg _ Nx), round_0, Rabs_R0, Rmult_0_r; [|apply valid_rnd_N]. + now unfold Rminus; rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0; right. } +destruct (sqrt_error_N_FLX_aux1 _ Fx Px) + as (mu, (e, (Fmu, (Hmu, (HmuGe1, HmuLtsqradix))))). +pose (t := sqrt x). +set (rt := round _ _ _ _). +assert (Ht : (t = sqrt mu * bpow e)%R). +{ unfold t; rewrite Hmu, sqrt_mult_alt; [|now apply (Rle_trans _ _ _ Rle_0_1)]. + now rewrite sqrt_bpow. } +destruct (sqrt_error_N_FLX_aux2 _ Fmu HmuGe1) as [Hmu'|[Hmu'|Hmu']]. +{ unfold rt; fold t; rewrite Ht, Hmu', sqrt_1, Rmult_1_l. + rewrite round_generic; [|now apply valid_rnd_N|]. + { rewrite Rminus_diag_eq, Rabs_R0; [|now simpl]. + now apply Rmult_le_pos; [|apply Rabs_pos]. } + apply generic_format_bpow'; [now apply FLX_exp_valid|]. + unfold FLX_exp; omega. } +{ assert (Hsqrtmu : (1 <= sqrt mu < 1 + u_ro)%R); [rewrite Hmu'; split|]. + { rewrite <- sqrt_1 at 1; apply sqrt_le_1_alt; lra. } + { rewrite <- sqrt_square; [|lra]; apply sqrt_lt_1_alt; split; [lra|]. + ring_simplify; assert (0 < u_ro ^ 2)%R; [apply pow_lt|]; lra. } + assert (Fbpowe : generic_format beta (FLX_exp prec) (bpow e)). + { apply generic_format_bpow; unfold FLX_exp; omega. } + assert (Hrt : rt = bpow e :> R). + { unfold rt; fold t; rewrite Ht; simpl; apply Rle_antisym. + { apply round_N_le_midp; [now apply FLX_exp_valid|exact Fbpowe|]. + apply (Rlt_le_trans _ ((1 + u_ro) * bpow e)). + { now apply Rmult_lt_compat_r; [apply bpow_gt_0|]. } + unfold succ; rewrite Rle_bool_true; [|now apply bpow_ge_0]. + rewrite ulp_bpow; unfold FLX_exp. + unfold Z.sub, u_ro; rewrite !bpow_plus; right; field. } + apply round_ge_generic; + [now apply FLX_exp_valid|now apply valid_rnd_N|exact Fbpowe|]. + rewrite <- (Rmult_1_l (bpow _)) at 1. + now apply Rmult_le_compat_r; [apply bpow_ge_0|]. } + fold t; rewrite Hrt, Ht, Hmu', <-(Rabs_pos_eq _ Pb), <-Rabs_mult. + rewrite Rabs_minus_sym; right; f_equal; field; lra. } +assert (Hsqrtmu : (1 + u_ro < sqrt mu)%R). +{ apply (Rlt_le_trans _ (sqrt (1 + 4 * u_ro))); [|now apply sqrt_le_1_alt]. + assert (P1peps : (0 <= 1 + u_ro)%R) + by now apply Rplus_le_le_0_compat; [lra|apply Peps]. + rewrite <- (sqrt_square (1 + u_ro)); [|lra]. + apply sqrt_lt_1_alt; split; [now apply Rmult_le_pos|]. + apply (Rplus_lt_reg_r (-1 - 2 * u_ro)); ring_simplify; simpl. + rewrite Rmult_1_r; apply Rmult_lt_compat_r; [apply Peps'|]. + now apply (Rlt_le_trans _ 1); [apply u_ro_lt_1|lra]. } +assert (Hulpt : (ulp beta (FLX_exp prec) t = 2 * u_ro * bpow e)%R). +{ unfold ulp; rewrite Req_bool_false; [|apply Rgt_not_eq, Rlt_gt]. + { unfold u_ro; rewrite <-Rmult_assoc, Rinv_r, Rmult_1_l, <-bpow_plus; [|lra]. + f_equal; unfold cexp, FLX_exp. + assert (Hmagt : (mag beta t = 1 + e :> Z)%Z). + { apply mag_unique. + unfold t; rewrite (Rabs_pos_eq _ (Rlt_le _ _ (sqrt_lt_R0 _ Px))). + fold t; split. + { rewrite Ht; replace (_ - _)%Z with e by ring. + rewrite <- (Rmult_1_l (bpow _)) at 1; apply Rmult_le_compat_r. + { apply bpow_ge_0. } + now rewrite <- sqrt_1; apply sqrt_le_1_alt. } + rewrite bpow_plus, bpow_1, Ht; simpl. + apply Rmult_lt_compat_r; [now apply bpow_gt_0|]. + rewrite <- sqrt_square. + { apply sqrt_lt_1_alt; split; [lra|]. + apply (Rlt_le_trans _ _ _ HmuLtsqradix); right. + now unfold bpow, Z.pow_pos; simpl; rewrite Zmult_1_r, mult_IZR. } + apply IZR_le, (Z.le_trans _ 2), Zle_bool_imp_le, radix_prop; omega. } + rewrite Hmagt; ring. } + rewrite Ht; apply Rmult_lt_0_compat; [|now apply bpow_gt_0]. + now apply (Rlt_le_trans _ 1); [lra|rewrite <- sqrt_1; apply sqrt_le_1_alt]. } +assert (Pt : (0 < t)%R). +{ rewrite Ht; apply Rmult_lt_0_compat; [lra|apply bpow_gt_0]. } +assert (H : (Rabs ((rt - sqrt x) / sqrt x) + <= 1 - 1 / sqrt (1 + 2 * u_ro))%R). +{ unfold Rdiv; rewrite Rabs_mult, (Rabs_pos_eq (/ _)); + [|now left; apply Rinv_0_lt_compat]. + apply (Rle_trans _ ((u_ro * bpow e) / t)). + { unfold Rdiv; apply Rmult_le_compat_r; [now left; apply Rinv_0_lt_compat|]. + apply (Rle_trans _ _ _ (error_le_half_ulp _ _ _ _)). + fold t; rewrite Hulpt; right; field. } + apply (Rle_trans _ (u_ro / sqrt (1 + 4 * u_ro))). + { apply (Rle_trans _ (u_ro * bpow e / (sqrt (1 + 4 * u_ro) * bpow e))). + { unfold Rdiv; apply Rmult_le_compat_l; + [now apply Rmult_le_pos; [apply Peps|apply bpow_ge_0]|]. + apply Rinv_le. + { apply Rmult_lt_0_compat; [apply sqrt_lt_R0; lra|apply bpow_gt_0]. } + now rewrite Ht; apply Rmult_le_compat_r; + [apply bpow_ge_0|apply sqrt_le_1_alt]. } + right; field; split; apply Rgt_not_eq, Rlt_gt; + [apply sqrt_lt_R0; lra|apply bpow_gt_0]. } + apply sqrt_error_N_FLX_aux3. } +revert H; unfold Rdiv; rewrite Rabs_mult, Rabs_Rinv; [|fold t; lra]; intro H. +apply (Rmult_le_reg_r (/ Rabs (sqrt x))); + [apply Rinv_0_lt_compat, Rabs_pos_lt; fold t; lra|]. +apply (Rle_trans _ _ _ H); right; field; split; [apply Rabs_no_R0;fold t|]; lra. +Qed. + +Theorem sqrt_error_N_FLX_ex x (Fx : format x) : + exists eps, + (Rabs eps <= 1 - 1 / sqrt (1 + 2 * u_ro))%R /\ + round beta (FLX_exp prec) (Znearest choice) (sqrt x) + = (sqrt x * (1 + eps))%R. +Proof. +now apply relative_error_le_conversion; + [apply valid_rnd_N|apply om1ds1p2u_ro_pos|apply sqrt_error_N_FLX]. +Qed. + +Lemma sqrt_error_N_round_ex_derive : + forall x rx, + (exists eps, + (Rabs eps <= 1 - 1 / sqrt (1 + 2 * u_ro))%R /\ rx = (x * (1 + eps))%R) -> + exists eps, + (Rabs eps <= sqrt (1 + 2 * u_ro) - 1)%R /\ x = (rx * (1 + eps))%R. +Proof. +intros x rx (d, (Bd, Hd)). +assert (H := Rabs_le_inv _ _ Bd). +assert (H' := om1ds1p2u_ro_le_u_rod1pu_ro). +assert (H'' := u_rod1pu_ro_le_u_ro beta prec). +assert (H''' := u_ro_lt_1 beta prec prec_gt_0_). +assert (Hpos := s1p2u_rom1_pos). +destruct (Req_dec rx 0) as [Zfx|Nzfx]. +{ exists 0%R; split; [now rewrite Rabs_R0|]. + rewrite Rplus_0_r, Rmult_1_r, Zfx; rewrite Zfx in Hd. + destruct (Rmult_integral _ _ (sym_eq Hd)); lra. } +destruct (Req_dec x 0) as [Zx|Nzx]. +{ now exfalso; revert Hd; rewrite Zx; rewrite Rmult_0_l. } +set (d' := ((x - rx) / rx)%R). +assert (Hd' : (Rabs d' <= sqrt (1 + 2 * u_ro) - 1)%R). +{ unfold d'; rewrite Hd. + replace (_ / _)%R with (- d / (1 + d))%R; [|now field; split; lra]. + unfold Rdiv; rewrite Rabs_mult, Rabs_Ropp. + rewrite (Rabs_pos_eq (/ _)); [|apply Rlt_le, Rinv_0_lt_compat; lra]. + apply (Rmult_le_reg_r (1 + d)); [lra|]. + rewrite Rmult_assoc, Rinv_l, Rmult_1_r; [|lra]. + apply (Rle_trans _ _ _ Bd). + apply (Rle_trans _ ((sqrt (1 + 2 * u_ro) - 1) * (1/sqrt (1 + 2 * u_ro)))); + [right; field|apply Rmult_le_compat_l]; lra. } +now exists d'; split; [exact Hd'|]; unfold d'; field. +Qed. + +(** sqrt(1 + 2 u_ro) - 1 <= u_ro *) +Theorem sqrt_error_N_FLX_round_ex : + forall x, + format x -> + exists eps, + (Rabs eps <= sqrt (1 + 2 * u_ro) - 1)%R /\ + sqrt x = (round beta (FLX_exp prec) (Znearest choice) (sqrt x) * (1 + eps))%R. +Proof. +now intros x Fx; apply sqrt_error_N_round_ex_derive, sqrt_error_N_FLX_ex. +Qed. + +Variable emin : Z. +Hypothesis Hemin : (emin <= 2 * (1 - prec))%Z. + +Theorem sqrt_error_N_FLT_ex : + forall x, + generic_format beta (FLT_exp emin prec) x -> + exists eps, + (Rabs eps <= 1 - 1 / sqrt (1 + 2 * u_ro))%R /\ + round beta (FLT_exp emin prec) (Znearest choice) (sqrt x) + = (sqrt x * (1 + eps))%R. +Proof. +intros x Fx. +assert (Heps := u_ro_pos). +assert (Pb := om1ds1p2u_ro_pos). +destruct (Rle_or_lt x 0) as [Nx|Px]. +{ exists 0%R; split; [now rewrite Rabs_R0|]. + now rewrite (sqrt_neg x Nx), round_0, Rmult_0_l; [|apply valid_rnd_N]. } +assert (Fx' := generic_format_FLX_FLT _ _ _ _ Fx). +destruct (sqrt_error_N_FLX_ex _ Fx') as (d, (Bd, Hd)). +exists d; split; [exact Bd|]; rewrite <-Hd; apply round_FLT_FLX. +apply (Rle_trans _ (bpow (emin / 2)%Z)). +{ apply bpow_le, Z.div_le_lower_bound; lia. } +apply (Rle_trans _ _ _ (sqrt_bpow_ge _ _)). +rewrite Rabs_pos_eq; [|now apply sqrt_pos]; apply sqrt_le_1_alt. +revert Fx; apply generic_format_ge_bpow; [|exact Px]. +intro e; unfold FLT_exp; apply Z.le_max_r. +Qed. + +(** sqrt(1 + 2 u_ro) - 1 <= u_ro *) +Theorem sqrt_error_N_FLT_round_ex : + forall x, + generic_format beta (FLT_exp emin prec) x -> + exists eps, + (Rabs eps <= sqrt (1 + 2 * u_ro) - 1)%R /\ + sqrt x + = (round beta (FLT_exp emin prec) (Znearest choice) (sqrt x) * (1 + eps))%R. +Proof. +now intros x Fx; apply sqrt_error_N_round_ex_derive, sqrt_error_N_FLT_ex. +Qed. + +End Fprop_divsqrt_error. + +Section format_REM_aux. + +Variable beta : radix. +Notation bpow e := (bpow beta e). + +Variable fexp : Z -> Z. +Context { valid_exp : Valid_exp fexp }. +Context { monotone_exp : Monotone_exp fexp }. + +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. + +Notation format := (generic_format beta fexp). + +Lemma format_REM_aux: + forall x y : R, + format x -> format y -> (0 <= x)%R -> (0 < y)%R -> + ((0 < x/y < /2)%R -> rnd (x/y) = 0%Z) -> + format (x - IZR (rnd (x/y))*y). +Proof with auto with typeclass_instances. +intros x y Fx Fy Hx Hy rnd_small. +pose (n:=rnd (x / y)). +assert (Hn:(IZR n = round beta (FIX_exp 0) rnd (x/y))%R). +unfold round, FIX_exp, cexp, scaled_mantissa, F2R; simpl. +now rewrite 2!Rmult_1_r. +assert (H:(0 <= n)%Z). +apply le_IZR; rewrite Hn; simpl. +apply Rle_trans with (round beta (FIX_exp 0) rnd 0). +right; apply sym_eq, round_0... +apply round_le... +apply Fourier_util.Rle_mult_inv_pos; assumption. +case (Zle_lt_or_eq 0 n); try exact H. +clear H; intros H. +case (Zle_lt_or_eq 1 n). +omega. +clear H; intros H. +set (ex := cexp beta fexp x). +set (ey := cexp beta fexp y). +set (mx := Ztrunc (scaled_mantissa beta fexp x)). +set (my := Ztrunc (scaled_mantissa beta fexp y)). +case (Zle_or_lt ey ex); intros Hexy. +(* ey <= ex *) +assert (H0:(x-IZR n *y = F2R (Float beta (mx*beta^(ex-ey) - n*my) ey))%R). +unfold Rminus; rewrite Rplus_comm. +replace (IZR n) with (F2R (Float beta n 0)). +rewrite Fx, Fy. +fold mx my ex ey. +rewrite <- F2R_mult. +rewrite <- F2R_opp. +rewrite <- F2R_plus. +unfold Fplus. simpl. +rewrite Zle_imp_le_bool with (1 := Hexy). +f_equal; f_equal; ring. +unfold F2R; simpl; ring. +fold n; rewrite H0. +apply generic_format_F2R. +rewrite <- H0; intros H3. +apply monotone_exp. +apply mag_le_abs. +rewrite H0; apply F2R_neq_0; easy. +apply Rmult_le_reg_l with (/Rabs y)%R. +apply Rinv_0_lt_compat. +apply Rabs_pos_lt. +now apply Rgt_not_eq. +rewrite Rinv_l. +2: apply Rgt_not_eq, Rabs_pos_lt. +2: now apply Rgt_not_eq. +rewrite <- Rabs_Rinv. +2: now apply Rgt_not_eq. +rewrite <- Rabs_mult. +replace (/y * (x - IZR n *y))%R with (-(IZR n - x/y))%R. +rewrite Rabs_Ropp. +rewrite Hn. +apply Rle_trans with (1:= error_le_ulp beta (FIX_exp 0) _ _). +rewrite ulp_FIX. +simpl; apply Rle_refl. +field. +now apply Rgt_not_eq. +(* ex < ey: impossible as 1 < n *) +absurd (1 < n)%Z; try easy. +apply Zle_not_lt. +apply le_IZR; simpl; rewrite Hn. +apply round_le_generic... +apply generic_format_FIX. +exists (Float beta 1 0); try easy. +unfold F2R; simpl; ring. +apply Rmult_le_reg_r with y; try easy. +unfold Rdiv; rewrite Rmult_assoc. +rewrite Rinv_l, Rmult_1_r, Rmult_1_l. +2: now apply Rgt_not_eq. +assert (mag beta x < mag beta y)%Z. +case (Zle_or_lt (mag beta y) (mag beta x)); try easy. +intros J; apply monotone_exp in J; clear -J Hexy. +unfold ex, ey, cexp in Hexy; omega. +left; apply lt_mag with beta; easy. +(* n = 1 -> Sterbenz + rnd_small *) +intros Hn'; fold n; rewrite <- Hn'. +rewrite Rmult_1_l. +case Hx; intros Hx'. +assert (J:(0 < x/y)%R). +apply Fourier_util.Rlt_mult_inv_pos; assumption. +apply sterbenz... +assert (H0:(Rabs (1 - x/y) < 1)%R). +rewrite Hn', Hn. +apply Rlt_le_trans with (ulp beta (FIX_exp 0) (round beta (FIX_exp 0) rnd (x / y)))%R. +apply error_lt_ulp_round... +now apply Rgt_not_eq. +rewrite ulp_FIX. +rewrite <- Hn, <- Hn'. +apply Rle_refl. +apply Rabs_lt_inv in H0. +split; apply Rmult_le_reg_l with (/y)%R; try now apply Rinv_0_lt_compat. +unfold Rdiv; rewrite <- Rmult_assoc. +rewrite Rinv_l. +2: now apply Rgt_not_eq. +rewrite Rmult_1_l, Rmult_comm; fold (x/y)%R. +case (Rle_or_lt (/2) (x/y)); try easy. +intros K. +elim Zlt_not_le with (1 := H). +apply Zeq_le. +apply rnd_small. +now split. +apply Ropp_le_cancel; apply Rplus_le_reg_l with 1%R. +apply Rle_trans with (1-x/y)%R. +2: right; unfold Rdiv; ring. +left; apply Rle_lt_trans with (2:=proj1 H0). +right; field. +now apply Rgt_not_eq. +rewrite <- Hx', Rminus_0_l. +now apply generic_format_opp. +(* n = 0 *) +clear H; intros H; fold n; rewrite <- H. +now rewrite Rmult_0_l, Rminus_0_r. +Qed. + +End format_REM_aux. + +Section format_REM. + +Variable beta : radix. +Notation bpow e := (bpow beta e). + +Variable fexp : Z -> Z. +Context { valid_exp : Valid_exp fexp }. +Context { monotone_exp : Monotone_exp fexp }. + +Notation format := (generic_format beta fexp). + +Theorem format_REM : + forall rnd : R -> Z, Valid_rnd rnd -> + forall x y : R, + ((Rabs (x/y) < /2)%R -> rnd (x/y)%R = 0%Z) -> + format x -> format y -> + format (x - IZR (rnd (x/y)%R) * y). +Proof with auto with typeclass_instances. +(* assume 0 < y *) +assert (H: forall rnd : R -> Z, Valid_rnd rnd -> + forall x y : R, + ((Rabs (x/y) < /2)%R -> rnd (x/y)%R = 0%Z) -> + format x -> format y -> (0 < y)%R -> + format (x - IZR (rnd (x/y)%R) * y)). +intros rnd valid_rnd x y Hrnd Fx Fy Hy. +case (Rle_or_lt 0 x); intros Hx. +apply format_REM_aux; try easy. +intros K. +apply Hrnd. +rewrite Rabs_pos_eq. +apply K. +apply Rlt_le, K. +replace (x - IZR (rnd (x/y)) * y)%R with + (- (-x - IZR (Zrnd_opp rnd (-x/y)) * y))%R. +apply generic_format_opp. +apply format_REM_aux; try easy... +now apply generic_format_opp. +apply Ropp_le_cancel; rewrite Ropp_0, Ropp_involutive; now left. +replace (- x / y)%R with (- (x/y))%R by (unfold Rdiv; ring). +intros K. +unfold Zrnd_opp. +rewrite Ropp_involutive, Hrnd. +easy. +rewrite Rabs_left. +apply K. +apply Ropp_lt_cancel. +now rewrite Ropp_0. +unfold Zrnd_opp. +replace (- (- x / y))%R with (x / y)%R by (unfold Rdiv; ring). +rewrite opp_IZR. +ring. +(* *) +intros rnd valid_rnd x y Hrnd Fx Fy. +case (Rle_or_lt 0 y); intros Hy. +destruct Hy as [Hy|Hy]. +now apply H. +now rewrite <- Hy, Rmult_0_r, Rminus_0_r. +replace (IZR (rnd (x/y)) * y)%R with + (IZR ((Zrnd_opp rnd) ((x / -y))) * -y)%R. +apply H; try easy... +replace (x / - y)%R with (- (x/y))%R. +intros K. +unfold Zrnd_opp. +rewrite Ropp_involutive, Hrnd. +easy. +now rewrite <- Rabs_Ropp. +field; now apply Rlt_not_eq. +now apply generic_format_opp. +apply Ropp_lt_cancel; now rewrite Ropp_0, Ropp_involutive. +unfold Zrnd_opp. +replace (- (x / - y))%R with (x/y)%R. +rewrite opp_IZR. +ring. +field; now apply Rlt_not_eq. +Qed. + +Theorem format_REM_ZR: + forall x y : R, + format x -> format y -> + format (x - IZR (Ztrunc (x/y)) * y). +Proof with auto with typeclass_instances. +intros x y Fx Fy. +apply format_REM; try easy... +intros K. +apply Z.abs_0_iff. +rewrite <- Ztrunc_abs. +rewrite Ztrunc_floor by apply Rabs_pos. +apply Zle_antisym. +replace 0%Z with (Zfloor (/2)). +apply Zfloor_le. +now apply Rlt_le. +apply Zfloor_imp. +simpl ; lra. +apply Zfloor_lub. +apply Rabs_pos. +Qed. + +Theorem format_REM_N : + forall choice, + forall x y : R, + format x -> format y -> + format (x - IZR (Znearest choice (x/y)) * y). +Proof with auto with typeclass_instances. +intros choice x y Fx Fy. +apply format_REM; try easy... +intros K. +apply Znearest_imp. +now rewrite Rminus_0_r. +Qed. + +End format_REM. diff --git a/flocq/Appli/Fappli_double_round.v b/flocq/Prop/Double_rounding.v index 82f61da3..055409bb 100644 --- a/flocq/Appli/Fappli_double_round.v +++ b/flocq/Prop/Double_rounding.v @@ -1,13 +1,28 @@ -(** * Conditions for innocuous double rounding. *) +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2014-2018 Sylvie Boldo +#<br /># +Copyright (C) 2014-2018 Guillaume Melquiond +#<br /># +Copyright (C) 2014-2018 Pierre Roux + +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 Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_generic_fmt. -Require Import Fcalc_ops. -Require Import Fcore_ulp. -Require Fcore_FLX Fcore_FLT Fcore_FTZ. +(** * Conditions for innocuous double rounding. *) Require Import Psatz. +Require Import Raux Defs Generic_fmt Operations Ulp FLX FLT FTZ. Open Scope R_scope. @@ -15,9 +30,9 @@ Section Double_round. Variable beta : radix. Notation bpow e := (bpow beta e). -Notation ln_beta x := (ln_beta beta x). +Notation mag x := (mag beta x). -Definition double_round_eq fexp1 fexp2 choice1 choice2 x := +Definition round_round_eq fexp1 fexp2 choice1 choice2 x := round beta fexp1 (Znearest choice1) (round beta fexp2 (Znearest choice2) x) = round beta fexp1 (Znearest choice1) x. @@ -26,22 +41,22 @@ Ltac bpow_simplify := (* bpow ex * bpow ey ~~> bpow (ex + ey) *) repeat match goal with - | |- context [(Fcore_Raux.bpow _ _ * Fcore_Raux.bpow _ _)] => + | |- context [(Raux.bpow _ _ * Raux.bpow _ _)] => rewrite <- bpow_plus - | |- context [(?X1 * Fcore_Raux.bpow _ _ * Fcore_Raux.bpow _ _)] => + | |- context [(?X1 * Raux.bpow _ _ * Raux.bpow _ _)] => rewrite (Rmult_assoc X1); rewrite <- bpow_plus - | |- context [(?X1 * (?X2 * Fcore_Raux.bpow _ _) * Fcore_Raux.bpow _ _)] => + | |- context [(?X1 * (?X2 * Raux.bpow _ _) * Raux.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 [(Fcore_Raux.bpow _ ?X)] => + | |- context [(Raux.bpow _ ?X)] => progress ring_simplify X end; (* bpow 0 ~~> 1 *) - change (Fcore_Raux.bpow _ 0) with 1; + change (Raux.bpow _ 0) with 1; repeat match goal with | |- context [(_ * 1)] => @@ -54,26 +69,26 @@ Definition midp (fexp : Z -> Z) (x : R) := Definition midp' (fexp : Z -> Z) (x : R) := round beta fexp Zceil x - / 2 * ulp beta fexp x. -Lemma double_round_lt_mid_further_place' : +Lemma round_round_lt_mid_further_place' : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z -> - x < bpow (ln_beta x) - / 2 * ulp beta fexp2 x -> + (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> + x < bpow (mag x) - / 2 * ulp beta fexp2 x -> x < midp fexp1 x - / 2 * ulp beta fexp2 x -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hx1. -unfold double_round_eq. +unfold round_round_eq. set (x' := round beta fexp1 Zfloor x). intro Hx2'. assert (Hx2 : x - round beta fexp1 Zfloor x < / 2 * (ulp beta fexp1 x - ulp beta fexp2 x)). { now apply (Rplus_lt_reg_r (round beta fexp1 Zfloor x)); ring_simplify. } set (x'' := round beta fexp2 (Znearest choice2) x). -assert (Hr1 : Rabs (x'' - x) <= / 2 * bpow (fexp2 (ln_beta x))). +assert (Hr1 : Rabs (x'' - x) <= / 2 * bpow (fexp2 (mag x))). apply Rle_trans with (/ 2 * ulp beta fexp2 x). now unfold x''; apply error_le_half_ulp... rewrite ulp_neq_0;[now right|now apply Rgt_not_eq]. @@ -82,12 +97,12 @@ assert (Pxx' : 0 <= x - x'). apply round_DN_pt. exact Vfexp1. } rewrite 2!ulp_neq_0 in Hx2; try (apply Rgt_not_eq; assumption). -assert (Hr2 : Rabs (x'' - x') < / 2 * bpow (fexp1 (ln_beta x))). +assert (Hr2 : Rabs (x'' - x') < / 2 * bpow (fexp1 (mag x))). { replace (x'' - x') with (x'' - x + (x - x')) by ring. apply (Rle_lt_trans _ _ _ (Rabs_triang _ _)). - replace (/ 2 * _) with (/ 2 * bpow (fexp2 (ln_beta x)) - + (/ 2 * (bpow (fexp1 (ln_beta x)) - - bpow (fexp2 (ln_beta x))))) by ring. + replace (/ 2 * _) with (/ 2 * bpow (fexp2 (mag x)) + + (/ 2 * (bpow (fexp1 (mag x)) + - bpow (fexp2 (mag x))))) by ring. apply Rplus_le_lt_compat. - exact Hr1. - now rewrite Rabs_right; [|now apply Rle_ge]; apply Hx2. } @@ -95,9 +110,9 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx'']. - (* x'' = 0 *) rewrite Zx'' in Hr1 |- *. rewrite round_0; [|now apply valid_rnd_N]. - unfold round, F2R, scaled_mantissa, canonic_exp; simpl. + unfold round, F2R, scaled_mantissa, cexp; simpl. rewrite (Znearest_imp _ _ 0); [now simpl; rewrite Rmult_0_l|]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; [|now apply Rle_ge; apply bpow_ge_0]. rewrite <- Rabs_mult; rewrite Rmult_minus_distr_r. @@ -109,25 +124,25 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx'']. apply bpow_lt. omega. - (* x'' <> 0 *) - assert (Lx'' : ln_beta x'' = ln_beta x :> Z). + assert (Lx'' : mag x'' = mag x :> Z). { apply Zle_antisym. - - apply ln_beta_le_bpow; [exact Nzx''|]. + - apply mag_le_bpow; [exact Nzx''|]. replace x'' with (x'' - x + x) by ring. apply (Rle_lt_trans _ _ _ (Rabs_triang _ _)). - replace (bpow _) with (/ 2 * bpow (fexp2 (ln_beta x)) - + (bpow (ln_beta x) - - / 2 * bpow (fexp2 (ln_beta x)))) by ring. + replace (bpow _) with (/ 2 * bpow (fexp2 (mag x)) + + (bpow (mag x) + - / 2 * bpow (fexp2 (mag x)))) by ring. apply Rplus_le_lt_compat; [exact Hr1|]. rewrite ulp_neq_0 in Hx1;[idtac| now apply Rgt_not_eq]. now rewrite Rabs_right; [|apply Rle_ge; apply Rlt_le]. - unfold x'' in Nzx'' |- *. - now apply ln_beta_round_ge; [|apply valid_rnd_N|]. } - unfold round, F2R, scaled_mantissa, canonic_exp; simpl. + now apply mag_round_ge; [|apply valid_rnd_N|]. } + unfold round, F2R, scaled_mantissa, cexp; simpl. rewrite Lx''. rewrite (Znearest_imp _ _ (Zfloor (scaled_mantissa beta fexp1 x))). + rewrite (Znearest_imp _ _ (Zfloor (scaled_mantissa beta fexp1 x))); [reflexivity|]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; [|now apply Rle_ge; apply bpow_ge_0]. rewrite <- Rabs_mult. @@ -137,9 +152,9 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx'']. rewrite Rabs_right; [|now apply Rle_ge]. apply (Rlt_le_trans _ _ _ Hx2). apply Rmult_le_compat_l; [lra|]. - generalize (bpow_ge_0 beta (fexp2 (ln_beta x))). - unfold ulp, canonic_exp; lra. - + apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + generalize (bpow_ge_0 beta (fexp2 (mag x))). + unfold ulp, cexp; lra. + + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; [|now apply Rle_ge; apply bpow_ge_0]. rewrite <- Rabs_mult. @@ -148,16 +163,16 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx'']. now bpow_simplify. Qed. -Lemma double_round_lt_mid_further_place : +Lemma round_round_lt_mid_further_place : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z -> - (fexp1 (ln_beta x) <= ln_beta x)%Z -> + (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> + (fexp1 (mag x) <= mag x)%Z -> x < midp fexp1 x - / 2 * ulp beta fexp2 x -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hf1. intro Hx2'. @@ -165,15 +180,15 @@ assert (Hx2 : x - round beta fexp1 Zfloor x < / 2 * (ulp beta fexp1 x - ulp beta fexp2 x)). { now apply (Rplus_lt_reg_r (round beta fexp1 Zfloor x)); ring_simplify. } revert Hx2. -unfold double_round_eq. +unfold round_round_eq. set (x' := round beta fexp1 Zfloor x). intro Hx2. assert (Pxx' : 0 <= x - x'). { apply Rle_0_minus. apply round_DN_pt. exact Vfexp1. } -assert (x < bpow (ln_beta x) - / 2 * bpow (fexp2 (ln_beta x))); - [|apply double_round_lt_mid_further_place'; try assumption]... +assert (x < bpow (mag x) - / 2 * bpow (fexp2 (mag x))); + [|apply round_round_lt_mid_further_place'; try assumption]... 2: rewrite ulp_neq_0;[assumption|now apply Rgt_not_eq]. destruct (Req_dec x' 0) as [Zx'|Nzx']. - (* x' = 0 *) @@ -182,10 +197,10 @@ destruct (Req_dec x' 0) as [Zx'|Nzx']. rewrite Rmult_minus_distr_l. rewrite 2!ulp_neq_0;[idtac|now apply Rgt_not_eq|now apply Rgt_not_eq]. apply Rplus_le_compat_r. - apply (Rmult_le_reg_r (bpow (- ln_beta x))); [now apply bpow_gt_0|]. - unfold ulp, canonic_exp; bpow_simplify. + apply (Rmult_le_reg_r (bpow (- mag x))); [now apply bpow_gt_0|]. + unfold ulp, cexp; bpow_simplify. apply Rmult_le_reg_l with (1 := Rlt_0_2). - replace (2 * (/ 2 * _)) with (bpow (fexp1 (ln_beta x) - ln_beta x)) by field. + replace (2 * (/ 2 * _)) with (bpow (fexp1 (mag x) - mag x)) by field. apply Rle_trans with 1; [|lra]. change 1 with (bpow 0); apply bpow_le. omega. @@ -193,16 +208,16 @@ destruct (Req_dec x' 0) as [Zx'|Nzx']. assert (Px' : 0 < x'). { assert (0 <= x'); [|lra]. unfold x'. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_0_l. - unfold round, F2R, canonic_exp; simpl; bpow_simplify. - change 0 with (Z2R 0); apply Z2R_le. + unfold round, F2R, cexp; simpl; bpow_simplify. + apply IZR_le. apply Zfloor_lub. rewrite <- (Rabs_right x); [|now apply Rle_ge; apply Rlt_le]. rewrite scaled_mantissa_abs. apply Rabs_pos. } - assert (Hx' : x' <= bpow (ln_beta x) - ulp beta fexp1 x). + assert (Hx' : x' <= bpow (mag x) - ulp beta fexp1 x). { apply (Rplus_le_reg_r (ulp beta fexp1 x)); ring_simplify. rewrite <- ulp_DN. - change (round _ _ _ _) with x'. @@ -213,10 +228,10 @@ destruct (Req_dec x' 0) as [Zx'|Nzx']. + apply Rle_lt_trans with x. * now apply round_DN_pt. * rewrite <- (Rabs_right x) at 1; [|now apply Rle_ge; apply Rlt_le]. - apply bpow_ln_beta_gt. + apply bpow_mag_gt. - exact Vfexp1. - - exact Px'. } - fold (canonic_exp beta fexp2 x); fold (ulp beta fexp2 x). + - now apply Rlt_le. } + fold (cexp beta fexp2 x); fold (ulp beta fexp2 x). assert (/ 2 * ulp beta fexp1 x <= ulp beta fexp1 x). rewrite <- (Rmult_1_l (ulp _ _ _)) at 2. apply Rmult_le_compat_r; [|lra]. @@ -227,39 +242,39 @@ destruct (Req_dec x' 0) as [Zx'|Nzx']. lra. Qed. -Lemma double_round_lt_mid_same_place : +Lemma round_round_lt_mid_same_place : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (fexp2 (ln_beta x) = fexp1 (ln_beta x))%Z -> + (fexp2 (mag x) = fexp1 (mag x))%Z -> x < midp fexp1 x -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 choice1 choice2 x Px Hf2f1. intro Hx'. assert (Hx : x - round beta fexp1 Zfloor x < / 2 * ulp beta fexp1 x). { now apply (Rplus_lt_reg_r (round beta fexp1 Zfloor x)); ring_simplify. } revert Hx. -unfold double_round_eq. +unfold round_round_eq. set (x' := round beta fexp1 Zfloor x). intro Hx. assert (Pxx' : 0 <= x - x'). { apply Rle_0_minus. apply round_DN_pt. exact Vfexp1. } -assert (H : Rabs (x * bpow (- fexp1 (ln_beta x)) - - Z2R (Zfloor (x * bpow (- fexp1 (ln_beta x))))) < / 2). -{ apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. - unfold scaled_mantissa, canonic_exp in Hx. +assert (H : Rabs (x * bpow (- fexp1 (mag x)) - + IZR (Zfloor (x * bpow (- fexp1 (mag x))))) < / 2). +{ apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. + unfold scaled_mantissa, cexp in Hx. rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; [|now apply Rle_ge; apply bpow_ge_0]. rewrite <- Rabs_mult. rewrite Rmult_minus_distr_r. bpow_simplify. apply Rabs_lt. - change (Z2R _ * _) with x'. + change (IZR _ * _) with x'. split. - apply Rlt_le_trans with 0; [|exact Pxx']. rewrite <- Ropp_0. @@ -269,55 +284,54 @@ assert (H : Rabs (x * bpow (- fexp1 (ln_beta x)) - apply bpow_gt_0. - rewrite ulp_neq_0 in Hx;try apply Rgt_not_eq; assumption. } unfold round at 2. -unfold F2R, scaled_mantissa, canonic_exp; simpl. +unfold F2R, scaled_mantissa, cexp; simpl. rewrite Hf2f1. -rewrite (Znearest_imp _ _ (Zfloor (scaled_mantissa beta fexp1 x))). -- rewrite round_generic. - + unfold round, F2R, scaled_mantissa, canonic_exp; simpl. - now rewrite (Znearest_imp _ _ (Zfloor (x * bpow (- fexp1 (ln_beta x))))). +rewrite (Znearest_imp _ _ (Zfloor (scaled_mantissa beta fexp1 x)) H). +rewrite round_generic. + + unfold round, F2R, scaled_mantissa, cexp; simpl. + now rewrite (Znearest_imp _ _ (Zfloor (x * bpow (- fexp1 (mag x))))). + now apply valid_rnd_N. - + fold (canonic_exp beta fexp1 x). - change (Z2R _ * bpow _) with (round beta fexp1 Zfloor x). + + fold (cexp beta fexp1 x). + change (IZR _ * bpow _) with (round beta fexp1 Zfloor x). apply generic_format_round. exact Vfexp1. now apply valid_rnd_DN. -- now unfold scaled_mantissa, canonic_exp. Qed. -Lemma double_round_lt_mid : +Lemma round_round_lt_mid : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (fexp2 (ln_beta x) <= fexp1 (ln_beta x))%Z -> - (fexp1 (ln_beta x) <= ln_beta x)%Z -> + (fexp2 (mag x) <= fexp1 (mag x))%Z -> + (fexp1 (mag x) <= mag x)%Z -> x < midp fexp1 x -> - ((fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z -> + ((fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> x < midp fexp1 x - / 2 * ulp beta fexp2 x) -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hf1 Hx Hx'. -destruct (Zle_or_lt (fexp1 (ln_beta x)) (fexp2 (ln_beta x))) as [Hf2'|Hf2']. -- (* fexp1 (ln_beta x) <= fexp2 (ln_beta x) *) - assert (Hf2'' : (fexp2 (ln_beta x) = fexp1 (ln_beta x) :> Z)%Z); [omega|]. - now apply double_round_lt_mid_same_place. -- (* fexp2 (ln_beta x) < fexp1 (ln_beta x) *) - assert (Hf2'' : (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z); [omega|]. +destruct (Zle_or_lt (fexp1 (mag x)) (fexp2 (mag x))) as [Hf2'|Hf2']. +- (* fexp1 (mag x) <= fexp2 (mag x) *) + assert (Hf2'' : (fexp2 (mag x) = fexp1 (mag x) :> Z)%Z); [omega|]. + now apply round_round_lt_mid_same_place. +- (* fexp2 (mag x) < fexp1 (mag x) *) + assert (Hf2'' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z); [omega|]. generalize (Hx' Hf2''); intro Hx''. - now apply double_round_lt_mid_further_place. + now apply round_round_lt_mid_further_place. Qed. -Lemma double_round_gt_mid_further_place' : +Lemma round_round_gt_mid_further_place' : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z -> - round beta fexp2 (Znearest choice2) x < bpow (ln_beta x) -> + (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> + round beta fexp2 (Znearest choice2) x < bpow (mag x) -> midp' fexp1 x + / 2 * ulp beta fexp2 x < x -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1. intros Hx1 Hx2'. @@ -327,11 +341,11 @@ assert (Hx2 : round beta fexp1 Zceil x - x + / 2 * ulp beta fexp2 x)); ring_simplify. now unfold midp' in Hx2'. } revert Hx1 Hx2. -unfold double_round_eq. +unfold round_round_eq. set (x' := round beta fexp1 Zceil x). set (x'' := round beta fexp2 (Znearest choice2) x). intros Hx1 Hx2. -assert (Hr1 : Rabs (x'' - x) <= / 2 * bpow (fexp2 (ln_beta x))). +assert (Hr1 : Rabs (x'' - x) <= / 2 * bpow (fexp2 (mag x))). apply Rle_trans with (/2* ulp beta fexp2 x). now unfold x''; apply error_le_half_ulp... rewrite ulp_neq_0;[now right|now apply Rgt_not_eq]. @@ -339,12 +353,12 @@ assert (Px'x : 0 <= x' - x). { apply Rle_0_minus. apply round_UP_pt. exact Vfexp1. } -assert (Hr2 : Rabs (x'' - x') < / 2 * bpow (fexp1 (ln_beta x))). +assert (Hr2 : Rabs (x'' - x') < / 2 * bpow (fexp1 (mag x))). { replace (x'' - x') with (x'' - x + (x - x')) by ring. apply (Rle_lt_trans _ _ _ (Rabs_triang _ _)). - replace (/ 2 * _) with (/ 2 * bpow (fexp2 (ln_beta x)) - + (/ 2 * (bpow (fexp1 (ln_beta x)) - - bpow (fexp2 (ln_beta x))))) by ring. + replace (/ 2 * _) with (/ 2 * bpow (fexp2 (mag x)) + + (/ 2 * (bpow (fexp1 (mag x)) + - bpow (fexp2 (mag x))))) by ring. apply Rplus_le_lt_compat. - exact Hr1. - rewrite Rabs_minus_sym. @@ -354,9 +368,9 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx'']. - (* x'' = 0 *) rewrite Zx'' in Hr1 |- *. rewrite round_0; [|now apply valid_rnd_N]. - unfold round, F2R, scaled_mantissa, canonic_exp; simpl. + unfold round, F2R, scaled_mantissa, cexp; simpl. rewrite (Znearest_imp _ _ 0); [now simpl; rewrite Rmult_0_l|]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; [|now apply Rle_ge; apply bpow_ge_0]. rewrite <- Rabs_mult; rewrite Rmult_minus_distr_r. @@ -368,9 +382,9 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx'']. apply bpow_lt. omega. - (* x'' <> 0 *) - assert (Lx'' : ln_beta x'' = ln_beta x :> Z). + assert (Lx'' : mag x'' = mag x :> Z). { apply Zle_antisym. - - apply ln_beta_le_bpow; [exact Nzx''|]. + - apply mag_le_bpow; [exact Nzx''|]. rewrite Rabs_right; [exact Hx1|apply Rle_ge]. apply round_ge_generic. + exact Vfexp2. @@ -378,13 +392,13 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx'']. + apply generic_format_0. + now apply Rlt_le. - unfold x'' in Nzx'' |- *. - now apply ln_beta_round_ge; [|apply valid_rnd_N|]. } - unfold round, F2R, scaled_mantissa, canonic_exp; simpl. + now apply mag_round_ge; [|apply valid_rnd_N|]. } + unfold round, F2R, scaled_mantissa, cexp; simpl. rewrite Lx''. rewrite (Znearest_imp _ _ (Zceil (scaled_mantissa beta fexp1 x))). + rewrite (Znearest_imp _ _ (Zceil (scaled_mantissa beta fexp1 x))); [reflexivity|]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; [|now apply Rle_ge; apply bpow_ge_0]. rewrite <- Rabs_mult. @@ -395,10 +409,10 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx'']. rewrite Rabs_right; [|now apply Rle_ge]. apply (Rlt_le_trans _ _ _ Hx2). apply Rmult_le_compat_l; [lra|]. - generalize (bpow_ge_0 beta (fexp2 (ln_beta x))). + generalize (bpow_ge_0 beta (fexp2 (mag x))). rewrite 2!ulp_neq_0; try (apply Rgt_not_eq; assumption). - unfold canonic_exp; lra. - + apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + unfold cexp; lra. + + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; [|now apply Rle_ge; apply bpow_ge_0]. rewrite <- Rabs_mult. @@ -407,16 +421,16 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx'']. now bpow_simplify. Qed. -Lemma double_round_gt_mid_further_place : +Lemma round_round_gt_mid_further_place : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z -> - (fexp1 (ln_beta x) <= ln_beta x)%Z -> + (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> + (fexp1 (mag x) <= mag x)%Z -> midp' fexp1 x + / 2 * ulp beta fexp2 x < x -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hf1 Hx2'. assert (Hx2 : round beta fexp1 Zceil x - x @@ -425,15 +439,15 @@ assert (Hx2 : round beta fexp1 Zceil x - x + / 2 * ulp beta fexp2 x)); ring_simplify. now unfold midp' in Hx2'. } revert Hx2. -unfold double_round_eq. +unfold round_round_eq. set (x' := round beta fexp1 Zfloor x). intro Hx2. set (x'' := round beta fexp2 (Znearest choice2) x). -destruct (Rlt_or_le x'' (bpow (ln_beta x))) as [Hx''|Hx'']; - [now apply double_round_gt_mid_further_place'|]. -(* bpow (ln_beta x) <= x'' *) -assert (Hx''pow : x'' = bpow (ln_beta x)). -{ assert (H'x'' : x'' < bpow (ln_beta x) + / 2 * ulp beta fexp2 x). +destruct (Rlt_or_le x'' (bpow (mag x))) as [Hx''|Hx'']; + [now apply round_round_gt_mid_further_place'|]. +(* bpow (mag x) <= x'' *) +assert (Hx''pow : x'' = bpow (mag x)). +{ assert (H'x'' : x'' < bpow (mag x) + / 2 * ulp beta fexp2 x). { apply Rle_lt_trans with (x + / 2 * ulp beta fexp2 x). - apply (Rplus_le_reg_r (- x)); ring_simplify. apply Rabs_le_inv. @@ -441,22 +455,22 @@ assert (Hx''pow : x'' = bpow (ln_beta x)). exact Vfexp2. - apply Rplus_lt_compat_r. rewrite <- Rabs_right at 1; [|now apply Rle_ge; apply Rlt_le]. - apply bpow_ln_beta_gt. } + apply bpow_mag_gt. } apply Rle_antisym; [|exact Hx'']. - unfold x'', round, F2R, scaled_mantissa, canonic_exp; simpl. - apply (Rmult_le_reg_r (bpow (- fexp2 (ln_beta x)))); [now apply bpow_gt_0|]. + unfold x'', round, F2R, scaled_mantissa, cexp; simpl. + apply (Rmult_le_reg_r (bpow (- fexp2 (mag x)))); [now apply bpow_gt_0|]. bpow_simplify. - rewrite <- (Z2R_Zpower _ (_ - _)); [|omega]. - apply Z2R_le. + rewrite <- (IZR_Zpower _ (_ - _)); [|omega]. + apply IZR_le. apply Zlt_succ_le; unfold Z.succ. - apply lt_Z2R. - rewrite Z2R_plus; rewrite Z2R_Zpower; [|omega]. - apply (Rmult_lt_reg_r (bpow (fexp2 (ln_beta x)))); [now apply bpow_gt_0|]. + apply lt_IZR. + rewrite plus_IZR; rewrite IZR_Zpower; [|omega]. + apply (Rmult_lt_reg_r (bpow (fexp2 (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_plus_distr_r; rewrite Rmult_1_l. bpow_simplify. apply (Rlt_le_trans _ _ _ H'x''). apply Rplus_le_compat_l. - rewrite <- (Rmult_1_l (Fcore_Raux.bpow _ _)). + rewrite <- (Rmult_1_l (Raux.bpow _ _)). rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq]. apply Rmult_le_compat_r; [now apply bpow_ge_0|]. lra. } @@ -467,26 +481,26 @@ assert (Hr : Rabs (x - x'') < / 2 * ulp beta fexp1 x). exact Vfexp2. - apply Rmult_lt_compat_l; [lra|]. rewrite 2!ulp_neq_0; try now apply Rgt_not_eq. - unfold canonic_exp; apply bpow_lt. + unfold cexp; apply bpow_lt. omega. } -unfold round, F2R, scaled_mantissa, canonic_exp; simpl. -assert (Hf : (0 <= ln_beta x - fexp1 (ln_beta x''))%Z). +unfold round, F2R, scaled_mantissa, cexp; simpl. +assert (Hf : (0 <= mag x - fexp1 (mag x''))%Z). { rewrite Hx''pow. - rewrite ln_beta_bpow. - assert (fexp1 (ln_beta x + 1) <= ln_beta x)%Z; [|omega]. - destruct (Zle_or_lt (ln_beta x) (fexp1 (ln_beta x))) as [Hle|Hlt]; + rewrite mag_bpow. + assert (fexp1 (mag x + 1) <= mag x)%Z; [|omega]. + destruct (Zle_or_lt (mag x) (fexp1 (mag x))) as [Hle|Hlt]; [|now apply Vfexp1]. - assert (H : (ln_beta x = fexp1 (ln_beta x) :> Z)%Z); + assert (H : (mag x = fexp1 (mag x) :> Z)%Z); [now apply Zle_antisym|]. rewrite H. now apply Vfexp1. } -rewrite (Znearest_imp _ _ (beta ^ (ln_beta x - fexp1 (ln_beta x'')))%Z). -- rewrite (Znearest_imp _ _ (beta ^ (ln_beta x - fexp1 (ln_beta x)))%Z). - + rewrite Z2R_Zpower; [|exact Hf]. - rewrite Z2R_Zpower; [|omega]. +rewrite (Znearest_imp _ _ (beta ^ (mag x - fexp1 (mag x'')))%Z). +- rewrite (Znearest_imp _ _ (beta ^ (mag x - fexp1 (mag x)))%Z). + + rewrite IZR_Zpower; [|exact Hf]. + rewrite IZR_Zpower; [|omega]. now bpow_simplify. - + rewrite Z2R_Zpower; [|omega]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + + rewrite IZR_Zpower; [|omega]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; [|now apply Rle_ge; apply bpow_ge_0]. rewrite <- Rabs_mult. @@ -494,8 +508,8 @@ rewrite (Znearest_imp _ _ (beta ^ (ln_beta x - fexp1 (ln_beta x'')))%Z). bpow_simplify. rewrite ulp_neq_0 in Hr;[idtac|now apply Rgt_not_eq]. rewrite <- Hx''pow; exact Hr. -- rewrite Z2R_Zpower; [|exact Hf]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x'')))); [now apply bpow_gt_0|]. +- rewrite IZR_Zpower; [|exact Hf]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x'')))); [now apply bpow_gt_0|]. rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; [|now apply Rle_ge; apply bpow_ge_0]. rewrite <- Rabs_mult. @@ -507,24 +521,24 @@ rewrite (Znearest_imp _ _ (beta ^ (ln_beta x - fexp1 (ln_beta x'')))%Z). apply Rmult_lt_compat_l; [lra|apply bpow_gt_0]. Qed. -Lemma double_round_gt_mid_same_place : +Lemma round_round_gt_mid_same_place : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (fexp2 (ln_beta x) = fexp1 (ln_beta x))%Z -> + (fexp2 (mag x) = fexp1 (mag x))%Z -> midp' fexp1 x < x -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 choice1 choice2 x Px Hf2f1 Hx'. assert (Hx : round beta fexp1 Zceil x - x < / 2 * ulp beta fexp1 x). { apply (Rplus_lt_reg_r (- / 2 * ulp beta fexp1 x + x)); ring_simplify. now unfold midp' in Hx'. } -assert (H : Rabs (Z2R (Zceil (x * bpow (- fexp1 (ln_beta x)))) - - x * bpow (- fexp1 (ln_beta x))) < / 2). -{ apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. - unfold scaled_mantissa, canonic_exp in Hx. +assert (H : Rabs (IZR (Zceil (x * bpow (- fexp1 (mag x)))) + - x * bpow (- fexp1 (mag x))) < / 2). +{ apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. + unfold scaled_mantissa, cexp in Hx. rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; [|now apply Rle_ge; apply bpow_ge_0]. rewrite <- Rabs_mult. @@ -541,67 +555,67 @@ assert (H : Rabs (Z2R (Zceil (x * bpow (- fexp1 (ln_beta x)))) apply round_UP_pt. exact Vfexp1. - rewrite ulp_neq_0 in Hx;[exact Hx|now apply Rgt_not_eq]. } -unfold double_round_eq, round at 2. -unfold F2R, scaled_mantissa, canonic_exp; simpl. +unfold round_round_eq, round at 2. +unfold F2R, scaled_mantissa, cexp; simpl. rewrite Hf2f1. rewrite (Znearest_imp _ _ (Zceil (scaled_mantissa beta fexp1 x))). - rewrite round_generic. - + unfold round, F2R, scaled_mantissa, canonic_exp; simpl. - now rewrite (Znearest_imp _ _ (Zceil (x * bpow (- fexp1 (ln_beta x))))); + + unfold round, F2R, scaled_mantissa, cexp; simpl. + now rewrite (Znearest_imp _ _ (Zceil (x * bpow (- fexp1 (mag x))))); [|rewrite Rabs_minus_sym]. + now apply valid_rnd_N. - + fold (canonic_exp beta fexp1 x). - change (Z2R _ * bpow _) with (round beta fexp1 Zceil x). + + fold (cexp beta fexp1 x). + change (IZR _ * bpow _) with (round beta fexp1 Zceil x). apply generic_format_round. exact Vfexp1. now apply valid_rnd_UP. - now rewrite Rabs_minus_sym. Qed. -Lemma double_round_gt_mid : +Lemma round_round_gt_mid : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (fexp2 (ln_beta x) <= fexp1 (ln_beta x))%Z -> - (fexp1 (ln_beta x) <= ln_beta x)%Z -> + (fexp2 (mag x) <= fexp1 (mag x))%Z -> + (fexp1 (mag x) <= mag x)%Z -> midp' fexp1 x < x -> - ((fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z -> + ((fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> midp' fexp1 x + / 2 * ulp beta fexp2 x < x) -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hf1 Hx Hx'. -destruct (Zle_or_lt (fexp1 (ln_beta x)) (fexp2 (ln_beta x))) as [Hf2'|Hf2']. -- (* fexp1 (ln_beta x) <= fexp2 (ln_beta x) *) - assert (Hf2'' : (fexp2 (ln_beta x) = fexp1 (ln_beta x) :> Z)%Z); [omega|]. - now apply double_round_gt_mid_same_place. -- (* fexp2 (ln_beta x) < fexp1 (ln_beta x) *) - assert (Hf2'' : (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z); [omega|]. +destruct (Zle_or_lt (fexp1 (mag x)) (fexp2 (mag x))) as [Hf2'|Hf2']. +- (* fexp1 (mag x) <= fexp2 (mag x) *) + assert (Hf2'' : (fexp2 (mag x) = fexp1 (mag x) :> Z)%Z); [omega|]. + now apply round_round_gt_mid_same_place. +- (* fexp2 (mag x) < fexp1 (mag x) *) + assert (Hf2'' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z); [omega|]. generalize (Hx' Hf2''); intro Hx''. - now apply double_round_gt_mid_further_place. + now apply round_round_gt_mid_further_place. Qed. Section Double_round_mult. -Lemma ln_beta_mult_disj : +Lemma mag_mult_disj : forall x y, x <> 0 -> y <> 0 -> - ((ln_beta (x * y) = (ln_beta x + ln_beta y - 1)%Z :> Z) - \/ (ln_beta (x * y) = (ln_beta x + ln_beta y)%Z :> Z)). + ((mag (x * y) = (mag x + mag y - 1)%Z :> Z) + \/ (mag (x * y) = (mag x + mag y)%Z :> Z)). Proof. intros x y Zx Zy. -destruct (ln_beta_mult beta x y Zx Zy). +destruct (mag_mult beta x y Zx Zy). omega. Qed. -Definition double_round_mult_hyp fexp1 fexp2 := +Definition round_round_mult_hyp fexp1 fexp2 := (forall ex ey, (fexp2 (ex + ey) <= fexp1 ex + fexp1 ey)%Z) /\ (forall ex ey, (fexp2 (ex + ey - 1) <= fexp1 ex + fexp1 ey)%Z). -Lemma double_round_mult_aux : +Lemma round_round_mult_aux : forall (fexp1 fexp2 : Z -> Z), - double_round_mult_hyp fexp1 fexp2 -> + round_round_mult_hyp fexp1 fexp2 -> forall x y, generic_format beta fexp1 x -> generic_format beta fexp1 y -> generic_format beta fexp2 (x * y). @@ -621,31 +635,31 @@ destruct (Req_dec x 0) as [Zx|Zx]. + (* y <> 0 *) revert Fx Fy. unfold generic_format. - unfold canonic_exp. + unfold cexp. set (mx := Ztrunc (scaled_mantissa beta fexp1 x)). set (my := Ztrunc (scaled_mantissa beta fexp1 y)). unfold F2R; simpl. intros Fx Fy. - set (fxy := Float beta (mx * my) (fexp1 (ln_beta x) + fexp1 (ln_beta y))). + set (fxy := Float beta (mx * my) (fexp1 (mag x) + fexp1 (mag y))). assert (Hxy : x * y = F2R fxy). { unfold fxy, F2R; simpl. rewrite bpow_plus. - rewrite Z2R_mult. + rewrite mult_IZR. rewrite Fx, Fy at 1. ring. } apply generic_format_F2R' with (f := fxy); [now rewrite Hxy|]. intros _. - unfold canonic_exp, fxy; simpl. + unfold cexp, fxy; simpl. destruct Hfexp as (Hfexp1, Hfexp2). - now destruct (ln_beta_mult_disj x y Zx Zy) as [Lxy|Lxy]; rewrite Lxy. + now destruct (mag_mult_disj x y Zx Zy) as [Lxy|Lxy]; rewrite Lxy. Qed. Variable rnd : R -> Z. Context { valid_rnd : Valid_rnd rnd }. -Theorem double_round_mult : +Theorem round_round_mult : forall (fexp1 fexp2 : Z -> Z), - double_round_mult_hyp fexp1 fexp2 -> + round_round_mult_hyp fexp1 fexp2 -> forall x y, generic_format beta fexp1 x -> generic_format beta fexp1 y -> round beta fexp1 rnd (round beta fexp2 rnd (x * y)) @@ -654,21 +668,19 @@ Proof. intros fexp1 fexp2 Hfexp x y Fx Fy. assert (Hxy : round beta fexp2 rnd (x * y) = x * y). { apply round_generic; [assumption|]. - now apply (double_round_mult_aux fexp1 fexp2). } + now apply (round_round_mult_aux fexp1 fexp2). } now rewrite Hxy at 1. Qed. Section Double_round_mult_FLX. -Import Fcore_FLX. - Variable prec : Z. Variable prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Theorem double_round_mult_FLX : +Theorem round_round_mult_FLX : (2 * prec <= prec')%Z -> forall x y, FLX_format beta prec x -> FLX_format beta prec y -> @@ -676,9 +688,9 @@ Theorem double_round_mult_FLX : = round beta (FLX_exp prec) rnd (x * y). Proof. intros Hprec x y Fx Fy. -apply double_round_mult; +apply round_round_mult; [|now apply generic_format_FLX|now apply generic_format_FLX]. -unfold double_round_mult_hyp; split; intros ex ey; unfold FLX_exp; +unfold round_round_mult_hyp; split; intros ex ey; unfold FLX_exp; omega. Qed. @@ -686,16 +698,13 @@ End Double_round_mult_FLX. Section Double_round_mult_FLT. -Import Fcore_FLX. -Import Fcore_FLT. - Variable emin prec : Z. Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Theorem double_round_mult_FLT : +Theorem round_round_mult_FLT : (emin' <= 2 * emin)%Z -> (2 * prec <= prec')%Z -> forall x y, FLT_format beta emin prec x -> FLT_format beta emin prec y -> @@ -704,9 +713,9 @@ Theorem double_round_mult_FLT : = round beta (FLT_exp emin prec) rnd (x * y). Proof. intros Hemin Hprec x y Fx Fy. -apply double_round_mult; +apply round_round_mult; [|now apply generic_format_FLT|now apply generic_format_FLT]. -unfold double_round_mult_hyp; split; intros ex ey; +unfold round_round_mult_hyp; split; intros ex ey; unfold FLT_exp; generalize (Zmax_spec (ex + ey - prec') emin'); generalize (Zmax_spec (ex + ey - 1 - prec') emin'); @@ -719,16 +728,13 @@ End Double_round_mult_FLT. Section Double_round_mult_FTZ. -Import Fcore_FLX. -Import Fcore_FTZ. - Variable emin prec : Z. Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Theorem double_round_mult_FTZ : +Theorem round_round_mult_FTZ : (emin' + prec' <= 2 * emin + prec)%Z -> (2 * prec <= prec')%Z -> forall x y, @@ -738,9 +744,9 @@ Theorem double_round_mult_FTZ : = round beta (FTZ_exp emin prec) rnd (x * y). Proof. intros Hemin Hprec x y Fx Fy. -apply double_round_mult; +apply round_round_mult; [|now apply generic_format_FTZ|now apply generic_format_FTZ]. -unfold double_round_mult_hyp; split; intros ex ey; +unfold round_round_mult_hyp; split; intros ex ey; unfold FTZ_exp; unfold Prec_gt_0 in *; destruct (Z.ltb_spec (ex + ey - prec') emin'); @@ -756,83 +762,77 @@ End Double_round_mult. Section Double_round_plus. -Lemma ln_beta_plus_disj : +Lemma mag_plus_disj : forall x y, 0 < y -> y <= x -> - ((ln_beta (x + y) = ln_beta x :> Z) - \/ (ln_beta (x + y) = (ln_beta x + 1)%Z :> Z)). + ((mag (x + y) = mag x :> Z) + \/ (mag (x + y) = (mag x + 1)%Z :> Z)). Proof. intros x y Py Hxy. -destruct (ln_beta_plus beta x y Py Hxy). +destruct (mag_plus beta x y Py Hxy). omega. Qed. -Lemma ln_beta_plus_separated : +Lemma mag_plus_separated : forall fexp : Z -> Z, forall x y, 0 < x -> 0 <= y -> generic_format beta fexp x -> - (ln_beta y <= fexp (ln_beta x))%Z -> - (ln_beta (x + y) = ln_beta x :> Z). + (mag y <= fexp (mag x))%Z -> + (mag (x + y) = mag x :> Z). Proof. intros fexp x y Px Nny Fx Hsep. -destruct (Req_dec y 0) as [Zy|Nzy]. -- (* y = 0 *) - now rewrite Zy; rewrite Rplus_0_r. -- (* y <> 0 *) - apply (ln_beta_plus_eps beta fexp); [assumption|assumption|]. - split; [assumption|]. - rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq]. - unfold canonic_exp. - destruct (ln_beta y) as (ey, Hey); simpl in *. - apply Rlt_le_trans with (bpow ey). - + now rewrite <- (Rabs_right y); [apply Hey|apply Rle_ge]. - + now apply bpow_le. +apply mag_plus_eps with (1 := Px) (2 := Fx). +apply (conj Nny). +rewrite <- Rabs_pos_eq with (1 := Nny). +apply Rlt_le_trans with (1 := bpow_mag_gt beta _). +rewrite ulp_neq_0 by now apply Rgt_not_eq. +now apply bpow_le. Qed. -Lemma ln_beta_minus_disj : +Lemma mag_minus_disj : forall x y, 0 < x -> 0 < y -> - (ln_beta y <= ln_beta x - 2)%Z -> - ((ln_beta (x - y) = ln_beta x :> Z) - \/ (ln_beta (x - y) = (ln_beta x - 1)%Z :> Z)). + (mag y <= mag x - 2)%Z -> + ((mag (x - y) = mag x :> Z) + \/ (mag (x - y) = (mag x - 1)%Z :> Z)). Proof. intros x y Px Py Hln. -assert (Hxy : y < x); [now apply (ln_beta_lt_pos beta); [ |omega]|]. -generalize (ln_beta_minus beta x y Py Hxy); intro Hln2. -generalize (ln_beta_minus_lb beta x y Px Py Hln); intro Hln3. +assert (Hxy : y < x); [now apply (lt_mag beta); [ |omega]|]. +generalize (mag_minus beta x y Py Hxy); intro Hln2. +generalize (mag_minus_lb beta x y Px Py Hln); intro Hln3. omega. Qed. -Lemma ln_beta_minus_separated : +Lemma mag_minus_separated : forall fexp : Z -> Z, Valid_exp fexp -> forall x y, 0 < x -> 0 < y -> y < x -> - bpow (ln_beta x - 1) < x -> - generic_format beta fexp x -> (ln_beta y <= fexp (ln_beta x))%Z -> - (ln_beta (x - y) = ln_beta x :> Z). + bpow (mag x - 1) < x -> + generic_format beta fexp x -> (mag y <= fexp (mag x))%Z -> + (mag (x - y) = mag x :> Z). Proof. intros fexp Vfexp x y Px Py Yltx Xgtpow Fx Ly. -apply ln_beta_unique. +apply mag_unique. split. - apply Rabs_ge; right. - assert (Hy : y < ulp beta fexp (bpow (ln_beta x - 1))). + assert (Hy : y < ulp beta fexp (bpow (mag x - 1))). { rewrite ulp_bpow. - replace (_ + _)%Z with (ln_beta x : Z) by ring. + replace (_ + _)%Z with (mag x : Z) by ring. rewrite <- (Rabs_right y); [|now apply Rle_ge; apply Rlt_le]. - apply Rlt_le_trans with (bpow (ln_beta y)). - - apply bpow_ln_beta_gt. + apply Rlt_le_trans with (bpow (mag y)). + - apply bpow_mag_gt. - now apply bpow_le. } apply (Rplus_le_reg_r y); ring_simplify. - apply Rle_trans with (bpow (ln_beta x - 1) - + ulp beta fexp (bpow (ln_beta x - 1))). + apply Rle_trans with (bpow (mag x - 1) + + ulp beta fexp (bpow (mag x - 1))). + now apply Rplus_le_compat_l; apply Rlt_le. + rewrite <- succ_eq_pos;[idtac|apply bpow_ge_0]. apply succ_le_lt; [apply Vfexp|idtac|exact Fx|assumption]. - apply (generic_format_bpow beta fexp (ln_beta x - 1)). - replace (_ + _)%Z with (ln_beta x : Z) by ring. - assert (fexp (ln_beta x) < ln_beta x)%Z; [|omega]. - now apply ln_beta_generic_gt; [|now apply Rgt_not_eq|]. + apply (generic_format_bpow beta fexp (mag x - 1)). + replace (_ + _)%Z with (mag x : Z) by ring. + assert (fexp (mag x) < mag x)%Z; [|omega]. + now apply mag_generic_gt; [|now apply Rgt_not_eq|]. - rewrite Rabs_right. + apply Rlt_trans with x. * rewrite <- (Rplus_0_r x) at 2. @@ -840,22 +840,22 @@ split. rewrite <- Ropp_0. now apply Ropp_lt_contravar. * apply Rabs_lt_inv. - apply bpow_ln_beta_gt. + apply bpow_mag_gt. + lra. Qed. -Definition double_round_plus_hyp fexp1 fexp2 := +Definition round_round_plus_hyp fexp1 fexp2 := (forall ex ey, (fexp1 (ex + 1) - 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z) /\ (forall ex ey, (fexp1 (ex - 1) + 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z) /\ (forall ex ey, (fexp1 ex - 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z) /\ (forall ex ey, (ex - 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z). -Lemma double_round_plus_aux0_aux_aux : +Lemma round_round_plus_aux0_aux_aux : forall (fexp1 fexp2 : Z -> Z), forall x y, - (fexp1 (ln_beta x) <= fexp1 (ln_beta y))%Z -> - (fexp2 (ln_beta (x + y))%Z <= fexp1 (ln_beta x))%Z -> - (fexp2 (ln_beta (x + y))%Z <= fexp1 (ln_beta y))%Z -> + (fexp1 (mag x) <= fexp1 (mag y))%Z -> + (fexp2 (mag (x + y))%Z <= fexp1 (mag x))%Z -> + (fexp2 (mag (x + y))%Z <= fexp1 (mag y))%Z -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> generic_format beta fexp2 (x + y). Proof. @@ -863,224 +863,224 @@ intros fexp1 fexp2 x y Oxy Hlnx Hlny Fx Fy. destruct (Req_dec x 0) as [Zx|Nzx]. - (* x = 0 *) rewrite Zx, Rplus_0_l in Hlny |- *. - now apply (generic_inclusion_ln_beta beta fexp1). + now apply (generic_inclusion_mag beta fexp1). - (* x <> 0 *) destruct (Req_dec y 0) as [Zy|Nzy]. + (* y = 0 *) rewrite Zy, Rplus_0_r in Hlnx |- *. - now apply (generic_inclusion_ln_beta beta fexp1). + now apply (generic_inclusion_mag beta fexp1). + (* y <> 0 *) revert Fx Fy. - unfold generic_format at -3, canonic_exp, F2R; simpl. + unfold generic_format at -3, cexp, F2R; simpl. set (mx := Ztrunc (scaled_mantissa beta fexp1 x)). set (my := Ztrunc (scaled_mantissa beta fexp1 y)). intros Fx Fy. - set (fxy := Float beta (mx + my * (beta ^ (fexp1 (ln_beta y) - - fexp1 (ln_beta x)))) - (fexp1 (ln_beta x))). + set (fxy := Float beta (mx + my * (beta ^ (fexp1 (mag y) + - fexp1 (mag x)))) + (fexp1 (mag x))). assert (Hxy : x + y = F2R fxy). { unfold fxy, F2R; simpl. - rewrite Z2R_plus. + rewrite plus_IZR. rewrite Rmult_plus_distr_r. rewrite <- Fx. - rewrite Z2R_mult. - rewrite Z2R_Zpower; [|omega]. + rewrite mult_IZR. + rewrite IZR_Zpower; [|omega]. bpow_simplify. now rewrite <- Fy. } apply generic_format_F2R' with (f := fxy); [now rewrite Hxy|]. intros _. - now unfold canonic_exp, fxy; simpl. + now unfold cexp, fxy; simpl. Qed. -Lemma double_round_plus_aux0_aux : +Lemma round_round_plus_aux0_aux : forall (fexp1 fexp2 : Z -> Z), forall x y, - (fexp2 (ln_beta (x + y))%Z <= fexp1 (ln_beta x))%Z -> - (fexp2 (ln_beta (x + y))%Z <= fexp1 (ln_beta y))%Z -> + (fexp2 (mag (x + y))%Z <= fexp1 (mag x))%Z -> + (fexp2 (mag (x + y))%Z <= fexp1 (mag y))%Z -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> generic_format beta fexp2 (x + y). Proof. intros fexp1 fexp2 x y Hlnx Hlny Fx Fy. -destruct (Z.le_gt_cases (fexp1 (ln_beta x)) (fexp1 (ln_beta y))) as [Hle|Hgt]. -- now apply (double_round_plus_aux0_aux_aux fexp1). +destruct (Z.le_gt_cases (fexp1 (mag x)) (fexp1 (mag y))) as [Hle|Hgt]. +- now apply (round_round_plus_aux0_aux_aux fexp1). - rewrite Rplus_comm in Hlnx, Hlny |- *. - now apply (double_round_plus_aux0_aux_aux fexp1); [omega| | | |]. + now apply (round_round_plus_aux0_aux_aux fexp1); [omega| | | |]. Qed. -(* fexp1 (ln_beta x) - 1 <= ln_beta y : +(* fexp1 (mag x) - 1 <= mag y : * addition is exact in the largest precision (fexp2). *) -Lemma double_round_plus_aux0 : +Lemma round_round_plus_aux0 : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> - double_round_plus_hyp fexp1 fexp2 -> + round_round_plus_hyp fexp1 fexp2 -> forall x y, (0 < x)%R -> (0 < y)%R -> (y <= x)%R -> - (fexp1 (ln_beta x) - 1 <= ln_beta y)%Z -> + (fexp1 (mag x) - 1 <= mag y)%Z -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> generic_format beta fexp2 (x + y). Proof. intros fexp1 fexp2 Vfexp1 Hexp x y Px Py Hyx Hln Fx Fy. assert (Nny : (0 <= y)%R); [now apply Rlt_le|]. destruct Hexp as (_,(Hexp2,(Hexp3,Hexp4))). -destruct (Z.le_gt_cases (ln_beta y) (fexp1 (ln_beta x))) as [Hle|Hgt]. -- (* ln_beta y <= fexp1 (ln_beta x) *) - assert (Lxy : ln_beta (x + y) = ln_beta x :> Z); - [now apply (ln_beta_plus_separated fexp1)|]. - apply (double_round_plus_aux0_aux fexp1); +destruct (Z.le_gt_cases (mag y) (fexp1 (mag x))) as [Hle|Hgt]. +- (* mag y <= fexp1 (mag x) *) + assert (Lxy : mag (x + y) = mag x :> Z); + [now apply (mag_plus_separated fexp1)|]. + apply (round_round_plus_aux0_aux fexp1); [| |assumption|assumption]; rewrite Lxy. + now apply Hexp4; omega. + now apply Hexp3; omega. -- (* fexp1 (ln_beta x) < ln_beta y *) - apply (double_round_plus_aux0_aux fexp1); [| |assumption|assumption]. - destruct (ln_beta_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. +- (* fexp1 (mag x) < mag y *) + apply (round_round_plus_aux0_aux fexp1); [| |assumption|assumption]. + destruct (mag_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. + now apply Hexp4; omega. - + apply Hexp2; apply (ln_beta_le beta y x Py) in Hyx. - replace (_ - _)%Z with (ln_beta x : Z) by ring. + + apply Hexp2; apply (mag_le beta y x Py) in Hyx. + replace (_ - _)%Z with (mag x : Z) by ring. omega. - + destruct (ln_beta_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. + + destruct (mag_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. * now apply Hexp3; omega. * apply Hexp2. - replace (_ - _)%Z with (ln_beta x : Z) by ring. + replace (_ - _)%Z with (mag x : Z) by ring. omega. Qed. -Lemma double_round_plus_aux1_aux : +Lemma round_round_plus_aux1_aux : forall k, (0 < k)%Z -> forall (fexp : Z -> Z), forall x y, 0 < x -> 0 < y -> - (ln_beta y <= fexp (ln_beta x) - k)%Z -> - (ln_beta (x + y) = ln_beta x :> Z) -> + (mag y <= fexp (mag x) - k)%Z -> + (mag (x + y) = mag x :> Z) -> generic_format beta fexp x -> - 0 < (x + y) - round beta fexp Zfloor (x + y) < bpow (fexp (ln_beta x) - k). + 0 < (x + y) - round beta fexp Zfloor (x + y) < bpow (fexp (mag x) - k). Proof. assert (Hbeta : (2 <= beta)%Z). { destruct beta as (beta_val,beta_prop). now apply Zle_bool_imp_le. } intros k Hk fexp x y Px Py Hln Hlxy Fx. revert Fx. -unfold round, generic_format, F2R, scaled_mantissa, canonic_exp; simpl. +unfold round, generic_format, F2R, scaled_mantissa, cexp; simpl. rewrite Hlxy. -set (mx := Ztrunc (x * bpow (- fexp (ln_beta x)))). +set (mx := Ztrunc (x * bpow (- fexp (mag x)))). intros Fx. -assert (R : (x + y) * bpow (- fexp (ln_beta x)) - = Z2R mx + y * bpow (- fexp (ln_beta x))). +assert (R : (x + y) * bpow (- fexp (mag x)) + = IZR mx + y * bpow (- fexp (mag x))). { rewrite Fx at 1. rewrite Rmult_plus_distr_r. now bpow_simplify. } rewrite R. -assert (LB : 0 < y * bpow (- fexp (ln_beta x))). +assert (LB : 0 < y * bpow (- fexp (mag x))). { rewrite <- (Rmult_0_r y). now apply Rmult_lt_compat_l; [|apply bpow_gt_0]. } -assert (UB : y * bpow (- fexp (ln_beta x)) < / Z2R (beta ^ k)). -{ apply Rlt_le_trans with (bpow (ln_beta y) * bpow (- fexp (ln_beta x))). +assert (UB : y * bpow (- fexp (mag x)) < / IZR (beta ^ k)). +{ apply Rlt_le_trans with (bpow (mag y) * bpow (- fexp (mag x))). - apply Rmult_lt_compat_r; [now apply bpow_gt_0|]. rewrite <- (Rabs_right y) at 1; [|now apply Rle_ge; apply Rlt_le]. - apply bpow_ln_beta_gt. - - apply Rle_trans with (bpow (fexp (ln_beta x) - k) - * bpow (- fexp (ln_beta x)))%R. + apply bpow_mag_gt. + - apply Rle_trans with (bpow (fexp (mag x) - k) + * bpow (- fexp (mag x)))%R. + apply Rmult_le_compat_r; [now apply bpow_ge_0|]. now apply bpow_le. + bpow_simplify. rewrite bpow_opp. destruct k. * omega. - * simpl; unfold Fcore_Raux.bpow, Z.pow_pos. + * simpl; unfold Raux.bpow, Z.pow_pos. now apply Rle_refl. - * casetype False; apply (Zlt_irrefl 0). - apply (Zlt_trans _ _ _ Hk). + * casetype False; apply (Z.lt_irrefl 0). + apply (Z.lt_trans _ _ _ Hk). apply Zlt_neg_0. } rewrite (Zfloor_imp mx). { split; ring_simplify. - - apply (Rmult_lt_reg_r (bpow (- fexp (ln_beta x)))); [now apply bpow_gt_0|]. + - apply (Rmult_lt_reg_r (bpow (- fexp (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_minus_distr_r, Rmult_0_l. bpow_simplify. rewrite R; ring_simplify. now apply Rmult_lt_0_compat; [|apply bpow_gt_0]. - - apply (Rmult_lt_reg_r (bpow (- fexp (ln_beta x)))); [now apply bpow_gt_0|]. + - apply (Rmult_lt_reg_r (bpow (- fexp (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_minus_distr_r. bpow_simplify. rewrite R; ring_simplify. apply (Rlt_le_trans _ _ _ UB). rewrite bpow_opp. apply Rinv_le; [now apply bpow_gt_0|]. - now rewrite Z2R_Zpower; [right|omega]. } + now rewrite IZR_Zpower; [right|omega]. } split. - rewrite <- Rplus_0_r at 1; apply Rplus_le_compat_l. now apply Rlt_le. -- rewrite Z2R_plus; apply Rplus_lt_compat_l. - apply (Rmult_lt_reg_r (bpow (fexp (ln_beta x)))); [now apply bpow_gt_0|]. +- rewrite plus_IZR; apply Rplus_lt_compat_l. + apply (Rmult_lt_reg_r (bpow (fexp (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_1_l. bpow_simplify. - apply Rlt_trans with (bpow (ln_beta y)). + apply Rlt_trans with (bpow (mag y)). + rewrite <- Rabs_right at 1; [|now apply Rle_ge; apply Rlt_le]. - apply bpow_ln_beta_gt. + apply bpow_mag_gt. + apply bpow_lt; omega. Qed. -(* ln_beta y <= fexp1 (ln_beta x) - 2 : double_round_lt_mid applies. *) -Lemma double_round_plus_aux1 : +(* mag y <= fexp1 (mag x) - 2 : round_round_lt_mid applies. *) +Lemma round_round_plus_aux1 : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_hyp fexp1 fexp2 -> + round_round_plus_hyp fexp1 fexp2 -> forall x y, 0 < x -> 0 < y -> - (ln_beta y <= fexp1 (ln_beta x) - 2)%Z -> + (mag y <= fexp1 (mag x) - 2)%Z -> generic_format beta fexp1 x -> - double_round_eq fexp1 fexp2 choice1 choice2 (x + y). + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). Proof. assert (Hbeta : (2 <= beta)%Z). { destruct beta as (beta_val,beta_prop). now apply Zle_bool_imp_le. } intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Hly Fx. -assert (Lxy : ln_beta (x + y) = ln_beta x :> Z); - [now apply (ln_beta_plus_separated fexp1); [|apply Rlt_le| |omega]|]. +assert (Lxy : mag (x + y) = mag x :> Z); + [now apply (mag_plus_separated fexp1); [|apply Rlt_le| |omega]|]. destruct Hexp as (_,(_,(_,Hexp4))). -assert (Hf2 : (fexp2 (ln_beta x) <= fexp1 (ln_beta x))%Z); +assert (Hf2 : (fexp2 (mag x) <= fexp1 (mag x))%Z); [now apply Hexp4; omega|]. assert (Bpow2 : bpow (- 2) <= / 2 * / 2). { replace (/2 * /2) with (/4) by field. rewrite (bpow_opp _ 2). apply Rinv_le; [lra|]. - apply (Z2R_le (2 * 2) (beta * (beta * 1))). + apply (IZR_le (2 * 2) (beta * (beta * 1))). rewrite Zmult_1_r. now apply Zmult_le_compat; omega. } assert (P2 : (0 < 2)%Z) by omega. -unfold double_round_eq. -apply double_round_lt_mid. +unfold round_round_eq. +apply round_round_lt_mid. - exact Vfexp1. - exact Vfexp2. - lra. - now rewrite Lxy. - rewrite Lxy. - assert (fexp1 (ln_beta x) < ln_beta x)%Z; [|omega]. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. + assert (fexp1 (mag x) < mag x)%Z; [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. - unfold midp. apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))). - apply (Rlt_le_trans _ _ _ (proj2 (double_round_plus_aux1_aux 2 P2 fexp1 x y Px + apply (Rlt_le_trans _ _ _ (proj2 (round_round_plus_aux1_aux 2 P2 fexp1 x y Px Py Hly Lxy Fx))). ring_simplify. rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. - unfold canonic_exp; rewrite Lxy. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + unfold cexp; rewrite Lxy. + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. bpow_simplify. apply (Rle_trans _ _ _ Bpow2). rewrite <- (Rmult_1_r (/ 2)) at 3. apply Rmult_le_compat_l; lra. - rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. - unfold round, F2R, scaled_mantissa, canonic_exp; simpl; rewrite Lxy. + unfold round, F2R, scaled_mantissa, cexp; simpl; rewrite Lxy. intro Hf2'. - apply (Rmult_lt_reg_r (bpow (- fexp1 (ln_beta x)))); + apply (Rmult_lt_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. bpow_simplify. apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))). unfold midp; ring_simplify. - apply (Rlt_le_trans _ _ _ (proj2 (double_round_plus_aux1_aux 2 P2 fexp1 x y Px + apply (Rlt_le_trans _ _ _ (proj2 (round_round_plus_aux1_aux 2 P2 fexp1 x y Px Py Hly Lxy Fx))). - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. - unfold canonic_exp; rewrite Lxy, Rmult_minus_distr_r; bpow_simplify. + unfold cexp; rewrite Lxy, Rmult_minus_distr_r; bpow_simplify. apply (Rle_trans _ _ _ Bpow2). rewrite <- (Rmult_1_r (/ 2)) at 3; rewrite <- Rmult_minus_distr_l. apply Rmult_le_compat_l; [lra|]. @@ -1089,49 +1089,49 @@ apply double_round_lt_mid. apply Ropp_le_contravar. { apply Rle_trans with (bpow (- 1)). - apply bpow_le; omega. - - unfold Fcore_Raux.bpow, Z.pow_pos; simpl. + - unfold Raux.bpow, Z.pow_pos; simpl. apply Rinv_le; [lra|]. - change 2 with (Z2R 2); apply Z2R_le; omega. } + apply IZR_le; omega. } Qed. -(* double_round_plus_aux{0,1} together *) -Lemma double_round_plus_aux2 : +(* round_round_plus_aux{0,1} together *) +Lemma round_round_plus_aux2 : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_hyp fexp1 fexp2 -> + round_round_plus_hyp fexp1 fexp2 -> forall x y, 0 < x -> 0 < y -> y <= x -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x + y). + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Hyx Fx Fy. -unfold double_round_eq. -destruct (Zle_or_lt (ln_beta y) (fexp1 (ln_beta x) - 2)) as [Hly|Hly]. -- (* ln_beta y <= fexp1 (ln_beta x) - 2 *) - now apply double_round_plus_aux1. -- (* fexp1 (ln_beta x) - 2 < ln_beta y *) +unfold round_round_eq. +destruct (Zle_or_lt (mag y) (fexp1 (mag x) - 2)) as [Hly|Hly]. +- (* mag y <= fexp1 (mag x) - 2 *) + now apply round_round_plus_aux1. +- (* fexp1 (mag x) - 2 < mag y *) rewrite (round_generic beta fexp2). + reflexivity. + now apply valid_rnd_N. - + assert (Hf1 : (fexp1 (ln_beta x) - 1 <= ln_beta y)%Z); [omega|]. - now apply (double_round_plus_aux0 fexp1). + + assert (Hf1 : (fexp1 (mag x) - 1 <= mag y)%Z); [omega|]. + now apply (round_round_plus_aux0 fexp1). Qed. -Lemma double_round_plus_aux : +Lemma round_round_plus_aux : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_hyp fexp1 fexp2 -> + round_round_plus_hyp fexp1 fexp2 -> forall x y, 0 <= x -> 0 <= y -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x + y). + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Nnx Nny Fx Fy. -unfold double_round_eq. +unfold round_round_eq. destruct (Req_dec x 0) as [Zx|Nzx]. - (* x = 0 *) destruct Hexp as (_,(_,(_,Hexp4))). @@ -1139,7 +1139,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. rewrite (round_generic beta fexp2). + reflexivity. + now apply valid_rnd_N. - + apply (generic_inclusion_ln_beta beta fexp1). + + apply (generic_inclusion_mag beta fexp1). now intros _; apply Hexp4; omega. exact Fy. - (* x <> 0 *) @@ -1150,7 +1150,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. rewrite (round_generic beta fexp2). * reflexivity. * now apply valid_rnd_N. - * apply (generic_inclusion_ln_beta beta fexp1). + * apply (generic_inclusion_mag beta fexp1). now intros _; apply Hexp4; omega. exact Fx. + (* y <> 0 *) @@ -1160,118 +1160,118 @@ destruct (Req_dec x 0) as [Zx|Nzx]. * (* x < y *) apply Rlt_le in H. rewrite Rplus_comm. - now apply double_round_plus_aux2. - * now apply double_round_plus_aux2. + now apply round_round_plus_aux2. + * now apply round_round_plus_aux2. Qed. -Lemma double_round_minus_aux0_aux : +Lemma round_round_minus_aux0_aux : forall (fexp1 fexp2 : Z -> Z), forall x y, - (fexp2 (ln_beta (x - y))%Z <= fexp1 (ln_beta x))%Z -> - (fexp2 (ln_beta (x - y))%Z <= fexp1 (ln_beta y))%Z -> + (fexp2 (mag (x - y))%Z <= fexp1 (mag x))%Z -> + (fexp2 (mag (x - y))%Z <= fexp1 (mag y))%Z -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> generic_format beta fexp2 (x - y). Proof. intros fexp1 fexp2 x y. replace (x - y)%R with (x + (- y))%R; [|ring]. intros Hlnx Hlny Fx Fy. -rewrite <- (ln_beta_opp beta y) in Hlny. +rewrite <- (mag_opp beta y) in Hlny. apply generic_format_opp in Fy. -now apply (double_round_plus_aux0_aux fexp1). +now apply (round_round_plus_aux0_aux fexp1). Qed. -(* fexp1 (ln_beta x) - 1 <= ln_beta y : +(* fexp1 (mag x) - 1 <= mag y : * substraction is exact in the largest precision (fexp2). *) -Lemma double_round_minus_aux0 : +Lemma round_round_minus_aux0 : forall (fexp1 fexp2 : Z -> Z), - double_round_plus_hyp fexp1 fexp2 -> + round_round_plus_hyp fexp1 fexp2 -> forall x y, 0 < y -> y < x -> - (fexp1 (ln_beta x) - 1 <= ln_beta y)%Z -> + (fexp1 (mag x) - 1 <= mag y)%Z -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> generic_format beta fexp2 (x - y). Proof. intros fexp1 fexp2 Hexp x y Py Hyx Hln Fx Fy. assert (Px := Rlt_trans 0 y x Py Hyx). destruct Hexp as (Hexp1,(_,(Hexp3,Hexp4))). -assert (Lyx : (ln_beta y <= ln_beta x)%Z); - [now apply ln_beta_le; [|apply Rlt_le]|]. -destruct (Z.lt_ge_cases (ln_beta x - 2) (ln_beta y)) as [Hlt|Hge]. -- (* ln_beta x - 2 < ln_beta y *) - assert (Hor : (ln_beta y = ln_beta x :> Z) - \/ (ln_beta y = ln_beta x - 1 :> Z)%Z); [omega|]. +assert (Lyx : (mag y <= mag x)%Z); + [now apply mag_le; [|apply Rlt_le]|]. +destruct (Z.lt_ge_cases (mag x - 2) (mag y)) as [Hlt|Hge]. +- (* mag x - 2 < mag y *) + assert (Hor : (mag y = mag x :> Z) + \/ (mag y = mag x - 1 :> Z)%Z); [omega|]. destruct Hor as [Heq|Heqm1]. - + (* ln_beta y = ln_beta x *) - apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. + + (* mag y = mag x *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. * apply Hexp4. - apply Zle_trans with (ln_beta (x - y)); [omega|]. - now apply ln_beta_minus. + apply Z.le_trans with (mag (x - y)); [omega|]. + now apply mag_minus. * rewrite Heq. apply Hexp4. - apply Zle_trans with (ln_beta (x - y)); [omega|]. - now apply ln_beta_minus. - + (* ln_beta y = ln_beta x - 1 *) - apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. + apply Z.le_trans with (mag (x - y)); [omega|]. + now apply mag_minus. + + (* mag y = mag x - 1 *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. * apply Hexp4. - apply Zle_trans with (ln_beta (x - y)); [omega|]. - now apply ln_beta_minus. + apply Z.le_trans with (mag (x - y)); [omega|]. + now apply mag_minus. * rewrite Heqm1. apply Hexp4. apply Zplus_le_compat_r. - now apply ln_beta_minus. -- (* ln_beta y <= ln_beta x - 2 *) - destruct (ln_beta_minus_disj x y Px Py Hge) as [Lxmy|Lxmy]. - + (* ln_beta (x - y) = ln_beta x *) - apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. + now apply mag_minus. +- (* mag y <= mag x - 2 *) + destruct (mag_minus_disj x y Px Py Hge) as [Lxmy|Lxmy]. + + (* mag (x - y) = mag x *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. * apply Hexp4. omega. * now rewrite Lxmy; apply Hexp3. - + (* ln_beta (x - y) = ln_beta x - 1 *) - apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]; + + (* mag (x - y) = mag x - 1 *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]; rewrite Lxmy. * apply Hexp1. - replace (_ + _)%Z with (ln_beta x : Z); [|ring]. - now apply Zle_trans with (ln_beta y). + replace (_ + _)%Z with (mag x : Z); [|ring]. + now apply Z.le_trans with (mag y). * apply Hexp1. - now replace (_ + _)%Z with (ln_beta x : Z); [|ring]. + now replace (_ + _)%Z with (mag x : Z); [|ring]. Qed. -(* ln_beta y <= fexp1 (ln_beta x) - 2, - * fexp1 (ln_beta (x - y)) - 1 <= ln_beta y : +(* mag y <= fexp1 (mag x) - 2, + * fexp1 (mag (x - y)) - 1 <= mag y : * substraction is exact in the largest precision (fexp2). *) -Lemma double_round_minus_aux1 : +Lemma round_round_minus_aux1 : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> - double_round_plus_hyp fexp1 fexp2 -> + round_round_plus_hyp fexp1 fexp2 -> forall x y, 0 < y -> y < x -> - (ln_beta y <= fexp1 (ln_beta x) - 2)%Z -> - (fexp1 (ln_beta (x - y)) - 1 <= ln_beta y)%Z -> + (mag y <= fexp1 (mag x) - 2)%Z -> + (fexp1 (mag (x - y)) - 1 <= mag y)%Z -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> generic_format beta fexp2 (x - y). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 Hexp x y Py Hyx Hln Hln' Fx Fy. assert (Px := Rlt_trans 0 y x Py Hyx). destruct Hexp as (Hexp1,(Hexp2,(Hexp3,Hexp4))). -assert (Lyx : (ln_beta y <= ln_beta x)%Z); - [now apply ln_beta_le; [|apply Rlt_le]|]. -assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. -assert (Hfy : (fexp1 (ln_beta y) < ln_beta y)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. -apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. -- apply Zle_trans with (fexp1 (ln_beta (x - y))). +assert (Lyx : (mag y <= mag x)%Z); + [now apply mag_le; [|apply Rlt_le]|]. +assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfy : (fexp1 (mag y) < mag y)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. +- apply Z.le_trans with (fexp1 (mag (x - y))). + apply Hexp4; omega. + omega. - now apply Hexp3. Qed. -Lemma double_round_minus_aux2_aux : +Lemma round_round_minus_aux2_aux : forall (fexp : Z -> Z), Valid_exp fexp -> forall x y, 0 < y -> y < x -> - (ln_beta y <= fexp (ln_beta x) - 1)%Z -> + (mag y <= fexp (mag x) - 1)%Z -> generic_format beta fexp x -> generic_format beta fexp y -> round beta fexp Zceil (x - y) - (x - y) <= y. @@ -1279,19 +1279,19 @@ Proof. intros fexp Vfexp x y Py Hxy Hly Fx Fy. assert (Px := Rlt_trans 0 y x Py Hxy). revert Fx. -unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl. -set (mx := Ztrunc (x * bpow (- fexp (ln_beta x)))). +unfold generic_format, F2R, scaled_mantissa, cexp; simpl. +set (mx := Ztrunc (x * bpow (- fexp (mag x)))). intro Fx. -assert (Hfx : (fexp (ln_beta x) < ln_beta x)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. -assert (Hfy : (fexp (ln_beta y) < ln_beta y)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. -destruct (Rlt_or_le (bpow (ln_beta x - 1)) x) as [Hx|Hx]. -- (* bpow (ln_beta x - 1) < x *) - assert (Lxy : ln_beta (x - y) = ln_beta x :> Z); - [now apply (ln_beta_minus_separated fexp); [| | | | | |omega]|]. +assert (Hfx : (fexp (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfy : (fexp (mag y) < mag y)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +destruct (Rlt_or_le (bpow (mag x - 1)) x) as [Hx|Hx]. +- (* bpow (mag x - 1) < x *) + assert (Lxy : mag (x - y) = mag x :> Z); + [now apply (mag_minus_separated fexp); [| | | | | |omega]|]. assert (Rxy : round beta fexp Zceil (x - y) = x). - { unfold round, F2R, scaled_mantissa, canonic_exp; simpl. + { unfold round, F2R, scaled_mantissa, cexp; simpl. rewrite Lxy. apply eq_sym; rewrite Fx at 1; apply eq_sym. apply Rmult_eq_compat_r. @@ -1301,18 +1301,18 @@ destruct (Rlt_or_le (bpow (ln_beta x - 1)) x) as [Hx|Hx]. bpow_simplify. apply Zceil_imp. split. - - unfold Zminus; rewrite Z2R_plus. + - unfold Zminus; rewrite plus_IZR. apply Rplus_lt_compat_l. apply Ropp_lt_contravar; simpl. - apply (Rmult_lt_reg_r (bpow (fexp (ln_beta x)))); + apply (Rmult_lt_reg_r (bpow (fexp (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_1_l; bpow_simplify. - apply Rlt_le_trans with (bpow (ln_beta y)). + apply Rlt_le_trans with (bpow (mag y)). + rewrite <- Rabs_right at 1; [|now apply Rle_ge; apply Rlt_le]. - apply bpow_ln_beta_gt. + apply bpow_mag_gt. + apply bpow_le. omega. - - rewrite <- (Rplus_0_r (Z2R _)) at 2. + - rewrite <- (Rplus_0_r (IZR _)) at 2. apply Rplus_le_compat_l. rewrite <- Ropp_0; apply Ropp_le_contravar. rewrite <- (Rmult_0_r y). @@ -1320,34 +1320,34 @@ destruct (Rlt_or_le (bpow (ln_beta x - 1)) x) as [Hx|Hx]. now apply bpow_ge_0. } rewrite Rxy; ring_simplify. apply Rle_refl. -- (* x <= bpow (ln_beta x - 1) *) - assert (Xpow : x = bpow (ln_beta x - 1)). +- (* x <= bpow (mag x - 1) *) + assert (Xpow : x = bpow (mag x - 1)). { apply Rle_antisym; [exact Hx|]. - destruct (ln_beta x) as (ex, Hex); simpl. + destruct (mag x) as (ex, Hex); simpl. rewrite <- (Rabs_right x); [|now apply Rle_ge; apply Rlt_le]. apply Hex. now apply Rgt_not_eq. } - assert (Lxy : (ln_beta (x - y) = ln_beta x - 1 :> Z)%Z). + assert (Lxy : (mag (x - y) = mag x - 1 :> Z)%Z). { apply Zle_antisym. - - apply ln_beta_le_bpow. + - apply mag_le_bpow. + apply Rminus_eq_contra. now intro Hx'; rewrite Hx' in Hxy; apply (Rlt_irrefl y). + rewrite Rabs_right; lra. - - apply (ln_beta_minus_lb beta x y Px Py). + - apply (mag_minus_lb beta x y Px Py). omega. } - assert (Hfx1 : (fexp (ln_beta x - 1) < ln_beta x - 1)%Z); - [now apply (valid_exp_large fexp (ln_beta y)); [|omega]|]. + assert (Hfx1 : (fexp (mag x - 1) < mag x - 1)%Z); + [now apply (valid_exp_large fexp (mag y)); [|omega]|]. assert (Rxy : round beta fexp Zceil (x - y) <= x). { rewrite Xpow at 2. - unfold round, F2R, scaled_mantissa, canonic_exp; simpl. + unfold round, F2R, scaled_mantissa, cexp; simpl. rewrite Lxy. - apply (Rmult_le_reg_r (bpow (- fexp (ln_beta x - 1)%Z))); + apply (Rmult_le_reg_r (bpow (- fexp (mag x - 1)%Z))); [now apply bpow_gt_0|]. bpow_simplify. - rewrite <- (Z2R_Zpower beta (_ - _ - _)); [|omega]. - apply Z2R_le. + rewrite <- (IZR_Zpower beta (_ - _ - _)); [|omega]. + apply IZR_le. apply Zceil_glb. - rewrite Z2R_Zpower; [|omega]. + rewrite IZR_Zpower; [|omega]. rewrite Xpow at 1. rewrite Rmult_minus_distr_r. bpow_simplify. @@ -1360,21 +1360,21 @@ destruct (Rlt_or_le (bpow (ln_beta x - 1)) x) as [Hx|Hx]. lra. Qed. -(* ln_beta y <= fexp1 (ln_beta x) - 2 : - * ln_beta y <= fexp1 (ln_beta (x - y)) - 2 : - * double_round_gt_mid applies. *) -Lemma double_round_minus_aux2 : +(* mag y <= fexp1 (mag x) - 2 : + * mag y <= fexp1 (mag (x - y)) - 2 : + * round_round_gt_mid applies. *) +Lemma round_round_minus_aux2 : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_hyp fexp1 fexp2 -> + round_round_plus_hyp fexp1 fexp2 -> forall x y, 0 < y -> y < x -> - (ln_beta y <= fexp1 (ln_beta x) - 2)%Z -> - (ln_beta y <= fexp1 (ln_beta (x - y)) - 2)%Z -> + (mag y <= fexp1 (mag x) - 2)%Z -> + (mag y <= fexp1 (mag (x - y)) - 2)%Z -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x - y). + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). Proof. assert (Hbeta : (2 <= beta)%Z). { destruct beta as (beta_val,beta_prop). @@ -1382,52 +1382,52 @@ assert (Hbeta : (2 <= beta)%Z). intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Py Hxy Hly Hly' Fx Fy. assert (Px := Rlt_trans 0 y x Py Hxy). destruct Hexp as (_,(_,(_,Hexp4))). -assert (Hf2 : (fexp2 (ln_beta x) <= fexp1 (ln_beta x))%Z); +assert (Hf2 : (fexp2 (mag x) <= fexp1 (mag x))%Z); [now apply Hexp4; omega|]. -assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. assert (Bpow2 : bpow (- 2) <= / 2 * / 2). { replace (/2 * /2) with (/4) by field. rewrite (bpow_opp _ 2). apply Rinv_le; [lra|]. - apply (Z2R_le (2 * 2) (beta * (beta * 1))). + apply (IZR_le (2 * 2) (beta * (beta * 1))). rewrite Zmult_1_r. now apply Zmult_le_compat; omega. } -assert (Ly : y < bpow (ln_beta y)). +assert (Ly : y < bpow (mag y)). { apply Rabs_lt_inv. - apply bpow_ln_beta_gt. } -unfold double_round_eq. -apply double_round_gt_mid. + apply bpow_mag_gt. } +unfold round_round_eq. +apply round_round_gt_mid. - exact Vfexp1. - exact Vfexp2. - lra. - apply Hexp4; omega. -- assert (fexp1 (ln_beta (x - y)) < ln_beta (x - y))%Z; [|omega]. - apply (valid_exp_large fexp1 (ln_beta x - 1)). - + apply (valid_exp_large fexp1 (ln_beta y)); [|omega]. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. - + now apply ln_beta_minus_lb; [| |omega]. +- assert (fexp1 (mag (x - y)) < mag (x - y))%Z; [|omega]. + apply (valid_exp_large fexp1 (mag x - 1)). + + apply (valid_exp_large fexp1 (mag y)); [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. + + now apply mag_minus_lb; [| |omega]. - unfold midp'. apply (Rplus_lt_reg_r (/ 2 * ulp beta fexp1 (x - y) - (x - y))). ring_simplify. replace (_ + _) with (round beta fexp1 Zceil (x - y) - (x - y)) by ring. - apply Rlt_le_trans with (bpow (fexp1 (ln_beta (x - y)) - 2)). + apply Rlt_le_trans with (bpow (fexp1 (mag (x - y)) - 2)). + apply Rle_lt_trans with y; - [now apply double_round_minus_aux2_aux; try assumption; omega|]. + [now apply round_round_minus_aux2_aux; try assumption; omega|]. apply (Rlt_le_trans _ _ _ Ly). now apply bpow_le. + rewrite ulp_neq_0;[idtac|now apply sym_not_eq, Rlt_not_eq, Rgt_minus]. - unfold canonic_exp. - replace (_ - 2)%Z with (fexp1 (ln_beta (x - y)) - 1 - 1)%Z by ring. + unfold cexp. + replace (_ - 2)%Z with (fexp1 (mag (x - y)) - 1 - 1)%Z by ring. unfold Zminus at 1; rewrite bpow_plus. rewrite Rmult_comm. apply Rmult_le_compat. * now apply bpow_ge_0. * now apply bpow_ge_0. - * unfold Fcore_Raux.bpow, Z.pow_pos; simpl. + * unfold Raux.bpow, Z.pow_pos; simpl. rewrite Zmult_1_r; apply Rinv_le. lra. - now change 2 with (Z2R 2); apply Z2R_le. + now apply IZR_le. * apply bpow_le; omega. - intro Hf2'. unfold midp'. @@ -1436,53 +1436,53 @@ apply double_round_gt_mid. ring_simplify. replace (_ + _) with (round beta fexp1 Zceil (x - y) - (x - y)) by ring. apply Rle_lt_trans with y; - [now apply double_round_minus_aux2_aux; try assumption; omega|]. + [now apply round_round_minus_aux2_aux; try assumption; omega|]. apply (Rlt_le_trans _ _ _ Ly). - apply Rle_trans with (bpow (fexp1 (ln_beta (x - y)) - 2)); + apply Rle_trans with (bpow (fexp1 (mag (x - y)) - 2)); [now apply bpow_le|]. - replace (_ - 2)%Z with (fexp1 (ln_beta (x - y)) - 1 - 1)%Z by ring. + replace (_ - 2)%Z with (fexp1 (mag (x - y)) - 1 - 1)%Z by ring. unfold Zminus at 1; rewrite bpow_plus. rewrite <- Rmult_minus_distr_l. rewrite Rmult_comm; apply Rmult_le_compat. + apply bpow_ge_0. + apply bpow_ge_0. - + unfold Fcore_Raux.bpow, Z.pow_pos; simpl. + + unfold Raux.bpow, Z.pow_pos; simpl. rewrite Zmult_1_r; apply Rinv_le; [lra|]. - now change 2 with (Z2R 2); apply Z2R_le. + now apply IZR_le. + rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, Rgt_minus. - unfold canonic_exp. - apply (Rplus_le_reg_r (bpow (fexp2 (ln_beta (x - y))))); ring_simplify. - apply Rle_trans with (2 * bpow (fexp1 (ln_beta (x - y)) - 1)). - * replace (2 * bpow (fexp1 (ln_beta (x - y)) - 1)) with (bpow (fexp1 (ln_beta (x - y)) - 1) + bpow (fexp1 (ln_beta (x - y)) - 1)) by ring. + unfold cexp. + apply (Rplus_le_reg_r (bpow (fexp2 (mag (x - y))))); ring_simplify. + apply Rle_trans with (2 * bpow (fexp1 (mag (x - y)) - 1)). + * rewrite double. apply Rplus_le_compat_l. now apply bpow_le. * unfold Zminus; rewrite bpow_plus. rewrite Rmult_comm; rewrite Rmult_assoc. rewrite <- Rmult_1_r. apply Rmult_le_compat_l; [now apply bpow_ge_0|]. - unfold Fcore_Raux.bpow, Z.pow_pos; simpl. + unfold Raux.bpow, Z.pow_pos; simpl. rewrite Zmult_1_r. - apply Z2R_le, Rinv_le in Hbeta. + apply IZR_le, Rinv_le in Hbeta. simpl in Hbeta. lra. apply Rlt_0_2. Qed. -(* double_round_minus_aux{0,1,2} together *) -Lemma double_round_minus_aux3 : +(* round_round_minus_aux{0,1,2} together *) +Lemma round_round_minus_aux3 : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_hyp fexp1 fexp2 -> + round_round_plus_hyp fexp1 fexp2 -> forall x y, 0 < y -> y <= x -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x - y). + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Py Hyx Fx Fy. assert (Px := Rlt_le_trans 0 y x Py Hyx). -unfold double_round_eq. +unfold round_round_eq. destruct (Req_dec y x) as [Hy|Hy]. - (* y = x *) rewrite Hy; replace (x - x) with 0 by ring. @@ -1491,38 +1491,38 @@ destruct (Req_dec y x) as [Hy|Hy]. + now apply valid_rnd_N. - (* y < x *) assert (Hyx' : y < x); [lra|]. - destruct (Zle_or_lt (ln_beta y) (fexp1 (ln_beta x) - 2)) as [Hly|Hly]. - + (* ln_beta y <= fexp1 (ln_beta x) - 2 *) - destruct (Zle_or_lt (ln_beta y) (fexp1 (ln_beta (x - y)) - 2)) + destruct (Zle_or_lt (mag y) (fexp1 (mag x) - 2)) as [Hly|Hly]. + + (* mag y <= fexp1 (mag x) - 2 *) + destruct (Zle_or_lt (mag y) (fexp1 (mag (x - y)) - 2)) as [Hly'|Hly']. - * (* ln_beta y <= fexp1 (ln_beta (x - y)) - 2 *) - now apply double_round_minus_aux2. - * (* fexp1 (ln_beta (x - y)) - 2 < ln_beta y *) + * (* mag y <= fexp1 (mag (x - y)) - 2 *) + now apply round_round_minus_aux2. + * (* fexp1 (mag (x - y)) - 2 < mag y *) { rewrite (round_generic beta fexp2). - reflexivity. - now apply valid_rnd_N. - - assert (Hf1 : (fexp1 (ln_beta (x - y)) - 1 <= ln_beta y)%Z); [omega|]. - now apply (double_round_minus_aux1 fexp1). } + - assert (Hf1 : (fexp1 (mag (x - y)) - 1 <= mag y)%Z); [omega|]. + now apply (round_round_minus_aux1 fexp1). } + rewrite (round_generic beta fexp2). * reflexivity. * now apply valid_rnd_N. - * assert (Hf1 : (fexp1 (ln_beta x) - 1 <= ln_beta y)%Z); [omega|]. - now apply (double_round_minus_aux0 fexp1). + * assert (Hf1 : (fexp1 (mag x) - 1 <= mag y)%Z); [omega|]. + now apply (round_round_minus_aux0 fexp1). Qed. -Lemma double_round_minus_aux : +Lemma round_round_minus_aux : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_hyp fexp1 fexp2 -> + round_round_plus_hyp fexp1 fexp2 -> forall x y, 0 <= x -> 0 <= y -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x - y). + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Nnx Nny Fx Fy. -unfold double_round_eq. +unfold round_round_eq. destruct (Req_dec x 0) as [Zx|Nzx]. - (* x = 0 *) rewrite Zx; unfold Rminus; rewrite Rplus_0_l. @@ -1530,7 +1530,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. rewrite (round_generic beta fexp2). * reflexivity. * now apply valid_rnd_N. - * apply (generic_inclusion_ln_beta beta fexp1). + * apply (generic_inclusion_mag beta fexp1). destruct Hexp as (_,(_,(_,Hexp4))). now intros _; apply Hexp4; omega. exact Fy. @@ -1541,7 +1541,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. rewrite (round_generic beta fexp2). * reflexivity. * now apply valid_rnd_N. - * apply (generic_inclusion_ln_beta beta fexp1). + * apply (generic_inclusion_mag beta fexp1). destruct Hexp as (_,(_,(_,Hexp4))). now intros _; apply Hexp4; omega. exact Fx. @@ -1554,23 +1554,23 @@ destruct (Req_dec x 0) as [Zx|Nzx]. replace (x - y) with (- (y - x)) by ring. do 3 rewrite round_N_opp. apply Ropp_eq_compat. - now apply double_round_minus_aux3. + now apply round_round_minus_aux3. * (* y <= x *) - now apply double_round_minus_aux3. + now apply round_round_minus_aux3. Qed. -Lemma double_round_plus : +Lemma round_round_plus : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_hyp fexp1 fexp2 -> + round_round_plus_hyp fexp1 fexp2 -> forall x y, generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x + y). + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Fx Fy. -unfold double_round_eq. +unfold round_round_eq. destruct (Rlt_or_le x 0) as [Sx|Sx]; destruct (Rlt_or_le y 0) as [Sy|Sy]. - (* x < 0, y < 0 *) replace (x + y) with (- (- x - y)); [|ring]. @@ -1580,87 +1580,85 @@ destruct (Rlt_or_le x 0) as [Sx|Sx]; destruct (Rlt_or_le y 0) as [Sy|Sy]. assert (Py : 0 <= - y); [lra|]. apply generic_format_opp in Fx. apply generic_format_opp in Fy. - now apply double_round_plus_aux. + now apply round_round_plus_aux. - (* x < 0, 0 <= y *) replace (x + y) with (y - (- x)); [|ring]. assert (Px : 0 <= - x); [lra|]. apply generic_format_opp in Fx. - now apply double_round_minus_aux. + now apply round_round_minus_aux. - (* 0 <= x, y < 0 *) replace (x + y) with (x - (- y)); [|ring]. assert (Py : 0 <= - y); [lra|]. apply generic_format_opp in Fy. - now apply double_round_minus_aux. + now apply round_round_minus_aux. - (* 0 <= x, 0 <= y *) - now apply double_round_plus_aux. + now apply round_round_plus_aux. Qed. -Lemma double_round_minus : +Lemma round_round_minus : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_hyp fexp1 fexp2 -> + round_round_plus_hyp fexp1 fexp2 -> forall x y, generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x - y). + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Fx Fy. unfold Rminus. apply generic_format_opp in Fy. -now apply double_round_plus. +now apply round_round_plus. Qed. Section Double_round_plus_FLX. -Import Fcore_FLX. - Variable prec : Z. Variable prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FLX_double_round_plus_hyp : +Lemma FLX_round_round_plus_hyp : (2 * prec + 1 <= prec')%Z -> - double_round_plus_hyp (FLX_exp prec) (FLX_exp prec'). + round_round_plus_hyp (FLX_exp prec) (FLX_exp prec'). Proof. intros Hprec. unfold FLX_exp. -unfold double_round_plus_hyp; split; [|split; [|split]]; +unfold round_round_plus_hyp; split; [|split; [|split]]; intros ex ey; try omega. unfold Prec_gt_0 in prec_gt_0_. omega. Qed. -Theorem double_round_plus_FLX : +Theorem round_round_plus_FLX : forall choice1 choice2, (2 * prec + 1 <= prec')%Z -> forall x y, FLX_format beta prec x -> FLX_format beta prec y -> - double_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x + y). + round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x + y). Proof. intros choice1 choice2 Hprec x y Fx Fy. -apply double_round_plus. +apply round_round_plus. - now apply FLX_exp_valid. - now apply FLX_exp_valid. -- now apply FLX_double_round_plus_hyp. +- now apply FLX_round_round_plus_hyp. - now apply generic_format_FLX. - now apply generic_format_FLX. Qed. -Theorem double_round_minus_FLX : +Theorem round_round_minus_FLX : forall choice1 choice2, (2 * prec + 1 <= prec')%Z -> forall x y, FLX_format beta prec x -> FLX_format beta prec y -> - double_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x - y). + round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x - y). Proof. intros choice1 choice2 Hprec x y Fx Fy. -apply double_round_minus. +apply round_round_minus. - now apply FLX_exp_valid. - now apply FLX_exp_valid. -- now apply FLX_double_round_plus_hyp. +- now apply FLX_round_round_plus_hyp. - now apply generic_format_FLX. - now apply generic_format_FLX. Qed. @@ -1669,22 +1667,19 @@ End Double_round_plus_FLX. Section Double_round_plus_FLT. -Import Fcore_FLX. -Import Fcore_FLT. - Variable emin prec : Z. Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FLT_double_round_plus_hyp : +Lemma FLT_round_round_plus_hyp : (emin' <= emin)%Z -> (2 * prec + 1 <= prec')%Z -> - double_round_plus_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). + round_round_plus_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). Proof. intros Hemin Hprec. unfold FLT_exp. -unfold double_round_plus_hyp; split; [|split; [|split]]; intros ex ey. +unfold round_round_plus_hyp; split; [|split; [|split]]; intros ex ey. - generalize (Zmax_spec (ex + 1 - prec) emin). generalize (Zmax_spec (ex - prec') emin'). generalize (Zmax_spec (ey - prec) emin). @@ -1703,36 +1698,36 @@ unfold double_round_plus_hyp; split; [|split; [|split]]; intros ex ey. omega. Qed. -Theorem double_round_plus_FLT : +Theorem round_round_plus_FLT : forall choice1 choice2, (emin' <= emin)%Z -> (2 * prec + 1 <= prec')%Z -> forall x y, FLT_format beta emin prec x -> FLT_format beta emin prec y -> - double_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') + round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') choice1 choice2 (x + y). Proof. intros choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_plus. +apply round_round_plus. - now apply FLT_exp_valid. - now apply FLT_exp_valid. -- now apply FLT_double_round_plus_hyp. +- now apply FLT_round_round_plus_hyp. - now apply generic_format_FLT. - now apply generic_format_FLT. Qed. -Theorem double_round_minus_FLT : +Theorem round_round_minus_FLT : forall choice1 choice2, (emin' <= emin)%Z -> (2 * prec + 1 <= prec')%Z -> forall x y, FLT_format beta emin prec x -> FLT_format beta emin prec y -> - double_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') + round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') choice1 choice2 (x - y). Proof. intros choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_minus. +apply round_round_minus. - now apply FLT_exp_valid. - now apply FLT_exp_valid. -- now apply FLT_double_round_plus_hyp. +- now apply FLT_round_round_plus_hyp. - now apply generic_format_FLT. - now apply generic_format_FLT. Qed. @@ -1741,23 +1736,20 @@ End Double_round_plus_FLT. Section Double_round_plus_FTZ. -Import Fcore_FLX. -Import Fcore_FTZ. - Variable emin prec : Z. Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FTZ_double_round_plus_hyp : +Lemma FTZ_round_round_plus_hyp : (emin' + prec' <= emin + 1)%Z -> (2 * prec + 1 <= prec')%Z -> - double_round_plus_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). + round_round_plus_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). Proof. intros Hemin Hprec. unfold FTZ_exp. unfold Prec_gt_0 in *. -unfold double_round_plus_hyp; split; [|split; [|split]]; intros ex ey. +unfold round_round_plus_hyp; split; [|split; [|split]]; intros ex ey. - destruct (Z.ltb_spec (ex + 1 - prec) emin); destruct (Z.ltb_spec (ex - prec') emin'); destruct (Z.ltb_spec (ey - prec) emin); @@ -1775,58 +1767,58 @@ unfold double_round_plus_hyp; split; [|split; [|split]]; intros ex ey. omega. Qed. -Theorem double_round_plus_FTZ : +Theorem round_round_plus_FTZ : forall choice1 choice2, (emin' + prec' <= emin + 1)%Z -> (2 * prec + 1 <= prec')%Z -> forall x y, FTZ_format beta emin prec x -> FTZ_format beta emin prec y -> - double_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') + round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') choice1 choice2 (x + y). Proof. intros choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_plus. +apply round_round_plus. - now apply FTZ_exp_valid. - now apply FTZ_exp_valid. -- now apply FTZ_double_round_plus_hyp. +- now apply FTZ_round_round_plus_hyp. - now apply generic_format_FTZ. - now apply generic_format_FTZ. Qed. -Theorem double_round_minus_FTZ : +Theorem round_round_minus_FTZ : forall choice1 choice2, (emin' + prec' <= emin + 1)%Z -> (2 * prec + 1 <= prec')%Z -> forall x y, FTZ_format beta emin prec x -> FTZ_format beta emin prec y -> - double_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') + round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') choice1 choice2 (x - y). Proof. intros choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_minus. +apply round_round_minus. - now apply FTZ_exp_valid. - now apply FTZ_exp_valid. -- now apply FTZ_double_round_plus_hyp. +- now apply FTZ_round_round_plus_hyp. - now apply generic_format_FTZ. - now apply generic_format_FTZ. Qed. End Double_round_plus_FTZ. -Section Double_round_plus_beta_ge_3. +Section Double_round_plus_radix_ge_3. -Definition double_round_plus_beta_ge_3_hyp fexp1 fexp2 := +Definition round_round_plus_radix_ge_3_hyp fexp1 fexp2 := (forall ex ey, (fexp1 (ex + 1) <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z) /\ (forall ex ey, (fexp1 (ex - 1) + 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z) /\ (forall ex ey, (fexp1 ex <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z) /\ (forall ex ey, (ex - 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z). -(* fexp1 (ln_beta x) <= ln_beta y : +(* fexp1 (mag x) <= mag y : * addition is exact in the largest precision (fexp2). *) -Lemma double_round_plus_beta_ge_3_aux0 : +Lemma round_round_plus_radix_ge_3_aux0 : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> forall x y, (0 < y)%R -> (y <= x)%R -> - (fexp1 (ln_beta x) <= ln_beta y)%Z -> + (fexp1 (mag x) <= mag y)%Z -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> generic_format beta fexp2 (x + y). Proof. @@ -1834,84 +1826,84 @@ intros fexp1 fexp2 Vfexp1 Hexp x y Py Hyx Hln Fx Fy. assert (Px := Rlt_le_trans 0 y x Py Hyx). assert (Nny : (0 <= y)%R); [now apply Rlt_le|]. destruct Hexp as (_,(Hexp2,(Hexp3,Hexp4))). -destruct (Z.le_gt_cases (ln_beta y) (fexp1 (ln_beta x))) as [Hle|Hgt]. -- (* ln_beta y <= fexp1 (ln_beta x) *) - assert (Lxy : ln_beta (x + y) = ln_beta x :> Z); - [now apply (ln_beta_plus_separated fexp1)|]. - apply (double_round_plus_aux0_aux fexp1); +destruct (Z.le_gt_cases (mag y) (fexp1 (mag x))) as [Hle|Hgt]. +- (* mag y <= fexp1 (mag x) *) + assert (Lxy : mag (x + y) = mag x :> Z); + [now apply (mag_plus_separated fexp1)|]. + apply (round_round_plus_aux0_aux fexp1); [| |assumption|assumption]; rewrite Lxy. + now apply Hexp4; omega. + now apply Hexp3; omega. -- (* fexp1 (ln_beta x) < ln_beta y *) - apply (double_round_plus_aux0_aux fexp1); [| |assumption|assumption]. - destruct (ln_beta_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. +- (* fexp1 (mag x) < mag y *) + apply (round_round_plus_aux0_aux fexp1); [| |assumption|assumption]. + destruct (mag_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. + now apply Hexp4; omega. - + apply Hexp2; apply (ln_beta_le beta y x Py) in Hyx. - replace (_ - _)%Z with (ln_beta x : Z) by ring. + + apply Hexp2; apply (mag_le beta y x Py) in Hyx. + replace (_ - _)%Z with (mag x : Z) by ring. omega. - + destruct (ln_beta_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. + + destruct (mag_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. * now apply Hexp3; omega. * apply Hexp2. - replace (_ - _)%Z with (ln_beta x : Z) by ring. + replace (_ - _)%Z with (mag x : Z) by ring. omega. Qed. -(* ln_beta y <= fexp1 (ln_beta x) - 1 : double_round_lt_mid applies. *) -Lemma double_round_plus_beta_ge_3_aux1 : +(* mag y <= fexp1 (mag x) - 1 : round_round_lt_mid applies. *) +Lemma round_round_plus_radix_ge_3_aux1 : (3 <= beta)%Z -> forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> forall x y, 0 < x -> 0 < y -> - (ln_beta y <= fexp1 (ln_beta x) - 1)%Z -> + (mag y <= fexp1 (mag x) - 1)%Z -> generic_format beta fexp1 x -> - double_round_eq fexp1 fexp2 choice1 choice2 (x + y). + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). Proof. intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Hly Fx. -assert (Lxy : ln_beta (x + y) = ln_beta x :> Z); - [now apply (ln_beta_plus_separated fexp1); [|apply Rlt_le| |omega]|]. +assert (Lxy : mag (x + y) = mag x :> Z); + [now apply (mag_plus_separated fexp1); [|apply Rlt_le| |omega]|]. destruct Hexp as (_,(_,(_,Hexp4))). -assert (Hf2 : (fexp2 (ln_beta x) <= fexp1 (ln_beta x))%Z); +assert (Hf2 : (fexp2 (mag x) <= fexp1 (mag x))%Z); [now apply Hexp4; omega|]. assert (Bpow3 : bpow (- 1) <= / 3). -{ unfold Fcore_Raux.bpow, Z.pow_pos; simpl. +{ unfold Raux.bpow, Z.pow_pos; simpl. rewrite Zmult_1_r. apply Rinv_le; [lra|]. - now change 3 with (Z2R 3); apply Z2R_le. } + now apply IZR_le. } assert (P1 : (0 < 1)%Z) by omega. -unfold double_round_eq. -apply double_round_lt_mid. +unfold round_round_eq. +apply round_round_lt_mid. - exact Vfexp1. - exact Vfexp2. - lra. - now rewrite Lxy. - rewrite Lxy. - assert (fexp1 (ln_beta x) < ln_beta x)%Z; [|omega]. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. + assert (fexp1 (mag x) < mag x)%Z; [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. - unfold midp. apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))). - apply (Rlt_le_trans _ _ _ (proj2 (double_round_plus_aux1_aux 1 P1 fexp1 x y Px + apply (Rlt_le_trans _ _ _ (proj2 (round_round_plus_aux1_aux 1 P1 fexp1 x y Px Py Hly Lxy Fx))). ring_simplify. rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. - unfold canonic_exp; rewrite Lxy. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); + unfold cexp; rewrite Lxy. + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. bpow_simplify. apply (Rle_trans _ _ _ Bpow3); lra. - rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. - unfold round, F2R, scaled_mantissa, canonic_exp; simpl; rewrite Lxy. + unfold round, F2R, scaled_mantissa, cexp; simpl; rewrite Lxy. intro Hf2'. unfold midp. apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))); ring_simplify. rewrite <- Rmult_minus_distr_l. - apply (Rlt_le_trans _ _ _ (proj2 (double_round_plus_aux1_aux 1 P1 fexp1 x y Px + apply (Rlt_le_trans _ _ _ (proj2 (round_round_plus_aux1_aux 1 P1 fexp1 x y Px Py Hly Lxy Fx))). rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. - unfold canonic_exp; rewrite Lxy. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); + unfold cexp; rewrite Lxy. + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite (Rmult_assoc (/ 2)). rewrite Rmult_minus_distr_r. @@ -1925,47 +1917,47 @@ apply double_round_lt_mid. now apply Rle_trans with (bpow (- 1)); [apply bpow_le; omega|]. Qed. -(* double_round_plus_beta_ge_3_aux{0,1} together *) -Lemma double_round_plus_beta_ge_3_aux2 : +(* round_round_plus_radix_ge_3_aux{0,1} together *) +Lemma round_round_plus_radix_ge_3_aux2 : (3 <= beta)%Z -> forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> forall x y, 0 < y -> y <= x -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x + y). + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). Proof. intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Py Hyx Fx Fy. assert (Px := Rlt_le_trans 0 y x Py Hyx). -unfold double_round_eq. -destruct (Zle_or_lt (ln_beta y) (fexp1 (ln_beta x) - 1)) as [Hly|Hly]. -- (* ln_beta y <= fexp1 (ln_beta x) - 1 *) - now apply double_round_plus_beta_ge_3_aux1. -- (* fexp1 (ln_beta x) - 1 < ln_beta y *) +unfold round_round_eq. +destruct (Zle_or_lt (mag y) (fexp1 (mag x) - 1)) as [Hly|Hly]. +- (* mag y <= fexp1 (mag x) - 1 *) + now apply round_round_plus_radix_ge_3_aux1. +- (* fexp1 (mag x) - 1 < mag y *) rewrite (round_generic beta fexp2). + reflexivity. + now apply valid_rnd_N. - + assert (Hf1 : (fexp1 (ln_beta x) <= ln_beta y)%Z); [omega|]. - now apply (double_round_plus_beta_ge_3_aux0 fexp1). + + assert (Hf1 : (fexp1 (mag x) <= mag y)%Z); [omega|]. + now apply (round_round_plus_radix_ge_3_aux0 fexp1). Qed. -Lemma double_round_plus_beta_ge_3_aux : +Lemma round_round_plus_radix_ge_3_aux : (3 <= beta)%Z -> forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> forall x y, 0 <= x -> 0 <= y -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x + y). + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). Proof. intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Nnx Nny Fx Fy. -unfold double_round_eq. +unfold round_round_eq. destruct (Req_dec x 0) as [Zx|Nzx]. - (* x = 0 *) destruct Hexp as (_,(_,(_,Hexp4))). @@ -1973,7 +1965,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. rewrite (round_generic beta fexp2). + reflexivity. + now apply valid_rnd_N. - + apply (generic_inclusion_ln_beta beta fexp1). + + apply (generic_inclusion_mag beta fexp1). now intros _; apply Hexp4; omega. exact Fy. - (* x <> 0 *) @@ -1984,7 +1976,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. rewrite (round_generic beta fexp2). * reflexivity. * now apply valid_rnd_N. - * apply (generic_inclusion_ln_beta beta fexp1). + * apply (generic_inclusion_mag beta fexp1). now intros _; apply Hexp4; omega. exact Fx. + (* y <> 0 *) @@ -1994,156 +1986,156 @@ destruct (Req_dec x 0) as [Zx|Nzx]. * (* x < y *) apply Rlt_le in H. rewrite Rplus_comm. - now apply double_round_plus_beta_ge_3_aux2. - * now apply double_round_plus_beta_ge_3_aux2. + now apply round_round_plus_radix_ge_3_aux2. + * now apply round_round_plus_radix_ge_3_aux2. Qed. -(* fexp1 (ln_beta x) <= ln_beta y : +(* fexp1 (mag x) <= mag y : * substraction is exact in the largest precision (fexp2). *) -Lemma double_round_minus_beta_ge_3_aux0 : +Lemma round_round_minus_radix_ge_3_aux0 : forall (fexp1 fexp2 : Z -> Z), - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> forall x y, 0 < y -> y < x -> - (fexp1 (ln_beta x) <= ln_beta y)%Z -> + (fexp1 (mag x) <= mag y)%Z -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> generic_format beta fexp2 (x - y). Proof. intros fexp1 fexp2 Hexp x y Py Hyx Hln Fx Fy. assert (Px := Rlt_trans 0 y x Py Hyx). destruct Hexp as (Hexp1,(_,(Hexp3,Hexp4))). -assert (Lyx : (ln_beta y <= ln_beta x)%Z); - [now apply ln_beta_le; [|apply Rlt_le]|]. -destruct (Z.lt_ge_cases (ln_beta x - 2) (ln_beta y)) as [Hlt|Hge]. -- (* ln_beta x - 2 < ln_beta y *) - assert (Hor : (ln_beta y = ln_beta x :> Z) - \/ (ln_beta y = ln_beta x - 1 :> Z)%Z); [omega|]. +assert (Lyx : (mag y <= mag x)%Z); + [now apply mag_le; [|apply Rlt_le]|]. +destruct (Z.lt_ge_cases (mag x - 2) (mag y)) as [Hlt|Hge]. +- (* mag x - 2 < mag y *) + assert (Hor : (mag y = mag x :> Z) + \/ (mag y = mag x - 1 :> Z)%Z); [omega|]. destruct Hor as [Heq|Heqm1]. - + (* ln_beta y = ln_beta x *) - apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. + + (* mag y = mag x *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. * apply Hexp4. - apply Zle_trans with (ln_beta (x - y)); [omega|]. - now apply ln_beta_minus. + apply Z.le_trans with (mag (x - y)); [omega|]. + now apply mag_minus. * rewrite Heq. apply Hexp4. - apply Zle_trans with (ln_beta (x - y)); [omega|]. - now apply ln_beta_minus. - + (* ln_beta y = ln_beta x - 1 *) - apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. + apply Z.le_trans with (mag (x - y)); [omega|]. + now apply mag_minus. + + (* mag y = mag x - 1 *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. * apply Hexp4. - apply Zle_trans with (ln_beta (x - y)); [omega|]. - now apply ln_beta_minus. + apply Z.le_trans with (mag (x - y)); [omega|]. + now apply mag_minus. * rewrite Heqm1. apply Hexp4. apply Zplus_le_compat_r. - now apply ln_beta_minus. -- (* ln_beta y <= ln_beta x - 2 *) - destruct (ln_beta_minus_disj x y Px Py Hge) as [Lxmy|Lxmy]. - + (* ln_beta (x - y) = ln_beta x *) - apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. + now apply mag_minus. +- (* mag y <= mag x - 2 *) + destruct (mag_minus_disj x y Px Py Hge) as [Lxmy|Lxmy]. + + (* mag (x - y) = mag x *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. * apply Hexp4. omega. * now rewrite Lxmy; apply Hexp3. - + (* ln_beta (x - y) = ln_beta x - 1 *) - apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]; + + (* mag (x - y) = mag x - 1 *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]; rewrite Lxmy. * apply Hexp1. - replace (_ + _)%Z with (ln_beta x : Z); [|ring]. - now apply Zle_trans with (ln_beta y). + replace (_ + _)%Z with (mag x : Z); [|ring]. + now apply Z.le_trans with (mag y). * apply Hexp1. - now replace (_ + _)%Z with (ln_beta x : Z); [|ring]. + now replace (_ + _)%Z with (mag x : Z); [|ring]. Qed. -(* ln_beta y <= fexp1 (ln_beta x) - 1, - * fexp1 (ln_beta (x - y)) <= ln_beta y : +(* mag y <= fexp1 (mag x) - 1, + * fexp1 (mag (x - y)) <= mag y : * substraction is exact in the largest precision (fexp2). *) -Lemma double_round_minus_beta_ge_3_aux1 : +Lemma round_round_minus_radix_ge_3_aux1 : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> forall x y, 0 < y -> y < x -> - (ln_beta y <= fexp1 (ln_beta x) - 1)%Z -> - (fexp1 (ln_beta (x - y)) <= ln_beta y)%Z -> + (mag y <= fexp1 (mag x) - 1)%Z -> + (fexp1 (mag (x - y)) <= mag y)%Z -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> generic_format beta fexp2 (x - y). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 Hexp x y Py Hyx Hln Hln' Fx Fy. assert (Px := Rlt_trans 0 y x Py Hyx). destruct Hexp as (Hexp1,(Hexp2,(Hexp3,Hexp4))). -assert (Lyx : (ln_beta y <= ln_beta x)%Z); - [now apply ln_beta_le; [|apply Rlt_le]|]. -assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. -assert (Hfy : (fexp1 (ln_beta y) < ln_beta y)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. -apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. -- apply Zle_trans with (fexp1 (ln_beta (x - y))). +assert (Lyx : (mag y <= mag x)%Z); + [now apply mag_le; [|apply Rlt_le]|]. +assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfy : (fexp1 (mag y) < mag y)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. +- apply Z.le_trans with (fexp1 (mag (x - y))). + apply Hexp4; omega. + omega. - now apply Hexp3. Qed. -(* ln_beta y <= fexp1 (ln_beta x) - 1 : - * ln_beta y <= fexp1 (ln_beta (x - y)) - 1 : - * double_round_gt_mid applies. *) -Lemma double_round_minus_beta_ge_3_aux2 : +(* mag y <= fexp1 (mag x) - 1 : + * mag y <= fexp1 (mag (x - y)) - 1 : + * round_round_gt_mid applies. *) +Lemma round_round_minus_radix_ge_3_aux2 : (3 <= beta)%Z -> forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> forall x y, 0 < y -> y < x -> - (ln_beta y <= fexp1 (ln_beta x) - 1)%Z -> - (ln_beta y <= fexp1 (ln_beta (x - y)) - 1)%Z -> + (mag y <= fexp1 (mag x) - 1)%Z -> + (mag y <= fexp1 (mag (x - y)) - 1)%Z -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x - y). + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). Proof. intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Py Hxy Hly Hly' Fx Fy. assert (Px := Rlt_trans 0 y x Py Hxy). destruct Hexp as (_,(_,(_,Hexp4))). -assert (Hf2 : (fexp2 (ln_beta x) <= fexp1 (ln_beta x))%Z); +assert (Hf2 : (fexp2 (mag x) <= fexp1 (mag x))%Z); [now apply Hexp4; omega|]. -assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. assert (Bpow3 : bpow (- 1) <= / 3). -{ unfold Fcore_Raux.bpow, Z.pow_pos; simpl. +{ unfold Raux.bpow, Z.pow_pos; simpl. rewrite Zmult_1_r. apply Rinv_le; [lra|]. - now change 3 with (Z2R 3); apply Z2R_le. } -assert (Ly : y < bpow (ln_beta y)). + now apply IZR_le. } +assert (Ly : y < bpow (mag y)). { apply Rabs_lt_inv. - apply bpow_ln_beta_gt. } -unfold double_round_eq. -apply double_round_gt_mid. + apply bpow_mag_gt. } +unfold round_round_eq. +apply round_round_gt_mid. - exact Vfexp1. - exact Vfexp2. - lra. - apply Hexp4; omega. -- assert (fexp1 (ln_beta (x - y)) < ln_beta (x - y))%Z; [|omega]. - apply (valid_exp_large fexp1 (ln_beta x - 1)). - + apply (valid_exp_large fexp1 (ln_beta y)); [|omega]. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. - + now apply ln_beta_minus_lb; [| |omega]. +- assert (fexp1 (mag (x - y)) < mag (x - y))%Z; [|omega]. + apply (valid_exp_large fexp1 (mag x - 1)). + + apply (valid_exp_large fexp1 (mag y)); [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. + + now apply mag_minus_lb; [| |omega]. - unfold midp'. apply (Rplus_lt_reg_r (/ 2 * ulp beta fexp1 (x - y) - (x - y))). ring_simplify. replace (_ + _) with (round beta fexp1 Zceil (x - y) - (x - y)) by ring. - apply Rlt_le_trans with (bpow (fexp1 (ln_beta (x - y)) - 1)). + apply Rlt_le_trans with (bpow (fexp1 (mag (x - y)) - 1)). + apply Rle_lt_trans with y; - [now apply double_round_minus_aux2_aux|]. + [now apply round_round_minus_aux2_aux|]. apply (Rlt_le_trans _ _ _ Ly). now apply bpow_le. + rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rgt_minus]. - unfold canonic_exp. + unfold cexp. unfold Zminus at 1; rewrite bpow_plus. rewrite Rmult_comm. apply Rmult_le_compat_r; [now apply bpow_ge_0|]. - unfold Fcore_Raux.bpow, Z.pow_pos; simpl. + unfold Raux.bpow, Z.pow_pos; simpl. rewrite Zmult_1_r; apply Rinv_le; [lra|]. - now change 2 with (Z2R 2); apply Z2R_le; omega. + now apply IZR_le; omega. - intro Hf2'. unfold midp'. apply (Rplus_lt_reg_r (/ 2 * (ulp beta fexp1 (x - y) @@ -2151,21 +2143,21 @@ apply double_round_gt_mid. ring_simplify; rewrite <- Rmult_minus_distr_l. replace (_ + _) with (round beta fexp1 Zceil (x - y) - (x - y)) by ring. apply Rle_lt_trans with y; - [now apply double_round_minus_aux2_aux|]. + [now apply round_round_minus_aux2_aux|]. apply (Rlt_le_trans _ _ _ Ly). - apply Rle_trans with (bpow (fexp1 (ln_beta (x - y)) - 1)); + apply Rle_trans with (bpow (fexp1 (mag (x - y)) - 1)); [now apply bpow_le|]. rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, Rgt_minus. - unfold canonic_exp. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta (x - y))))); + unfold cexp. + apply (Rmult_le_reg_r (bpow (- fexp1 (mag (x - y))))); [now apply bpow_gt_0|]. rewrite Rmult_assoc. rewrite Rmult_minus_distr_r. bpow_simplify. apply Rle_trans with (/ 3). - + unfold Fcore_Raux.bpow, Z.pow_pos; simpl. + + unfold Raux.bpow, Z.pow_pos; simpl. rewrite Zmult_1_r; apply Rinv_le; [lra|]. - now change 3 with (Z2R 3); apply Z2R_le. + now apply IZR_le. + replace (/ 3) with (/ 2 * (2 / 3)) by field. apply Rmult_le_compat_l; [lra|]. apply (Rplus_le_reg_r (- 1)); ring_simplify. @@ -2173,27 +2165,27 @@ apply double_round_gt_mid. apply Ropp_le_contravar. apply Rle_trans with (bpow (- 1)). * apply bpow_le; omega. - * unfold Fcore_Raux.bpow, Z.pow_pos; simpl. + * unfold Raux.bpow, Z.pow_pos; simpl. rewrite Zmult_1_r; apply Rinv_le; [lra|]. - now change 3 with (Z2R 3); apply Z2R_le. + now apply IZR_le. Qed. -(* double_round_minus_aux{0,1,2} together *) -Lemma double_round_minus_beta_ge_3_aux3 : +(* round_round_minus_aux{0,1,2} together *) +Lemma round_round_minus_radix_ge_3_aux3 : (3 <= beta)%Z -> forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> forall x y, 0 < y -> y <= x -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x - y). + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). Proof. intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Py Hyx Fx Fy. assert (Px := Rlt_le_trans 0 y x Py Hyx). -unfold double_round_eq. +unfold round_round_eq. destruct (Req_dec y x) as [Hy|Hy]. - (* y = x *) rewrite Hy; replace (x - x) with 0 by ring. @@ -2202,39 +2194,39 @@ destruct (Req_dec y x) as [Hy|Hy]. + now apply valid_rnd_N. - (* y < x *) assert (Hyx' : y < x); [lra|]. - destruct (Zle_or_lt (ln_beta y) (fexp1 (ln_beta x) - 1)) as [Hly|Hly]. - + (* ln_beta y <= fexp1 (ln_beta x) - 1 *) - destruct (Zle_or_lt (ln_beta y) (fexp1 (ln_beta (x - y)) - 1)) + destruct (Zle_or_lt (mag y) (fexp1 (mag x) - 1)) as [Hly|Hly]. + + (* mag y <= fexp1 (mag x) - 1 *) + destruct (Zle_or_lt (mag y) (fexp1 (mag (x - y)) - 1)) as [Hly'|Hly']. - * (* ln_beta y <= fexp1 (ln_beta (x - y)) - 1 *) - now apply double_round_minus_beta_ge_3_aux2. - * (* fexp1 (ln_beta (x - y)) - 1 < ln_beta y *) + * (* mag y <= fexp1 (mag (x - y)) - 1 *) + now apply round_round_minus_radix_ge_3_aux2. + * (* fexp1 (mag (x - y)) - 1 < mag y *) { rewrite (round_generic beta fexp2). - reflexivity. - now apply valid_rnd_N. - - assert (Hf1 : (fexp1 (ln_beta (x - y)) <= ln_beta y)%Z); [omega|]. - now apply (double_round_minus_beta_ge_3_aux1 fexp1). } + - assert (Hf1 : (fexp1 (mag (x - y)) <= mag y)%Z); [omega|]. + now apply (round_round_minus_radix_ge_3_aux1 fexp1). } + rewrite (round_generic beta fexp2). * reflexivity. * now apply valid_rnd_N. - * assert (Hf1 : (fexp1 (ln_beta x) <= ln_beta y)%Z); [omega|]. - now apply (double_round_minus_beta_ge_3_aux0 fexp1). + * assert (Hf1 : (fexp1 (mag x) <= mag y)%Z); [omega|]. + now apply (round_round_minus_radix_ge_3_aux0 fexp1). Qed. -Lemma double_round_minus_beta_ge_3_aux : +Lemma round_round_minus_radix_ge_3_aux : (3 <= beta)%Z -> forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> forall x y, 0 <= x -> 0 <= y -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x - y). + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). Proof. intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Nnx Nny Fx Fy. -unfold double_round_eq. +unfold round_round_eq. destruct (Req_dec x 0) as [Zx|Nzx]. - (* x = 0 *) rewrite Zx; unfold Rminus; rewrite Rplus_0_l. @@ -2242,7 +2234,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. rewrite (round_generic beta fexp2). * reflexivity. * now apply valid_rnd_N. - * apply (generic_inclusion_ln_beta beta fexp1). + * apply (generic_inclusion_mag beta fexp1). destruct Hexp as (_,(_,(_,Hexp4))). now intros _; apply Hexp4; omega. exact Fy. @@ -2253,7 +2245,7 @@ destruct (Req_dec x 0) as [Zx|Nzx]. rewrite (round_generic beta fexp2). * reflexivity. * now apply valid_rnd_N. - * apply (generic_inclusion_ln_beta beta fexp1). + * apply (generic_inclusion_mag beta fexp1). destruct Hexp as (_,(_,(_,Hexp4))). now intros _; apply Hexp4; omega. exact Fx. @@ -2266,24 +2258,24 @@ destruct (Req_dec x 0) as [Zx|Nzx]. replace (x - y) with (- (y - x)) by ring. do 3 rewrite round_N_opp. apply Ropp_eq_compat. - now apply double_round_minus_beta_ge_3_aux3. + now apply round_round_minus_radix_ge_3_aux3. * (* y <= x *) - now apply double_round_minus_beta_ge_3_aux3. + now apply round_round_minus_radix_ge_3_aux3. Qed. -Lemma double_round_plus_beta_ge_3 : +Lemma round_round_plus_radix_ge_3 : (3 <= beta)%Z -> forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> forall x y, generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x + y). + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). Proof. intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Fx Fy. -unfold double_round_eq. +unfold round_round_eq. destruct (Rlt_or_le x 0) as [Sx|Sx]; destruct (Rlt_or_le y 0) as [Sy|Sy]. - (* x < 0, y < 0 *) replace (x + y) with (- (- x - y)); [|ring]. @@ -2293,41 +2285,39 @@ destruct (Rlt_or_le x 0) as [Sx|Sx]; destruct (Rlt_or_le y 0) as [Sy|Sy]. assert (Py : 0 <= - y); [lra|]. apply generic_format_opp in Fx. apply generic_format_opp in Fy. - now apply double_round_plus_beta_ge_3_aux. + now apply round_round_plus_radix_ge_3_aux. - (* x < 0, 0 <= y *) replace (x + y) with (y - (- x)); [|ring]. assert (Px : 0 <= - x); [lra|]. apply generic_format_opp in Fx. - now apply double_round_minus_beta_ge_3_aux. + now apply round_round_minus_radix_ge_3_aux. - (* 0 <= x, y < 0 *) replace (x + y) with (x - (- y)); [|ring]. assert (Py : 0 <= - y); [lra|]. apply generic_format_opp in Fy. - now apply double_round_minus_beta_ge_3_aux. + now apply round_round_minus_radix_ge_3_aux. - (* 0 <= x, 0 <= y *) - now apply double_round_plus_beta_ge_3_aux. + now apply round_round_plus_radix_ge_3_aux. Qed. -Lemma double_round_minus_beta_ge_3 : +Lemma round_round_minus_radix_ge_3 : (3 <= beta)%Z -> forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> forall x y, generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x - y). + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). Proof. intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Fx Fy. unfold Rminus. apply generic_format_opp in Fy. -now apply double_round_plus_beta_ge_3. +now apply round_round_plus_radix_ge_3. Qed. -Section Double_round_plus_beta_ge_3_FLX. - -Import Fcore_FLX. +Section Double_round_plus_radix_ge_3_FLX. Variable prec : Z. Variable prec' : Z. @@ -2335,60 +2325,57 @@ Variable prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FLX_double_round_plus_beta_ge_3_hyp : +Lemma FLX_round_round_plus_radix_ge_3_hyp : (2 * prec <= prec')%Z -> - double_round_plus_beta_ge_3_hyp (FLX_exp prec) (FLX_exp prec'). + round_round_plus_radix_ge_3_hyp (FLX_exp prec) (FLX_exp prec'). Proof. intros Hprec. unfold FLX_exp. -unfold double_round_plus_beta_ge_3_hyp; split; [|split; [|split]]; +unfold round_round_plus_radix_ge_3_hyp; split; [|split; [|split]]; intros ex ey; try omega. unfold Prec_gt_0 in prec_gt_0_. omega. Qed. -Theorem double_round_plus_beta_ge_3_FLX : +Theorem round_round_plus_radix_ge_3_FLX : (3 <= beta)%Z -> forall choice1 choice2, (2 * prec <= prec')%Z -> forall x y, FLX_format beta prec x -> FLX_format beta prec y -> - double_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x + y). + round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x + y). Proof. intros Hbeta choice1 choice2 Hprec x y Fx Fy. -apply double_round_plus_beta_ge_3. +apply round_round_plus_radix_ge_3. - exact Hbeta. - now apply FLX_exp_valid. - now apply FLX_exp_valid. -- now apply FLX_double_round_plus_beta_ge_3_hyp. +- now apply FLX_round_round_plus_radix_ge_3_hyp. - now apply generic_format_FLX. - now apply generic_format_FLX. Qed. -Theorem double_round_minus_beta_ge_3_FLX : +Theorem round_round_minus_radix_ge_3_FLX : (3 <= beta)%Z -> forall choice1 choice2, (2 * prec <= prec')%Z -> forall x y, FLX_format beta prec x -> FLX_format beta prec y -> - double_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x - y). + round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x - y). Proof. intros Hbeta choice1 choice2 Hprec x y Fx Fy. -apply double_round_minus_beta_ge_3. +apply round_round_minus_radix_ge_3. - exact Hbeta. - now apply FLX_exp_valid. - now apply FLX_exp_valid. -- now apply FLX_double_round_plus_beta_ge_3_hyp. +- now apply FLX_round_round_plus_radix_ge_3_hyp. - now apply generic_format_FLX. - now apply generic_format_FLX. Qed. -End Double_round_plus_beta_ge_3_FLX. - -Section Double_round_plus_beta_ge_3_FLT. +End Double_round_plus_radix_ge_3_FLX. -Import Fcore_FLX. -Import Fcore_FLT. +Section Double_round_plus_radix_ge_3_FLT. Variable emin prec : Z. Variable emin' prec' : Z. @@ -2396,13 +2383,13 @@ Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FLT_double_round_plus_beta_ge_3_hyp : +Lemma FLT_round_round_plus_radix_ge_3_hyp : (emin' <= emin)%Z -> (2 * prec <= prec')%Z -> - double_round_plus_beta_ge_3_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). + round_round_plus_radix_ge_3_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). Proof. intros Hemin Hprec. unfold FLT_exp. -unfold double_round_plus_beta_ge_3_hyp; split; [|split; [|split]]; intros ex ey. +unfold round_round_plus_radix_ge_3_hyp; split; [|split; [|split]]; intros ex ey. - generalize (Zmax_spec (ex + 1 - prec) emin). generalize (Zmax_spec (ex - prec') emin'). generalize (Zmax_spec (ey - prec) emin). @@ -2421,50 +2408,47 @@ unfold double_round_plus_beta_ge_3_hyp; split; [|split; [|split]]; intros ex ey. omega. Qed. -Theorem double_round_plus_beta_ge_3_FLT : +Theorem round_round_plus_radix_ge_3_FLT : (3 <= beta)%Z -> forall choice1 choice2, (emin' <= emin)%Z -> (2 * prec <= prec')%Z -> forall x y, FLT_format beta emin prec x -> FLT_format beta emin prec y -> - double_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') + round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') choice1 choice2 (x + y). Proof. intros Hbeta choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_plus_beta_ge_3. +apply round_round_plus_radix_ge_3. - exact Hbeta. - now apply FLT_exp_valid. - now apply FLT_exp_valid. -- now apply FLT_double_round_plus_beta_ge_3_hyp. +- now apply FLT_round_round_plus_radix_ge_3_hyp. - now apply generic_format_FLT. - now apply generic_format_FLT. Qed. -Theorem double_round_minus_beta_ge_3_FLT : +Theorem round_round_minus_radix_ge_3_FLT : (3 <= beta)%Z -> forall choice1 choice2, (emin' <= emin)%Z -> (2 * prec <= prec')%Z -> forall x y, FLT_format beta emin prec x -> FLT_format beta emin prec y -> - double_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') + round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') choice1 choice2 (x - y). Proof. intros Hbeta choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_minus_beta_ge_3. +apply round_round_minus_radix_ge_3. - exact Hbeta. - now apply FLT_exp_valid. - now apply FLT_exp_valid. -- now apply FLT_double_round_plus_beta_ge_3_hyp. +- now apply FLT_round_round_plus_radix_ge_3_hyp. - now apply generic_format_FLT. - now apply generic_format_FLT. Qed. -End Double_round_plus_beta_ge_3_FLT. +End Double_round_plus_radix_ge_3_FLT. -Section Double_round_plus_beta_ge_3_FTZ. - -Import Fcore_FLX. -Import Fcore_FTZ. +Section Double_round_plus_radix_ge_3_FTZ. Variable emin prec : Z. Variable emin' prec' : Z. @@ -2472,14 +2456,14 @@ Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FTZ_double_round_plus_beta_ge_3_hyp : +Lemma FTZ_round_round_plus_radix_ge_3_hyp : (emin' + prec' <= emin + 1)%Z -> (2 * prec <= prec')%Z -> - double_round_plus_beta_ge_3_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). + round_round_plus_radix_ge_3_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). Proof. intros Hemin Hprec. unfold FTZ_exp. unfold Prec_gt_0 in *. -unfold double_round_plus_beta_ge_3_hyp; split; [|split; [|split]]; intros ex ey. +unfold round_round_plus_radix_ge_3_hyp; split; [|split; [|split]]; intros ex ey. - destruct (Z.ltb_spec (ex + 1 - prec) emin); destruct (Z.ltb_spec (ex - prec') emin'); destruct (Z.ltb_spec (ey - prec) emin); @@ -2497,64 +2481,64 @@ unfold double_round_plus_beta_ge_3_hyp; split; [|split; [|split]]; intros ex ey. omega. Qed. -Theorem double_round_plus_beta_ge_3_FTZ : +Theorem round_round_plus_radix_ge_3_FTZ : (3 <= beta)%Z -> forall choice1 choice2, (emin' + prec' <= emin + 1)%Z -> (2 * prec <= prec')%Z -> forall x y, FTZ_format beta emin prec x -> FTZ_format beta emin prec y -> - double_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') + round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') choice1 choice2 (x + y). Proof. intros Hbeta choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_plus_beta_ge_3. +apply round_round_plus_radix_ge_3. - exact Hbeta. - now apply FTZ_exp_valid. - now apply FTZ_exp_valid. -- now apply FTZ_double_round_plus_beta_ge_3_hyp. +- now apply FTZ_round_round_plus_radix_ge_3_hyp. - now apply generic_format_FTZ. - now apply generic_format_FTZ. Qed. -Theorem double_round_minus_beta_ge_3_FTZ : +Theorem round_round_minus_radix_ge_3_FTZ : (3 <= beta)%Z -> forall choice1 choice2, (emin' + prec' <= emin + 1)%Z -> (2 * prec <= prec')%Z -> forall x y, FTZ_format beta emin prec x -> FTZ_format beta emin prec y -> - double_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') + round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') choice1 choice2 (x - y). Proof. intros Hbeta choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_minus_beta_ge_3. +apply round_round_minus_radix_ge_3. - exact Hbeta. - now apply FTZ_exp_valid. - now apply FTZ_exp_valid. -- now apply FTZ_double_round_plus_beta_ge_3_hyp. +- now apply FTZ_round_round_plus_radix_ge_3_hyp. - now apply generic_format_FTZ. - now apply generic_format_FTZ. Qed. -End Double_round_plus_beta_ge_3_FTZ. +End Double_round_plus_radix_ge_3_FTZ. -End Double_round_plus_beta_ge_3. +End Double_round_plus_radix_ge_3. End Double_round_plus. -Lemma double_round_mid_cases : +Lemma round_round_mid_cases : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z -> - (fexp1 (ln_beta x) <= ln_beta x)%Z -> + (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> + (fexp1 (mag x) <= mag x)%Z -> (Rabs (x - midp fexp1 x) <= / 2 * (ulp beta fexp2 x) -> - double_round_eq fexp1 fexp2 choice1 choice2 x) -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + round_round_eq fexp1 fexp2 choice1 choice2 x) -> + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hf1. -unfold double_round_eq, midp. +unfold round_round_eq, midp. set (rd := round beta fexp1 Zfloor x). set (u1 := ulp beta fexp1 x). set (u2 := ulp beta fexp2 x). @@ -2562,14 +2546,14 @@ intros Cmid. destruct (generic_format_EM beta fexp1 x) as [Fx|Nfx]. - (* generic_format beta fexp1 x *) rewrite (round_generic beta fexp2); [reflexivity|now apply valid_rnd_N|]. - now apply (generic_inclusion_ln_beta beta fexp1); [omega|]. + now apply (generic_inclusion_mag beta fexp1); [omega|]. - (* ~ generic_format beta fexp1 x *) assert (Hceil : round beta fexp1 Zceil x = rd + u1); [now apply round_UP_DN_ulp|]. - assert (Hf2' : (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z); [omega|]. + assert (Hf2' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z); [omega|]. destruct (Rlt_or_le (x - rd) (/ 2 * (u1 - u2))). + (* x - rd < / 2 * (u1 - u2) *) - apply double_round_lt_mid_further_place; try assumption. + apply round_round_lt_mid_further_place; try assumption. unfold midp. fold rd; fold u1; fold u2. apply (Rplus_lt_reg_r (- rd)); ring_simplify. now rewrite <- Rmult_minus_distr_l. @@ -2580,7 +2564,7 @@ destruct (generic_format_EM beta fexp1 x) as [Fx|Nfx]. < / 2 * (ulp beta fexp1 x - ulp beta fexp2 x)). { rewrite Hceil; fold u1; fold u2. lra. } - apply double_round_gt_mid_further_place; try assumption. + apply round_round_gt_mid_further_place; try assumption. unfold midp'; lra. - (* x - rd <= / 2 * (u1 + u2) *) apply Cmid, Rabs_le; split; lra. } @@ -2588,31 +2572,31 @@ Qed. Section Double_round_sqrt. -Definition double_round_sqrt_hyp fexp1 fexp2 := +Definition round_round_sqrt_hyp fexp1 fexp2 := (forall ex, (2 * fexp1 ex <= fexp1 (2 * ex))%Z) /\ (forall ex, (2 * fexp1 ex <= fexp1 (2 * ex - 1))%Z) /\ (forall ex, (fexp1 (2 * ex) < 2 * ex)%Z -> (fexp2 ex + ex <= 2 * fexp1 ex - 2)%Z). -Lemma ln_beta_sqrt_disj : +Lemma mag_sqrt_disj : forall x, 0 < x -> - (ln_beta x = 2 * ln_beta (sqrt x) - 1 :> Z)%Z - \/ (ln_beta x = 2 * ln_beta (sqrt x) :> Z)%Z. + (mag x = 2 * mag (sqrt x) - 1 :> Z)%Z + \/ (mag x = 2 * mag (sqrt x) :> Z)%Z. Proof. intros x Px. -generalize (ln_beta_sqrt beta x Px). -intro H. -omega. +rewrite (mag_sqrt beta x Px). +generalize (Zdiv2_odd_eqn (mag x + 1)). +destruct Z.odd ; intros ; omega. Qed. -Lemma double_round_sqrt_aux : +Lemma round_round_sqrt_aux : forall fexp1 fexp2 : Z -> Z, Valid_exp fexp1 -> Valid_exp fexp2 -> - double_round_sqrt_hyp fexp1 fexp2 -> + round_round_sqrt_hyp fexp1 fexp2 -> forall x, 0 < x -> - (fexp2 (ln_beta (sqrt x)) <= fexp1 (ln_beta (sqrt x)) - 1)%Z -> + (fexp2 (mag (sqrt x)) <= fexp1 (mag (sqrt x)) - 1)%Z -> generic_format beta fexp1 x -> / 2 * ulp beta fexp2 (sqrt x) < Rabs (sqrt x - midp fexp1 (sqrt x)). Proof. @@ -2621,8 +2605,8 @@ assert (Hbeta : (2 <= beta)%Z). { destruct beta as (beta_val,beta_prop). now apply Zle_bool_imp_le. } set (a := round beta fexp1 Zfloor (sqrt x)). -set (u1 := bpow (fexp1 (ln_beta (sqrt x)))). -set (u2 := bpow (fexp2 (ln_beta (sqrt x)))). +set (u1 := bpow (fexp1 (mag (sqrt x)))). +set (u2 := bpow (fexp2 (mag (sqrt x)))). set (b := / 2 * (u1 - u2)). set (b' := / 2 * (u1 + u2)). unfold midp; rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, sqrt_lt_R0. @@ -2633,9 +2617,9 @@ assert (Fa : generic_format beta fexp1 a). - exact Vfexp1. - now apply valid_rnd_DN. } revert Fa; revert Fx. -unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl. -set (mx := Ztrunc (x * bpow (- fexp1 (ln_beta x)))). -set (ma := Ztrunc (a * bpow (- fexp1 (ln_beta a)))). +unfold generic_format, F2R, scaled_mantissa, cexp; simpl. +set (mx := Ztrunc (x * bpow (- fexp1 (mag x)))). +set (ma := Ztrunc (a * bpow (- fexp1 (mag a)))). intros Fx Fa. assert (Nna : 0 <= a). { rewrite <- (round_0 beta fexp1 Zfloor). @@ -2666,14 +2650,14 @@ assert (Hl : a + b <= sqrt x). replace (_ + sqrt _) with (sqrt x - (a + / 2 * u1)) by ring. rewrite Ropp_mult_distr_l_reverse. now apply Rabs_le_inv in H; destruct H. } -assert (Hf1 : (2 * fexp1 (ln_beta (sqrt x)) <= fexp1 (ln_beta (x)))%Z); - [destruct (ln_beta_sqrt_disj x Px) as [H'|H']; rewrite H'; apply Hexp|]. -assert (Hlx : (fexp1 (2 * ln_beta (sqrt x)) < 2 * ln_beta (sqrt x))%Z). -{ destruct (ln_beta_sqrt_disj x Px) as [Hlx|Hlx]. - - apply (valid_exp_large fexp1 (ln_beta x)); [|omega]. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. +assert (Hf1 : (2 * fexp1 (mag (sqrt x)) <= fexp1 (mag (x)))%Z); + [destruct (mag_sqrt_disj x Px) as [H'|H']; rewrite H'; apply Hexp|]. +assert (Hlx : (fexp1 (2 * mag (sqrt x)) < 2 * mag (sqrt x))%Z). +{ destruct (mag_sqrt_disj x Px) as [Hlx|Hlx]. + - apply (valid_exp_large fexp1 (mag x)); [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. - rewrite <- Hlx. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. } + now apply mag_generic_gt; [|apply Rgt_not_eq|]. } assert (Hsl : a * a + u1 * a - u2 * a + b * b <= x). { replace (_ + _) with ((a + b) * (a + b)); [|now unfold b; field]. rewrite <- sqrt_def; [|now apply Rlt_le]. @@ -2692,34 +2676,33 @@ destruct (Req_dec a 0) as [Za|Nza]. + revert Hsl; unfold Rminus; rewrite Za; do 3 rewrite Rmult_0_r. now rewrite Ropp_0; do 3 rewrite Rplus_0_l. + rewrite Fx. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_0_l; bpow_simplify. unfold mx. rewrite Ztrunc_floor; [|now apply Rmult_le_pos; [apply Rlt_le|apply bpow_ge_0]]. - apply Req_le. - change 0 with (Z2R 0); apply f_equal. + apply Req_le, IZR_eq. apply Zfloor_imp. split; [now apply Rmult_le_pos; [apply Rlt_le|apply bpow_ge_0]|simpl]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_1_l; bpow_simplify. - apply Rlt_le_trans with (bpow (2 * fexp1 (ln_beta (sqrt x)))); + apply Rlt_le_trans with (bpow (2 * fexp1 (mag (sqrt x)))); [|now apply bpow_le]. change 2%Z with (1 + 1)%Z; rewrite Zmult_plus_distr_l; rewrite Zmult_1_l. rewrite bpow_plus. rewrite <- (sqrt_def x) at 1; [|now apply Rlt_le]. - assert (sqrt x < bpow (fexp1 (ln_beta (sqrt x)))); + assert (sqrt x < bpow (fexp1 (mag (sqrt x)))); [|now apply Rmult_lt_compat; [apply sqrt_pos|apply sqrt_pos| |]]. apply (Rle_lt_trans _ _ _ Hr); rewrite Za; rewrite Rplus_0_l. unfold b'; change (bpow _) with u1. apply Rlt_le_trans with (/ 2 * (u1 + u1)); [|lra]. apply Rmult_lt_compat_l; [lra|]; apply Rplus_lt_compat_l. - unfold u2, u1, ulp, canonic_exp; apply bpow_lt; omega. + unfold u2, u1, ulp, cexp; apply bpow_lt; omega. - (* a <> 0 *) assert (Pa : 0 < a); [lra|]. - assert (Hla : (ln_beta a = ln_beta (sqrt x) :> Z)). - { unfold a; apply ln_beta_DN. + assert (Hla : (mag a = mag (sqrt x) :> Z)). + { unfold a; apply mag_DN. - exact Vfexp1. - now fold a. } assert (Hl' : 0 < - (u2 * a) + b * b). @@ -2728,60 +2711,60 @@ destruct (Req_dec a 0) as [Za|Nza]. apply (Rplus_lt_reg_r (/ 2 * u2 * u1)); field_simplify. replace (_ / 2) with (u2 * (a + / 2 * u1)) by field. replace (_ / 8) with (/ 4 * (u2 ^ 2 + u1 ^ 2)) by field. - apply Rlt_le_trans with (u2 * bpow (ln_beta (sqrt x))). + apply Rlt_le_trans with (u2 * bpow (mag (sqrt x))). - apply Rmult_lt_compat_l; [now unfold u2, ulp; apply bpow_gt_0|]. unfold u1; rewrite <- Hla. - apply Rlt_le_trans with (a + bpow (fexp1 (ln_beta a))). + apply Rlt_le_trans with (a + bpow (fexp1 (mag a))). + apply Rplus_lt_compat_l. rewrite <- (Rmult_1_l (bpow _)) at 2. apply Rmult_lt_compat_r; [apply bpow_gt_0|lra]. + apply Rle_trans with (a+ ulp beta fexp1 a). right; now rewrite ulp_neq_0. apply (id_p_ulp_le_bpow _ _ _ _ Pa Fa). - apply Rabs_lt_inv, bpow_ln_beta_gt. + apply Rabs_lt_inv, bpow_mag_gt. - apply Rle_trans with (bpow (- 2) * u1 ^ 2). + unfold pow; rewrite Rmult_1_r. - unfold u1, u2, ulp, canonic_exp; bpow_simplify; apply bpow_le. + unfold u1, u2, ulp, cexp; bpow_simplify; apply bpow_le. now apply Hexp. + apply Rmult_le_compat. * apply bpow_ge_0. * apply pow2_ge_0. - * unfold Fcore_Raux.bpow, Z.pow_pos; simpl; rewrite Zmult_1_r. + * unfold Raux.bpow, Z.pow_pos; simpl; rewrite Zmult_1_r. apply Rinv_le; [lra|]. - change 4 with (Z2R (2 * 2)%Z); apply Z2R_le, Zmult_le_compat; omega. + change 4%Z with (2 * 2)%Z; apply IZR_le, Zmult_le_compat; omega. * rewrite <- (Rplus_0_l (u1 ^ 2)) at 1; apply Rplus_le_compat_r. apply pow2_ge_0. } assert (Hr' : x <= a * a + u1 * a). { rewrite Hla in Fa. rewrite <- Rmult_plus_distr_r. - unfold u1, ulp, canonic_exp. + unfold u1, ulp, cexp. rewrite <- (Rmult_1_l (bpow _)); rewrite Fa; rewrite <- Rmult_plus_distr_r. - rewrite <- Rmult_assoc; rewrite (Rmult_comm _ (Z2R ma)). - rewrite <- (Rmult_assoc (Z2R ma)); bpow_simplify. - apply (Rmult_le_reg_r (bpow (- 2 * fexp1 (ln_beta (sqrt x))))); + rewrite <- Rmult_assoc; rewrite (Rmult_comm _ (IZR ma)). + rewrite <- (Rmult_assoc (IZR ma)); bpow_simplify. + apply (Rmult_le_reg_r (bpow (- 2 * fexp1 (mag (sqrt x))))); [now apply bpow_gt_0|bpow_simplify]. rewrite Fx at 1; bpow_simplify. - rewrite <- Z2R_Zpower; [|omega]. - change 1 with (Z2R 1); rewrite <- Z2R_plus; do 2 rewrite <- Z2R_mult. - apply Z2R_le, Zlt_succ_le, lt_Z2R. - unfold Z.succ; rewrite Z2R_plus; do 2 rewrite Z2R_mult; rewrite Z2R_plus. - rewrite Z2R_Zpower; [|omega]. - apply (Rmult_lt_reg_r (bpow (2 * fexp1 (ln_beta (sqrt x))))); + rewrite <- IZR_Zpower; [|omega]. + rewrite <- plus_IZR, <- 2!mult_IZR. + apply IZR_le, Zlt_succ_le, lt_IZR. + unfold Z.succ; rewrite plus_IZR; do 2 rewrite mult_IZR; rewrite plus_IZR. + rewrite IZR_Zpower; [|omega]. + apply (Rmult_lt_reg_r (bpow (2 * fexp1 (mag (sqrt x))))); [now apply bpow_gt_0|bpow_simplify]. rewrite <- Fx. change 2%Z with (1 + 1)%Z; rewrite Zmult_plus_distr_l; rewrite Zmult_1_l. rewrite bpow_plus; simpl. replace (_ * _) with (a * a + u1 * a + u1 * u1); - [|unfold u1, ulp, canonic_exp; rewrite Fa; ring]. + [|unfold u1, ulp, cexp; rewrite Fa; ring]. apply (Rle_lt_trans _ _ _ Hsr). rewrite Rplus_assoc; apply Rplus_lt_compat_l. apply (Rplus_lt_reg_r (- b' * b' + / 2 * u1 * u2)); ring_simplify. replace (_ + _) with ((a + / 2 * u1) * u2) by ring. - apply Rlt_le_trans with (bpow (ln_beta (sqrt x)) * u2). + apply Rlt_le_trans with (bpow (mag (sqrt x)) * u2). - apply Rmult_lt_compat_r; [now unfold u2, ulp; apply bpow_gt_0|]. apply Rlt_le_trans with (a + u1); [lra|]. - unfold u1; fold (canonic_exp beta fexp1 (sqrt x)). - rewrite <- canonic_exp_DN; [|exact Vfexp1|exact Pa]; fold a. + unfold u1; fold (cexp beta fexp1 (sqrt x)). + rewrite <- cexp_DN; [|exact Vfexp1|exact Pa]; fold a. rewrite <- ulp_neq_0; trivial. apply id_p_ulp_le_bpow. + exact Pa. @@ -2789,27 +2772,27 @@ destruct (Req_dec a 0) as [Za|Nza]. + apply Rle_lt_trans with (sqrt x). * now apply round_DN_pt. * apply Rabs_lt_inv. - apply bpow_ln_beta_gt. + apply bpow_mag_gt. - apply Rle_trans with (/ 2 * u1 ^ 2). + apply Rle_trans with (bpow (- 2) * u1 ^ 2). * unfold pow; rewrite Rmult_1_r. - unfold u2, u1, ulp, canonic_exp. + unfold u2, u1, ulp, cexp. bpow_simplify. apply bpow_le. rewrite Zplus_comm. now apply Hexp. * apply Rmult_le_compat_r; [now apply pow2_ge_0|]. - unfold Fcore_Raux.bpow; simpl; unfold Z.pow_pos; simpl. + unfold Raux.bpow; simpl; unfold Z.pow_pos; simpl. rewrite Zmult_1_r. apply Rinv_le; [lra|]. - change 2 with (Z2R 2); apply Z2R_le. + apply IZR_le. rewrite <- (Zmult_1_l 2). apply Zmult_le_compat; omega. + assert (u2 ^ 2 < u1 ^ 2); [|unfold b'; lra]. unfold pow; do 2 rewrite Rmult_1_r. assert (H' : 0 <= u2); [unfold u2, ulp; apply bpow_ge_0|]. assert (u2 < u1); [|now apply Rmult_lt_compat]. - unfold u1, u2, ulp, canonic_exp; apply bpow_lt; omega. } + unfold u1, u2, ulp, cexp; apply bpow_lt; omega. } apply (Rlt_irrefl (a * a + u1 * a)). apply Rlt_le_trans with (a * a + u1 * a - u2 * a + b * b). + rewrite <- (Rplus_0_r (a * a + _)) at 1. @@ -2819,29 +2802,29 @@ destruct (Req_dec a 0) as [Za|Nza]. Qed. -Lemma double_round_sqrt : +Lemma round_round_sqrt : forall fexp1 fexp2 : Z -> Z, Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_sqrt_hyp fexp1 fexp2 -> + round_round_sqrt_hyp fexp1 fexp2 -> forall x, generic_format beta fexp1 x -> - double_round_eq fexp1 fexp2 choice1 choice2 (sqrt x). + round_round_eq fexp1 fexp2 choice1 choice2 (sqrt x). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x Fx. -unfold double_round_eq. +unfold round_round_eq. destruct (Rle_or_lt x 0) as [Npx|Px]. - (* x <= 0 *) rewrite (sqrt_neg _ Npx). now rewrite round_0; [|apply valid_rnd_N]. - (* 0 < x *) - assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z); - [now apply ln_beta_generic_gt; try assumption; lra|]. - assert (Hfsx : (fexp1 (ln_beta (sqrt x)) < ln_beta (sqrt x))%Z). + assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; try assumption; lra|]. + assert (Hfsx : (fexp1 (mag (sqrt x)) < mag (sqrt x))%Z). { destruct (Rle_or_lt x 1) as [Hx|Hx]. - (* x <= 1 *) - apply (valid_exp_large fexp1 (ln_beta x)); [exact Hfx|]. - apply ln_beta_le; [exact Px|]. + apply (valid_exp_large fexp1 (mag x)); [exact Hfx|]. + apply mag_le; [exact Px|]. rewrite <- (sqrt_def x) at 1; [|lra]. rewrite <- Rmult_1_r. apply Rmult_le_compat_l. @@ -2854,64 +2837,62 @@ destruct (Rle_or_lt x 0) as [Npx|Px]. intro Hexp10. assert (Hf0 : (fexp1 1 < 1)%Z); [omega|clear Hexp10]. apply (valid_exp_large fexp1 1); [exact Hf0|]. - apply ln_beta_ge_bpow. + apply mag_ge_bpow. rewrite Zeq_minus; [|reflexivity]. - unfold Fcore_Raux.bpow; simpl. + unfold Raux.bpow; simpl. apply Rabs_ge; right. rewrite <- sqrt_1. apply sqrt_le_1_alt. now apply Rlt_le. } - assert (Hf2 : (fexp2 (ln_beta (sqrt x)) <= fexp1 (ln_beta (sqrt x)) - 1)%Z). - { assert (H : (fexp1 (2 * ln_beta (sqrt x)) < 2 * ln_beta (sqrt x))%Z). - { destruct (ln_beta_sqrt_disj x Px) as [Hlx|Hlx]. - - apply (valid_exp_large fexp1 (ln_beta x)); [|omega]. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. + assert (Hf2 : (fexp2 (mag (sqrt x)) <= fexp1 (mag (sqrt x)) - 1)%Z). + { assert (H : (fexp1 (2 * mag (sqrt x)) < 2 * mag (sqrt x))%Z). + { destruct (mag_sqrt_disj x Px) as [Hlx|Hlx]. + - apply (valid_exp_large fexp1 (mag x)); [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. - rewrite <- Hlx. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. } - generalize ((proj2 (proj2 Hexp)) (ln_beta (sqrt x)) H). + now apply mag_generic_gt; [|apply Rgt_not_eq|]. } + generalize ((proj2 (proj2 Hexp)) (mag (sqrt x)) H). omega. } - apply double_round_mid_cases. + apply round_round_mid_cases. + exact Vfexp1. + exact Vfexp2. + now apply sqrt_lt_R0. + omega. + omega. + intros Hmid; casetype False; apply (Rle_not_lt _ _ Hmid). - apply (double_round_sqrt_aux fexp1 fexp2 Vfexp1 Vfexp2 Hexp x Px Hf2 Fx). + apply (round_round_sqrt_aux fexp1 fexp2 Vfexp1 Vfexp2 Hexp x Px Hf2 Fx). Qed. Section Double_round_sqrt_FLX. -Import Fcore_FLX. - Variable prec : Z. Variable prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FLX_double_round_sqrt_hyp : +Lemma FLX_round_round_sqrt_hyp : (2 * prec + 2 <= prec')%Z -> - double_round_sqrt_hyp (FLX_exp prec) (FLX_exp prec'). + round_round_sqrt_hyp (FLX_exp prec) (FLX_exp prec'). Proof. intros Hprec. unfold FLX_exp. unfold Prec_gt_0 in prec_gt_0_. -unfold double_round_sqrt_hyp; split; [|split]; intro ex; omega. +unfold round_round_sqrt_hyp; split; [|split]; intro ex; omega. Qed. -Theorem double_round_sqrt_FLX : +Theorem round_round_sqrt_FLX : forall choice1 choice2, (2 * prec + 2 <= prec')%Z -> forall x, FLX_format beta prec x -> - double_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (sqrt x). + round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (sqrt x). Proof. intros choice1 choice2 Hprec x Fx. -apply double_round_sqrt. +apply round_round_sqrt. - now apply FLX_exp_valid. - now apply FLX_exp_valid. -- now apply FLX_double_round_sqrt_hyp. +- now apply FLX_round_round_sqrt_hyp. - now apply generic_format_FLX. Qed. @@ -2919,26 +2900,23 @@ End Double_round_sqrt_FLX. Section Double_round_sqrt_FLT. -Import Fcore_FLX. -Import Fcore_FLT. - Variable emin prec : Z. Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FLT_double_round_sqrt_hyp : +Lemma FLT_round_round_sqrt_hyp : (emin <= 0)%Z -> ((emin' <= emin - prec - 2)%Z \/ (2 * emin' <= emin - 4 * prec - 2)%Z) -> (2 * prec + 2 <= prec')%Z -> - double_round_sqrt_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). + round_round_sqrt_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). Proof. intros Hemin Heminprec Hprec. unfold FLT_exp. unfold Prec_gt_0 in prec_gt_0_. -unfold double_round_sqrt_hyp; split; [|split]; intros ex. +unfold round_round_sqrt_hyp; split; [|split]; intros ex. - generalize (Zmax_spec (ex - prec) emin). generalize (Zmax_spec (2 * ex - prec) emin). omega. @@ -2951,7 +2929,7 @@ unfold double_round_sqrt_hyp; split; [|split]; intros ex. omega. Qed. -Theorem double_round_sqrt_FLT : +Theorem round_round_sqrt_FLT : forall choice1 choice2, (emin <= 0)%Z -> ((emin' <= emin - prec - 2)%Z @@ -2959,14 +2937,14 @@ Theorem double_round_sqrt_FLT : (2 * prec + 2 <= prec')%Z -> forall x, FLT_format beta emin prec x -> - double_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') + round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') choice1 choice2 (sqrt x). Proof. intros choice1 choice2 Hemin Heminprec Hprec x Fx. -apply double_round_sqrt. +apply round_round_sqrt. - now apply FLT_exp_valid. - now apply FLT_exp_valid. -- now apply FLT_double_round_sqrt_hyp. +- now apply FLT_round_round_sqrt_hyp. - now apply generic_format_FLT. Qed. @@ -2974,24 +2952,21 @@ End Double_round_sqrt_FLT. Section Double_round_sqrt_FTZ. -Import Fcore_FLX. -Import Fcore_FTZ. - Variable emin prec : Z. Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FTZ_double_round_sqrt_hyp : +Lemma FTZ_round_round_sqrt_hyp : (2 * (emin' + prec') <= emin + prec <= 1)%Z -> (2 * prec + 2 <= prec')%Z -> - double_round_sqrt_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). + round_round_sqrt_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). Proof. intros Hemin Hprec. unfold FTZ_exp. unfold Prec_gt_0 in *. -unfold double_round_sqrt_hyp; split; [|split]; intros ex. +unfold round_round_sqrt_hyp; split; [|split]; intros ex. - destruct (Z.ltb_spec (ex - prec) emin); destruct (Z.ltb_spec (2 * ex - prec) emin); omega. @@ -3008,49 +2983,49 @@ unfold double_round_sqrt_hyp; split; [|split]; intros ex. omega. Qed. -Theorem double_round_sqrt_FTZ : +Theorem round_round_sqrt_FTZ : (4 <= beta)%Z -> forall choice1 choice2, (2 * (emin' + prec') <= emin + prec <= 1)%Z -> (2 * prec + 2 <= prec')%Z -> forall x, FTZ_format beta emin prec x -> - double_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') + round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') choice1 choice2 (sqrt x). Proof. intros Hbeta choice1 choice2 Hemin Hprec x Fx. -apply double_round_sqrt. +apply round_round_sqrt. - now apply FTZ_exp_valid. - now apply FTZ_exp_valid. -- now apply FTZ_double_round_sqrt_hyp. +- now apply FTZ_round_round_sqrt_hyp. - now apply generic_format_FTZ. Qed. End Double_round_sqrt_FTZ. -Section Double_round_sqrt_beta_ge_4. +Section Double_round_sqrt_radix_ge_4. -Definition double_round_sqrt_beta_ge_4_hyp fexp1 fexp2 := +Definition round_round_sqrt_radix_ge_4_hyp fexp1 fexp2 := (forall ex, (2 * fexp1 ex <= fexp1 (2 * ex))%Z) /\ (forall ex, (2 * fexp1 ex <= fexp1 (2 * ex - 1))%Z) /\ (forall ex, (fexp1 (2 * ex) < 2 * ex)%Z -> (fexp2 ex + ex <= 2 * fexp1 ex - 1)%Z). -Lemma double_round_sqrt_beta_ge_4_aux : +Lemma round_round_sqrt_radix_ge_4_aux : (4 <= beta)%Z -> forall fexp1 fexp2 : Z -> Z, Valid_exp fexp1 -> Valid_exp fexp2 -> - double_round_sqrt_beta_ge_4_hyp fexp1 fexp2 -> + round_round_sqrt_radix_ge_4_hyp fexp1 fexp2 -> forall x, 0 < x -> - (fexp2 (ln_beta (sqrt x)) <= fexp1 (ln_beta (sqrt x)) - 1)%Z -> + (fexp2 (mag (sqrt x)) <= fexp1 (mag (sqrt x)) - 1)%Z -> generic_format beta fexp1 x -> / 2 * ulp beta fexp2 (sqrt x) < Rabs (sqrt x - midp fexp1 (sqrt x)). Proof. intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 Hexp x Px Hf2 Fx. set (a := round beta fexp1 Zfloor (sqrt x)). -set (u1 := bpow (fexp1 (ln_beta (sqrt x)))). -set (u2 := bpow (fexp2 (ln_beta (sqrt x)))). +set (u1 := bpow (fexp1 (mag (sqrt x)))). +set (u2 := bpow (fexp2 (mag (sqrt x)))). set (b := / 2 * (u1 - u2)). set (b' := / 2 * (u1 + u2)). unfold midp; rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, sqrt_lt_R0. @@ -3061,9 +3036,9 @@ assert (Fa : generic_format beta fexp1 a). - exact Vfexp1. - now apply valid_rnd_DN. } revert Fa; revert Fx. -unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl. -set (mx := Ztrunc (x * bpow (- fexp1 (ln_beta x)))). -set (ma := Ztrunc (a * bpow (- fexp1 (ln_beta a)))). +unfold generic_format, F2R, scaled_mantissa, cexp; simpl. +set (mx := Ztrunc (x * bpow (- fexp1 (mag x)))). +set (ma := Ztrunc (a * bpow (- fexp1 (mag a)))). intros Fx Fa. assert (Nna : 0 <= a). { rewrite <- (round_0 beta fexp1 Zfloor). @@ -3080,7 +3055,7 @@ assert (Pb : 0 < b). rewrite <- (Rmult_0_r (/ 2)). apply Rmult_lt_compat_l; [lra|]. apply Rlt_Rminus. - unfold u2, u1, ulp, canonic_exp. + unfold u2, u1, ulp, cexp. apply bpow_lt. omega. } assert (Pb' : 0 < b'). @@ -3094,14 +3069,14 @@ assert (Hl : a + b <= sqrt x). replace (_ + sqrt _) with (sqrt x - (a + / 2 * u1)) by ring. rewrite Ropp_mult_distr_l_reverse. now apply Rabs_le_inv in H; destruct H. } -assert (Hf1 : (2 * fexp1 (ln_beta (sqrt x)) <= fexp1 (ln_beta (x)))%Z); - [destruct (ln_beta_sqrt_disj x Px) as [H'|H']; rewrite H'; apply Hexp|]. -assert (Hlx : (fexp1 (2 * ln_beta (sqrt x)) < 2 * ln_beta (sqrt x))%Z). -{ destruct (ln_beta_sqrt_disj x Px) as [Hlx|Hlx]. - - apply (valid_exp_large fexp1 (ln_beta x)); [|omega]. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. +assert (Hf1 : (2 * fexp1 (mag (sqrt x)) <= fexp1 (mag (x)))%Z); + [destruct (mag_sqrt_disj x Px) as [H'|H']; rewrite H'; apply Hexp|]. +assert (Hlx : (fexp1 (2 * mag (sqrt x)) < 2 * mag (sqrt x))%Z). +{ destruct (mag_sqrt_disj x Px) as [Hlx|Hlx]. + - apply (valid_exp_large fexp1 (mag x)); [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. - rewrite <- Hlx. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. } + now apply mag_generic_gt; [|apply Rgt_not_eq|]. } assert (Hsl : a * a + u1 * a - u2 * a + b * b <= x). { replace (_ + _) with ((a + b) * (a + b)); [|now unfold b; field]. rewrite <- sqrt_def; [|now apply Rlt_le]. @@ -3120,34 +3095,33 @@ destruct (Req_dec a 0) as [Za|Nza]. + revert Hsl; unfold Rminus; rewrite Za; do 3 rewrite Rmult_0_r. now rewrite Ropp_0; do 3 rewrite Rplus_0_l. + rewrite Fx. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_0_l; bpow_simplify. unfold mx. rewrite Ztrunc_floor; [|now apply Rmult_le_pos; [apply Rlt_le|apply bpow_ge_0]]. - apply Req_le. - change 0 with (Z2R 0); apply f_equal. + apply Req_le, IZR_eq. apply Zfloor_imp. split; [now apply Rmult_le_pos; [apply Rlt_le|apply bpow_ge_0]|simpl]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_1_l; bpow_simplify. - apply Rlt_le_trans with (bpow (2 * fexp1 (ln_beta (sqrt x)))); + apply Rlt_le_trans with (bpow (2 * fexp1 (mag (sqrt x)))); [|now apply bpow_le]. change 2%Z with (1 + 1)%Z; rewrite Zmult_plus_distr_l; rewrite Zmult_1_l. rewrite bpow_plus. rewrite <- (sqrt_def x) at 1; [|now apply Rlt_le]. - assert (sqrt x < bpow (fexp1 (ln_beta (sqrt x)))); + assert (sqrt x < bpow (fexp1 (mag (sqrt x)))); [|now apply Rmult_lt_compat; [apply sqrt_pos|apply sqrt_pos| |]]. apply (Rle_lt_trans _ _ _ Hr); rewrite Za; rewrite Rplus_0_l. unfold b'; change (bpow _) with u1. apply Rlt_le_trans with (/ 2 * (u1 + u1)); [|lra]. apply Rmult_lt_compat_l; [lra|]; apply Rplus_lt_compat_l. - unfold u2, u1, ulp, canonic_exp; apply bpow_lt; omega. + unfold u2, u1, ulp, cexp; apply bpow_lt; omega. - (* a <> 0 *) assert (Pa : 0 < a); [lra|]. - assert (Hla : (ln_beta a = ln_beta (sqrt x) :> Z)). - { unfold a; apply ln_beta_DN. + assert (Hla : (mag a = mag (sqrt x) :> Z)). + { unfold a; apply mag_DN. - exact Vfexp1. - now fold a. } assert (Hl' : 0 < - (u2 * a) + b * b). @@ -3156,7 +3130,7 @@ destruct (Req_dec a 0) as [Za|Nza]. apply (Rplus_lt_reg_r (/ 2 * u2 * u1)); field_simplify. replace (_ / 2) with (u2 * (a + / 2 * u1)) by field. replace (_ / 8) with (/ 4 * (u2 ^ 2 + u1 ^ 2)) by field. - apply Rlt_le_trans with (u2 * bpow (ln_beta (sqrt x))). + apply Rlt_le_trans with (u2 * bpow (mag (sqrt x))). - apply Rmult_lt_compat_l; [now unfold u2, ulp; apply bpow_gt_0|]. unfold u1; rewrite <- Hla. apply Rlt_le_trans with (a + ulp beta fexp1 a). @@ -3165,50 +3139,50 @@ destruct (Req_dec a 0) as [Za|Nza]. rewrite ulp_neq_0; trivial. apply Rmult_lt_compat_r; [apply bpow_gt_0|lra]. + apply (id_p_ulp_le_bpow _ _ _ _ Pa Fa). - apply Rabs_lt_inv, bpow_ln_beta_gt. + apply Rabs_lt_inv, bpow_mag_gt. - apply Rle_trans with (bpow (- 1) * u1 ^ 2). + unfold pow; rewrite Rmult_1_r. - unfold u1, u2, ulp, canonic_exp; bpow_simplify; apply bpow_le. + unfold u1, u2, ulp, cexp; bpow_simplify; apply bpow_le. now apply Hexp. + apply Rmult_le_compat. * apply bpow_ge_0. * apply pow2_ge_0. - * unfold Fcore_Raux.bpow, Z.pow_pos; simpl; rewrite Zmult_1_r. + * unfold Raux.bpow, Z.pow_pos; simpl; rewrite Zmult_1_r. apply Rinv_le; [lra|]. - now change 4 with (Z2R 4); apply Z2R_le. + now apply IZR_le. * rewrite <- (Rplus_0_l (u1 ^ 2)) at 1; apply Rplus_le_compat_r. apply pow2_ge_0. } assert (Hr' : x <= a * a + u1 * a). { rewrite Hla in Fa. rewrite <- Rmult_plus_distr_r. - unfold u1, ulp, canonic_exp. + unfold u1, ulp, cexp. rewrite <- (Rmult_1_l (bpow _)); rewrite Fa; rewrite <- Rmult_plus_distr_r. - rewrite <- Rmult_assoc; rewrite (Rmult_comm _ (Z2R ma)). - rewrite <- (Rmult_assoc (Z2R ma)); bpow_simplify. - apply (Rmult_le_reg_r (bpow (- 2 * fexp1 (ln_beta (sqrt x))))); + rewrite <- Rmult_assoc; rewrite (Rmult_comm _ (IZR ma)). + rewrite <- (Rmult_assoc (IZR ma)); bpow_simplify. + apply (Rmult_le_reg_r (bpow (- 2 * fexp1 (mag (sqrt x))))); [now apply bpow_gt_0|bpow_simplify]. rewrite Fx at 1; bpow_simplify. - rewrite <- Z2R_Zpower; [|omega]. - change 1 with (Z2R 1); rewrite <- Z2R_plus; do 2 rewrite <- Z2R_mult. - apply Z2R_le, Zlt_succ_le, lt_Z2R. - unfold Z.succ; rewrite Z2R_plus; do 2 rewrite Z2R_mult; rewrite Z2R_plus. - rewrite Z2R_Zpower; [|omega]. - apply (Rmult_lt_reg_r (bpow (2 * fexp1 (ln_beta (sqrt x))))); + rewrite <- IZR_Zpower; [|omega]. + rewrite <- plus_IZR, <- 2!mult_IZR. + apply IZR_le, Zlt_succ_le, lt_IZR. + unfold Z.succ; rewrite plus_IZR; do 2 rewrite mult_IZR; rewrite plus_IZR. + rewrite IZR_Zpower; [|omega]. + apply (Rmult_lt_reg_r (bpow (2 * fexp1 (mag (sqrt x))))); [now apply bpow_gt_0|bpow_simplify]. rewrite <- Fx. change 2%Z with (1 + 1)%Z; rewrite Zmult_plus_distr_l; rewrite Zmult_1_l. rewrite bpow_plus; simpl. replace (_ * _) with (a * a + u1 * a + u1 * u1); - [|unfold u1, ulp, canonic_exp; rewrite Fa; ring]. + [|unfold u1, ulp, cexp; rewrite Fa; ring]. apply (Rle_lt_trans _ _ _ Hsr). rewrite Rplus_assoc; apply Rplus_lt_compat_l. apply (Rplus_lt_reg_r (- b' * b' + / 2 * u1 * u2)); ring_simplify. replace (_ + _) with ((a + / 2 * u1) * u2) by ring. - apply Rlt_le_trans with (bpow (ln_beta (sqrt x)) * u2). + apply Rlt_le_trans with (bpow (mag (sqrt x)) * u2). - apply Rmult_lt_compat_r; [now unfold u2, ulp; apply bpow_gt_0|]. apply Rlt_le_trans with (a + u1); [lra|]. - unfold u1; fold (canonic_exp beta fexp1 (sqrt x)). - rewrite <- canonic_exp_DN; [|exact Vfexp1|exact Pa]; fold a. + unfold u1; fold (cexp beta fexp1 (sqrt x)). + rewrite <- cexp_DN; [|exact Vfexp1|exact Pa]; fold a. rewrite <- ulp_neq_0; trivial. apply id_p_ulp_le_bpow. + exact Pa. @@ -3216,25 +3190,25 @@ destruct (Req_dec a 0) as [Za|Nza]. + apply Rle_lt_trans with (sqrt x). * now apply round_DN_pt. * apply Rabs_lt_inv. - apply bpow_ln_beta_gt. + apply bpow_mag_gt. - apply Rle_trans with (/ 2 * u1 ^ 2). + apply Rle_trans with (bpow (- 1) * u1 ^ 2). * unfold pow; rewrite Rmult_1_r. - unfold u2, u1, ulp, canonic_exp. + unfold u2, u1, ulp, cexp. bpow_simplify. apply bpow_le. rewrite Zplus_comm. now apply Hexp. * apply Rmult_le_compat_r; [now apply pow2_ge_0|]. - unfold Fcore_Raux.bpow; simpl; unfold Z.pow_pos; simpl. + unfold Raux.bpow; simpl; unfold Z.pow_pos; simpl. rewrite Zmult_1_r. apply Rinv_le; [lra|]. - change 2 with (Z2R 2); apply Z2R_le; omega. + apply IZR_le; omega. + assert (u2 ^ 2 < u1 ^ 2); [|unfold b'; lra]. unfold pow; do 2 rewrite Rmult_1_r. assert (H' : 0 <= u2); [unfold u2, ulp; apply bpow_ge_0|]. assert (u2 < u1); [|now apply Rmult_lt_compat]. - unfold u1, u2, ulp, canonic_exp; apply bpow_lt; omega. } + unfold u1, u2, ulp, cexp; apply bpow_lt; omega. } apply (Rlt_irrefl (a * a + u1 * a)). apply Rlt_le_trans with (a * a + u1 * a - u2 * a + b * b). + rewrite <- (Rplus_0_r (a * a + _)) at 1. @@ -3243,18 +3217,18 @@ destruct (Req_dec a 0) as [Za|Nza]. + now apply Rle_trans with x. Qed. -Lemma double_round_sqrt_beta_ge_4 : +Lemma round_round_sqrt_radix_ge_4 : (4 <= beta)%Z -> forall fexp1 fexp2 : Z -> Z, Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_sqrt_beta_ge_4_hyp fexp1 fexp2 -> + round_round_sqrt_radix_ge_4_hyp fexp1 fexp2 -> forall x, generic_format beta fexp1 x -> - double_round_eq fexp1 fexp2 choice1 choice2 (sqrt x). + round_round_eq fexp1 fexp2 choice1 choice2 (sqrt x). Proof. intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x Fx. -unfold double_round_eq. +unfold round_round_eq. destruct (Rle_or_lt x 0) as [Npx|Px]. - (* x <= 0 *) assert (Hs : sqrt x = 0). @@ -3272,13 +3246,13 @@ destruct (Rle_or_lt x 0) as [Npx|Px]. + reflexivity. + now apply valid_rnd_N. - (* 0 < x *) - assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z); - [now apply ln_beta_generic_gt; try assumption; lra|]. - assert (Hfsx : (fexp1 (ln_beta (sqrt x)) < ln_beta (sqrt x))%Z). + assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; try assumption; lra|]. + assert (Hfsx : (fexp1 (mag (sqrt x)) < mag (sqrt x))%Z). { destruct (Rle_or_lt x 1) as [Hx|Hx]. - (* x <= 1 *) - apply (valid_exp_large fexp1 (ln_beta x)); [exact Hfx|]. - apply ln_beta_le; [exact Px|]. + apply (valid_exp_large fexp1 (mag x)); [exact Hfx|]. + apply mag_le; [exact Px|]. rewrite <- (sqrt_def x) at 1; [|lra]. rewrite <- Rmult_1_r. apply Rmult_le_compat_l. @@ -3291,36 +3265,34 @@ destruct (Rle_or_lt x 0) as [Npx|Px]. intro Hexp10. assert (Hf0 : (fexp1 1 < 1)%Z); [omega|clear Hexp10]. apply (valid_exp_large fexp1 1); [exact Hf0|]. - apply ln_beta_ge_bpow. + apply mag_ge_bpow. rewrite Zeq_minus; [|reflexivity]. - unfold Fcore_Raux.bpow; simpl. + unfold Raux.bpow; simpl. apply Rabs_ge; right. rewrite <- sqrt_1. apply sqrt_le_1_alt. now apply Rlt_le. } - assert (Hf2 : (fexp2 (ln_beta (sqrt x)) <= fexp1 (ln_beta (sqrt x)) - 1)%Z). - { assert (H : (fexp1 (2 * ln_beta (sqrt x)) < 2 * ln_beta (sqrt x))%Z). - { destruct (ln_beta_sqrt_disj x Px) as [Hlx|Hlx]. - - apply (valid_exp_large fexp1 (ln_beta x)); [|omega]. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. + assert (Hf2 : (fexp2 (mag (sqrt x)) <= fexp1 (mag (sqrt x)) - 1)%Z). + { assert (H : (fexp1 (2 * mag (sqrt x)) < 2 * mag (sqrt x))%Z). + { destruct (mag_sqrt_disj x Px) as [Hlx|Hlx]. + - apply (valid_exp_large fexp1 (mag x)); [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. - rewrite <- Hlx. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. } - generalize ((proj2 (proj2 Hexp)) (ln_beta (sqrt x)) H). + now apply mag_generic_gt; [|apply Rgt_not_eq|]. } + generalize ((proj2 (proj2 Hexp)) (mag (sqrt x)) H). omega. } - apply double_round_mid_cases. + apply round_round_mid_cases. + exact Vfexp1. + exact Vfexp2. + now apply sqrt_lt_R0. + omega. + omega. + intros Hmid; casetype False; apply (Rle_not_lt _ _ Hmid). - apply (double_round_sqrt_beta_ge_4_aux Hbeta fexp1 fexp2 Vfexp1 Vfexp2 + apply (round_round_sqrt_radix_ge_4_aux Hbeta fexp1 fexp2 Vfexp1 Vfexp2 Hexp x Px Hf2 Fx). Qed. -Section Double_round_sqrt_beta_ge_4_FLX. - -Import Fcore_FLX. +Section Double_round_sqrt_radix_ge_4_FLX. Variable prec : Z. Variable prec' : Z. @@ -3328,39 +3300,36 @@ Variable prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FLX_double_round_sqrt_beta_ge_4_hyp : +Lemma FLX_round_round_sqrt_radix_ge_4_hyp : (2 * prec + 1 <= prec')%Z -> - double_round_sqrt_beta_ge_4_hyp (FLX_exp prec) (FLX_exp prec'). + round_round_sqrt_radix_ge_4_hyp (FLX_exp prec) (FLX_exp prec'). Proof. intros Hprec. unfold FLX_exp. unfold Prec_gt_0 in prec_gt_0_. -unfold double_round_sqrt_beta_ge_4_hyp; split; [|split]; intro ex; omega. +unfold round_round_sqrt_radix_ge_4_hyp; split; [|split]; intro ex; omega. Qed. -Theorem double_round_sqrt_beta_ge_4_FLX : +Theorem round_round_sqrt_radix_ge_4_FLX : (4 <= beta)%Z -> forall choice1 choice2, (2 * prec + 1 <= prec')%Z -> forall x, FLX_format beta prec x -> - double_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (sqrt x). + round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (sqrt x). Proof. intros Hbeta choice1 choice2 Hprec x Fx. -apply double_round_sqrt_beta_ge_4. +apply round_round_sqrt_radix_ge_4. - exact Hbeta. - now apply FLX_exp_valid. - now apply FLX_exp_valid. -- now apply FLX_double_round_sqrt_beta_ge_4_hyp. +- now apply FLX_round_round_sqrt_radix_ge_4_hyp. - now apply generic_format_FLX. Qed. -End Double_round_sqrt_beta_ge_4_FLX. +End Double_round_sqrt_radix_ge_4_FLX. -Section Double_round_sqrt_beta_ge_4_FLT. - -Import Fcore_FLX. -Import Fcore_FLT. +Section Double_round_sqrt_radix_ge_4_FLT. Variable emin prec : Z. Variable emin' prec' : Z. @@ -3368,17 +3337,17 @@ Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FLT_double_round_sqrt_beta_ge_4_hyp : +Lemma FLT_round_round_sqrt_radix_ge_4_hyp : (emin <= 0)%Z -> ((emin' <= emin - prec - 1)%Z \/ (2 * emin' <= emin - 4 * prec)%Z) -> (2 * prec + 1 <= prec')%Z -> - double_round_sqrt_beta_ge_4_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). + round_round_sqrt_radix_ge_4_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). Proof. intros Hemin Heminprec Hprec. unfold FLT_exp. unfold Prec_gt_0 in prec_gt_0_. -unfold double_round_sqrt_beta_ge_4_hyp; split; [|split]; intros ex. +unfold round_round_sqrt_radix_ge_4_hyp; split; [|split]; intros ex. - generalize (Zmax_spec (ex - prec) emin). generalize (Zmax_spec (2 * ex - prec) emin). omega. @@ -3391,7 +3360,7 @@ unfold double_round_sqrt_beta_ge_4_hyp; split; [|split]; intros ex. omega. Qed. -Theorem double_round_sqrt_beta_ge_4_FLT : +Theorem round_round_sqrt_radix_ge_4_FLT : (4 <= beta)%Z -> forall choice1 choice2, (emin <= 0)%Z -> @@ -3400,24 +3369,21 @@ Theorem double_round_sqrt_beta_ge_4_FLT : (2 * prec + 1 <= prec')%Z -> forall x, FLT_format beta emin prec x -> - double_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') + round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') choice1 choice2 (sqrt x). Proof. intros Hbeta choice1 choice2 Hemin Heminprec Hprec x Fx. -apply double_round_sqrt_beta_ge_4. +apply round_round_sqrt_radix_ge_4. - exact Hbeta. - now apply FLT_exp_valid. - now apply FLT_exp_valid. -- now apply FLT_double_round_sqrt_beta_ge_4_hyp. +- now apply FLT_round_round_sqrt_radix_ge_4_hyp. - now apply generic_format_FLT. Qed. -End Double_round_sqrt_beta_ge_4_FLT. - -Section Double_round_sqrt_beta_ge_4_FTZ. +End Double_round_sqrt_radix_ge_4_FLT. -Import Fcore_FLX. -Import Fcore_FTZ. +Section Double_round_sqrt_radix_ge_4_FTZ. Variable emin prec : Z. Variable emin' prec' : Z. @@ -3425,15 +3391,15 @@ Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FTZ_double_round_sqrt_beta_ge_4_hyp : +Lemma FTZ_round_round_sqrt_radix_ge_4_hyp : (2 * (emin' + prec') <= emin + prec <= 1)%Z -> (2 * prec + 1 <= prec')%Z -> - double_round_sqrt_beta_ge_4_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). + round_round_sqrt_radix_ge_4_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). Proof. intros Hemin Hprec. unfold FTZ_exp. unfold Prec_gt_0 in *. -unfold double_round_sqrt_beta_ge_4_hyp; split; [|split]; intros ex. +unfold round_round_sqrt_radix_ge_4_hyp; split; [|split]; intros ex. - destruct (Z.ltb_spec (ex - prec) emin); destruct (Z.ltb_spec (2 * ex - prec) emin); omega. @@ -3450,47 +3416,47 @@ unfold double_round_sqrt_beta_ge_4_hyp; split; [|split]; intros ex. omega. Qed. -Theorem double_round_sqrt_beta_ge_4_FTZ : +Theorem round_round_sqrt_radix_ge_4_FTZ : (4 <= beta)%Z -> forall choice1 choice2, (2 * (emin' + prec') <= emin + prec <= 1)%Z -> (2 * prec + 1 <= prec')%Z -> forall x, FTZ_format beta emin prec x -> - double_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') + round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') choice1 choice2 (sqrt x). Proof. intros Hbeta choice1 choice2 Hemin Hprec x Fx. -apply double_round_sqrt_beta_ge_4. +apply round_round_sqrt_radix_ge_4. - exact Hbeta. - now apply FTZ_exp_valid. - now apply FTZ_exp_valid. -- now apply FTZ_double_round_sqrt_beta_ge_4_hyp. +- now apply FTZ_round_round_sqrt_radix_ge_4_hyp. - now apply generic_format_FTZ. Qed. -End Double_round_sqrt_beta_ge_4_FTZ. +End Double_round_sqrt_radix_ge_4_FTZ. -End Double_round_sqrt_beta_ge_4. +End Double_round_sqrt_radix_ge_4. End Double_round_sqrt. Section Double_round_div. -Lemma double_round_eq_mid_beta_even : +Lemma round_round_eq_mid_beta_even : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), (exists n, (beta = 2 * n :> Z)%Z) -> forall x, 0 < x -> - (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z -> - (fexp1 (ln_beta x) <= ln_beta x)%Z -> + (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> + (fexp1 (mag x) <= mag x)%Z -> x = midp fexp1 x -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Ebeta x Px Hf2 Hf1. -unfold double_round_eq. +unfold round_round_eq. unfold midp. set (rd := round beta fexp1 Zfloor x). set (u := ulp beta fexp1 x). @@ -3505,30 +3471,30 @@ assert (Hbeta : (2 <= beta)%Z). apply (Rplus_eq_compat_l rd) in Xmid; ring_simplify in Xmid. rewrite (round_generic beta fexp2); [reflexivity|now apply valid_rnd_N|]. set (f := Float beta (Zfloor (scaled_mantissa beta fexp2 rd) - + n * beta ^ (fexp1 (ln_beta x) - 1 - - fexp2 (ln_beta x))) - (canonic_exp beta fexp2 x)). + + n * beta ^ (fexp1 (mag x) - 1 + - fexp2 (mag x))) + (cexp beta fexp2 x)). assert (Hf : F2R f = x). { unfold f, F2R; simpl. - rewrite Z2R_plus. + rewrite plus_IZR. rewrite Rmult_plus_distr_r. - rewrite Z2R_mult. - rewrite Z2R_Zpower; [|omega]. - unfold canonic_exp at 2; bpow_simplify. + rewrite mult_IZR. + rewrite IZR_Zpower; [|omega]. + unfold cexp at 2; bpow_simplify. unfold Zminus; rewrite bpow_plus. rewrite (Rmult_comm _ (bpow (- 1))). - rewrite <- (Rmult_assoc (Z2R n)). - change (bpow (- 1)) with (/ Z2R (beta * 1)). + rewrite <- (Rmult_assoc (IZR n)). + change (bpow (- 1)) with (/ IZR (beta * 1)). rewrite Zmult_1_r. rewrite Ebeta. - rewrite (Z2R_mult 2). + rewrite (mult_IZR 2). rewrite Rinv_mult_distr; - [|simpl; lra|change 0 with (Z2R 0); apply Z2R_neq; omega]. - rewrite <- Rmult_assoc; rewrite (Rmult_comm (Z2R n)); - rewrite (Rmult_assoc _ (Z2R n)). + [|simpl; lra | apply IZR_neq; omega]. + rewrite <- Rmult_assoc; rewrite (Rmult_comm (IZR n)); + rewrite (Rmult_assoc _ (IZR n)). rewrite Rinv_r; - [rewrite Rmult_1_r|change 0 with (Z2R 0); apply Z2R_neq; omega]. - simpl; fold (canonic_exp beta fexp1 x). + [rewrite Rmult_1_r | apply IZR_neq; omega]. + simpl; fold (cexp beta fexp1 x). rewrite <- 2!ulp_neq_0; try now apply Rgt_not_eq. fold u; rewrite Xmid at 2. apply f_equal2; [|reflexivity]. @@ -3537,7 +3503,7 @@ assert (Hf : F2R f = x). - (* rd = 0 *) rewrite Zrd. rewrite scaled_mantissa_0. - change 0 with (Z2R 0) at 1; rewrite Zfloor_Z2R. + rewrite Zfloor_IZR. now rewrite Rmult_0_l. - (* rd <> 0 *) assert (Nnrd : 0 <= rd). @@ -3546,187 +3512,187 @@ assert (Hf : F2R f = x). - apply generic_format_0. - now apply Rlt_le. } assert (Prd : 0 < rd); [lra|]. - assert (Lrd : (ln_beta rd = ln_beta x :> Z)). + assert (Lrd : (mag rd = mag x :> Z)). { apply Zle_antisym. - - apply ln_beta_le; [exact Prd|]. + - apply mag_le; [exact Prd|]. now apply round_DN_pt. - - apply ln_beta_round_ge. + - apply mag_round_ge. + exact Vfexp1. + now apply valid_rnd_DN. + exact Nzrd. } unfold scaled_mantissa. unfold rd at 1. - unfold round, F2R, scaled_mantissa, canonic_exp; simpl. + unfold round, F2R, scaled_mantissa, cexp; simpl. bpow_simplify. rewrite Lrd. - rewrite <- (Z2R_Zpower _ (_ - _)); [|omega]. - rewrite <- Z2R_mult. - rewrite (Zfloor_imp (Zfloor (x * bpow (- fexp1 (ln_beta x))) * - beta ^ (fexp1 (ln_beta x) - fexp2 (ln_beta x)))). - + rewrite Z2R_mult. - rewrite Z2R_Zpower; [|omega]. + rewrite <- (IZR_Zpower _ (_ - _)); [|omega]. + rewrite <- mult_IZR. + rewrite (Zfloor_imp (Zfloor (x * bpow (- fexp1 (mag x))) * + beta ^ (fexp1 (mag x) - fexp2 (mag x)))). + + rewrite mult_IZR. + rewrite IZR_Zpower; [|omega]. bpow_simplify. now unfold rd. + split; [now apply Rle_refl|]. - rewrite Z2R_plus. + rewrite plus_IZR. simpl; lra. } apply (generic_format_F2R' _ _ x f Hf). intros _. -apply Zle_refl. +apply Z.le_refl. Qed. -Lemma double_round_really_zero : +Lemma round_round_really_zero : forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (ln_beta x <= fexp1 (ln_beta x) - 2)%Z -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + (mag x <= fexp1 (mag x) - 2)%Z -> + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf1. -assert (Hlx : bpow (ln_beta x - 1) <= x < bpow (ln_beta x)). -{ destruct (ln_beta x) as (ex,Hex); simpl. +assert (Hlx : bpow (mag x - 1) <= x < bpow (mag x)). +{ destruct (mag x) as (ex,Hex); simpl. rewrite <- (Rabs_right x); [|now apply Rle_ge; apply Rlt_le]. apply Hex. now apply Rgt_not_eq. } -unfold double_round_eq. -rewrite (round_N_really_small_pos beta fexp1 _ x (ln_beta x)); [|exact Hlx|omega]. +unfold round_round_eq. +rewrite (round_N_small_pos beta fexp1 _ x (mag x)); [|exact Hlx|omega]. set (x'' := round beta fexp2 (Znearest choice2) x). destruct (Req_dec x'' 0) as [Zx''|Nzx'']; [now rewrite Zx''; rewrite round_0; [|apply valid_rnd_N]|]. -destruct (Zle_or_lt (fexp2 (ln_beta x)) (ln_beta x)). -- (* fexp2 (ln_beta x) <= ln_beta x *) - destruct (Rlt_or_le x'' (bpow (ln_beta x))). - + (* x'' < bpow (ln_beta x) *) - rewrite (round_N_really_small_pos beta fexp1 _ _ (ln_beta x)); +destruct (Zle_or_lt (fexp2 (mag x)) (mag x)). +- (* fexp2 (mag x) <= mag x *) + destruct (Rlt_or_le x'' (bpow (mag x))). + + (* x'' < bpow (mag x) *) + rewrite (round_N_small_pos beta fexp1 _ _ (mag x)); [reflexivity|split; [|exact H0]|omega]. - apply round_large_pos_ge_pow; [now apply valid_rnd_N| |now apply Hlx]. + apply round_large_pos_ge_bpow; [now apply valid_rnd_N| |now apply Hlx]. fold x''; assert (0 <= x''); [|lra]; unfold x''. rewrite <- (round_0 beta fexp2 (Znearest choice2)). now apply round_le; [|apply valid_rnd_N|apply Rlt_le]. - + (* bpow (ln_beta x) <= x'' *) - assert (Hx'' : x'' = bpow (ln_beta x)). + + (* bpow (mag x) <= x'' *) + assert (Hx'' : x'' = bpow (mag x)). { apply Rle_antisym; [|exact H0]. rewrite <- (round_generic beta fexp2 (Znearest choice2) (bpow _)). - now apply round_le; [|apply valid_rnd_N|apply Rlt_le]. - now apply generic_format_bpow'. } rewrite Hx''. - unfold round, F2R, scaled_mantissa, canonic_exp; simpl. - rewrite ln_beta_bpow. - assert (Hf11 : (fexp1 (ln_beta x + 1) = fexp1 (ln_beta x) :> Z)%Z); + unfold round, F2R, scaled_mantissa, cexp; simpl. + rewrite mag_bpow. + assert (Hf11 : (fexp1 (mag x + 1) = fexp1 (mag x) :> Z)%Z); [apply Vfexp1; omega|]. rewrite Hf11. - apply (Rmult_eq_reg_r (bpow (- fexp1 (ln_beta x)))); + apply (Rmult_eq_reg_r (bpow (- fexp1 (mag x)))); [|now apply Rgt_not_eq; apply bpow_gt_0]. rewrite Rmult_0_l; bpow_simplify. - change 0 with (Z2R 0); apply f_equal. + apply IZR_eq. apply Znearest_imp. simpl; unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r. rewrite Rabs_right; [|now apply Rle_ge; apply bpow_ge_0]. apply Rle_lt_trans with (bpow (- 2)); [now apply bpow_le; omega|]. - unfold Fcore_Raux.bpow, Z.pow_pos; simpl; rewrite Zmult_1_r. + unfold Raux.bpow, Z.pow_pos; simpl; rewrite Zmult_1_r. assert (Hbeta : (2 <= beta)%Z). { destruct beta as (beta_val,beta_prop); simpl. now apply Zle_bool_imp_le. } apply Rinv_lt_contravar. * apply Rmult_lt_0_compat; [lra|]. - rewrite Z2R_mult; apply Rmult_lt_0_compat; change 0 with (Z2R 0); - apply Z2R_lt; omega. - * change 2 with (Z2R 2); apply Z2R_lt. - apply (Zle_lt_trans _ _ _ Hbeta). + rewrite mult_IZR; apply Rmult_lt_0_compat; + apply IZR_lt; omega. + * apply IZR_lt. + apply (Z.le_lt_trans _ _ _ Hbeta). rewrite <- (Zmult_1_r beta) at 1. apply Zmult_lt_compat_l; omega. -- (* ln_beta x < fexp2 (ln_beta x) *) +- (* mag x < fexp2 (mag x) *) casetype False; apply Nzx''. - now apply (round_N_really_small_pos beta _ _ _ (ln_beta x)). + now apply (round_N_small_pos beta _ _ _ (mag x)). Qed. -Lemma double_round_zero : +Lemma round_round_zero : forall fexp1 fexp2 : Z -> Z, Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (fexp1 (ln_beta x) = ln_beta x + 1 :> Z)%Z -> - x < bpow (ln_beta x) - / 2 * ulp beta fexp2 x -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + (fexp1 (mag x) = mag x + 1 :> Z)%Z -> + x < bpow (mag x) - / 2 * ulp beta fexp2 x -> + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf1. -unfold double_round_eq. +unfold round_round_eq. set (x'' := round beta fexp2 (Znearest choice2) x). set (u1 := ulp beta fexp1 x). set (u2 := ulp beta fexp2 x). intro Hx. -assert (Hlx : bpow (ln_beta x - 1) <= x < bpow (ln_beta x)). -{ destruct (ln_beta x) as (ex,Hex); simpl. +assert (Hlx : bpow (mag x - 1) <= x < bpow (mag x)). +{ destruct (mag x) as (ex,Hex); simpl. rewrite <- (Rabs_right x); [|now apply Rle_ge; apply Rlt_le]. apply Hex. now apply Rgt_not_eq. } -rewrite (round_N_really_small_pos beta fexp1 choice1 x (ln_beta x)); +rewrite (round_N_small_pos beta fexp1 choice1 x (mag x)); [|exact Hlx|omega]. destruct (Req_dec x'' 0) as [Zx''|Nzx'']; [now rewrite Zx''; rewrite round_0; [reflexivity|apply valid_rnd_N]|]. -rewrite (round_N_really_small_pos beta _ _ x'' (ln_beta x)); +rewrite (round_N_small_pos beta _ _ x'' (mag x)); [reflexivity| |omega]. split. -- apply round_large_pos_ge_pow. +- apply round_large_pos_ge_bpow. + now apply valid_rnd_N. + assert (0 <= x''); [|now fold x''; lra]. rewrite <- (round_0 beta fexp2 (Znearest choice2)). now apply round_le; [|apply valid_rnd_N|apply Rlt_le]. + apply Rle_trans with (Rabs x); [|now rewrite Rabs_right; [apply Rle_refl|apply Rle_ge; apply Rlt_le]]. - destruct (ln_beta x) as (ex,Hex); simpl; apply Hex. + destruct (mag x) as (ex,Hex); simpl; apply Hex. now apply Rgt_not_eq. - replace x'' with (x + (x'' - x)) by ring. - replace (bpow _) with (bpow (ln_beta x) - / 2 * u2 + / 2 * u2) by ring. + replace (bpow _) with (bpow (mag x) - / 2 * u2 + / 2 * u2) by ring. apply Rplus_lt_le_compat; [exact Hx|]. apply Rabs_le_inv. now apply error_le_half_ulp. Qed. -Lemma double_round_all_mid_cases : +Lemma round_round_all_mid_cases : forall fexp1 fexp2 : Z -> Z, Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), forall x, 0 < x -> - (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z -> - ((fexp1 (ln_beta x) = ln_beta x + 1 :> Z)%Z -> - bpow (ln_beta x) - / 2 * ulp beta fexp2 x <= x -> - double_round_eq fexp1 fexp2 choice1 choice2 x) -> - ((fexp1 (ln_beta x) <= ln_beta x)%Z -> + (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> + ((fexp1 (mag x) = mag x + 1 :> Z)%Z -> + bpow (mag x) - / 2 * ulp beta fexp2 x <= x -> + round_round_eq fexp1 fexp2 choice1 choice2 x) -> + ((fexp1 (mag x) <= mag x)%Z -> midp fexp1 x - / 2 * ulp beta fexp2 x <= x < midp fexp1 x -> - double_round_eq fexp1 fexp2 choice1 choice2 x) -> - ((fexp1 (ln_beta x) <= ln_beta x)%Z -> + round_round_eq fexp1 fexp2 choice1 choice2 x) -> + ((fexp1 (mag x) <= mag x)%Z -> x = midp fexp1 x -> - double_round_eq fexp1 fexp2 choice1 choice2 x) -> - ((fexp1 (ln_beta x) <= ln_beta x)%Z -> + round_round_eq fexp1 fexp2 choice1 choice2 x) -> + ((fexp1 (mag x) <= mag x)%Z -> midp fexp1 x < x <= midp fexp1 x + / 2 * ulp beta fexp2 x -> - double_round_eq fexp1 fexp2 choice1 choice2 x) -> - double_round_eq fexp1 fexp2 choice1 choice2 x. + round_round_eq fexp1 fexp2 choice1 choice2 x) -> + round_round_eq fexp1 fexp2 choice1 choice2 x. Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2. set (x' := round beta fexp1 Zfloor x). set (u1 := ulp beta fexp1 x). set (u2 := ulp beta fexp2 x). intros Cz Clt Ceq Cgt. -destruct (Ztrichotomy (ln_beta x) (fexp1 (ln_beta x) - 1)) as [Hlt|[Heq|Hgt]]. -- (* ln_beta x < fexp1 (ln_beta x) - 1 *) - assert (H : (ln_beta x <= fexp1 (ln_beta x) - 2)%Z) by omega. - now apply double_round_really_zero. -- (* ln_beta x = fexp1 (ln_beta x) - 1 *) - assert (H : (fexp1 (ln_beta x) = (ln_beta x + 1))%Z) by omega. - destruct (Rlt_or_le x (bpow (ln_beta x) - / 2 * u2)) as [Hlt'|Hge']. - + now apply double_round_zero. +destruct (Ztrichotomy (mag x) (fexp1 (mag x) - 1)) as [Hlt|[Heq|Hgt]]. +- (* mag x < fexp1 (mag x) - 1 *) + assert (H : (mag x <= fexp1 (mag x) - 2)%Z) by omega. + now apply round_round_really_zero. +- (* mag x = fexp1 (mag x) - 1 *) + assert (H : (fexp1 (mag x) = (mag x + 1))%Z) by omega. + destruct (Rlt_or_le x (bpow (mag x) - / 2 * u2)) as [Hlt'|Hge']. + + now apply round_round_zero. + now apply Cz. -- (* ln_beta x > fexp1 (ln_beta x) - 1 *) - assert (H : (fexp1 (ln_beta x) <= ln_beta x)%Z) by omega. +- (* mag x > fexp1 (mag x) - 1 *) + assert (H : (fexp1 (mag x) <= mag x)%Z) by omega. destruct (Rtotal_order x (midp fexp1 x)) as [Hlt'|[Heq'|Hgt']]. + (* x < midp fexp1 x *) destruct (Rlt_or_le x (midp fexp1 x - / 2 * u2)) as [Hlt''|Hle'']. - * now apply double_round_lt_mid_further_place; [| | |omega| |]. + * now apply round_round_lt_mid_further_place; [| | |omega| |]. * now apply Clt; [|split]. + (* x = midp fexp1 x *) now apply Ceq. @@ -3735,33 +3701,33 @@ destruct (Ztrichotomy (ln_beta x) (fexp1 (ln_beta x) - 1)) as [Hlt|[Heq|Hgt]]. * now apply Cgt; [|split]. * { destruct (generic_format_EM beta fexp1 x) as [Fx|Nfx]. - (* generic_format beta fexp1 x *) - unfold double_round_eq; rewrite (round_generic beta fexp2); + unfold round_round_eq; rewrite (round_generic beta fexp2); [reflexivity|now apply valid_rnd_N|]. - now apply (generic_inclusion_ln_beta beta fexp1); [omega|]. + now apply (generic_inclusion_mag beta fexp1); [omega|]. - (* ~ generic_format beta fexp1 x *) assert (Hceil : round beta fexp1 Zceil x = x' + u1); [now apply round_UP_DN_ulp|]. - assert (Hf2' : (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z); + assert (Hf2' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z); [omega|]. assert (midp' fexp1 x + / 2 * ulp beta fexp2 x < x); - [|now apply double_round_gt_mid_further_place]. + [|now apply round_round_gt_mid_further_place]. revert Hle''; unfold midp, midp'; fold x'. rewrite Hceil; fold u1; fold u2. lra. } Qed. -Lemma ln_beta_div_disj : +Lemma mag_div_disj : forall x y : R, 0 < x -> 0 < y -> - ((ln_beta (x / y) = ln_beta x - ln_beta y :> Z)%Z - \/ (ln_beta (x / y) = ln_beta x - ln_beta y + 1 :> Z)%Z). + ((mag (x / y) = mag x - mag y :> Z)%Z + \/ (mag (x / y) = mag x - mag y + 1 :> Z)%Z). Proof. intros x y Px Py. -generalize (ln_beta_div beta x y Px Py). +generalize (mag_div beta x y (Rgt_not_eq _ _ Px) (Rgt_not_eq _ _ Py)). omega. Qed. -Definition double_round_div_hyp fexp1 fexp2 := +Definition round_round_div_hyp fexp1 fexp2 := (forall ex, (fexp2 ex <= fexp1 ex - 1)%Z) /\ (forall ex ey, (fexp1 ex < ex)%Z -> (fexp1 ey < ey)%Z -> (fexp1 (ex - ey) <= ex - ey + 1)%Z -> @@ -3777,63 +3743,63 @@ Definition double_round_div_hyp fexp1 fexp2 := (fexp1 (ex - ey) = ex - ey + 1)%Z -> (fexp2 (ex - ey) <= ex - ey - ey + fexp1 ey)%Z). -Lemma double_round_div_aux0 : +Lemma round_round_div_aux0 : forall fexp1 fexp2 : Z -> Z, Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_div_hyp fexp1 fexp2 -> + round_round_div_hyp fexp1 fexp2 -> forall x y, 0 < x -> 0 < y -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - fexp1 (ln_beta (x / y)) = (ln_beta (x / y) + 1)%Z -> - ~ (bpow (ln_beta (x / y)) - / 2 * ulp beta fexp2 (x / y) <= x / y). + fexp1 (mag (x / y)) = (mag (x / y) + 1)%Z -> + ~ (bpow (mag (x / y)) - / 2 * ulp beta fexp2 (x / y) <= x / y). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Fx Fy Hf1. -assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. -assert (Hfy : (fexp1 (ln_beta y) < ln_beta y)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. -set (p := bpow (ln_beta (x / y))). -set (u2 := bpow (fexp2 (ln_beta (x / y)))). +assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfy : (fexp1 (mag y) < mag y)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +set (p := bpow (mag (x / y))). +set (u2 := bpow (fexp2 (mag (x / y)))). revert Fx Fy. -unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl. -set (mx := Ztrunc (x * bpow (- fexp1 (ln_beta x)))). -set (my := Ztrunc (y * bpow (- fexp1 (ln_beta y)))). +unfold generic_format, F2R, scaled_mantissa, cexp; simpl. +set (mx := Ztrunc (x * bpow (- fexp1 (mag x)))). +set (my := Ztrunc (y * bpow (- fexp1 (mag y)))). intros Fx Fy. rewrite ulp_neq_0. 2: apply Rmult_integral_contrapositive_currified; [now apply Rgt_not_eq|idtac]. 2: now apply Rinv_neq_0_compat, Rgt_not_eq. intro Hl. assert (Hr : x / y < p); - [now apply Rabs_lt_inv; apply bpow_ln_beta_gt|]. + [now apply Rabs_lt_inv; apply bpow_mag_gt|]. apply (Rlt_irrefl (p - / 2 * u2)). apply (Rle_lt_trans _ _ _ Hl). apply (Rmult_lt_reg_r y _ _ Py). unfold Rdiv; rewrite Rmult_assoc. rewrite Rinv_l; [|now apply Rgt_not_eq]; rewrite Rmult_1_r. -destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - ln_beta (x / y) - - fexp1 (ln_beta y))%Z) as [He|He]. -- (* ln_beta (x / y) + fexp1 (ln_beta y) <= fexp1 (ln_beta x) *) - apply Rle_lt_trans with (p * y - p * bpow (fexp1 (ln_beta y))). +destruct (Zle_or_lt Z0 (fexp1 (mag x) - mag (x / y) + - fexp1 (mag y))%Z) as [He|He]. +- (* mag (x / y) + fexp1 (mag y) <= fexp1 (mag x) *) + apply Rle_lt_trans with (p * y - p * bpow (fexp1 (mag y))). + rewrite Fx; rewrite Fy at 1. rewrite <- Rmult_assoc. rewrite (Rmult_comm p). unfold p; bpow_simplify. - apply (Rmult_le_reg_r (bpow (- ln_beta (x / y) - fexp1 (ln_beta y)))); + apply (Rmult_le_reg_r (bpow (- mag (x / y) - fexp1 (mag y)))); [now apply bpow_gt_0|]. rewrite Rmult_minus_distr_r. bpow_simplify. - rewrite <- Z2R_Zpower; [|exact He]. - rewrite <- Z2R_mult. - change 1 with (Z2R 1); rewrite <- Z2R_minus. - apply Z2R_le. + rewrite <- IZR_Zpower; [|exact He]. + rewrite <- mult_IZR. + rewrite <- minus_IZR. + apply IZR_le. apply (Zplus_le_reg_r _ _ 1); ring_simplify. apply Zlt_le_succ. - apply lt_Z2R. - rewrite Z2R_mult. - rewrite Z2R_Zpower; [|exact He]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta y) + ln_beta (x / y)))); + apply lt_IZR. + rewrite mult_IZR. + rewrite IZR_Zpower; [|exact He]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag y) + mag (x / y)))); [now apply bpow_gt_0|]. bpow_simplify. rewrite <- Fx. @@ -3845,7 +3811,7 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - ln_beta (x / y) + rewrite Rmult_minus_distr_r. unfold Rminus; apply Rplus_lt_compat_l. apply Ropp_lt_contravar. - apply Rlt_le_trans with (u2 * bpow (ln_beta y)). + apply Rlt_le_trans with (u2 * bpow (mag y)). * rewrite <- (Rmult_1_l (u2 * _)). rewrite Rmult_assoc. { apply Rmult_lt_compat. @@ -3854,38 +3820,38 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - ln_beta (x / y) - lra. - apply Rmult_lt_compat_l; [now apply bpow_gt_0|]. apply Rabs_lt_inv. - apply bpow_ln_beta_gt. } - * unfold u2, p, ulp, canonic_exp; bpow_simplify; apply bpow_le. - apply (Zplus_le_reg_r _ _ (- ln_beta y)); ring_simplify. - rewrite (Zplus_comm (- _)); fold (Zminus (ln_beta (x / y)) (ln_beta y)). - destruct (ln_beta_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; + apply bpow_mag_gt. } + * unfold u2, p, ulp, cexp; bpow_simplify; apply bpow_le. + apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify. + rewrite (Zplus_comm (- _)); fold (Zminus (mag (x / y)) (mag y)). + destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; [now apply Hexp; [| |rewrite <- Hxy]|]. - replace (_ - _ + 1)%Z with ((ln_beta x + 1) - ln_beta y)%Z by ring. + replace (_ - _ + 1)%Z with ((mag x + 1) - mag y)%Z by ring. apply Hexp. - { now assert (fexp1 (ln_beta x + 1) <= ln_beta x)%Z; + { now assert (fexp1 (mag x + 1) <= mag x)%Z; [apply valid_exp|omega]. } { assumption. } - replace (_ + 1 - _)%Z with (ln_beta x - ln_beta y + 1)%Z by ring. + replace (_ + 1 - _)%Z with (mag x - mag y + 1)%Z by ring. now rewrite <- Hxy. -- (* fexp1 (ln_beta x) < ln_beta (x / y) + fexp1 (ln_beta y) *) - apply Rle_lt_trans with (p * y - bpow (fexp1 (ln_beta x))). +- (* fexp1 (mag x) < mag (x / y) + fexp1 (mag y) *) + apply Rle_lt_trans with (p * y - bpow (fexp1 (mag x))). + rewrite Fx at 1; rewrite Fy at 1. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_minus_distr_r. bpow_simplify. rewrite (Rmult_comm p). unfold p; bpow_simplify. - rewrite <- Z2R_Zpower; [|omega]. - rewrite <- Z2R_mult. - change 1 with (Z2R 1); rewrite <- Z2R_minus. - apply Z2R_le. + rewrite <- IZR_Zpower; [|omega]. + rewrite <- mult_IZR. + rewrite <- minus_IZR. + apply IZR_le. apply (Zplus_le_reg_r _ _ 1); ring_simplify. apply Zlt_le_succ. - apply lt_Z2R. - rewrite Z2R_mult. - rewrite Z2R_Zpower; [|omega]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); + apply lt_IZR. + rewrite mult_IZR. + rewrite IZR_Zpower; [|omega]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|bpow_simplify]. rewrite <- Fx. rewrite Zplus_comm; rewrite bpow_plus. @@ -3896,7 +3862,7 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - ln_beta (x / y) + rewrite Rmult_minus_distr_r. unfold Rminus; apply Rplus_lt_compat_l. apply Ropp_lt_contravar. - apply Rlt_le_trans with (u2 * bpow (ln_beta y)). + apply Rlt_le_trans with (u2 * bpow (mag y)). * rewrite <- (Rmult_1_l (u2 * _)). rewrite Rmult_assoc. { apply Rmult_lt_compat. @@ -3905,33 +3871,33 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - ln_beta (x / y) - lra. - apply Rmult_lt_compat_l; [now apply bpow_gt_0|]. apply Rabs_lt_inv. - apply bpow_ln_beta_gt. } - * unfold u2, p, ulp, canonic_exp; bpow_simplify; apply bpow_le. - apply (Zplus_le_reg_r _ _ (- ln_beta y)); ring_simplify. - rewrite (Zplus_comm (- _)); fold (Zminus (ln_beta (x / y)) (ln_beta y)). - destruct (ln_beta_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; - apply Hexp; try assumption; rewrite <- Hxy; rewrite Hf1; apply Zle_refl. + apply bpow_mag_gt. } + * unfold u2, p, ulp, cexp; bpow_simplify; apply bpow_le. + apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify. + rewrite (Zplus_comm (- _)); fold (Zminus (mag (x / y)) (mag y)). + destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; + apply Hexp; try assumption; rewrite <- Hxy; rewrite Hf1; apply Z.le_refl. Qed. -Lemma double_round_div_aux1 : +Lemma round_round_div_aux1 : forall fexp1 fexp2 : Z -> Z, Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_div_hyp fexp1 fexp2 -> + round_round_div_hyp fexp1 fexp2 -> forall x y, 0 < x -> 0 < y -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - (fexp1 (ln_beta (x / y)) <= ln_beta (x / y))%Z -> + (fexp1 (mag (x / y)) <= mag (x / y))%Z -> ~ (midp fexp1 (x / y) - / 2 * ulp beta fexp2 (x / y) <= x / y < midp fexp1 (x / y)). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Fx Fy Hf1. -assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. -assert (Hfy : (fexp1 (ln_beta y) < ln_beta y)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfy : (fexp1 (mag y) < mag y)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. assert (S : (x / y <> 0)%R). apply Rmult_integral_contrapositive_currified; [now apply Rgt_not_eq|idtac]. now apply Rinv_neq_0_compat, Rgt_not_eq. @@ -3945,14 +3911,14 @@ cut (~ (/ 2 * (ulp beta fexp1 (x / y) - ulp beta fexp2 (x / y)) - apply (Rplus_lt_reg_l (round beta fexp1 Zfloor (x / y))). ring_simplify. apply H'. } -set (u1 := bpow (fexp1 (ln_beta (x / y)))). -set (u2 := bpow (fexp2 (ln_beta (x / y)))). +set (u1 := bpow (fexp1 (mag (x / y)))). +set (u2 := bpow (fexp2 (mag (x / y)))). set (x' := round beta fexp1 Zfloor (x / y)). rewrite 2!ulp_neq_0; trivial. revert Fx Fy. -unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl. -set (mx := Ztrunc (x * bpow (- fexp1 (ln_beta x)))). -set (my := Ztrunc (y * bpow (- fexp1 (ln_beta y)))). +unfold generic_format, F2R, scaled_mantissa, cexp; simpl. +set (mx := Ztrunc (x * bpow (- fexp1 (mag x)))). +set (my := Ztrunc (y * bpow (- fexp1 (mag y)))). intros Fx Fy. intro Hlr. apply (Rlt_irrefl (/ 2 * (u1 - u2))). @@ -3966,48 +3932,47 @@ apply (Rmult_lt_reg_l 2); [lra|]. rewrite Rmult_minus_distr_l; rewrite Rmult_plus_distr_l. do 5 rewrite <- Rmult_assoc. rewrite Rinv_r; [|lra]; do 2 rewrite Rmult_1_l. -destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - fexp1 (ln_beta (x / y)) - - fexp1 (ln_beta y))%Z) as [He|He]. -- (* fexp1 (ln_beta (x / y)) + fexp1 (ln_beta y)) <= fexp1 (ln_beta x) *) +destruct (Zle_or_lt Z0 (fexp1 (mag x) - fexp1 (mag (x / y)) + - fexp1 (mag y))%Z) as [He|He]. +- (* fexp1 (mag (x / y)) + fexp1 (mag y)) <= fexp1 (mag x) *) apply Rle_lt_trans with (2 * x' * y + u1 * y - - bpow (fexp1 (ln_beta (x / y)) - + fexp1 (ln_beta y))). + - bpow (fexp1 (mag (x / y)) + + fexp1 (mag y))). + rewrite Fx at 1; rewrite Fy at 1 2. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta (x / y)) - - fexp1 (ln_beta y)))); + apply (Rmult_le_reg_r (bpow (- fexp1 (mag (x / y)) + - fexp1 (mag y)))); [now apply bpow_gt_0|]. rewrite Rmult_minus_distr_r; rewrite (Rmult_plus_distr_r (_ * _ * _)). bpow_simplify. replace (2 * x' * _ * _) - with (2 * Z2R my * x' * bpow (- fexp1 (ln_beta (x / y)))) by ring. + with (2 * IZR my * x' * bpow (- fexp1 (mag (x / y)))) by ring. rewrite (Rmult_comm u1). - unfold x', u1, round, F2R, ulp, scaled_mantissa, canonic_exp; simpl. + unfold x', u1, round, F2R, ulp, scaled_mantissa, cexp; simpl. bpow_simplify. - rewrite <- Z2R_Zpower; [|exact He]. - change 2 with (Z2R 2). - do 4 rewrite <- Z2R_mult. - rewrite <- Z2R_plus. - change 1 with (Z2R 1); rewrite <- Z2R_minus. - apply Z2R_le. + rewrite <- IZR_Zpower; [|exact He]. + do 4 rewrite <- mult_IZR. + rewrite <- plus_IZR. + rewrite <- minus_IZR. + apply IZR_le. apply (Zplus_le_reg_r _ _ 1); ring_simplify. apply Zlt_le_succ. - apply lt_Z2R. - rewrite Z2R_plus. - do 4 rewrite Z2R_mult; simpl. - rewrite Z2R_Zpower; [|exact He]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta (x / y)) - + fexp1 (ln_beta y)))); + apply lt_IZR. + rewrite plus_IZR. + do 4 rewrite mult_IZR; simpl. + rewrite IZR_Zpower; [|exact He]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag (x / y)) + + fexp1 (mag y)))); [now apply bpow_gt_0|bpow_simplify]. rewrite Rmult_assoc. rewrite <- Fx. - rewrite (Rmult_plus_distr_r _ _ (Fcore_Raux.bpow _ _)). + rewrite (Rmult_plus_distr_r _ _ (Raux.bpow _ _)). rewrite Rmult_assoc. rewrite bpow_plus. - rewrite <- (Rmult_assoc (Z2R (Zfloor _))). - change (Z2R (Zfloor _) * _) with x'. - do 2 rewrite (Rmult_comm _ (bpow (fexp1 (ln_beta y)))). + rewrite <- (Rmult_assoc (IZR (Zfloor _))). + change (IZR (Zfloor _) * _) with x'. + do 2 rewrite (Rmult_comm _ (bpow (fexp1 (mag y)))). rewrite Rmult_assoc. - do 2 rewrite <- (Rmult_assoc (Z2R my)). + do 2 rewrite <- (Rmult_assoc (IZR my)). rewrite <- Fy. change (bpow _) with u1. apply (Rmult_lt_reg_l (/ 2)); [lra|]. @@ -4022,60 +3987,59 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - fexp1 (ln_beta (x / y)) now rewrite Rmult_comm. + apply Rplus_lt_compat_l. apply Ropp_lt_contravar. - apply Rlt_le_trans with (u2 * bpow (ln_beta y)). + apply Rlt_le_trans with (u2 * bpow (mag y)). * { apply Rmult_lt_compat_l. - apply bpow_gt_0. - apply Rabs_lt_inv. - apply bpow_ln_beta_gt. } - * unfold u2, ulp, canonic_exp; bpow_simplify; apply bpow_le. - apply (Zplus_le_reg_r _ _ (- ln_beta y)); ring_simplify. + apply bpow_mag_gt. } + * unfold u2, ulp, cexp; bpow_simplify; apply bpow_le. + apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify. rewrite <- Zplus_assoc; rewrite (Zplus_comm (- _)). - destruct (ln_beta_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; + destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; [now apply Hexp; [| |rewrite <- Hxy]|]. - replace (_ - _ + 1)%Z with ((ln_beta x + 1) - ln_beta y)%Z by ring. + replace (_ - _ + 1)%Z with ((mag x + 1) - mag y)%Z by ring. apply Hexp. - { now assert (fexp1 (ln_beta x + 1) <= ln_beta x)%Z; + { now assert (fexp1 (mag x + 1) <= mag x)%Z; [apply valid_exp|omega]. } { assumption. } - replace (_ + 1 - _)%Z with (ln_beta x - ln_beta y + 1)%Z by ring. + replace (_ + 1 - _)%Z with (mag x - mag y + 1)%Z by ring. now rewrite <- Hxy. -- (* fexp1 (ln_beta x) < fexp1 (ln_beta (x / y)) + fexp1 (ln_beta y) *) - apply Rle_lt_trans with (2 * x' * y + u1 * y - bpow (fexp1 (ln_beta x))). +- (* fexp1 (mag x) < fexp1 (mag (x / y)) + fexp1 (mag y) *) + apply Rle_lt_trans with (2 * x' * y + u1 * y - bpow (fexp1 (mag x))). + rewrite Fx at 1; rewrite Fy at 1 2. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_minus_distr_r; rewrite (Rmult_plus_distr_r (_ * _ * _)). bpow_simplify. replace (2 * x' * _ * _) - with (2 * Z2R my * x' * bpow (fexp1 (ln_beta y) - fexp1 (ln_beta x))) by ring. + with (2 * IZR my * x' * bpow (fexp1 (mag y) - fexp1 (mag x))) by ring. rewrite (Rmult_comm u1). - unfold x', u1, round, F2R, ulp, scaled_mantissa, canonic_exp; simpl. + unfold x', u1, round, F2R, ulp, scaled_mantissa, cexp; simpl. bpow_simplify. - rewrite <- (Z2R_Zpower _ (_ - _)%Z); [|omega]. - change 2 with (Z2R 2). - do 5 rewrite <- Z2R_mult. - rewrite <- Z2R_plus. - change 1 with (Z2R 1); rewrite <- Z2R_minus. - apply Z2R_le. + rewrite <- (IZR_Zpower _ (_ - _)%Z); [|omega]. + do 5 rewrite <- mult_IZR. + rewrite <- plus_IZR. + rewrite <- minus_IZR. + apply IZR_le. apply (Zplus_le_reg_r _ _ 1); ring_simplify. apply Zlt_le_succ. - apply lt_Z2R. - rewrite Z2R_plus. - do 5 rewrite Z2R_mult; simpl. - rewrite Z2R_Zpower; [|omega]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); + apply lt_IZR. + rewrite plus_IZR. + do 5 rewrite mult_IZR; simpl. + rewrite IZR_Zpower; [|omega]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. rewrite Rmult_assoc. rewrite <- Fx. - rewrite (Rmult_plus_distr_r _ _ (Fcore_Raux.bpow _ _)). + rewrite (Rmult_plus_distr_r _ _ (Raux.bpow _ _)). bpow_simplify. rewrite Rmult_assoc. rewrite bpow_plus. - rewrite <- (Rmult_assoc (Z2R (Zfloor _))). - change (Z2R (Zfloor _) * _) with x'. - do 2 rewrite (Rmult_comm _ (bpow (fexp1 (ln_beta y)))). + rewrite <- (Rmult_assoc (IZR (Zfloor _))). + change (IZR (Zfloor _) * _) with x'. + do 2 rewrite (Rmult_comm _ (bpow (fexp1 (mag y)))). rewrite Rmult_assoc. - do 2 rewrite <- (Rmult_assoc (Z2R my)). + do 2 rewrite <- (Rmult_assoc (IZR my)). rewrite <- Fy. change (bpow _) with u1. apply (Rmult_lt_reg_l (/ 2)); [lra|]. @@ -4090,37 +4054,37 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - fexp1 (ln_beta (x / y)) now rewrite Rmult_comm. + apply Rplus_lt_compat_l. apply Ropp_lt_contravar. - apply Rlt_le_trans with (u2 * bpow (ln_beta y)). + apply Rlt_le_trans with (u2 * bpow (mag y)). * { apply Rmult_lt_compat_l. - apply bpow_gt_0. - apply Rabs_lt_inv. - apply bpow_ln_beta_gt. } - * unfold u2, ulp, canonic_exp; bpow_simplify; apply bpow_le. - apply (Zplus_le_reg_r _ _ (- ln_beta y)); ring_simplify. + apply bpow_mag_gt. } + * unfold u2, ulp, cexp; bpow_simplify; apply bpow_le. + apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify. rewrite (Zplus_comm (- _)). - destruct (ln_beta_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; + destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; apply Hexp; try assumption; rewrite <- Hxy; omega. Qed. -Lemma double_round_div_aux2 : +Lemma round_round_div_aux2 : forall fexp1 fexp2 : Z -> Z, Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), - double_round_div_hyp fexp1 fexp2 -> + round_round_div_hyp fexp1 fexp2 -> forall x y, 0 < x -> 0 < y -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - (fexp1 (ln_beta (x / y)) <= ln_beta (x / y))%Z -> + (fexp1 (mag (x / y)) <= mag (x / y))%Z -> ~ (midp fexp1 (x / y) < x / y <= midp fexp1 (x / y) + / 2 * ulp beta fexp2 (x / y)). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Fx Fy Hf1. -assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. -assert (Hfy : (fexp1 (ln_beta y) < ln_beta y)%Z); - [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfy : (fexp1 (mag y) < mag y)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. cut (~ (/ 2 * ulp beta fexp1 (x / y) < x / y - round beta fexp1 Zfloor (x / y) <= / 2 * (ulp beta fexp1 (x / y) + ulp beta fexp2 (x / y)))). @@ -4131,17 +4095,17 @@ cut (~ (/ 2 * ulp beta fexp1 (x / y) - apply (Rplus_le_reg_l (round beta fexp1 Zfloor (x / y))). ring_simplify. apply H'. } -set (u1 := bpow (fexp1 (ln_beta (x / y)))). -set (u2 := bpow (fexp2 (ln_beta (x / y)))). +set (u1 := bpow (fexp1 (mag (x / y)))). +set (u2 := bpow (fexp2 (mag (x / y)))). set (x' := round beta fexp1 Zfloor (x / y)). assert (S : (x / y <> 0)%R). apply Rmult_integral_contrapositive_currified; [now apply Rgt_not_eq|idtac]. now apply Rinv_neq_0_compat, Rgt_not_eq. rewrite 2!ulp_neq_0; trivial. revert Fx Fy. -unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl. -set (mx := Ztrunc (x * bpow (- fexp1 (ln_beta x)))). -set (my := Ztrunc (y * bpow (- fexp1 (ln_beta y)))). +unfold generic_format, F2R, scaled_mantissa, cexp; simpl. +set (mx := Ztrunc (x * bpow (- fexp1 (mag x)))). +set (my := Ztrunc (y * bpow (- fexp1 (mag y)))). intros Fx Fy. intro Hlr. apply (Rlt_irrefl (/ 2 * (u1 + u2))). @@ -4155,76 +4119,75 @@ apply (Rmult_lt_reg_l 2); [lra|]. do 2 rewrite Rmult_plus_distr_l. do 5 rewrite <- Rmult_assoc. rewrite Rinv_r; [|lra]; do 2 rewrite Rmult_1_l. -destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - fexp1 (ln_beta (x / y)) - - fexp1 (ln_beta y))%Z) as [He|He]. -- (* fexp1 (ln_beta (x / y)) + fexp1 (ln_beta y) <= fexp1 (ln_beta x) *) - apply Rlt_le_trans with (u1 * y + bpow (fexp1 (ln_beta (x / y)) - + fexp1 (ln_beta y)) +destruct (Zle_or_lt Z0 (fexp1 (mag x) - fexp1 (mag (x / y)) + - fexp1 (mag y))%Z) as [He|He]. +- (* fexp1 (mag (x / y)) + fexp1 (mag y) <= fexp1 (mag x) *) + apply Rlt_le_trans with (u1 * y + bpow (fexp1 (mag (x / y)) + + fexp1 (mag y)) + 2 * x' * y). + apply Rplus_lt_compat_r, Rplus_lt_compat_l. - apply Rlt_le_trans with (u2 * bpow (ln_beta y)). + apply Rlt_le_trans with (u2 * bpow (mag y)). * { apply Rmult_lt_compat_l. - apply bpow_gt_0. - apply Rabs_lt_inv. - apply bpow_ln_beta_gt. } - * unfold u2, ulp, canonic_exp; bpow_simplify; apply bpow_le. - apply (Zplus_le_reg_r _ _ (- ln_beta y)); ring_simplify. + apply bpow_mag_gt. } + * unfold u2, ulp, cexp; bpow_simplify; apply bpow_le. + apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify. rewrite <- Zplus_assoc; rewrite (Zplus_comm (- _)). - destruct (ln_beta_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; + destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; [now apply Hexp; [| |rewrite <- Hxy]|]. - replace (_ - _ + 1)%Z with ((ln_beta x + 1) - ln_beta y)%Z by ring. + replace (_ - _ + 1)%Z with ((mag x + 1) - mag y)%Z by ring. apply Hexp. - { now assert (fexp1 (ln_beta x + 1) <= ln_beta x)%Z; + { now assert (fexp1 (mag x + 1) <= mag x)%Z; [apply valid_exp|omega]. } { assumption. } - replace (_ + 1 - _)%Z with (ln_beta x - ln_beta y + 1)%Z by ring. + replace (_ + 1 - _)%Z with (mag x - mag y + 1)%Z by ring. now rewrite <- Hxy. + apply Rge_le; rewrite Fx at 1; apply Rle_ge. - replace (u1 * y) with (u1 * (Z2R my * bpow (fexp1 (ln_beta y)))); + replace (u1 * y) with (u1 * (IZR my * bpow (fexp1 (mag y)))); [|now apply eq_sym; rewrite Fy at 1]. - replace (2 * x' * y) with (2 * x' * (Z2R my * bpow (fexp1 (ln_beta y)))); + replace (2 * x' * y) with (2 * x' * (IZR my * bpow (fexp1 (mag y)))); [|now apply eq_sym; rewrite Fy at 1]. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta (x / y)) - - fexp1 (ln_beta y)))); + apply (Rmult_le_reg_r (bpow (- fexp1 (mag (x / y)) + - fexp1 (mag y)))); [now apply bpow_gt_0|]. do 2 rewrite Rmult_plus_distr_r. bpow_simplify. rewrite (Rmult_comm u1). - unfold u1, ulp, canonic_exp; bpow_simplify. + unfold u1, ulp, cexp; bpow_simplify. rewrite (Rmult_assoc 2). rewrite (Rmult_comm x'). rewrite (Rmult_assoc 2). - unfold x', round, F2R, scaled_mantissa, canonic_exp; simpl. + unfold x', round, F2R, scaled_mantissa, cexp; simpl. bpow_simplify. - rewrite <- (Z2R_Zpower _ (_ - _)%Z); [|exact He]. - change 2 with (Z2R 2). - do 4 rewrite <- Z2R_mult. - change 1 with (Z2R 1); do 2 rewrite <- Z2R_plus. - apply Z2R_le. + rewrite <- (IZR_Zpower _ (_ - _)%Z); [|exact He]. + do 4 rewrite <- mult_IZR. + do 2 rewrite <- plus_IZR. + apply IZR_le. rewrite Zplus_comm, Zplus_assoc. apply Zlt_le_succ. - apply lt_Z2R. - rewrite Z2R_plus. - do 4 rewrite Z2R_mult; simpl. - rewrite Z2R_Zpower; [|exact He]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta y)))); + apply lt_IZR. + rewrite plus_IZR. + do 4 rewrite mult_IZR; simpl. + rewrite IZR_Zpower; [|exact He]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag y)))); [now apply bpow_gt_0|]. rewrite Rmult_plus_distr_r. - rewrite (Rmult_comm _ (Z2R _)). + rewrite (Rmult_comm _ (IZR _)). do 2 rewrite Rmult_assoc. rewrite <- Fy. bpow_simplify. unfold Zminus; rewrite bpow_plus. - rewrite (Rmult_assoc _ (Z2R mx)). - rewrite <- (Rmult_assoc (Z2R mx)). + rewrite (Rmult_assoc _ (IZR mx)). + rewrite <- (Rmult_assoc (IZR mx)). rewrite <- Fx. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta (x / y))))); + apply (Rmult_lt_reg_r (bpow (fexp1 (mag (x / y))))); [now apply bpow_gt_0|]. rewrite Rmult_plus_distr_r. bpow_simplify. rewrite (Rmult_comm _ y). do 2 rewrite Rmult_assoc. - change (Z2R (Zfloor _) * _) with x'. + change (IZR (Zfloor _) * _) with x'. change (bpow _) with u1. apply (Rmult_lt_reg_l (/ 2)); [lra|]. rewrite Rmult_plus_distr_l. @@ -4239,52 +4202,51 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - fexp1 (ln_beta (x / y)) rewrite Rinv_l; [|now apply Rgt_not_eq]; do 2 rewrite Rmult_1_l. rewrite (Rmult_comm (/ y)). now rewrite (Rplus_comm (- x')). -- (* fexp1 (ln_beta x) < fexp1 (ln_beta (x / y)) + fexp1 (ln_beta y) *) - apply Rlt_le_trans with (2 * x' * y + u1 * y + bpow (fexp1 (ln_beta x))). +- (* fexp1 (mag x) < fexp1 (mag (x / y)) + fexp1 (mag y) *) + apply Rlt_le_trans with (2 * x' * y + u1 * y + bpow (fexp1 (mag x))). + rewrite Rplus_comm, Rplus_assoc; do 2 apply Rplus_lt_compat_l. - apply Rlt_le_trans with (u2 * bpow (ln_beta y)). + apply Rlt_le_trans with (u2 * bpow (mag y)). * apply Rmult_lt_compat_l. now apply bpow_gt_0. - now apply Rabs_lt_inv; apply bpow_ln_beta_gt. - * unfold u2, ulp, canonic_exp; bpow_simplify; apply bpow_le. - apply (Zplus_le_reg_r _ _ (- ln_beta y)); ring_simplify. + now apply Rabs_lt_inv; apply bpow_mag_gt. + * unfold u2, ulp, cexp; bpow_simplify; apply bpow_le. + apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify. rewrite (Zplus_comm (- _)). - destruct (ln_beta_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; + destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; apply Hexp; try assumption; rewrite <- Hxy; omega. + apply Rge_le; rewrite Fx at 1; apply Rle_ge. rewrite Fy at 1 2. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. do 2 rewrite Rmult_plus_distr_r. bpow_simplify. replace (2 * x' * _ * _) - with (2 * Z2R my * x' * bpow (fexp1 (ln_beta y) - fexp1 (ln_beta x))) by ring. + with (2 * IZR my * x' * bpow (fexp1 (mag y) - fexp1 (mag x))) by ring. rewrite (Rmult_comm u1). - unfold x', u1, round, F2R, ulp, scaled_mantissa, canonic_exp; simpl. + unfold x', u1, round, F2R, ulp, scaled_mantissa, cexp; simpl. bpow_simplify. - rewrite <- (Z2R_Zpower _ (_ - _)%Z); [|omega]. - change 2 with (Z2R 2). - do 5 rewrite <- Z2R_mult. - change 1 with (Z2R 1); do 2 rewrite <- Z2R_plus. - apply Z2R_le. + rewrite <- (IZR_Zpower _ (_ - _)%Z); [|omega]. + do 5 rewrite <- mult_IZR. + do 2 rewrite <- plus_IZR. + apply IZR_le. apply Zlt_le_succ. - apply lt_Z2R. - rewrite Z2R_plus. - do 5 rewrite Z2R_mult; simpl. - rewrite Z2R_Zpower; [|omega]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); + apply lt_IZR. + rewrite plus_IZR. + do 5 rewrite mult_IZR; simpl. + rewrite IZR_Zpower; [|omega]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. - rewrite (Rmult_assoc _ (Z2R mx)). + rewrite (Rmult_assoc _ (IZR mx)). rewrite <- Fx. rewrite Rmult_plus_distr_r. bpow_simplify. rewrite bpow_plus. rewrite Rmult_assoc. - rewrite <- (Rmult_assoc (Z2R _)). - change (Z2R _ * bpow _) with x'. - do 2 rewrite (Rmult_comm _ (bpow (fexp1 (ln_beta y)))). + rewrite <- (Rmult_assoc (IZR _)). + change (IZR _ * bpow _) with x'. + do 2 rewrite (Rmult_comm _ (bpow (fexp1 (mag y)))). rewrite Rmult_assoc. - do 2 rewrite <- (Rmult_assoc (Z2R my)). + do 2 rewrite <- (Rmult_assoc (IZR my)). rewrite <- Fy. change (bpow _) with u1. apply (Rmult_lt_reg_l (/ 2)); [lra|]. @@ -4302,55 +4264,55 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - fexp1 (ln_beta (x / y)) now rewrite (Rplus_comm (- x')). Qed. -Lemma double_round_div_aux : +Lemma round_round_div_aux : forall fexp1 fexp2 : Z -> Z, Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), (exists n, (beta = 2 * n :> Z)%Z) -> - double_round_div_hyp fexp1 fexp2 -> + round_round_div_hyp fexp1 fexp2 -> forall x y, 0 < x -> 0 < y -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x / y). + round_round_eq fexp1 fexp2 choice1 choice2 (x / y). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Ebeta Hexp x y Px Py Fx Fy. assert (Pxy : 0 < x / y). { apply Rmult_lt_0_compat; [exact Px|]. now apply Rinv_0_lt_compat. } -apply double_round_all_mid_cases. +apply round_round_all_mid_cases. - exact Vfexp1. - exact Vfexp2. - exact Pxy. - apply Hexp. - intros Hf1 Hlxy. casetype False. - now apply (double_round_div_aux0 fexp1 fexp2 _ _ choice1 choice2 Hexp x y). + now apply (round_round_div_aux0 fexp1 fexp2 _ _ choice1 choice2 Hexp x y). - intros Hf1 Hlxy. casetype False. - now apply (double_round_div_aux1 fexp1 fexp2 _ _ choice1 choice2 Hexp x y). + now apply (round_round_div_aux1 fexp1 fexp2 _ _ choice1 choice2 Hexp x y). - intro H. - apply double_round_eq_mid_beta_even; try assumption. + apply round_round_eq_mid_beta_even; try assumption. apply Hexp. - intros Hf1 Hlxy. casetype False. - now apply (double_round_div_aux2 fexp1 fexp2 _ _ choice1 choice2 Hexp x y). + now apply (round_round_div_aux2 fexp1 fexp2 _ _ choice1 choice2 Hexp x y). Qed. -Lemma double_round_div : +Lemma round_round_div : forall fexp1 fexp2 : Z -> Z, Valid_exp fexp1 -> Valid_exp fexp2 -> forall (choice1 choice2 : Z -> bool), (exists n, (beta = 2 * n :> Z)%Z) -> - double_round_div_hyp fexp1 fexp2 -> + round_round_div_hyp fexp1 fexp2 -> forall x y, y <> 0 -> generic_format beta fexp1 x -> generic_format beta fexp1 y -> - double_round_eq fexp1 fexp2 choice1 choice2 (x / y). + round_round_eq fexp1 fexp2 choice1 choice2 (x / y). Proof. intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Ebeta Hexp x y Nzy Fx Fy. -unfold double_round_eq. +unfold round_round_eq. destruct (Rtotal_order x 0) as [Nx|[Zx|Px]]. - (* x < 0 *) destruct (Rtotal_order y 0) as [Ny|[Zy|Py]]. @@ -4367,7 +4329,7 @@ destruct (Rtotal_order x 0) as [Nx|[Zx|Px]]. rewrite Ropp_0 in Nx, Ny. apply generic_format_opp in Fx. apply generic_format_opp in Fy. - now apply double_round_div_aux. + now apply round_round_div_aux. + (* y = 0 *) now casetype False; apply Nzy. + (* y > 0 *) @@ -4378,7 +4340,7 @@ destruct (Rtotal_order x 0) as [Nx|[Zx|Px]]. apply Ropp_lt_contravar in Nx. rewrite Ropp_0 in Nx. apply generic_format_opp in Fx. - now apply double_round_div_aux. + now apply round_round_div_aux. - (* x = 0 *) rewrite Zx. unfold Rdiv; rewrite Rmult_0_l. @@ -4394,50 +4356,48 @@ destruct (Rtotal_order x 0) as [Nx|[Zx|Px]]. apply Ropp_lt_contravar in Ny. rewrite Ropp_0 in Ny. apply generic_format_opp in Fy. - now apply double_round_div_aux. + now apply round_round_div_aux. + (* y = 0 *) now casetype False; apply Nzy. + (* y > 0 *) - now apply double_round_div_aux. + now apply round_round_div_aux. Qed. Section Double_round_div_FLX. -Import Fcore_FLX. - Variable prec : Z. Variable prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FLX_double_round_div_hyp : +Lemma FLX_round_round_div_hyp : (2 * prec <= prec')%Z -> - double_round_div_hyp (FLX_exp prec) (FLX_exp prec'). + round_round_div_hyp (FLX_exp prec) (FLX_exp prec'). Proof. intros Hprec. unfold Prec_gt_0 in prec_gt_0_. unfold FLX_exp. -unfold double_round_div_hyp. +unfold round_round_div_hyp. split; [now intro ex; omega|]. split; [|split; [|split]]; intros ex ey; omega. Qed. -Theorem double_round_div_FLX : +Theorem round_round_div_FLX : forall choice1 choice2, (exists n, (beta = 2 * n :> Z)%Z) -> (2 * prec <= prec')%Z -> forall x y, y <> 0 -> FLX_format beta prec x -> FLX_format beta prec y -> - double_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x / y). + round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x / y). Proof. intros choice1 choice2 Ebeta Hprec x y Nzy Fx Fy. -apply double_round_div. +apply round_round_div. - now apply FLX_exp_valid. - now apply FLX_exp_valid. - exact Ebeta. -- now apply FLX_double_round_div_hyp. +- now apply FLX_round_round_div_hyp. - exact Nzy. - now apply generic_format_FLX. - now apply generic_format_FLX. @@ -4447,24 +4407,21 @@ End Double_round_div_FLX. Section Double_round_div_FLT. -Import Fcore_FLX. -Import Fcore_FLT. - Variable emin prec : Z. Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FLT_double_round_div_hyp : +Lemma FLT_round_round_div_hyp : (emin' <= emin - prec - 2)%Z -> (2 * prec <= prec')%Z -> - double_round_div_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). + round_round_div_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). Proof. intros Hemin Hprec. unfold FLT_exp. unfold Prec_gt_0 in prec_gt_0_. -unfold double_round_div_hyp. +unfold round_round_div_hyp. split; [intro ex|split; [|split; [|split]]; intros ex ey]. - generalize (Zmax_spec (ex - prec') emin'). generalize (Zmax_spec (ex - prec) emin). @@ -4491,7 +4448,7 @@ split; [intro ex|split; [|split; [|split]]; intros ex ey]. omega. Qed. -Theorem double_round_div_FLT : +Theorem round_round_div_FLT : forall choice1 choice2, (exists n, (beta = 2 * n :> Z)%Z) -> (emin' <= emin - prec - 2)%Z -> @@ -4499,15 +4456,15 @@ Theorem double_round_div_FLT : forall x y, y <> 0 -> FLT_format beta emin prec x -> FLT_format beta emin prec y -> - double_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') + round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') choice1 choice2 (x / y). Proof. intros choice1 choice2 Ebeta Hemin Hprec x y Nzy Fx Fy. -apply double_round_div. +apply round_round_div. - now apply FLT_exp_valid. - now apply FLT_exp_valid. - exact Ebeta. -- now apply FLT_double_round_div_hyp. +- now apply FLT_round_round_div_hyp. - exact Nzy. - now apply generic_format_FLT. - now apply generic_format_FLT. @@ -4517,25 +4474,22 @@ End Double_round_div_FLT. Section Double_round_div_FTZ. -Import Fcore_FLX. -Import Fcore_FTZ. - Variable emin prec : Z. Variable emin' prec' : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Context { prec_gt_0_' : Prec_gt_0 prec' }. -Lemma FTZ_double_round_div_hyp : +Lemma FTZ_round_round_div_hyp : (emin' + prec' <= emin - 1)%Z -> (2 * prec <= prec')%Z -> - double_round_div_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). + round_round_div_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). Proof. intros Hemin Hprec. unfold FTZ_exp. unfold Prec_gt_0 in prec_gt_0_. unfold Prec_gt_0 in prec_gt_0_. -unfold double_round_div_hyp. +unfold round_round_div_hyp. split; [intro ex|split; [|split; [|split]]; intros ex ey]. - destruct (Z.ltb_spec (ex - prec') emin'); destruct (Z.ltb_spec (ex - prec) emin); @@ -4562,7 +4516,7 @@ split; [intro ex|split; [|split; [|split]]; intros ex ey]. omega. Qed. -Theorem double_round_div_FTZ : +Theorem round_round_div_FTZ : forall choice1 choice2, (exists n, (beta = 2 * n :> Z)%Z) -> (emin' + prec' <= emin - 1)%Z -> @@ -4570,15 +4524,15 @@ Theorem double_round_div_FTZ : forall x y, y <> 0 -> FTZ_format beta emin prec x -> FTZ_format beta emin prec y -> - double_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') + round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') choice1 choice2 (x / y). Proof. intros choice1 choice2 Ebeta Hemin Hprec x y Nzy Fx Fy. -apply double_round_div. +apply round_round_div. - now apply FTZ_exp_valid. - now apply FTZ_exp_valid. - exact Ebeta. -- now apply FTZ_double_round_div_hyp. +- now apply FTZ_round_round_div_hyp. - exact Nzy. - now apply generic_format_FTZ. - now apply generic_format_FTZ. diff --git a/flocq/Prop/Fprop_div_sqrt_error.v b/flocq/Prop/Fprop_div_sqrt_error.v deleted file mode 100644 index 422b6b64..00000000 --- a/flocq/Prop/Fprop_div_sqrt_error.v +++ /dev/null @@ -1,300 +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 -#<br /># -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. -*) - -(** * Remainder of the division and square root are in the FLX format *) -Require Import Fcore. -Require Import Fcalc_ops. -Require Import Fprop_relative. - -Section Fprop_divsqrt_error. - -Variable beta : radix. -Notation bpow e := (bpow beta e). - -Variable prec : Z. - -Theorem generic_format_plus_prec: - forall fexp, (forall e, (fexp e <= e - prec)%Z) -> - forall x y (fx fy: float beta), - (x = F2R fx)%R -> (y = F2R fy)%R -> (Rabs (x+y) < bpow (prec+Fexp fx))%R -> (Rabs (x+y) < bpow (prec+Fexp fy))%R - -> generic_format beta fexp (x+y)%R. -intros fexp Hfexp x y fx fy Hx Hy H1 H2. -case (Req_dec (x+y) 0); intros H. -rewrite H; apply generic_format_0. -rewrite Hx, Hy, <- F2R_plus. -apply generic_format_F2R. -intros _. -case_eq (Fplus beta fx fy). -intros mz ez Hz. -rewrite <- Hz. -apply Zle_trans with (Zmin (Fexp fx) (Fexp fy)). -rewrite F2R_plus, <- Hx, <- Hy. -unfold canonic_exp. -apply Zle_trans with (1:=Hfexp _). -apply Zplus_le_reg_l with prec; ring_simplify. -apply ln_beta_le_bpow with (1 := H). -now apply Zmin_case. -rewrite <- Fexp_Fplus, Hz. -apply Zle_refl. -Qed. - -Theorem ex_Fexp_canonic: forall fexp, forall x, generic_format beta fexp x - -> exists fx:float beta, (x=F2R fx)%R /\ Fexp fx = canonic_exp beta fexp x. -intros fexp x; unfold generic_format. -exists (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)). -split; auto. -Qed. - - -Context { prec_gt_0_ : Prec_gt_0 prec }. - -Notation format := (generic_format beta (FLX_exp prec)). -Notation cexp := (canonic_exp beta (FLX_exp prec)). - -Variable choice : Z -> bool. - - -(** Remainder of the division in FLX *) -Theorem div_error_FLX : - forall rnd { Zrnd : Valid_rnd rnd } x y, - format x -> format y -> - format (x - round beta (FLX_exp prec) rnd (x/y) * y)%R. -Proof with auto with typeclass_instances. -intros rnd Zrnd x y Hx Hy. -destruct (Req_dec y 0) as [Zy|Zy]. -now rewrite Zy, Rmult_0_r, Rminus_0_r. -destruct (Req_dec (round beta (FLX_exp prec) rnd (x/y)) 0) as [Hr|Hr]. -rewrite Hr; ring_simplify (x-0*y)%R; assumption. -assert (Zx: x <> R0). -contradict Hr. -rewrite Hr. -unfold Rdiv. -now rewrite Rmult_0_l, round_0. -destruct (ex_Fexp_canonic _ x Hx) as (fx,(Hx1,Hx2)). -destruct (ex_Fexp_canonic _ y Hy) as (fy,(Hy1,Hy2)). -destruct (ex_Fexp_canonic (FLX_exp prec) (round beta (FLX_exp prec) rnd (x / y))) as (fr,(Hr1,Hr2)). -apply generic_format_round... -unfold Rminus; apply generic_format_plus_prec with fx (Fopp beta (Fmult beta fr fy)); trivial. -intros e; apply Zle_refl. -now rewrite F2R_opp, F2R_mult, <- Hr1, <- Hy1. -(* *) -destruct (relative_error_FLX_ex beta prec (prec_gt_0 prec) rnd (x / y)%R) as (eps,(Heps1,Heps2)). -rewrite Heps2. -rewrite <- Rabs_Ropp. -replace (-(x + - (x / y * (1 + eps) * y)))%R with (x * eps)%R by now field. -rewrite Rabs_mult. -apply Rlt_le_trans with (Rabs x * 1)%R. -apply Rmult_lt_compat_l. -now apply Rabs_pos_lt. -apply Rlt_le_trans with (1 := Heps1). -change 1%R with (bpow 0). -apply bpow_le. -generalize (prec_gt_0 prec). -clear ; omega. -rewrite Rmult_1_r. -rewrite Hx2. -unfold canonic_exp. -destruct (ln_beta beta x) as (ex, Hex). -simpl. -specialize (Hex Zx). -apply Rlt_le. -apply Rlt_le_trans with (1 := proj2 Hex). -apply bpow_le. -unfold FLX_exp. -ring_simplify. -apply Zle_refl. -(* *) -replace (Fexp (Fopp beta (Fmult beta fr fy))) with (Fexp fr + Fexp fy)%Z. -2: unfold Fopp, Fmult; destruct fr; destruct fy; now simpl. -replace (x + - (round beta (FLX_exp prec) rnd (x / y) * y))%R with - (y * (-(round beta (FLX_exp prec) rnd (x / y) - x/y)))%R. -2: field; assumption. -rewrite Rabs_mult. -apply Rlt_le_trans with (Rabs y * bpow (Fexp fr))%R. -apply Rmult_lt_compat_l. -now apply Rabs_pos_lt. -rewrite Rabs_Ropp. -replace (bpow (Fexp fr)) with (ulp beta (FLX_exp prec) (F2R fr)). -rewrite <- Hr1. -apply error_lt_ulp_round... -apply Rmult_integral_contrapositive_currified; try apply Rinv_neq_0_compat; assumption. -rewrite ulp_neq_0. -2: now rewrite <- Hr1. -apply f_equal. -now rewrite Hr2, <- Hr1. -replace (prec+(Fexp fr+Fexp fy))%Z with ((prec+Fexp fy)+Fexp fr)%Z by ring. -rewrite bpow_plus. -apply Rmult_le_compat_r. -apply bpow_ge_0. -rewrite Hy2; unfold canonic_exp, FLX_exp. -ring_simplify (prec + (ln_beta beta y - prec))%Z. -destruct (ln_beta beta y); simpl. -left; now apply a. -Qed. - -(** Remainder of the square in FLX (with p>1) and rounding to nearest *) -Variable Hp1 : Zlt 1 prec. - -Theorem sqrt_error_FLX_N : - forall x, format x -> - format (x - Rsqr (round beta (FLX_exp prec) (Znearest choice) (sqrt x)))%R. -Proof with auto with typeclass_instances. -intros x Hx. -destruct (total_order_T x 0) as [[Hxz|Hxz]|Hxz]. -unfold sqrt. -destruct (Rcase_abs x). -rewrite round_0... -unfold Rsqr. -now rewrite Rmult_0_l, Rminus_0_r. -elim (Rlt_irrefl 0). -now apply Rgt_ge_trans with x. -rewrite Hxz, sqrt_0, round_0... -unfold Rsqr. -rewrite Rmult_0_l, Rminus_0_r. -apply generic_format_0. -case (Req_dec (round beta (FLX_exp prec) (Znearest choice) (sqrt x)) 0); intros Hr. -rewrite Hr; unfold Rsqr; ring_simplify (x-0*0)%R; assumption. -destruct (ex_Fexp_canonic _ x Hx) as (fx,(Hx1,Hx2)). -destruct (ex_Fexp_canonic (FLX_exp prec) (round beta (FLX_exp prec) (Znearest choice) (sqrt x))) as (fr,(Hr1,Hr2)). -apply generic_format_round... -unfold Rminus; apply generic_format_plus_prec with fx (Fopp beta (Fmult beta fr fr)); trivial. -intros e; apply Zle_refl. -unfold Rsqr; now rewrite F2R_opp,F2R_mult, <- Hr1. -(* *) -apply Rle_lt_trans with x. -apply Rabs_minus_le. -apply Rle_0_sqr. -destruct (relative_error_N_FLX_ex beta prec (prec_gt_0 prec) choice (sqrt x)) as (eps,(Heps1,Heps2)). -rewrite Heps2. -rewrite Rsqr_mult, Rsqr_sqrt, Rmult_comm. 2: now apply Rlt_le. -apply Rmult_le_compat_r. -now apply Rlt_le. -apply Rle_trans with (5²/4²)%R. -rewrite <- Rsqr_div. -apply Rsqr_le_abs_1. -apply Rle_trans with (1 := Rabs_triang _ _). -rewrite Rabs_R1. -apply Rplus_le_reg_l with (-1)%R. -replace (-1 + (1 + Rabs eps))%R with (Rabs eps) by ring. -apply Rle_trans with (1 := Heps1). -rewrite Rabs_pos_eq. -apply Rmult_le_reg_l with 2%R. -now apply (Z2R_lt 0 2). -rewrite <- Rmult_assoc, Rinv_r, Rmult_1_l. -apply Rle_trans with (bpow (-1)). -apply bpow_le. -omega. -replace (2 * (-1 + 5 / 4))%R with (/2)%R by field. -apply Rinv_le. -now apply (Z2R_lt 0 2). -apply (Z2R_le 2). -unfold Zpower_pos. simpl. -rewrite Zmult_1_r. -apply Zle_bool_imp_le. -apply beta. -apply Rgt_not_eq. -now apply (Z2R_lt 0 2). -unfold Rdiv. -apply Rmult_le_pos. -now apply (Z2R_le 0 5). -apply Rlt_le. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 4). -apply Rgt_not_eq. -now apply (Z2R_lt 0 4). -unfold Rsqr. -replace (5 * 5 / (4 * 4))%R with (25 * /16)%R by field. -apply Rmult_le_reg_r with 16%R. -now apply (Z2R_lt 0 16). -rewrite Rmult_assoc, Rinv_l, Rmult_1_r. -now apply (Z2R_le 25 32). -apply Rgt_not_eq. -now apply (Z2R_lt 0 16). -rewrite Hx2; unfold canonic_exp, FLX_exp. -ring_simplify (prec + (ln_beta beta x - prec))%Z. -destruct (ln_beta beta x); simpl. -rewrite <- (Rabs_right x). -apply a. -now apply Rgt_not_eq. -now apply Rgt_ge. -(* *) -replace (Fexp (Fopp beta (Fmult beta fr fr))) with (Fexp fr + Fexp fr)%Z. -2: unfold Fopp, Fmult; destruct fr; now simpl. -rewrite Hr1. -replace (x + - Rsqr (F2R fr))%R with (-((F2R fr - sqrt x)*(F2R fr + sqrt x)))%R. -2: rewrite <- (sqrt_sqrt x) at 3; auto. -2: unfold Rsqr; ring. -rewrite Rabs_Ropp, Rabs_mult. -apply Rle_lt_trans with ((/2*bpow (Fexp fr))* Rabs (F2R fr + sqrt x))%R. -apply Rmult_le_compat_r. -apply Rabs_pos. -apply Rle_trans with (/2*ulp beta (FLX_exp prec) (F2R fr))%R. -rewrite <- Hr1. -apply error_le_half_ulp_round... -right; rewrite ulp_neq_0. -2: now rewrite <- Hr1. -apply f_equal. -rewrite Hr2, <- Hr1; trivial. -rewrite Rmult_assoc, Rmult_comm. -replace (prec+(Fexp fr+Fexp fr))%Z with (Fexp fr + (prec+Fexp fr))%Z by ring. -rewrite bpow_plus, Rmult_assoc. -apply Rmult_lt_compat_l. -apply bpow_gt_0. -apply Rmult_lt_reg_l with (1 := Rlt_0_2). -apply Rle_lt_trans with (Rabs (F2R fr + sqrt x)). -right; field. -apply Rle_lt_trans with (1:=Rabs_triang _ _). -(* . *) -assert (Rabs (F2R fr) < bpow (prec + Fexp fr))%R. -rewrite Hr2; unfold canonic_exp; rewrite Hr1. -unfold FLX_exp. -ring_simplify (prec + (ln_beta beta (F2R fr) - prec))%Z. -destruct (ln_beta beta (F2R fr)); simpl. -apply a. -rewrite <- Hr1; auto. -(* . *) -apply Rlt_le_trans with (bpow (prec + Fexp fr)+ Rabs (sqrt x))%R. -now apply Rplus_lt_compat_r. -(* . *) -replace (2 * bpow (prec + Fexp fr))%R with (bpow (prec + Fexp fr) + bpow (prec + Fexp fr))%R by ring. -apply Rplus_le_compat_l. -assert (sqrt x <> 0)%R. -apply Rgt_not_eq. -now apply sqrt_lt_R0. -destruct (ln_beta beta (sqrt x)) as (es,Es). -specialize (Es H0). -apply Rle_trans with (bpow es). -now apply Rlt_le. -apply bpow_le. -case (Zle_or_lt es (prec + Fexp fr)) ; trivial. -intros H1. -absurd (Rabs (F2R fr) < bpow (es - 1))%R. -apply Rle_not_lt. -rewrite <- Hr1. -apply abs_round_ge_generic... -apply generic_format_bpow. -unfold FLX_exp; omega. -apply Es. -apply Rlt_le_trans with (1:=H). -apply bpow_le. -omega. -now apply Rlt_le. -Qed. - -End Fprop_divsqrt_error. diff --git a/flocq/Prop/Fprop_mult_error.v b/flocq/Prop/Mult_error.v index 44448cd6..57a3856f 100644 --- a/flocq/Prop/Fprop_mult_error.v +++ b/flocq/Prop/Mult_error.v @@ -2,9 +2,9 @@ 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-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +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 @@ -18,8 +18,7 @@ COPYING file for more details. *) (** * Error of the multiplication is in the FLX/FLT format *) -Require Import Fcore. -Require Import Fcalc_ops. +Require Import Core Operations Plus_error. Section Fprop_mult_error. @@ -30,7 +29,7 @@ Variable prec : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Notation format := (generic_format beta (FLX_exp prec)). -Notation cexp := (canonic_exp beta (FLX_exp prec)). +Notation cexp := (cexp beta (FLX_exp prec)). Variable rnd : R -> Z. Context { valid_rnd : Valid_rnd rnd }. @@ -41,9 +40,9 @@ Lemma mult_error_FLX_aux: format x -> format y -> (round beta (FLX_exp prec) rnd (x * y) - (x * y) <> 0)%R -> exists f:float beta, - (F2R f = round beta (FLX_exp prec) rnd (x * y) - (x * y))%R - /\ (canonic_exp beta (FLX_exp prec) (F2R f) <= Fexp f)%Z - /\ (Fexp f = cexp x + cexp y)%Z. + (F2R f = round beta (FLX_exp prec) rnd (x * y) - (x * y))%R + /\ (cexp (F2R f) <= Fexp f)%Z + /\ (Fexp f = cexp x + cexp y)%Z. Proof with auto with typeclass_instances. intros x y Hx Hy Hz. set (f := (round beta (FLX_exp prec) rnd (x * y))). @@ -52,26 +51,26 @@ contradict Hz. rewrite Hxy0. rewrite round_0... ring. -destruct (ln_beta beta (x * y)) as (exy, Hexy). +destruct (mag beta (x * y)) as (exy, Hexy). specialize (Hexy Hxy0). -destruct (ln_beta beta (f - x * y)) as (er, Her). +destruct (mag beta (f - x * y)) as (er, Her). specialize (Her Hz). -destruct (ln_beta beta x) as (ex, Hex). +destruct (mag beta x) as (ex, Hex). assert (Hx0: (x <> 0)%R). contradict Hxy0. now rewrite Hxy0, Rmult_0_l. specialize (Hex Hx0). -destruct (ln_beta beta y) as (ey, Hey). +destruct (mag beta y) as (ey, Hey). assert (Hy0: (y <> 0)%R). contradict Hxy0. now rewrite Hxy0, Rmult_0_r. specialize (Hey Hy0). (* *) assert (Hc1: (cexp (x * y)%R - prec <= cexp x + cexp y)%Z). -unfold canonic_exp, FLX_exp. -rewrite ln_beta_unique with (1 := Hex). -rewrite ln_beta_unique with (1 := Hey). -rewrite ln_beta_unique with (1 := Hexy). +unfold cexp, FLX_exp. +rewrite mag_unique with (1 := Hex). +rewrite mag_unique with (1 := Hey). +rewrite mag_unique with (1 := Hexy). cut (exy - 1 < ex + ey)%Z. omega. apply (lt_bpow beta). apply Rle_lt_trans with (1 := proj1 Hexy). @@ -84,10 +83,10 @@ apply Hex. apply Hey. (* *) assert (Hc2: (cexp x + cexp y <= cexp (x * y)%R)%Z). -unfold canonic_exp, FLX_exp. -rewrite ln_beta_unique with (1 := Hex). -rewrite ln_beta_unique with (1 := Hey). -rewrite ln_beta_unique with (1 := Hexy). +unfold cexp, FLX_exp. +rewrite mag_unique with (1 := Hex). +rewrite mag_unique with (1 := Hey). +rewrite mag_unique with (1 := Hexy). cut ((ex - 1) + (ey - 1) < exy)%Z. generalize (prec_gt_0 prec). clear ; omega. @@ -120,16 +119,16 @@ split;[assumption|split]. rewrite Hr. simpl. clear Hr. -apply Zle_trans with (cexp (x * y)%R - prec)%Z. -unfold canonic_exp, FLX_exp. +apply Z.le_trans with (cexp (x * y)%R - prec)%Z. +unfold cexp, FLX_exp. apply Zplus_le_compat_r. -rewrite ln_beta_unique with (1 := Hexy). -apply ln_beta_le_bpow with (1 := Hz). +rewrite mag_unique with (1 := Hexy). +apply mag_le_bpow with (1 := Hz). replace (bpow (exy - prec)) with (ulp beta (FLX_exp prec) (x * y)). apply error_lt_ulp... rewrite ulp_neq_0; trivial. -unfold canonic_exp. -now rewrite ln_beta_unique with (1 := Hexy). +unfold cexp. +now rewrite mag_unique with (1 := Hexy). apply Hc1. reflexivity. Qed. @@ -149,6 +148,24 @@ rewrite <- H1. now apply generic_format_F2R. Qed. +Lemma mult_bpow_exact_FLX : + forall x e, + format x -> + format (x * bpow e)%R. +Proof. +intros x e Fx. +destruct (Req_dec x 0) as [Zx|Nzx]. +{ rewrite Zx, Rmult_0_l; apply generic_format_0. } +rewrite Fx. +set (mx := Ztrunc _); set (ex := cexp _). +pose (f := {| Fnum := mx; Fexp := ex + e |} : float beta). +apply (generic_format_F2R' _ _ _ f). +{ now unfold F2R; simpl; rewrite bpow_plus, Rmult_assoc. } +intro Nzmx; unfold mx, ex; rewrite <- Fx. +unfold f, ex; simpl; unfold cexp; rewrite (mag_mult_bpow _ _ _ Nzx). +unfold FLX_exp; omega. +Qed. + End Fprop_mult_error. Section Fprop_mult_error_FLT. @@ -160,7 +177,7 @@ Variable emin prec : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. Notation format := (generic_format beta (FLT_exp emin prec)). -Notation cexp := (canonic_exp beta (FLT_exp emin prec)). +Notation cexp := (cexp beta (FLT_exp emin prec)). Variable rnd : R -> Z. Context { valid_rnd : Valid_rnd rnd }. @@ -169,7 +186,7 @@ Context { valid_rnd : Valid_rnd rnd }. Theorem mult_error_FLT : forall x y, format x -> format y -> - (x*y = 0)%R \/ (bpow (emin + 2*prec - 1) <= Rabs (x * y))%R -> + (x * y <> 0 -> bpow (emin + 2*prec - 1) <= Rabs (x * y))%R -> format (round beta (FLT_exp emin prec) rnd (x * y) - (x * y))%R. Proof with auto with typeclass_instances. intros x y Hx Hy Hxy. @@ -177,12 +194,13 @@ set (f := (round beta (FLT_exp emin prec) rnd (x * y))). destruct (Req_dec (f - x * y) 0) as [Hr0|Hr0]. rewrite Hr0. apply generic_format_0. -destruct Hxy as [Hxy|Hxy]. +destruct (Req_dec (x * y) 0) as [Hxy'|Hxy']. unfold f. -rewrite Hxy. +rewrite Hxy'. rewrite round_0... ring_simplify (0 - 0)%R. apply generic_format_0. +specialize (Hxy Hxy'). destruct (mult_error_FLX_aux beta prec rnd x y) as ((m,e),(H1,(H2,H3))). now apply generic_format_FLX_FLT with emin. now apply generic_format_FLX_FLT with emin. @@ -199,14 +217,14 @@ unfold f; rewrite <- H1. apply generic_format_F2R. intros _. simpl in H2, H3. -unfold canonic_exp, FLT_exp. -case (Zmax_spec (ln_beta beta (F2R (Float beta m e)) - prec) emin); +unfold cexp, FLT_exp. +case (Zmax_spec (mag beta (F2R (Float beta m e)) - prec) emin); intros (M1,M2); rewrite M2. -apply Zle_trans with (2:=H2). -unfold canonic_exp, FLX_exp. -apply Zle_refl. +apply Z.le_trans with (2:=H2). +unfold cexp, FLX_exp. +apply Z.le_refl. rewrite H3. -unfold canonic_exp, FLX_exp. +unfold cexp, FLX_exp. assert (Hxy0:(x*y <> 0)%R). contradict Hr0. unfold f. @@ -219,9 +237,9 @@ now rewrite Hxy0, Rmult_0_l. assert (Hy0: (y <> 0)%R). contradict Hxy0. now rewrite Hxy0, Rmult_0_r. -destruct (ln_beta beta x) as (ex,Ex) ; simpl. +destruct (mag beta x) as (ex,Ex) ; simpl. specialize (Ex Hx0). -destruct (ln_beta beta y) as (ey,Ey) ; simpl. +destruct (mag beta y) as (ey,Ey) ; simpl. specialize (Ey Hy0). assert (emin + 2 * prec -1 < ex + ey)%Z. 2: omega. @@ -233,4 +251,85 @@ apply Ex. apply Ey. Qed. +Lemma F2R_ge: forall (y:float beta), + (F2R y <> 0)%R -> (bpow (Fexp y) <= Rabs (F2R y))%R. +Proof. +intros (ny,ey). +rewrite <- F2R_Zabs; unfold F2R; simpl. +case (Zle_lt_or_eq 0 (Z.abs ny)). +apply Z.abs_nonneg. +intros Hy _. +rewrite <- (Rmult_1_l (bpow _)) at 1. +apply Rmult_le_compat_r. +apply bpow_ge_0. +apply IZR_le; omega. +intros H1 H2; contradict H2. +replace ny with 0%Z. +simpl; ring. +now apply sym_eq, Z.abs_0_iff, sym_eq. +Qed. + +Theorem mult_error_FLT_ge_bpow : + forall x y e, + format x -> format y -> + (bpow (e+2*prec-1) <= Rabs (x * y))%R -> + (round beta (FLT_exp emin prec) rnd (x * y) - (x * y) <> 0)%R -> + (bpow e <= Rabs (round beta (FLT_exp emin prec) rnd (x * y) - (x * y)))%R. +Proof with auto with typeclass_instances. +intros x y e. +set (f := (round beta (FLT_exp emin prec) rnd (x * y))). +intros Fx Fy H1. +unfold f; rewrite Fx, Fy, <- F2R_mult. +simpl Fmult. +destruct (round_repr_same_exp beta (FLT_exp emin prec) + rnd (Ztrunc (scaled_mantissa beta (FLT_exp emin prec) x) * + Ztrunc (scaled_mantissa beta (FLT_exp emin prec) y)) + (cexp x + cexp y)) as (n,Hn). +rewrite Hn; clear Hn. +rewrite <- F2R_minus, Fminus_same_exp. +intros K. +eapply Rle_trans with (2:=F2R_ge _ K). +simpl (Fexp _). +apply bpow_le. +unfold cexp, FLT_exp. +destruct (mag beta x) as (ex,Hx). +destruct (mag beta y) as (ey,Hy). +simpl; apply Z.le_trans with ((ex-prec)+(ey-prec))%Z. +2: apply Zplus_le_compat; apply Z.le_max_l. +assert (e + 2*prec -1< ex+ey)%Z;[idtac|omega]. +apply lt_bpow with beta. +apply Rle_lt_trans with (1:=H1). +rewrite Rabs_mult, bpow_plus. +apply Rmult_lt_compat. +apply Rabs_pos. +apply Rabs_pos. +apply Hx. +intros K'; contradict H1; apply Rlt_not_le. +rewrite K', Rmult_0_l, Rabs_R0; apply bpow_gt_0. +apply Hy. +intros K'; contradict H1; apply Rlt_not_le. +rewrite K', Rmult_0_r, Rabs_R0; apply bpow_gt_0. +Qed. + +Lemma mult_bpow_exact_FLT : + forall x e, + format x -> + (emin + prec - mag beta x <= e)%Z -> + format (x * bpow e)%R. +Proof. +intros x e Fx He. +destruct (Req_dec x 0) as [Zx|Nzx]. +{ rewrite Zx, Rmult_0_l; apply generic_format_0. } +rewrite Fx. +set (mx := Ztrunc _); set (ex := cexp _). +pose (f := {| Fnum := mx; Fexp := ex + e |} : float beta). +apply (generic_format_F2R' _ _ _ f). +{ now unfold F2R; simpl; rewrite bpow_plus, Rmult_assoc. } +intro Nzmx; unfold mx, ex; rewrite <- Fx. +unfold f, ex; simpl; unfold cexp; rewrite (mag_mult_bpow _ _ _ Nzx). +unfold FLT_exp; rewrite Z.max_l; [|omega]; rewrite <- Z.add_max_distr_r. +set (n := (_ - _ + _)%Z); apply (Z.le_trans _ n); [unfold n; omega|]. +apply Z.le_max_l. +Qed. + End Fprop_mult_error_FLT. diff --git a/flocq/Prop/Fprop_plus_error.v b/flocq/Prop/Plus_error.v index 9bb5aee8..42f80093 100644 --- a/flocq/Prop/Fprop_plus_error.v +++ b/flocq/Prop/Plus_error.v @@ -2,9 +2,9 @@ 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-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +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 @@ -20,15 +20,9 @@ COPYING file for more details. (** * Error of the rounded-to-nearest addition is representable. *) Require Import Psatz. -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_float_prop. -Require Import Fcore_generic_fmt. -Require Import Fcore_FIX. -Require Import Fcore_FLX. -Require Import Fcore_FLT. -Require Import Fcore_ulp. -Require Import Fcalc_ops. +Require Import Raux Defs Float_prop Generic_fmt. +Require Import FIX FLX FLT Ulp Operations. +Require Import Relative. Section Fprop_plus_error. @@ -44,31 +38,31 @@ Section round_repr_same_exp. Variable rnd : R -> Z. Context { valid_rnd : Valid_rnd rnd }. -Theorem round_repr_same_exp : +Lemma round_repr_same_exp : forall m e, exists m', round beta fexp rnd (F2R (Float beta m e)) = F2R (Float beta m' e). Proof with auto with typeclass_instances. intros m e. -set (e' := canonic_exp beta fexp (F2R (Float beta m e))). +set (e' := cexp beta fexp (F2R (Float beta m e))). unfold round, scaled_mantissa. fold e'. destruct (Zle_or_lt e' e) as [He|He]. exists m. unfold F2R at 2. simpl. rewrite Rmult_assoc, <- bpow_plus. -rewrite <- Z2R_Zpower. 2: omega. -rewrite <- Z2R_mult, Zrnd_Z2R... +rewrite <- IZR_Zpower. 2: omega. +rewrite <- mult_IZR, Zrnd_IZR... unfold F2R. simpl. -rewrite Z2R_mult. +rewrite mult_IZR. rewrite Rmult_assoc. -rewrite Z2R_Zpower. 2: omega. +rewrite IZR_Zpower. 2: omega. rewrite <- bpow_plus. -apply (f_equal (fun v => Z2R m * bpow v)%R). +apply (f_equal (fun v => IZR m * bpow v)%R). ring. -exists ((rnd (Z2R m * bpow (e - e'))) * Zpower beta (e' - e))%Z. +exists ((rnd (IZR m * bpow (e - e'))) * Zpower beta (e' - e))%Z. unfold F2R. simpl. -rewrite Z2R_mult. -rewrite Z2R_Zpower. 2: omega. +rewrite mult_IZR. +rewrite IZR_Zpower. 2: omega. rewrite 2!Rmult_assoc. rewrite <- 2!bpow_plus. apply (f_equal (fun v => _ * bpow v)%R). @@ -84,13 +78,13 @@ Variable choice : Z -> bool. Lemma plus_error_aux : forall x y, - (canonic_exp beta fexp x <= canonic_exp beta fexp y)%Z -> + (cexp beta fexp x <= cexp beta fexp y)%Z -> format x -> format y -> format (round beta fexp (Znearest choice) (x + y) - (x + y))%R. Proof. intros x y. -set (ex := canonic_exp beta fexp x). -set (ey := canonic_exp beta fexp y). +set (ex := cexp beta fexp x). +set (ey := cexp beta fexp y). intros He Hx Hy. destruct (Req_dec (round beta fexp (Znearest choice) (x + y) - (x + y)) R0) as [H0|H0]. rewrite H0. @@ -116,7 +110,7 @@ apply generic_format_F2R. intros _. apply monotone_exp. rewrite <- H, <- Hxy', <- Hxy. -apply ln_beta_le_abs. +apply mag_le_abs. exact H0. pattern x at 3 ; replace x with (-(y - (x + y)))%R by ring. rewrite Rabs_Ropp. @@ -130,7 +124,7 @@ Theorem plus_error : format (round beta fexp (Znearest choice) (x + y) - (x + y))%R. Proof. intros x y Hx Hy. -destruct (Zle_or_lt (canonic_exp beta fexp x) (canonic_exp beta fexp y)). +destruct (Zle_or_lt (cexp beta fexp x) (cexp beta fexp y)). now apply plus_error_aux. rewrite Rplus_comm. apply plus_error_aux ; try easy. @@ -154,20 +148,17 @@ Section round_plus_eq_zero_aux. Variable rnd : R -> Z. Context { valid_rnd : Valid_rnd rnd }. -Lemma round_plus_eq_zero_aux : +Lemma round_plus_neq_0_aux : forall x y, - (canonic_exp beta fexp x <= canonic_exp beta fexp y)%Z -> + (cexp beta fexp x <= cexp beta fexp y)%Z -> format x -> format y -> - (0 <= x + y)%R -> - round beta fexp rnd (x + y) = 0%R -> - (x + y = 0)%R. + (0 < x + y)%R -> + round beta fexp rnd (x + y) <> 0%R. Proof with auto with typeclass_instances. -intros x y He Hx Hy Hp Hxy. -destruct (Req_dec (x + y) 0) as [H0|H0]. -exact H0. -destruct (ln_beta beta (x + y)) as (exy, Hexy). +intros x y He Hx Hy Hxy. +destruct (mag beta (x + y)) as (exy, Hexy). simpl. -specialize (Hexy H0). +specialize (Hexy (Rgt_not_eq _ _ Hxy)). destruct (Zle_or_lt exy (fexp exy)) as [He'|He']. (* . *) assert (H: (x + y)%R = F2R (Float beta (Ztrunc (x * bpow (- fexp exy)) + @@ -175,19 +166,21 @@ assert (H: (x + y)%R = F2R (Float beta (Ztrunc (x * bpow (- fexp exy)) + rewrite (subnormal_exponent beta fexp exy x He' Hx) at 1. rewrite (subnormal_exponent beta fexp exy y He' Hy) at 1. now rewrite <- F2R_plus, Fplus_same_exp. -rewrite H in Hxy. -rewrite round_generic in Hxy... -now rewrite <- H in Hxy. +rewrite H. +rewrite round_generic... +rewrite <- H. +now apply Rgt_not_eq. apply generic_format_F2R. intros _. rewrite <- H. -unfold canonic_exp. -rewrite ln_beta_unique with (1 := Hexy). -apply Zle_refl. +unfold cexp. +rewrite mag_unique with (1 := Hexy). +apply Z.le_refl. (* . *) +intros H. elim Rle_not_lt with (1 := round_le beta _ rnd _ _ (proj1 Hexy)). -rewrite (Rabs_pos_eq _ Hp). -rewrite Hxy. +rewrite (Rabs_pos_eq _ (Rlt_le _ _ Hxy)). +rewrite H. rewrite round_generic... apply bpow_gt_0. apply generic_format_bpow. @@ -201,40 +194,46 @@ Variable rnd : R -> Z. Context { valid_rnd : Valid_rnd rnd }. (** rnd(x+y)=0 -> x+y = 0 provided this is not a FTZ format *) -Theorem round_plus_eq_zero : +Theorem round_plus_neq_0 : forall x y, format x -> format y -> - round beta fexp rnd (x + y) = 0%R -> - (x + y = 0)%R. + (x + y <> 0)%R -> + round beta fexp rnd (x + y) <> 0%R. Proof with auto with typeclass_instances. -intros x y Hx Hy. +intros x y Hx Hy Hxy. destruct (Rle_or_lt 0 (x + y)) as [H1|H1]. (* . *) -revert H1. -destruct (Zle_or_lt (canonic_exp beta fexp x) (canonic_exp beta fexp y)) as [H2|H2]. -now apply round_plus_eq_zero_aux. +destruct (Zle_or_lt (cexp beta fexp x) (cexp beta fexp y)) as [H2|H2]. +apply round_plus_neq_0_aux... +lra. rewrite Rplus_comm. -apply round_plus_eq_zero_aux ; try easy. +apply round_plus_neq_0_aux ; try easy. now apply Zlt_le_weak. +lra. (* . *) -revert H1. -rewrite <- (Ropp_involutive (x + y)), Ropp_plus_distr, <- Ropp_0. -intros H1. +rewrite <- (Ropp_involutive (x + y)), Ropp_plus_distr. rewrite round_opp. -intros Hxy. -apply f_equal. -cut (round beta fexp (Zrnd_opp rnd) (- x + - y) = 0)%R. -cut (0 <= -x + -y)%R. -destruct (Zle_or_lt (canonic_exp beta fexp (-x)) (canonic_exp beta fexp (-y))) as [H2|H2]. -apply round_plus_eq_zero_aux ; try apply generic_format_opp... +apply Ropp_neq_0_compat. +destruct (Zle_or_lt (cexp beta fexp (-x)) (cexp beta fexp (-y))) as [H2|H2]. +apply round_plus_neq_0_aux; try apply generic_format_opp... +lra. rewrite Rplus_comm. -apply round_plus_eq_zero_aux ; try apply generic_format_opp... +apply round_plus_neq_0_aux; try apply generic_format_opp... now apply Zlt_le_weak. -apply Rlt_le. -now apply Ropp_lt_cancel. -rewrite <- (Ropp_involutive (round _ _ _ _)). -rewrite Hxy. -apply Ropp_involutive. +lra. +Qed. + +Theorem round_plus_eq_0 : + forall x y, + format x -> format y -> + round beta fexp rnd (x + y) = 0%R -> + (x + y = 0)%R. +Proof with auto with typeclass_instances. +intros x y Fx Fy H. +destruct (Req_dec (x + y) 0) as [H'|H']. +exact H'. +contradict H. +now apply round_plus_neq_0. Qed. End Fprop_plus_zero. @@ -258,14 +257,48 @@ apply generic_format_FLT_FIX... rewrite Zplus_comm; assumption. apply generic_format_FIX_FLT, FIX_format_generic in Fx. apply generic_format_FIX_FLT, FIX_format_generic in Fy. -destruct Fx as (nx,(H1x,H2x)). -destruct Fy as (ny,(H1y,H2y)). +destruct Fx as [nx H1x H2x]. +destruct Fy as [ny H1y H2y]. apply generic_format_FIX. exists (Float beta (Fnum nx+Fnum ny)%Z emin). -split;[idtac|reflexivity]. rewrite H1x,H1y; unfold F2R; simpl. rewrite H2x, H2y. -rewrite Z2R_plus; ring. +rewrite plus_IZR; ring. +easy. +Qed. + +Variable choice : Z -> bool. + +Lemma FLT_plus_error_N_ex : forall x y, + generic_format beta (FLT_exp emin prec) x -> + generic_format beta (FLT_exp emin prec) y -> + exists eps, + (Rabs eps <= u_ro beta prec / (1 + u_ro beta prec))%R /\ + round beta (FLT_exp emin prec) (Znearest choice) (x + y) + = ((x + y) * (1 + eps))%R. +Proof. +intros x y Fx Fy. +assert (Pb := u_rod1pu_ro_pos beta prec). +destruct (Rle_or_lt (bpow (emin + prec - 1)) (Rabs (x + y))) as [M|M]. +{ destruct (relative_error_N_FLX'_ex beta prec prec_gt_0_ choice (x + y)) + as (d, (Bd, Hd)). + now exists d; split; [exact Bd|]; rewrite <- Hd; apply round_FLT_FLX. } +exists 0%R; rewrite Rabs_R0; split; [exact Pb|]; rewrite Rplus_0_r, Rmult_1_r. +apply round_generic; [apply valid_rnd_N|]. +apply FLT_format_plus_small; [exact Fx|exact Fy|]. +apply Rlt_le, (Rlt_le_trans _ _ _ M), bpow_le; lia. +Qed. + +Lemma FLT_plus_error_N_round_ex : forall x y, + generic_format beta (FLT_exp emin prec) x -> + generic_format beta (FLT_exp emin prec) y -> + exists eps, + (Rabs eps <= u_ro beta prec)%R /\ + (x + y + = round beta (FLT_exp emin prec) (Znearest choice) (x + y) * (1 + eps))%R. +Proof. +intros x y Fx Fy. +now apply relative_error_N_round_ex_derive, FLT_plus_error_N_ex. Qed. End Fprop_plus_FLT. @@ -282,62 +315,58 @@ Variable rnd : R -> Z. Context { valid_rnd : Valid_rnd rnd }. Notation format := (generic_format beta fexp). -Notation cexp := (canonic_exp beta fexp). +Notation cexp := (cexp beta fexp). Lemma ex_shift : forall x e, format x -> (e <= cexp x)%Z -> - exists m, (x = Z2R m * bpow e)%R. + exists m, (x = IZR m * bpow e)%R. Proof with auto with typeclass_instances. intros x e Fx He. exists (Ztrunc (scaled_mantissa beta fexp x)*Zpower beta (cexp x -e))%Z. rewrite Fx at 1; unfold F2R; simpl. -rewrite Z2R_mult, Rmult_assoc. +rewrite mult_IZR, Rmult_assoc. f_equal. -rewrite Z2R_Zpower. +rewrite IZR_Zpower. 2: omega. rewrite <- bpow_plus; f_equal; ring. Qed. -Lemma ln_beta_minus1 : +Lemma mag_minus1 : forall z, z <> 0%R -> - (ln_beta beta z - 1)%Z = ln_beta beta (z / Z2R beta). + (mag beta z - 1)%Z = mag beta (z / IZR beta). Proof. intros z Hz. unfold Zminus. -rewrite <- ln_beta_mult_bpow with (1 := Hz). +rewrite <- mag_mult_bpow by easy. now rewrite bpow_opp, bpow_1. Qed. -Theorem round_plus_mult_ulp : +Theorem round_plus_F2R : forall x y, format x -> format y -> (x <> 0)%R -> - exists m, (round beta fexp rnd (x+y) = Z2R m * ulp beta fexp (x/Z2R beta))%R. + exists m, + round beta fexp rnd (x+y) = F2R (Float beta m (cexp (x / IZR beta))). Proof with auto with typeclass_instances. intros x y Fx Fy Zx. -case (Zle_or_lt (ln_beta beta (x/Z2R beta)) (ln_beta beta y)); intros H1. -pose (e:=cexp (x / Z2R beta)). +case (Zle_or_lt (mag beta (x/IZR beta)) (mag beta y)); intros H1. +pose (e:=cexp (x / IZR beta)). destruct (ex_shift x e) as (nx, Hnx); try exact Fx. apply monotone_exp. -rewrite <- (ln_beta_minus1 x Zx); omega. +rewrite <- (mag_minus1 x Zx); omega. destruct (ex_shift y e) as (ny, Hny); try assumption. apply monotone_exp... destruct (round_repr_same_exp beta fexp rnd (nx+ny) e) as (n,Hn). exists n. -apply trans_eq with (F2R (Float beta n e)). +fold e. rewrite <- Hn; f_equal. -rewrite Hnx, Hny; unfold F2R; simpl; rewrite Z2R_plus; ring. +rewrite Hnx, Hny; unfold F2R; simpl; rewrite plus_IZR; ring. unfold F2R; simpl. -rewrite ulp_neq_0; try easy. -apply Rmult_integral_contrapositive_currified; try assumption. -apply Rinv_neq_0_compat. -apply Rgt_not_eq. -apply radix_pos. (* *) -destruct (ex_shift (round beta fexp rnd (x + y)) (cexp (x/Z2R beta))) as (n,Hn). +destruct (ex_shift (round beta fexp rnd (x + y)) (cexp (x/IZR beta))) as (n,Hn). apply generic_format_round... -apply Zle_trans with (cexp (x+y)). +apply Z.le_trans with (cexp (x+y)). apply monotone_exp. -rewrite <- ln_beta_minus1 by easy. -rewrite <- (ln_beta_abs beta (x+y)). +rewrite <- mag_minus1 by easy. +rewrite <- (mag_abs beta (x+y)). (* . *) assert (U: (Rabs (x+y) = Rabs x + Rabs y)%R \/ (y <> 0 /\ Rabs (x+y) = Rabs x - Rabs y)%R). assert (V: forall x y, (Rabs y <= Rabs x)%R -> @@ -374,94 +403,89 @@ rewrite Rabs_left1. ring. lra. apply V; left. -apply ln_beta_lt_pos with beta. +apply lt_mag with beta. now apply Rabs_pos_lt. -rewrite <- ln_beta_minus1 in H1; try assumption. -rewrite 2!ln_beta_abs; omega. +rewrite <- mag_minus1 in H1; try assumption. +rewrite 2!mag_abs; omega. (* . *) destruct U as [U|U]. -rewrite U; apply Zle_trans with (ln_beta beta x). +rewrite U; apply Z.le_trans with (mag beta x). omega. -rewrite <- ln_beta_abs. -apply ln_beta_le. +rewrite <- mag_abs. +apply mag_le. now apply Rabs_pos_lt. apply Rplus_le_reg_l with (-Rabs x)%R; ring_simplify. apply Rabs_pos. destruct U as (U',U); rewrite U. -rewrite <- ln_beta_abs. -apply ln_beta_minus_lb. +rewrite <- mag_abs. +apply mag_minus_lb. now apply Rabs_pos_lt. now apply Rabs_pos_lt. -rewrite 2!ln_beta_abs. -assert (ln_beta beta y < ln_beta beta x - 1)%Z. -now rewrite (ln_beta_minus1 x Zx). +rewrite 2!mag_abs. +assert (mag beta y < mag beta x - 1)%Z. +now rewrite (mag_minus1 x Zx). omega. -apply canonic_exp_round_ge... -intros K. -apply round_plus_eq_zero in K... +apply cexp_round_ge... +apply round_plus_neq_0... contradict H1; apply Zle_not_lt. -rewrite <- (ln_beta_minus1 x Zx). +rewrite <- (mag_minus1 x Zx). replace y with (-x)%R. -rewrite ln_beta_opp; omega. +rewrite mag_opp; omega. lra. -exists n. -rewrite ulp_neq_0. -assumption. -apply Rmult_integral_contrapositive_currified; try assumption. -apply Rinv_neq_0_compat. -apply Rgt_not_eq. -apply radix_pos. +now exists n. Qed. Context {exp_not_FTZ : Exp_not_FTZ fexp}. Theorem round_plus_ge_ulp : forall x y, format x -> format y -> - round beta fexp rnd (x+y) = 0%R \/ - (ulp beta fexp (x/Z2R beta) <= Rabs (round beta fexp rnd (x+y)))%R. + round beta fexp rnd (x+y) <> 0%R -> + (ulp beta fexp (x/IZR beta) <= Rabs (round beta fexp rnd (x+y)))%R. Proof with auto with typeclass_instances. -intros x y Fx Fy. +intros x y Fx Fy KK. case (Req_dec x 0); intros Zx. (* *) rewrite Zx, Rplus_0_l. rewrite round_generic... unfold Rdiv; rewrite Rmult_0_l. -rewrite Fy at 2. +rewrite Fy. unfold F2R; simpl; rewrite Rabs_mult. rewrite (Rabs_pos_eq (bpow _)) by apply bpow_ge_0. case (Z.eq_dec (Ztrunc (scaled_mantissa beta fexp y)) 0); intros Hm. -left. -rewrite Fy, Hm; unfold F2R; simpl; ring. -right. +contradict KK. +rewrite Zx, Fy, Hm; unfold F2R; simpl. +rewrite Rplus_0_l, Rmult_0_l. +apply round_0... apply Rle_trans with (1*bpow (cexp y))%R. rewrite Rmult_1_l. rewrite <- ulp_neq_0. apply ulp_ge_ulp_0... intros K; apply Hm. rewrite K, scaled_mantissa_0. -apply (Ztrunc_Z2R 0). +apply Ztrunc_IZR. apply Rmult_le_compat_r. apply bpow_ge_0. -rewrite <- Z2R_abs. -apply (Z2R_le 1). +rewrite <- abs_IZR. +apply IZR_le. apply (Zlt_le_succ 0). now apply Z.abs_pos. (* *) -destruct (round_plus_mult_ulp x y Fx Fy Zx) as (m,Hm). +destruct (round_plus_F2R x y Fx Fy Zx) as (m,Hm). case (Z.eq_dec m 0); intros Zm. -left. -rewrite Hm, Zm; simpl; ring. -right. -rewrite Hm, Rabs_mult. -rewrite (Rabs_pos_eq (ulp _ _ _)) by apply ulp_ge_0. -apply Rle_trans with (1*ulp beta fexp (x/Z2R beta))%R. -right; ring. +contradict KK. +rewrite Hm, Zm. +apply F2R_0. +rewrite Hm, <- F2R_Zabs. +rewrite ulp_neq_0. +rewrite <- (Rmult_1_l (bpow _)). apply Rmult_le_compat_r. -apply ulp_ge_0. -rewrite <- Z2R_abs. -apply (Z2R_le 1). +apply bpow_ge_0. +apply IZR_le. apply (Zlt_le_succ 0). now apply Z.abs_pos. +apply Rmult_integral_contrapositive_currified with (1 := Zx). +apply Rinv_neq_0_compat. +apply Rgt_not_eq, radix_pos. Qed. End Fprop_plus_mult_ulp. @@ -476,27 +500,27 @@ Context { valid_rnd : Valid_rnd rnd }. Variable emin prec : Z. Context { prec_gt_0_ : Prec_gt_0 prec }. -Theorem round_plus_ge_ulp_FLT : forall x y e, +Theorem round_FLT_plus_ge : + forall x y e, generic_format beta (FLT_exp emin prec) x -> generic_format beta (FLT_exp emin prec) y -> - (bpow e <= Rabs x)%R -> - round beta (FLT_exp emin prec) rnd (x+y) = 0%R \/ - (bpow (e - prec) <= Rabs (round beta (FLT_exp emin prec) rnd (x+y)))%R. + (bpow (e + prec) <= Rabs x)%R -> + round beta (FLT_exp emin prec) rnd (x + y) <> 0%R -> + (bpow e <= Rabs (round beta (FLT_exp emin prec) rnd (x + y)))%R. Proof with auto with typeclass_instances. -intros x y e Fx Fy He. +intros x y e Fx Fy He KK. assert (Zx: x <> 0%R). contradict He. apply Rlt_not_le; rewrite He, Rabs_R0. apply bpow_gt_0. -case round_plus_ge_ulp with beta (FLT_exp emin prec) rnd x y... -intros H; right. -apply Rle_trans with (2:=H). +apply Rle_trans with (ulp beta (FLT_exp emin prec) (x/IZR beta)). +2: apply round_plus_ge_ulp... rewrite ulp_neq_0. -unfold canonic_exp. -rewrite <- ln_beta_minus1 by easy. +unfold cexp. +rewrite <- mag_minus1; try assumption. unfold FLT_exp; apply bpow_le. -apply Zle_trans with (2:=Z.le_max_l _ _). -destruct (ln_beta beta x) as (n,Hn); simpl. -assert (e < n)%Z; try omega. +apply Z.le_trans with (2:=Z.le_max_l _ _). +destruct (mag beta x) as (n,Hn); simpl. +assert (e + prec < n)%Z; try omega. apply lt_bpow with beta. apply Rle_lt_trans with (1:=He). now apply Hn. @@ -506,26 +530,45 @@ apply Rgt_not_eq. apply radix_pos. Qed. -Theorem round_plus_ge_ulp_FLX : forall x y e, +Lemma round_FLT_plus_ge' : + forall x y e, + generic_format beta (FLT_exp emin prec) x -> generic_format beta (FLT_exp emin prec) y -> + (x <> 0%R -> (bpow (e+prec) <= Rabs x)%R) -> + (x = 0%R -> y <> 0%R -> (bpow e <= Rabs y)%R) -> + round beta (FLT_exp emin prec) rnd (x+y) <> 0%R -> + (bpow e <= Rabs (round beta (FLT_exp emin prec) rnd (x+y)))%R. +Proof with auto with typeclass_instances. +intros x y e Fx Fy H1 H2 H3. +case (Req_dec x 0); intros H4. +case (Req_dec y 0); intros H5. +contradict H3. +rewrite H4, H5, Rplus_0_l; apply round_0... +rewrite H4, Rplus_0_l. +rewrite round_generic... +apply round_FLT_plus_ge; try easy. +now apply H1. +Qed. + +Theorem round_FLX_plus_ge : + forall x y e, generic_format beta (FLX_exp prec) x -> generic_format beta (FLX_exp prec) y -> - (bpow e <= Rabs x)%R -> - round beta (FLX_exp prec) rnd (x+y) = 0%R \/ - (bpow (e - prec) <= Rabs (round beta (FLX_exp prec) rnd (x+y)))%R. + (bpow (e+prec) <= Rabs x)%R -> + (round beta (FLX_exp prec) rnd (x+y) <> 0)%R -> + (bpow e <= Rabs (round beta (FLX_exp prec) rnd (x+y)))%R. Proof with auto with typeclass_instances. -intros x y e Fx Fy He. +intros x y e Fx Fy He KK. assert (Zx: x <> 0%R). contradict He. apply Rlt_not_le; rewrite He, Rabs_R0. apply bpow_gt_0. -case round_plus_ge_ulp with beta (FLX_exp prec) rnd x y... -intros H; right. -apply Rle_trans with (2:=H). +apply Rle_trans with (ulp beta (FLX_exp prec) (x/IZR beta)). +2: apply round_plus_ge_ulp... rewrite ulp_neq_0. -unfold canonic_exp. -rewrite <- ln_beta_minus1 by easy. +unfold cexp. +rewrite <- mag_minus1 by easy. unfold FLX_exp; apply bpow_le. -destruct (ln_beta beta x) as (n,Hn); simpl. -assert (e < n)%Z; try omega. +destruct (mag beta x) as (n,Hn); simpl. +assert (e + prec < n)%Z; try omega. apply lt_bpow with beta. apply Rle_lt_trans with (1:=He). now apply Hn. @@ -536,3 +579,28 @@ apply radix_pos. Qed. End Fprop_plus_ge_ulp. + +Section Fprop_plus_le_ops. + +Variable beta : radix. +Variable fexp : Z -> Z. +Context { valid_exp : Valid_exp fexp }. +Variable choice : Z -> bool. + +Lemma plus_error_le_l : + forall x y, + generic_format beta fexp x -> generic_format beta fexp y -> + (Rabs (round beta fexp (Znearest choice) (x + y) - (x + y)) <= Rabs x)%R. +Proof. +intros x y Fx Fy. +apply (Rle_trans _ (Rabs (y - (x + y)))); [now apply round_N_pt|]. +rewrite Rabs_minus_sym; right; f_equal; ring. +Qed. + +Lemma plus_error_le_r : + forall x y, + generic_format beta fexp x -> generic_format beta fexp y -> + (Rabs (round beta fexp (Znearest choice) (x + y) - (x + y)) <= Rabs y)%R. +Proof. now intros x y Fx Fy; rewrite Rplus_comm; apply plus_error_le_l. Qed. + +End Fprop_plus_le_ops. diff --git a/flocq/Prop/Fprop_relative.v b/flocq/Prop/Relative.v index 276ccd3b..b936f2f7 100644 --- a/flocq/Prop/Fprop_relative.v +++ b/flocq/Prop/Relative.v @@ -2,9 +2,9 @@ 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-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +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 @@ -18,7 +18,8 @@ COPYING file for more details. *) (** * Relative error of the roundings *) -Require Import Fcore. +Require Import Core. +Require Import Psatz. (* for lra *) Section Fprop_relative. @@ -88,6 +89,32 @@ rewrite Rinv_l with (1 := Hx0). now rewrite Rabs_R1, Rmult_1_r. Qed. +Lemma relative_error_le_conversion_inv : + forall x b, + (exists eps, + (Rabs eps <= b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R) -> + (Rabs (round beta fexp rnd x - x) <= b * Rabs x)%R. +Proof with auto with typeclass_instances. +intros x b (eps, (Beps, Heps)). +assert (Pb : (0 <= b)%R); [now revert Beps; apply Rle_trans, Rabs_pos|]. +rewrite Heps; replace (_ - _)%R with (eps * x)%R; [|ring]. +now rewrite Rabs_mult; apply Rmult_le_compat_r; [apply Rabs_pos|]. +Qed. + +Lemma relative_error_le_conversion_round_inv : + forall x b, + (exists eps, + (Rabs eps <= b)%R /\ x = (round beta fexp rnd x * (1 + eps))%R) -> + (Rabs (round beta fexp rnd x - x) <= b * Rabs (round beta fexp rnd x))%R. +Proof with auto with typeclass_instances. +intros x b. +set (rx := round _ _ _ _). +intros (eps, (Beps, Heps)). +assert (Pb : (0 <= b)%R); [now revert Beps; apply Rle_trans, Rabs_pos|]. +rewrite Heps; replace (_ - _)%R with (- (eps * rx))%R; [|ring]. +now rewrite Rabs_Ropp, Rabs_mult; apply Rmult_le_compat_r; [apply Rabs_pos|]. +Qed. + End relative_error_conversion. Variable emin p : Z. @@ -108,8 +135,8 @@ apply Rlt_not_le, bpow_gt_0. apply Rlt_le_trans with (ulp beta fexp x)%R. now apply error_lt_ulp... rewrite ulp_neq_0; trivial. -unfold canonic_exp. -destruct (ln_beta beta x) as (ex, He). +unfold cexp. +destruct (mag beta x) as (ex, He). simpl. specialize (He Hx'). apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R. @@ -150,7 +177,7 @@ apply relative_error. unfold x. rewrite <- F2R_Zabs. apply bpow_le_F2R. -apply F2R_lt_reg with beta emin. +apply lt_F2R with beta emin. rewrite F2R_0, F2R_Zabs. now apply Rabs_pos_lt. Qed. @@ -179,8 +206,8 @@ apply Rlt_not_le, bpow_gt_0. apply Rlt_le_trans with (ulp beta fexp x)%R. now apply error_lt_ulp. rewrite ulp_neq_0; trivial. -unfold canonic_exp. -destruct (ln_beta beta x) as (ex, He). +unfold cexp. +destruct (mag beta x) as (ex, He). simpl. specialize (He Hx'). assert (He': (emin < ex)%Z). @@ -218,7 +245,7 @@ exact Hp. unfold x. rewrite <- F2R_Zabs. apply bpow_le_F2R. -apply F2R_lt_reg with beta emin. +apply lt_F2R with beta emin. rewrite F2R_0, F2R_Zabs. now apply Rabs_pos_lt. Qed. @@ -237,15 +264,15 @@ rewrite Rmult_assoc. apply Rmult_le_compat_l. apply Rlt_le. apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). +now apply IZR_lt. assert (Hx': (x <> 0)%R). intros H. apply Rlt_not_le with (2 := Hx). rewrite H, Rabs_R0. apply bpow_gt_0. rewrite ulp_neq_0; trivial. -unfold canonic_exp. -destruct (ln_beta beta x) as (ex, He). +unfold cexp. +destruct (mag beta x) as (ex, He). simpl. specialize (He Hx'). apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R. @@ -274,7 +301,7 @@ apply relative_error_le_conversion... apply Rlt_le. apply Rmult_lt_0_compat. apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). +now apply IZR_lt. apply bpow_gt_0. now apply relative_error_N. Qed. @@ -296,7 +323,7 @@ apply relative_error_N. unfold x. rewrite <- F2R_Zabs. apply bpow_le_F2R. -apply F2R_lt_reg with beta emin. +apply lt_F2R with beta emin. rewrite F2R_0, F2R_Zabs. now apply Rabs_pos_lt. Qed. @@ -311,7 +338,7 @@ apply relative_error_le_conversion... apply Rlt_le. apply Rmult_lt_0_compat. apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). +now apply IZR_lt. apply bpow_gt_0. now apply relative_error_N_F2R_emin. Qed. @@ -329,15 +356,15 @@ rewrite Rmult_assoc. apply Rmult_le_compat_l. apply Rlt_le. apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). +now apply IZR_lt. assert (Hx': (x <> 0)%R). intros H. apply Rlt_not_le with (2 := Hx). rewrite H, Rabs_R0. apply bpow_gt_0. rewrite ulp_neq_0; trivial. -unfold canonic_exp. -destruct (ln_beta beta x) as (ex, He). +unfold cexp. +destruct (mag beta x) as (ex, He). simpl. specialize (He Hx'). assert (He': (emin < ex)%Z). @@ -381,17 +408,250 @@ apply relative_error_N_round with (1 := Hp). unfold x. rewrite <- F2R_Zabs. apply bpow_le_F2R. -apply F2R_lt_reg with beta emin. +apply lt_F2R with beta emin. rewrite F2R_0, F2R_Zabs. now apply Rabs_pos_lt. Qed. End Fprop_relative_generic. +Section Fprop_relative_FLX. + +Variable prec : Z. +Variable Hp : Z.lt 0 prec. + +Lemma relative_error_FLX_aux : + forall k, (prec <= k - FLX_exp prec k)%Z. +Proof. +intros k. +unfold FLX_exp. +omega. +Qed. + +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. + +Theorem relative_error_FLX : + forall x, + (x <> 0)%R -> + (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R. +Proof with auto with typeclass_instances. +intros x Hx. +destruct (mag beta x) as (ex, He). +specialize (He Hx). +apply relative_error with (ex - 1)%Z... +intros k _. +apply relative_error_FLX_aux. +apply He. +Qed. + +(** 1+#ε# property in any rounding in FLX *) +Theorem relative_error_FLX_ex : + forall x, + exists eps, + (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLX_exp prec) rnd x = (x * (1 + eps))%R. +Proof with auto with typeclass_instances. +intros x. +apply relative_error_lt_conversion... +apply bpow_gt_0. +now apply relative_error_FLX. +Qed. + +Theorem relative_error_FLX_round : + forall x, + (x <> 0)%R -> + (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs (round beta (FLX_exp prec) rnd x))%R. +Proof with auto with typeclass_instances. +intros x Hx. +destruct (mag beta x) as (ex, He). +specialize (He Hx). +apply relative_error_round with (ex - 1)%Z... +intros k _. +apply relative_error_FLX_aux. +apply He. +Qed. + +Variable choice : Z -> bool. + +Theorem relative_error_N_FLX : + forall x, + (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R. +Proof with auto with typeclass_instances. +intros x. +destruct (Req_dec x 0) as [Hx|Hx]. +(* . *) +rewrite Hx, round_0... +unfold Rminus. +rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0. +rewrite Rmult_0_r. +apply Rle_refl. +(* . *) +destruct (mag beta x) as (ex, He). +specialize (He Hx). +apply relative_error_N with (ex - 1)%Z... +intros k _. +apply relative_error_FLX_aux. +apply He. +Qed. + +(** unit roundoff *) +Definition u_ro := (/2 * bpow (-prec + 1))%R. + +Lemma u_ro_pos : (0 <= u_ro)%R. +Proof. apply Rmult_le_pos; [lra|apply bpow_ge_0]. Qed. + +Lemma u_ro_lt_1 : (u_ro < 1)%R. +Proof. +unfold u_ro; apply (Rmult_lt_reg_l 2); [lra|]. +rewrite <-Rmult_assoc, Rinv_r, Rmult_1_l, Rmult_1_r; [|lra]. +apply (Rle_lt_trans _ (bpow 0)); + [apply bpow_le; omega|simpl; lra]. +Qed. + +Lemma u_rod1pu_ro_pos : (0 <= u_ro / (1 + u_ro))%R. +Proof. +apply Rmult_le_pos; [|apply Rlt_le, Rinv_0_lt_compat]; +assert (H := u_ro_pos); lra. +Qed. + +Lemma u_rod1pu_ro_le_u_ro : (u_ro / (1 + u_ro) <= u_ro)%R. +Proof. +assert (Pu_ro := u_ro_pos). +apply (Rmult_le_reg_r (1 + u_ro)); [lra|]. +unfold Rdiv; rewrite Rmult_assoc, Rinv_l; [|lra]. +assert (0 <= u_ro * u_ro)%R; [apply Rmult_le_pos|]; lra. +Qed. + +Theorem relative_error_N_FLX' : + forall x, + (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) + <= u_ro / (1 + u_ro) * Rabs x)%R. +Proof with auto with typeclass_instances. +intro x. +assert (Pu_ro : (0 <= u_ro)%R). +{ apply Rmult_le_pos; [lra|apply bpow_ge_0]. } +destruct (Req_dec x 0) as [Zx|Nzx]. +{ rewrite Zx, Rabs_R0, Rmult_0_r, round_0... + now unfold Rminus; rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0; right. } +set (ufpx := bpow (mag beta x - 1)%Z). +set (rx := round _ _ _ _). +assert (Pufpx : (0 <= ufpx)%R); [now apply bpow_ge_0|]. +assert (H_2_1 : (Rabs (rx - x) <= u_ro * ufpx)%R). +{ refine (Rle_trans _ _ _ (error_le_half_ulp _ _ _ _) _); + [now apply FLX_exp_valid|right]. + unfold ulp, cexp, FLX_exp, u_ro, ufpx; rewrite (Req_bool_false _ _ Nzx). + rewrite Rmult_assoc, <-bpow_plus; do 2 f_equal; ring. } +assert (H_2_3 : (ufpx + Rabs (rx - x) <= Rabs x)%R). +{ apply (Rplus_le_reg_r (- ufpx)); ring_simplify. + destruct (Rle_or_lt 0 x) as [Sx|Sx]. + { apply (Rle_trans _ (Rabs (ufpx - x))). + { apply round_N_pt; [now apply FLX_exp_valid|]. + apply generic_format_bpow; unfold FLX_exp; lia. } + rewrite Rabs_minus_sym, Rabs_pos_eq. + { now rewrite Rabs_pos_eq; [right; ring|]. } + apply (Rplus_le_reg_r ufpx); ring_simplify. + now rewrite <-(Rabs_pos_eq _ Sx); apply bpow_mag_le. } + apply (Rle_trans _ (Rabs (- ufpx - x))). + { apply round_N_pt; [now apply FLX_exp_valid|]. + apply generic_format_opp, generic_format_bpow; unfold FLX_exp; lia. } + rewrite Rabs_pos_eq; [now rewrite Rabs_left; [right|]|]. + apply (Rplus_le_reg_r x); ring_simplify. + rewrite <-(Ropp_involutive x); apply Ropp_le_contravar; unfold ufpx. + rewrite <-mag_opp, <-Rabs_pos_eq; [apply bpow_mag_le|]; lra. } +assert (H : (Rabs ((rx - x) / x) <= u_ro / (1 + u_ro))%R). +{ assert (H : (0 < ufpx + Rabs (rx - x))%R). + { apply Rplus_lt_le_0_compat; [apply bpow_gt_0|apply Rabs_pos]. } + apply (Rle_trans _ (Rabs (rx - x) / (ufpx + Rabs (rx - x)))). + { unfold Rdiv; rewrite Rabs_mult; apply Rmult_le_compat_l; [apply Rabs_pos|]. + now rewrite (Rabs_Rinv _ Nzx); apply Rinv_le. } + apply (Rmult_le_reg_r ((ufpx + Rabs (rx - x)) * (1 + u_ro))). + { apply Rmult_lt_0_compat; lra. } + field_simplify; [unfold Rdiv; rewrite Rinv_1, !Rmult_1_r| |]; lra. } +revert H; unfold Rdiv; rewrite Rabs_mult, (Rabs_Rinv _ Nzx); intro H. +apply (Rmult_le_reg_r (/ Rabs x)); [now apply Rinv_0_lt_compat, Rabs_pos_lt|]. +now apply (Rle_trans _ _ _ H); right; field; split; [apply Rabs_no_R0|lra]. +Qed. + +(** 1+#ε# property in rounding to nearest in FLX *) +Theorem relative_error_N_FLX_ex : + forall x, + exists eps, + (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLX_exp prec) (Znearest choice) x = (x * (1 + eps))%R. +Proof with auto with typeclass_instances. +intros x. +apply relative_error_le_conversion... +apply Rlt_le. +apply Rmult_lt_0_compat. +apply Rinv_0_lt_compat. +now apply IZR_lt. +apply bpow_gt_0. +now apply relative_error_N_FLX. +Qed. + +Theorem relative_error_N_FLX'_ex : + forall x, + exists eps, + (Rabs eps <= u_ro / (1 + u_ro))%R /\ + round beta (FLX_exp prec) (Znearest choice) x = (x * (1 + eps))%R. +Proof with auto with typeclass_instances. +intros x. +apply relative_error_le_conversion... +{ apply u_rod1pu_ro_pos. } +now apply relative_error_N_FLX'. +Qed. + +Lemma relative_error_N_round_ex_derive : + forall x rx, + (exists eps, (Rabs eps <= u_ro / (1 + u_ro))%R /\ rx = (x * (1 + eps))%R) -> + exists eps, (Rabs eps <= u_ro)%R /\ x = (rx * (1 + eps))%R. +Proof. +intros x rx (d, (Bd, Hd)). +assert (Pu_ro := u_ro_pos). +assert (H := Rabs_le_inv _ _ Bd). +assert (H' := u_rod1pu_ro_le_u_ro); assert (H'' := u_ro_lt_1). +destruct (Req_dec rx 0) as [Zfx|Nzfx]. +{ exists 0%R; split; [now rewrite Rabs_R0|]. + rewrite Rplus_0_r, Rmult_1_r, Zfx. + now rewrite Zfx in Hd; destruct (Rmult_integral _ _ (sym_eq Hd)); [|lra]. } +destruct (Req_dec x 0) as [Zx|Nzx]. +{ now exfalso; revert Hd; rewrite Zx, Rmult_0_l. } +set (d' := ((x - rx) / rx)%R). +assert (Hd' : (Rabs d' <= u_ro)%R). +{ unfold d'; rewrite Hd. + replace (_ / _)%R with (- d / (1 + d))%R; [|now field; split; lra]. + unfold Rdiv; rewrite Rabs_mult, Rabs_Ropp. + rewrite (Rabs_pos_eq (/ _)); [|apply Rlt_le, Rinv_0_lt_compat; lra]. + apply (Rmult_le_reg_r (1 + d)); [lra|]. + rewrite Rmult_assoc, Rinv_l, Rmult_1_r; [|lra]. + apply (Rle_trans _ _ _ Bd). + unfold Rdiv; apply Rmult_le_compat_l; [now apply u_ro_pos|]. + apply (Rle_trans _ (1 - u_ro / (1 + u_ro))); [right; field|]; lra. } +now exists d'; split; [|unfold d'; field]. +Qed. + +Theorem relative_error_N_FLX_round_ex : + forall x, + exists eps, + (Rabs eps <= u_ro)%R /\ + x = (round beta (FLX_exp prec) (Znearest choice) x * (1 + eps))%R. +Proof. +intro x; apply relative_error_N_round_ex_derive, relative_error_N_FLX'_ex. +Qed. + +Theorem relative_error_N_FLX_round : + forall x, + (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs(round beta (FLX_exp prec) (Znearest choice) x))%R. +Proof. +intro x. +apply relative_error_le_conversion_round_inv, relative_error_N_FLX_round_ex. +Qed. + +End Fprop_relative_FLX. + Section Fprop_relative_FLT. Variable emin prec : Z. -Variable Hp : Zlt 0 prec. +Variable Hp : Z.lt 0 prec. Lemma relative_error_FLT_aux : forall k, (emin + prec - 1 < k)%Z -> (prec <= k - FLT_exp emin prec k)%Z. @@ -486,7 +746,7 @@ apply relative_error_le_conversion... apply Rlt_le. apply Rmult_lt_0_compat. apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). +now apply IZR_lt. apply bpow_gt_0. now apply relative_error_N_FLT. Qed. @@ -607,23 +867,84 @@ apply Rlt_le, pos_half_prf. rewrite ulp_neq_0. 2: now apply Rgt_not_eq. apply bpow_le. -unfold FLT_exp, canonic_exp. +unfold FLT_exp, cexp. rewrite Zmax_right. omega. -destruct (ln_beta beta x) as (e,He); simpl. +destruct (mag beta x) as (e,He); simpl. assert (e-1 < emin+prec)%Z. apply (lt_bpow beta). apply Rle_lt_trans with (2:=Hx). -rewrite <- (Rabs_right x). -apply He; auto with real. -apply Rle_ge; now left. +rewrite <- (Rabs_pos_eq x) by now apply Rlt_le. +now apply He, Rgt_not_eq. omega. -split;ring. +split ; ring. +Qed. + +Theorem relative_error_N_FLT'_ex : + forall x, + exists eps eta : R, + (Rabs eps <= u_ro prec / (1 + u_ro prec))%R /\ + (Rabs eta <= /2 * bpow emin)%R /\ + (eps * eta = 0)%R /\ + round beta (FLT_exp emin prec) (Znearest choice) x + = (x * (1 + eps) + eta)%R. +Proof. +intro x. +set (rx := round _ _ _ x). +assert (Pb := u_rod1pu_ro_pos prec). +destruct (Rle_or_lt (bpow (emin + prec - 1)) (Rabs x)) as [MX|Mx]. +{ destruct (relative_error_N_FLX'_ex prec Hp choice x) as (d, (Bd, Hd)). + exists d, 0%R; split; [exact Bd|]; split. + { rewrite Rabs_R0; apply Rmult_le_pos; [lra|apply bpow_ge_0]. } + rewrite Rplus_0_r, Rmult_0_r; split; [reflexivity|]. + now rewrite <- Hd; apply round_FLT_FLX. } +assert (H : (Rabs (rx - x) <= /2 * bpow emin)%R). +{ refine (Rle_trans _ _ _ (error_le_half_ulp _ _ _ _) _); + [now apply FLT_exp_valid|]. + rewrite ulp_FLT_small; [now right|now simpl|]. + apply (Rlt_le_trans _ _ _ Mx), bpow_le; lia. } +exists 0%R, (rx - x)%R; split; [now rewrite Rabs_R0|]; split; [exact H|]. +now rewrite Rmult_0_l, Rplus_0_r, Rmult_1_r; split; [|ring]. +Qed. + +Theorem relative_error_N_FLT'_ex_separate : + forall x, + exists x' : R, + round beta (FLT_exp emin prec) (Znearest choice) x' + = round beta (FLT_exp emin prec) (Znearest choice) x /\ + (exists eta, Rabs eta <= /2 * bpow emin /\ x' = x + eta)%R /\ + (exists eps, Rabs eps <= u_ro prec / (1 + u_ro prec) /\ + round beta (FLT_exp emin prec) (Znearest choice) x' + = x' * (1 + eps))%R. +Proof. +intro x. +set (rx := round _ _ _ x). +destruct (relative_error_N_FLT'_ex x) as (d, (e, (Bd, (Be, (Hde0, Hde))))). +destruct (Rlt_or_le (Rabs (d * x)) (Rabs e)) as [HdxLte|HeLedx]. +{ exists rx; split; [|split]. + { apply round_generic; [now apply valid_rnd_N|]. + now apply generic_format_round; [apply FLT_exp_valid|apply valid_rnd_N]. } + { exists e; split; [exact Be|]. + unfold rx; rewrite Hde; destruct (Rmult_integral _ _ Hde0) as [Zd|Ze]. + { now rewrite Zd, Rplus_0_r, Rmult_1_r. } + exfalso; revert HdxLte; rewrite Ze, Rabs_R0; apply Rle_not_lt, Rabs_pos. } + exists 0%R; split; [now rewrite Rabs_R0; apply u_rod1pu_ro_pos|]. + rewrite Rplus_0_r, Rmult_1_r; apply round_generic; [now apply valid_rnd_N|]. + now apply generic_format_round; [apply FLT_exp_valid|apply valid_rnd_N]. } +exists x; split; [now simpl|split]. +{ exists 0%R; split; + [rewrite Rabs_R0; apply Rmult_le_pos; [lra|apply bpow_ge_0]|ring]. } +exists d; rewrite Hde; destruct (Rmult_integral _ _ Hde0) as [Zd|Ze]. +{ split; [exact Bd|]. + assert (Ze : e = 0%R); [|now rewrite Ze, Rplus_0_r]. + apply Rabs_eq_R0, Rle_antisym; [|now apply Rabs_pos]. + now revert HeLedx; rewrite Zd, Rmult_0_l, Rabs_R0. } +now rewrite Ze, Rplus_0_r. Qed. End Fprop_relative_FLT. -Lemma error_N_FLT : +Theorem error_N_FLT : forall (emin prec : Z), (0 < prec)%Z -> forall (choice : Z -> bool), forall (x : R), @@ -638,9 +959,9 @@ intros emin prec Pprec choice x. destruct (Rtotal_order x 0) as [Nx|[Zx|Px]]. { assert (Pmx : (0 < - x)%R). { now rewrite <- Ropp_0; apply Ropp_lt_contravar. } - destruct (error_N_FLT_aux emin prec Pprec - (fun t : Z => negb (choice (- (t + 1))%Z)) - (- x)%R Pmx) + destruct (@error_N_FLT_aux emin prec Pprec + (fun t : Z => negb (choice (- (t + 1))%Z)) + (- x)%R Pmx) as (d,(e,(Hd,(He,(Hde,Hr))))). exists d; exists (- e)%R; split; [exact Hd|split; [|split]]. { now rewrite Rabs_Ropp. } @@ -659,124 +980,4 @@ destruct (Rtotal_order x 0) as [Nx|[Zx|Px]]. now apply error_N_FLT_aux. Qed. -Section Fprop_relative_FLX. - -Variable prec : Z. -Variable Hp : Zlt 0 prec. - -Lemma relative_error_FLX_aux : - forall k, (prec <= k - FLX_exp prec k)%Z. -Proof. -intros k. -unfold FLX_exp. -omega. -Qed. - -Variable rnd : R -> Z. -Context { valid_rnd : Valid_rnd rnd }. - -Theorem relative_error_FLX : - forall x, - (x <> 0)%R -> - (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R. -Proof with auto with typeclass_instances. -intros x Hx. -destruct (ln_beta beta x) as (ex, He). -specialize (He Hx). -apply relative_error with (ex - 1)%Z... -intros k _. -apply relative_error_FLX_aux. -apply He. -Qed. - -(** 1+#ε# property in any rounding in FLX *) -Theorem relative_error_FLX_ex : - forall x, - exists eps, - (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLX_exp prec) rnd x = (x * (1 + eps))%R. -Proof with auto with typeclass_instances. -intros x. -apply relative_error_lt_conversion... -apply bpow_gt_0. -now apply relative_error_FLX. -Qed. - -Theorem relative_error_FLX_round : - forall x, - (x <> 0)%R -> - (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs (round beta (FLX_exp prec) rnd x))%R. -Proof with auto with typeclass_instances. -intros x Hx. -destruct (ln_beta beta x) as (ex, He). -specialize (He Hx). -apply relative_error_round with (ex - 1)%Z... -intros k _. -apply relative_error_FLX_aux. -apply He. -Qed. - -Variable choice : Z -> bool. - -Theorem relative_error_N_FLX : - forall x, - (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R. -Proof with auto with typeclass_instances. -intros x. -destruct (Req_dec x 0) as [Hx|Hx]. -(* . *) -rewrite Hx, round_0... -unfold Rminus. -rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0. -rewrite Rmult_0_r. -apply Rle_refl. -(* . *) -destruct (ln_beta beta x) as (ex, He). -specialize (He Hx). -apply relative_error_N with (ex - 1)%Z... -intros k _. -apply relative_error_FLX_aux. -apply He. -Qed. - -(** 1+#ε# property in rounding to nearest in FLX *) -Theorem relative_error_N_FLX_ex : - forall x, - exists eps, - (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLX_exp prec) (Znearest choice) x = (x * (1 + eps))%R. -Proof with auto with typeclass_instances. -intros x. -apply relative_error_le_conversion... -apply Rlt_le. -apply Rmult_lt_0_compat. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). -apply bpow_gt_0. -now apply relative_error_N_FLX. -Qed. - -Theorem relative_error_N_FLX_round : - forall x, - (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLX_exp prec) (Znearest choice) x))%R. -Proof with auto with typeclass_instances. -intros x. -destruct (Req_dec x 0) as [Hx|Hx]. -(* . *) -rewrite Hx, round_0... -unfold Rminus. -rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0. -rewrite Rmult_0_r. -apply Rle_refl. -(* . *) -destruct (ln_beta beta x) as (ex, He). -specialize (He Hx). -apply relative_error_N_round with (ex - 1)%Z. -now apply FLX_exp_valid. -intros k _. -apply relative_error_FLX_aux. -exact Hp. -apply He. -Qed. - -End Fprop_relative_FLX. - -End Fprop_relative.
\ No newline at end of file +End Fprop_relative. diff --git a/flocq/Appli/Fappli_rnd_odd.v b/flocq/Prop/Round_odd.v index 273c1000..df2952cc 100644 --- a/flocq/Appli/Fappli_rnd_odd.v +++ b/flocq/Prop/Round_odd.v @@ -2,9 +2,9 @@ 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) 2013-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +Copyright (C) 2013-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 @@ -21,12 +21,11 @@ COPYING file for more details. between rnd_NE and double rounding with rnd_odd and then rnd_NE *) Require Import Reals Psatz. -Require Import Fcore. -Require Import Fcalc_ops. +Require Import Core Operations. -Definition Zrnd_odd x := match Req_EM_T x (Z2R (Zfloor x)) with +Definition Zrnd_odd x := match Req_EM_T x (IZR (Zfloor x)) with | left _ => Zfloor x - | right _ => match (Zeven (Zfloor x)) with + | right _ => match (Z.even (Zfloor x)) with | true => Zceil x | false => Zfloor x end @@ -41,64 +40,120 @@ split. intros x y Hxy. assert (Zfloor x <= Zrnd_odd y)%Z. (* .. *) -apply Zle_trans with (Zfloor y). +apply Z.le_trans with (Zfloor y). now apply Zfloor_le. -unfold Zrnd_odd; destruct (Req_EM_T y (Z2R (Zfloor y))). -now apply Zle_refl. -case (Zeven (Zfloor y)). -apply le_Z2R. +unfold Zrnd_odd; destruct (Req_EM_T y (IZR (Zfloor y))). +now apply Z.le_refl. +case (Z.even (Zfloor y)). +apply le_IZR. apply Rle_trans with y. apply Zfloor_lb. apply Zceil_ub. -now apply Zle_refl. +now apply Z.le_refl. unfold Zrnd_odd at 1. (* . *) -destruct (Req_EM_T x (Z2R (Zfloor x))) as [Hx|Hx]. +destruct (Req_EM_T x (IZR (Zfloor x))) as [Hx|Hx]. (* .. *) apply H. (* .. *) -case_eq (Zeven (Zfloor x)); intros Hx2. +case_eq (Z.even (Zfloor x)); intros Hx2. 2: apply H. -unfold Zrnd_odd; destruct (Req_EM_T y (Z2R (Zfloor y))) as [Hy|Hy]. +unfold Zrnd_odd; destruct (Req_EM_T y (IZR (Zfloor y))) as [Hy|Hy]. apply Zceil_glb. now rewrite <- Hy. -case_eq (Zeven (Zfloor y)); intros Hy2. +case_eq (Z.even (Zfloor y)); intros Hy2. now apply Zceil_le. apply Zceil_glb. assert (H0:(Zfloor x <= Zfloor y)%Z) by now apply Zfloor_le. case (Zle_lt_or_eq _ _ H0); intros H1. apply Rle_trans with (1:=Zceil_ub _). rewrite Zceil_floor_neq. -apply Z2R_le; omega. +apply IZR_le; omega. now apply sym_not_eq. contradict Hy2. rewrite <- H1, Hx2; discriminate. (* . *) intros n; unfold Zrnd_odd. -rewrite Zfloor_Z2R, Zceil_Z2R. -destruct (Req_EM_T (Z2R n) (Z2R n)); trivial. -case (Zeven n); trivial. +rewrite Zfloor_IZR, Zceil_IZR. +destruct (Req_EM_T (IZR n) (IZR n)); trivial. +case (Z.even n); trivial. Qed. -Lemma Zrnd_odd_Zodd: forall x, x <> (Z2R (Zfloor x)) -> - (Zeven (Zrnd_odd x)) = false. +Lemma Zrnd_odd_Zodd: forall x, x <> (IZR (Zfloor x)) -> + (Z.even (Zrnd_odd x)) = false. Proof. intros x Hx; unfold Zrnd_odd. -destruct (Req_EM_T x (Z2R (Zfloor x))) as [H|H]. +destruct (Req_EM_T x (IZR (Zfloor x))) as [H|H]. now contradict H. -case_eq (Zeven (Zfloor x)). +case_eq (Z.even (Zfloor x)). (* difficult case *) intros H'. rewrite Zceil_floor_neq. -rewrite Zeven_plus, H'. +rewrite Z.even_add, H'. reflexivity. now apply sym_not_eq. trivial. Qed. +Lemma Zfloor_plus: forall (n:Z) y, + (Zfloor (IZR n+y) = n + Zfloor y)%Z. +Proof. +intros n y; unfold Zfloor. +unfold Zminus; rewrite Zplus_assoc; f_equal. +apply sym_eq, tech_up. +rewrite plus_IZR. +apply Rplus_lt_compat_l. +apply archimed. +rewrite plus_IZR, Rplus_assoc. +apply Rplus_le_compat_l. +apply Rplus_le_reg_r with (-y)%R. +ring_simplify (y+1+-y)%R. +apply archimed. +Qed. + +Lemma Zceil_plus: forall (n:Z) y, + (Zceil (IZR n+y) = n + Zceil y)%Z. +Proof. +intros n y; unfold Zceil. +rewrite Ropp_plus_distr, <- Ropp_Ropp_IZR. +rewrite Zfloor_plus. +ring. +Qed. + + +Lemma Zeven_abs: forall z, Z.even (Z.abs z) = Z.even z. +Proof. +intros z; case (Zle_or_lt z 0); intros H1. +rewrite Z.abs_neq; try assumption. +apply Z.even_opp. +rewrite Z.abs_eq; auto with zarith. +Qed. + + + + +Lemma Zrnd_odd_plus: forall x y, (x = IZR (Zfloor x)) -> + Z.even (Zfloor x) = true -> + (IZR (Zrnd_odd (x+y)) = x+IZR (Zrnd_odd y))%R. +Proof. +intros x y Hx H. +unfold Zrnd_odd; rewrite Hx, Zfloor_plus. +case (Req_EM_T y (IZR (Zfloor y))); intros Hy. +rewrite Hy; repeat rewrite <- plus_IZR. +repeat rewrite Zfloor_IZR. +case (Req_EM_T _ _); intros K; easy. +case (Req_EM_T _ _); intros K. +contradict Hy. +apply Rplus_eq_reg_l with (IZR (Zfloor x)). +now rewrite K, plus_IZR. +rewrite Z.even_add, H; simpl. +case (Z.even (Zfloor y)). +now rewrite Zceil_plus, plus_IZR. +now rewrite plus_IZR. +Qed. Section Fcore_rnd_odd. @@ -113,20 +168,19 @@ Context { valid_exp : Valid_exp fexp }. Context { exists_NE_ : Exists_NE beta fexp }. Notation format := (generic_format beta fexp). -Notation canonic := (canonic beta fexp). -Notation cexp := (canonic_exp beta fexp). +Notation canonical := (canonical beta fexp). +Notation cexp := (cexp beta fexp). Definition Rnd_odd_pt (x f : R) := format f /\ ((f = x)%R \/ ((Rnd_DN_pt format x f \/ Rnd_UP_pt format x f) /\ - exists g : float beta, f = F2R g /\ canonic g /\ Zeven (Fnum g) = false)). + exists g : float beta, f = F2R g /\ canonical g /\ Z.even (Fnum g) = false)). Definition Rnd_odd (rnd : R -> R) := forall x : R, Rnd_odd_pt x (rnd x). - -Theorem Rnd_odd_pt_sym : forall x f : R, +Theorem Rnd_odd_pt_opp_inv : forall x f : R, Rnd_odd_pt (-x) (-f) -> Rnd_odd_pt x f. Proof with auto with typeclass_instances. intros x f (H1,H2). @@ -144,12 +198,12 @@ destruct H2. right. replace f with (-(-f))%R by ring. replace x with (-(-x))%R by ring. -apply Rnd_DN_UP_pt_sym... +apply Rnd_UP_pt_opp... apply generic_format_opp. left. replace f with (-(-f))%R by ring. replace x with (-(-x))%R by ring. -apply Rnd_UP_DN_pt_sym... +apply Rnd_DN_pt_opp... apply generic_format_opp. exists (Float beta (-Fnum g) (Fexp g)). split. @@ -157,15 +211,15 @@ rewrite F2R_Zopp. replace f with (-(-f))%R by ring. rewrite Hg1; reflexivity. split. -now apply canonic_opp. +now apply canonical_opp. simpl. -now rewrite Zeven_opp. +now rewrite Z.even_opp. Qed. Theorem round_odd_opp : forall x, - (round beta fexp Zrnd_odd (-x) = (- round beta fexp Zrnd_odd x))%R. + round beta fexp Zrnd_odd (-x) = (- round beta fexp Zrnd_odd x)%R. Proof. intros x; unfold round. rewrite <- F2R_Zopp. @@ -174,36 +228,36 @@ apply f_equal2; apply f_equal. rewrite scaled_mantissa_opp. generalize (scaled_mantissa beta fexp x); intros r. unfold Zrnd_odd. -case (Req_EM_T (- r) (Z2R (Zfloor (- r)))). -case (Req_EM_T r (Z2R (Zfloor r))). +case (Req_EM_T (- r) (IZR (Zfloor (- r)))). +case (Req_EM_T r (IZR (Zfloor r))). intros Y1 Y2. -apply eq_Z2R. -now rewrite Z2R_opp, <- Y1, <-Y2. +apply eq_IZR. +now rewrite opp_IZR, <- Y1, <-Y2. intros Y1 Y2. -absurd (r=Z2R (Zfloor r)); trivial. +absurd (r=IZR (Zfloor r)); trivial. pattern r at 2; replace r with (-(-r))%R by ring. -rewrite Y2, <- Z2R_opp. -rewrite Zfloor_Z2R. -rewrite Z2R_opp, <- Y2. +rewrite Y2, <- opp_IZR. +rewrite Zfloor_IZR. +rewrite opp_IZR, <- Y2. ring. -case (Req_EM_T r (Z2R (Zfloor r))). +case (Req_EM_T r (IZR (Zfloor r))). intros Y1 Y2. -absurd (-r=Z2R (Zfloor (-r)))%R; trivial. +absurd (-r=IZR (Zfloor (-r)))%R; trivial. pattern r at 2; rewrite Y1. -rewrite <- Z2R_opp, Zfloor_Z2R. -now rewrite Z2R_opp, <- Y1. +rewrite <- opp_IZR, Zfloor_IZR. +now rewrite opp_IZR, <- Y1. intros Y1 Y2. unfold Zceil; rewrite Ropp_involutive. -replace (Zeven (Zfloor (- r))) with (negb (Zeven (Zfloor r))). -case (Zeven (Zfloor r)); simpl; ring. -apply trans_eq with (Zeven (Zceil r)). +replace (Z.even (Zfloor (- r))) with (negb (Z.even (Zfloor r))). +case (Z.even (Zfloor r)); simpl; ring. +apply trans_eq with (Z.even (Zceil r)). rewrite Zceil_floor_neq. -rewrite Zeven_plus. -destruct (Zeven (Zfloor r)); reflexivity. +rewrite Z.even_add. +destruct (Z.even (Zfloor r)); reflexivity. now apply sym_not_eq. -rewrite <- (Zeven_opp (Zfloor (- r))). +rewrite <- (Z.even_opp (Zfloor (- r))). reflexivity. -apply canonic_exp_opp. +apply cexp_opp. Qed. @@ -221,7 +275,7 @@ rewrite round_0... split. apply generic_format_0. now left. -intros Hx; apply Rnd_odd_pt_sym. +intros Hx; apply Rnd_odd_pt_opp_inv. rewrite <- round_odd_opp. apply H. auto with real. @@ -248,7 +302,7 @@ right; apply round_UP_pt... (* *) unfold o, Zrnd_odd, round. case (Req_EM_T (scaled_mantissa beta fexp x) - (Z2R (Zfloor (scaled_mantissa beta fexp x)))). + (IZR (Zfloor (scaled_mantissa beta fexp x)))). intros T. absurd (o=x); trivial. apply round_generic... @@ -260,20 +314,20 @@ apply Rmult_le_pos. now left. apply bpow_ge_0. intros L. -case_eq (Zeven (Zfloor (scaled_mantissa beta fexp x))). +case_eq (Z.even (Zfloor (scaled_mantissa beta fexp x))). (* . *) generalize (generic_format_round beta fexp Zceil x). unfold generic_format. set (f:=round beta fexp Zceil x). -set (ef := canonic_exp beta fexp f). +set (ef := cexp f). set (mf := Ztrunc (scaled_mantissa beta fexp f)). exists (Float beta mf ef). -unfold Fcore_generic_fmt.canonic. +unfold canonical. rewrite <- H0. repeat split; try assumption. -apply trans_eq with (negb (Zeven (Zfloor (scaled_mantissa beta fexp x)))). +apply trans_eq with (negb (Z.even (Zfloor (scaled_mantissa beta fexp x)))). 2: rewrite H1; reflexivity. -apply trans_eq with (negb (Zeven (Fnum +apply trans_eq with (negb (Z.even (Fnum (Float beta (Zfloor (scaled_mantissa beta fexp x)) (cexp x))))). 2: reflexivity. case (Rle_lt_or_eq_dec 0 (round beta fexp Zfloor x)). @@ -294,10 +348,10 @@ assumption. apply Rmult_le_pos. now left. apply bpow_ge_0. -unfold Fcore_generic_fmt.canonic. +unfold canonical. simpl. -apply sym_eq, canonic_exp_DN... -unfold Fcore_generic_fmt.canonic. +apply sym_eq, cexp_DN... +unfold canonical. rewrite <- H0; reflexivity. reflexivity. apply trans_eq with (round beta fexp Ztrunc (round beta fexp Zceil x)). @@ -305,7 +359,7 @@ reflexivity. apply round_generic... intros Y. replace (Fnum {| Fnum := Zfloor (scaled_mantissa beta fexp x); Fexp := cexp x |}) - with (Fnum (Float beta 0 (fexp (ln_beta beta 0)))). + with (Fnum (Float beta 0 (fexp (mag beta 0)))). generalize (DN_UP_parity_generic beta fexp)... unfold DN_UP_parity_prop. intros T; apply T with x; clear T. @@ -319,15 +373,15 @@ assumption. apply Rmult_le_pos. now left. apply bpow_ge_0. -apply canonic_0. -unfold Fcore_generic_fmt.canonic. +apply canonical_0. +unfold canonical. rewrite <- H0; reflexivity. rewrite <- Y; unfold F2R; simpl; ring. apply trans_eq with (round beta fexp Ztrunc (round beta fexp Zceil x)). reflexivity. apply round_generic... simpl. -apply eq_Z2R, Rmult_eq_reg_r with (bpow (cexp x)). +apply eq_IZR, Rmult_eq_reg_r with (bpow (cexp x)). unfold round, F2R in Y; simpl in Y; rewrite <- Y. simpl; ring. apply Rgt_not_eq, bpow_gt_0. @@ -338,27 +392,25 @@ rewrite <- round_0 with beta fexp Zfloor... apply round_le... now left. intros Hrx. -set (ef := canonic_exp beta fexp x). +set (ef := cexp x). set (mf := Zfloor (scaled_mantissa beta fexp x)). exists (Float beta mf ef). -unfold Fcore_generic_fmt.canonic. +unfold canonical. repeat split; try assumption. simpl. apply trans_eq with (cexp (round beta fexp Zfloor x )). -apply sym_eq, canonic_exp_DN... +apply sym_eq, cexp_DN... reflexivity. intros Hrx; contradict Y. replace (Zfloor (scaled_mantissa beta fexp x)) with 0%Z. simpl; discriminate. -apply eq_Z2R, Rmult_eq_reg_r with (bpow (cexp x)). +apply eq_IZR, Rmult_eq_reg_r with (bpow (cexp x)). unfold round, F2R in Hrx; simpl in Hrx; rewrite <- Hrx. simpl; ring. apply Rgt_not_eq, bpow_gt_0. Qed. - - -Theorem Rnd_odd_pt_unicity : +Theorem Rnd_odd_pt_unique : forall x f1 f2 : R, Rnd_odd_pt x f1 -> Rnd_odd_pt x f2 -> f1 = f2. @@ -381,61 +433,56 @@ contradict L; now rewrite <- H1. destruct H2 as [H2|(H2,H2')]. contradict L; now rewrite <- H2. destruct H1 as [H1|H1]; destruct H2 as [H2|H2]. -apply Rnd_DN_pt_unicity with format x; assumption. +apply Rnd_DN_pt_unique with format x; assumption. destruct H1' as (ff,(K1,(K2,K3))). destruct H2' as (gg,(L1,(L2,L3))). absurd (true = false); try discriminate. rewrite <- L3. -apply trans_eq with (negb (Zeven (Fnum ff))). +apply trans_eq with (negb (Z.even (Fnum ff))). rewrite K3; easy. apply sym_eq. generalize (DN_UP_parity_generic beta fexp). unfold DN_UP_parity_prop; intros T; apply (T x); clear T; try assumption... -rewrite <- K1; apply Rnd_DN_pt_unicity with (generic_format beta fexp) x; try easy... +rewrite <- K1; apply Rnd_DN_pt_unique with (generic_format beta fexp) x; try easy... now apply round_DN_pt... -rewrite <- L1; apply Rnd_UP_pt_unicity with (generic_format beta fexp) x; try easy... +rewrite <- L1; apply Rnd_UP_pt_unique with (generic_format beta fexp) x; try easy... now apply round_UP_pt... (* *) destruct H1' as (ff,(K1,(K2,K3))). destruct H2' as (gg,(L1,(L2,L3))). absurd (true = false); try discriminate. rewrite <- K3. -apply trans_eq with (negb (Zeven (Fnum gg))). +apply trans_eq with (negb (Z.even (Fnum gg))). rewrite L3; easy. apply sym_eq. generalize (DN_UP_parity_generic beta fexp). unfold DN_UP_parity_prop; intros T; apply (T x); clear T; try assumption... -rewrite <- L1; apply Rnd_DN_pt_unicity with (generic_format beta fexp) x; try easy... +rewrite <- L1; apply Rnd_DN_pt_unique with (generic_format beta fexp) x; try easy... now apply round_DN_pt... -rewrite <- K1; apply Rnd_UP_pt_unicity with (generic_format beta fexp) x; try easy... +rewrite <- K1; apply Rnd_UP_pt_unique with (generic_format beta fexp) x; try easy... now apply round_UP_pt... -apply Rnd_UP_pt_unicity with format x; assumption. +apply Rnd_UP_pt_unique with format x; assumption. Qed. - - Theorem Rnd_odd_pt_monotone : round_pred_monotone (Rnd_odd_pt). Proof with auto with typeclass_instances. intros x y f g H1 H2 Hxy. apply Rle_trans with (round beta fexp Zrnd_odd x). -right; apply Rnd_odd_pt_unicity with x; try assumption. +right; apply Rnd_odd_pt_unique with x; try assumption. apply round_odd_pt. apply Rle_trans with (round beta fexp Zrnd_odd y). apply round_le... -right; apply Rnd_odd_pt_unicity with y; try assumption. +right; apply Rnd_odd_pt_unique with y; try assumption. apply round_odd_pt. Qed. - - - End Fcore_rnd_odd. Section Odd_prop_aux. Variable beta : radix. -Hypothesis Even_beta: Zeven (radix_val beta)=true. +Hypothesis Even_beta: Z.even (radix_val beta)=true. Notation bpow e := (bpow beta e). @@ -454,26 +501,26 @@ Lemma generic_format_fexpe_fexp: forall x, generic_format beta fexp x -> generic_format beta fexpe x. Proof. intros x Hx. -apply generic_inclusion_ln_beta with fexp; trivial; intros Hx2. -generalize (fexpe_fexp (ln_beta beta x)). +apply generic_inclusion_mag with fexp; trivial; intros Hx2. +generalize (fexpe_fexp (mag beta x)). omega. Qed. Lemma exists_even_fexp_lt: forall (c:Z->Z), forall (x:R), - (exists f:float beta, F2R f = x /\ (c (ln_beta beta x) < Fexp f)%Z) -> - exists f:float beta, F2R f =x /\ canonic beta c f /\ Zeven (Fnum f) = true. + (exists f:float beta, F2R f = x /\ (c (mag beta x) < Fexp f)%Z) -> + exists f:float beta, F2R f =x /\ canonical beta c f /\ Z.even (Fnum f) = true. Proof with auto with typeclass_instances. intros c x (g,(Hg1,Hg2)). exists (Float beta - (Fnum g*Z.pow (radix_val beta) (Fexp g - c (ln_beta beta x))) - (c (ln_beta beta x))). + (Fnum g*Z.pow (radix_val beta) (Fexp g - c (mag beta x))) + (c (mag beta x))). assert (F2R (Float beta - (Fnum g*Z.pow (radix_val beta) (Fexp g - c (ln_beta beta x))) - (c (ln_beta beta x))) = x). + (Fnum g*Z.pow (radix_val beta) (Fexp g - c (mag beta x))) + (c (mag beta x))) = x). unfold F2R; simpl. -rewrite Z2R_mult, Z2R_Zpower. +rewrite mult_IZR, IZR_Zpower. rewrite Rmult_assoc, <- bpow_plus. rewrite <- Hg1; unfold F2R. apply f_equal, f_equal. @@ -481,11 +528,11 @@ ring. omega. split; trivial. split. -unfold canonic, canonic_exp. +unfold canonical, cexp. now rewrite H. simpl. -rewrite Zeven_mult. -rewrite Zeven_Zpower. +rewrite Z.even_mul. +rewrite Z.even_pow. rewrite Even_beta. apply Bool.orb_true_intro. now right. @@ -499,9 +546,9 @@ Variable x:R. Variable d u: float beta. Hypothesis Hd: Rnd_DN_pt (generic_format beta fexp) x (F2R d). -Hypothesis Cd: canonic beta fexp d. +Hypothesis Cd: canonical beta fexp d. Hypothesis Hu: Rnd_UP_pt (generic_format beta fexp) x (F2R u). -Hypothesis Cu: canonic beta fexp u. +Hypothesis Cu: canonical beta fexp u. Hypothesis xPos: (0 < x)%R. @@ -511,14 +558,14 @@ Let m:= ((F2R d+F2R u)/2)%R. Lemma d_eq: F2R d= round beta fexp Zfloor x. Proof with auto with typeclass_instances. -apply Rnd_DN_pt_unicity with (generic_format beta fexp) x... +apply Rnd_DN_pt_unique with (generic_format beta fexp) x... apply round_DN_pt... Qed. Lemma u_eq: F2R u= round beta fexp Zceil x. Proof with auto with typeclass_instances. -apply Rnd_UP_pt_unicity with (generic_format beta fexp) x... +apply Rnd_UP_pt_unique with (generic_format beta fexp) x... apply round_UP_pt... Qed. @@ -532,47 +579,47 @@ Qed. -Lemma ln_beta_d: (0< F2R d)%R -> - (ln_beta beta (F2R d) = ln_beta beta x :>Z). +Lemma mag_d: (0< F2R d)%R -> + (mag beta (F2R d) = mag beta x :>Z). Proof with auto with typeclass_instances. intros Y. -rewrite d_eq; apply ln_beta_DN... +rewrite d_eq; apply mag_DN... now rewrite <- d_eq. Qed. -Lemma Fexp_d: (0 < F2R d)%R -> Fexp d =fexp (ln_beta beta x). +Lemma Fexp_d: (0 < F2R d)%R -> Fexp d =fexp (mag beta x). Proof with auto with typeclass_instances. intros Y. -now rewrite Cd, <- ln_beta_d. +now rewrite Cd, <- mag_d. Qed. Lemma format_bpow_x: (0 < F2R d)%R - -> generic_format beta fexp (bpow (ln_beta beta x)). + -> generic_format beta fexp (bpow (mag beta x)). Proof with auto with typeclass_instances. intros Y. apply generic_format_bpow. apply valid_exp. rewrite <- Fexp_d; trivial. -apply Zlt_le_trans with (ln_beta beta (F2R d))%Z. -rewrite Cd; apply ln_beta_generic_gt... +apply Z.lt_le_trans with (mag beta (F2R d))%Z. +rewrite Cd; apply mag_generic_gt... now apply Rgt_not_eq. apply Hd. -apply ln_beta_le; trivial. +apply mag_le; trivial. apply Hd. Qed. Lemma format_bpow_d: (0 < F2R d)%R -> - generic_format beta fexp (bpow (ln_beta beta (F2R d))). + generic_format beta fexp (bpow (mag beta (F2R d))). Proof with auto with typeclass_instances. intros Y; apply generic_format_bpow. apply valid_exp. -apply ln_beta_generic_gt... +apply mag_generic_gt... now apply Rgt_not_eq. -now apply generic_format_canonic. +now apply generic_format_canonical. Qed. @@ -596,12 +643,12 @@ unfold m. lra. Qed. -Lemma ln_beta_m: (0 < F2R d)%R -> (ln_beta beta m =ln_beta beta (F2R d) :>Z). +Lemma mag_m: (0 < F2R d)%R -> (mag beta m =mag beta (F2R d) :>Z). Proof with auto with typeclass_instances. -intros dPos; apply ln_beta_unique_pos. +intros dPos; apply mag_unique_pos. split. apply Rle_trans with (F2R d). -destruct (ln_beta beta (F2R d)) as (e,He). +destruct (mag beta (F2R d)) as (e,He). simpl. rewrite Rabs_right in He. apply He. @@ -614,13 +661,13 @@ rewrite u_eq. apply round_le_generic... apply generic_format_bpow. apply valid_exp. -apply ln_beta_generic_gt... +apply mag_generic_gt... now apply Rgt_not_eq. -now apply generic_format_canonic. -case (Rle_or_lt x (bpow (ln_beta beta (F2R d)))); trivial; intros Z. -absurd ((bpow (ln_beta beta (F2R d)) <= (F2R d)))%R. +now apply generic_format_canonical. +case (Rle_or_lt x (bpow (mag beta (F2R d)))); trivial; intros Z. +absurd ((bpow (mag beta (F2R d)) <= (F2R d)))%R. apply Rlt_not_le. -destruct (ln_beta beta (F2R d)) as (e,He). +destruct (mag beta (F2R d)) as (e,He). simpl in *; rewrite Rabs_right in He. apply He. now apply Rgt_not_eq. @@ -630,12 +677,12 @@ apply Rle_trans with (round beta fexp Zfloor x). apply round_ge_generic... apply generic_format_bpow. apply valid_exp. -apply ln_beta_generic_gt... +apply mag_generic_gt... now apply Rgt_not_eq. -now apply generic_format_canonic. +now apply generic_format_canonical. now left. replace m with (F2R d). -destruct (ln_beta beta (F2R d)) as (e,He). +destruct (mag beta (F2R d)) as (e,He). simpl in *; rewrite Rabs_right in He. apply He. now apply Rgt_not_eq. @@ -645,17 +692,17 @@ lra. Qed. -Lemma ln_beta_m_0: (0 = F2R d)%R - -> (ln_beta beta m =ln_beta beta (F2R u)-1:>Z)%Z. +Lemma mag_m_0: (0 = F2R d)%R + -> (mag beta m =mag beta (F2R u)-1:>Z)%Z. Proof with auto with typeclass_instances. intros Y. -apply ln_beta_unique_pos. +apply mag_unique_pos. unfold m; rewrite <- Y, Rplus_0_l. rewrite u_eq. -destruct (ln_beta beta x) as (e,He). +destruct (mag beta x) as (e,He). rewrite Rabs_pos_eq in He by now apply Rlt_le. rewrite round_UP_small_pos with (ex:=e). -rewrite ln_beta_bpow. +rewrite mag_bpow. ring_simplify (fexp e + 1 - 1)%Z. split. unfold Zminus; rewrite bpow_plus. @@ -664,7 +711,7 @@ apply bpow_ge_0. simpl; unfold Z.pow_pos; simpl. rewrite Zmult_1_r; apply Rinv_le. exact Rlt_0_2. -apply (Z2R_le 2). +apply IZR_le. specialize (radix_gt_1 beta). omega. apply Rlt_le_trans with (bpow (fexp e)*1)%R. @@ -691,29 +738,29 @@ simpl; now rewrite Fexp_d. Qed. - - -Lemma m_eq: (0 < F2R d)%R -> exists f:float beta, - F2R f = m /\ (Fexp f = fexp (ln_beta beta x) -1)%Z. +Lemma m_eq : + (0 < F2R d)%R -> + exists f:float beta, + F2R f = m /\ (Fexp f = fexp (mag beta x) - 1)%Z. Proof with auto with typeclass_instances. intros Y. specialize (Zeven_ex (radix_val beta)); rewrite Even_beta. intros (b, Hb); rewrite Zplus_0_r in Hb. destruct u'_eq as (u', (Hu'1,Hu'2)); trivial. -exists (Fmult beta (Float beta b (-1)) (Fplus beta d u'))%R. +exists (Fmult (Float beta b (-1)) (Fplus d u'))%R. split. rewrite F2R_mult, F2R_plus, Hu'1. unfold m; rewrite Rmult_comm. unfold Rdiv; apply f_equal. unfold F2R; simpl; unfold Z.pow_pos; simpl. -rewrite Zmult_1_r, Hb, Z2R_mult. +rewrite Zmult_1_r, Hb, mult_IZR. simpl; field. apply Rgt_not_eq, Rmult_lt_reg_l with (1 := Rlt_0_2). -rewrite Rmult_0_r, <- (Z2R_mult 2), <-Hb. +rewrite Rmult_0_r, <- (mult_IZR 2), <-Hb. apply radix_pos. -apply trans_eq with (-1+Fexp (Fplus beta d u'))%Z. +apply trans_eq with (-1+Fexp (Fplus d u'))%Z. unfold Fmult. -destruct (Fplus beta d u'); reflexivity. +destruct (Fplus d u'); reflexivity. rewrite Zplus_comm; unfold Zminus; apply f_equal2. 2: reflexivity. rewrite Fexp_Fplus. @@ -723,21 +770,21 @@ rewrite Hu'2; omega. Qed. Lemma m_eq_0: (0 = F2R d)%R -> exists f:float beta, - F2R f = m /\ (Fexp f = fexp (ln_beta beta (F2R u)) -1)%Z. + F2R f = m /\ (Fexp f = fexp (mag beta (F2R u)) -1)%Z. Proof with auto with typeclass_instances. intros Y. specialize (Zeven_ex (radix_val beta)); rewrite Even_beta. intros (b, Hb); rewrite Zplus_0_r in Hb. -exists (Fmult beta (Float beta b (-1)) u)%R. +exists (Fmult (Float beta b (-1)) u)%R. split. rewrite F2R_mult; unfold m; rewrite <- Y, Rplus_0_l. rewrite Rmult_comm. unfold Rdiv; apply f_equal. unfold F2R; simpl; unfold Z.pow_pos; simpl. -rewrite Zmult_1_r, Hb, Z2R_mult. +rewrite Zmult_1_r, Hb, mult_IZR. simpl; field. apply Rgt_not_eq, Rmult_lt_reg_l with (1 := Rlt_0_2). -rewrite Rmult_0_r, <- (Z2R_mult 2), <-Hb. +rewrite Rmult_0_r, <- (mult_IZR 2), <-Hb. apply radix_pos. apply trans_eq with (-1+Fexp u)%Z. unfold Fmult. @@ -746,12 +793,12 @@ rewrite Zplus_comm, Cu; unfold Zminus; now apply f_equal2. Qed. Lemma fexp_m_eq_0: (0 = F2R d)%R -> - (fexp (ln_beta beta (F2R u)-1) < fexp (ln_beta beta (F2R u))+1)%Z. + (fexp (mag beta (F2R u)-1) < fexp (mag beta (F2R u))+1)%Z. Proof with auto with typeclass_instances. intros Y. -assert ((fexp (ln_beta beta (F2R u) - 1) <= fexp (ln_beta beta (F2R u))))%Z. +assert ((fexp (mag beta (F2R u) - 1) <= fexp (mag beta (F2R u))))%Z. 2: omega. -destruct (ln_beta beta x) as (e,He). +destruct (mag beta x) as (e,He). rewrite Rabs_right in He. 2: now left. assert (e <= fexp e)%Z. @@ -760,7 +807,7 @@ now apply He, Rgt_not_eq. now rewrite <- d_eq, Y. rewrite u_eq, round_UP_small_pos with (ex:=e); trivial. 2: now apply He, Rgt_not_eq. -rewrite ln_beta_bpow. +rewrite mag_bpow. ring_simplify (fexp e + 1 - 1)%Z. replace (fexp (fexp e)) with (fexp e). case exists_NE_; intros V. @@ -770,33 +817,34 @@ apply sym_eq, valid_exp; omega. Qed. Lemma Fm: generic_format beta fexpe m. +Proof. case (d_ge_0); intros Y. (* *) destruct m_eq as (g,(Hg1,Hg2)); trivial. apply generic_format_F2R' with g. now apply sym_eq. -intros H; unfold canonic_exp; rewrite Hg2. -rewrite ln_beta_m; trivial. +intros H; unfold cexp; rewrite Hg2. +rewrite mag_m; trivial. rewrite <- Fexp_d; trivial. rewrite Cd. -unfold canonic_exp. -generalize (fexpe_fexp (ln_beta beta (F2R d))). +unfold cexp. +generalize (fexpe_fexp (mag beta (F2R d))). omega. (* *) destruct m_eq_0 as (g,(Hg1,Hg2)); trivial. apply generic_format_F2R' with g. assumption. -intros H; unfold canonic_exp; rewrite Hg2. -rewrite ln_beta_m_0; try assumption. -apply Zle_trans with (1:=fexpe_fexp _). -assert (fexp (ln_beta beta (F2R u)-1) < fexp (ln_beta beta (F2R u))+1)%Z;[idtac|omega]. -now apply fexp_m_eq_0. +intros H; unfold cexp; rewrite Hg2. +rewrite mag_m_0; try assumption. +apply Z.le_trans with (1:=fexpe_fexp _). +generalize (fexp_m_eq_0 Y). +omega. Qed. Lemma Zm: - exists g : float beta, F2R g = m /\ canonic beta fexpe g /\ Zeven (Fnum g) = true. + exists g : float beta, F2R g = m /\ canonical beta fexpe g /\ Z.even (Fnum g) = true. Proof with auto with typeclass_instances. case (d_ge_0); intros Y. (* *) @@ -804,26 +852,27 @@ destruct m_eq as (g,(Hg1,Hg2)); trivial. apply exists_even_fexp_lt. exists g; split; trivial. rewrite Hg2. -rewrite ln_beta_m; trivial. +rewrite mag_m; trivial. rewrite <- Fexp_d; trivial. rewrite Cd. -unfold canonic_exp. -generalize (fexpe_fexp (ln_beta beta (F2R d))). +unfold cexp. +generalize (fexpe_fexp (mag beta (F2R d))). omega. (* *) destruct m_eq_0 as (g,(Hg1,Hg2)); trivial. apply exists_even_fexp_lt. exists g; split; trivial. rewrite Hg2. -rewrite ln_beta_m_0; trivial. -apply Zle_lt_trans with (1:=fexpe_fexp _). -assert (fexp (ln_beta beta (F2R u)-1) < fexp (ln_beta beta (F2R u))+1)%Z;[idtac|omega]. -now apply fexp_m_eq_0. +rewrite mag_m_0; trivial. +apply Z.le_lt_trans with (1:=fexpe_fexp _). +generalize (fexp_m_eq_0 Y). +omega. Qed. -Lemma DN_odd_d_aux: forall z, (F2R d<= z< F2R u)%R -> - Rnd_DN_pt (generic_format beta fexp) z (F2R d). +Lemma DN_odd_d_aux : + forall z, (F2R d <= z < F2R u)%R -> + Rnd_DN_pt (generic_format beta fexp) z (F2R d). Proof with auto with typeclass_instances. intros z Hz1. replace (F2R d) with (round beta fexp Zfloor z). @@ -834,22 +883,21 @@ intros Y; apply Rle_antisym; trivial. apply round_DN_pt... apply Hd. apply Hz1. -intros Y; absurd (z < z)%R. -auto with real. +intros Y ; elim (Rlt_irrefl z). apply Rlt_le_trans with (1:=proj2 Hz1), Rle_trans with (1:=Y). apply round_DN_pt... Qed. -Lemma UP_odd_d_aux: forall z, (F2R d< z <= F2R u)%R -> - Rnd_UP_pt (generic_format beta fexp) z (F2R u). +Lemma UP_odd_d_aux : + forall z, (F2R d < z <= F2R u)%R -> + Rnd_UP_pt (generic_format beta fexp) z (F2R u). Proof with auto with typeclass_instances. intros z Hz1. replace (F2R u) with (round beta fexp Zceil z). apply round_UP_pt... case (Rnd_DN_UP_pt_split _ _ _ _ Hd Hu (round beta fexp Zceil z)). apply generic_format_round... -intros Y; absurd (z < z)%R. -auto with real. +intros Y ; elim (Rlt_irrefl z). apply Rle_lt_trans with (2:=proj1 Hz1), Rle_trans with (2:=Y). apply round_UP_pt... intros Y; apply Rle_antisym; trivial. @@ -859,7 +907,7 @@ apply Hz1. Qed. -Theorem round_odd_prop_pos: +Lemma round_N_odd_pos : round beta fexp (Znearest choice) (round beta fexpe Zrnd_odd x) = round beta fexp (Znearest choice) x. Proof with auto with typeclass_instances. @@ -889,7 +937,7 @@ absurd (true=false). discriminate. rewrite <- Hk3, <- Hk'3. apply f_equal, f_equal. -apply canonic_unicity with fexpe... +apply canonical_unique with fexpe... now rewrite Hk'1, <- Y2. assert (generic_format beta fexp o -> (forall P:Prop, P)). intros Y. @@ -902,14 +950,14 @@ destruct H as (_,(k,(Hk1,(Hk2,Hk3)))). destruct (exists_even_fexp_lt fexpe o) as (k',(Hk'1,(Hk'2,Hk'3))). eexists; split. apply sym_eq, Y. -simpl; unfold canonic_exp. -apply Zle_lt_trans with (1:=fexpe_fexp _). +simpl; unfold cexp. +apply Z.le_lt_trans with (1:=fexpe_fexp _). omega. absurd (true=false). discriminate. rewrite <- Hk3, <- Hk'3. apply f_equal, f_equal. -apply canonic_unicity with fexpe... +apply canonical_unique with fexpe... now rewrite Hk'1, <- Hk1. case K1; clear K1; intros K1. 2: apply H; rewrite <- K1; apply Hd. @@ -957,7 +1005,7 @@ End Odd_prop_aux. Section Odd_prop. Variable beta : radix. -Hypothesis Even_beta: Zeven (radix_val beta)=true. +Hypothesis Even_beta: Z.even (radix_val beta)=true. Variable fexp : Z -> Z. Variable fexpe : Z -> Z. @@ -970,25 +1018,8 @@ Context { exists_NE_e : Exists_NE beta fexpe }. (* for defining rounding to odd Hypothesis fexpe_fexp: forall e, (fexpe e <= fexp e -2)%Z. - -Theorem canonizer: forall f, generic_format beta fexp f - -> exists g : float beta, f = F2R g /\ canonic beta fexp g. -Proof with auto with typeclass_instances. -intros f Hf. -exists (Float beta (Ztrunc (scaled_mantissa beta fexp f)) (canonic_exp beta fexp f)). -assert (L:(f = F2R (Float beta (Ztrunc (scaled_mantissa beta fexp f)) (canonic_exp beta fexp f)))). -apply trans_eq with (round beta fexp Ztrunc f). -apply sym_eq, round_generic... -reflexivity. -split; trivial. -unfold canonic; rewrite <- L. -reflexivity. -Qed. - - - - -Theorem round_odd_prop: forall x, +Theorem round_N_odd : + forall x, round beta fexp (Znearest choice) (round beta fexpe Zrnd_odd x) = round beta fexp (Znearest choice) x. Proof with auto with typeclass_instances. @@ -998,25 +1029,192 @@ rewrite <- (Ropp_involutive x). rewrite round_odd_opp. rewrite 2!round_N_opp. apply f_equal. -destruct (canonizer (round beta fexp Zfloor (-x))) as (d,(Hd1,Hd2)). +destruct (canonical_generic_format beta fexp (round beta fexp Zfloor (-x))) as (d,(Hd1,Hd2)). apply generic_format_round... -destruct (canonizer (round beta fexp Zceil (-x))) as (u,(Hu1,Hu2)). +destruct (canonical_generic_format beta fexp (round beta fexp Zceil (-x))) as (u,(Hu1,Hu2)). apply generic_format_round... -apply round_odd_prop_pos with d u... +apply round_N_odd_pos with d u... rewrite <- Hd1; apply round_DN_pt... rewrite <- Hu1; apply round_UP_pt... auto with real. (* . *) rewrite H; repeat rewrite round_0... (* . *) -destruct (canonizer (round beta fexp Zfloor x)) as (d,(Hd1,Hd2)). +destruct (canonical_generic_format beta fexp (round beta fexp Zfloor x)) as (d,(Hd1,Hd2)). apply generic_format_round... -destruct (canonizer (round beta fexp Zceil x)) as (u,(Hu1,Hu2)). +destruct (canonical_generic_format beta fexp (round beta fexp Zceil x)) as (u,(Hu1,Hu2)). apply generic_format_round... -apply round_odd_prop_pos with d u... +apply round_N_odd_pos with d u... rewrite <- Hd1; apply round_DN_pt... rewrite <- Hu1; apply round_UP_pt... Qed. - End Odd_prop. + + +Section Odd_propbis. + +Variable beta : radix. +Hypothesis Even_beta: Z.even (radix_val beta)=true. + +Variable emin prec:Z. +Variable choice:Z->bool. + +Hypothesis prec_gt_1: (1 < prec)%Z. + + +Notation format := (generic_format beta (FLT_exp emin prec)). +Notation round_flt :=(round beta (FLT_exp emin prec) (Znearest choice)). +Notation cexp_flt := (cexp beta (FLT_exp emin prec)). +Notation fexpe k := (FLT_exp (emin-k) (prec+k)). + + + +Lemma Zrnd_odd_plus': forall x y, + (exists n:Z, exists e:Z, (x = IZR n*bpow beta e)%R /\ (1 <= e)%Z) -> + (IZR (Zrnd_odd (x+y)) = x+IZR (Zrnd_odd y))%R. +Proof. +intros x y (n,(e,(H1,H2))). +apply Zrnd_odd_plus. +rewrite H1. +rewrite <- IZR_Zpower. +2: auto with zarith. +now rewrite <- mult_IZR, Zfloor_IZR. +rewrite H1, <- IZR_Zpower. +2: auto with zarith. +rewrite <- mult_IZR, Zfloor_IZR. +rewrite Z.even_mul. +rewrite Z.even_pow. +2: auto with zarith. +rewrite Even_beta. +apply Bool.orb_true_iff; now right. +Qed. + + + +Theorem mag_round_odd: forall (x:R), + (emin < mag beta x)%Z -> + (mag_val beta _ (mag beta (round beta (FLT_exp emin prec) Zrnd_odd x)) + = mag_val beta x (mag beta x))%Z. +Proof with auto with typeclass_instances. +intros x. +assert (T:Prec_gt_0 prec). +unfold Prec_gt_0; auto with zarith. +case (Req_dec x 0); intros Zx. +intros _; rewrite Zx, round_0... +destruct (mag beta x) as (e,He); simpl; intros H. +apply mag_unique; split. +apply abs_round_ge_generic... +apply FLT_format_bpow... +auto with zarith. +now apply He. +assert (V: + (Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) <= bpow beta e)%R). +apply abs_round_le_generic... +apply FLT_format_bpow... +auto with zarith. +left; now apply He. +case V; try easy; intros K. +assert (H0:Rnd_odd_pt beta (FLT_exp emin prec) x (round beta (FLT_exp emin prec) Zrnd_odd x)). +apply round_odd_pt... +destruct H0 as (_,HH); destruct HH as [H0|(H0,(g,(Hg1,(Hg2,Hg3))))]. +absurd (Rabs x < bpow beta e)%R. +apply Rle_not_lt; right. +now rewrite <- H0,K. +now apply He. +pose (gg:=Float beta (Zpower beta (e-FLT_exp emin prec (e+1))) (FLT_exp emin prec (e+1))). +assert (Y1: F2R gg = bpow beta e). +unfold F2R; simpl. +rewrite IZR_Zpower. +rewrite <- bpow_plus. +f_equal; ring. +assert (FLT_exp emin prec (e+1) <= e)%Z; [idtac|auto with zarith]. +unfold FLT_exp. +apply Z.max_case_strong; auto with zarith. +assert (Y2: canonical beta (FLT_exp emin prec) gg). +unfold canonical; rewrite Y1; unfold gg; simpl. +unfold cexp; now rewrite mag_bpow. +assert (Y3: Fnum gg = Z.abs (Fnum g)). +apply trans_eq with (Fnum (Fabs g)). +2: destruct g; unfold Fabs; now simpl. +f_equal. +apply canonical_unique with (FLT_exp emin prec); try assumption. +destruct g; unfold Fabs; apply canonical_abs; easy. +now rewrite Y1, F2R_abs, <- Hg1,K. +assert (Y4: Z.even (Fnum gg) = true). +unfold gg; simpl. +rewrite Z.even_pow; try assumption. +assert (FLT_exp emin prec (e+1) < e)%Z; [idtac|auto with zarith]. +unfold FLT_exp. +apply Z.max_case_strong; auto with zarith. +absurd (true = false). +discriminate. +rewrite <- Hg3. +rewrite <- Zeven_abs. +now rewrite <- Y3. +Qed. + +Theorem fexp_round_odd: forall (x:R), + (cexp_flt (round beta (FLT_exp emin prec) Zrnd_odd x) + = cexp_flt x)%Z. +Proof with auto with typeclass_instances. +intros x. +assert (G0:Valid_exp (FLT_exp emin prec)). +apply FLT_exp_valid; unfold Prec_gt_0; auto with zarith. +case (Req_dec x 0); intros Zx. +rewrite Zx, round_0... +case (Zle_or_lt (mag beta x) emin). +unfold cexp; destruct (mag beta x) as (e,He); simpl. +intros H; unfold FLT_exp at 4. +rewrite Z.max_r. +2: auto with zarith. +apply Z.max_r. +assert (G: Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) = bpow beta emin). +assert (G1: (Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) <= bpow beta emin)%R). +apply abs_round_le_generic... +apply generic_format_bpow'... +unfold FLT_exp; rewrite Z.max_r; auto with zarith. +left; apply Rlt_le_trans with (bpow beta e). +now apply He. +now apply bpow_le. +assert (G2: (0 <= Rabs (round beta (FLT_exp emin prec) Zrnd_odd x))%R). +apply Rabs_pos. +assert (G3: (Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) <> 0)%R). +assert (H0:Rnd_odd_pt beta (FLT_exp emin prec) x + (round beta (FLT_exp emin prec) Zrnd_odd x)). +apply round_odd_pt... +destruct H0 as (_,H0); destruct H0 as [H0|(_,(g,(Hg1,(Hg2,Hg3))))]. +apply Rgt_not_eq; rewrite H0. +apply Rlt_le_trans with (bpow beta (e-1)). +apply bpow_gt_0. +now apply He. +rewrite Hg1; intros K. +contradict Hg3. +replace (Fnum g) with 0%Z. +easy. +case (Z.eq_dec (Fnum g) Z0); intros W; try easy. +contradict K. +apply Rabs_no_R0. +now apply F2R_neq_0. +apply Rle_antisym; try assumption. +apply Rle_trans with (succ beta (FLT_exp emin prec) 0). +right; rewrite succ_0. +rewrite ulp_FLT_small; try easy. +unfold Prec_gt_0; auto with zarith. +rewrite Rabs_R0; apply bpow_gt_0. +apply succ_le_lt... +apply generic_format_0. +apply generic_format_abs; apply generic_format_round... +case G2; [easy|intros; now contradict G3]. +rewrite <- mag_abs. +rewrite G, mag_bpow; auto with zarith. +intros H; unfold cexp. +now rewrite mag_round_odd. +Qed. + + + + +End Odd_propbis. + + diff --git a/flocq/Prop/Fprop_Sterbenz.v b/flocq/Prop/Sterbenz.v index 4e74f889..746b7026 100644 --- a/flocq/Prop/Fprop_Sterbenz.v +++ b/flocq/Prop/Sterbenz.v @@ -2,9 +2,9 @@ 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-2018 Sylvie Boldo #<br /># -Copyright (C) 2010-2013 Guillaume Melquiond +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 @@ -19,10 +19,7 @@ COPYING file for more details. (** * Sterbenz conditions for exact subtraction *) -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_generic_fmt. -Require Import Fcalc_ops. +Require Import Raux Defs Generic_fmt Operations. Section Fprop_Sterbenz. @@ -37,7 +34,7 @@ Notation format := (generic_format beta fexp). Theorem generic_format_plus : forall x y, format x -> format y -> - (Rabs (x + y) < bpow (Zmin (ln_beta beta x) (ln_beta beta y)))%R -> + (Rabs (x + y) <= bpow (Z.min (mag beta x) (mag beta y)))%R -> format (x + y)%R. Proof. intros x y Fx Fy Hxy. @@ -48,44 +45,51 @@ destruct (Req_dec x R0) as [Zx|Zx]. now rewrite Zx, Rplus_0_l. destruct (Req_dec y R0) as [Zy|Zy]. now rewrite Zy, Rplus_0_r. +destruct Hxy as [Hxy|Hxy]. revert Hxy. -destruct (ln_beta beta x) as (ex, Ex). simpl. +destruct (mag beta x) as (ex, Ex). simpl. specialize (Ex Zx). -destruct (ln_beta beta y) as (ey, Ey). simpl. +destruct (mag beta y) as (ey, Ey). simpl. specialize (Ey Zy). intros Hxy. set (fx := Float beta (Ztrunc (scaled_mantissa beta fexp x)) (fexp ex)). assert (Hx: x = F2R fx). rewrite Fx at 1. -unfold canonic_exp. -now rewrite ln_beta_unique with (1 := Ex). +unfold cexp. +now rewrite mag_unique with (1 := Ex). set (fy := Float beta (Ztrunc (scaled_mantissa beta fexp y)) (fexp ey)). assert (Hy: y = F2R fy). rewrite Fy at 1. -unfold canonic_exp. -now rewrite ln_beta_unique with (1 := Ey). +unfold cexp. +now rewrite mag_unique with (1 := Ey). rewrite Hx, Hy. rewrite <- F2R_plus. apply generic_format_F2R. intros _. -case_eq (Fplus beta fx fy). +case_eq (Fplus fx fy). intros mxy exy Pxy. rewrite <- Pxy, F2R_plus, <- Hx, <- Hy. -unfold canonic_exp. -replace exy with (fexp (Zmin ex ey)). +unfold cexp. +replace exy with (fexp (Z.min ex ey)). apply monotone_exp. -now apply ln_beta_le_bpow. -replace exy with (Fexp (Fplus beta fx fy)) by exact (f_equal Fexp Pxy). +now apply mag_le_bpow. +replace exy with (Fexp (Fplus fx fy)) by exact (f_equal Fexp Pxy). rewrite Fexp_Fplus. simpl. clear -monotone_exp. apply sym_eq. destruct (Zmin_spec ex ey) as [(H1,H2)|(H1,H2)] ; rewrite H2. -apply Zmin_l. +apply Z.min_l. now apply monotone_exp. -apply Zmin_r. +apply Z.min_r. apply monotone_exp. apply Zlt_le_weak. -now apply Zgt_lt. +now apply Z.gt_lt. +apply generic_format_abs_inv. +rewrite Hxy. +apply generic_format_bpow. +apply valid_exp. +case (Zmin_spec (mag beta x) (mag beta y)); intros (H1,H2); + rewrite H2; now apply mag_generic_gt. Qed. Theorem generic_format_plus_weak : @@ -100,17 +104,17 @@ now rewrite Zx, Rplus_0_l. destruct (Req_dec y R0) as [Zy|Zy]. now rewrite Zy, Rplus_0_r. apply generic_format_plus ; try assumption. -apply Rle_lt_trans with (1 := Hxy). +apply Rle_trans with (1 := Hxy). unfold Rmin. destruct (Rle_dec (Rabs x) (Rabs y)) as [Hxy'|Hxy']. -rewrite Zmin_l. -destruct (ln_beta beta x) as (ex, Hx). -now apply Hx. -now apply ln_beta_le_abs. -rewrite Zmin_r. -destruct (ln_beta beta y) as (ex, Hy). -now apply Hy. -apply ln_beta_le_abs. +rewrite Z.min_l. +destruct (mag beta x) as (ex, Hx). +apply Rlt_le; now apply Hx. +now apply mag_le_abs. +rewrite Z.min_r. +destruct (mag beta y) as (ex, Hy). +apply Rlt_le; now apply Hy. +apply mag_le_abs. exact Zy. apply Rlt_le. now apply Rnot_le_lt. diff --git a/flocq/Flocq_version.v b/flocq/Version.v index 72d4fe20..d0e36a57 100644 --- a/flocq/Flocq_version.v +++ b/flocq/Version.v @@ -2,9 +2,9 @@ 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-2018 Sylvie Boldo #<br /># -Copyright (C) 2011-2013 Guillaume Melquiond +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 @@ -29,4 +29,4 @@ Definition Flocq_version := Eval vm_compute in parse t major (minor * 10 + N_of_ascii h - N_of_ascii "0"%char)%N | Empty_string => (major * 100 + minor)%N end in - parse "2.6.1"%string N0 N0. + parse "3.1.0"%string N0 N0. |