diff options
Diffstat (limited to 'flocq/Appli')
| -rw-r--r-- | flocq/Appli/Fappli_IEEE.v | 1920 | ||||
| -rw-r--r-- | flocq/Appli/Fappli_IEEE_bits.v | 688 | ||||
| -rw-r--r-- | flocq/Appli/Fappli_double_round.v | 4591 | ||||
| -rw-r--r-- | flocq/Appli/Fappli_rnd_odd.v | 1022 |
4 files changed, 0 insertions, 8221 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/Appli/Fappli_IEEE_bits.v b/flocq/Appli/Fappli_IEEE_bits.v deleted file mode 100644 index e6a012cf..00000000 --- a/flocq/Appli/Fappli_IEEE_bits.v +++ /dev/null @@ -1,688 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2011-2013 Sylvie Boldo -#<br /># -Copyright (C) 2011-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** * IEEE-754 encoding of binary floating-point data *) -Require Import Fcore. -Require Import Fcore_digits. -Require Import Fcalc_digits. -Require Import Fappli_IEEE. - -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 _. - -(** 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. - -Lemma join_bits_range : - forall s m e, - (0 <= m < 2^mw)%Z -> - (0 <= e < 2^ew)%Z -> - (0 <= join_bits s m e < 2 ^ (mw + ew + 1))%Z. -Proof. -intros s m e Hm He. -unfold join_bits. -rewrite Z.shiftl_mul_pow2 by now apply Zlt_le_weak. -split. -- apply (Zplus_le_compat 0 _ 0) with (2 := proj1 Hm). - rewrite <- (Zmult_0_l (2^mw)). - apply Zmult_le_compat_r. - case s. - 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. - 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. - 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. -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. - -Theorem split_join_bits : - forall s m e, - (0 <= m < Zpower 2 mw)%Z -> - (0 <= e < Zpower 2 ew)%Z -> - split_bits (join_bits s m e) = (s, m, e). -Proof. -intros s m e Hm He. -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. -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. -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. - -Theorem join_split_bits : - forall x, - (0 <= x < Zpower 2 (mw + ew + 1))%Z -> - let '(s, m, e) := split_bits x in - join_bits s m e = x. -Proof. -intros x Hx. -unfold split_bits, join_bits. -rewrite Z.shiftl_mul_pow2 by now apply Zlt_le_weak. -pattern x at 4 ; rewrite Z_div_mod_eq_full with x (2^mw)%Z. -apply (f_equal (fun v => (v + _)%Z)). -rewrite Zmult_comm. -apply f_equal. -pattern (x / (2^mw))%Z at 2 ; rewrite Z_div_mod_eq_full with (x / (2^mw))%Z (2^ew)%Z. -apply (f_equal (fun v => (v + _)%Z)). -replace (x / 2 ^ mw / 2 ^ ew)%Z with (if Zle_bool (2 ^ mw * 2 ^ ew) x then 1 else 0)%Z. -case Zle_bool. -now rewrite Zmult_1_r. -now rewrite Zmult_0_r. -rewrite Zdiv_Zdiv. -apply sym_eq. -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 ). -change 2%Z at 1 with (Zpower 2 1). -rewrite <- Zpower_exp. -now rewrite Zplus_comm. -discriminate. -apply Zle_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. -now split. -now apply Zlt_le_weak. -now apply Zlt_le_weak. -now apply Zgt_not_eq. -now apply Zgt_not_eq. -Qed. - -Theorem split_bits_inj : - forall x y, - (0 <= x < Zpower 2 (mw + ew + 1))%Z -> - (0 <= y < Zpower 2 (mw + ew + 1))%Z -> - split_bits x = split_bits y -> - x = y. -Proof. -intros x y Hx Hy. -generalize (join_split_bits x Hx) (join_split_bits y Hy). -destruct (split_bits x) as ((sx, mx), ex). -destruct (split_bits y) as ((sy, my), ey). -intros Jx Jy H. revert Jx Jy. -inversion_clear H. -intros Jx Jy. -now rewrite <- Jx. -Qed. - -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_finite sx mx ex _ => - let m := (Zpos mx - Zpower 2 mw)%Z in - if Zle_bool 0 m then - join_bits sx m (ex - emin + 1) - else - join_bits sx (Zpos mx) 0 - end. - -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_finite sx mx ex _ => - let m := (Zpos mx - Zpower 2 mw)%Z in - if Zle_bool 0 m then - (sx, m, ex - emin + 1)%Z - else - (sx, Zpos mx, 0)%Z - end. - -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 ). -simpl. apply split_join_bits; split; try (zify; omega). -destruct (digits2_Pnat_correct plx). -rewrite Zpos_digits2_pos, <- Z_of_nat_S_digits2_Pnat in Hplx. -rewrite Zpower_nat_Z in H0. -eapply Zlt_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. -(* *) -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'. -rewrite Zpos_digits2_pos in Hx'. -generalize (Zeq_bool_eq _ _ Hx'). -unfold FLT_exp. -unfold emin. -clear ; zify ; omega. -case Zle_bool_spec ; intros H ; - [ apply -> Z.le_0_sub in H | apply -> Z.lt_sub_0 in H ] ; - apply split_join_bits ; try now split. -(* *) -split. -clear -He_gt_0 H ; omega. -cut (Zpos mx < 2 * 2^mw)%Z. clear ; omega. -replace (2 * 2^mw)%Z with (2^prec)%Z. -apply (Zpower_gt_Zdigits radix2 _ (Zpos mx)). -apply Hf. -unfold prec. -rewrite Zplus_comm. -apply Zpower_exp ; apply Zle_ge. -discriminate. -now apply Zlt_le_weak. -(* *) -split. -generalize (proj1 Hf). -clear ; omega. -destruct (andb_prop _ _ Hx) as (_, Hx'). -unfold emin. -replace (2^ew)%Z with (2 * emax)%Z. -generalize (Zle_bool_imp_le _ _ Hx'). -clear ; omega. -apply sym_eq. -rewrite (Zsucc_pred ew). -unfold Zsucc. -rewrite Zplus_comm. -apply Zpower_exp ; apply Zle_ge. -discriminate. -now apply Zlt_0_le_0_pred. -Qed. - -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]. -- apply join_bits_range ; now split. -- apply join_bits_range. - now split. - clear -He_gt_0 ; omega. -- apply Z.ltb_lt in pl_range. - apply join_bits_range. - split. - easy. - apply (Zpower_gt_Zdigits radix2 _ (Zpos pl)). - apply Z.lt_succ_r. - now rewrite <- Zdigits2_Zdigits. - clear -He_gt_0 ; omega. -- 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. - case Zle_bool_spec ; intros H. - + apply join_bits_range. - * split. - clear -H ; omega. - rewrite Zpos_digits2_pos in A. - cut (Zpos mx < 2 ^ prec)%Z. - unfold prec. - rewrite Zpower_plus by (clear -Hmw ; omega). - change (2^1)%Z with 2%Z. - clear ; omega. - apply (Zpower_gt_Zdigits radix2 _ (Zpos mx)). - clear -A ; zify ; omega. - * split. - unfold emin ; clear -A ; zify ; omega. - replace ew with ((ew - 1) + 1)%Z by ring. - rewrite Zpower_plus by (clear - Hew ; omega). - unfold emin, emax in *. - change (2^1)%Z with 2%Z. - clear -B ; omega. - + apply -> Z.lt_sub_0 in H. - apply join_bits_range ; now split. -Qed. - -Definition binary_float_of_bits_aux x := - let '(sx, mx, ex) := split_bits x in - if Zeq_bool ex 0 then - match mx with - | Z0 => F754_zero sx - | Zpos px => F754_finite sx px emin - | Zneg _ => F754_nan false xH (* dummy *) - end - else if Zeq_bool ex (Zpower 2 ew - 1) then - match mx with - | Z0 => F754_infinity sx - | Zpos plx => F754_nan sx plx - | Zneg _ => F754_nan false xH (* dummy *) - end - else - match (mx + Zpower 2 mw)%Z with - | Zpos px => F754_finite sx px (ex + emin - 1) - | _ => F754_nan false xH (* dummy *) - end. - -Lemma binary_float_of_bits_aux_correct : - forall x, - valid_binary prec emax (binary_float_of_bits_aux x) = true. -Proof. -intros x. -unfold binary_float_of_bits_aux, split_bits. -case Zeq_bool_spec ; intros He1. -case_eq (x mod 2^mw)%Z ; try easy. -(* subnormal *) -intros px Hm. -assert (Zdigits radix2 (Zpos px) <= mw)%Z. -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. -fold emin. -rewrite ln_beta_F2R_Zdigits. 2: discriminate. -unfold Fexp, FLT_exp. -apply sym_eq. -apply Zmax_right. -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. -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 *) -intros plx Eqplx. apply Z.ltb_lt. -rewrite Zpos_digits2_pos. -assert (forall a b, a <= b -> a < b+1)%Z by (intros; omega). apply H. clear H. -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. -apply sym_eq. -apply ln_beta_unique. -rewrite <- Z2R_abs. -unfold Zabs. -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 <- Hm. -split. -apply Z2R_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. -unfold prec. -rewrite Zpower_exp. 2: now apply Zle_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. -(* . *) -apply bounded_canonic_lt_emax ; try assumption. -unfold canonic, canonic_exp. -rewrite ln_beta_F2R_Zdigits. 2: discriminate. -unfold Fexp, FLT_exp. -rewrite <- H. -set (ex := ((x / 2^mw) mod 2^ew)%Z). -replace (prec + (ex + emin - 1) - prec)%Z with (ex + emin - 1)%Z by ring. -apply sym_eq. -apply Zmax_left. -revert He1. -fold ex. -cut (0 <= ex)%Z. -unfold emin. -clear ; intros H1 H2 ; omega. -eapply Z_mod_lt. -apply Zlt_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. -rewrite <- H. -apply Zlt_not_le. -unfold emin. -apply Zplus_lt_reg_r with (emax - 1)%Z. -ring_simplify. -revert He2. -set (ex := ((x / 2^mw) mod 2^ew)%Z). -cut (ex < 2^ew)%Z. -replace (2^ew)%Z with (2 * emax)%Z. -clear ; intros H1 H2 ; omega. -replace ew with (1 + (ew - 1))%Z by ring. -rewrite Zpower_exp. -apply refl_equal. -discriminate. -clear -Hew ; omega. -eapply Z_mod_lt. -apply Zlt_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 := - FF2B prec emax _ (binary_float_of_bits_aux_correct x). - -Theorem binary_float_of_bits_of_binary_float : - forall x, - binary_float_of_bits (bits_of_binary_float x) = x. -Proof. -intros x. -apply B2FF_inj. -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]. -apply refl_equal. -(* *) -simpl. -rewrite Zeq_bool_false. -now rewrite Zeq_bool_true. -cut (1 < 2^ew)%Z. clear ; omega. -now apply (Zpower_gt_1 radix2). -(* *) -simpl. -rewrite Zeq_bool_false. -rewrite Zeq_bool_true; auto. -cut (1 < 2^ew)%Z. clear ; omega. -now apply (Zpower_gt_1 radix2). -(* *) -unfold split_bits_of_binary_float. -case Zle_bool_spec ; intros Hm. -(* . *) -rewrite Zeq_bool_false. -rewrite Zeq_bool_false. -now ring_simplify (Zpos mx - 2 ^ mw + 2 ^ mw)%Z (ex - emin + 1 + emin - 1)%Z. -destruct (andb_prop _ _ Bx) as (_, H1). -generalize (Zle_bool_imp_le _ _ H1). -unfold emin. -replace (2^ew)%Z with (2 * emax)%Z. -clear ; omega. -replace ew with (1 + (ew - 1))%Z by ring. -rewrite Zpower_exp. -apply refl_equal. -discriminate. -clear -Hew ; omega. -destruct (andb_prop _ _ Bx) as (H1, _). -generalize (Zeq_bool_eq _ _ H1). -rewrite Zpos_digits2_pos. -unfold FLT_exp, emin. -generalize (Zdigits radix2 (Zpos mx)). -clear. -intros ; zify ; omega. -(* . *) -rewrite Zeq_bool_true. 2: apply refl_equal. -simpl. -apply f_equal. -destruct (andb_prop _ _ Bx) as (H1, _). -generalize (Zeq_bool_eq _ _ H1). -rewrite Zpos_digits2_pos. -unfold FLT_exp, emin, prec. -apply -> Z.lt_sub_0 in Hm. -generalize (Zdigits_le_Zpower radix2 _ (Zpos mx) Hm). -generalize (Zdigits radix2 (Zpos mx)). -clear. -intros ; zify ; omega. -Qed. - -Theorem bits_of_binary_float_of_bits : - forall x, - (0 <= x < 2^(mw+ew+1))%Z -> - bits_of_binary_float (binary_float_of_bits x) = x. -Proof. -intros x Hx. -unfold binary_float_of_bits, bits_of_binary_float. -set (Cx := binary_float_of_bits_aux_correct x). -clearbody Cx. -rewrite match_FF2B. -revert Cx. -generalize (join_split_bits x Hx). -unfold binary_float_of_bits_aux. -case_eq (split_bits x). -intros (sx, mx) ex Sx. -assert (Bm: (0 <= mx < 2^mw)%Z). -inversion_clear Sx. -apply Z_mod_lt. -now apply Zlt_gt. -case Zeq_bool_spec ; intros He1. -(* subnormal *) -case_eq mx. -intros Hm Jx _. -now rewrite He1 in Jx. -intros px Hm Jx _. -rewrite Zle_bool_false. -now rewrite <- He1. -apply <- Z.lt_sub_0. -now rewrite <- Hm. -intros px Hm _ _. -apply False_ind. -apply Zle_not_lt with (1 := proj1 Bm). -now rewrite Hm. -case Zeq_bool_spec ; intros He2. -(* infinity/nan *) -case_eq mx; intros Hm. -now rewrite He2. -now rewrite He2. -intros. zify; omega. -(* normal *) -case_eq (mx + 2 ^ mw)%Z. -intros Hm. -apply False_ind. -clear -Bm Hm ; omega. -intros p Hm Jx Cx. -rewrite <- Hm. -rewrite Zle_bool_true. -now ring_simplify (mx + 2^mw - 2^mw)%Z (ex + emin - 1 - emin + 1)%Z. -now ring_simplify. -intros p Hm. -apply False_ind. -clear -Bm Hm ; zify ; omega. -Qed. - -End Binary_Bits. - -(** Specialization for IEEE single precision operations *) -Section B32_Bits. - -Arguments B754_nan {prec emax} _ _. - -Definition binary32 := binary_float 24 128. - -Let Hprec : (0 < 24)%Z. -apply refl_equal. -Qed. - -Let Hprec_emax : (24 < 128)%Z. -apply refl_equal. -Qed. - -Definition default_nan_pl32 : bool * nan_pl 24 := - (false, exist _ (iter_nat xO 22 xH) (refl_equal true)). - -Definition unop_nan_pl32 (f : binary32) : bool * nan_pl 24 := - match f with - | B754_nan s pl => (s, pl) - | _ => default_nan_pl32 - end. - -Definition binop_nan_pl32 (f1 f2 : binary32) : bool * nan_pl 24 := - match f1, f2 with - | B754_nan s1 pl1, _ => (s1, pl1) - | _, B754_nan s2 pl2 => (s2, pl2) - | _, _ => 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_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. - -End B32_Bits. - -(** Specialization for IEEE double precision operations *) -Section B64_Bits. - -Arguments B754_nan {prec emax} _ _. - -Definition binary64 := binary_float 53 1024. - -Let Hprec : (0 < 53)%Z. -apply refl_equal. -Qed. - -Let Hprec_emax : (53 < 1024)%Z. -apply refl_equal. -Qed. - -Definition default_nan_pl64 : bool * nan_pl 53 := - (false, exist _ (iter_nat xO 51 xH) (refl_equal true)). - -Definition unop_nan_pl64 (f : binary64) : bool * nan_pl 53 := - match f with - | B754_nan s pl => (s, pl) - | _ => 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) - | _, _ => 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_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. - -End B64_Bits. diff --git a/flocq/Appli/Fappli_double_round.v b/flocq/Appli/Fappli_double_round.v deleted file mode 100644 index 82f61da3..00000000 --- a/flocq/Appli/Fappli_double_round.v +++ /dev/null @@ -1,4591 +0,0 @@ -(** * Conditions for innocuous double rounding. *) - -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. - -Require Import Psatz. - -Open Scope R_scope. - -Section Double_round. - -Variable beta : radix. -Notation bpow e := (bpow beta e). -Notation ln_beta x := (ln_beta beta x). - -Definition double_round_eq fexp1 fexp2 choice1 choice2 x := - round beta fexp1 (Znearest choice1) (round beta fexp2 (Znearest choice2) x) - = round beta fexp1 (Znearest choice1) x. - -(** A little tactic to simplify terms of the form [bpow a * bpow b]. *) -Ltac bpow_simplify := - (* bpow ex * bpow ey ~~> bpow (ex + ey) *) - repeat - match goal with - | |- context [(Fcore_Raux.bpow _ _ * Fcore_Raux.bpow _ _)] => - rewrite <- bpow_plus - | |- context [(?X1 * Fcore_Raux.bpow _ _ * Fcore_Raux.bpow _ _)] => - rewrite (Rmult_assoc X1); rewrite <- bpow_plus - | |- context [(?X1 * (?X2 * Fcore_Raux.bpow _ _) * Fcore_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)] => - progress ring_simplify X - end; - (* bpow 0 ~~> 1 *) - change (Fcore_Raux.bpow _ 0) with 1; - repeat - match goal with - | |- context [(_ * 1)] => - rewrite Rmult_1_r - end. - -Definition midp (fexp : Z -> Z) (x : R) := - round beta fexp Zfloor x + / 2 * ulp beta fexp x. - -Definition midp' (fexp : Z -> Z) (x : R) := - round beta fexp Zceil x - / 2 * ulp beta fexp x. - -Lemma double_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 -> - x < midp fexp1 x - / 2 * ulp beta fexp2 x -> - double_round_eq fexp1 fexp2 choice1 choice2 x. -Proof. -intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hx1. -unfold double_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))). -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]. -assert (Pxx' : 0 <= x - x'). -{ apply Rle_0_minus. - 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))). -{ 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. - apply Rplus_le_lt_compat. - - exact Hr1. - - now rewrite Rabs_right; [|now apply Rle_ge]; apply Hx2. } -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. - 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|]. - rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; - [|now apply Rle_ge; apply bpow_ge_0]. - rewrite <- Rabs_mult; rewrite Rmult_minus_distr_r. - rewrite Rmult_0_l. - bpow_simplify. - rewrite Rabs_minus_sym. - apply (Rle_lt_trans _ _ _ Hr1). - apply Rmult_lt_compat_l; [lra|]. - apply bpow_lt. - omega. -- (* x'' <> 0 *) - assert (Lx'' : ln_beta x'' = ln_beta x :> Z). - { apply Zle_antisym. - - apply ln_beta_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. - 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. - 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|]. - rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; - [|now apply Rle_ge; apply bpow_ge_0]. - rewrite <- Rabs_mult. - rewrite Rmult_minus_distr_r. - fold x'. - bpow_simplify. - 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|]. - rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; - [|now apply Rle_ge; apply bpow_ge_0]. - rewrite <- Rabs_mult. - rewrite Rmult_minus_distr_r. - fold x'. - now bpow_simplify. -Qed. - -Lemma double_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 -> - x < midp fexp1 x - / 2 * ulp beta fexp2 x -> - double_round_eq fexp1 fexp2 choice1 choice2 x. -Proof. -intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hf1. -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. } -revert Hx2. -unfold double_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]... -2: rewrite ulp_neq_0;[assumption|now apply Rgt_not_eq]. -destruct (Req_dec x' 0) as [Zx'|Nzx']. -- (* x' = 0 *) - rewrite Zx' in Hx2; rewrite Rminus_0_r in Hx2. - apply (Rlt_le_trans _ _ _ Hx2). - 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_l with (1 := Rlt_0_2). - replace (2 * (/ 2 * _)) with (bpow (fexp1 (ln_beta x) - ln_beta x)) by field. - apply Rle_trans with 1; [|lra]. - change 1 with (bpow 0); apply bpow_le. - omega. -- (* x' <> 0 *) - assert (Px' : 0 < x'). - { assert (0 <= x'); [|lra]. - unfold x'. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta 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. - 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). - { apply (Rplus_le_reg_r (ulp beta fexp1 x)); ring_simplify. - rewrite <- ulp_DN. - - change (round _ _ _ _) with x'. - apply id_p_ulp_le_bpow. - + exact Px'. - + change x' with (round beta fexp1 Zfloor x). - now apply generic_format_round; [|apply valid_rnd_DN]. - + 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. - - exact Vfexp1. - - exact Px'. } - fold (canonic_exp 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]. - apply ulp_ge_0. - rewrite 2!ulp_neq_0 in Hx2;[|now apply Rgt_not_eq|now apply Rgt_not_eq]. - rewrite ulp_neq_0 in Hx';[|now apply Rgt_not_eq]. - rewrite ulp_neq_0 in H;[|now apply Rgt_not_eq]. - lra. -Qed. - -Lemma double_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 -> - x < midp fexp1 x -> - double_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. -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. - 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'. - split. - - apply Rlt_le_trans with 0; [|exact Pxx']. - rewrite <- Ropp_0. - apply Ropp_lt_contravar. - rewrite <- (Rmult_0_r (/ 2)). - apply Rmult_lt_compat_l; [lra|]. - 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. -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))))). - + now apply valid_rnd_N. - + fold (canonic_exp beta fexp1 x). - change (Z2R _ * 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 : - 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 -> - x < midp fexp1 x -> - ((fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z -> - x < midp fexp1 x - / 2 * ulp beta fexp2 x) -> - double_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|]. - generalize (Hx' Hf2''); intro Hx''. - now apply double_round_lt_mid_further_place. -Qed. - -Lemma double_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) -> - midp' fexp1 x + / 2 * ulp beta fexp2 x < x -> - double_round_eq fexp1 fexp2 choice1 choice2 x. -Proof. -intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1. -intros Hx1 Hx2'. -assert (Hx2 : round beta fexp1 Zceil x - x - < / 2 * (ulp beta fexp1 x - ulp beta fexp2 x)). -{ apply (Rplus_lt_reg_r (- / 2 * ulp beta fexp1 x + x - + / 2 * ulp beta fexp2 x)); ring_simplify. - now unfold midp' in Hx2'. } -revert Hx1 Hx2. -unfold double_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))). - 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]. -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))). -{ 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. - apply Rplus_le_lt_compat. - - exact Hr1. - - rewrite Rabs_minus_sym. - rewrite 2!ulp_neq_0 in Hx2; try (apply Rgt_not_eq; assumption). - now rewrite Rabs_right; [|now apply Rle_ge]; apply Hx2. } -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. - 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|]. - rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; - [|now apply Rle_ge; apply bpow_ge_0]. - rewrite <- Rabs_mult; rewrite Rmult_minus_distr_r. - rewrite Rmult_0_l. - bpow_simplify. - rewrite Rabs_minus_sym. - apply (Rle_lt_trans _ _ _ Hr1). - apply Rmult_lt_compat_l; [lra|]. - apply bpow_lt. - omega. -- (* x'' <> 0 *) - assert (Lx'' : ln_beta x'' = ln_beta x :> Z). - { apply Zle_antisym. - - apply ln_beta_le_bpow; [exact Nzx''|]. - rewrite Rabs_right; [exact Hx1|apply Rle_ge]. - apply round_ge_generic. - + exact Vfexp2. - + now apply valid_rnd_N. - + 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. - 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|]. - rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; - [|now apply Rle_ge; apply bpow_ge_0]. - rewrite <- Rabs_mult. - rewrite Rmult_minus_distr_r. - fold x'. - bpow_simplify. - rewrite Rabs_minus_sym. - 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))). - 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|]. - rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; - [|now apply Rle_ge; apply bpow_ge_0]. - rewrite <- Rabs_mult. - rewrite Rmult_minus_distr_r. - fold x'. - now bpow_simplify. -Qed. - -Lemma double_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 -> - midp' fexp1 x + / 2 * ulp beta fexp2 x < x -> - double_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 - < / 2 * (ulp beta fexp1 x - ulp beta fexp2 x)). -{ apply (Rplus_lt_reg_r (- / 2 * ulp beta fexp1 x + x - + / 2 * ulp beta fexp2 x)); ring_simplify. - now unfold midp' in Hx2'. } -revert Hx2. -unfold double_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). - { apply Rle_lt_trans with (x + / 2 * ulp beta fexp2 x). - - apply (Rplus_le_reg_r (- x)); ring_simplify. - apply Rabs_le_inv. - apply error_le_half_ulp. - 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 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|]. - bpow_simplify. - rewrite <- (Z2R_Zpower _ (_ - _)); [|omega]. - apply Z2R_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|]. - 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 ulp_neq_0;[idtac|now apply Rgt_not_eq]. - apply Rmult_le_compat_r; [now apply bpow_ge_0|]. - lra. } -assert (Hr : Rabs (x - x'') < / 2 * ulp beta fexp1 x). -{ apply Rle_lt_trans with (/ 2 * ulp beta fexp2 x). - - rewrite Rabs_minus_sym. - apply error_le_half_ulp. - 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. - omega. } -unfold round, F2R, scaled_mantissa, canonic_exp; simpl. -assert (Hf : (0 <= ln_beta x - fexp1 (ln_beta 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]; - [|now apply Vfexp1]. - assert (H : (ln_beta x = fexp1 (ln_beta 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]. - now bpow_simplify. - + rewrite Z2R_Zpower; [|omega]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta 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. - 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 <- (Rabs_right (bpow (fexp1 _))) at 1; - [|now apply Rle_ge; apply bpow_ge_0]. - rewrite <- Rabs_mult. - rewrite Rmult_minus_distr_r. - bpow_simplify. - rewrite Rminus_diag_eq; [|exact Hx''pow]. - rewrite Rabs_R0. - rewrite <- (Rmult_0_r (/ 2)). - apply Rmult_lt_compat_l; [lra|apply bpow_gt_0]. -Qed. - -Lemma double_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 -> - midp' fexp1 x < x -> - double_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. - 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. - split. - - apply Rlt_le_trans with 0. - + rewrite <- Ropp_0; apply Ropp_lt_contravar. - rewrite <- (Rmult_0_r (/ 2)). - apply Rmult_lt_compat_l; [lra|]. - apply bpow_gt_0. - + apply Rle_0_minus. - 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. -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))))); - [|rewrite Rabs_minus_sym]. - + now apply valid_rnd_N. - + fold (canonic_exp beta fexp1 x). - change (Z2R _ * 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 : - 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 -> - midp' fexp1 x < x -> - ((fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z -> - midp' fexp1 x + / 2 * ulp beta fexp2 x < x) -> - double_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|]. - generalize (Hx' Hf2''); intro Hx''. - now apply double_round_gt_mid_further_place. -Qed. - -Section Double_round_mult. - -Lemma ln_beta_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)). -Proof. -intros x y Zx Zy. -destruct (ln_beta_mult beta x y Zx Zy). -omega. -Qed. - -Definition double_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 : - forall (fexp1 fexp2 : Z -> Z), - double_round_mult_hyp fexp1 fexp2 -> - forall x y, - generic_format beta fexp1 x -> generic_format beta fexp1 y -> - generic_format beta fexp2 (x * y). -Proof. -intros fexp1 fexp2 Hfexp x y Fx Fy. -destruct (Req_dec x 0) as [Zx|Zx]. -- (* x = 0 *) - rewrite Zx. - rewrite Rmult_0_l. - now apply generic_format_0. -- (* x <> 0 *) - destruct (Req_dec y 0) as [Zy|Zy]. - + (* y = 0 *) - rewrite Zy. - rewrite Rmult_0_r. - now apply generic_format_0. - + (* y <> 0 *) - revert Fx Fy. - unfold generic_format. - unfold canonic_exp. - 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))). - assert (Hxy : x * y = F2R fxy). - { unfold fxy, F2R; simpl. - rewrite bpow_plus. - rewrite Z2R_mult. - rewrite Fx, Fy at 1. - ring. } - apply generic_format_F2R' with (f := fxy); [now rewrite Hxy|]. - intros _. - unfold canonic_exp, fxy; simpl. - destruct Hfexp as (Hfexp1, Hfexp2). - now destruct (ln_beta_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 : - forall (fexp1 fexp2 : Z -> Z), - double_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)) - = round beta fexp1 rnd (x * y). -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 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 : - (2 * prec <= prec')%Z -> - forall x y, - FLX_format beta prec x -> FLX_format beta prec y -> - round beta (FLX_exp prec) rnd (round beta (FLX_exp prec') rnd (x * y)) - = round beta (FLX_exp prec) rnd (x * y). -Proof. -intros Hprec x y Fx Fy. -apply double_round_mult; - [|now apply generic_format_FLX|now apply generic_format_FLX]. -unfold double_round_mult_hyp; split; intros ex ey; unfold FLX_exp; -omega. -Qed. - -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 : - (emin' <= 2 * emin)%Z -> (2 * prec <= prec')%Z -> - forall x y, - FLT_format beta emin prec x -> FLT_format beta emin prec y -> - round beta (FLT_exp emin prec) rnd - (round beta (FLT_exp emin' prec') rnd (x * y)) - = round beta (FLT_exp emin prec) rnd (x * y). -Proof. -intros Hemin Hprec x y Fx Fy. -apply double_round_mult; - [|now apply generic_format_FLT|now apply generic_format_FLT]. -unfold double_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'); -generalize (Zmax_spec (ex - prec) emin); -generalize (Zmax_spec (ey - prec) emin); -omega. -Qed. - -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 : - (emin' + prec' <= 2 * emin + prec)%Z -> - (2 * prec <= prec')%Z -> - forall x y, - FTZ_format beta emin prec x -> FTZ_format beta emin prec y -> - round beta (FTZ_exp emin prec) rnd - (round beta (FTZ_exp emin' prec') rnd (x * y)) - = round beta (FTZ_exp emin prec) rnd (x * y). -Proof. -intros Hemin Hprec x y Fx Fy. -apply double_round_mult; - [|now apply generic_format_FTZ|now apply generic_format_FTZ]. -unfold double_round_mult_hyp; split; intros ex ey; -unfold FTZ_exp; -unfold Prec_gt_0 in *; -destruct (Z.ltb_spec (ex + ey - prec') emin'); -destruct (Z.ltb_spec (ex - prec) emin); -destruct (Z.ltb_spec (ey - prec) emin); -destruct (Z.ltb_spec (ex + ey - 1 - prec') emin'); -omega. -Qed. - -End Double_round_mult_FTZ. - -End Double_round_mult. - -Section Double_round_plus. - -Lemma ln_beta_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)). -Proof. -intros x y Py Hxy. -destruct (ln_beta_plus beta x y Py Hxy). -omega. -Qed. - -Lemma ln_beta_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). -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. -Qed. - -Lemma ln_beta_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)). -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. -omega. -Qed. - -Lemma ln_beta_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). -Proof. -intros fexp Vfexp x y Px Py Yltx Xgtpow Fx Ly. -apply ln_beta_unique. -split. -- apply Rabs_ge; right. - assert (Hy : y < ulp beta fexp (bpow (ln_beta x - 1))). - { rewrite ulp_bpow. - replace (_ + _)%Z with (ln_beta 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. - - 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))). - + 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|]. -- rewrite Rabs_right. - + apply Rlt_trans with x. - * rewrite <- (Rplus_0_r x) at 2. - apply Rplus_lt_compat_l. - rewrite <- Ropp_0. - now apply Ropp_lt_contravar. - * apply Rabs_lt_inv. - apply bpow_ln_beta_gt. - + lra. -Qed. - -Definition double_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 : - 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 -> - generic_format beta fexp1 x -> generic_format beta fexp1 y -> - generic_format beta fexp2 (x + y). -Proof. -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). -- (* 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). - + (* y <> 0 *) - revert Fx Fy. - unfold generic_format at -3, canonic_exp, 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))). - assert (Hxy : x + y = F2R fxy). - { unfold fxy, F2R; simpl. - rewrite Z2R_plus. - rewrite Rmult_plus_distr_r. - rewrite <- Fx. - rewrite Z2R_mult. - rewrite Z2R_Zpower; [|omega]. - bpow_simplify. - now rewrite <- Fy. } - apply generic_format_F2R' with (f := fxy); [now rewrite Hxy|]. - intros _. - now unfold canonic_exp, fxy; simpl. -Qed. - -Lemma double_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 -> - 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). -- rewrite Rplus_comm in Hlnx, Hlny |- *. - now apply (double_round_plus_aux0_aux_aux fexp1); [omega| | | |]. -Qed. - -(* fexp1 (ln_beta x) - 1 <= ln_beta y : - * addition is exact in the largest precision (fexp2). *) -Lemma double_round_plus_aux0 : - forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> - double_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 -> - 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); - [| |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. - + 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. - omega. - + destruct (ln_beta_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. - omega. -Qed. - -Lemma double_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) -> - generic_format beta fexp x -> - 0 < (x + y) - round beta fexp Zfloor (x + y) < bpow (fexp (ln_beta 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. -rewrite Hlxy. -set (mx := Ztrunc (x * bpow (- fexp (ln_beta x)))). -intros Fx. -assert (R : (x + y) * bpow (- fexp (ln_beta x)) - = Z2R mx + y * bpow (- fexp (ln_beta x))). -{ rewrite Fx at 1. - rewrite Rmult_plus_distr_r. - now bpow_simplify. } -rewrite R. -assert (LB : 0 < y * bpow (- fexp (ln_beta 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))). - - 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 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. - now apply Rle_refl. - * casetype False; apply (Zlt_irrefl 0). - apply (Zlt_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|]. - 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|]. - 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]. } -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 Rmult_1_l. - bpow_simplify. - apply Rlt_trans with (bpow (ln_beta y)). - + rewrite <- Rabs_right at 1; [|now apply Rle_ge; apply Rlt_le]. - apply bpow_ln_beta_gt. - + apply bpow_lt; omega. -Qed. - -(* ln_beta y <= fexp1 (ln_beta x) - 2 : double_round_lt_mid applies. *) -Lemma double_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 -> - forall x y, - 0 < x -> 0 < y -> - (ln_beta y <= fexp1 (ln_beta x) - 2)%Z -> - generic_format beta fexp1 x -> - double_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]|]. -destruct Hexp as (_,(_,(_,Hexp4))). -assert (Hf2 : (fexp2 (ln_beta x) <= fexp1 (ln_beta 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))). - 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. -- 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|]. -- 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 - 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|]. - 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. - intro Hf2'. - apply (Rmult_lt_reg_r (bpow (- fexp1 (ln_beta x)))); - [now apply bpow_gt_0|]. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta 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 - Py Hly Lxy Fx))). - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta 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. - apply (Rle_trans _ _ _ Bpow2). - rewrite <- (Rmult_1_r (/ 2)) at 3; rewrite <- Rmult_minus_distr_l. - apply Rmult_le_compat_l; [lra|]. - apply (Rplus_le_reg_r (- 1)); ring_simplify. - replace (_ - _) with (- (/ 2)) by lra. - apply Ropp_le_contravar. - { apply Rle_trans with (bpow (- 1)). - - apply bpow_le; omega. - - unfold Fcore_Raux.bpow, Z.pow_pos; simpl. - apply Rinv_le; [lra|]. - change 2 with (Z2R 2); apply Z2R_le; omega. } -Qed. - -(* double_round_plus_aux{0,1} together *) -Lemma double_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 -> - 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). -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 *) - 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). -Qed. - -Lemma double_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 -> - 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). -Proof. -intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Nnx Nny Fx Fy. -unfold double_round_eq. -destruct (Req_dec x 0) as [Zx|Nzx]. -- (* x = 0 *) - destruct Hexp as (_,(_,(_,Hexp4))). - rewrite Zx; rewrite Rplus_0_l. - rewrite (round_generic beta fexp2). - + reflexivity. - + now apply valid_rnd_N. - + apply (generic_inclusion_ln_beta beta fexp1). - now intros _; apply Hexp4; omega. - exact Fy. -- (* x <> 0 *) - destruct (Req_dec y 0) as [Zy|Nzy]. - + (* y = 0 *) - destruct Hexp as (_,(_,(_,Hexp4))). - rewrite Zy; rewrite Rplus_0_r. - rewrite (round_generic beta fexp2). - * reflexivity. - * now apply valid_rnd_N. - * apply (generic_inclusion_ln_beta beta fexp1). - now intros _; apply Hexp4; omega. - exact Fx. - + (* y <> 0 *) - assert (Px : 0 < x); [lra|]. - assert (Py : 0 < y); [lra|]. - destruct (Rlt_or_le x y) as [H|H]. - * (* x < y *) - apply Rlt_le in H. - rewrite Rplus_comm. - now apply double_round_plus_aux2. - * now apply double_round_plus_aux2. -Qed. - -Lemma double_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 -> - 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. -apply generic_format_opp in Fy. -now apply (double_round_plus_aux0_aux fexp1). -Qed. - -(* fexp1 (ln_beta x) - 1 <= ln_beta y : - * substraction is exact in the largest precision (fexp2). *) -Lemma double_round_minus_aux0 : - forall (fexp1 fexp2 : Z -> Z), - double_round_plus_hyp fexp1 fexp2 -> - forall x y, - 0 < y -> y < x -> - (fexp1 (ln_beta x) - 1 <= ln_beta 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|]. - destruct Hor as [Heq|Heqm1]. - + (* ln_beta y = ln_beta x *) - apply (double_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. - * 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 Hexp4. - apply Zle_trans with (ln_beta (x - y)); [omega|]. - now apply ln_beta_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]. - * 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]; - rewrite Lxmy. - * apply Hexp1. - replace (_ + _)%Z with (ln_beta x : Z); [|ring]. - now apply Zle_trans with (ln_beta y). - * apply Hexp1. - now replace (_ + _)%Z with (ln_beta x : Z); [|ring]. -Qed. - -(* ln_beta y <= fexp1 (ln_beta x) - 2, - * fexp1 (ln_beta (x - y)) - 1 <= ln_beta y : - * substraction is exact in the largest precision (fexp2). *) -Lemma double_round_minus_aux1 : - forall (fexp1 fexp2 : Z -> Z), - Valid_exp fexp1 -> Valid_exp fexp2 -> - double_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 -> - 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))). - + apply Hexp4; omega. - + omega. -- now apply Hexp3. -Qed. - -Lemma double_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 -> - generic_format beta fexp x -> - generic_format beta fexp y -> - round beta fexp Zceil (x - y) - (x - y) <= y. -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)))). -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 (Rxy : round beta fexp Zceil (x - y) = x). - { unfold round, F2R, scaled_mantissa, canonic_exp; simpl. - rewrite Lxy. - apply eq_sym; rewrite Fx at 1; apply eq_sym. - apply Rmult_eq_compat_r. - apply f_equal. - rewrite Fx at 1. - rewrite Rmult_minus_distr_r. - bpow_simplify. - apply Zceil_imp. - split. - - unfold Zminus; rewrite Z2R_plus. - apply Rplus_lt_compat_l. - apply Ropp_lt_contravar; simpl. - apply (Rmult_lt_reg_r (bpow (fexp (ln_beta x)))); - [now apply bpow_gt_0|]. - rewrite Rmult_1_l; bpow_simplify. - apply Rlt_le_trans with (bpow (ln_beta y)). - + rewrite <- Rabs_right at 1; [|now apply Rle_ge; apply Rlt_le]. - apply bpow_ln_beta_gt. - + apply bpow_le. - omega. - - rewrite <- (Rplus_0_r (Z2R _)) at 2. - apply Rplus_le_compat_l. - rewrite <- Ropp_0; apply Ropp_le_contravar. - rewrite <- (Rmult_0_r y). - apply Rmult_le_compat_l; [now apply Rlt_le|]. - 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)). - { apply Rle_antisym; [exact Hx|]. - destruct (ln_beta 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). - { apply Zle_antisym. - - apply ln_beta_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). - omega. } - assert (Hfx1 : (fexp (ln_beta x - 1) < ln_beta x - 1)%Z); - [now apply (valid_exp_large fexp (ln_beta y)); [|omega]|]. - assert (Rxy : round beta fexp Zceil (x - y) <= x). - { rewrite Xpow at 2. - unfold round, F2R, scaled_mantissa, canonic_exp; simpl. - rewrite Lxy. - apply (Rmult_le_reg_r (bpow (- fexp (ln_beta x - 1)%Z))); - [now apply bpow_gt_0|]. - bpow_simplify. - rewrite <- (Z2R_Zpower beta (_ - _ - _)); [|omega]. - apply Z2R_le. - apply Zceil_glb. - rewrite Z2R_Zpower; [|omega]. - rewrite Xpow at 1. - rewrite Rmult_minus_distr_r. - bpow_simplify. - rewrite <- (Rplus_0_r (bpow _)) at 2. - apply Rplus_le_compat_l. - rewrite <- Ropp_0; apply Ropp_le_contravar. - rewrite <- (Rmult_0_r y). - apply Rmult_le_compat_l; [now apply Rlt_le|]. - now apply bpow_ge_0. } - 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 : - forall (fexp1 fexp2 : Z -> Z), - Valid_exp fexp1 -> Valid_exp fexp2 -> - forall (choice1 choice2 : Z -> bool), - double_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 -> - generic_format beta fexp1 x -> - generic_format beta fexp1 y -> - double_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 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); - [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 (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))). - rewrite Zmult_1_r. - now apply Zmult_le_compat; omega. } -assert (Ly : y < bpow (ln_beta y)). -{ apply Rabs_lt_inv. - apply bpow_ln_beta_gt. } -unfold double_round_eq. -apply double_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]. -- 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 Rle_lt_trans with y; - [now apply double_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 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. - rewrite Zmult_1_r; apply Rinv_le. - lra. - now change 2 with (Z2R 2); apply Z2R_le. - * apply bpow_le; omega. -- intro Hf2'. - unfold midp'. - apply (Rplus_lt_reg_r (/ 2 * ulp beta fexp1 (x - y) - (x - y) - - / 2 * ulp beta fexp2 (x - y))). - 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|]. - apply (Rlt_le_trans _ _ _ Ly). - apply Rle_trans with (bpow (fexp1 (ln_beta (x - y)) - 2)); - [now apply bpow_le|]. - replace (_ - 2)%Z with (fexp1 (ln_beta (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. - rewrite Zmult_1_r; apply Rinv_le; [lra|]. - now change 2 with (Z2R 2); apply Z2R_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. - 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. - rewrite Zmult_1_r. - apply Z2R_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 : - forall (fexp1 fexp2 : Z -> Z), - Valid_exp fexp1 -> Valid_exp fexp2 -> - forall (choice1 choice2 : Z -> bool), - double_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). -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. -destruct (Req_dec y x) as [Hy|Hy]. -- (* y = x *) - rewrite Hy; replace (x - x) with 0 by ring. - rewrite round_0. - + reflexivity. - + 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)) - 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 *) - { 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). } - + 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). -Qed. - -Lemma double_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 -> - 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). -Proof. -intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Nnx Nny Fx Fy. -unfold double_round_eq. -destruct (Req_dec x 0) as [Zx|Nzx]. -- (* x = 0 *) - rewrite Zx; unfold Rminus; rewrite Rplus_0_l. - do 3 rewrite round_N_opp. - rewrite (round_generic beta fexp2). - * reflexivity. - * now apply valid_rnd_N. - * apply (generic_inclusion_ln_beta beta fexp1). - destruct Hexp as (_,(_,(_,Hexp4))). - now intros _; apply Hexp4; omega. - exact Fy. -- (* x <> 0 *) - destruct (Req_dec y 0) as [Zy|Nzy]. - + (* y = 0 *) - rewrite Zy; unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r. - rewrite (round_generic beta fexp2). - * reflexivity. - * now apply valid_rnd_N. - * apply (generic_inclusion_ln_beta beta fexp1). - destruct Hexp as (_,(_,(_,Hexp4))). - now intros _; apply Hexp4; omega. - exact Fx. - + (* y <> 0 *) - assert (Px : 0 < x); [lra|]. - assert (Py : 0 < y); [lra|]. - destruct (Rlt_or_le x y) as [H|H]. - * (* x < y *) - apply Rlt_le in H. - replace (x - y) with (- (y - x)) by ring. - do 3 rewrite round_N_opp. - apply Ropp_eq_compat. - now apply double_round_minus_aux3. - * (* y <= x *) - now apply double_round_minus_aux3. -Qed. - -Lemma double_round_plus : - forall (fexp1 fexp2 : Z -> Z), - Valid_exp fexp1 -> Valid_exp fexp2 -> - forall (choice1 choice2 : Z -> bool), - double_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). -Proof. -intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Fx Fy. -unfold double_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]. - do 3 rewrite round_N_opp. - apply Ropp_eq_compat. - assert (Px : 0 <= - x); [lra|]. - assert (Py : 0 <= - y); [lra|]. - apply generic_format_opp in Fx. - apply generic_format_opp in Fy. - now apply double_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. -- (* 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. -- (* 0 <= x, 0 <= y *) - now apply double_round_plus_aux. -Qed. - -Lemma double_round_minus : - forall (fexp1 fexp2 : Z -> Z), - Valid_exp fexp1 -> Valid_exp fexp2 -> - forall (choice1 choice2 : Z -> bool), - double_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). -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. -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 : - (2 * prec + 1 <= prec')%Z -> - double_round_plus_hyp (FLX_exp prec) (FLX_exp prec'). -Proof. -intros Hprec. -unfold FLX_exp. -unfold double_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 : - 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). -Proof. -intros choice1 choice2 Hprec x y Fx Fy. -apply double_round_plus. -- now apply FLX_exp_valid. -- now apply FLX_exp_valid. -- now apply FLX_double_round_plus_hyp. -- now apply generic_format_FLX. -- now apply generic_format_FLX. -Qed. - -Theorem double_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). -Proof. -intros choice1 choice2 Hprec x y Fx Fy. -apply double_round_minus. -- now apply FLX_exp_valid. -- now apply FLX_exp_valid. -- now apply FLX_double_round_plus_hyp. -- now apply generic_format_FLX. -- now apply generic_format_FLX. -Qed. - -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 : - (emin' <= emin)%Z -> (2 * prec + 1 <= prec')%Z -> - double_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. -- generalize (Zmax_spec (ex + 1 - prec) emin). - generalize (Zmax_spec (ex - prec') emin'). - generalize (Zmax_spec (ey - prec) emin). - omega. -- generalize (Zmax_spec (ex - 1 - prec) emin). - generalize (Zmax_spec (ex - prec') emin'). - generalize (Zmax_spec (ey - prec) emin). - omega. -- generalize (Zmax_spec (ex - prec) emin). - generalize (Zmax_spec (ex - prec') emin'). - generalize (Zmax_spec (ey - prec) emin). - omega. -- unfold Prec_gt_0 in prec_gt_0_. - generalize (Zmax_spec (ex - prec') emin'). - generalize (Zmax_spec (ey - prec) emin). - omega. -Qed. - -Theorem double_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') - choice1 choice2 (x + y). -Proof. -intros choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_plus. -- now apply FLT_exp_valid. -- now apply FLT_exp_valid. -- now apply FLT_double_round_plus_hyp. -- now apply generic_format_FLT. -- now apply generic_format_FLT. -Qed. - -Theorem double_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') - choice1 choice2 (x - y). -Proof. -intros choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_minus. -- now apply FLT_exp_valid. -- now apply FLT_exp_valid. -- now apply FLT_double_round_plus_hyp. -- now apply generic_format_FLT. -- now apply generic_format_FLT. -Qed. - -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 : - (emin' + prec' <= emin + 1)%Z -> (2 * prec + 1 <= prec')%Z -> - double_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. -- destruct (Z.ltb_spec (ex + 1 - prec) emin); - destruct (Z.ltb_spec (ex - prec') emin'); - destruct (Z.ltb_spec (ey - prec) emin); - omega. -- destruct (Z.ltb_spec (ex - 1 - prec) emin); - destruct (Z.ltb_spec (ex - prec') emin'); - destruct (Z.ltb_spec (ey - prec) emin); - omega. -- destruct (Z.ltb_spec (ex - prec) emin); - destruct (Z.ltb_spec (ex - prec') emin'); - destruct (Z.ltb_spec (ey - prec) emin); - omega. -- destruct (Z.ltb_spec (ex - prec') emin'); - destruct (Z.ltb_spec (ey - prec) emin); - omega. -Qed. - -Theorem double_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') - choice1 choice2 (x + y). -Proof. -intros choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_plus. -- now apply FTZ_exp_valid. -- now apply FTZ_exp_valid. -- now apply FTZ_double_round_plus_hyp. -- now apply generic_format_FTZ. -- now apply generic_format_FTZ. -Qed. - -Theorem double_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') - choice1 choice2 (x - y). -Proof. -intros choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_minus. -- now apply FTZ_exp_valid. -- now apply FTZ_exp_valid. -- now apply FTZ_double_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. - -Definition double_round_plus_beta_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 : - * addition is exact in the largest precision (fexp2). *) -Lemma double_round_plus_beta_ge_3_aux0 : - forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> - forall x y, - (0 < y)%R -> (y <= x)%R -> - (fexp1 (ln_beta x) <= ln_beta 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 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); - [| |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. - + 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. - omega. - + destruct (ln_beta_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. - omega. -Qed. - -(* ln_beta y <= fexp1 (ln_beta x) - 1 : double_round_lt_mid applies. *) -Lemma double_round_plus_beta_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 -> - forall x y, - 0 < x -> 0 < y -> - (ln_beta y <= fexp1 (ln_beta x) - 1)%Z -> - generic_format beta fexp1 x -> - double_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]|]. -destruct Hexp as (_,(_,(_,Hexp4))). -assert (Hf2 : (fexp2 (ln_beta x) <= fexp1 (ln_beta x))%Z); - [now apply Hexp4; omega|]. -assert (Bpow3 : bpow (- 1) <= / 3). -{ unfold Fcore_Raux.bpow, Z.pow_pos; simpl. - rewrite Zmult_1_r. - apply Rinv_le; [lra|]. - now change 3 with (Z2R 3); apply Z2R_le. } -assert (P1 : (0 < 1)%Z) by omega. -unfold double_round_eq. -apply double_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|]. -- 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 - 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|]. - 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. - 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 - 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)))); - [now apply bpow_gt_0|]. - rewrite (Rmult_assoc (/ 2)). - rewrite Rmult_minus_distr_r. - bpow_simplify. - apply (Rle_trans _ _ _ Bpow3). - apply Rle_trans with (/ 2 * (2 / 3)); [lra|]. - apply Rmult_le_compat_l; [lra|]. - apply (Rplus_le_reg_r (- 1)); ring_simplify. - replace (_ - _) with (- (/ 3)) by lra. - apply Ropp_le_contravar. - 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 : - (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 -> - 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). -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 *) - 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). -Qed. - -Lemma double_round_plus_beta_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 -> - 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). -Proof. -intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Nnx Nny Fx Fy. -unfold double_round_eq. -destruct (Req_dec x 0) as [Zx|Nzx]. -- (* x = 0 *) - destruct Hexp as (_,(_,(_,Hexp4))). - rewrite Zx; rewrite Rplus_0_l. - rewrite (round_generic beta fexp2). - + reflexivity. - + now apply valid_rnd_N. - + apply (generic_inclusion_ln_beta beta fexp1). - now intros _; apply Hexp4; omega. - exact Fy. -- (* x <> 0 *) - destruct (Req_dec y 0) as [Zy|Nzy]. - + (* y = 0 *) - destruct Hexp as (_,(_,(_,Hexp4))). - rewrite Zy; rewrite Rplus_0_r. - rewrite (round_generic beta fexp2). - * reflexivity. - * now apply valid_rnd_N. - * apply (generic_inclusion_ln_beta beta fexp1). - now intros _; apply Hexp4; omega. - exact Fx. - + (* y <> 0 *) - assert (Px : 0 < x); [lra|]. - assert (Py : 0 < y); [lra|]. - destruct (Rlt_or_le x y) as [H|H]. - * (* 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. -Qed. - -(* fexp1 (ln_beta x) <= ln_beta y : - * substraction is exact in the largest precision (fexp2). *) -Lemma double_round_minus_beta_ge_3_aux0 : - forall (fexp1 fexp2 : Z -> Z), - double_round_plus_beta_ge_3_hyp fexp1 fexp2 -> - forall x y, - 0 < y -> y < x -> - (fexp1 (ln_beta x) <= ln_beta 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|]. - destruct Hor as [Heq|Heqm1]. - + (* ln_beta y = ln_beta x *) - apply (double_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. - * 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 Hexp4. - apply Zle_trans with (ln_beta (x - y)); [omega|]. - now apply ln_beta_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]. - * 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]; - rewrite Lxmy. - * apply Hexp1. - replace (_ + _)%Z with (ln_beta x : Z); [|ring]. - now apply Zle_trans with (ln_beta y). - * apply Hexp1. - now replace (_ + _)%Z with (ln_beta x : Z); [|ring]. -Qed. - -(* ln_beta y <= fexp1 (ln_beta x) - 1, - * fexp1 (ln_beta (x - y)) <= ln_beta y : - * substraction is exact in the largest precision (fexp2). *) -Lemma double_round_minus_beta_ge_3_aux1 : - forall (fexp1 fexp2 : Z -> Z), - Valid_exp fexp1 -> Valid_exp fexp2 -> - double_round_plus_beta_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 -> - 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))). - + 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 : - (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 -> - 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 -> - generic_format beta fexp1 x -> - generic_format beta fexp1 y -> - double_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); - [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 (Bpow3 : bpow (- 1) <= / 3). -{ unfold Fcore_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)). -{ apply Rabs_lt_inv. - apply bpow_ln_beta_gt. } -unfold double_round_eq. -apply double_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]. -- 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 Rle_lt_trans with y; - [now apply double_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 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. - rewrite Zmult_1_r; apply Rinv_le; [lra|]. - now change 2 with (Z2R 2); apply Z2R_le; omega. -- intro Hf2'. - unfold midp'. - apply (Rplus_lt_reg_r (/ 2 * (ulp beta fexp1 (x - y) - - ulp beta fexp2 (x - y)) - (x - y))). - 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|]. - apply (Rlt_le_trans _ _ _ Ly). - apply Rle_trans with (bpow (fexp1 (ln_beta (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))))); - [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. - rewrite Zmult_1_r; apply Rinv_le; [lra|]. - now change 3 with (Z2R 3); apply Z2R_le. - + replace (/ 3) with (/ 2 * (2 / 3)) by field. - apply Rmult_le_compat_l; [lra|]. - apply (Rplus_le_reg_r (- 1)); ring_simplify. - replace (_ - _) with (- / 3) by field. - apply Ropp_le_contravar. - apply Rle_trans with (bpow (- 1)). - * apply bpow_le; omega. - * unfold Fcore_Raux.bpow, Z.pow_pos; simpl. - rewrite Zmult_1_r; apply Rinv_le; [lra|]. - now change 3 with (Z2R 3); apply Z2R_le. -Qed. - -(* double_round_minus_aux{0,1,2} together *) -Lemma double_round_minus_beta_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 -> - 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). -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 (Req_dec y x) as [Hy|Hy]. -- (* y = x *) - rewrite Hy; replace (x - x) with 0 by ring. - rewrite round_0. - + reflexivity. - + 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)) - 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 *) - { 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). } - + 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). -Qed. - -Lemma double_round_minus_beta_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 -> - 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). -Proof. -intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Nnx Nny Fx Fy. -unfold double_round_eq. -destruct (Req_dec x 0) as [Zx|Nzx]. -- (* x = 0 *) - rewrite Zx; unfold Rminus; rewrite Rplus_0_l. - do 3 rewrite round_N_opp. - rewrite (round_generic beta fexp2). - * reflexivity. - * now apply valid_rnd_N. - * apply (generic_inclusion_ln_beta beta fexp1). - destruct Hexp as (_,(_,(_,Hexp4))). - now intros _; apply Hexp4; omega. - exact Fy. -- (* x <> 0 *) - destruct (Req_dec y 0) as [Zy|Nzy]. - + (* y = 0 *) - rewrite Zy; unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r. - rewrite (round_generic beta fexp2). - * reflexivity. - * now apply valid_rnd_N. - * apply (generic_inclusion_ln_beta beta fexp1). - destruct Hexp as (_,(_,(_,Hexp4))). - now intros _; apply Hexp4; omega. - exact Fx. - + (* y <> 0 *) - assert (Px : 0 < x); [lra|]. - assert (Py : 0 < y); [lra|]. - destruct (Rlt_or_le x y) as [H|H]. - * (* x < y *) - apply Rlt_le in H. - 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. - * (* y <= x *) - now apply double_round_minus_beta_ge_3_aux3. -Qed. - -Lemma double_round_plus_beta_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 -> - forall x y, - generic_format beta fexp1 x -> - generic_format beta fexp1 y -> - double_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. -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]. - do 3 rewrite round_N_opp. - apply Ropp_eq_compat. - assert (Px : 0 <= - x); [lra|]. - 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. -- (* 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. -- (* 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. -- (* 0 <= x, 0 <= y *) - now apply double_round_plus_beta_ge_3_aux. -Qed. - -Lemma double_round_minus_beta_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 -> - forall x y, - generic_format beta fexp1 x -> - generic_format beta fexp1 y -> - double_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. -Qed. - -Section Double_round_plus_beta_ge_3_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_beta_ge_3_hyp : - (2 * prec <= prec')%Z -> - double_round_plus_beta_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]]; -intros ex ey; try omega. -unfold Prec_gt_0 in prec_gt_0_. -omega. -Qed. - -Theorem double_round_plus_beta_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). -Proof. -intros Hbeta choice1 choice2 Hprec x y Fx Fy. -apply double_round_plus_beta_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 generic_format_FLX. -- now apply generic_format_FLX. -Qed. - -Theorem double_round_minus_beta_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). -Proof. -intros Hbeta choice1 choice2 Hprec x y Fx Fy. -apply double_round_minus_beta_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 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. - -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_beta_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'). -Proof. -intros Hemin Hprec. -unfold FLT_exp. -unfold double_round_plus_beta_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). - omega. -- generalize (Zmax_spec (ex - 1 - prec) emin). - generalize (Zmax_spec (ex - prec') emin'). - generalize (Zmax_spec (ey - prec) emin). - omega. -- generalize (Zmax_spec (ex - prec) emin). - generalize (Zmax_spec (ex - prec') emin'). - generalize (Zmax_spec (ey - prec) emin). - omega. -- unfold Prec_gt_0 in prec_gt_0_. - generalize (Zmax_spec (ex - prec') emin'). - generalize (Zmax_spec (ey - prec) emin). - omega. -Qed. - -Theorem double_round_plus_beta_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') - choice1 choice2 (x + y). -Proof. -intros Hbeta choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_plus_beta_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 generic_format_FLT. -- now apply generic_format_FLT. -Qed. - -Theorem double_round_minus_beta_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') - choice1 choice2 (x - y). -Proof. -intros Hbeta choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_minus_beta_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 generic_format_FLT. -- now apply generic_format_FLT. -Qed. - -End Double_round_plus_beta_ge_3_FLT. - -Section Double_round_plus_beta_ge_3_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_beta_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'). -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. -- destruct (Z.ltb_spec (ex + 1 - prec) emin); - destruct (Z.ltb_spec (ex - prec') emin'); - destruct (Z.ltb_spec (ey - prec) emin); - omega. -- destruct (Z.ltb_spec (ex - 1 - prec) emin); - destruct (Z.ltb_spec (ex - prec') emin'); - destruct (Z.ltb_spec (ey - prec) emin); - omega. -- destruct (Z.ltb_spec (ex - prec) emin); - destruct (Z.ltb_spec (ex - prec') emin'); - destruct (Z.ltb_spec (ey - prec) emin); - omega. -- destruct (Z.ltb_spec (ex - prec') emin'); - destruct (Z.ltb_spec (ey - prec) emin); - omega. -Qed. - -Theorem double_round_plus_beta_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') - choice1 choice2 (x + y). -Proof. -intros Hbeta choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_plus_beta_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 generic_format_FTZ. -- now apply generic_format_FTZ. -Qed. - -Theorem double_round_minus_beta_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') - choice1 choice2 (x - y). -Proof. -intros Hbeta choice1 choice2 Hemin Hprec x y Fx Fy. -apply double_round_minus_beta_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 generic_format_FTZ. -- now apply generic_format_FTZ. -Qed. - -End Double_round_plus_beta_ge_3_FTZ. - -End Double_round_plus_beta_ge_3. - -End Double_round_plus. - -Lemma double_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 -> - (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. -Proof. -intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hf1. -unfold double_round_eq, midp. -set (rd := round beta fexp1 Zfloor x). -set (u1 := ulp beta fexp1 x). -set (u2 := ulp beta fexp2 x). -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|]. -- (* ~ 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|]. - destruct (Rlt_or_le (x - rd) (/ 2 * (u1 - u2))). - + (* x - rd < / 2 * (u1 - u2) *) - apply double_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. - + (* / 2 * (u1 - u2) <= x - rd *) - { destruct (Rlt_or_le (/ 2 * (u1 + u2)) (x - rd)). - - (* / 2 * (u1 + u2) < x - rd *) - assert (round beta fexp1 Zceil x - x - < / 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. - unfold midp'; lra. - - (* x - rd <= / 2 * (u1 + u2) *) - apply Cmid, Rabs_le; split; lra. } -Qed. - -Section Double_round_sqrt. - -Definition double_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 : - 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. -Proof. -intros x Px. -generalize (ln_beta_sqrt beta x Px). -intro H. -omega. -Qed. - -Lemma double_round_sqrt_aux : - forall fexp1 fexp2 : Z -> Z, - Valid_exp fexp1 -> Valid_exp fexp2 -> - double_round_sqrt_hyp fexp1 fexp2 -> - forall x, - 0 < x -> - (fexp2 (ln_beta (sqrt x)) <= fexp1 (ln_beta (sqrt x)) - 1)%Z -> - generic_format beta fexp1 x -> - / 2 * ulp beta fexp2 (sqrt x) < Rabs (sqrt x - midp fexp1 (sqrt x)). -Proof. -intros fexp1 fexp2 Vfexp1 Vfexp2 Hexp x Px Hf2 Fx. -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 (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. -apply Rnot_ge_lt; intro H; apply Rge_le in H. -assert (Fa : generic_format beta fexp1 a). -{ unfold a. - apply generic_format_round. - - 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)))). -intros Fx Fa. -assert (Nna : 0 <= a). -{ rewrite <- (round_0 beta fexp1 Zfloor). - unfold a; apply round_le. - - exact Vfexp1. - - now apply valid_rnd_DN. - - apply sqrt_pos. } -assert (Phu1 : 0 < / 2 * u1). -{ apply Rmult_lt_0_compat; [lra|apply bpow_gt_0]. } -assert (Phu2 : 0 < / 2 * u2). -{ apply Rmult_lt_0_compat; [lra|apply bpow_gt_0]. } -assert (Pb : 0 < b). -{ unfold b. - rewrite <- (Rmult_0_r (/ 2)). - apply Rmult_lt_compat_l; [lra|]. - apply Rlt_Rminus. - unfold u2, u1. - apply bpow_lt. - omega. } -assert (Pb' : 0 < b'). -{ now unfold b'; rewrite Rmult_plus_distr_l; apply Rplus_lt_0_compat. } -assert (Hr : sqrt x <= a + b'). -{ unfold b'; apply (Rplus_le_reg_r (- / 2 * u1 - a)); ring_simplify. - replace (_ - _) with (sqrt x - (a + / 2 * u1)) by ring. - now apply Rabs_le_inv. } -assert (Hl : a + b <= sqrt x). -{ unfold b; apply (Rplus_le_reg_r (- / 2 * u1 - a)); ring_simplify. - 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|]. - - rewrite <- Hlx. - now apply ln_beta_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]. - assert (H' : 0 <= a + b); [now apply Rlt_le, Rplus_le_lt_0_compat|]. - now apply Rmult_le_compat. } -assert (Hsr : x <= a * a + u1 * a + u2 * a + b' * b'). -{ replace (_ + _) with ((a + b') * (a + b')); [|now unfold b'; field]. - rewrite <- (sqrt_def x); [|now apply Rlt_le]. - assert (H' : 0 <= sqrt x); [now apply sqrt_pos|]. - now apply Rmult_le_compat. } -destruct (Req_dec a 0) as [Za|Nza]. -- (* a = 0 *) - apply (Rlt_irrefl 0). - apply Rlt_le_trans with (b * b); [now apply Rmult_lt_0_compat|]. - apply Rle_trans with x. - + 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)))); - [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 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|]. - rewrite Rmult_1_l; bpow_simplify. - apply Rlt_le_trans with (bpow (2 * fexp1 (ln_beta (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)))); - [|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. -- (* a <> 0 *) - assert (Pa : 0 < a); [lra|]. - assert (Hla : (ln_beta a = ln_beta (sqrt x) :> Z)). - { unfold a; apply ln_beta_DN. - - exact Vfexp1. - - now fold a. } - assert (Hl' : 0 < - (u2 * a) + b * b). - { apply (Rplus_lt_reg_r (u2 * a)); ring_simplify. - unfold b; ring_simplify. - 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 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 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 Rle_trans with (bpow (- 2) * u1 ^ 2). - + unfold pow; rewrite Rmult_1_r. - unfold u1, u2, ulp, canonic_exp; 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. - apply Rinv_le; [lra|]. - change 4 with (Z2R (2 * 2)%Z); apply Z2R_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. - 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))))); - [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))))); - [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]. - 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 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. - rewrite <- ulp_neq_0; trivial. - apply id_p_ulp_le_bpow. - + exact Pa. - + now apply round_DN_pt. - + apply Rle_lt_trans with (sqrt x). - * now apply round_DN_pt. - * apply Rabs_lt_inv. - apply bpow_ln_beta_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. - 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. - rewrite Zmult_1_r. - apply Rinv_le; [lra|]. - change 2 with (Z2R 2); apply Z2R_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. } - 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. - unfold Rminus; rewrite (Rplus_assoc _ _ (b * b)). - now apply Rplus_lt_compat_l. - + now apply Rle_trans with x. -Qed. - - -Lemma double_round_sqrt : - forall fexp1 fexp2 : Z -> Z, - Valid_exp fexp1 -> Valid_exp fexp2 -> - forall (choice1 choice2 : Z -> bool), - double_round_sqrt_hyp fexp1 fexp2 -> - forall x, - generic_format beta fexp1 x -> - double_round_eq fexp1 fexp2 choice1 choice2 (sqrt x). -Proof. -intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x Fx. -unfold double_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). - { 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|]. - rewrite <- (sqrt_def x) at 1; [|lra]. - rewrite <- Rmult_1_r. - apply Rmult_le_compat_l. - + apply sqrt_pos. - + rewrite <- sqrt_1. - now apply sqrt_le_1_alt. - - (* 1 < x *) - generalize ((proj1 (proj2 Hexp)) 1%Z). - replace (_ - 1)%Z with 1%Z by ring. - intro Hexp10. - assert (Hf0 : (fexp1 1 < 1)%Z); [omega|clear Hexp10]. - apply (valid_exp_large fexp1 1); [exact Hf0|]. - apply ln_beta_ge_bpow. - rewrite Zeq_minus; [|reflexivity]. - unfold Fcore_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|]. - - rewrite <- Hlx. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. } - generalize ((proj2 (proj2 Hexp)) (ln_beta (sqrt x)) H). - omega. } - apply double_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). -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 : - (2 * prec + 2 <= prec')%Z -> - double_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. -Qed. - -Theorem double_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). -Proof. -intros choice1 choice2 Hprec x Fx. -apply double_round_sqrt. -- now apply FLX_exp_valid. -- now apply FLX_exp_valid. -- now apply FLX_double_round_sqrt_hyp. -- now apply generic_format_FLX. -Qed. - -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 : - (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'). -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. -- generalize (Zmax_spec (ex - prec) emin). - generalize (Zmax_spec (2 * ex - prec) emin). - omega. -- generalize (Zmax_spec (ex - prec) emin). - generalize (Zmax_spec (2 * ex - 1 - prec) emin). - omega. -- generalize (Zmax_spec (2 * ex - prec) emin). - generalize (Zmax_spec (ex - prec') emin'). - generalize (Zmax_spec (ex - prec) emin). - omega. -Qed. - -Theorem double_round_sqrt_FLT : - forall choice1 choice2, - (emin <= 0)%Z -> - ((emin' <= emin - prec - 2)%Z - \/ (2 * emin' <= emin - 4 * prec - 2)%Z) -> - (2 * prec + 2 <= prec')%Z -> - forall x, - FLT_format beta emin prec x -> - double_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. -- now apply FLT_exp_valid. -- now apply FLT_exp_valid. -- now apply FLT_double_round_sqrt_hyp. -- now apply generic_format_FLT. -Qed. - -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 : - (2 * (emin' + prec') <= emin + prec <= 1)%Z -> - (2 * prec + 2 <= prec')%Z -> - double_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. -- destruct (Z.ltb_spec (ex - prec) emin); - destruct (Z.ltb_spec (2 * ex - prec) emin); - omega. -- destruct (Z.ltb_spec (ex - prec) emin); - destruct (Z.ltb_spec (2 * ex - 1 - prec) emin); - omega. -- intro H. - destruct (Zle_or_lt emin (2 * ex - prec)) as [H'|H']. - + destruct (Z.ltb_spec (ex - prec') emin'); - destruct (Z.ltb_spec (ex - prec) emin); - omega. - + casetype False. - rewrite (Zlt_bool_true _ _ H') in H. - omega. -Qed. - -Theorem double_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') - choice1 choice2 (sqrt x). -Proof. -intros Hbeta choice1 choice2 Hemin Hprec x Fx. -apply double_round_sqrt. -- now apply FTZ_exp_valid. -- now apply FTZ_exp_valid. -- now apply FTZ_double_round_sqrt_hyp. -- now apply generic_format_FTZ. -Qed. - -End Double_round_sqrt_FTZ. - -Section Double_round_sqrt_beta_ge_4. - -Definition double_round_sqrt_beta_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 : - (4 <= beta)%Z -> - forall fexp1 fexp2 : Z -> Z, - Valid_exp fexp1 -> Valid_exp fexp2 -> - double_round_sqrt_beta_ge_4_hyp fexp1 fexp2 -> - forall x, - 0 < x -> - (fexp2 (ln_beta (sqrt x)) <= fexp1 (ln_beta (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 (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. -apply Rnot_ge_lt; intro H; apply Rge_le in H. -assert (Fa : generic_format beta fexp1 a). -{ unfold a. - apply generic_format_round. - - 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)))). -intros Fx Fa. -assert (Nna : 0 <= a). -{ rewrite <- (round_0 beta fexp1 Zfloor). - unfold a; apply round_le. - - exact Vfexp1. - - now apply valid_rnd_DN. - - apply sqrt_pos. } -assert (Phu1 : 0 < / 2 * u1). -{ apply Rmult_lt_0_compat; [lra|apply bpow_gt_0]. } -assert (Phu2 : 0 < / 2 * u2). -{ apply Rmult_lt_0_compat; [lra|apply bpow_gt_0]. } -assert (Pb : 0 < b). -{ unfold b. - rewrite <- (Rmult_0_r (/ 2)). - apply Rmult_lt_compat_l; [lra|]. - apply Rlt_Rminus. - unfold u2, u1, ulp, canonic_exp. - apply bpow_lt. - omega. } -assert (Pb' : 0 < b'). -{ now unfold b'; rewrite Rmult_plus_distr_l; apply Rplus_lt_0_compat. } -assert (Hr : sqrt x <= a + b'). -{ unfold b'; apply (Rplus_le_reg_r (- / 2 * u1 - a)); ring_simplify. - replace (_ - _) with (sqrt x - (a + / 2 * u1)) by ring. - now apply Rabs_le_inv. } -assert (Hl : a + b <= sqrt x). -{ unfold b; apply (Rplus_le_reg_r (- / 2 * u1 - a)); ring_simplify. - 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|]. - - rewrite <- Hlx. - now apply ln_beta_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]. - assert (H' : 0 <= a + b); [now apply Rlt_le, Rplus_le_lt_0_compat|]. - now apply Rmult_le_compat. } -assert (Hsr : x <= a * a + u1 * a + u2 * a + b' * b'). -{ replace (_ + _) with ((a + b') * (a + b')); [|now unfold b'; field]. - rewrite <- (sqrt_def x); [|now apply Rlt_le]. - assert (H' : 0 <= sqrt x); [now apply sqrt_pos|]. - now apply Rmult_le_compat. } -destruct (Req_dec a 0) as [Za|Nza]. -- (* a = 0 *) - apply (Rlt_irrefl 0). - apply Rlt_le_trans with (b * b); [now apply Rmult_lt_0_compat|]. - apply Rle_trans with x. - + 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)))); - [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 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|]. - rewrite Rmult_1_l; bpow_simplify. - apply Rlt_le_trans with (bpow (2 * fexp1 (ln_beta (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)))); - [|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. -- (* a <> 0 *) - assert (Pa : 0 < a); [lra|]. - assert (Hla : (ln_beta a = ln_beta (sqrt x) :> Z)). - { unfold a; apply ln_beta_DN. - - exact Vfexp1. - - now fold a. } - assert (Hl' : 0 < - (u2 * a) + b * b). - { apply (Rplus_lt_reg_r (u2 * a)); ring_simplify. - unfold b; ring_simplify. - 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 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). - + apply Rplus_lt_compat_l. - rewrite <- (Rmult_1_l (ulp _ _ _)). - 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 Rle_trans with (bpow (- 1) * u1 ^ 2). - + unfold pow; rewrite Rmult_1_r. - unfold u1, u2, ulp, canonic_exp; 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. - apply Rinv_le; [lra|]. - now change 4 with (Z2R 4); apply Z2R_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. - 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))))); - [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))))); - [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]. - 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 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. - rewrite <- ulp_neq_0; trivial. - apply id_p_ulp_le_bpow. - + exact Pa. - + now apply round_DN_pt. - + apply Rle_lt_trans with (sqrt x). - * now apply round_DN_pt. - * apply Rabs_lt_inv. - apply bpow_ln_beta_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. - 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. - rewrite Zmult_1_r. - apply Rinv_le; [lra|]. - change 2 with (Z2R 2); apply Z2R_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. } - 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. - unfold Rminus; rewrite (Rplus_assoc _ _ (b * b)). - now apply Rplus_lt_compat_l. - + now apply Rle_trans with x. -Qed. - -Lemma double_round_sqrt_beta_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 -> - forall x, - generic_format beta fexp1 x -> - double_round_eq fexp1 fexp2 choice1 choice2 (sqrt x). -Proof. -intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x Fx. -unfold double_round_eq. -destruct (Rle_or_lt x 0) as [Npx|Px]. -- (* x <= 0 *) - assert (Hs : sqrt x = 0). - { destruct (Req_dec x 0) as [Zx|Nzx]. - - (* x = 0 *) - rewrite Zx. - exact sqrt_0. - - (* x < 0 *) - unfold sqrt. - destruct Rcase_abs. - + reflexivity. - + casetype False; lra. } - rewrite Hs. - rewrite round_0. - + 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). - { 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|]. - rewrite <- (sqrt_def x) at 1; [|lra]. - rewrite <- Rmult_1_r. - apply Rmult_le_compat_l. - + apply sqrt_pos. - + rewrite <- sqrt_1. - now apply sqrt_le_1_alt. - - (* 1 < x *) - generalize ((proj1 (proj2 Hexp)) 1%Z). - replace (_ - 1)%Z with 1%Z by ring. - intro Hexp10. - assert (Hf0 : (fexp1 1 < 1)%Z); [omega|clear Hexp10]. - apply (valid_exp_large fexp1 1); [exact Hf0|]. - apply ln_beta_ge_bpow. - rewrite Zeq_minus; [|reflexivity]. - unfold Fcore_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|]. - - rewrite <- Hlx. - now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. } - generalize ((proj2 (proj2 Hexp)) (ln_beta (sqrt x)) H). - omega. } - apply double_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 - Hexp x Px Hf2 Fx). -Qed. - -Section Double_round_sqrt_beta_ge_4_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_beta_ge_4_hyp : - (2 * prec + 1 <= prec')%Z -> - double_round_sqrt_beta_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. -Qed. - -Theorem double_round_sqrt_beta_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). -Proof. -intros Hbeta choice1 choice2 Hprec x Fx. -apply double_round_sqrt_beta_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 generic_format_FLX. -Qed. - -End Double_round_sqrt_beta_ge_4_FLX. - -Section Double_round_sqrt_beta_ge_4_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_beta_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'). -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. -- generalize (Zmax_spec (ex - prec) emin). - generalize (Zmax_spec (2 * ex - prec) emin). - omega. -- generalize (Zmax_spec (ex - prec) emin). - generalize (Zmax_spec (2 * ex - 1 - prec) emin). - omega. -- generalize (Zmax_spec (2 * ex - prec) emin). - generalize (Zmax_spec (ex - prec') emin'). - generalize (Zmax_spec (ex - prec) emin). - omega. -Qed. - -Theorem double_round_sqrt_beta_ge_4_FLT : - (4 <= beta)%Z -> - forall choice1 choice2, - (emin <= 0)%Z -> - ((emin' <= emin - prec - 1)%Z - \/ (2 * emin' <= emin - 4 * prec)%Z) -> - (2 * prec + 1 <= prec')%Z -> - forall x, - FLT_format beta emin prec x -> - double_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. -- exact Hbeta. -- now apply FLT_exp_valid. -- now apply FLT_exp_valid. -- now apply FLT_double_round_sqrt_beta_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. - -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_beta_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'). -Proof. -intros Hemin Hprec. -unfold FTZ_exp. -unfold Prec_gt_0 in *. -unfold double_round_sqrt_beta_ge_4_hyp; split; [|split]; intros ex. -- destruct (Z.ltb_spec (ex - prec) emin); - destruct (Z.ltb_spec (2 * ex - prec) emin); - omega. -- destruct (Z.ltb_spec (ex - prec) emin); - destruct (Z.ltb_spec (2 * ex - 1 - prec) emin); - omega. -- intro H. - destruct (Zle_or_lt emin (2 * ex - prec)) as [H'|H']. - + destruct (Z.ltb_spec (ex - prec') emin'); - destruct (Z.ltb_spec (ex - prec) emin); - omega. - + casetype False. - rewrite (Zlt_bool_true _ _ H') in H. - omega. -Qed. - -Theorem double_round_sqrt_beta_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') - choice1 choice2 (sqrt x). -Proof. -intros Hbeta choice1 choice2 Hemin Hprec x Fx. -apply double_round_sqrt_beta_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 generic_format_FTZ. -Qed. - -End Double_round_sqrt_beta_ge_4_FTZ. - -End Double_round_sqrt_beta_ge_4. - -End Double_round_sqrt. - -Section Double_round_div. - -Lemma double_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 -> - x = midp fexp1 x -> - double_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 midp. -set (rd := round beta fexp1 Zfloor x). -set (u := ulp beta fexp1 x). -intro H; apply (Rplus_eq_compat_l (- rd)) in H. -ring_simplify in H; revert H. -rewrite Rplus_comm; fold (Rminus x rd). -intro Xmid. -destruct Ebeta as (n,Ebeta). -assert (Hbeta : (2 <= beta)%Z). -{ destruct beta as (beta_val,beta_prop). - now apply Zle_bool_imp_le. } -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)). -assert (Hf : F2R f = x). -{ unfold f, F2R; simpl. - rewrite Z2R_plus. - rewrite Rmult_plus_distr_r. - rewrite Z2R_mult. - rewrite Z2R_Zpower; [|omega]. - unfold canonic_exp 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 Zmult_1_r. - rewrite Ebeta. - rewrite (Z2R_mult 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)). - rewrite Rinv_r; - [rewrite Rmult_1_r|change 0 with (Z2R 0); apply Z2R_neq; omega]. - simpl; fold (canonic_exp beta fexp1 x). - rewrite <- 2!ulp_neq_0; try now apply Rgt_not_eq. - fold u; rewrite Xmid at 2. - apply f_equal2; [|reflexivity]. - rewrite ulp_neq_0; try now apply Rgt_not_eq. - destruct (Req_dec rd 0) as [Zrd|Nzrd]. - - (* rd = 0 *) - rewrite Zrd. - rewrite scaled_mantissa_0. - change 0 with (Z2R 0) at 1; rewrite Zfloor_Z2R. - now rewrite Rmult_0_l. - - (* rd <> 0 *) - assert (Nnrd : 0 <= rd). - { apply round_DN_pt. - - exact Vfexp1. - - apply generic_format_0. - - now apply Rlt_le. } - assert (Prd : 0 < rd); [lra|]. - assert (Lrd : (ln_beta rd = ln_beta x :> Z)). - { apply Zle_antisym. - - apply ln_beta_le; [exact Prd|]. - now apply round_DN_pt. - - apply ln_beta_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. - 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]. - bpow_simplify. - now unfold rd. - + split; [now apply Rle_refl|]. - rewrite Z2R_plus. - simpl; lra. } -apply (generic_format_F2R' _ _ x f Hf). -intros _. -apply Zle_refl. -Qed. - -Lemma double_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. -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. - 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]. -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)); - [reflexivity|split; [|exact H0]|omega]. - apply round_large_pos_ge_pow; [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)). - { 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); - [apply Vfexp1; omega|]. - rewrite Hf11. - apply (Rmult_eq_reg_r (bpow (- fexp1 (ln_beta 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 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. - 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 <- (Zmult_1_r beta) at 1. - apply Zmult_lt_compat_l; omega. -- (* ln_beta x < fexp2 (ln_beta x) *) - casetype False; apply Nzx''. - now apply (round_N_really_small_pos beta _ _ _ (ln_beta x)). -Qed. - -Lemma double_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. -Proof. -intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf1. -unfold double_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. - 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)); - [|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)); - [reflexivity| |omega]. -split. -- apply round_large_pos_ge_pow. - + 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. - 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. - apply Rplus_lt_le_compat; [exact Hx|]. - apply Rabs_le_inv. - now apply error_le_half_ulp. -Qed. - -Lemma double_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 -> - 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 -> - x = midp fexp1 x -> - double_round_eq fexp1 fexp2 choice1 choice2 x) -> - ((fexp1 (ln_beta x) <= ln_beta 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. -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. - + now apply Cz. -- (* ln_beta x > fexp1 (ln_beta x) - 1 *) - assert (H : (fexp1 (ln_beta x) <= ln_beta 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 Clt; [|split]. - + (* x = midp fexp1 x *) - now apply Ceq. - + (* x > midp fexp1 x *) - destruct (Rle_or_lt x (midp fexp1 x + / 2 * u2)) as [Hlt''|Hle'']. - * 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); - [reflexivity|now apply valid_rnd_N|]. - now apply (generic_inclusion_ln_beta 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); - [omega|]. - assert (midp' fexp1 x + / 2 * ulp beta fexp2 x < x); - [|now apply double_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 : - 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). -Proof. -intros x y Px Py. -generalize (ln_beta_div beta x y Px Py). -omega. -Qed. - -Definition double_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 -> - (fexp2 (ex - ey) <= fexp1 ex - ey)%Z) - /\ (forall ex ey, (fexp1 ex < ex)%Z -> (fexp1 ey < ey)%Z -> - (fexp1 (ex - ey + 1) <= ex - ey + 1 + 1)%Z -> - (fexp2 (ex - ey + 1) <= fexp1 ex - ey)%Z) - /\ (forall ex ey, (fexp1 ex < ex)%Z -> (fexp1 ey < ey)%Z -> - (fexp1 (ex - ey) <= ex - ey)%Z -> - (fexp2 (ex - ey) <= fexp1 (ex - ey) - + fexp1 ey - ey)%Z) - /\ (forall ex ey, (fexp1 ex < ex)%Z -> (fexp1 ey < ey)%Z -> - (fexp1 (ex - ey) = ex - ey + 1)%Z -> - (fexp2 (ex - ey) <= ex - ey - ey + fexp1 ey)%Z). - -Lemma double_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 -> - 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). -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)))). -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)))). -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|]. -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))). - + 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)))); - [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. - 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)))); - [now apply bpow_gt_0|]. - bpow_simplify. - rewrite <- Fx. - rewrite bpow_plus. - rewrite <- Rmult_assoc; rewrite <- Fy. - fold p. - apply (Rmult_lt_reg_r (/ y)); [now apply Rinv_0_lt_compat|]. - field_simplify; lra. - + 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)). - * rewrite <- (Rmult_1_l (u2 * _)). - rewrite Rmult_assoc. - { apply Rmult_lt_compat. - - lra. - - now apply Rmult_le_pos; [apply bpow_ge_0|apply Rlt_le]. - - 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; - [now apply Hexp; [| |rewrite <- Hxy]|]. - replace (_ - _ + 1)%Z with ((ln_beta x + 1) - ln_beta y)%Z by ring. - apply Hexp. - { now assert (fexp1 (ln_beta x + 1) <= ln_beta x)%Z; - [apply valid_exp|omega]. } - { assumption. } - replace (_ + 1 - _)%Z with (ln_beta x - ln_beta 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))). - + rewrite Fx at 1; rewrite Fy at 1. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta 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. - 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)))); - [now apply bpow_gt_0|bpow_simplify]. - rewrite <- Fx. - rewrite Zplus_comm; rewrite bpow_plus. - rewrite <- Rmult_assoc; rewrite <- Fy. - fold p. - apply (Rmult_lt_reg_r (/ y)); [now apply Rinv_0_lt_compat|]. - field_simplify; lra. - + 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)). - * rewrite <- (Rmult_1_l (u2 * _)). - rewrite Rmult_assoc. - { apply Rmult_lt_compat. - - lra. - - now apply Rmult_le_pos; [apply bpow_ge_0|apply Rlt_le]. - - 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. -Qed. - -Lemma double_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 -> - 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 -> - ~ (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 (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. -cut (~ (/ 2 * (ulp beta fexp1 (x / y) - ulp beta fexp2 (x / y)) - <= x / y - round beta fexp1 Zfloor (x / y) - < / 2 * ulp beta fexp1 (x / y))). -{ intro H; intro H'; apply H; split. - - apply (Rplus_le_reg_l (round beta fexp1 Zfloor (x / y))). - ring_simplify. - apply H'. - - 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 (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)))). -intros Fx Fy. -intro Hlr. -apply (Rlt_irrefl (/ 2 * (u1 - u2))). -apply (Rle_lt_trans _ _ _ (proj1 Hlr)). -apply (Rplus_lt_reg_r x'); ring_simplify. -apply (Rmult_lt_reg_r y _ _ Py). -unfold Rdiv; rewrite Rmult_assoc. -rewrite Rinv_l; [|now apply Rgt_not_eq]; rewrite Rmult_1_r. -rewrite Rmult_minus_distr_r; rewrite Rmult_plus_distr_r. -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) *) - apply Rle_lt_trans with (2 * x' * y + u1 * y - - bpow (fexp1 (ln_beta (x / y)) - + fexp1 (ln_beta 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)))); - [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. - rewrite (Rmult_comm u1). - unfold x', u1, round, F2R, ulp, scaled_mantissa, canonic_exp; 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. - 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)))); - [now apply bpow_gt_0|bpow_simplify]. - rewrite Rmult_assoc. - rewrite <- Fx. - rewrite (Rmult_plus_distr_r _ _ (Fcore_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. - do 2 rewrite <- (Rmult_assoc (Z2R my)). - rewrite <- Fy. - change (bpow _) with u1. - apply (Rmult_lt_reg_l (/ 2)); [lra|]. - rewrite Rmult_plus_distr_l. - do 4 rewrite <- Rmult_assoc. - rewrite Rinv_l; [|lra]; do 2 rewrite Rmult_1_l. - apply (Rplus_lt_reg_r (- y * x')); ring_simplify. - apply (Rmult_lt_reg_l (/ y)); [now apply Rinv_0_lt_compat|]. - rewrite Rmult_minus_distr_l. - do 3 rewrite <- Rmult_assoc. - rewrite Rinv_l; [|now apply Rgt_not_eq]; do 2 rewrite Rmult_1_l. - now rewrite Rmult_comm. - + apply Rplus_lt_compat_l. - apply Ropp_lt_contravar. - apply Rlt_le_trans with (u2 * bpow (ln_beta 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. - rewrite <- Zplus_assoc; rewrite (Zplus_comm (- _)). - destruct (ln_beta_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. - apply Hexp. - { now assert (fexp1 (ln_beta x + 1) <= ln_beta x)%Z; - [apply valid_exp|omega]. } - { assumption. } - replace (_ + 1 - _)%Z with (ln_beta x - ln_beta 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))). - + rewrite Fx at 1; rewrite Fy at 1 2. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta 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. - rewrite (Rmult_comm u1). - unfold x', u1, round, F2R, ulp, scaled_mantissa, canonic_exp; 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. - 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)))); - [now apply bpow_gt_0|]. - rewrite Rmult_assoc. - rewrite <- Fx. - rewrite (Rmult_plus_distr_r _ _ (Fcore_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. - do 2 rewrite <- (Rmult_assoc (Z2R my)). - rewrite <- Fy. - change (bpow _) with u1. - apply (Rmult_lt_reg_l (/ 2)); [lra|]. - rewrite Rmult_plus_distr_l. - do 4 rewrite <- Rmult_assoc. - rewrite Rinv_l; [|lra]; do 2 rewrite Rmult_1_l. - apply (Rplus_lt_reg_r (- y * x')); ring_simplify. - apply (Rmult_lt_reg_l (/ y)); [now apply Rinv_0_lt_compat|]. - rewrite Rmult_minus_distr_l. - do 3 rewrite <- Rmult_assoc. - rewrite Rinv_l; [|now apply Rgt_not_eq]; do 2 rewrite Rmult_1_l. - now rewrite Rmult_comm. - + apply Rplus_lt_compat_l. - apply Ropp_lt_contravar. - apply Rlt_le_trans with (u2 * bpow (ln_beta 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. - rewrite (Zplus_comm (- _)). - destruct (ln_beta_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; - apply Hexp; try assumption; rewrite <- Hxy; omega. -Qed. - -Lemma double_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 -> - 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 -> - ~ (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|]|]. -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)))). -{ intro H; intro H'; apply H; split. - - apply (Rplus_lt_reg_l (round beta fexp1 Zfloor (x / y))). - ring_simplify. - apply H'. - - 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 (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)))). -intros Fx Fy. -intro Hlr. -apply (Rlt_irrefl (/ 2 * (u1 + u2))). -apply Rlt_le_trans with (x / y - x'); [|now apply Hlr]. -apply (Rplus_lt_reg_r x'); ring_simplify. -apply (Rmult_lt_reg_r y _ _ Py). -unfold Rdiv; rewrite Rmult_assoc. -rewrite Rinv_l; [|now apply Rgt_not_eq]; rewrite Rmult_1_r. -do 2 rewrite Rmult_plus_distr_r. -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)) - + 2 * x' * y). - + apply Rplus_lt_compat_r, Rplus_lt_compat_l. - apply Rlt_le_trans with (u2 * bpow (ln_beta 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. - rewrite <- Zplus_assoc; rewrite (Zplus_comm (- _)). - destruct (ln_beta_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. - apply Hexp. - { now assert (fexp1 (ln_beta x + 1) <= ln_beta x)%Z; - [apply valid_exp|omega]. } - { assumption. } - replace (_ + 1 - _)%Z with (ln_beta x - ln_beta 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)))); - [|now apply eq_sym; rewrite Fy at 1]. - replace (2 * x' * y) with (2 * x' * (Z2R my * bpow (fexp1 (ln_beta y)))); - [|now apply eq_sym; rewrite Fy at 1]. - apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta (x / y)) - - fexp1 (ln_beta 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. - rewrite (Rmult_assoc 2). - rewrite (Rmult_comm x'). - rewrite (Rmult_assoc 2). - unfold x', round, F2R, scaled_mantissa, canonic_exp; 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 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)))); - [now apply bpow_gt_0|]. - rewrite Rmult_plus_distr_r. - rewrite (Rmult_comm _ (Z2R _)). - 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 <- Fx. - apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta (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 (bpow _) with u1. - apply (Rmult_lt_reg_l (/ 2)); [lra|]. - rewrite Rmult_plus_distr_l. - do 4 rewrite <- Rmult_assoc. - rewrite Rinv_l; [|lra]; do 2 rewrite Rmult_1_l. - apply (Rplus_lt_reg_r (- y * x')); ring_simplify. - apply (Rmult_lt_reg_l (/ y)); [now apply Rinv_0_lt_compat|]. - rewrite Rmult_plus_distr_l. - do 3 rewrite <- Rmult_assoc. - rewrite Ropp_mult_distr_r_reverse. - rewrite Ropp_mult_distr_l_reverse. - 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))). - + rewrite Rplus_comm, Rplus_assoc; do 2 apply Rplus_lt_compat_l. - apply Rlt_le_trans with (u2 * bpow (ln_beta 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. - rewrite (Zplus_comm (- _)). - destruct (ln_beta_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)))); - [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. - rewrite (Rmult_comm u1). - unfold x', u1, round, F2R, ulp, scaled_mantissa, canonic_exp; 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. - 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)))); - [now apply bpow_gt_0|]. - rewrite (Rmult_assoc _ (Z2R 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. - do 2 rewrite <- (Rmult_assoc (Z2R my)). - rewrite <- Fy. - change (bpow _) with u1. - apply (Rmult_lt_reg_l (/ 2)); [lra|]. - rewrite Rmult_plus_distr_l. - do 4 rewrite <- Rmult_assoc. - rewrite Rinv_l; [|lra]; do 2 rewrite Rmult_1_l. - apply (Rplus_lt_reg_r (- y * x')); ring_simplify. - apply (Rmult_lt_reg_l (/ y)); [now apply Rinv_0_lt_compat|]. - rewrite Rmult_plus_distr_l. - do 3 rewrite <- Rmult_assoc. - rewrite Ropp_mult_distr_r_reverse. - rewrite Ropp_mult_distr_l_reverse. - rewrite Rinv_l; [|now apply Rgt_not_eq]; do 2 rewrite Rmult_1_l. - rewrite (Rmult_comm (/ y)). - now rewrite (Rplus_comm (- x')). -Qed. - -Lemma double_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 -> - 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). -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. -- 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). -- intros Hf1 Hlxy. - casetype False. - now apply (double_round_div_aux1 fexp1 fexp2 _ _ choice1 choice2 Hexp x y). -- intro H. - apply double_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). -Qed. - -Lemma double_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 -> - forall x y, - y <> 0 -> - generic_format beta fexp1 x -> - generic_format beta fexp1 y -> - double_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. -destruct (Rtotal_order x 0) as [Nx|[Zx|Px]]. -- (* x < 0 *) - destruct (Rtotal_order y 0) as [Ny|[Zy|Py]]. - + (* y < 0 *) - rewrite <- (Ropp_involutive x). - rewrite <- (Ropp_involutive y). - rewrite Ropp_div. - unfold Rdiv; rewrite <- Ropp_inv_permute; [|lra]. - rewrite Ropp_mult_distr_r_reverse. - rewrite Ropp_involutive. - fold ((- x) / (- y)). - apply Ropp_lt_contravar in Nx. - apply Ropp_lt_contravar in Ny. - rewrite Ropp_0 in Nx, Ny. - apply generic_format_opp in Fx. - apply generic_format_opp in Fy. - now apply double_round_div_aux. - + (* y = 0 *) - now casetype False; apply Nzy. - + (* y > 0 *) - rewrite <- (Ropp_involutive x). - rewrite Ropp_div. - do 3 rewrite round_N_opp. - apply Ropp_eq_compat. - apply Ropp_lt_contravar in Nx. - rewrite Ropp_0 in Nx. - apply generic_format_opp in Fx. - now apply double_round_div_aux. -- (* x = 0 *) - rewrite Zx. - unfold Rdiv; rewrite Rmult_0_l. - now rewrite round_0; [|apply valid_rnd_N]. -- (* x > 0 *) - destruct (Rtotal_order y 0) as [Ny|[Zy|Py]]. - + (* y < 0 *) - rewrite <- (Ropp_involutive y). - unfold Rdiv; rewrite <- Ropp_inv_permute; [|lra]. - rewrite Ropp_mult_distr_r_reverse. - do 3 rewrite round_N_opp. - apply Ropp_eq_compat. - apply Ropp_lt_contravar in Ny. - rewrite Ropp_0 in Ny. - apply generic_format_opp in Fy. - now apply double_round_div_aux. - + (* y = 0 *) - now casetype False; apply Nzy. - + (* y > 0 *) - now apply double_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 : - (2 * prec <= prec')%Z -> - double_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. -split; [now intro ex; omega|]. -split; [|split; [|split]]; intros ex ey; omega. -Qed. - -Theorem double_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). -Proof. -intros choice1 choice2 Ebeta Hprec x y Nzy Fx Fy. -apply double_round_div. -- now apply FLX_exp_valid. -- now apply FLX_exp_valid. -- exact Ebeta. -- now apply FLX_double_round_div_hyp. -- exact Nzy. -- now apply generic_format_FLX. -- now apply generic_format_FLX. -Qed. - -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 : - (emin' <= emin - prec - 2)%Z -> - (2 * prec <= prec')%Z -> - double_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. -split; [intro ex|split; [|split; [|split]]; intros ex ey]. -- generalize (Zmax_spec (ex - prec') emin'). - generalize (Zmax_spec (ex - prec) emin). - omega. -- generalize (Zmax_spec (ex - prec) emin). - generalize (Zmax_spec (ey - prec) emin). - generalize (Zmax_spec (ex - ey - prec) emin). - generalize (Zmax_spec (ex - ey - prec') emin'). - omega. -- generalize (Zmax_spec (ex - prec) emin). - generalize (Zmax_spec (ey - prec) emin). - generalize (Zmax_spec (ex - ey + 1 - prec) emin). - generalize (Zmax_spec (ex - ey + 1 - prec') emin'). - omega. -- generalize (Zmax_spec (ex - prec) emin). - generalize (Zmax_spec (ey - prec) emin). - generalize (Zmax_spec (ex - ey - prec) emin). - generalize (Zmax_spec (ex - ey - prec') emin'). - omega. -- generalize (Zmax_spec (ex - prec) emin). - generalize (Zmax_spec (ey - prec) emin). - generalize (Zmax_spec (ex - ey - prec) emin). - generalize (Zmax_spec (ex - ey - prec') emin'). - omega. -Qed. - -Theorem double_round_div_FLT : - forall choice1 choice2, - (exists n, (beta = 2 * n :> Z)%Z) -> - (emin' <= emin - prec - 2)%Z -> - (2 * prec <= prec')%Z -> - 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') - choice1 choice2 (x / y). -Proof. -intros choice1 choice2 Ebeta Hemin Hprec x y Nzy Fx Fy. -apply double_round_div. -- now apply FLT_exp_valid. -- now apply FLT_exp_valid. -- exact Ebeta. -- now apply FLT_double_round_div_hyp. -- exact Nzy. -- now apply generic_format_FLT. -- now apply generic_format_FLT. -Qed. - -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 : - (emin' + prec' <= emin - 1)%Z -> - (2 * prec <= prec')%Z -> - double_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. -split; [intro ex|split; [|split; [|split]]; intros ex ey]. -- destruct (Z.ltb_spec (ex - prec') emin'); - destruct (Z.ltb_spec (ex - prec) emin); - omega. -- destruct (Z.ltb_spec (ex - prec) emin); - destruct (Z.ltb_spec (ey - prec) emin); - destruct (Z.ltb_spec (ex - ey - prec) emin); - destruct (Z.ltb_spec (ex - ey - prec') emin'); - omega. -- destruct (Z.ltb_spec (ex - prec) emin); - destruct (Z.ltb_spec (ey - prec) emin); - destruct (Z.ltb_spec (ex - ey + 1 - prec) emin); - destruct (Z.ltb_spec (ex - ey + 1 - prec') emin'); - omega. -- destruct (Z.ltb_spec (ex - prec) emin); - destruct (Z.ltb_spec (ey - prec) emin); - destruct (Z.ltb_spec (ex - ey - prec) emin); - destruct (Z.ltb_spec (ex - ey - prec') emin'); - omega. -- destruct (Z.ltb_spec (ex - prec) emin); - destruct (Z.ltb_spec (ey - prec) emin); - destruct (Z.ltb_spec (ex - ey - prec) emin); - destruct (Z.ltb_spec (ex - ey - prec') emin'); - omega. -Qed. - -Theorem double_round_div_FTZ : - forall choice1 choice2, - (exists n, (beta = 2 * n :> Z)%Z) -> - (emin' + prec' <= emin - 1)%Z -> - (2 * prec <= prec')%Z -> - 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') - choice1 choice2 (x / y). -Proof. -intros choice1 choice2 Ebeta Hemin Hprec x y Nzy Fx Fy. -apply double_round_div. -- now apply FTZ_exp_valid. -- now apply FTZ_exp_valid. -- exact Ebeta. -- now apply FTZ_double_round_div_hyp. -- exact Nzy. -- now apply generic_format_FTZ. -- now apply generic_format_FTZ. -Qed. - -End Double_round_div_FTZ. - -End Double_round_div. - -End Double_round. diff --git a/flocq/Appli/Fappli_rnd_odd.v b/flocq/Appli/Fappli_rnd_odd.v deleted file mode 100644 index 273c1000..00000000 --- a/flocq/Appli/Fappli_rnd_odd.v +++ /dev/null @@ -1,1022 +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. -*) - -(** * Rounding to odd and its properties, including the equivalence - between rnd_NE and double rounding with rnd_odd and then rnd_NE *) - -Require Import Reals Psatz. -Require Import Fcore. -Require Import Fcalc_ops. - -Definition Zrnd_odd x := match Req_EM_T x (Z2R (Zfloor x)) with - | left _ => Zfloor x - | right _ => match (Zeven (Zfloor x)) with - | true => Zceil x - | false => Zfloor x - end - end. - - - -Global Instance valid_rnd_odd : Valid_rnd Zrnd_odd. -Proof. -split. -(* . *) -intros x y Hxy. -assert (Zfloor x <= Zrnd_odd y)%Z. -(* .. *) -apply Zle_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. -apply Rle_trans with y. -apply Zfloor_lb. -apply Zceil_ub. -now apply Zle_refl. -unfold Zrnd_odd at 1. -(* . *) -destruct (Req_EM_T x (Z2R (Zfloor x))) as [Hx|Hx]. -(* .. *) -apply H. -(* .. *) -case_eq (Zeven (Zfloor x)); intros Hx2. -2: apply H. -unfold Zrnd_odd; destruct (Req_EM_T y (Z2R (Zfloor y))) as [Hy|Hy]. -apply Zceil_glb. -now rewrite <- Hy. -case_eq (Zeven (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. -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. -Qed. - - - -Lemma Zrnd_odd_Zodd: forall x, x <> (Z2R (Zfloor x)) -> - (Zeven (Zrnd_odd x)) = false. -Proof. -intros x Hx; unfold Zrnd_odd. -destruct (Req_EM_T x (Z2R (Zfloor x))) as [H|H]. -now contradict H. -case_eq (Zeven (Zfloor x)). -(* difficult case *) -intros H'. -rewrite Zceil_floor_neq. -rewrite Zeven_plus, H'. -reflexivity. -now apply sym_not_eq. -trivial. -Qed. - - - - -Section Fcore_rnd_odd. - -Variable beta : radix. - -Notation bpow e := (bpow beta e). - -Variable fexp : Z -> Z. - -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). - - -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)). - -Definition Rnd_odd (rnd : R -> R) := - forall x : R, Rnd_odd_pt x (rnd x). - - -Theorem Rnd_odd_pt_sym : 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). -split. -replace f with (-(-f))%R by ring. -now apply generic_format_opp. -destruct H2. -left. -replace f with (-(-f))%R by ring. -rewrite H; ring. -right. -destruct H as (H2,(g,(Hg1,(Hg2,Hg3)))). -split. -destruct H2. -right. -replace f with (-(-f))%R by ring. -replace x with (-(-x))%R by ring. -apply Rnd_DN_UP_pt_sym... -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 generic_format_opp. -exists (Float beta (-Fnum g) (Fexp g)). -split. -rewrite F2R_Zopp. -replace f with (-(-f))%R by ring. -rewrite Hg1; reflexivity. -split. -now apply canonic_opp. -simpl. -now rewrite Zeven_opp. -Qed. - - -Theorem round_odd_opp : - forall x, - (round beta fexp Zrnd_odd (-x) = (- round beta fexp Zrnd_odd x))%R. -Proof. -intros x; unfold round. -rewrite <- F2R_Zopp. -unfold F2R; simpl. -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))). -intros Y1 Y2. -apply eq_Z2R. -now rewrite Z2R_opp, <- Y1, <-Y2. -intros Y1 Y2. -absurd (r=Z2R (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. -ring. -case (Req_EM_T r (Z2R (Zfloor r))). -intros Y1 Y2. -absurd (-r=Z2R (Zfloor (-r)))%R; trivial. -pattern r at 2; rewrite Y1. -rewrite <- Z2R_opp, Zfloor_Z2R. -now rewrite Z2R_opp, <- 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)). -rewrite Zceil_floor_neq. -rewrite Zeven_plus. -destruct (Zeven (Zfloor r)); reflexivity. -now apply sym_not_eq. -rewrite <- (Zeven_opp (Zfloor (- r))). -reflexivity. -apply canonic_exp_opp. -Qed. - - - -Theorem round_odd_pt : - forall x, - Rnd_odd_pt x (round beta fexp Zrnd_odd x). -Proof with auto with typeclass_instances. -cut (forall x : R, (0 < x)%R -> Rnd_odd_pt x (round beta fexp Zrnd_odd x)). -intros H x; case (Rle_or_lt 0 x). -intros H1; destruct H1. -now apply H. -rewrite <- H0. -rewrite round_0... -split. -apply generic_format_0. -now left. -intros Hx; apply Rnd_odd_pt_sym. -rewrite <- round_odd_opp. -apply H. -auto with real. -(* *) -intros x Hxp. -generalize (generic_format_round beta fexp Zrnd_odd x). -set (o:=round beta fexp Zrnd_odd x). -intros Ho. -split. -assumption. -(* *) -case (Req_dec o x); intros Hx. -now left. -right. -assert (o=round beta fexp Zfloor x \/ o=round beta fexp Zceil x). -unfold o, round, F2R;simpl. -case (Zrnd_DN_or_UP Zrnd_odd (scaled_mantissa beta fexp x))... -intros H; rewrite H; now left. -intros H; rewrite H; now right. -split. -destruct H; rewrite H. -left; apply round_DN_pt... -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)))). -intros T. -absurd (o=x); trivial. -apply round_generic... -unfold generic_format, F2R; simpl. -rewrite <- (scaled_mantissa_mult_bpow beta fexp) at 1. -apply f_equal2; trivial; rewrite T at 1. -apply f_equal, sym_eq, Ztrunc_floor. -apply Rmult_le_pos. -now left. -apply bpow_ge_0. -intros L. -case_eq (Zeven (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 (mf := Ztrunc (scaled_mantissa beta fexp f)). -exists (Float beta mf ef). -unfold Fcore_generic_fmt.canonic. -rewrite <- H0. -repeat split; try assumption. -apply trans_eq with (negb (Zeven (Zfloor (scaled_mantissa beta fexp x)))). -2: rewrite H1; reflexivity. -apply trans_eq with (negb (Zeven (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)). -rewrite <- round_0 with beta fexp Zfloor... -apply round_le... -now left. -intros Y. -generalize (DN_UP_parity_generic beta fexp)... -unfold DN_UP_parity_prop. -intros T; apply T with x; clear T. -unfold generic_format. -rewrite <- (scaled_mantissa_mult_bpow beta fexp x) at 1. -unfold F2R; simpl. -apply Rmult_neq_compat_r. -apply Rgt_not_eq, bpow_gt_0. -rewrite Ztrunc_floor. -assumption. -apply Rmult_le_pos. -now left. -apply bpow_ge_0. -unfold Fcore_generic_fmt.canonic. -simpl. -apply sym_eq, canonic_exp_DN... -unfold Fcore_generic_fmt.canonic. -rewrite <- H0; reflexivity. -reflexivity. -apply trans_eq with (round beta fexp Ztrunc (round beta fexp Zceil x)). -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)))). -generalize (DN_UP_parity_generic beta fexp)... -unfold DN_UP_parity_prop. -intros T; apply T with x; clear T. -unfold generic_format. -rewrite <- (scaled_mantissa_mult_bpow beta fexp x) at 1. -unfold F2R; simpl. -apply Rmult_neq_compat_r. -apply Rgt_not_eq, bpow_gt_0. -rewrite Ztrunc_floor. -assumption. -apply Rmult_le_pos. -now left. -apply bpow_ge_0. -apply canonic_0. -unfold Fcore_generic_fmt.canonic. -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)). -unfold round, F2R in Y; simpl in Y; rewrite <- Y. -simpl; ring. -apply Rgt_not_eq, bpow_gt_0. -(* . *) -intros Y. -case (Rle_lt_or_eq_dec 0 (round beta fexp Zfloor x)). -rewrite <- round_0 with beta fexp Zfloor... -apply round_le... -now left. -intros Hrx. -set (ef := canonic_exp beta fexp x). -set (mf := Zfloor (scaled_mantissa beta fexp x)). -exists (Float beta mf ef). -unfold Fcore_generic_fmt.canonic. -repeat split; try assumption. -simpl. -apply trans_eq with (cexp (round beta fexp Zfloor x )). -apply sym_eq, canonic_exp_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)). -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 : - forall x f1 f2 : R, - Rnd_odd_pt x f1 -> Rnd_odd_pt x f2 -> - f1 = f2. -Proof. -intros x f1 f2 (Ff1,H1) (Ff2,H2). -(* *) -case (generic_format_EM beta fexp x); intros L. -apply trans_eq with x. -case H1; try easy. -intros (J,_); case J; intros J'. -apply Rnd_DN_pt_idempotent with format; assumption. -apply Rnd_UP_pt_idempotent with format; assumption. -case H2; try easy. -intros (J,_); case J; intros J'; apply sym_eq. -apply Rnd_DN_pt_idempotent with format; assumption. -apply Rnd_UP_pt_idempotent with format; assumption. -(* *) -destruct H1 as [H1|(H1,H1')]. -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. -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))). -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... -now apply round_DN_pt... -rewrite <- L1; apply Rnd_UP_pt_unicity 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))). -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... -now apply round_DN_pt... -rewrite <- K1; apply Rnd_UP_pt_unicity with (generic_format beta fexp) x; try easy... -now apply round_UP_pt... -apply Rnd_UP_pt_unicity 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. -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. -apply round_odd_pt. -Qed. - - - - -End Fcore_rnd_odd. - -Section Odd_prop_aux. - -Variable beta : radix. -Hypothesis Even_beta: Zeven (radix_val beta)=true. - -Notation bpow e := (bpow beta e). - -Variable fexp : Z -> Z. -Variable fexpe : Z -> Z. - -Context { valid_exp : Valid_exp fexp }. -Context { exists_NE_ : Exists_NE beta fexp }. (* for underflow reason *) -Context { valid_expe : Valid_exp fexpe }. -Context { exists_NE_e : Exists_NE beta fexpe }. (* for defining rounding to odd *) - -Hypothesis fexpe_fexp: forall e, (fexpe e <= fexp e -2)%Z. - - -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)). -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. -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))). -assert (F2R (Float beta - (Fnum g*Z.pow (radix_val beta) (Fexp g - c (ln_beta beta x))) - (c (ln_beta beta x))) = x). -unfold F2R; simpl. -rewrite Z2R_mult, Z2R_Zpower. -rewrite Rmult_assoc, <- bpow_plus. -rewrite <- Hg1; unfold F2R. -apply f_equal, f_equal. -ring. -omega. -split; trivial. -split. -unfold canonic, canonic_exp. -now rewrite H. -simpl. -rewrite Zeven_mult. -rewrite Zeven_Zpower. -rewrite Even_beta. -apply Bool.orb_true_intro. -now right. -omega. -Qed. - - -Variable choice:Z->bool. -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 Hu: Rnd_UP_pt (generic_format beta fexp) x (F2R u). -Hypothesis Cu: canonic beta fexp u. - -Hypothesis xPos: (0 < x)%R. - - -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 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 round_UP_pt... -Qed. - - -Lemma d_ge_0: (0 <= F2R d)%R. -Proof with auto with typeclass_instances. -rewrite d_eq; apply round_ge_generic... -apply generic_format_0. -now left. -Qed. - - - -Lemma ln_beta_d: (0< F2R d)%R -> - (ln_beta beta (F2R d) = ln_beta beta x :>Z). -Proof with auto with typeclass_instances. -intros Y. -rewrite d_eq; apply ln_beta_DN... -now rewrite <- d_eq. -Qed. - - -Lemma Fexp_d: (0 < F2R d)%R -> Fexp d =fexp (ln_beta beta x). -Proof with auto with typeclass_instances. -intros Y. -now rewrite Cd, <- ln_beta_d. -Qed. - - - -Lemma format_bpow_x: (0 < F2R d)%R - -> generic_format beta fexp (bpow (ln_beta 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... -now apply Rgt_not_eq. -apply Hd. -apply ln_beta_le; trivial. -apply Hd. -Qed. - - -Lemma format_bpow_d: (0 < F2R d)%R -> - generic_format beta fexp (bpow (ln_beta beta (F2R d))). -Proof with auto with typeclass_instances. -intros Y; apply generic_format_bpow. -apply valid_exp. -apply ln_beta_generic_gt... -now apply Rgt_not_eq. -now apply generic_format_canonic. -Qed. - - -Lemma d_le_m: (F2R d <= m)%R. -Proof. -assert (F2R d <= F2R u)%R. - apply Rle_trans with x. - apply Hd. - apply Hu. -unfold m. -lra. -Qed. - -Lemma m_le_u: (m <= F2R u)%R. -Proof. -assert (F2R d <= F2R u)%R. - apply Rle_trans with x. - apply Hd. - apply Hu. -unfold m. -lra. -Qed. - -Lemma ln_beta_m: (0 < F2R d)%R -> (ln_beta beta m =ln_beta beta (F2R d) :>Z). -Proof with auto with typeclass_instances. -intros dPos; apply ln_beta_unique_pos. -split. -apply Rle_trans with (F2R d). -destruct (ln_beta beta (F2R d)) as (e,He). -simpl. -rewrite Rabs_right in He. -apply He. -now apply Rgt_not_eq. -apply Rle_ge; now left. -apply d_le_m. -case m_le_u; intros H. -apply Rlt_le_trans with (1:=H). -rewrite u_eq. -apply round_le_generic... -apply generic_format_bpow. -apply valid_exp. -apply ln_beta_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. -apply Rlt_not_le. -destruct (ln_beta beta (F2R d)) as (e,He). -simpl in *; rewrite Rabs_right in He. -apply He. -now apply Rgt_not_eq. -apply Rle_ge; now left. -apply Rle_trans with (round beta fexp Zfloor x). -2: right; apply sym_eq, d_eq. -apply round_ge_generic... -apply generic_format_bpow. -apply valid_exp. -apply ln_beta_generic_gt... -now apply Rgt_not_eq. -now apply generic_format_canonic. -now left. -replace m with (F2R d). -destruct (ln_beta beta (F2R d)) as (e,He). -simpl in *; rewrite Rabs_right in He. -apply He. -now apply Rgt_not_eq. -apply Rle_ge; now left. -unfold m in H |- *. -lra. -Qed. - - -Lemma ln_beta_m_0: (0 = F2R d)%R - -> (ln_beta beta m =ln_beta beta (F2R u)-1:>Z)%Z. -Proof with auto with typeclass_instances. -intros Y. -apply ln_beta_unique_pos. -unfold m; rewrite <- Y, Rplus_0_l. -rewrite u_eq. -destruct (ln_beta 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. -ring_simplify (fexp e + 1 - 1)%Z. -split. -unfold Zminus; rewrite bpow_plus. -unfold Rdiv; apply Rmult_le_compat_l. -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). -specialize (radix_gt_1 beta). -omega. -apply Rlt_le_trans with (bpow (fexp e)*1)%R. -2: right; ring. -unfold Rdiv; apply Rmult_lt_compat_l. -apply bpow_gt_0. -lra. -now apply He, Rgt_not_eq. -apply exp_small_round_0_pos with beta (Zfloor) x... -now apply He, Rgt_not_eq. -now rewrite <- d_eq, Y. -Qed. - - - - - -Lemma u'_eq: (0 < F2R d)%R -> exists f:float beta, F2R f = F2R u /\ (Fexp f = Fexp d)%Z. -Proof with auto with typeclass_instances. -intros Y. -rewrite u_eq; unfold round. -eexists; repeat split. -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. -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. -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. -simpl; field. -apply Rgt_not_eq, Rmult_lt_reg_l with (1 := Rlt_0_2). -rewrite Rmult_0_r, <- (Z2R_mult 2), <-Hb. -apply radix_pos. -apply trans_eq with (-1+Fexp (Fplus beta d u'))%Z. -unfold Fmult. -destruct (Fplus beta d u'); reflexivity. -rewrite Zplus_comm; unfold Zminus; apply f_equal2. -2: reflexivity. -rewrite Fexp_Fplus. -rewrite Z.min_l. -now rewrite Fexp_d. -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. -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. -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. -simpl; field. -apply Rgt_not_eq, Rmult_lt_reg_l with (1 := Rlt_0_2). -rewrite Rmult_0_r, <- (Z2R_mult 2), <-Hb. -apply radix_pos. -apply trans_eq with (-1+Fexp u)%Z. -unfold Fmult. -destruct u; reflexivity. -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. -Proof with auto with typeclass_instances. -intros Y. -assert ((fexp (ln_beta beta (F2R u) - 1) <= fexp (ln_beta beta (F2R u))))%Z. -2: omega. -destruct (ln_beta beta x) as (e,He). -rewrite Rabs_right in He. -2: now left. -assert (e <= fexp e)%Z. -apply exp_small_round_0_pos with beta (Zfloor) x... -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. -ring_simplify (fexp e + 1 - 1)%Z. -replace (fexp (fexp e)) with (fexp e). -case exists_NE_; intros V. -contradict V; rewrite Even_beta; discriminate. -rewrite (proj2 (V e)); omega. -apply sym_eq, valid_exp; omega. -Qed. - -Lemma Fm: generic_format beta fexpe m. -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. -rewrite <- Fexp_d; trivial. -rewrite Cd. -unfold canonic_exp. -generalize (fexpe_fexp (ln_beta 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. -Qed. - - - -Lemma Zm: - exists g : float beta, F2R g = m /\ canonic beta fexpe g /\ Zeven (Fnum g) = true. -Proof with auto with typeclass_instances. -case (d_ge_0); intros Y. -(* *) -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 <- Fexp_d; trivial. -rewrite Cd. -unfold canonic_exp. -generalize (fexpe_fexp (ln_beta 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. -Qed. - - -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). -apply round_DN_pt... -case (Rnd_DN_UP_pt_split _ _ _ _ Hd Hu (round beta fexp Zfloor z)). -apply generic_format_round... -intros Y; apply Rle_antisym; trivial. -apply round_DN_pt... -apply Hd. -apply Hz1. -intros Y; absurd (z < z)%R. -auto with real. -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). -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. -apply Rle_lt_trans with (2:=proj1 Hz1), Rle_trans with (2:=Y). -apply round_UP_pt... -intros Y; apply Rle_antisym; trivial. -apply round_UP_pt... -apply Hu. -apply Hz1. -Qed. - - -Theorem round_odd_prop_pos: - round beta fexp (Znearest choice) (round beta fexpe Zrnd_odd x) = - round beta fexp (Znearest choice) x. -Proof with auto with typeclass_instances. -set (o:=round beta fexpe Zrnd_odd x). -case (generic_format_EM beta fexp x); intros Hx. -replace o with x; trivial. -unfold o; apply sym_eq, round_generic... -now apply generic_format_fexpe_fexp. -assert (K1:(F2R d <= o)%R). -apply round_ge_generic... -apply generic_format_fexpe_fexp, Hd. -apply Hd. -assert (K2:(o <= F2R u)%R). -apply round_le_generic... -apply generic_format_fexpe_fexp, Hu. -apply Hu. -assert (P:(x <> m -> o=m -> (forall P:Prop, P))). -intros Y1 Y2. -assert (H:(Rnd_odd_pt beta fexpe x o)). -apply round_odd_pt... -destruct H as (_,H); destruct H. -absurd (x=m)%R; try trivial. -now rewrite <- Y2, H. -destruct H as (_,(k,(Hk1,(Hk2,Hk3)))). -destruct Zm as (k',(Hk'1,(Hk'2,Hk'3))). -absurd (true=false). -discriminate. -rewrite <- Hk3, <- Hk'3. -apply f_equal, f_equal. -apply canonic_unicity with fexpe... -now rewrite Hk'1, <- Y2. -assert (generic_format beta fexp o -> (forall P:Prop, P)). -intros Y. -assert (H:(Rnd_odd_pt beta fexpe x o)). -apply round_odd_pt... -destruct H as (_,H); destruct H. -absurd (generic_format beta fexp x); trivial. -now rewrite <- H. -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 _). -omega. -absurd (true=false). -discriminate. -rewrite <- Hk3, <- Hk'3. -apply f_equal, f_equal. -apply canonic_unicity with fexpe... -now rewrite Hk'1, <- Hk1. -case K1; clear K1; intros K1. -2: apply H; rewrite <- K1; apply Hd. -case K2; clear K2; intros K2. -2: apply H; rewrite K2; apply Hu. -case (Rle_or_lt x m); intros Y;[destruct Y|idtac]. -(* . *) -apply trans_eq with (F2R d). -apply round_N_eq_DN_pt with (F2R u)... -apply DN_odd_d_aux; split; try left; assumption. -apply UP_odd_d_aux; split; try left; assumption. -assert (o <= (F2R d + F2R u) / 2)%R. -apply round_le_generic... -apply Fm. -now left. -destruct H1; trivial. -apply P. -now apply Rlt_not_eq. -trivial. -apply sym_eq, round_N_eq_DN_pt with (F2R u)... -(* . *) -replace o with x. -reflexivity. -apply sym_eq, round_generic... -rewrite H0; apply Fm. -(* . *) -apply trans_eq with (F2R u). -apply round_N_eq_UP_pt with (F2R d)... -apply DN_odd_d_aux; split; try left; assumption. -apply UP_odd_d_aux; split; try left; assumption. -assert ((F2R d + F2R u) / 2 <= o)%R. -apply round_ge_generic... -apply Fm. -now left. -destruct H0; trivial. -apply P. -now apply Rgt_not_eq. -rewrite <- H0; trivial. -apply sym_eq, round_N_eq_UP_pt with (F2R d)... -Qed. - - -End Odd_prop_aux. - -Section Odd_prop. - -Variable beta : radix. -Hypothesis Even_beta: Zeven (radix_val beta)=true. - -Variable fexp : Z -> Z. -Variable fexpe : Z -> Z. -Variable choice:Z->bool. - -Context { valid_exp : Valid_exp fexp }. -Context { exists_NE_ : Exists_NE beta fexp }. (* for underflow reason *) -Context { valid_expe : Valid_exp fexpe }. -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, - round beta fexp (Znearest choice) (round beta fexpe Zrnd_odd x) = - round beta fexp (Znearest choice) x. -Proof with auto with typeclass_instances. -intros x. -case (total_order_T x 0); intros H; [case H; clear H; intros H | idtac]. -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)). -apply generic_format_round... -destruct (canonizer (round beta fexp Zceil (-x))) as (u,(Hu1,Hu2)). -apply generic_format_round... -apply round_odd_prop_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)). -apply generic_format_round... -destruct (canonizer (round beta fexp Zceil x)) as (u,(Hu1,Hu2)). -apply generic_format_round... -apply round_odd_prop_pos with d u... -rewrite <- Hd1; apply round_DN_pt... -rewrite <- Hu1; apply round_UP_pt... -Qed. - - -End Odd_prop. |