From 0f919eb26c68d3882e612a1b3a9df45bee6d3624 Mon Sep 17 00:00:00 2001 From: Guillaume Melquiond Date: Wed, 13 Feb 2019 18:53:17 +0100 Subject: Upgrade embedded version of Flocq to 3.1. Main changes to CompCert outside of Flocq are as follows: - Minimal supported version of Coq is now 8.7, due to Flocq requirements. - Most modifications are due to Z2R being dropped in favor of IZR and to the way Flocq now handles NaNs. - CompCert now correctly handles NaNs for the Risc-V architecture (hopefully). --- flocq/Prop/Div_sqrt_error.v | 872 +++++++ flocq/Prop/Double_rounding.v | 4545 +++++++++++++++++++++++++++++++++++++ flocq/Prop/Fprop_Sterbenz.v | 169 -- flocq/Prop/Fprop_div_sqrt_error.v | 300 --- flocq/Prop/Fprop_mult_error.v | 236 -- flocq/Prop/Fprop_plus_error.v | 538 ----- flocq/Prop/Fprop_relative.v | 782 ------- flocq/Prop/Mult_error.v | 335 +++ flocq/Prop/Plus_error.v | 606 +++++ flocq/Prop/Relative.v | 983 ++++++++ flocq/Prop/Round_odd.v | 1220 ++++++++++ flocq/Prop/Sterbenz.v | 173 ++ 12 files changed, 8734 insertions(+), 2025 deletions(-) create mode 100644 flocq/Prop/Div_sqrt_error.v create mode 100644 flocq/Prop/Double_rounding.v delete mode 100644 flocq/Prop/Fprop_Sterbenz.v delete mode 100644 flocq/Prop/Fprop_div_sqrt_error.v delete mode 100644 flocq/Prop/Fprop_mult_error.v delete mode 100644 flocq/Prop/Fprop_plus_error.v delete mode 100644 flocq/Prop/Fprop_relative.v create mode 100644 flocq/Prop/Mult_error.v create mode 100644 flocq/Prop/Plus_error.v create mode 100644 flocq/Prop/Relative.v create mode 100644 flocq/Prop/Round_odd.v create mode 100644 flocq/Prop/Sterbenz.v (limited to 'flocq/Prop') diff --git a/flocq/Prop/Div_sqrt_error.v b/flocq/Prop/Div_sqrt_error.v new file mode 100644 index 00000000..76c7af95 --- /dev/null +++ b/flocq/Prop/Div_sqrt_error.v @@ -0,0 +1,872 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2010-2018 Sylvie Boldo +#
# +Copyright (C) 2010-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +(** * Remainder of the division and square root are in the FLX format *) + +Require Import Psatz. +Require Import Core Operations Relative Sterbenz Mult_error. + +Section Fprop_divsqrt_error. + +Variable beta : radix. +Notation bpow e := (bpow beta e). + +Variable prec : Z. + +Lemma generic_format_plus_prec : + forall fexp, (forall e, (fexp e <= e - prec)%Z) -> + forall x y (fx fy: float beta), + (x = F2R fx)%R -> (y = F2R fy)%R -> (Rabs (x+y) < bpow (prec+Fexp fx))%R -> + (Rabs (x+y) < bpow (prec+Fexp fy))%R -> + generic_format beta fexp (x+y)%R. +Proof. +intros fexp Hfexp x y fx fy Hx Hy H1 H2. +case (Req_dec (x+y) 0); intros H. +rewrite H; apply generic_format_0. +rewrite Hx, Hy, <- F2R_plus. +apply generic_format_F2R. +intros _. +case_eq (Fplus fx fy). +intros mz ez Hz. +rewrite <- Hz. +apply Z.le_trans with (Z.min (Fexp fx) (Fexp fy)). +rewrite F2R_plus, <- Hx, <- Hy. +unfold cexp. +apply Z.le_trans with (1:=Hfexp _). +apply Zplus_le_reg_l with prec; ring_simplify. +apply mag_le_bpow with (1 := H). +now apply Z.min_case. +rewrite <- Fexp_Fplus, Hz. +apply Z.le_refl. +Qed. + +Context { prec_gt_0_ : Prec_gt_0 prec }. + +Notation format := (generic_format beta (FLX_exp prec)). +Notation cexp := (cexp beta (FLX_exp prec)). + +Variable choice : Z -> bool. + + +(** Remainder of the division in FLX *) +Theorem div_error_FLX : + forall rnd { Zrnd : Valid_rnd rnd } x y, + format x -> format y -> + format (x - round beta (FLX_exp prec) rnd (x/y) * y)%R. +Proof with auto with typeclass_instances. +intros rnd Zrnd x y Hx Hy. +destruct (Req_dec y 0) as [Zy|Zy]. +now rewrite Zy, Rmult_0_r, Rminus_0_r. +destruct (Req_dec (round beta (FLX_exp prec) rnd (x/y)) 0) as [Hr|Hr]. +rewrite Hr; ring_simplify (x-0*y)%R; assumption. +assert (Zx: x <> R0). +contradict Hr. +rewrite Hr. +unfold Rdiv. +now rewrite Rmult_0_l, round_0. +destruct (canonical_generic_format _ _ x Hx) as (fx,(Hx1,Hx2)). +destruct (canonical_generic_format _ _ y Hy) as (fy,(Hy1,Hy2)). +destruct (canonical_generic_format beta (FLX_exp prec) (round beta (FLX_exp prec) rnd (x / y))) as (fr,(Hr1,Hr2)). +apply generic_format_round... +unfold Rminus; apply generic_format_plus_prec with fx (Fopp (Fmult fr fy)); trivial. +intros e; apply Z.le_refl. +now rewrite F2R_opp, F2R_mult, <- Hr1, <- Hy1. +(* *) +destruct (relative_error_FLX_ex beta prec (prec_gt_0 prec) rnd (x / y)%R) as (eps,(Heps1,Heps2)). +rewrite Heps2. +rewrite <- Rabs_Ropp. +replace (-(x + - (x / y * (1 + eps) * y)))%R with (x * eps)%R by now field. +rewrite Rabs_mult. +apply Rlt_le_trans with (Rabs x * 1)%R. +apply Rmult_lt_compat_l. +now apply Rabs_pos_lt. +apply Rlt_le_trans with (1 := Heps1). +change 1%R with (bpow 0). +apply bpow_le. +generalize (prec_gt_0 prec). +clear ; omega. +rewrite Rmult_1_r. +rewrite Hx2, <- Hx1. +unfold cexp. +destruct (mag beta x) as (ex, Hex). +simpl. +specialize (Hex Zx). +apply Rlt_le. +apply Rlt_le_trans with (1 := proj2 Hex). +apply bpow_le. +unfold FLX_exp. +ring_simplify. +apply Z.le_refl. +(* *) +replace (Fexp (Fopp (Fmult fr fy))) with (Fexp fr + Fexp fy)%Z. +2: unfold Fopp, Fmult; destruct fr; destruct fy; now simpl. +replace (x + - (round beta (FLX_exp prec) rnd (x / y) * y))%R with + (y * (-(round beta (FLX_exp prec) rnd (x / y) - x/y)))%R. +2: field; assumption. +rewrite Rabs_mult. +apply Rlt_le_trans with (Rabs y * bpow (Fexp fr))%R. +apply Rmult_lt_compat_l. +now apply Rabs_pos_lt. +rewrite Rabs_Ropp. +replace (bpow (Fexp fr)) with (ulp beta (FLX_exp prec) (F2R fr)). +rewrite <- Hr1. +apply error_lt_ulp_round... +apply Rmult_integral_contrapositive_currified; try apply Rinv_neq_0_compat; assumption. +rewrite ulp_neq_0. +2: now rewrite <- Hr1. +apply f_equal. +now rewrite Hr2, <- Hr1. +replace (prec+(Fexp fr+Fexp fy))%Z with ((prec+Fexp fy)+Fexp fr)%Z by ring. +rewrite bpow_plus. +apply Rmult_le_compat_r. +apply bpow_ge_0. +rewrite Hy2, <- Hy1 ; unfold cexp, FLX_exp. +ring_simplify (prec + (mag beta y - prec))%Z. +destruct (mag beta y); simpl. +left; now apply a. +Qed. + +(** Remainder of the square in FLX (with p>1) and rounding to nearest *) +Variable Hp1 : Z.lt 1 prec. + +Theorem sqrt_error_FLX_N : + forall x, format x -> + format (x - Rsqr (round beta (FLX_exp prec) (Znearest choice) (sqrt x)))%R. +Proof with auto with typeclass_instances. +intros x Hx. +destruct (total_order_T x 0) as [[Hxz|Hxz]|Hxz]. +unfold sqrt. +destruct (Rcase_abs x). +rewrite round_0... +unfold Rsqr. +now rewrite Rmult_0_l, Rminus_0_r. +elim (Rlt_irrefl 0). +now apply Rgt_ge_trans with x. +rewrite Hxz, sqrt_0, round_0... +unfold Rsqr. +rewrite Rmult_0_l, Rminus_0_r. +apply generic_format_0. +case (Req_dec (round beta (FLX_exp prec) (Znearest choice) (sqrt x)) 0); intros Hr. +rewrite Hr; unfold Rsqr; ring_simplify (x-0*0)%R; assumption. +destruct (canonical_generic_format _ _ x Hx) as (fx,(Hx1,Hx2)). +destruct (canonical_generic_format beta (FLX_exp prec) (round beta (FLX_exp prec) (Znearest choice) (sqrt x))) as (fr,(Hr1,Hr2)). +apply generic_format_round... +unfold Rminus; apply generic_format_plus_prec with fx (Fopp (Fmult fr fr)); trivial. +intros e; apply Z.le_refl. +unfold Rsqr; now rewrite F2R_opp,F2R_mult, <- Hr1. +(* *) +apply Rle_lt_trans with x. +apply Rabs_minus_le. +apply Rle_0_sqr. +destruct (relative_error_N_FLX_ex beta prec (prec_gt_0 prec) choice (sqrt x)) as (eps,(Heps1,Heps2)). +rewrite Heps2. +rewrite Rsqr_mult, Rsqr_sqrt, Rmult_comm. 2: now apply Rlt_le. +apply Rmult_le_compat_r. +now apply Rlt_le. +apply Rle_trans with (5²/4²)%R. +rewrite <- Rsqr_div. +apply Rsqr_le_abs_1. +apply Rle_trans with (1 := Rabs_triang _ _). +rewrite Rabs_R1. +apply Rplus_le_reg_l with (-1)%R. +replace (-1 + (1 + Rabs eps))%R with (Rabs eps) by ring. +apply Rle_trans with (1 := Heps1). +rewrite Rabs_pos_eq. +apply Rmult_le_reg_l with 2%R. +now apply IZR_lt. +rewrite <- Rmult_assoc, Rinv_r, Rmult_1_l. +apply Rle_trans with (bpow (-1)). +apply bpow_le. +omega. +replace (2 * (-1 + 5 / 4))%R with (/2)%R by field. +apply Rinv_le. +now apply IZR_lt. +apply IZR_le. +unfold Zpower_pos. simpl. +rewrite Zmult_1_r. +apply Zle_bool_imp_le. +apply beta. +now apply IZR_neq. +unfold Rdiv. +apply Rmult_le_pos. +now apply IZR_le. +apply Rlt_le. +apply Rinv_0_lt_compat. +now apply IZR_lt. +now apply IZR_neq. +unfold Rsqr. +replace (5 * 5 / (4 * 4))%R with (25 * /16)%R by field. +apply Rmult_le_reg_r with 16%R. +now apply IZR_lt. +rewrite Rmult_assoc, Rinv_l, Rmult_1_r. +now apply (IZR_le _ 32). +now apply IZR_neq. +rewrite Hx2, <- Hx1; unfold cexp, FLX_exp. +ring_simplify (prec + (mag beta x - prec))%Z. +destruct (mag beta x); simpl. +rewrite <- (Rabs_right x). +apply a. +now apply Rgt_not_eq. +now apply Rgt_ge. +(* *) +replace (Fexp (Fopp (Fmult fr fr))) with (Fexp fr + Fexp fr)%Z. +2: unfold Fopp, Fmult; destruct fr; now simpl. +rewrite Hr1. +replace (x + - Rsqr (F2R fr))%R with (-((F2R fr - sqrt x)*(F2R fr + sqrt x)))%R. +2: rewrite <- (sqrt_sqrt x) at 3; auto. +2: unfold Rsqr; ring. +rewrite Rabs_Ropp, Rabs_mult. +apply Rle_lt_trans with ((/2*bpow (Fexp fr))* Rabs (F2R fr + sqrt x))%R. +apply Rmult_le_compat_r. +apply Rabs_pos. +apply Rle_trans with (/2*ulp beta (FLX_exp prec) (F2R fr))%R. +rewrite <- Hr1. +apply error_le_half_ulp_round... +right; rewrite ulp_neq_0. +2: now rewrite <- Hr1. +apply f_equal. +rewrite Hr2, <- Hr1; trivial. +rewrite Rmult_assoc, Rmult_comm. +replace (prec+(Fexp fr+Fexp fr))%Z with (Fexp fr + (prec+Fexp fr))%Z by ring. +rewrite bpow_plus, Rmult_assoc. +apply Rmult_lt_compat_l. +apply bpow_gt_0. +apply Rmult_lt_reg_l with (1 := Rlt_0_2). +apply Rle_lt_trans with (Rabs (F2R fr + sqrt x)). +right; field. +apply Rle_lt_trans with (1:=Rabs_triang _ _). +(* . *) +assert (Rabs (F2R fr) < bpow (prec + Fexp fr))%R. +rewrite Hr2. +unfold cexp, FLX_exp. +ring_simplify (prec + (mag beta (F2R fr) - prec))%Z. +destruct (mag beta (F2R fr)); simpl. +apply a. +rewrite <- Hr1; auto. +(* . *) +apply Rlt_le_trans with (bpow (prec + Fexp fr)+ Rabs (sqrt x))%R. +now apply Rplus_lt_compat_r. +(* . *) +replace (2 * bpow (prec + Fexp fr))%R with (bpow (prec + Fexp fr) + bpow (prec + Fexp fr))%R by ring. +apply Rplus_le_compat_l. +assert (sqrt x <> 0)%R. +apply Rgt_not_eq. +now apply sqrt_lt_R0. +destruct (mag beta (sqrt x)) as (es,Es). +specialize (Es H0). +apply Rle_trans with (bpow es). +now apply Rlt_le. +apply bpow_le. +case (Zle_or_lt es (prec + Fexp fr)) ; trivial. +intros H1. +absurd (Rabs (F2R fr) < bpow (es - 1))%R. +apply Rle_not_lt. +rewrite <- Hr1. +apply abs_round_ge_generic... +apply generic_format_bpow. +unfold FLX_exp; omega. +apply Es. +apply Rlt_le_trans with (1:=H). +apply bpow_le. +omega. +now apply Rlt_le. +Qed. + +Lemma sqrt_error_N_FLX_aux1 x (Fx : format x) (Px : (0 < x)%R) : + exists (mu : R) (e : Z), (format mu /\ x = mu * bpow (2 * e) :> R + /\ 1 <= mu < bpow 2)%R. +Proof. +set (e := ((mag beta x - 1) / 2)%Z). +set (mu := (x * bpow (-2 * e)%Z)%R). +assert (Hbe : (bpow (-2 * e) * bpow (2 * e) = 1)%R). +{ now rewrite <- bpow_plus; case e; simpl; [reflexivity| |]; intro p; + rewrite Z.pos_sub_diag. } +assert (Fmu : format mu); [now apply mult_bpow_exact_FLX|]. +exists mu, e; split; [exact Fmu|split; [|split]]. +{ set (e2 := (2 * e)%Z); simpl; unfold mu; rewrite Rmult_assoc. + now unfold e2; rewrite Hbe, Rmult_1_r. } +{ apply (Rmult_le_reg_r (bpow (2 * e))). + { apply bpow_gt_0. } + rewrite Rmult_1_l; set (e2 := (2 * e)%Z); simpl; unfold mu. + unfold e2; rewrite Rmult_assoc, Hbe, Rmult_1_r. + apply (Rle_trans _ (bpow (mag beta x - 1))). + { now apply bpow_le; unfold e; apply Z_mult_div_ge. } + set (l := mag _ _); rewrite <- (Rabs_pos_eq _ (Rlt_le _ _ Px)). + unfold l; apply bpow_mag_le. + intro Hx; revert Px; rewrite Hx; apply Rlt_irrefl. } +simpl; unfold mu; change (IZR _) with (bpow 2). +apply (Rmult_lt_reg_r (bpow (2 * e))); [now apply bpow_gt_0|]. +rewrite Rmult_assoc, Hbe, Rmult_1_r. +apply (Rlt_le_trans _ (bpow (mag beta x))). +{ rewrite <- (Rabs_pos_eq _ (Rlt_le _ _ Px)) at 1; apply bpow_mag_gt. } +rewrite <- bpow_plus; apply bpow_le; unfold e; set (mxm1 := (_ - 1)%Z). +replace (_ * _)%Z with (2 * (mxm1 / 2) + mxm1 mod 2 - mxm1 mod 2)%Z by ring. +rewrite <- Z.div_mod; [|now simpl]. +apply (Zplus_le_reg_r _ _ (mxm1 mod 2 - mag beta x)%Z). +unfold mxm1; destruct (Z.mod_bound_or (mag beta x - 1) 2); omega. +Qed. + +Notation u_ro := (u_ro beta prec). + +Lemma sqrt_error_N_FLX_aux2 x (Fx : format x) : + (1 <= x)%R -> + (x = 1 :> R \/ x = 1 + 2 * u_ro :> R \/ 1 + 4 * u_ro <= x)%R. +Proof. +intro HxGe1. +assert (Pu_ro : (0 <= u_ro)%R); [apply Rmult_le_pos; [lra|apply bpow_ge_0]|]. +destruct (Rle_or_lt x 1) as [HxLe1|HxGt1]; [now left; apply Rle_antisym|right]. +assert (F1 : format 1); [now apply generic_format_FLX_1|]. +assert (H2eps : (2 * u_ro = bpow (-prec + 1))%R). +{ unfold u_ro; rewrite bpow_plus; field. } +assert (HmuGe1p2eps : (1 + 2 * u_ro <= x)%R). +{ rewrite H2eps, <- succ_FLX_1. + now apply succ_le_lt; [now apply FLX_exp_valid| | |]. } +destruct (Rle_or_lt x (1 + 2 * u_ro)) as [HxLe1p2eps|HxGt1p2eps]; + [now left; apply Rle_antisym|right]. +assert (Hulp1p2eps : (ulp beta (FLX_exp prec) (1 + 2 * u_ro) = 2 * u_ro)%R). +{ destruct (ulp_succ_pos _ _ _ F1 Rlt_0_1) as [Hsucc|Hsucc]. + { now rewrite H2eps, <- succ_FLX_1, <- ulp_FLX_1. } + exfalso; revert Hsucc; apply Rlt_not_eq. + rewrite succ_FLX_1, mag_1, bpow_1, <- H2eps; simpl. + apply (Rlt_le_trans _ 2); [apply Rplus_lt_compat_l|]. + { unfold u_ro; rewrite <-Rmult_assoc, Rinv_r, Rmult_1_l; [|lra]. + change R1 with (bpow 0); apply bpow_lt; omega. } + apply IZR_le, Zle_bool_imp_le, radix_prop. } +assert (Hsucc1p2eps : + (succ beta (FLX_exp prec) (1 + 2 * u_ro) = 1 + 4 * u_ro)%R). +{ unfold succ; rewrite Rle_bool_true; [rewrite Hulp1p2eps; ring|]. + apply Rplus_le_le_0_compat; lra. } +rewrite <- Hsucc1p2eps. +apply succ_le_lt; [now apply FLX_exp_valid| |exact Fx|now simpl]. +rewrite H2eps, <- succ_FLX_1. +now apply generic_format_succ; [apply FLX_exp_valid|]. +Qed. + +Lemma sqrt_error_N_FLX_aux3 : + (u_ro / sqrt (1 + 4 * u_ro) <= 1 - 1 / sqrt (1 + 2 * u_ro))%R. +Proof. +assert (Pu_ro : (0 <= u_ro)%R); [apply Rmult_le_pos; [lra|apply bpow_ge_0]|]. +unfold Rdiv; apply (Rplus_le_reg_r (/ sqrt (1 + 2 * u_ro))); ring_simplify. +apply (Rmult_le_reg_r (sqrt (1 + 4 * u_ro) * sqrt (1 + 2 * u_ro))). +{ apply Rmult_lt_0_compat; apply sqrt_lt_R0; lra. } +field_simplify; [|split; apply Rgt_not_eq, Rlt_gt, sqrt_lt_R0; lra]. +unfold Rdiv; rewrite Rinv_1, !Rmult_1_r. +apply Rsqr_incr_0_var; [|now apply Rmult_le_pos; apply sqrt_pos]. +rewrite <-sqrt_mult; [|lra|lra]. +rewrite Rsqr_sqrt; [|apply Rmult_le_pos; lra]. +unfold Rsqr; ring_simplify; unfold pow; rewrite !Rmult_1_r. +rewrite !sqrt_def; [|lra|lra]. +apply (Rplus_le_reg_r (-u_ro * u_ro - 1 -4 * u_ro - 2 * u_ro ^ 3)). +ring_simplify; apply Rsqr_incr_0_var. +{ unfold Rsqr; ring_simplify. + unfold pow; rewrite !Rmult_1_r, !sqrt_def; [|lra|lra]. + apply (Rplus_le_reg_r (-32 * u_ro ^ 4 - 24 * u_ro ^ 3 - 4 * u_ro ^ 2)). + ring_simplify. + replace (_ + _)%R + with (((4 * u_ro ^ 2 - 28 * u_ro + 9) * u_ro + 4) * u_ro ^ 3)%R by ring. + apply Rmult_le_pos; [|now apply pow_le]. + assert (Heps_le_half : (u_ro <= 1 / 2)%R). + { unfold u_ro, Rdiv; rewrite Rmult_comm; apply Rmult_le_compat_r; [lra|]. + change 1%R with (bpow 0); apply bpow_le; omega. } + apply (Rle_trans _ (-8 * u_ro + 4)); [lra|]. + apply Rplus_le_compat_r, Rmult_le_compat_r; [apply Pu_ro|]. + now assert (H : (0 <= u_ro ^ 2)%R); [apply pow2_ge_0|lra]. } +assert (H : (u_ro ^ 3 <= u_ro ^ 2)%R). +{ unfold pow; rewrite <-!Rmult_assoc, Rmult_1_r. + apply Rmult_le_compat_l; [now apply Rmult_le_pos; apply Pu_ro|]. + now apply Rlt_le, u_ro_lt_1. } +now assert (H' : (0 <= u_ro ^ 2)%R); [apply pow2_ge_0|lra]. +Qed. + +Lemma om1ds1p2u_ro_pos : (0 <= 1 - 1 / sqrt (1 + 2 * u_ro))%R. +Proof. +unfold Rdiv; rewrite Rmult_1_l, <-Rinv_1 at 1. +apply Rle_0_minus, Rinv_le; [lra|]. +rewrite <- sqrt_1 at 1; apply sqrt_le_1_alt. +assert (H := u_ro_pos beta prec); lra. +Qed. + +Lemma om1ds1p2u_ro_le_u_rod1pu_ro : + (1 - 1 / sqrt (1 + 2 * u_ro) <= u_ro / (1 + u_ro))%R. +Proof. +assert (Pu_ro := u_ro_pos beta prec). +apply (Rmult_le_reg_r (sqrt (1 + 2 * u_ro) * (1 + u_ro))). +{ apply Rmult_lt_0_compat; [apply sqrt_lt_R0|]; lra. } +field_simplify; [|lra|intro H; apply sqrt_eq_0 in H; lra]. +unfold Rdiv, Rminus; rewrite Rinv_1, !Rmult_1_r, !Rplus_assoc. +rewrite <-(Rplus_0_r (sqrt _ * _)) at 2; apply Rplus_le_compat_l. +apply (Rplus_le_reg_r (1 + u_ro)); ring_simplify. +rewrite <-(sqrt_square (_ + 1)); [|lra]; apply sqrt_le_1_alt. +assert (H : (0 <= u_ro * u_ro)%R); [apply Rmult_le_pos|]; lra. +Qed. + +Lemma s1p2u_rom1_pos : (0 <= sqrt (1 + 2 * u_ro) - 1)%R. +apply (Rplus_le_reg_r 1); ring_simplify. +rewrite <-sqrt_1 at 1; apply sqrt_le_1_alt. +assert (H := u_ro_pos beta prec); lra. +Qed. + +Theorem sqrt_error_N_FLX x (Fx : format x) : + (Rabs (round beta (FLX_exp prec) (Znearest choice) (sqrt x) - sqrt x) + <= (1 - 1 / sqrt (1 + 2 * u_ro)) * Rabs (sqrt x))%R. +Proof. +assert (Peps := u_ro_pos beta prec). +assert (Peps' : (0 < u_ro)%R). +{ unfold u_ro; apply Rmult_lt_0_compat; [lra|apply bpow_gt_0]. } +assert (Pb := om1ds1p2u_ro_pos). +assert (Pb' := s1p2u_rom1_pos). +destruct (Rle_or_lt x 0) as [Nx|Px]. +{ rewrite (sqrt_neg _ Nx), round_0, Rabs_R0, Rmult_0_r; [|apply valid_rnd_N]. + now unfold Rminus; rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0; right. } +destruct (sqrt_error_N_FLX_aux1 _ Fx Px) + as (mu, (e, (Fmu, (Hmu, (HmuGe1, HmuLtsqradix))))). +pose (t := sqrt x). +set (rt := round _ _ _ _). +assert (Ht : (t = sqrt mu * bpow e)%R). +{ unfold t; rewrite Hmu, sqrt_mult_alt; [|now apply (Rle_trans _ _ _ Rle_0_1)]. + now rewrite sqrt_bpow. } +destruct (sqrt_error_N_FLX_aux2 _ Fmu HmuGe1) as [Hmu'|[Hmu'|Hmu']]. +{ unfold rt; fold t; rewrite Ht, Hmu', sqrt_1, Rmult_1_l. + rewrite round_generic; [|now apply valid_rnd_N|]. + { rewrite Rminus_diag_eq, Rabs_R0; [|now simpl]. + now apply Rmult_le_pos; [|apply Rabs_pos]. } + apply generic_format_bpow'; [now apply FLX_exp_valid|]. + unfold FLX_exp; omega. } +{ assert (Hsqrtmu : (1 <= sqrt mu < 1 + u_ro)%R); [rewrite Hmu'; split|]. + { rewrite <- sqrt_1 at 1; apply sqrt_le_1_alt; lra. } + { rewrite <- sqrt_square; [|lra]; apply sqrt_lt_1_alt; split; [lra|]. + ring_simplify; assert (0 < u_ro ^ 2)%R; [apply pow_lt|]; lra. } + assert (Fbpowe : generic_format beta (FLX_exp prec) (bpow e)). + { apply generic_format_bpow; unfold FLX_exp; omega. } + assert (Hrt : rt = bpow e :> R). + { unfold rt; fold t; rewrite Ht; simpl; apply Rle_antisym. + { apply round_N_le_midp; [now apply FLX_exp_valid|exact Fbpowe|]. + apply (Rlt_le_trans _ ((1 + u_ro) * bpow e)). + { now apply Rmult_lt_compat_r; [apply bpow_gt_0|]. } + unfold succ; rewrite Rle_bool_true; [|now apply bpow_ge_0]. + rewrite ulp_bpow; unfold FLX_exp. + unfold Z.sub, u_ro; rewrite !bpow_plus; right; field. } + apply round_ge_generic; + [now apply FLX_exp_valid|now apply valid_rnd_N|exact Fbpowe|]. + rewrite <- (Rmult_1_l (bpow _)) at 1. + now apply Rmult_le_compat_r; [apply bpow_ge_0|]. } + fold t; rewrite Hrt, Ht, Hmu', <-(Rabs_pos_eq _ Pb), <-Rabs_mult. + rewrite Rabs_minus_sym; right; f_equal; field; lra. } +assert (Hsqrtmu : (1 + u_ro < sqrt mu)%R). +{ apply (Rlt_le_trans _ (sqrt (1 + 4 * u_ro))); [|now apply sqrt_le_1_alt]. + assert (P1peps : (0 <= 1 + u_ro)%R) + by now apply Rplus_le_le_0_compat; [lra|apply Peps]. + rewrite <- (sqrt_square (1 + u_ro)); [|lra]. + apply sqrt_lt_1_alt; split; [now apply Rmult_le_pos|]. + apply (Rplus_lt_reg_r (-1 - 2 * u_ro)); ring_simplify; simpl. + rewrite Rmult_1_r; apply Rmult_lt_compat_r; [apply Peps'|]. + now apply (Rlt_le_trans _ 1); [apply u_ro_lt_1|lra]. } +assert (Hulpt : (ulp beta (FLX_exp prec) t = 2 * u_ro * bpow e)%R). +{ unfold ulp; rewrite Req_bool_false; [|apply Rgt_not_eq, Rlt_gt]. + { unfold u_ro; rewrite <-Rmult_assoc, Rinv_r, Rmult_1_l, <-bpow_plus; [|lra]. + f_equal; unfold cexp, FLX_exp. + assert (Hmagt : (mag beta t = 1 + e :> Z)%Z). + { apply mag_unique. + unfold t; rewrite (Rabs_pos_eq _ (Rlt_le _ _ (sqrt_lt_R0 _ Px))). + fold t; split. + { rewrite Ht; replace (_ - _)%Z with e by ring. + rewrite <- (Rmult_1_l (bpow _)) at 1; apply Rmult_le_compat_r. + { apply bpow_ge_0. } + now rewrite <- sqrt_1; apply sqrt_le_1_alt. } + rewrite bpow_plus, bpow_1, Ht; simpl. + apply Rmult_lt_compat_r; [now apply bpow_gt_0|]. + rewrite <- sqrt_square. + { apply sqrt_lt_1_alt; split; [lra|]. + apply (Rlt_le_trans _ _ _ HmuLtsqradix); right. + now unfold bpow, Z.pow_pos; simpl; rewrite Zmult_1_r, mult_IZR. } + apply IZR_le, (Z.le_trans _ 2), Zle_bool_imp_le, radix_prop; omega. } + rewrite Hmagt; ring. } + rewrite Ht; apply Rmult_lt_0_compat; [|now apply bpow_gt_0]. + now apply (Rlt_le_trans _ 1); [lra|rewrite <- sqrt_1; apply sqrt_le_1_alt]. } +assert (Pt : (0 < t)%R). +{ rewrite Ht; apply Rmult_lt_0_compat; [lra|apply bpow_gt_0]. } +assert (H : (Rabs ((rt - sqrt x) / sqrt x) + <= 1 - 1 / sqrt (1 + 2 * u_ro))%R). +{ unfold Rdiv; rewrite Rabs_mult, (Rabs_pos_eq (/ _)); + [|now left; apply Rinv_0_lt_compat]. + apply (Rle_trans _ ((u_ro * bpow e) / t)). + { unfold Rdiv; apply Rmult_le_compat_r; [now left; apply Rinv_0_lt_compat|]. + apply (Rle_trans _ _ _ (error_le_half_ulp _ _ _ _)). + fold t; rewrite Hulpt; right; field. } + apply (Rle_trans _ (u_ro / sqrt (1 + 4 * u_ro))). + { apply (Rle_trans _ (u_ro * bpow e / (sqrt (1 + 4 * u_ro) * bpow e))). + { unfold Rdiv; apply Rmult_le_compat_l; + [now apply Rmult_le_pos; [apply Peps|apply bpow_ge_0]|]. + apply Rinv_le. + { apply Rmult_lt_0_compat; [apply sqrt_lt_R0; lra|apply bpow_gt_0]. } + now rewrite Ht; apply Rmult_le_compat_r; + [apply bpow_ge_0|apply sqrt_le_1_alt]. } + right; field; split; apply Rgt_not_eq, Rlt_gt; + [apply sqrt_lt_R0; lra|apply bpow_gt_0]. } + apply sqrt_error_N_FLX_aux3. } +revert H; unfold Rdiv; rewrite Rabs_mult, Rabs_Rinv; [|fold t; lra]; intro H. +apply (Rmult_le_reg_r (/ Rabs (sqrt x))); + [apply Rinv_0_lt_compat, Rabs_pos_lt; fold t; lra|]. +apply (Rle_trans _ _ _ H); right; field; split; [apply Rabs_no_R0;fold t|]; lra. +Qed. + +Theorem sqrt_error_N_FLX_ex x (Fx : format x) : + exists eps, + (Rabs eps <= 1 - 1 / sqrt (1 + 2 * u_ro))%R /\ + round beta (FLX_exp prec) (Znearest choice) (sqrt x) + = (sqrt x * (1 + eps))%R. +Proof. +now apply relative_error_le_conversion; + [apply valid_rnd_N|apply om1ds1p2u_ro_pos|apply sqrt_error_N_FLX]. +Qed. + +Lemma sqrt_error_N_round_ex_derive : + forall x rx, + (exists eps, + (Rabs eps <= 1 - 1 / sqrt (1 + 2 * u_ro))%R /\ rx = (x * (1 + eps))%R) -> + exists eps, + (Rabs eps <= sqrt (1 + 2 * u_ro) - 1)%R /\ x = (rx * (1 + eps))%R. +Proof. +intros x rx (d, (Bd, Hd)). +assert (H := Rabs_le_inv _ _ Bd). +assert (H' := om1ds1p2u_ro_le_u_rod1pu_ro). +assert (H'' := u_rod1pu_ro_le_u_ro beta prec). +assert (H''' := u_ro_lt_1 beta prec prec_gt_0_). +assert (Hpos := s1p2u_rom1_pos). +destruct (Req_dec rx 0) as [Zfx|Nzfx]. +{ exists 0%R; split; [now rewrite Rabs_R0|]. + rewrite Rplus_0_r, Rmult_1_r, Zfx; rewrite Zfx in Hd. + destruct (Rmult_integral _ _ (sym_eq Hd)); lra. } +destruct (Req_dec x 0) as [Zx|Nzx]. +{ now exfalso; revert Hd; rewrite Zx; rewrite Rmult_0_l. } +set (d' := ((x - rx) / rx)%R). +assert (Hd' : (Rabs d' <= sqrt (1 + 2 * u_ro) - 1)%R). +{ unfold d'; rewrite Hd. + replace (_ / _)%R with (- d / (1 + d))%R; [|now field; split; lra]. + unfold Rdiv; rewrite Rabs_mult, Rabs_Ropp. + rewrite (Rabs_pos_eq (/ _)); [|apply Rlt_le, Rinv_0_lt_compat; lra]. + apply (Rmult_le_reg_r (1 + d)); [lra|]. + rewrite Rmult_assoc, Rinv_l, Rmult_1_r; [|lra]. + apply (Rle_trans _ _ _ Bd). + apply (Rle_trans _ ((sqrt (1 + 2 * u_ro) - 1) * (1/sqrt (1 + 2 * u_ro)))); + [right; field|apply Rmult_le_compat_l]; lra. } +now exists d'; split; [exact Hd'|]; unfold d'; field. +Qed. + +(** sqrt(1 + 2 u_ro) - 1 <= u_ro *) +Theorem sqrt_error_N_FLX_round_ex : + forall x, + format x -> + exists eps, + (Rabs eps <= sqrt (1 + 2 * u_ro) - 1)%R /\ + sqrt x = (round beta (FLX_exp prec) (Znearest choice) (sqrt x) * (1 + eps))%R. +Proof. +now intros x Fx; apply sqrt_error_N_round_ex_derive, sqrt_error_N_FLX_ex. +Qed. + +Variable emin : Z. +Hypothesis Hemin : (emin <= 2 * (1 - prec))%Z. + +Theorem sqrt_error_N_FLT_ex : + forall x, + generic_format beta (FLT_exp emin prec) x -> + exists eps, + (Rabs eps <= 1 - 1 / sqrt (1 + 2 * u_ro))%R /\ + round beta (FLT_exp emin prec) (Znearest choice) (sqrt x) + = (sqrt x * (1 + eps))%R. +Proof. +intros x Fx. +assert (Heps := u_ro_pos). +assert (Pb := om1ds1p2u_ro_pos). +destruct (Rle_or_lt x 0) as [Nx|Px]. +{ exists 0%R; split; [now rewrite Rabs_R0|]. + now rewrite (sqrt_neg x Nx), round_0, Rmult_0_l; [|apply valid_rnd_N]. } +assert (Fx' := generic_format_FLX_FLT _ _ _ _ Fx). +destruct (sqrt_error_N_FLX_ex _ Fx') as (d, (Bd, Hd)). +exists d; split; [exact Bd|]; rewrite <-Hd; apply round_FLT_FLX. +apply (Rle_trans _ (bpow (emin / 2)%Z)). +{ apply bpow_le, Z.div_le_lower_bound; lia. } +apply (Rle_trans _ _ _ (sqrt_bpow_ge _ _)). +rewrite Rabs_pos_eq; [|now apply sqrt_pos]; apply sqrt_le_1_alt. +revert Fx; apply generic_format_ge_bpow; [|exact Px]. +intro e; unfold FLT_exp; apply Z.le_max_r. +Qed. + +(** sqrt(1 + 2 u_ro) - 1 <= u_ro *) +Theorem sqrt_error_N_FLT_round_ex : + forall x, + generic_format beta (FLT_exp emin prec) x -> + exists eps, + (Rabs eps <= sqrt (1 + 2 * u_ro) - 1)%R /\ + sqrt x + = (round beta (FLT_exp emin prec) (Znearest choice) (sqrt x) * (1 + eps))%R. +Proof. +now intros x Fx; apply sqrt_error_N_round_ex_derive, sqrt_error_N_FLT_ex. +Qed. + +End Fprop_divsqrt_error. + +Section format_REM_aux. + +Variable beta : radix. +Notation bpow e := (bpow beta e). + +Variable fexp : Z -> Z. +Context { valid_exp : Valid_exp fexp }. +Context { monotone_exp : Monotone_exp fexp }. + +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. + +Notation format := (generic_format beta fexp). + +Lemma format_REM_aux: + forall x y : R, + format x -> format y -> (0 <= x)%R -> (0 < y)%R -> + ((0 < x/y < /2)%R -> rnd (x/y) = 0%Z) -> + format (x - IZR (rnd (x/y))*y). +Proof with auto with typeclass_instances. +intros x y Fx Fy Hx Hy rnd_small. +pose (n:=rnd (x / y)). +assert (Hn:(IZR n = round beta (FIX_exp 0) rnd (x/y))%R). +unfold round, FIX_exp, cexp, scaled_mantissa, F2R; simpl. +now rewrite 2!Rmult_1_r. +assert (H:(0 <= n)%Z). +apply le_IZR; rewrite Hn; simpl. +apply Rle_trans with (round beta (FIX_exp 0) rnd 0). +right; apply sym_eq, round_0... +apply round_le... +apply Fourier_util.Rle_mult_inv_pos; assumption. +case (Zle_lt_or_eq 0 n); try exact H. +clear H; intros H. +case (Zle_lt_or_eq 1 n). +omega. +clear H; intros H. +set (ex := cexp beta fexp x). +set (ey := cexp beta fexp y). +set (mx := Ztrunc (scaled_mantissa beta fexp x)). +set (my := Ztrunc (scaled_mantissa beta fexp y)). +case (Zle_or_lt ey ex); intros Hexy. +(* ey <= ex *) +assert (H0:(x-IZR n *y = F2R (Float beta (mx*beta^(ex-ey) - n*my) ey))%R). +unfold Rminus; rewrite Rplus_comm. +replace (IZR n) with (F2R (Float beta n 0)). +rewrite Fx, Fy. +fold mx my ex ey. +rewrite <- F2R_mult. +rewrite <- F2R_opp. +rewrite <- F2R_plus. +unfold Fplus. simpl. +rewrite Zle_imp_le_bool with (1 := Hexy). +f_equal; f_equal; ring. +unfold F2R; simpl; ring. +fold n; rewrite H0. +apply generic_format_F2R. +rewrite <- H0; intros H3. +apply monotone_exp. +apply mag_le_abs. +rewrite H0; apply F2R_neq_0; easy. +apply Rmult_le_reg_l with (/Rabs y)%R. +apply Rinv_0_lt_compat. +apply Rabs_pos_lt. +now apply Rgt_not_eq. +rewrite Rinv_l. +2: apply Rgt_not_eq, Rabs_pos_lt. +2: now apply Rgt_not_eq. +rewrite <- Rabs_Rinv. +2: now apply Rgt_not_eq. +rewrite <- Rabs_mult. +replace (/y * (x - IZR n *y))%R with (-(IZR n - x/y))%R. +rewrite Rabs_Ropp. +rewrite Hn. +apply Rle_trans with (1:= error_le_ulp beta (FIX_exp 0) _ _). +rewrite ulp_FIX. +simpl; apply Rle_refl. +field. +now apply Rgt_not_eq. +(* ex < ey: impossible as 1 < n *) +absurd (1 < n)%Z; try easy. +apply Zle_not_lt. +apply le_IZR; simpl; rewrite Hn. +apply round_le_generic... +apply generic_format_FIX. +exists (Float beta 1 0); try easy. +unfold F2R; simpl; ring. +apply Rmult_le_reg_r with y; try easy. +unfold Rdiv; rewrite Rmult_assoc. +rewrite Rinv_l, Rmult_1_r, Rmult_1_l. +2: now apply Rgt_not_eq. +assert (mag beta x < mag beta y)%Z. +case (Zle_or_lt (mag beta y) (mag beta x)); try easy. +intros J; apply monotone_exp in J; clear -J Hexy. +unfold ex, ey, cexp in Hexy; omega. +left; apply lt_mag with beta; easy. +(* n = 1 -> Sterbenz + rnd_small *) +intros Hn'; fold n; rewrite <- Hn'. +rewrite Rmult_1_l. +case Hx; intros Hx'. +assert (J:(0 < x/y)%R). +apply Fourier_util.Rlt_mult_inv_pos; assumption. +apply sterbenz... +assert (H0:(Rabs (1 - x/y) < 1)%R). +rewrite Hn', Hn. +apply Rlt_le_trans with (ulp beta (FIX_exp 0) (round beta (FIX_exp 0) rnd (x / y)))%R. +apply error_lt_ulp_round... +now apply Rgt_not_eq. +rewrite ulp_FIX. +rewrite <- Hn, <- Hn'. +apply Rle_refl. +apply Rabs_lt_inv in H0. +split; apply Rmult_le_reg_l with (/y)%R; try now apply Rinv_0_lt_compat. +unfold Rdiv; rewrite <- Rmult_assoc. +rewrite Rinv_l. +2: now apply Rgt_not_eq. +rewrite Rmult_1_l, Rmult_comm; fold (x/y)%R. +case (Rle_or_lt (/2) (x/y)); try easy. +intros K. +elim Zlt_not_le with (1 := H). +apply Zeq_le. +apply rnd_small. +now split. +apply Ropp_le_cancel; apply Rplus_le_reg_l with 1%R. +apply Rle_trans with (1-x/y)%R. +2: right; unfold Rdiv; ring. +left; apply Rle_lt_trans with (2:=proj1 H0). +right; field. +now apply Rgt_not_eq. +rewrite <- Hx', Rminus_0_l. +now apply generic_format_opp. +(* n = 0 *) +clear H; intros H; fold n; rewrite <- H. +now rewrite Rmult_0_l, Rminus_0_r. +Qed. + +End format_REM_aux. + +Section format_REM. + +Variable beta : radix. +Notation bpow e := (bpow beta e). + +Variable fexp : Z -> Z. +Context { valid_exp : Valid_exp fexp }. +Context { monotone_exp : Monotone_exp fexp }. + +Notation format := (generic_format beta fexp). + +Theorem format_REM : + forall rnd : R -> Z, Valid_rnd rnd -> + forall x y : R, + ((Rabs (x/y) < /2)%R -> rnd (x/y)%R = 0%Z) -> + format x -> format y -> + format (x - IZR (rnd (x/y)%R) * y). +Proof with auto with typeclass_instances. +(* assume 0 < y *) +assert (H: forall rnd : R -> Z, Valid_rnd rnd -> + forall x y : R, + ((Rabs (x/y) < /2)%R -> rnd (x/y)%R = 0%Z) -> + format x -> format y -> (0 < y)%R -> + format (x - IZR (rnd (x/y)%R) * y)). +intros rnd valid_rnd x y Hrnd Fx Fy Hy. +case (Rle_or_lt 0 x); intros Hx. +apply format_REM_aux; try easy. +intros K. +apply Hrnd. +rewrite Rabs_pos_eq. +apply K. +apply Rlt_le, K. +replace (x - IZR (rnd (x/y)) * y)%R with + (- (-x - IZR (Zrnd_opp rnd (-x/y)) * y))%R. +apply generic_format_opp. +apply format_REM_aux; try easy... +now apply generic_format_opp. +apply Ropp_le_cancel; rewrite Ropp_0, Ropp_involutive; now left. +replace (- x / y)%R with (- (x/y))%R by (unfold Rdiv; ring). +intros K. +unfold Zrnd_opp. +rewrite Ropp_involutive, Hrnd. +easy. +rewrite Rabs_left. +apply K. +apply Ropp_lt_cancel. +now rewrite Ropp_0. +unfold Zrnd_opp. +replace (- (- x / y))%R with (x / y)%R by (unfold Rdiv; ring). +rewrite opp_IZR. +ring. +(* *) +intros rnd valid_rnd x y Hrnd Fx Fy. +case (Rle_or_lt 0 y); intros Hy. +destruct Hy as [Hy|Hy]. +now apply H. +now rewrite <- Hy, Rmult_0_r, Rminus_0_r. +replace (IZR (rnd (x/y)) * y)%R with + (IZR ((Zrnd_opp rnd) ((x / -y))) * -y)%R. +apply H; try easy... +replace (x / - y)%R with (- (x/y))%R. +intros K. +unfold Zrnd_opp. +rewrite Ropp_involutive, Hrnd. +easy. +now rewrite <- Rabs_Ropp. +field; now apply Rlt_not_eq. +now apply generic_format_opp. +apply Ropp_lt_cancel; now rewrite Ropp_0, Ropp_involutive. +unfold Zrnd_opp. +replace (- (x / - y))%R with (x/y)%R. +rewrite opp_IZR. +ring. +field; now apply Rlt_not_eq. +Qed. + +Theorem format_REM_ZR: + forall x y : R, + format x -> format y -> + format (x - IZR (Ztrunc (x/y)) * y). +Proof with auto with typeclass_instances. +intros x y Fx Fy. +apply format_REM; try easy... +intros K. +apply Z.abs_0_iff. +rewrite <- Ztrunc_abs. +rewrite Ztrunc_floor by apply Rabs_pos. +apply Zle_antisym. +replace 0%Z with (Zfloor (/2)). +apply Zfloor_le. +now apply Rlt_le. +apply Zfloor_imp. +simpl ; lra. +apply Zfloor_lub. +apply Rabs_pos. +Qed. + +Theorem format_REM_N : + forall choice, + forall x y : R, + format x -> format y -> + format (x - IZR (Znearest choice (x/y)) * y). +Proof with auto with typeclass_instances. +intros choice x y Fx Fy. +apply format_REM; try easy... +intros K. +apply Znearest_imp. +now rewrite Rminus_0_r. +Qed. + +End format_REM. diff --git a/flocq/Prop/Double_rounding.v b/flocq/Prop/Double_rounding.v new file mode 100644 index 00000000..055409bb --- /dev/null +++ b/flocq/Prop/Double_rounding.v @@ -0,0 +1,4545 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2014-2018 Sylvie Boldo +#
# +Copyright (C) 2014-2018 Guillaume Melquiond +#
# +Copyright (C) 2014-2018 Pierre Roux + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +(** * Conditions for innocuous double rounding. *) + +Require Import Psatz. +Require Import Raux Defs Generic_fmt Operations Ulp FLX FLT FTZ. + +Open Scope R_scope. + +Section Double_round. + +Variable beta : radix. +Notation bpow e := (bpow beta e). +Notation mag x := (mag beta x). + +Definition round_round_eq fexp1 fexp2 choice1 choice2 x := + round beta fexp1 (Znearest choice1) (round beta fexp2 (Znearest choice2) x) + = round beta fexp1 (Znearest choice1) x. + +(** 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 [(Raux.bpow _ _ * Raux.bpow _ _)] => + rewrite <- bpow_plus + | |- context [(?X1 * Raux.bpow _ _ * Raux.bpow _ _)] => + rewrite (Rmult_assoc X1); rewrite <- bpow_plus + | |- context [(?X1 * (?X2 * Raux.bpow _ _) * Raux.bpow _ _)] => + rewrite <- (Rmult_assoc X1 X2); rewrite (Rmult_assoc (X1 * X2)); + rewrite <- bpow_plus + end; + (* ring_simplify arguments of bpow *) + repeat + match goal with + | |- context [(Raux.bpow _ ?X)] => + progress ring_simplify X + end; + (* bpow 0 ~~> 1 *) + change (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 round_round_lt_mid_further_place' : + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + forall x, + 0 < x -> + (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> + x < bpow (mag x) - / 2 * ulp beta fexp2 x -> + x < midp fexp1 x - / 2 * ulp beta fexp2 x -> + round_round_eq fexp1 fexp2 choice1 choice2 x. +Proof. +intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hx1. +unfold round_round_eq. +set (x' := round beta fexp1 Zfloor x). +intro Hx2'. +assert (Hx2 : x - round beta fexp1 Zfloor x + < / 2 * (ulp beta fexp1 x - ulp beta fexp2 x)). +{ now apply (Rplus_lt_reg_r (round beta fexp1 Zfloor x)); ring_simplify. } +set (x'' := round beta fexp2 (Znearest choice2) x). +assert (Hr1 : Rabs (x'' - x) <= / 2 * bpow (fexp2 (mag x))). +apply Rle_trans with (/ 2 * ulp beta fexp2 x). +now unfold x''; apply error_le_half_ulp... +rewrite ulp_neq_0;[now right|now apply Rgt_not_eq]. +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 (mag x))). +{ replace (x'' - x') with (x'' - x + (x - x')) by ring. + apply (Rle_lt_trans _ _ _ (Rabs_triang _ _)). + replace (/ 2 * _) with (/ 2 * bpow (fexp2 (mag x)) + + (/ 2 * (bpow (fexp1 (mag x)) + - bpow (fexp2 (mag x))))) by ring. + apply Rplus_le_lt_compat. + - exact Hr1. + - now rewrite Rabs_right; [|now apply Rle_ge]; apply Hx2. } +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, cexp; simpl. + rewrite (Znearest_imp _ _ 0); [now simpl; rewrite Rmult_0_l|]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. + rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; + [|now apply Rle_ge; apply bpow_ge_0]. + rewrite <- Rabs_mult; rewrite Rmult_minus_distr_r. + 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'' : mag x'' = mag x :> Z). + { apply Zle_antisym. + - apply mag_le_bpow; [exact Nzx''|]. + replace x'' with (x'' - x + x) by ring. + apply (Rle_lt_trans _ _ _ (Rabs_triang _ _)). + replace (bpow _) with (/ 2 * bpow (fexp2 (mag x)) + + (bpow (mag x) + - / 2 * bpow (fexp2 (mag x)))) by ring. + apply Rplus_le_lt_compat; [exact Hr1|]. + rewrite ulp_neq_0 in Hx1;[idtac| now apply Rgt_not_eq]. + now rewrite Rabs_right; [|apply Rle_ge; apply Rlt_le]. + - unfold x'' in Nzx'' |- *. + now apply mag_round_ge; [|apply valid_rnd_N|]. } + unfold round, F2R, scaled_mantissa, cexp; simpl. + rewrite Lx''. + rewrite (Znearest_imp _ _ (Zfloor (scaled_mantissa beta fexp1 x))). + + rewrite (Znearest_imp _ _ (Zfloor (scaled_mantissa beta fexp1 x))); + [reflexivity|]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. + rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; + [|now apply Rle_ge; apply bpow_ge_0]. + rewrite <- Rabs_mult. + rewrite Rmult_minus_distr_r. + 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 (mag x))). + unfold ulp, cexp; lra. + + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. + rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; + [|now apply Rle_ge; apply bpow_ge_0]. + rewrite <- Rabs_mult. + rewrite Rmult_minus_distr_r. + fold x'. + now bpow_simplify. +Qed. + +Lemma round_round_lt_mid_further_place : + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + forall x, + 0 < x -> + (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> + (fexp1 (mag x) <= mag x)%Z -> + x < midp fexp1 x - / 2 * ulp beta fexp2 x -> + round_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 round_round_eq. +set (x' := round beta fexp1 Zfloor x). +intro Hx2. +assert (Pxx' : 0 <= x - x'). +{ apply Rle_0_minus. + apply round_DN_pt. + exact Vfexp1. } +assert (x < bpow (mag x) - / 2 * bpow (fexp2 (mag x))); + [|apply round_round_lt_mid_further_place'; try assumption]... +2: rewrite ulp_neq_0;[assumption|now apply Rgt_not_eq]. +destruct (Req_dec x' 0) as [Zx'|Nzx']. +- (* x' = 0 *) + 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 (- mag x))); [now apply bpow_gt_0|]. + unfold ulp, cexp; bpow_simplify. + apply Rmult_le_reg_l with (1 := Rlt_0_2). + replace (2 * (/ 2 * _)) with (bpow (fexp1 (mag x) - mag 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 (mag x)))); + [now apply bpow_gt_0|]. + rewrite Rmult_0_l. + unfold round, F2R, cexp; simpl; bpow_simplify. + apply IZR_le. + apply Zfloor_lub. + rewrite <- (Rabs_right x); [|now apply Rle_ge; apply Rlt_le]. + rewrite scaled_mantissa_abs. + apply Rabs_pos. } + assert (Hx' : x' <= bpow (mag 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_mag_gt. + - exact Vfexp1. + - now apply Rlt_le. } + fold (cexp beta fexp2 x); fold (ulp beta fexp2 x). + assert (/ 2 * ulp beta fexp1 x <= ulp beta fexp1 x). + rewrite <- (Rmult_1_l (ulp _ _ _)) at 2. + apply Rmult_le_compat_r; [|lra]. + 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 round_round_lt_mid_same_place : + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> + forall (choice1 choice2 : Z -> bool), + forall x, + 0 < x -> + (fexp2 (mag x) = fexp1 (mag x))%Z -> + x < midp fexp1 x -> + round_round_eq fexp1 fexp2 choice1 choice2 x. +Proof. +intros fexp1 fexp2 Vfexp1 choice1 choice2 x Px Hf2f1. +intro Hx'. +assert (Hx : x - round beta fexp1 Zfloor x < / 2 * ulp beta fexp1 x). +{ now apply (Rplus_lt_reg_r (round beta fexp1 Zfloor x)); ring_simplify. } +revert Hx. +unfold round_round_eq. +set (x' := round beta fexp1 Zfloor x). +intro Hx. +assert (Pxx' : 0 <= x - x'). +{ apply Rle_0_minus. + apply round_DN_pt. + exact Vfexp1. } +assert (H : Rabs (x * bpow (- fexp1 (mag x)) - + IZR (Zfloor (x * bpow (- fexp1 (mag x))))) < / 2). +{ apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. + unfold scaled_mantissa, cexp in Hx. + rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; + [|now apply Rle_ge; apply bpow_ge_0]. + rewrite <- Rabs_mult. + rewrite Rmult_minus_distr_r. + bpow_simplify. + apply Rabs_lt. + change (IZR _ * _) 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, cexp; simpl. +rewrite Hf2f1. +rewrite (Znearest_imp _ _ (Zfloor (scaled_mantissa beta fexp1 x)) H). +rewrite round_generic. + + unfold round, F2R, scaled_mantissa, cexp; simpl. + now rewrite (Znearest_imp _ _ (Zfloor (x * bpow (- fexp1 (mag x))))). + + now apply valid_rnd_N. + + fold (cexp beta fexp1 x). + change (IZR _ * bpow _) with (round beta fexp1 Zfloor x). + apply generic_format_round. + exact Vfexp1. + now apply valid_rnd_DN. +Qed. + +Lemma round_round_lt_mid : + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + forall x, + 0 < x -> + (fexp2 (mag x) <= fexp1 (mag x))%Z -> + (fexp1 (mag x) <= mag x)%Z -> + x < midp fexp1 x -> + ((fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> + x < midp fexp1 x - / 2 * ulp beta fexp2 x) -> + round_round_eq fexp1 fexp2 choice1 choice2 x. +Proof. +intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hf1 Hx Hx'. +destruct (Zle_or_lt (fexp1 (mag x)) (fexp2 (mag x))) as [Hf2'|Hf2']. +- (* fexp1 (mag x) <= fexp2 (mag x) *) + assert (Hf2'' : (fexp2 (mag x) = fexp1 (mag x) :> Z)%Z); [omega|]. + now apply round_round_lt_mid_same_place. +- (* fexp2 (mag x) < fexp1 (mag x) *) + assert (Hf2'' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z); [omega|]. + generalize (Hx' Hf2''); intro Hx''. + now apply round_round_lt_mid_further_place. +Qed. + +Lemma round_round_gt_mid_further_place' : + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + forall x, + 0 < x -> + (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> + round beta fexp2 (Znearest choice2) x < bpow (mag x) -> + midp' fexp1 x + / 2 * ulp beta fexp2 x < x -> + round_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 round_round_eq. +set (x' := round beta fexp1 Zceil x). +set (x'' := round beta fexp2 (Znearest choice2) x). +intros Hx1 Hx2. +assert (Hr1 : Rabs (x'' - x) <= / 2 * bpow (fexp2 (mag x))). + apply Rle_trans with (/2* ulp beta fexp2 x). + now unfold x''; apply error_le_half_ulp... + rewrite ulp_neq_0;[now right|now apply Rgt_not_eq]. +assert (Px'x : 0 <= x' - x). +{ apply Rle_0_minus. + apply round_UP_pt. + exact Vfexp1. } +assert (Hr2 : Rabs (x'' - x') < / 2 * bpow (fexp1 (mag x))). +{ replace (x'' - x') with (x'' - x + (x - x')) by ring. + apply (Rle_lt_trans _ _ _ (Rabs_triang _ _)). + replace (/ 2 * _) with (/ 2 * bpow (fexp2 (mag x)) + + (/ 2 * (bpow (fexp1 (mag x)) + - bpow (fexp2 (mag 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, cexp; simpl. + rewrite (Znearest_imp _ _ 0); [now simpl; rewrite Rmult_0_l|]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. + rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; + [|now apply Rle_ge; apply bpow_ge_0]. + rewrite <- Rabs_mult; rewrite Rmult_minus_distr_r. + 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'' : mag x'' = mag x :> Z). + { apply Zle_antisym. + - apply mag_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 mag_round_ge; [|apply valid_rnd_N|]. } + unfold round, F2R, scaled_mantissa, cexp; simpl. + rewrite Lx''. + rewrite (Znearest_imp _ _ (Zceil (scaled_mantissa beta fexp1 x))). + + rewrite (Znearest_imp _ _ (Zceil (scaled_mantissa beta fexp1 x))); + [reflexivity|]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. + rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; + [|now apply Rle_ge; apply bpow_ge_0]. + rewrite <- Rabs_mult. + rewrite Rmult_minus_distr_r. + 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 (mag x))). + rewrite 2!ulp_neq_0; try (apply Rgt_not_eq; assumption). + unfold cexp; lra. + + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. + rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; + [|now apply Rle_ge; apply bpow_ge_0]. + rewrite <- Rabs_mult. + rewrite Rmult_minus_distr_r. + fold x'. + now bpow_simplify. +Qed. + +Lemma round_round_gt_mid_further_place : + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + forall x, + 0 < x -> + (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> + (fexp1 (mag x) <= mag x)%Z -> + midp' fexp1 x + / 2 * ulp beta fexp2 x < x -> + round_round_eq fexp1 fexp2 choice1 choice2 x. +Proof. +intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hf1 Hx2'. +assert (Hx2 : round beta fexp1 Zceil x - x + < / 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 round_round_eq. +set (x' := round beta fexp1 Zfloor x). +intro Hx2. +set (x'' := round beta fexp2 (Znearest choice2) x). +destruct (Rlt_or_le x'' (bpow (mag x))) as [Hx''|Hx'']; + [now apply round_round_gt_mid_further_place'|]. +(* bpow (mag x) <= x'' *) +assert (Hx''pow : x'' = bpow (mag x)). +{ assert (H'x'' : x'' < bpow (mag x) + / 2 * ulp beta fexp2 x). + { apply Rle_lt_trans with (x + / 2 * ulp beta fexp2 x). + - apply (Rplus_le_reg_r (- x)); ring_simplify. + apply Rabs_le_inv. + 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_mag_gt. } + apply Rle_antisym; [|exact Hx'']. + unfold x'', round, F2R, scaled_mantissa, cexp; simpl. + apply (Rmult_le_reg_r (bpow (- fexp2 (mag x)))); [now apply bpow_gt_0|]. + bpow_simplify. + rewrite <- (IZR_Zpower _ (_ - _)); [|omega]. + apply IZR_le. + apply Zlt_succ_le; unfold Z.succ. + apply lt_IZR. + rewrite plus_IZR; rewrite IZR_Zpower; [|omega]. + apply (Rmult_lt_reg_r (bpow (fexp2 (mag x)))); [now apply bpow_gt_0|]. + rewrite Rmult_plus_distr_r; rewrite Rmult_1_l. + bpow_simplify. + apply (Rlt_le_trans _ _ _ H'x''). + apply Rplus_le_compat_l. + rewrite <- (Rmult_1_l (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 cexp; apply bpow_lt. + omega. } +unfold round, F2R, scaled_mantissa, cexp; simpl. +assert (Hf : (0 <= mag x - fexp1 (mag x''))%Z). +{ rewrite Hx''pow. + rewrite mag_bpow. + assert (fexp1 (mag x + 1) <= mag x)%Z; [|omega]. + destruct (Zle_or_lt (mag x) (fexp1 (mag x))) as [Hle|Hlt]; + [|now apply Vfexp1]. + assert (H : (mag x = fexp1 (mag x) :> Z)%Z); + [now apply Zle_antisym|]. + rewrite H. + now apply Vfexp1. } +rewrite (Znearest_imp _ _ (beta ^ (mag x - fexp1 (mag x'')))%Z). +- rewrite (Znearest_imp _ _ (beta ^ (mag x - fexp1 (mag x)))%Z). + + rewrite IZR_Zpower; [|exact Hf]. + rewrite IZR_Zpower; [|omega]. + now bpow_simplify. + + rewrite IZR_Zpower; [|omega]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. + rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; + [|now apply Rle_ge; apply bpow_ge_0]. + rewrite <- Rabs_mult. + 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 IZR_Zpower; [|exact Hf]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x'')))); [now apply bpow_gt_0|]. + rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; + [|now apply Rle_ge; apply bpow_ge_0]. + rewrite <- Rabs_mult. + 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 round_round_gt_mid_same_place : + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> + forall (choice1 choice2 : Z -> bool), + forall x, + 0 < x -> + (fexp2 (mag x) = fexp1 (mag x))%Z -> + midp' fexp1 x < x -> + round_round_eq fexp1 fexp2 choice1 choice2 x. +Proof. +intros fexp1 fexp2 Vfexp1 choice1 choice2 x Px Hf2f1 Hx'. +assert (Hx : round beta fexp1 Zceil x - x < / 2 * ulp beta fexp1 x). +{ apply (Rplus_lt_reg_r (- / 2 * ulp beta fexp1 x + x)); ring_simplify. + now unfold midp' in Hx'. } +assert (H : Rabs (IZR (Zceil (x * bpow (- fexp1 (mag x)))) + - x * bpow (- fexp1 (mag x))) < / 2). +{ apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. + unfold scaled_mantissa, cexp in Hx. + rewrite <- (Rabs_right (bpow (fexp1 _))) at 1; + [|now apply Rle_ge; apply bpow_ge_0]. + rewrite <- Rabs_mult. + 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 round_round_eq, round at 2. +unfold F2R, scaled_mantissa, cexp; simpl. +rewrite Hf2f1. +rewrite (Znearest_imp _ _ (Zceil (scaled_mantissa beta fexp1 x))). +- rewrite round_generic. + + unfold round, F2R, scaled_mantissa, cexp; simpl. + now rewrite (Znearest_imp _ _ (Zceil (x * bpow (- fexp1 (mag x))))); + [|rewrite Rabs_minus_sym]. + + now apply valid_rnd_N. + + fold (cexp beta fexp1 x). + change (IZR _ * bpow _) with (round beta fexp1 Zceil x). + apply generic_format_round. + exact Vfexp1. + now apply valid_rnd_UP. +- now rewrite Rabs_minus_sym. +Qed. + +Lemma round_round_gt_mid : + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + forall x, + 0 < x -> + (fexp2 (mag x) <= fexp1 (mag x))%Z -> + (fexp1 (mag x) <= mag x)%Z -> + midp' fexp1 x < x -> + ((fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> + midp' fexp1 x + / 2 * ulp beta fexp2 x < x) -> + round_round_eq fexp1 fexp2 choice1 choice2 x. +Proof. +intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hf1 Hx Hx'. +destruct (Zle_or_lt (fexp1 (mag x)) (fexp2 (mag x))) as [Hf2'|Hf2']. +- (* fexp1 (mag x) <= fexp2 (mag x) *) + assert (Hf2'' : (fexp2 (mag x) = fexp1 (mag x) :> Z)%Z); [omega|]. + now apply round_round_gt_mid_same_place. +- (* fexp2 (mag x) < fexp1 (mag x) *) + assert (Hf2'' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z); [omega|]. + generalize (Hx' Hf2''); intro Hx''. + now apply round_round_gt_mid_further_place. +Qed. + +Section Double_round_mult. + +Lemma mag_mult_disj : + forall x y, + x <> 0 -> y <> 0 -> + ((mag (x * y) = (mag x + mag y - 1)%Z :> Z) + \/ (mag (x * y) = (mag x + mag y)%Z :> Z)). +Proof. +intros x y Zx Zy. +destruct (mag_mult beta x y Zx Zy). +omega. +Qed. + +Definition round_round_mult_hyp fexp1 fexp2 := + (forall ex ey, (fexp2 (ex + ey) <= fexp1 ex + fexp1 ey)%Z) + /\ (forall ex ey, (fexp2 (ex + ey - 1) <= fexp1 ex + fexp1 ey)%Z). + +Lemma round_round_mult_aux : + forall (fexp1 fexp2 : Z -> Z), + round_round_mult_hyp fexp1 fexp2 -> + forall x y, + generic_format beta fexp1 x -> generic_format beta fexp1 y -> + generic_format beta fexp2 (x * y). +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 cexp. + set (mx := Ztrunc (scaled_mantissa beta fexp1 x)). + set (my := Ztrunc (scaled_mantissa beta fexp1 y)). + unfold F2R; simpl. + intros Fx Fy. + set (fxy := Float beta (mx * my) (fexp1 (mag x) + fexp1 (mag y))). + assert (Hxy : x * y = F2R fxy). + { unfold fxy, F2R; simpl. + rewrite bpow_plus. + rewrite mult_IZR. + rewrite Fx, Fy at 1. + ring. } + apply generic_format_F2R' with (f := fxy); [now rewrite Hxy|]. + intros _. + unfold cexp, fxy; simpl. + destruct Hfexp as (Hfexp1, Hfexp2). + now destruct (mag_mult_disj x y Zx Zy) as [Lxy|Lxy]; rewrite Lxy. +Qed. + +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. + +Theorem round_round_mult : + forall (fexp1 fexp2 : Z -> Z), + round_round_mult_hyp fexp1 fexp2 -> + forall x y, + generic_format beta fexp1 x -> generic_format beta fexp1 y -> + round beta fexp1 rnd (round beta fexp2 rnd (x * y)) + = 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 (round_round_mult_aux fexp1 fexp2). } +now rewrite Hxy at 1. +Qed. + +Section Double_round_mult_FLX. + +Variable prec : Z. +Variable prec' : Z. + +Context { prec_gt_0_ : Prec_gt_0 prec }. +Context { prec_gt_0_' : Prec_gt_0 prec' }. + +Theorem round_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 round_round_mult; + [|now apply generic_format_FLX|now apply generic_format_FLX]. +unfold round_round_mult_hyp; split; intros ex ey; unfold FLX_exp; +omega. +Qed. + +End Double_round_mult_FLX. + +Section Double_round_mult_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 round_round_mult_FLT : + (emin' <= 2 * emin)%Z -> (2 * prec <= prec')%Z -> + forall x y, + FLT_format beta emin prec x -> FLT_format beta emin prec y -> + 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 round_round_mult; + [|now apply generic_format_FLT|now apply generic_format_FLT]. +unfold round_round_mult_hyp; split; intros ex ey; +unfold FLT_exp; +generalize (Zmax_spec (ex + ey - prec') emin'); +generalize (Zmax_spec (ex + ey - 1 - prec') emin'); +generalize (Zmax_spec (ex - prec) emin); +generalize (Zmax_spec (ey - prec) emin); +omega. +Qed. + +End Double_round_mult_FLT. + +Section Double_round_mult_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 round_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 round_round_mult; + [|now apply generic_format_FTZ|now apply generic_format_FTZ]. +unfold round_round_mult_hyp; split; intros ex ey; +unfold FTZ_exp; +unfold Prec_gt_0 in *; +destruct (Z.ltb_spec (ex + ey - prec') emin'); +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 mag_plus_disj : + forall x y, + 0 < y -> y <= x -> + ((mag (x + y) = mag x :> Z) + \/ (mag (x + y) = (mag x + 1)%Z :> Z)). +Proof. +intros x y Py Hxy. +destruct (mag_plus beta x y Py Hxy). +omega. +Qed. + +Lemma mag_plus_separated : + forall fexp : Z -> Z, + forall x y, + 0 < x -> 0 <= y -> + generic_format beta fexp x -> + (mag y <= fexp (mag x))%Z -> + (mag (x + y) = mag x :> Z). +Proof. +intros fexp x y Px Nny Fx Hsep. +apply mag_plus_eps with (1 := Px) (2 := Fx). +apply (conj Nny). +rewrite <- Rabs_pos_eq with (1 := Nny). +apply Rlt_le_trans with (1 := bpow_mag_gt beta _). +rewrite ulp_neq_0 by now apply Rgt_not_eq. +now apply bpow_le. +Qed. + +Lemma mag_minus_disj : + forall x y, + 0 < x -> 0 < y -> + (mag y <= mag x - 2)%Z -> + ((mag (x - y) = mag x :> Z) + \/ (mag (x - y) = (mag x - 1)%Z :> Z)). +Proof. +intros x y Px Py Hln. +assert (Hxy : y < x); [now apply (lt_mag beta); [ |omega]|]. +generalize (mag_minus beta x y Py Hxy); intro Hln2. +generalize (mag_minus_lb beta x y Px Py Hln); intro Hln3. +omega. +Qed. + +Lemma mag_minus_separated : + forall fexp : Z -> Z, Valid_exp fexp -> + forall x y, + 0 < x -> 0 < y -> y < x -> + bpow (mag x - 1) < x -> + generic_format beta fexp x -> (mag y <= fexp (mag x))%Z -> + (mag (x - y) = mag x :> Z). +Proof. +intros fexp Vfexp x y Px Py Yltx Xgtpow Fx Ly. +apply mag_unique. +split. +- apply Rabs_ge; right. + assert (Hy : y < ulp beta fexp (bpow (mag x - 1))). + { rewrite ulp_bpow. + replace (_ + _)%Z with (mag x : Z) by ring. + rewrite <- (Rabs_right y); [|now apply Rle_ge; apply Rlt_le]. + apply Rlt_le_trans with (bpow (mag y)). + - apply bpow_mag_gt. + - now apply bpow_le. } + apply (Rplus_le_reg_r y); ring_simplify. + apply Rle_trans with (bpow (mag x - 1) + + ulp beta fexp (bpow (mag x - 1))). + + now apply Rplus_le_compat_l; apply Rlt_le. + + rewrite <- succ_eq_pos;[idtac|apply bpow_ge_0]. + apply succ_le_lt; [apply Vfexp|idtac|exact Fx|assumption]. + apply (generic_format_bpow beta fexp (mag x - 1)). + replace (_ + _)%Z with (mag x : Z) by ring. + assert (fexp (mag x) < mag x)%Z; [|omega]. + now apply mag_generic_gt; [|now apply Rgt_not_eq|]. +- rewrite Rabs_right. + + apply Rlt_trans with x. + * rewrite <- (Rplus_0_r x) at 2. + apply Rplus_lt_compat_l. + rewrite <- Ropp_0. + now apply Ropp_lt_contravar. + * apply Rabs_lt_inv. + apply bpow_mag_gt. + + lra. +Qed. + +Definition round_round_plus_hyp fexp1 fexp2 := + (forall ex ey, (fexp1 (ex + 1) - 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z) + /\ (forall ex ey, (fexp1 (ex - 1) + 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z) + /\ (forall ex ey, (fexp1 ex - 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z) + /\ (forall ex ey, (ex - 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z). + +Lemma round_round_plus_aux0_aux_aux : + forall (fexp1 fexp2 : Z -> Z), + forall x y, + (fexp1 (mag x) <= fexp1 (mag y))%Z -> + (fexp2 (mag (x + y))%Z <= fexp1 (mag x))%Z -> + (fexp2 (mag (x + y))%Z <= fexp1 (mag y))%Z -> + generic_format beta fexp1 x -> generic_format beta fexp1 y -> + generic_format beta fexp2 (x + y). +Proof. +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_mag beta fexp1). +- (* x <> 0 *) + destruct (Req_dec y 0) as [Zy|Nzy]. + + (* y = 0 *) + rewrite Zy, Rplus_0_r in Hlnx |- *. + now apply (generic_inclusion_mag beta fexp1). + + (* y <> 0 *) + revert Fx Fy. + unfold generic_format at -3, cexp, F2R; simpl. + set (mx := Ztrunc (scaled_mantissa beta fexp1 x)). + set (my := Ztrunc (scaled_mantissa beta fexp1 y)). + intros Fx Fy. + set (fxy := Float beta (mx + my * (beta ^ (fexp1 (mag y) + - fexp1 (mag x)))) + (fexp1 (mag x))). + assert (Hxy : x + y = F2R fxy). + { unfold fxy, F2R; simpl. + rewrite plus_IZR. + rewrite Rmult_plus_distr_r. + rewrite <- Fx. + rewrite mult_IZR. + rewrite IZR_Zpower; [|omega]. + bpow_simplify. + now rewrite <- Fy. } + apply generic_format_F2R' with (f := fxy); [now rewrite Hxy|]. + intros _. + now unfold cexp, fxy; simpl. +Qed. + +Lemma round_round_plus_aux0_aux : + forall (fexp1 fexp2 : Z -> Z), + forall x y, + (fexp2 (mag (x + y))%Z <= fexp1 (mag x))%Z -> + (fexp2 (mag (x + y))%Z <= fexp1 (mag y))%Z -> + generic_format beta fexp1 x -> generic_format beta fexp1 y -> + generic_format beta fexp2 (x + y). +Proof. +intros fexp1 fexp2 x y Hlnx Hlny Fx Fy. +destruct (Z.le_gt_cases (fexp1 (mag x)) (fexp1 (mag y))) as [Hle|Hgt]. +- now apply (round_round_plus_aux0_aux_aux fexp1). +- rewrite Rplus_comm in Hlnx, Hlny |- *. + now apply (round_round_plus_aux0_aux_aux fexp1); [omega| | | |]. +Qed. + +(* fexp1 (mag x) - 1 <= mag y : + * addition is exact in the largest precision (fexp2). *) +Lemma round_round_plus_aux0 : + forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> + round_round_plus_hyp fexp1 fexp2 -> + forall x y, + (0 < x)%R -> (0 < y)%R -> (y <= x)%R -> + (fexp1 (mag x) - 1 <= mag y)%Z -> + generic_format beta fexp1 x -> generic_format beta fexp1 y -> + generic_format beta fexp2 (x + y). +Proof. +intros fexp1 fexp2 Vfexp1 Hexp x y Px Py Hyx Hln Fx Fy. +assert (Nny : (0 <= y)%R); [now apply Rlt_le|]. +destruct Hexp as (_,(Hexp2,(Hexp3,Hexp4))). +destruct (Z.le_gt_cases (mag y) (fexp1 (mag x))) as [Hle|Hgt]. +- (* mag y <= fexp1 (mag x) *) + assert (Lxy : mag (x + y) = mag x :> Z); + [now apply (mag_plus_separated fexp1)|]. + apply (round_round_plus_aux0_aux fexp1); + [| |assumption|assumption]; rewrite Lxy. + + now apply Hexp4; omega. + + now apply Hexp3; omega. +- (* fexp1 (mag x) < mag y *) + apply (round_round_plus_aux0_aux fexp1); [| |assumption|assumption]. + destruct (mag_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. + + now apply Hexp4; omega. + + apply Hexp2; apply (mag_le beta y x Py) in Hyx. + replace (_ - _)%Z with (mag x : Z) by ring. + omega. + + destruct (mag_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. + * now apply Hexp3; omega. + * apply Hexp2. + replace (_ - _)%Z with (mag x : Z) by ring. + omega. +Qed. + +Lemma round_round_plus_aux1_aux : + forall k, (0 < k)%Z -> + forall (fexp : Z -> Z), + forall x y, + 0 < x -> 0 < y -> + (mag y <= fexp (mag x) - k)%Z -> + (mag (x + y) = mag x :> Z) -> + generic_format beta fexp x -> + 0 < (x + y) - round beta fexp Zfloor (x + y) < bpow (fexp (mag x) - k). +Proof. +assert (Hbeta : (2 <= beta)%Z). +{ destruct beta as (beta_val,beta_prop). + now apply Zle_bool_imp_le. } +intros k Hk fexp x y Px Py Hln Hlxy Fx. +revert Fx. +unfold round, generic_format, F2R, scaled_mantissa, cexp; simpl. +rewrite Hlxy. +set (mx := Ztrunc (x * bpow (- fexp (mag x)))). +intros Fx. +assert (R : (x + y) * bpow (- fexp (mag x)) + = IZR mx + y * bpow (- fexp (mag x))). +{ rewrite Fx at 1. + rewrite Rmult_plus_distr_r. + now bpow_simplify. } +rewrite R. +assert (LB : 0 < y * bpow (- fexp (mag x))). +{ rewrite <- (Rmult_0_r y). + now apply Rmult_lt_compat_l; [|apply bpow_gt_0]. } +assert (UB : y * bpow (- fexp (mag x)) < / IZR (beta ^ k)). +{ apply Rlt_le_trans with (bpow (mag y) * bpow (- fexp (mag x))). + - apply Rmult_lt_compat_r; [now apply bpow_gt_0|]. + rewrite <- (Rabs_right y) at 1; [|now apply Rle_ge; apply Rlt_le]. + apply bpow_mag_gt. + - apply Rle_trans with (bpow (fexp (mag x) - k) + * bpow (- fexp (mag x)))%R. + + apply Rmult_le_compat_r; [now apply bpow_ge_0|]. + now apply bpow_le. + + bpow_simplify. + rewrite bpow_opp. + destruct k. + * omega. + * simpl; unfold Raux.bpow, Z.pow_pos. + now apply Rle_refl. + * casetype False; apply (Z.lt_irrefl 0). + apply (Z.lt_trans _ _ _ Hk). + apply Zlt_neg_0. } +rewrite (Zfloor_imp mx). +{ split; ring_simplify. + - apply (Rmult_lt_reg_r (bpow (- fexp (mag x)))); [now apply bpow_gt_0|]. + rewrite Rmult_minus_distr_r, Rmult_0_l. + bpow_simplify. + rewrite R; ring_simplify. + now apply Rmult_lt_0_compat; [|apply bpow_gt_0]. + - apply (Rmult_lt_reg_r (bpow (- fexp (mag x)))); [now apply bpow_gt_0|]. + rewrite Rmult_minus_distr_r. + bpow_simplify. + rewrite R; ring_simplify. + apply (Rlt_le_trans _ _ _ UB). + rewrite bpow_opp. + apply Rinv_le; [now apply bpow_gt_0|]. + now rewrite IZR_Zpower; [right|omega]. } +split. +- rewrite <- Rplus_0_r at 1; apply Rplus_le_compat_l. + now apply Rlt_le. +- rewrite plus_IZR; apply Rplus_lt_compat_l. + apply (Rmult_lt_reg_r (bpow (fexp (mag x)))); [now apply bpow_gt_0|]. + rewrite Rmult_1_l. + bpow_simplify. + apply Rlt_trans with (bpow (mag y)). + + rewrite <- Rabs_right at 1; [|now apply Rle_ge; apply Rlt_le]. + apply bpow_mag_gt. + + apply bpow_lt; omega. +Qed. + +(* mag y <= fexp1 (mag x) - 2 : round_round_lt_mid applies. *) +Lemma round_round_plus_aux1 : + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + round_round_plus_hyp fexp1 fexp2 -> + forall x y, + 0 < x -> 0 < y -> + (mag y <= fexp1 (mag x) - 2)%Z -> + generic_format beta fexp1 x -> + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). +Proof. +assert (Hbeta : (2 <= beta)%Z). +{ destruct beta as (beta_val,beta_prop). + now apply Zle_bool_imp_le. } +intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Hly Fx. +assert (Lxy : mag (x + y) = mag x :> Z); + [now apply (mag_plus_separated fexp1); [|apply Rlt_le| |omega]|]. +destruct Hexp as (_,(_,(_,Hexp4))). +assert (Hf2 : (fexp2 (mag x) <= fexp1 (mag x))%Z); + [now apply Hexp4; omega|]. +assert (Bpow2 : bpow (- 2) <= / 2 * / 2). +{ replace (/2 * /2) with (/4) by field. + rewrite (bpow_opp _ 2). + apply Rinv_le; [lra|]. + apply (IZR_le (2 * 2) (beta * (beta * 1))). + rewrite Zmult_1_r. + now apply Zmult_le_compat; omega. } +assert (P2 : (0 < 2)%Z) by omega. +unfold round_round_eq. +apply round_round_lt_mid. +- exact Vfexp1. +- exact Vfexp2. +- lra. +- now rewrite Lxy. +- rewrite Lxy. + assert (fexp1 (mag x) < mag x)%Z; [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. +- unfold midp. + apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))). + apply (Rlt_le_trans _ _ _ (proj2 (round_round_plus_aux1_aux 2 P2 fexp1 x y Px + Py Hly Lxy Fx))). + ring_simplify. + rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. + unfold cexp; rewrite Lxy. + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. + bpow_simplify. + apply (Rle_trans _ _ _ Bpow2). + rewrite <- (Rmult_1_r (/ 2)) at 3. + apply Rmult_le_compat_l; lra. +- rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. + unfold round, F2R, scaled_mantissa, cexp; simpl; rewrite Lxy. + intro Hf2'. + apply (Rmult_lt_reg_r (bpow (- fexp1 (mag x)))); + [now apply bpow_gt_0|]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. + bpow_simplify. + apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))). + unfold midp; ring_simplify. + apply (Rlt_le_trans _ _ _ (proj2 (round_round_plus_aux1_aux 2 P2 fexp1 x y Px + Py Hly Lxy Fx))). + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|]. + rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. + unfold cexp; rewrite Lxy, Rmult_minus_distr_r; bpow_simplify. + apply (Rle_trans _ _ _ Bpow2). + rewrite <- (Rmult_1_r (/ 2)) at 3; rewrite <- Rmult_minus_distr_l. + apply Rmult_le_compat_l; [lra|]. + 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 Raux.bpow, Z.pow_pos; simpl. + apply Rinv_le; [lra|]. + apply IZR_le; omega. } +Qed. + +(* round_round_plus_aux{0,1} together *) +Lemma round_round_plus_aux2 : + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + round_round_plus_hyp fexp1 fexp2 -> + forall x y, + 0 < x -> 0 < y -> y <= x -> + generic_format beta fexp1 x -> + generic_format beta fexp1 y -> + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). +Proof. +intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Hyx Fx Fy. +unfold round_round_eq. +destruct (Zle_or_lt (mag y) (fexp1 (mag x) - 2)) as [Hly|Hly]. +- (* mag y <= fexp1 (mag x) - 2 *) + now apply round_round_plus_aux1. +- (* fexp1 (mag x) - 2 < mag y *) + rewrite (round_generic beta fexp2). + + reflexivity. + + now apply valid_rnd_N. + + assert (Hf1 : (fexp1 (mag x) - 1 <= mag y)%Z); [omega|]. + now apply (round_round_plus_aux0 fexp1). +Qed. + +Lemma round_round_plus_aux : + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + round_round_plus_hyp fexp1 fexp2 -> + forall x y, + 0 <= x -> 0 <= y -> + generic_format beta fexp1 x -> + generic_format beta fexp1 y -> + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). +Proof. +intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Nnx Nny Fx Fy. +unfold round_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_mag 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_mag 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 round_round_plus_aux2. + * now apply round_round_plus_aux2. +Qed. + +Lemma round_round_minus_aux0_aux : + forall (fexp1 fexp2 : Z -> Z), + forall x y, + (fexp2 (mag (x - y))%Z <= fexp1 (mag x))%Z -> + (fexp2 (mag (x - y))%Z <= fexp1 (mag y))%Z -> + generic_format beta fexp1 x -> generic_format beta fexp1 y -> + generic_format beta fexp2 (x - y). +Proof. +intros fexp1 fexp2 x y. +replace (x - y)%R with (x + (- y))%R; [|ring]. +intros Hlnx Hlny Fx Fy. +rewrite <- (mag_opp beta y) in Hlny. +apply generic_format_opp in Fy. +now apply (round_round_plus_aux0_aux fexp1). +Qed. + +(* fexp1 (mag x) - 1 <= mag y : + * substraction is exact in the largest precision (fexp2). *) +Lemma round_round_minus_aux0 : + forall (fexp1 fexp2 : Z -> Z), + round_round_plus_hyp fexp1 fexp2 -> + forall x y, + 0 < y -> y < x -> + (fexp1 (mag x) - 1 <= mag y)%Z -> + generic_format beta fexp1 x -> generic_format beta fexp1 y -> + generic_format beta fexp2 (x - y). +Proof. +intros fexp1 fexp2 Hexp x y Py Hyx Hln Fx Fy. +assert (Px := Rlt_trans 0 y x Py Hyx). +destruct Hexp as (Hexp1,(_,(Hexp3,Hexp4))). +assert (Lyx : (mag y <= mag x)%Z); + [now apply mag_le; [|apply Rlt_le]|]. +destruct (Z.lt_ge_cases (mag x - 2) (mag y)) as [Hlt|Hge]. +- (* mag x - 2 < mag y *) + assert (Hor : (mag y = mag x :> Z) + \/ (mag y = mag x - 1 :> Z)%Z); [omega|]. + destruct Hor as [Heq|Heqm1]. + + (* mag y = mag x *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. + * apply Hexp4. + apply Z.le_trans with (mag (x - y)); [omega|]. + now apply mag_minus. + * rewrite Heq. + apply Hexp4. + apply Z.le_trans with (mag (x - y)); [omega|]. + now apply mag_minus. + + (* mag y = mag x - 1 *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. + * apply Hexp4. + apply Z.le_trans with (mag (x - y)); [omega|]. + now apply mag_minus. + * rewrite Heqm1. + apply Hexp4. + apply Zplus_le_compat_r. + now apply mag_minus. +- (* mag y <= mag x - 2 *) + destruct (mag_minus_disj x y Px Py Hge) as [Lxmy|Lxmy]. + + (* mag (x - y) = mag x *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. + * apply Hexp4. + omega. + * now rewrite Lxmy; apply Hexp3. + + (* mag (x - y) = mag x - 1 *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]; + rewrite Lxmy. + * apply Hexp1. + replace (_ + _)%Z with (mag x : Z); [|ring]. + now apply Z.le_trans with (mag y). + * apply Hexp1. + now replace (_ + _)%Z with (mag x : Z); [|ring]. +Qed. + +(* mag y <= fexp1 (mag x) - 2, + * fexp1 (mag (x - y)) - 1 <= mag y : + * substraction is exact in the largest precision (fexp2). *) +Lemma round_round_minus_aux1 : + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + round_round_plus_hyp fexp1 fexp2 -> + forall x y, + 0 < y -> y < x -> + (mag y <= fexp1 (mag x) - 2)%Z -> + (fexp1 (mag (x - y)) - 1 <= mag y)%Z -> + generic_format beta fexp1 x -> generic_format beta fexp1 y -> + generic_format beta fexp2 (x - y). +Proof. +intros fexp1 fexp2 Vfexp1 Vfexp2 Hexp x y Py Hyx Hln Hln' Fx Fy. +assert (Px := Rlt_trans 0 y x Py Hyx). +destruct Hexp as (Hexp1,(Hexp2,(Hexp3,Hexp4))). +assert (Lyx : (mag y <= mag x)%Z); + [now apply mag_le; [|apply Rlt_le]|]. +assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfy : (fexp1 (mag y) < mag y)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. +- apply Z.le_trans with (fexp1 (mag (x - y))). + + apply Hexp4; omega. + + omega. +- now apply Hexp3. +Qed. + +Lemma round_round_minus_aux2_aux : + forall (fexp : Z -> Z), + Valid_exp fexp -> + forall x y, + 0 < y -> y < x -> + (mag y <= fexp (mag x) - 1)%Z -> + generic_format beta fexp x -> + generic_format beta fexp y -> + round beta fexp Zceil (x - y) - (x - y) <= y. +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, cexp; simpl. +set (mx := Ztrunc (x * bpow (- fexp (mag x)))). +intro Fx. +assert (Hfx : (fexp (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfy : (fexp (mag y) < mag y)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +destruct (Rlt_or_le (bpow (mag x - 1)) x) as [Hx|Hx]. +- (* bpow (mag x - 1) < x *) + assert (Lxy : mag (x - y) = mag x :> Z); + [now apply (mag_minus_separated fexp); [| | | | | |omega]|]. + assert (Rxy : round beta fexp Zceil (x - y) = x). + { unfold round, F2R, scaled_mantissa, cexp; 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 plus_IZR. + apply Rplus_lt_compat_l. + apply Ropp_lt_contravar; simpl. + apply (Rmult_lt_reg_r (bpow (fexp (mag x)))); + [now apply bpow_gt_0|]. + rewrite Rmult_1_l; bpow_simplify. + apply Rlt_le_trans with (bpow (mag y)). + + rewrite <- Rabs_right at 1; [|now apply Rle_ge; apply Rlt_le]. + apply bpow_mag_gt. + + apply bpow_le. + omega. + - rewrite <- (Rplus_0_r (IZR _)) 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 (mag x - 1) *) + assert (Xpow : x = bpow (mag x - 1)). + { apply Rle_antisym; [exact Hx|]. + destruct (mag x) as (ex, Hex); simpl. + rewrite <- (Rabs_right x); [|now apply Rle_ge; apply Rlt_le]. + apply Hex. + now apply Rgt_not_eq. } + assert (Lxy : (mag (x - y) = mag x - 1 :> Z)%Z). + { apply Zle_antisym. + - apply mag_le_bpow. + + apply Rminus_eq_contra. + now intro Hx'; rewrite Hx' in Hxy; apply (Rlt_irrefl y). + + rewrite Rabs_right; lra. + - apply (mag_minus_lb beta x y Px Py). + omega. } + assert (Hfx1 : (fexp (mag x - 1) < mag x - 1)%Z); + [now apply (valid_exp_large fexp (mag y)); [|omega]|]. + assert (Rxy : round beta fexp Zceil (x - y) <= x). + { rewrite Xpow at 2. + unfold round, F2R, scaled_mantissa, cexp; simpl. + rewrite Lxy. + apply (Rmult_le_reg_r (bpow (- fexp (mag x - 1)%Z))); + [now apply bpow_gt_0|]. + bpow_simplify. + rewrite <- (IZR_Zpower beta (_ - _ - _)); [|omega]. + apply IZR_le. + apply Zceil_glb. + rewrite IZR_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. + +(* mag y <= fexp1 (mag x) - 2 : + * mag y <= fexp1 (mag (x - y)) - 2 : + * round_round_gt_mid applies. *) +Lemma round_round_minus_aux2 : + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + round_round_plus_hyp fexp1 fexp2 -> + forall x y, + 0 < y -> y < x -> + (mag y <= fexp1 (mag x) - 2)%Z -> + (mag y <= fexp1 (mag (x - y)) - 2)%Z -> + generic_format beta fexp1 x -> + generic_format beta fexp1 y -> + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). +Proof. +assert (Hbeta : (2 <= beta)%Z). +{ destruct beta as (beta_val,beta_prop). + now apply Zle_bool_imp_le. } +intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Py Hxy Hly Hly' Fx Fy. +assert (Px := Rlt_trans 0 y x Py Hxy). +destruct Hexp as (_,(_,(_,Hexp4))). +assert (Hf2 : (fexp2 (mag x) <= fexp1 (mag x))%Z); + [now apply Hexp4; omega|]. +assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Bpow2 : bpow (- 2) <= / 2 * / 2). +{ replace (/2 * /2) with (/4) by field. + rewrite (bpow_opp _ 2). + apply Rinv_le; [lra|]. + apply (IZR_le (2 * 2) (beta * (beta * 1))). + rewrite Zmult_1_r. + now apply Zmult_le_compat; omega. } +assert (Ly : y < bpow (mag y)). +{ apply Rabs_lt_inv. + apply bpow_mag_gt. } +unfold round_round_eq. +apply round_round_gt_mid. +- exact Vfexp1. +- exact Vfexp2. +- lra. +- apply Hexp4; omega. +- assert (fexp1 (mag (x - y)) < mag (x - y))%Z; [|omega]. + apply (valid_exp_large fexp1 (mag x - 1)). + + apply (valid_exp_large fexp1 (mag y)); [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. + + now apply mag_minus_lb; [| |omega]. +- unfold midp'. + apply (Rplus_lt_reg_r (/ 2 * ulp beta fexp1 (x - y) - (x - y))). + ring_simplify. + replace (_ + _) with (round beta fexp1 Zceil (x - y) - (x - y)) by ring. + apply Rlt_le_trans with (bpow (fexp1 (mag (x - y)) - 2)). + + apply Rle_lt_trans with y; + [now apply round_round_minus_aux2_aux; try assumption; omega|]. + apply (Rlt_le_trans _ _ _ Ly). + now apply bpow_le. + + rewrite ulp_neq_0;[idtac|now apply sym_not_eq, Rlt_not_eq, Rgt_minus]. + unfold cexp. + replace (_ - 2)%Z with (fexp1 (mag (x - y)) - 1 - 1)%Z by ring. + unfold Zminus at 1; rewrite bpow_plus. + rewrite Rmult_comm. + apply Rmult_le_compat. + * now apply bpow_ge_0. + * now apply bpow_ge_0. + * unfold Raux.bpow, Z.pow_pos; simpl. + rewrite Zmult_1_r; apply Rinv_le. + lra. + now apply IZR_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 round_round_minus_aux2_aux; try assumption; omega|]. + apply (Rlt_le_trans _ _ _ Ly). + apply Rle_trans with (bpow (fexp1 (mag (x - y)) - 2)); + [now apply bpow_le|]. + replace (_ - 2)%Z with (fexp1 (mag (x - y)) - 1 - 1)%Z by ring. + unfold Zminus at 1; rewrite bpow_plus. + rewrite <- Rmult_minus_distr_l. + rewrite Rmult_comm; apply Rmult_le_compat. + + apply bpow_ge_0. + + apply bpow_ge_0. + + unfold Raux.bpow, Z.pow_pos; simpl. + rewrite Zmult_1_r; apply Rinv_le; [lra|]. + now apply IZR_le. + + rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, Rgt_minus. + unfold cexp. + apply (Rplus_le_reg_r (bpow (fexp2 (mag (x - y))))); ring_simplify. + apply Rle_trans with (2 * bpow (fexp1 (mag (x - y)) - 1)). + * rewrite double. + apply Rplus_le_compat_l. + now apply bpow_le. + * unfold Zminus; rewrite bpow_plus. + rewrite Rmult_comm; rewrite Rmult_assoc. + rewrite <- Rmult_1_r. + apply Rmult_le_compat_l; [now apply bpow_ge_0|]. + unfold Raux.bpow, Z.pow_pos; simpl. + rewrite Zmult_1_r. + apply IZR_le, Rinv_le in Hbeta. + simpl in Hbeta. + lra. + apply Rlt_0_2. +Qed. + +(* round_round_minus_aux{0,1,2} together *) +Lemma round_round_minus_aux3 : + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + round_round_plus_hyp fexp1 fexp2 -> + forall x y, + 0 < y -> y <= x -> + generic_format beta fexp1 x -> + generic_format beta fexp1 y -> + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). +Proof. +intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Py Hyx Fx Fy. +assert (Px := Rlt_le_trans 0 y x Py Hyx). +unfold round_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 (mag y) (fexp1 (mag x) - 2)) as [Hly|Hly]. + + (* mag y <= fexp1 (mag x) - 2 *) + destruct (Zle_or_lt (mag y) (fexp1 (mag (x - y)) - 2)) + as [Hly'|Hly']. + * (* mag y <= fexp1 (mag (x - y)) - 2 *) + now apply round_round_minus_aux2. + * (* fexp1 (mag (x - y)) - 2 < mag y *) + { rewrite (round_generic beta fexp2). + - reflexivity. + - now apply valid_rnd_N. + - assert (Hf1 : (fexp1 (mag (x - y)) - 1 <= mag y)%Z); [omega|]. + now apply (round_round_minus_aux1 fexp1). } + + rewrite (round_generic beta fexp2). + * reflexivity. + * now apply valid_rnd_N. + * assert (Hf1 : (fexp1 (mag x) - 1 <= mag y)%Z); [omega|]. + now apply (round_round_minus_aux0 fexp1). +Qed. + +Lemma round_round_minus_aux : + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + round_round_plus_hyp fexp1 fexp2 -> + forall x y, + 0 <= x -> 0 <= y -> + generic_format beta fexp1 x -> + generic_format beta fexp1 y -> + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). +Proof. +intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Nnx Nny Fx Fy. +unfold round_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_mag 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_mag 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 round_round_minus_aux3. + * (* y <= x *) + now apply round_round_minus_aux3. +Qed. + +Lemma round_round_plus : + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + round_round_plus_hyp fexp1 fexp2 -> + forall x y, + generic_format beta fexp1 x -> + generic_format beta fexp1 y -> + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). +Proof. +intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Fx Fy. +unfold round_round_eq. +destruct (Rlt_or_le x 0) as [Sx|Sx]; destruct (Rlt_or_le y 0) as [Sy|Sy]. +- (* x < 0, y < 0 *) + replace (x + y) with (- (- x - y)); [|ring]. + 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 round_round_plus_aux. +- (* x < 0, 0 <= y *) + replace (x + y) with (y - (- x)); [|ring]. + assert (Px : 0 <= - x); [lra|]. + apply generic_format_opp in Fx. + now apply round_round_minus_aux. +- (* 0 <= x, y < 0 *) + replace (x + y) with (x - (- y)); [|ring]. + assert (Py : 0 <= - y); [lra|]. + apply generic_format_opp in Fy. + now apply round_round_minus_aux. +- (* 0 <= x, 0 <= y *) + now apply round_round_plus_aux. +Qed. + +Lemma round_round_minus : + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + round_round_plus_hyp fexp1 fexp2 -> + forall x y, + generic_format beta fexp1 x -> + generic_format beta fexp1 y -> + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). +Proof. +intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Fx Fy. +unfold Rminus. +apply generic_format_opp in Fy. +now apply round_round_plus. +Qed. + +Section Double_round_plus_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_round_round_plus_hyp : + (2 * prec + 1 <= prec')%Z -> + round_round_plus_hyp (FLX_exp prec) (FLX_exp prec'). +Proof. +intros Hprec. +unfold FLX_exp. +unfold round_round_plus_hyp; split; [|split; [|split]]; +intros ex ey; try omega. +unfold Prec_gt_0 in prec_gt_0_. +omega. +Qed. + +Theorem round_round_plus_FLX : + forall choice1 choice2, + (2 * prec + 1 <= prec')%Z -> + forall x y, + FLX_format beta prec x -> FLX_format beta prec y -> + round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x + y). +Proof. +intros choice1 choice2 Hprec x y Fx Fy. +apply round_round_plus. +- now apply FLX_exp_valid. +- now apply FLX_exp_valid. +- now apply FLX_round_round_plus_hyp. +- now apply generic_format_FLX. +- now apply generic_format_FLX. +Qed. + +Theorem round_round_minus_FLX : + forall choice1 choice2, + (2 * prec + 1 <= prec')%Z -> + forall x y, + FLX_format beta prec x -> FLX_format beta prec y -> + round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x - y). +Proof. +intros choice1 choice2 Hprec x y Fx Fy. +apply round_round_minus. +- now apply FLX_exp_valid. +- now apply FLX_exp_valid. +- now apply FLX_round_round_plus_hyp. +- now apply generic_format_FLX. +- now apply generic_format_FLX. +Qed. + +End Double_round_plus_FLX. + +Section Double_round_plus_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_round_round_plus_hyp : + (emin' <= emin)%Z -> (2 * prec + 1 <= prec')%Z -> + round_round_plus_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). +Proof. +intros Hemin Hprec. +unfold FLT_exp. +unfold round_round_plus_hyp; split; [|split; [|split]]; intros ex ey. +- generalize (Zmax_spec (ex + 1 - prec) emin). + generalize (Zmax_spec (ex - prec') emin'). + generalize (Zmax_spec (ey - prec) emin). + 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 round_round_plus_FLT : + forall choice1 choice2, + (emin' <= emin)%Z -> (2 * prec + 1 <= prec')%Z -> + forall x y, + FLT_format beta emin prec x -> FLT_format beta emin prec y -> + round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') + choice1 choice2 (x + y). +Proof. +intros choice1 choice2 Hemin Hprec x y Fx Fy. +apply round_round_plus. +- now apply FLT_exp_valid. +- now apply FLT_exp_valid. +- now apply FLT_round_round_plus_hyp. +- now apply generic_format_FLT. +- now apply generic_format_FLT. +Qed. + +Theorem round_round_minus_FLT : + forall choice1 choice2, + (emin' <= emin)%Z -> (2 * prec + 1 <= prec')%Z -> + forall x y, + FLT_format beta emin prec x -> FLT_format beta emin prec y -> + round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') + choice1 choice2 (x - y). +Proof. +intros choice1 choice2 Hemin Hprec x y Fx Fy. +apply round_round_minus. +- now apply FLT_exp_valid. +- now apply FLT_exp_valid. +- now apply FLT_round_round_plus_hyp. +- now apply generic_format_FLT. +- now apply generic_format_FLT. +Qed. + +End Double_round_plus_FLT. + +Section Double_round_plus_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_round_round_plus_hyp : + (emin' + prec' <= emin + 1)%Z -> (2 * prec + 1 <= prec')%Z -> + round_round_plus_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). +Proof. +intros Hemin Hprec. +unfold FTZ_exp. +unfold Prec_gt_0 in *. +unfold round_round_plus_hyp; split; [|split; [|split]]; intros ex ey. +- destruct (Z.ltb_spec (ex + 1 - prec) emin); + destruct (Z.ltb_spec (ex - prec') emin'); + destruct (Z.ltb_spec (ey - prec) emin); + 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 round_round_plus_FTZ : + forall choice1 choice2, + (emin' + prec' <= emin + 1)%Z -> (2 * prec + 1 <= prec')%Z -> + forall x y, + FTZ_format beta emin prec x -> FTZ_format beta emin prec y -> + round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') + choice1 choice2 (x + y). +Proof. +intros choice1 choice2 Hemin Hprec x y Fx Fy. +apply round_round_plus. +- now apply FTZ_exp_valid. +- now apply FTZ_exp_valid. +- now apply FTZ_round_round_plus_hyp. +- now apply generic_format_FTZ. +- now apply generic_format_FTZ. +Qed. + +Theorem round_round_minus_FTZ : + forall choice1 choice2, + (emin' + prec' <= emin + 1)%Z -> (2 * prec + 1 <= prec')%Z -> + forall x y, + FTZ_format beta emin prec x -> FTZ_format beta emin prec y -> + round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') + choice1 choice2 (x - y). +Proof. +intros choice1 choice2 Hemin Hprec x y Fx Fy. +apply round_round_minus. +- now apply FTZ_exp_valid. +- now apply FTZ_exp_valid. +- now apply FTZ_round_round_plus_hyp. +- now apply generic_format_FTZ. +- now apply generic_format_FTZ. +Qed. + +End Double_round_plus_FTZ. + +Section Double_round_plus_radix_ge_3. + +Definition round_round_plus_radix_ge_3_hyp fexp1 fexp2 := + (forall ex ey, (fexp1 (ex + 1) <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z) + /\ (forall ex ey, (fexp1 (ex - 1) + 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z) + /\ (forall ex ey, (fexp1 ex <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z) + /\ (forall ex ey, (ex - 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z). + +(* fexp1 (mag x) <= mag y : + * addition is exact in the largest precision (fexp2). *) +Lemma round_round_plus_radix_ge_3_aux0 : + forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> + forall x y, + (0 < y)%R -> (y <= x)%R -> + (fexp1 (mag x) <= mag y)%Z -> + generic_format beta fexp1 x -> generic_format beta fexp1 y -> + generic_format beta fexp2 (x + y). +Proof. +intros fexp1 fexp2 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 (mag y) (fexp1 (mag x))) as [Hle|Hgt]. +- (* mag y <= fexp1 (mag x) *) + assert (Lxy : mag (x + y) = mag x :> Z); + [now apply (mag_plus_separated fexp1)|]. + apply (round_round_plus_aux0_aux fexp1); + [| |assumption|assumption]; rewrite Lxy. + + now apply Hexp4; omega. + + now apply Hexp3; omega. +- (* fexp1 (mag x) < mag y *) + apply (round_round_plus_aux0_aux fexp1); [| |assumption|assumption]. + destruct (mag_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. + + now apply Hexp4; omega. + + apply Hexp2; apply (mag_le beta y x Py) in Hyx. + replace (_ - _)%Z with (mag x : Z) by ring. + omega. + + destruct (mag_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy. + * now apply Hexp3; omega. + * apply Hexp2. + replace (_ - _)%Z with (mag x : Z) by ring. + omega. +Qed. + +(* mag y <= fexp1 (mag x) - 1 : round_round_lt_mid applies. *) +Lemma round_round_plus_radix_ge_3_aux1 : + (3 <= beta)%Z -> + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> + forall x y, + 0 < x -> 0 < y -> + (mag y <= fexp1 (mag x) - 1)%Z -> + generic_format beta fexp1 x -> + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). +Proof. +intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Hly Fx. +assert (Lxy : mag (x + y) = mag x :> Z); + [now apply (mag_plus_separated fexp1); [|apply Rlt_le| |omega]|]. +destruct Hexp as (_,(_,(_,Hexp4))). +assert (Hf2 : (fexp2 (mag x) <= fexp1 (mag x))%Z); + [now apply Hexp4; omega|]. +assert (Bpow3 : bpow (- 1) <= / 3). +{ unfold Raux.bpow, Z.pow_pos; simpl. + rewrite Zmult_1_r. + apply Rinv_le; [lra|]. + now apply IZR_le. } +assert (P1 : (0 < 1)%Z) by omega. +unfold round_round_eq. +apply round_round_lt_mid. +- exact Vfexp1. +- exact Vfexp2. +- lra. +- now rewrite Lxy. +- rewrite Lxy. + assert (fexp1 (mag x) < mag x)%Z; [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. +- unfold midp. + apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))). + apply (Rlt_le_trans _ _ _ (proj2 (round_round_plus_aux1_aux 1 P1 fexp1 x y Px + Py Hly Lxy Fx))). + ring_simplify. + rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. + unfold cexp; rewrite Lxy. + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); + [now apply bpow_gt_0|]. + bpow_simplify. + apply (Rle_trans _ _ _ Bpow3); lra. +- rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. + unfold round, F2R, scaled_mantissa, cexp; simpl; rewrite Lxy. + intro Hf2'. + unfold midp. + apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))); ring_simplify. + rewrite <- Rmult_minus_distr_l. + apply (Rlt_le_trans _ _ _ (proj2 (round_round_plus_aux1_aux 1 P1 fexp1 x y Px + Py Hly Lxy Fx))). + rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat]. + unfold cexp; rewrite Lxy. + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); + [now apply bpow_gt_0|]. + rewrite (Rmult_assoc (/ 2)). + rewrite Rmult_minus_distr_r. + 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. + +(* round_round_plus_radix_ge_3_aux{0,1} together *) +Lemma round_round_plus_radix_ge_3_aux2 : + (3 <= beta)%Z -> + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> + forall x y, + 0 < y -> y <= x -> + generic_format beta fexp1 x -> + generic_format beta fexp1 y -> + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). +Proof. +intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Py Hyx Fx Fy. +assert (Px := Rlt_le_trans 0 y x Py Hyx). +unfold round_round_eq. +destruct (Zle_or_lt (mag y) (fexp1 (mag x) - 1)) as [Hly|Hly]. +- (* mag y <= fexp1 (mag x) - 1 *) + now apply round_round_plus_radix_ge_3_aux1. +- (* fexp1 (mag x) - 1 < mag y *) + rewrite (round_generic beta fexp2). + + reflexivity. + + now apply valid_rnd_N. + + assert (Hf1 : (fexp1 (mag x) <= mag y)%Z); [omega|]. + now apply (round_round_plus_radix_ge_3_aux0 fexp1). +Qed. + +Lemma round_round_plus_radix_ge_3_aux : + (3 <= beta)%Z -> + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> + forall x y, + 0 <= x -> 0 <= y -> + generic_format beta fexp1 x -> + generic_format beta fexp1 y -> + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). +Proof. +intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Nnx Nny Fx Fy. +unfold round_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_mag 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_mag 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 round_round_plus_radix_ge_3_aux2. + * now apply round_round_plus_radix_ge_3_aux2. +Qed. + +(* fexp1 (mag x) <= mag y : + * substraction is exact in the largest precision (fexp2). *) +Lemma round_round_minus_radix_ge_3_aux0 : + forall (fexp1 fexp2 : Z -> Z), + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> + forall x y, + 0 < y -> y < x -> + (fexp1 (mag x) <= mag y)%Z -> + generic_format beta fexp1 x -> generic_format beta fexp1 y -> + generic_format beta fexp2 (x - y). +Proof. +intros fexp1 fexp2 Hexp x y Py Hyx Hln Fx Fy. +assert (Px := Rlt_trans 0 y x Py Hyx). +destruct Hexp as (Hexp1,(_,(Hexp3,Hexp4))). +assert (Lyx : (mag y <= mag x)%Z); + [now apply mag_le; [|apply Rlt_le]|]. +destruct (Z.lt_ge_cases (mag x - 2) (mag y)) as [Hlt|Hge]. +- (* mag x - 2 < mag y *) + assert (Hor : (mag y = mag x :> Z) + \/ (mag y = mag x - 1 :> Z)%Z); [omega|]. + destruct Hor as [Heq|Heqm1]. + + (* mag y = mag x *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. + * apply Hexp4. + apply Z.le_trans with (mag (x - y)); [omega|]. + now apply mag_minus. + * rewrite Heq. + apply Hexp4. + apply Z.le_trans with (mag (x - y)); [omega|]. + now apply mag_minus. + + (* mag y = mag x - 1 *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. + * apply Hexp4. + apply Z.le_trans with (mag (x - y)); [omega|]. + now apply mag_minus. + * rewrite Heqm1. + apply Hexp4. + apply Zplus_le_compat_r. + now apply mag_minus. +- (* mag y <= mag x - 2 *) + destruct (mag_minus_disj x y Px Py Hge) as [Lxmy|Lxmy]. + + (* mag (x - y) = mag x *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. + * apply Hexp4. + omega. + * now rewrite Lxmy; apply Hexp3. + + (* mag (x - y) = mag x - 1 *) + apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]; + rewrite Lxmy. + * apply Hexp1. + replace (_ + _)%Z with (mag x : Z); [|ring]. + now apply Z.le_trans with (mag y). + * apply Hexp1. + now replace (_ + _)%Z with (mag x : Z); [|ring]. +Qed. + +(* mag y <= fexp1 (mag x) - 1, + * fexp1 (mag (x - y)) <= mag y : + * substraction is exact in the largest precision (fexp2). *) +Lemma round_round_minus_radix_ge_3_aux1 : + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> + forall x y, + 0 < y -> y < x -> + (mag y <= fexp1 (mag x) - 1)%Z -> + (fexp1 (mag (x - y)) <= mag y)%Z -> + generic_format beta fexp1 x -> generic_format beta fexp1 y -> + generic_format beta fexp2 (x - y). +Proof. +intros fexp1 fexp2 Vfexp1 Vfexp2 Hexp x y Py Hyx Hln Hln' Fx Fy. +assert (Px := Rlt_trans 0 y x Py Hyx). +destruct Hexp as (Hexp1,(Hexp2,(Hexp3,Hexp4))). +assert (Lyx : (mag y <= mag x)%Z); + [now apply mag_le; [|apply Rlt_le]|]. +assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfy : (fexp1 (mag y) < mag y)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy]. +- apply Z.le_trans with (fexp1 (mag (x - y))). + + apply Hexp4; omega. + + omega. +- now apply Hexp3. +Qed. + +(* mag y <= fexp1 (mag x) - 1 : + * mag y <= fexp1 (mag (x - y)) - 1 : + * round_round_gt_mid applies. *) +Lemma round_round_minus_radix_ge_3_aux2 : + (3 <= beta)%Z -> + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> + forall x y, + 0 < y -> y < x -> + (mag y <= fexp1 (mag x) - 1)%Z -> + (mag y <= fexp1 (mag (x - y)) - 1)%Z -> + generic_format beta fexp1 x -> + generic_format beta fexp1 y -> + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). +Proof. +intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Py Hxy Hly Hly' Fx Fy. +assert (Px := Rlt_trans 0 y x Py Hxy). +destruct Hexp as (_,(_,(_,Hexp4))). +assert (Hf2 : (fexp2 (mag x) <= fexp1 (mag x))%Z); + [now apply Hexp4; omega|]. +assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Bpow3 : bpow (- 1) <= / 3). +{ unfold Raux.bpow, Z.pow_pos; simpl. + rewrite Zmult_1_r. + apply Rinv_le; [lra|]. + now apply IZR_le. } +assert (Ly : y < bpow (mag y)). +{ apply Rabs_lt_inv. + apply bpow_mag_gt. } +unfold round_round_eq. +apply round_round_gt_mid. +- exact Vfexp1. +- exact Vfexp2. +- lra. +- apply Hexp4; omega. +- assert (fexp1 (mag (x - y)) < mag (x - y))%Z; [|omega]. + apply (valid_exp_large fexp1 (mag x - 1)). + + apply (valid_exp_large fexp1 (mag y)); [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. + + now apply mag_minus_lb; [| |omega]. +- unfold midp'. + apply (Rplus_lt_reg_r (/ 2 * ulp beta fexp1 (x - y) - (x - y))). + ring_simplify. + replace (_ + _) with (round beta fexp1 Zceil (x - y) - (x - y)) by ring. + apply Rlt_le_trans with (bpow (fexp1 (mag (x - y)) - 1)). + + apply Rle_lt_trans with y; + [now apply round_round_minus_aux2_aux|]. + apply (Rlt_le_trans _ _ _ Ly). + now apply bpow_le. + + rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rgt_minus]. + unfold cexp. + unfold Zminus at 1; rewrite bpow_plus. + rewrite Rmult_comm. + apply Rmult_le_compat_r; [now apply bpow_ge_0|]. + unfold Raux.bpow, Z.pow_pos; simpl. + rewrite Zmult_1_r; apply Rinv_le; [lra|]. + now apply IZR_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 round_round_minus_aux2_aux|]. + apply (Rlt_le_trans _ _ _ Ly). + apply Rle_trans with (bpow (fexp1 (mag (x - y)) - 1)); + [now apply bpow_le|]. + rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, Rgt_minus. + unfold cexp. + apply (Rmult_le_reg_r (bpow (- fexp1 (mag (x - y))))); + [now apply bpow_gt_0|]. + rewrite Rmult_assoc. + rewrite Rmult_minus_distr_r. + bpow_simplify. + apply Rle_trans with (/ 3). + + unfold Raux.bpow, Z.pow_pos; simpl. + rewrite Zmult_1_r; apply Rinv_le; [lra|]. + now apply IZR_le. + + replace (/ 3) with (/ 2 * (2 / 3)) by field. + apply Rmult_le_compat_l; [lra|]. + apply (Rplus_le_reg_r (- 1)); ring_simplify. + replace (_ - _) with (- / 3) by field. + apply Ropp_le_contravar. + apply Rle_trans with (bpow (- 1)). + * apply bpow_le; omega. + * unfold Raux.bpow, Z.pow_pos; simpl. + rewrite Zmult_1_r; apply Rinv_le; [lra|]. + now apply IZR_le. +Qed. + +(* round_round_minus_aux{0,1,2} together *) +Lemma round_round_minus_radix_ge_3_aux3 : + (3 <= beta)%Z -> + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> + forall x y, + 0 < y -> y <= x -> + generic_format beta fexp1 x -> + generic_format beta fexp1 y -> + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). +Proof. +intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Py Hyx Fx Fy. +assert (Px := Rlt_le_trans 0 y x Py Hyx). +unfold round_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 (mag y) (fexp1 (mag x) - 1)) as [Hly|Hly]. + + (* mag y <= fexp1 (mag x) - 1 *) + destruct (Zle_or_lt (mag y) (fexp1 (mag (x - y)) - 1)) + as [Hly'|Hly']. + * (* mag y <= fexp1 (mag (x - y)) - 1 *) + now apply round_round_minus_radix_ge_3_aux2. + * (* fexp1 (mag (x - y)) - 1 < mag y *) + { rewrite (round_generic beta fexp2). + - reflexivity. + - now apply valid_rnd_N. + - assert (Hf1 : (fexp1 (mag (x - y)) <= mag y)%Z); [omega|]. + now apply (round_round_minus_radix_ge_3_aux1 fexp1). } + + rewrite (round_generic beta fexp2). + * reflexivity. + * now apply valid_rnd_N. + * assert (Hf1 : (fexp1 (mag x) <= mag y)%Z); [omega|]. + now apply (round_round_minus_radix_ge_3_aux0 fexp1). +Qed. + +Lemma round_round_minus_radix_ge_3_aux : + (3 <= beta)%Z -> + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> + forall x y, + 0 <= x -> 0 <= y -> + generic_format beta fexp1 x -> + generic_format beta fexp1 y -> + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). +Proof. +intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Nnx Nny Fx Fy. +unfold round_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_mag 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_mag 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 round_round_minus_radix_ge_3_aux3. + * (* y <= x *) + now apply round_round_minus_radix_ge_3_aux3. +Qed. + +Lemma round_round_plus_radix_ge_3 : + (3 <= beta)%Z -> + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> + forall x y, + generic_format beta fexp1 x -> + generic_format beta fexp1 y -> + round_round_eq fexp1 fexp2 choice1 choice2 (x + y). +Proof. +intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Fx Fy. +unfold round_round_eq. +destruct (Rlt_or_le x 0) as [Sx|Sx]; destruct (Rlt_or_le y 0) as [Sy|Sy]. +- (* x < 0, y < 0 *) + replace (x + y) with (- (- x - y)); [|ring]. + 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 round_round_plus_radix_ge_3_aux. +- (* x < 0, 0 <= y *) + replace (x + y) with (y - (- x)); [|ring]. + assert (Px : 0 <= - x); [lra|]. + apply generic_format_opp in Fx. + now apply round_round_minus_radix_ge_3_aux. +- (* 0 <= x, y < 0 *) + replace (x + y) with (x - (- y)); [|ring]. + assert (Py : 0 <= - y); [lra|]. + apply generic_format_opp in Fy. + now apply round_round_minus_radix_ge_3_aux. +- (* 0 <= x, 0 <= y *) + now apply round_round_plus_radix_ge_3_aux. +Qed. + +Lemma round_round_minus_radix_ge_3 : + (3 <= beta)%Z -> + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + round_round_plus_radix_ge_3_hyp fexp1 fexp2 -> + forall x y, + generic_format beta fexp1 x -> + generic_format beta fexp1 y -> + round_round_eq fexp1 fexp2 choice1 choice2 (x - y). +Proof. +intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Fx Fy. +unfold Rminus. +apply generic_format_opp in Fy. +now apply round_round_plus_radix_ge_3. +Qed. + +Section Double_round_plus_radix_ge_3_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_round_round_plus_radix_ge_3_hyp : + (2 * prec <= prec')%Z -> + round_round_plus_radix_ge_3_hyp (FLX_exp prec) (FLX_exp prec'). +Proof. +intros Hprec. +unfold FLX_exp. +unfold round_round_plus_radix_ge_3_hyp; split; [|split; [|split]]; +intros ex ey; try omega. +unfold Prec_gt_0 in prec_gt_0_. +omega. +Qed. + +Theorem round_round_plus_radix_ge_3_FLX : + (3 <= beta)%Z -> + forall choice1 choice2, + (2 * prec <= prec')%Z -> + forall x y, + FLX_format beta prec x -> FLX_format beta prec y -> + round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x + y). +Proof. +intros Hbeta choice1 choice2 Hprec x y Fx Fy. +apply round_round_plus_radix_ge_3. +- exact Hbeta. +- now apply FLX_exp_valid. +- now apply FLX_exp_valid. +- now apply FLX_round_round_plus_radix_ge_3_hyp. +- now apply generic_format_FLX. +- now apply generic_format_FLX. +Qed. + +Theorem round_round_minus_radix_ge_3_FLX : + (3 <= beta)%Z -> + forall choice1 choice2, + (2 * prec <= prec')%Z -> + forall x y, + FLX_format beta prec x -> FLX_format beta prec y -> + round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x - y). +Proof. +intros Hbeta choice1 choice2 Hprec x y Fx Fy. +apply round_round_minus_radix_ge_3. +- exact Hbeta. +- now apply FLX_exp_valid. +- now apply FLX_exp_valid. +- now apply FLX_round_round_plus_radix_ge_3_hyp. +- now apply generic_format_FLX. +- now apply generic_format_FLX. +Qed. + +End Double_round_plus_radix_ge_3_FLX. + +Section Double_round_plus_radix_ge_3_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_round_round_plus_radix_ge_3_hyp : + (emin' <= emin)%Z -> (2 * prec <= prec')%Z -> + round_round_plus_radix_ge_3_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). +Proof. +intros Hemin Hprec. +unfold FLT_exp. +unfold round_round_plus_radix_ge_3_hyp; split; [|split; [|split]]; intros ex ey. +- generalize (Zmax_spec (ex + 1 - prec) emin). + generalize (Zmax_spec (ex - prec') emin'). + generalize (Zmax_spec (ey - prec) emin). + 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 round_round_plus_radix_ge_3_FLT : + (3 <= beta)%Z -> + forall choice1 choice2, + (emin' <= emin)%Z -> (2 * prec <= prec')%Z -> + forall x y, + FLT_format beta emin prec x -> FLT_format beta emin prec y -> + round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') + choice1 choice2 (x + y). +Proof. +intros Hbeta choice1 choice2 Hemin Hprec x y Fx Fy. +apply round_round_plus_radix_ge_3. +- exact Hbeta. +- now apply FLT_exp_valid. +- now apply FLT_exp_valid. +- now apply FLT_round_round_plus_radix_ge_3_hyp. +- now apply generic_format_FLT. +- now apply generic_format_FLT. +Qed. + +Theorem round_round_minus_radix_ge_3_FLT : + (3 <= beta)%Z -> + forall choice1 choice2, + (emin' <= emin)%Z -> (2 * prec <= prec')%Z -> + forall x y, + FLT_format beta emin prec x -> FLT_format beta emin prec y -> + round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') + choice1 choice2 (x - y). +Proof. +intros Hbeta choice1 choice2 Hemin Hprec x y Fx Fy. +apply round_round_minus_radix_ge_3. +- exact Hbeta. +- now apply FLT_exp_valid. +- now apply FLT_exp_valid. +- now apply FLT_round_round_plus_radix_ge_3_hyp. +- now apply generic_format_FLT. +- now apply generic_format_FLT. +Qed. + +End Double_round_plus_radix_ge_3_FLT. + +Section Double_round_plus_radix_ge_3_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_round_round_plus_radix_ge_3_hyp : + (emin' + prec' <= emin + 1)%Z -> (2 * prec <= prec')%Z -> + round_round_plus_radix_ge_3_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). +Proof. +intros Hemin Hprec. +unfold FTZ_exp. +unfold Prec_gt_0 in *. +unfold round_round_plus_radix_ge_3_hyp; split; [|split; [|split]]; intros ex ey. +- destruct (Z.ltb_spec (ex + 1 - prec) emin); + destruct (Z.ltb_spec (ex - prec') emin'); + destruct (Z.ltb_spec (ey - prec) emin); + 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 round_round_plus_radix_ge_3_FTZ : + (3 <= beta)%Z -> + forall choice1 choice2, + (emin' + prec' <= emin + 1)%Z -> (2 * prec <= prec')%Z -> + forall x y, + FTZ_format beta emin prec x -> FTZ_format beta emin prec y -> + round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') + choice1 choice2 (x + y). +Proof. +intros Hbeta choice1 choice2 Hemin Hprec x y Fx Fy. +apply round_round_plus_radix_ge_3. +- exact Hbeta. +- now apply FTZ_exp_valid. +- now apply FTZ_exp_valid. +- now apply FTZ_round_round_plus_radix_ge_3_hyp. +- now apply generic_format_FTZ. +- now apply generic_format_FTZ. +Qed. + +Theorem round_round_minus_radix_ge_3_FTZ : + (3 <= beta)%Z -> + forall choice1 choice2, + (emin' + prec' <= emin + 1)%Z -> (2 * prec <= prec')%Z -> + forall x y, + FTZ_format beta emin prec x -> FTZ_format beta emin prec y -> + round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') + choice1 choice2 (x - y). +Proof. +intros Hbeta choice1 choice2 Hemin Hprec x y Fx Fy. +apply round_round_minus_radix_ge_3. +- exact Hbeta. +- now apply FTZ_exp_valid. +- now apply FTZ_exp_valid. +- now apply FTZ_round_round_plus_radix_ge_3_hyp. +- now apply generic_format_FTZ. +- now apply generic_format_FTZ. +Qed. + +End Double_round_plus_radix_ge_3_FTZ. + +End Double_round_plus_radix_ge_3. + +End Double_round_plus. + +Lemma round_round_mid_cases : + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + forall x, + 0 < x -> + (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> + (fexp1 (mag x) <= mag x)%Z -> + (Rabs (x - midp fexp1 x) <= / 2 * (ulp beta fexp2 x) -> + round_round_eq fexp1 fexp2 choice1 choice2 x) -> + round_round_eq fexp1 fexp2 choice1 choice2 x. +Proof. +intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hf1. +unfold round_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_mag beta fexp1); [omega|]. +- (* ~ generic_format beta fexp1 x *) + assert (Hceil : round beta fexp1 Zceil x = rd + u1); + [now apply round_UP_DN_ulp|]. + assert (Hf2' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z); [omega|]. + destruct (Rlt_or_le (x - rd) (/ 2 * (u1 - u2))). + + (* x - rd < / 2 * (u1 - u2) *) + apply round_round_lt_mid_further_place; try assumption. + unfold midp. fold rd; fold u1; fold u2. + apply (Rplus_lt_reg_r (- rd)); ring_simplify. + now rewrite <- Rmult_minus_distr_l. + + (* / 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 round_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 round_round_sqrt_hyp fexp1 fexp2 := + (forall ex, (2 * fexp1 ex <= fexp1 (2 * ex))%Z) + /\ (forall ex, (2 * fexp1 ex <= fexp1 (2 * ex - 1))%Z) + /\ (forall ex, (fexp1 (2 * ex) < 2 * ex)%Z -> + (fexp2 ex + ex <= 2 * fexp1 ex - 2)%Z). + +Lemma mag_sqrt_disj : + forall x, + 0 < x -> + (mag x = 2 * mag (sqrt x) - 1 :> Z)%Z + \/ (mag x = 2 * mag (sqrt x) :> Z)%Z. +Proof. +intros x Px. +rewrite (mag_sqrt beta x Px). +generalize (Zdiv2_odd_eqn (mag x + 1)). +destruct Z.odd ; intros ; omega. +Qed. + +Lemma round_round_sqrt_aux : + forall fexp1 fexp2 : Z -> Z, + Valid_exp fexp1 -> Valid_exp fexp2 -> + round_round_sqrt_hyp fexp1 fexp2 -> + forall x, + 0 < x -> + (fexp2 (mag (sqrt x)) <= fexp1 (mag (sqrt x)) - 1)%Z -> + generic_format beta fexp1 x -> + / 2 * ulp beta fexp2 (sqrt x) < Rabs (sqrt x - midp fexp1 (sqrt x)). +Proof. +intros 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 (mag (sqrt x)))). +set (u2 := bpow (fexp2 (mag (sqrt x)))). +set (b := / 2 * (u1 - u2)). +set (b' := / 2 * (u1 + u2)). +unfold midp; rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, sqrt_lt_R0. +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, cexp; simpl. +set (mx := Ztrunc (x * bpow (- fexp1 (mag x)))). +set (ma := Ztrunc (a * bpow (- fexp1 (mag a)))). +intros Fx Fa. +assert (Nna : 0 <= a). +{ rewrite <- (round_0 beta fexp1 Zfloor). + 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 (mag (sqrt x)) <= fexp1 (mag (x)))%Z); + [destruct (mag_sqrt_disj x Px) as [H'|H']; rewrite H'; apply Hexp|]. +assert (Hlx : (fexp1 (2 * mag (sqrt x)) < 2 * mag (sqrt x))%Z). +{ destruct (mag_sqrt_disj x Px) as [Hlx|Hlx]. + - apply (valid_exp_large fexp1 (mag x)); [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. + - rewrite <- Hlx. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. } +assert (Hsl : a * a + u1 * a - u2 * a + b * b <= x). +{ replace (_ + _) with ((a + b) * (a + b)); [|now unfold b; field]. + rewrite <- sqrt_def; [|now apply Rlt_le]. + 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 (mag x)))); + [now apply bpow_gt_0|]. + rewrite Rmult_0_l; bpow_simplify. + unfold mx. + rewrite Ztrunc_floor; + [|now apply Rmult_le_pos; [apply Rlt_le|apply bpow_ge_0]]. + apply Req_le, IZR_eq. + apply Zfloor_imp. + split; [now apply Rmult_le_pos; [apply Rlt_le|apply bpow_ge_0]|simpl]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. + rewrite Rmult_1_l; bpow_simplify. + apply Rlt_le_trans with (bpow (2 * fexp1 (mag (sqrt x)))); + [|now apply bpow_le]. + change 2%Z with (1 + 1)%Z; rewrite Zmult_plus_distr_l; rewrite Zmult_1_l. + rewrite bpow_plus. + rewrite <- (sqrt_def x) at 1; [|now apply Rlt_le]. + assert (sqrt x < bpow (fexp1 (mag (sqrt x)))); + [|now apply Rmult_lt_compat; [apply sqrt_pos|apply sqrt_pos| |]]. + apply (Rle_lt_trans _ _ _ Hr); rewrite Za; rewrite Rplus_0_l. + unfold b'; change (bpow _) with u1. + apply Rlt_le_trans with (/ 2 * (u1 + u1)); [|lra]. + apply Rmult_lt_compat_l; [lra|]; apply Rplus_lt_compat_l. + unfold u2, u1, ulp, cexp; apply bpow_lt; omega. +- (* a <> 0 *) + assert (Pa : 0 < a); [lra|]. + assert (Hla : (mag a = mag (sqrt x) :> Z)). + { unfold a; apply mag_DN. + - exact Vfexp1. + - now fold a. } + assert (Hl' : 0 < - (u2 * a) + b * b). + { 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 (mag (sqrt x))). + - apply Rmult_lt_compat_l; [now unfold u2, ulp; apply bpow_gt_0|]. + unfold u1; rewrite <- Hla. + apply Rlt_le_trans with (a + bpow (fexp1 (mag a))). + + apply Rplus_lt_compat_l. + rewrite <- (Rmult_1_l (bpow _)) at 2. + apply Rmult_lt_compat_r; [apply bpow_gt_0|lra]. + + apply Rle_trans with (a+ ulp beta fexp1 a). + right; now rewrite ulp_neq_0. + apply (id_p_ulp_le_bpow _ _ _ _ Pa Fa). + apply Rabs_lt_inv, bpow_mag_gt. + - apply Rle_trans with (bpow (- 2) * u1 ^ 2). + + unfold pow; rewrite Rmult_1_r. + unfold u1, u2, ulp, cexp; bpow_simplify; apply bpow_le. + now apply Hexp. + + apply Rmult_le_compat. + * apply bpow_ge_0. + * apply pow2_ge_0. + * unfold Raux.bpow, Z.pow_pos; simpl; rewrite Zmult_1_r. + apply Rinv_le; [lra|]. + change 4%Z with (2 * 2)%Z; apply IZR_le, Zmult_le_compat; omega. + * rewrite <- (Rplus_0_l (u1 ^ 2)) at 1; apply Rplus_le_compat_r. + apply pow2_ge_0. } + assert (Hr' : x <= a * a + u1 * a). + { rewrite Hla in Fa. + rewrite <- Rmult_plus_distr_r. + unfold u1, ulp, cexp. + rewrite <- (Rmult_1_l (bpow _)); rewrite Fa; rewrite <- Rmult_plus_distr_r. + rewrite <- Rmult_assoc; rewrite (Rmult_comm _ (IZR ma)). + rewrite <- (Rmult_assoc (IZR ma)); bpow_simplify. + apply (Rmult_le_reg_r (bpow (- 2 * fexp1 (mag (sqrt x))))); + [now apply bpow_gt_0|bpow_simplify]. + rewrite Fx at 1; bpow_simplify. + rewrite <- IZR_Zpower; [|omega]. + rewrite <- plus_IZR, <- 2!mult_IZR. + apply IZR_le, Zlt_succ_le, lt_IZR. + unfold Z.succ; rewrite plus_IZR; do 2 rewrite mult_IZR; rewrite plus_IZR. + rewrite IZR_Zpower; [|omega]. + apply (Rmult_lt_reg_r (bpow (2 * fexp1 (mag (sqrt x))))); + [now apply bpow_gt_0|bpow_simplify]. + rewrite <- Fx. + change 2%Z with (1 + 1)%Z; rewrite Zmult_plus_distr_l; rewrite Zmult_1_l. + rewrite bpow_plus; simpl. + replace (_ * _) with (a * a + u1 * a + u1 * u1); + [|unfold u1, ulp, cexp; rewrite Fa; ring]. + apply (Rle_lt_trans _ _ _ Hsr). + rewrite Rplus_assoc; apply Rplus_lt_compat_l. + apply (Rplus_lt_reg_r (- b' * b' + / 2 * u1 * u2)); ring_simplify. + replace (_ + _) with ((a + / 2 * u1) * u2) by ring. + apply Rlt_le_trans with (bpow (mag (sqrt x)) * u2). + - apply Rmult_lt_compat_r; [now unfold u2, ulp; apply bpow_gt_0|]. + apply Rlt_le_trans with (a + u1); [lra|]. + unfold u1; fold (cexp beta fexp1 (sqrt x)). + rewrite <- cexp_DN; [|exact Vfexp1|exact Pa]; fold a. + rewrite <- ulp_neq_0; trivial. + apply id_p_ulp_le_bpow. + + exact Pa. + + now apply round_DN_pt. + + apply Rle_lt_trans with (sqrt x). + * now apply round_DN_pt. + * apply Rabs_lt_inv. + apply bpow_mag_gt. + - apply Rle_trans with (/ 2 * u1 ^ 2). + + apply Rle_trans with (bpow (- 2) * u1 ^ 2). + * unfold pow; rewrite Rmult_1_r. + unfold u2, u1, ulp, cexp. + bpow_simplify. + apply bpow_le. + rewrite Zplus_comm. + now apply Hexp. + * apply Rmult_le_compat_r; [now apply pow2_ge_0|]. + unfold Raux.bpow; simpl; unfold Z.pow_pos; simpl. + rewrite Zmult_1_r. + apply Rinv_le; [lra|]. + apply IZR_le. + rewrite <- (Zmult_1_l 2). + apply Zmult_le_compat; omega. + + assert (u2 ^ 2 < u1 ^ 2); [|unfold b'; lra]. + unfold pow; do 2 rewrite Rmult_1_r. + assert (H' : 0 <= u2); [unfold u2, ulp; apply bpow_ge_0|]. + assert (u2 < u1); [|now apply Rmult_lt_compat]. + unfold u1, u2, ulp, cexp; apply bpow_lt; omega. } + apply (Rlt_irrefl (a * a + u1 * a)). + apply Rlt_le_trans with (a * a + u1 * a - u2 * a + b * b). + + rewrite <- (Rplus_0_r (a * a + _)) at 1. + unfold Rminus; rewrite (Rplus_assoc _ _ (b * b)). + now apply Rplus_lt_compat_l. + + now apply Rle_trans with x. +Qed. + + +Lemma round_round_sqrt : + forall fexp1 fexp2 : Z -> Z, + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + round_round_sqrt_hyp fexp1 fexp2 -> + forall x, + generic_format beta fexp1 x -> + round_round_eq fexp1 fexp2 choice1 choice2 (sqrt x). +Proof. +intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x Fx. +unfold round_round_eq. +destruct (Rle_or_lt x 0) as [Npx|Px]. +- (* x <= 0 *) + rewrite (sqrt_neg _ Npx). + now rewrite round_0; [|apply valid_rnd_N]. +- (* 0 < x *) + assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; try assumption; lra|]. + assert (Hfsx : (fexp1 (mag (sqrt x)) < mag (sqrt x))%Z). + { destruct (Rle_or_lt x 1) as [Hx|Hx]. + - (* x <= 1 *) + apply (valid_exp_large fexp1 (mag x)); [exact Hfx|]. + apply mag_le; [exact Px|]. + rewrite <- (sqrt_def x) at 1; [|lra]. + rewrite <- Rmult_1_r. + apply Rmult_le_compat_l. + + 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 mag_ge_bpow. + rewrite Zeq_minus; [|reflexivity]. + unfold Raux.bpow; simpl. + apply Rabs_ge; right. + rewrite <- sqrt_1. + apply sqrt_le_1_alt. + now apply Rlt_le. } + assert (Hf2 : (fexp2 (mag (sqrt x)) <= fexp1 (mag (sqrt x)) - 1)%Z). + { assert (H : (fexp1 (2 * mag (sqrt x)) < 2 * mag (sqrt x))%Z). + { destruct (mag_sqrt_disj x Px) as [Hlx|Hlx]. + - apply (valid_exp_large fexp1 (mag x)); [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. + - rewrite <- Hlx. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. } + generalize ((proj2 (proj2 Hexp)) (mag (sqrt x)) H). + omega. } + apply round_round_mid_cases. + + exact Vfexp1. + + exact Vfexp2. + + now apply sqrt_lt_R0. + + omega. + + omega. + + intros Hmid; casetype False; apply (Rle_not_lt _ _ Hmid). + apply (round_round_sqrt_aux fexp1 fexp2 Vfexp1 Vfexp2 Hexp x Px Hf2 Fx). +Qed. + +Section Double_round_sqrt_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_round_round_sqrt_hyp : + (2 * prec + 2 <= prec')%Z -> + round_round_sqrt_hyp (FLX_exp prec) (FLX_exp prec'). +Proof. +intros Hprec. +unfold FLX_exp. +unfold Prec_gt_0 in prec_gt_0_. +unfold round_round_sqrt_hyp; split; [|split]; intro ex; omega. +Qed. + +Theorem round_round_sqrt_FLX : + forall choice1 choice2, + (2 * prec + 2 <= prec')%Z -> + forall x, + FLX_format beta prec x -> + round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (sqrt x). +Proof. +intros choice1 choice2 Hprec x Fx. +apply round_round_sqrt. +- now apply FLX_exp_valid. +- now apply FLX_exp_valid. +- now apply FLX_round_round_sqrt_hyp. +- now apply generic_format_FLX. +Qed. + +End Double_round_sqrt_FLX. + +Section Double_round_sqrt_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_round_round_sqrt_hyp : + (emin <= 0)%Z -> + ((emin' <= emin - prec - 2)%Z + \/ (2 * emin' <= emin - 4 * prec - 2)%Z) -> + (2 * prec + 2 <= prec')%Z -> + round_round_sqrt_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). +Proof. +intros Hemin Heminprec Hprec. +unfold FLT_exp. +unfold Prec_gt_0 in prec_gt_0_. +unfold round_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 round_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 -> + round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') + choice1 choice2 (sqrt x). +Proof. +intros choice1 choice2 Hemin Heminprec Hprec x Fx. +apply round_round_sqrt. +- now apply FLT_exp_valid. +- now apply FLT_exp_valid. +- now apply FLT_round_round_sqrt_hyp. +- now apply generic_format_FLT. +Qed. + +End Double_round_sqrt_FLT. + +Section Double_round_sqrt_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_round_round_sqrt_hyp : + (2 * (emin' + prec') <= emin + prec <= 1)%Z -> + (2 * prec + 2 <= prec')%Z -> + round_round_sqrt_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). +Proof. +intros Hemin Hprec. +unfold FTZ_exp. +unfold Prec_gt_0 in *. +unfold round_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 round_round_sqrt_FTZ : + (4 <= beta)%Z -> + forall choice1 choice2, + (2 * (emin' + prec') <= emin + prec <= 1)%Z -> + (2 * prec + 2 <= prec')%Z -> + forall x, + FTZ_format beta emin prec x -> + round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') + choice1 choice2 (sqrt x). +Proof. +intros Hbeta choice1 choice2 Hemin Hprec x Fx. +apply round_round_sqrt. +- now apply FTZ_exp_valid. +- now apply FTZ_exp_valid. +- now apply FTZ_round_round_sqrt_hyp. +- now apply generic_format_FTZ. +Qed. + +End Double_round_sqrt_FTZ. + +Section Double_round_sqrt_radix_ge_4. + +Definition round_round_sqrt_radix_ge_4_hyp fexp1 fexp2 := + (forall ex, (2 * fexp1 ex <= fexp1 (2 * ex))%Z) + /\ (forall ex, (2 * fexp1 ex <= fexp1 (2 * ex - 1))%Z) + /\ (forall ex, (fexp1 (2 * ex) < 2 * ex)%Z -> + (fexp2 ex + ex <= 2 * fexp1 ex - 1)%Z). + +Lemma round_round_sqrt_radix_ge_4_aux : + (4 <= beta)%Z -> + forall fexp1 fexp2 : Z -> Z, + Valid_exp fexp1 -> Valid_exp fexp2 -> + round_round_sqrt_radix_ge_4_hyp fexp1 fexp2 -> + forall x, + 0 < x -> + (fexp2 (mag (sqrt x)) <= fexp1 (mag (sqrt x)) - 1)%Z -> + generic_format beta fexp1 x -> + / 2 * ulp beta fexp2 (sqrt x) < Rabs (sqrt x - midp fexp1 (sqrt x)). +Proof. +intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 Hexp x Px Hf2 Fx. +set (a := round beta fexp1 Zfloor (sqrt x)). +set (u1 := bpow (fexp1 (mag (sqrt x)))). +set (u2 := bpow (fexp2 (mag (sqrt x)))). +set (b := / 2 * (u1 - u2)). +set (b' := / 2 * (u1 + u2)). +unfold midp; rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, sqrt_lt_R0. +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, cexp; simpl. +set (mx := Ztrunc (x * bpow (- fexp1 (mag x)))). +set (ma := Ztrunc (a * bpow (- fexp1 (mag a)))). +intros Fx Fa. +assert (Nna : 0 <= a). +{ rewrite <- (round_0 beta fexp1 Zfloor). + 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, cexp. + 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 (mag (sqrt x)) <= fexp1 (mag (x)))%Z); + [destruct (mag_sqrt_disj x Px) as [H'|H']; rewrite H'; apply Hexp|]. +assert (Hlx : (fexp1 (2 * mag (sqrt x)) < 2 * mag (sqrt x))%Z). +{ destruct (mag_sqrt_disj x Px) as [Hlx|Hlx]. + - apply (valid_exp_large fexp1 (mag x)); [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. + - rewrite <- Hlx. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. } +assert (Hsl : a * a + u1 * a - u2 * a + b * b <= x). +{ replace (_ + _) with ((a + b) * (a + b)); [|now unfold b; field]. + rewrite <- sqrt_def; [|now apply Rlt_le]. + 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 (mag x)))); + [now apply bpow_gt_0|]. + rewrite Rmult_0_l; bpow_simplify. + unfold mx. + rewrite Ztrunc_floor; + [|now apply Rmult_le_pos; [apply Rlt_le|apply bpow_ge_0]]. + apply Req_le, IZR_eq. + apply Zfloor_imp. + split; [now apply Rmult_le_pos; [apply Rlt_le|apply bpow_ge_0]|simpl]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|]. + rewrite Rmult_1_l; bpow_simplify. + apply Rlt_le_trans with (bpow (2 * fexp1 (mag (sqrt x)))); + [|now apply bpow_le]. + change 2%Z with (1 + 1)%Z; rewrite Zmult_plus_distr_l; rewrite Zmult_1_l. + rewrite bpow_plus. + rewrite <- (sqrt_def x) at 1; [|now apply Rlt_le]. + assert (sqrt x < bpow (fexp1 (mag (sqrt x)))); + [|now apply Rmult_lt_compat; [apply sqrt_pos|apply sqrt_pos| |]]. + apply (Rle_lt_trans _ _ _ Hr); rewrite Za; rewrite Rplus_0_l. + unfold b'; change (bpow _) with u1. + apply Rlt_le_trans with (/ 2 * (u1 + u1)); [|lra]. + apply Rmult_lt_compat_l; [lra|]; apply Rplus_lt_compat_l. + unfold u2, u1, ulp, cexp; apply bpow_lt; omega. +- (* a <> 0 *) + assert (Pa : 0 < a); [lra|]. + assert (Hla : (mag a = mag (sqrt x) :> Z)). + { unfold a; apply mag_DN. + - exact Vfexp1. + - now fold a. } + assert (Hl' : 0 < - (u2 * a) + b * b). + { 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 (mag (sqrt x))). + - apply Rmult_lt_compat_l; [now unfold u2, ulp; apply bpow_gt_0|]. + unfold u1; rewrite <- Hla. + apply Rlt_le_trans with (a + ulp beta fexp1 a). + + 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_mag_gt. + - apply Rle_trans with (bpow (- 1) * u1 ^ 2). + + unfold pow; rewrite Rmult_1_r. + unfold u1, u2, ulp, cexp; bpow_simplify; apply bpow_le. + now apply Hexp. + + apply Rmult_le_compat. + * apply bpow_ge_0. + * apply pow2_ge_0. + * unfold Raux.bpow, Z.pow_pos; simpl; rewrite Zmult_1_r. + apply Rinv_le; [lra|]. + now apply IZR_le. + * rewrite <- (Rplus_0_l (u1 ^ 2)) at 1; apply Rplus_le_compat_r. + apply pow2_ge_0. } + assert (Hr' : x <= a * a + u1 * a). + { rewrite Hla in Fa. + rewrite <- Rmult_plus_distr_r. + unfold u1, ulp, cexp. + rewrite <- (Rmult_1_l (bpow _)); rewrite Fa; rewrite <- Rmult_plus_distr_r. + rewrite <- Rmult_assoc; rewrite (Rmult_comm _ (IZR ma)). + rewrite <- (Rmult_assoc (IZR ma)); bpow_simplify. + apply (Rmult_le_reg_r (bpow (- 2 * fexp1 (mag (sqrt x))))); + [now apply bpow_gt_0|bpow_simplify]. + rewrite Fx at 1; bpow_simplify. + rewrite <- IZR_Zpower; [|omega]. + rewrite <- plus_IZR, <- 2!mult_IZR. + apply IZR_le, Zlt_succ_le, lt_IZR. + unfold Z.succ; rewrite plus_IZR; do 2 rewrite mult_IZR; rewrite plus_IZR. + rewrite IZR_Zpower; [|omega]. + apply (Rmult_lt_reg_r (bpow (2 * fexp1 (mag (sqrt x))))); + [now apply bpow_gt_0|bpow_simplify]. + rewrite <- Fx. + change 2%Z with (1 + 1)%Z; rewrite Zmult_plus_distr_l; rewrite Zmult_1_l. + rewrite bpow_plus; simpl. + replace (_ * _) with (a * a + u1 * a + u1 * u1); + [|unfold u1, ulp, cexp; rewrite Fa; ring]. + apply (Rle_lt_trans _ _ _ Hsr). + rewrite Rplus_assoc; apply Rplus_lt_compat_l. + apply (Rplus_lt_reg_r (- b' * b' + / 2 * u1 * u2)); ring_simplify. + replace (_ + _) with ((a + / 2 * u1) * u2) by ring. + apply Rlt_le_trans with (bpow (mag (sqrt x)) * u2). + - apply Rmult_lt_compat_r; [now unfold u2, ulp; apply bpow_gt_0|]. + apply Rlt_le_trans with (a + u1); [lra|]. + unfold u1; fold (cexp beta fexp1 (sqrt x)). + rewrite <- cexp_DN; [|exact Vfexp1|exact Pa]; fold a. + rewrite <- ulp_neq_0; trivial. + apply id_p_ulp_le_bpow. + + exact Pa. + + now apply round_DN_pt. + + apply Rle_lt_trans with (sqrt x). + * now apply round_DN_pt. + * apply Rabs_lt_inv. + apply bpow_mag_gt. + - apply Rle_trans with (/ 2 * u1 ^ 2). + + apply Rle_trans with (bpow (- 1) * u1 ^ 2). + * unfold pow; rewrite Rmult_1_r. + unfold u2, u1, ulp, cexp. + bpow_simplify. + apply bpow_le. + rewrite Zplus_comm. + now apply Hexp. + * apply Rmult_le_compat_r; [now apply pow2_ge_0|]. + unfold Raux.bpow; simpl; unfold Z.pow_pos; simpl. + rewrite Zmult_1_r. + apply Rinv_le; [lra|]. + apply IZR_le; omega. + + assert (u2 ^ 2 < u1 ^ 2); [|unfold b'; lra]. + unfold pow; do 2 rewrite Rmult_1_r. + assert (H' : 0 <= u2); [unfold u2, ulp; apply bpow_ge_0|]. + assert (u2 < u1); [|now apply Rmult_lt_compat]. + unfold u1, u2, ulp, cexp; apply bpow_lt; omega. } + apply (Rlt_irrefl (a * a + u1 * a)). + apply Rlt_le_trans with (a * a + u1 * a - u2 * a + b * b). + + rewrite <- (Rplus_0_r (a * a + _)) at 1. + unfold Rminus; rewrite (Rplus_assoc _ _ (b * b)). + now apply Rplus_lt_compat_l. + + now apply Rle_trans with x. +Qed. + +Lemma round_round_sqrt_radix_ge_4 : + (4 <= beta)%Z -> + forall fexp1 fexp2 : Z -> Z, + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + round_round_sqrt_radix_ge_4_hyp fexp1 fexp2 -> + forall x, + generic_format beta fexp1 x -> + round_round_eq fexp1 fexp2 choice1 choice2 (sqrt x). +Proof. +intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x Fx. +unfold round_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 (mag x) < mag x)%Z); + [now apply mag_generic_gt; try assumption; lra|]. + assert (Hfsx : (fexp1 (mag (sqrt x)) < mag (sqrt x))%Z). + { destruct (Rle_or_lt x 1) as [Hx|Hx]. + - (* x <= 1 *) + apply (valid_exp_large fexp1 (mag x)); [exact Hfx|]. + apply mag_le; [exact Px|]. + rewrite <- (sqrt_def x) at 1; [|lra]. + rewrite <- Rmult_1_r. + apply Rmult_le_compat_l. + + 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 mag_ge_bpow. + rewrite Zeq_minus; [|reflexivity]. + unfold Raux.bpow; simpl. + apply Rabs_ge; right. + rewrite <- sqrt_1. + apply sqrt_le_1_alt. + now apply Rlt_le. } + assert (Hf2 : (fexp2 (mag (sqrt x)) <= fexp1 (mag (sqrt x)) - 1)%Z). + { assert (H : (fexp1 (2 * mag (sqrt x)) < 2 * mag (sqrt x))%Z). + { destruct (mag_sqrt_disj x Px) as [Hlx|Hlx]. + - apply (valid_exp_large fexp1 (mag x)); [|omega]. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. + - rewrite <- Hlx. + now apply mag_generic_gt; [|apply Rgt_not_eq|]. } + generalize ((proj2 (proj2 Hexp)) (mag (sqrt x)) H). + omega. } + apply round_round_mid_cases. + + exact Vfexp1. + + exact Vfexp2. + + now apply sqrt_lt_R0. + + omega. + + omega. + + intros Hmid; casetype False; apply (Rle_not_lt _ _ Hmid). + apply (round_round_sqrt_radix_ge_4_aux Hbeta fexp1 fexp2 Vfexp1 Vfexp2 + Hexp x Px Hf2 Fx). +Qed. + +Section Double_round_sqrt_radix_ge_4_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_round_round_sqrt_radix_ge_4_hyp : + (2 * prec + 1 <= prec')%Z -> + round_round_sqrt_radix_ge_4_hyp (FLX_exp prec) (FLX_exp prec'). +Proof. +intros Hprec. +unfold FLX_exp. +unfold Prec_gt_0 in prec_gt_0_. +unfold round_round_sqrt_radix_ge_4_hyp; split; [|split]; intro ex; omega. +Qed. + +Theorem round_round_sqrt_radix_ge_4_FLX : + (4 <= beta)%Z -> + forall choice1 choice2, + (2 * prec + 1 <= prec')%Z -> + forall x, + FLX_format beta prec x -> + round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (sqrt x). +Proof. +intros Hbeta choice1 choice2 Hprec x Fx. +apply round_round_sqrt_radix_ge_4. +- exact Hbeta. +- now apply FLX_exp_valid. +- now apply FLX_exp_valid. +- now apply FLX_round_round_sqrt_radix_ge_4_hyp. +- now apply generic_format_FLX. +Qed. + +End Double_round_sqrt_radix_ge_4_FLX. + +Section Double_round_sqrt_radix_ge_4_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_round_round_sqrt_radix_ge_4_hyp : + (emin <= 0)%Z -> + ((emin' <= emin - prec - 1)%Z + \/ (2 * emin' <= emin - 4 * prec)%Z) -> + (2 * prec + 1 <= prec')%Z -> + round_round_sqrt_radix_ge_4_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). +Proof. +intros Hemin Heminprec Hprec. +unfold FLT_exp. +unfold Prec_gt_0 in prec_gt_0_. +unfold round_round_sqrt_radix_ge_4_hyp; split; [|split]; intros ex. +- generalize (Zmax_spec (ex - prec) emin). + generalize (Zmax_spec (2 * ex - prec) emin). + omega. +- 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 round_round_sqrt_radix_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 -> + round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') + choice1 choice2 (sqrt x). +Proof. +intros Hbeta choice1 choice2 Hemin Heminprec Hprec x Fx. +apply round_round_sqrt_radix_ge_4. +- exact Hbeta. +- now apply FLT_exp_valid. +- now apply FLT_exp_valid. +- now apply FLT_round_round_sqrt_radix_ge_4_hyp. +- now apply generic_format_FLT. +Qed. + +End Double_round_sqrt_radix_ge_4_FLT. + +Section Double_round_sqrt_radix_ge_4_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_round_round_sqrt_radix_ge_4_hyp : + (2 * (emin' + prec') <= emin + prec <= 1)%Z -> + (2 * prec + 1 <= prec')%Z -> + round_round_sqrt_radix_ge_4_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). +Proof. +intros Hemin Hprec. +unfold FTZ_exp. +unfold Prec_gt_0 in *. +unfold round_round_sqrt_radix_ge_4_hyp; split; [|split]; intros ex. +- destruct (Z.ltb_spec (ex - prec) emin); + destruct (Z.ltb_spec (2 * ex - prec) emin); + omega. +- 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 round_round_sqrt_radix_ge_4_FTZ : + (4 <= beta)%Z -> + forall choice1 choice2, + (2 * (emin' + prec') <= emin + prec <= 1)%Z -> + (2 * prec + 1 <= prec')%Z -> + forall x, + FTZ_format beta emin prec x -> + round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') + choice1 choice2 (sqrt x). +Proof. +intros Hbeta choice1 choice2 Hemin Hprec x Fx. +apply round_round_sqrt_radix_ge_4. +- exact Hbeta. +- now apply FTZ_exp_valid. +- now apply FTZ_exp_valid. +- now apply FTZ_round_round_sqrt_radix_ge_4_hyp. +- now apply generic_format_FTZ. +Qed. + +End Double_round_sqrt_radix_ge_4_FTZ. + +End Double_round_sqrt_radix_ge_4. + +End Double_round_sqrt. + +Section Double_round_div. + +Lemma round_round_eq_mid_beta_even : + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + (exists n, (beta = 2 * n :> Z)%Z) -> + forall x, + 0 < x -> + (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> + (fexp1 (mag x) <= mag x)%Z -> + x = midp fexp1 x -> + round_round_eq fexp1 fexp2 choice1 choice2 x. +Proof. +intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Ebeta x Px Hf2 Hf1. +unfold round_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 (mag x) - 1 + - fexp2 (mag x))) + (cexp beta fexp2 x)). +assert (Hf : F2R f = x). +{ unfold f, F2R; simpl. + rewrite plus_IZR. + rewrite Rmult_plus_distr_r. + rewrite mult_IZR. + rewrite IZR_Zpower; [|omega]. + unfold cexp at 2; bpow_simplify. + unfold Zminus; rewrite bpow_plus. + rewrite (Rmult_comm _ (bpow (- 1))). + rewrite <- (Rmult_assoc (IZR n)). + change (bpow (- 1)) with (/ IZR (beta * 1)). + rewrite Zmult_1_r. + rewrite Ebeta. + rewrite (mult_IZR 2). + rewrite Rinv_mult_distr; + [|simpl; lra | apply IZR_neq; omega]. + rewrite <- Rmult_assoc; rewrite (Rmult_comm (IZR n)); + rewrite (Rmult_assoc _ (IZR n)). + rewrite Rinv_r; + [rewrite Rmult_1_r | apply IZR_neq; omega]. + simpl; fold (cexp beta fexp1 x). + rewrite <- 2!ulp_neq_0; try now apply Rgt_not_eq. + fold u; rewrite Xmid at 2. + apply f_equal2; [|reflexivity]. + 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. + rewrite Zfloor_IZR. + 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 : (mag rd = mag x :> Z)). + { apply Zle_antisym. + - apply mag_le; [exact Prd|]. + now apply round_DN_pt. + - apply mag_round_ge. + + exact Vfexp1. + + now apply valid_rnd_DN. + + exact Nzrd. } + unfold scaled_mantissa. + unfold rd at 1. + unfold round, F2R, scaled_mantissa, cexp; simpl. + bpow_simplify. + rewrite Lrd. + rewrite <- (IZR_Zpower _ (_ - _)); [|omega]. + rewrite <- mult_IZR. + rewrite (Zfloor_imp (Zfloor (x * bpow (- fexp1 (mag x))) * + beta ^ (fexp1 (mag x) - fexp2 (mag x)))). + + rewrite mult_IZR. + rewrite IZR_Zpower; [|omega]. + bpow_simplify. + now unfold rd. + + split; [now apply Rle_refl|]. + rewrite plus_IZR. + simpl; lra. } +apply (generic_format_F2R' _ _ x f Hf). +intros _. +apply Z.le_refl. +Qed. + +Lemma round_round_really_zero : + forall (fexp1 fexp2 : Z -> Z), + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + forall x, + 0 < x -> + (mag x <= fexp1 (mag x) - 2)%Z -> + round_round_eq fexp1 fexp2 choice1 choice2 x. +Proof. +intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf1. +assert (Hlx : bpow (mag x - 1) <= x < bpow (mag x)). +{ destruct (mag x) as (ex,Hex); simpl. + rewrite <- (Rabs_right x); [|now apply Rle_ge; apply Rlt_le]. + apply Hex. + now apply Rgt_not_eq. } +unfold round_round_eq. +rewrite (round_N_small_pos beta fexp1 _ x (mag x)); [|exact Hlx|omega]. +set (x'' := round beta fexp2 (Znearest choice2) x). +destruct (Req_dec x'' 0) as [Zx''|Nzx'']; + [now rewrite Zx''; rewrite round_0; [|apply valid_rnd_N]|]. +destruct (Zle_or_lt (fexp2 (mag x)) (mag x)). +- (* fexp2 (mag x) <= mag x *) + destruct (Rlt_or_le x'' (bpow (mag x))). + + (* x'' < bpow (mag x) *) + rewrite (round_N_small_pos beta fexp1 _ _ (mag x)); + [reflexivity|split; [|exact H0]|omega]. + apply round_large_pos_ge_bpow; [now apply valid_rnd_N| |now apply Hlx]. + fold x''; assert (0 <= x''); [|lra]; unfold x''. + rewrite <- (round_0 beta fexp2 (Znearest choice2)). + now apply round_le; [|apply valid_rnd_N|apply Rlt_le]. + + (* bpow (mag x) <= x'' *) + assert (Hx'' : x'' = bpow (mag x)). + { apply Rle_antisym; [|exact H0]. + rewrite <- (round_generic beta fexp2 (Znearest choice2) (bpow _)). + - now apply round_le; [|apply valid_rnd_N|apply Rlt_le]. + - now apply generic_format_bpow'. } + rewrite Hx''. + unfold round, F2R, scaled_mantissa, cexp; simpl. + rewrite mag_bpow. + assert (Hf11 : (fexp1 (mag x + 1) = fexp1 (mag x) :> Z)%Z); + [apply Vfexp1; omega|]. + rewrite Hf11. + apply (Rmult_eq_reg_r (bpow (- fexp1 (mag x)))); + [|now apply Rgt_not_eq; apply bpow_gt_0]. + rewrite Rmult_0_l; bpow_simplify. + apply IZR_eq. + apply Znearest_imp. + simpl; unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r. + rewrite Rabs_right; [|now apply Rle_ge; apply bpow_ge_0]. + apply Rle_lt_trans with (bpow (- 2)); [now apply bpow_le; omega|]. + unfold 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 mult_IZR; apply Rmult_lt_0_compat; + apply IZR_lt; omega. + * apply IZR_lt. + apply (Z.le_lt_trans _ _ _ Hbeta). + rewrite <- (Zmult_1_r beta) at 1. + apply Zmult_lt_compat_l; omega. +- (* mag x < fexp2 (mag x) *) + casetype False; apply Nzx''. + now apply (round_N_small_pos beta _ _ _ (mag x)). +Qed. + +Lemma round_round_zero : + forall fexp1 fexp2 : Z -> Z, + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + forall x, + 0 < x -> + (fexp1 (mag x) = mag x + 1 :> Z)%Z -> + x < bpow (mag x) - / 2 * ulp beta fexp2 x -> + round_round_eq fexp1 fexp2 choice1 choice2 x. +Proof. +intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf1. +unfold round_round_eq. +set (x'' := round beta fexp2 (Znearest choice2) x). +set (u1 := ulp beta fexp1 x). +set (u2 := ulp beta fexp2 x). +intro Hx. +assert (Hlx : bpow (mag x - 1) <= x < bpow (mag x)). +{ destruct (mag x) as (ex,Hex); simpl. + rewrite <- (Rabs_right x); [|now apply Rle_ge; apply Rlt_le]. + apply Hex. + now apply Rgt_not_eq. } +rewrite (round_N_small_pos beta fexp1 choice1 x (mag x)); + [|exact Hlx|omega]. +destruct (Req_dec x'' 0) as [Zx''|Nzx'']; + [now rewrite Zx''; rewrite round_0; [reflexivity|apply valid_rnd_N]|]. +rewrite (round_N_small_pos beta _ _ x'' (mag x)); + [reflexivity| |omega]. +split. +- apply round_large_pos_ge_bpow. + + now apply valid_rnd_N. + + assert (0 <= x''); [|now fold x''; lra]. + rewrite <- (round_0 beta fexp2 (Znearest choice2)). + now apply round_le; [|apply valid_rnd_N|apply Rlt_le]. + + apply Rle_trans with (Rabs x); + [|now rewrite Rabs_right; [apply Rle_refl|apply Rle_ge; apply Rlt_le]]. + destruct (mag x) as (ex,Hex); simpl; apply Hex. + now apply Rgt_not_eq. +- replace x'' with (x + (x'' - x)) by ring. + replace (bpow _) with (bpow (mag x) - / 2 * u2 + / 2 * u2) by ring. + apply Rplus_lt_le_compat; [exact Hx|]. + apply Rabs_le_inv. + now apply error_le_half_ulp. +Qed. + +Lemma round_round_all_mid_cases : + forall fexp1 fexp2 : Z -> Z, + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + forall x, + 0 < x -> + (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z -> + ((fexp1 (mag x) = mag x + 1 :> Z)%Z -> + bpow (mag x) - / 2 * ulp beta fexp2 x <= x -> + round_round_eq fexp1 fexp2 choice1 choice2 x) -> + ((fexp1 (mag x) <= mag x)%Z -> + midp fexp1 x - / 2 * ulp beta fexp2 x <= x < midp fexp1 x -> + round_round_eq fexp1 fexp2 choice1 choice2 x) -> + ((fexp1 (mag x) <= mag x)%Z -> + x = midp fexp1 x -> + round_round_eq fexp1 fexp2 choice1 choice2 x) -> + ((fexp1 (mag x) <= mag x)%Z -> + midp fexp1 x < x <= midp fexp1 x + / 2 * ulp beta fexp2 x -> + round_round_eq fexp1 fexp2 choice1 choice2 x) -> + round_round_eq fexp1 fexp2 choice1 choice2 x. +Proof. +intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2. +set (x' := round beta fexp1 Zfloor x). +set (u1 := ulp beta fexp1 x). +set (u2 := ulp beta fexp2 x). +intros Cz Clt Ceq Cgt. +destruct (Ztrichotomy (mag x) (fexp1 (mag x) - 1)) as [Hlt|[Heq|Hgt]]. +- (* mag x < fexp1 (mag x) - 1 *) + assert (H : (mag x <= fexp1 (mag x) - 2)%Z) by omega. + now apply round_round_really_zero. +- (* mag x = fexp1 (mag x) - 1 *) + assert (H : (fexp1 (mag x) = (mag x + 1))%Z) by omega. + destruct (Rlt_or_le x (bpow (mag x) - / 2 * u2)) as [Hlt'|Hge']. + + now apply round_round_zero. + + now apply Cz. +- (* mag x > fexp1 (mag x) - 1 *) + assert (H : (fexp1 (mag x) <= mag x)%Z) by omega. + destruct (Rtotal_order x (midp fexp1 x)) as [Hlt'|[Heq'|Hgt']]. + + (* x < midp fexp1 x *) + destruct (Rlt_or_le x (midp fexp1 x - / 2 * u2)) as [Hlt''|Hle'']. + * now apply round_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 round_round_eq; rewrite (round_generic beta fexp2); + [reflexivity|now apply valid_rnd_N|]. + now apply (generic_inclusion_mag beta fexp1); [omega|]. + - (* ~ generic_format beta fexp1 x *) + assert (Hceil : round beta fexp1 Zceil x = x' + u1); + [now apply round_UP_DN_ulp|]. + assert (Hf2' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z); + [omega|]. + assert (midp' fexp1 x + / 2 * ulp beta fexp2 x < x); + [|now apply round_round_gt_mid_further_place]. + revert Hle''; unfold midp, midp'; fold x'. + rewrite Hceil; fold u1; fold u2. + lra. } +Qed. + +Lemma mag_div_disj : + forall x y : R, + 0 < x -> 0 < y -> + ((mag (x / y) = mag x - mag y :> Z)%Z + \/ (mag (x / y) = mag x - mag y + 1 :> Z)%Z). +Proof. +intros x y Px Py. +generalize (mag_div beta x y (Rgt_not_eq _ _ Px) (Rgt_not_eq _ _ Py)). +omega. +Qed. + +Definition round_round_div_hyp fexp1 fexp2 := + (forall ex, (fexp2 ex <= fexp1 ex - 1)%Z) + /\ (forall ex ey, (fexp1 ex < ex)%Z -> (fexp1 ey < ey)%Z -> + (fexp1 (ex - ey) <= ex - ey + 1)%Z -> + (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 round_round_div_aux0 : + forall fexp1 fexp2 : Z -> Z, + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + round_round_div_hyp fexp1 fexp2 -> + forall x y, + 0 < x -> 0 < y -> + generic_format beta fexp1 x -> + generic_format beta fexp1 y -> + fexp1 (mag (x / y)) = (mag (x / y) + 1)%Z -> + ~ (bpow (mag (x / y)) - / 2 * ulp beta fexp2 (x / y) <= x / y). +Proof. +intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Fx Fy Hf1. +assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfy : (fexp1 (mag y) < mag y)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +set (p := bpow (mag (x / y))). +set (u2 := bpow (fexp2 (mag (x / y)))). +revert Fx Fy. +unfold generic_format, F2R, scaled_mantissa, cexp; simpl. +set (mx := Ztrunc (x * bpow (- fexp1 (mag x)))). +set (my := Ztrunc (y * bpow (- fexp1 (mag y)))). +intros Fx Fy. +rewrite ulp_neq_0. +2: apply Rmult_integral_contrapositive_currified; [now apply Rgt_not_eq|idtac]. +2: now apply Rinv_neq_0_compat, Rgt_not_eq. +intro Hl. +assert (Hr : x / y < p); + [now apply Rabs_lt_inv; apply bpow_mag_gt|]. +apply (Rlt_irrefl (p - / 2 * u2)). +apply (Rle_lt_trans _ _ _ Hl). +apply (Rmult_lt_reg_r y _ _ Py). +unfold Rdiv; rewrite Rmult_assoc. +rewrite Rinv_l; [|now apply Rgt_not_eq]; rewrite Rmult_1_r. +destruct (Zle_or_lt Z0 (fexp1 (mag x) - mag (x / y) + - fexp1 (mag y))%Z) as [He|He]. +- (* mag (x / y) + fexp1 (mag y) <= fexp1 (mag x) *) + apply Rle_lt_trans with (p * y - p * bpow (fexp1 (mag y))). + + rewrite Fx; rewrite Fy at 1. + rewrite <- Rmult_assoc. + rewrite (Rmult_comm p). + unfold p; bpow_simplify. + apply (Rmult_le_reg_r (bpow (- mag (x / y) - fexp1 (mag y)))); + [now apply bpow_gt_0|]. + rewrite Rmult_minus_distr_r. + bpow_simplify. + rewrite <- IZR_Zpower; [|exact He]. + rewrite <- mult_IZR. + rewrite <- minus_IZR. + apply IZR_le. + apply (Zplus_le_reg_r _ _ 1); ring_simplify. + apply Zlt_le_succ. + apply lt_IZR. + rewrite mult_IZR. + rewrite IZR_Zpower; [|exact He]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag y) + mag (x / y)))); + [now apply bpow_gt_0|]. + bpow_simplify. + rewrite <- Fx. + 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 (mag 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_mag_gt. } + * unfold u2, p, ulp, cexp; bpow_simplify; apply bpow_le. + apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify. + rewrite (Zplus_comm (- _)); fold (Zminus (mag (x / y)) (mag y)). + destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; + [now apply Hexp; [| |rewrite <- Hxy]|]. + replace (_ - _ + 1)%Z with ((mag x + 1) - mag y)%Z by ring. + apply Hexp. + { now assert (fexp1 (mag x + 1) <= mag x)%Z; + [apply valid_exp|omega]. } + { assumption. } + replace (_ + 1 - _)%Z with (mag x - mag y + 1)%Z by ring. + now rewrite <- Hxy. +- (* fexp1 (mag x) < mag (x / y) + fexp1 (mag y) *) + apply Rle_lt_trans with (p * y - bpow (fexp1 (mag x))). + + rewrite Fx at 1; rewrite Fy at 1. + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); + [now apply bpow_gt_0|]. + rewrite Rmult_minus_distr_r. + bpow_simplify. + rewrite (Rmult_comm p). + unfold p; bpow_simplify. + rewrite <- IZR_Zpower; [|omega]. + rewrite <- mult_IZR. + rewrite <- minus_IZR. + apply IZR_le. + apply (Zplus_le_reg_r _ _ 1); ring_simplify. + apply Zlt_le_succ. + apply lt_IZR. + rewrite mult_IZR. + rewrite IZR_Zpower; [|omega]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); + [now apply bpow_gt_0|bpow_simplify]. + rewrite <- Fx. + rewrite Zplus_comm; rewrite bpow_plus. + 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 (mag 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_mag_gt. } + * unfold u2, p, ulp, cexp; bpow_simplify; apply bpow_le. + apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify. + rewrite (Zplus_comm (- _)); fold (Zminus (mag (x / y)) (mag y)). + destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; + apply Hexp; try assumption; rewrite <- Hxy; rewrite Hf1; apply Z.le_refl. +Qed. + +Lemma round_round_div_aux1 : + forall fexp1 fexp2 : Z -> Z, + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + round_round_div_hyp fexp1 fexp2 -> + forall x y, + 0 < x -> 0 < y -> + generic_format beta fexp1 x -> + generic_format beta fexp1 y -> + (fexp1 (mag (x / y)) <= mag (x / y))%Z -> + ~ (midp fexp1 (x / y) - / 2 * ulp beta fexp2 (x / y) + <= x / y + < midp fexp1 (x / y)). +Proof. +intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Fx Fy Hf1. +assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfy : (fexp1 (mag y) < mag y)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +assert (S : (x / y <> 0)%R). +apply Rmult_integral_contrapositive_currified; [now apply Rgt_not_eq|idtac]. +now apply Rinv_neq_0_compat, Rgt_not_eq. +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 (mag (x / y)))). +set (u2 := bpow (fexp2 (mag (x / y)))). +set (x' := round beta fexp1 Zfloor (x / y)). +rewrite 2!ulp_neq_0; trivial. +revert Fx Fy. +unfold generic_format, F2R, scaled_mantissa, cexp; simpl. +set (mx := Ztrunc (x * bpow (- fexp1 (mag x)))). +set (my := Ztrunc (y * bpow (- fexp1 (mag y)))). +intros Fx Fy. +intro Hlr. +apply (Rlt_irrefl (/ 2 * (u1 - u2))). +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 (mag x) - fexp1 (mag (x / y)) + - fexp1 (mag y))%Z) as [He|He]. +- (* fexp1 (mag (x / y)) + fexp1 (mag y)) <= fexp1 (mag x) *) + apply Rle_lt_trans with (2 * x' * y + u1 * y + - bpow (fexp1 (mag (x / y)) + + fexp1 (mag y))). + + rewrite Fx at 1; rewrite Fy at 1 2. + apply (Rmult_le_reg_r (bpow (- fexp1 (mag (x / y)) + - fexp1 (mag y)))); + [now apply bpow_gt_0|]. + rewrite Rmult_minus_distr_r; rewrite (Rmult_plus_distr_r (_ * _ * _)). + bpow_simplify. + replace (2 * x' * _ * _) + with (2 * IZR my * x' * bpow (- fexp1 (mag (x / y)))) by ring. + rewrite (Rmult_comm u1). + unfold x', u1, round, F2R, ulp, scaled_mantissa, cexp; simpl. + bpow_simplify. + rewrite <- IZR_Zpower; [|exact He]. + do 4 rewrite <- mult_IZR. + rewrite <- plus_IZR. + rewrite <- minus_IZR. + apply IZR_le. + apply (Zplus_le_reg_r _ _ 1); ring_simplify. + apply Zlt_le_succ. + apply lt_IZR. + rewrite plus_IZR. + do 4 rewrite mult_IZR; simpl. + rewrite IZR_Zpower; [|exact He]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag (x / y)) + + fexp1 (mag y)))); + [now apply bpow_gt_0|bpow_simplify]. + rewrite Rmult_assoc. + rewrite <- Fx. + rewrite (Rmult_plus_distr_r _ _ (Raux.bpow _ _)). + rewrite Rmult_assoc. + rewrite bpow_plus. + rewrite <- (Rmult_assoc (IZR (Zfloor _))). + change (IZR (Zfloor _) * _) with x'. + do 2 rewrite (Rmult_comm _ (bpow (fexp1 (mag y)))). + rewrite Rmult_assoc. + do 2 rewrite <- (Rmult_assoc (IZR 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 (mag y)). + * { apply Rmult_lt_compat_l. + - apply bpow_gt_0. + - apply Rabs_lt_inv. + apply bpow_mag_gt. } + * unfold u2, ulp, cexp; bpow_simplify; apply bpow_le. + apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify. + rewrite <- Zplus_assoc; rewrite (Zplus_comm (- _)). + destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; + [now apply Hexp; [| |rewrite <- Hxy]|]. + replace (_ - _ + 1)%Z with ((mag x + 1) - mag y)%Z by ring. + apply Hexp. + { now assert (fexp1 (mag x + 1) <= mag x)%Z; + [apply valid_exp|omega]. } + { assumption. } + replace (_ + 1 - _)%Z with (mag x - mag y + 1)%Z by ring. + now rewrite <- Hxy. +- (* fexp1 (mag x) < fexp1 (mag (x / y)) + fexp1 (mag y) *) + apply Rle_lt_trans with (2 * x' * y + u1 * y - bpow (fexp1 (mag x))). + + rewrite Fx at 1; rewrite Fy at 1 2. + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); + [now apply bpow_gt_0|]. + rewrite Rmult_minus_distr_r; rewrite (Rmult_plus_distr_r (_ * _ * _)). + bpow_simplify. + replace (2 * x' * _ * _) + with (2 * IZR my * x' * bpow (fexp1 (mag y) - fexp1 (mag x))) by ring. + rewrite (Rmult_comm u1). + unfold x', u1, round, F2R, ulp, scaled_mantissa, cexp; simpl. + bpow_simplify. + rewrite <- (IZR_Zpower _ (_ - _)%Z); [|omega]. + do 5 rewrite <- mult_IZR. + rewrite <- plus_IZR. + rewrite <- minus_IZR. + apply IZR_le. + apply (Zplus_le_reg_r _ _ 1); ring_simplify. + apply Zlt_le_succ. + apply lt_IZR. + rewrite plus_IZR. + do 5 rewrite mult_IZR; simpl. + rewrite IZR_Zpower; [|omega]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); + [now apply bpow_gt_0|]. + rewrite Rmult_assoc. + rewrite <- Fx. + rewrite (Rmult_plus_distr_r _ _ (Raux.bpow _ _)). + bpow_simplify. + rewrite Rmult_assoc. + rewrite bpow_plus. + rewrite <- (Rmult_assoc (IZR (Zfloor _))). + change (IZR (Zfloor _) * _) with x'. + do 2 rewrite (Rmult_comm _ (bpow (fexp1 (mag y)))). + rewrite Rmult_assoc. + do 2 rewrite <- (Rmult_assoc (IZR 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 (mag y)). + * { apply Rmult_lt_compat_l. + - apply bpow_gt_0. + - apply Rabs_lt_inv. + apply bpow_mag_gt. } + * unfold u2, ulp, cexp; bpow_simplify; apply bpow_le. + apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify. + rewrite (Zplus_comm (- _)). + destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; + apply Hexp; try assumption; rewrite <- Hxy; omega. +Qed. + +Lemma round_round_div_aux2 : + forall fexp1 fexp2 : Z -> Z, + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + round_round_div_hyp fexp1 fexp2 -> + forall x y, + 0 < x -> 0 < y -> + generic_format beta fexp1 x -> + generic_format beta fexp1 y -> + (fexp1 (mag (x / y)) <= mag (x / y))%Z -> + ~ (midp fexp1 (x / y) + < x / y + <= midp fexp1 (x / y) + / 2 * ulp beta fexp2 (x / y)). +Proof. +intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Fx Fy Hf1. +assert (Hfx : (fexp1 (mag x) < mag x)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +assert (Hfy : (fexp1 (mag y) < mag y)%Z); + [now apply mag_generic_gt; [|apply Rgt_not_eq|]|]. +cut (~ (/ 2 * ulp beta fexp1 (x / y) + < x / y - round beta fexp1 Zfloor (x / y) + <= / 2 * (ulp beta fexp1 (x / y) + ulp beta fexp2 (x / y)))). +{ 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 (mag (x / y)))). +set (u2 := bpow (fexp2 (mag (x / y)))). +set (x' := round beta fexp1 Zfloor (x / y)). +assert (S : (x / y <> 0)%R). +apply Rmult_integral_contrapositive_currified; [now apply Rgt_not_eq|idtac]. +now apply Rinv_neq_0_compat, Rgt_not_eq. +rewrite 2!ulp_neq_0; trivial. +revert Fx Fy. +unfold generic_format, F2R, scaled_mantissa, cexp; simpl. +set (mx := Ztrunc (x * bpow (- fexp1 (mag x)))). +set (my := Ztrunc (y * bpow (- fexp1 (mag y)))). +intros Fx Fy. +intro Hlr. +apply (Rlt_irrefl (/ 2 * (u1 + u2))). +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 (mag x) - fexp1 (mag (x / y)) + - fexp1 (mag y))%Z) as [He|He]. +- (* fexp1 (mag (x / y)) + fexp1 (mag y) <= fexp1 (mag x) *) + apply Rlt_le_trans with (u1 * y + bpow (fexp1 (mag (x / y)) + + fexp1 (mag y)) + + 2 * x' * y). + + apply Rplus_lt_compat_r, Rplus_lt_compat_l. + apply Rlt_le_trans with (u2 * bpow (mag y)). + * { apply Rmult_lt_compat_l. + - apply bpow_gt_0. + - apply Rabs_lt_inv. + apply bpow_mag_gt. } + * unfold u2, ulp, cexp; bpow_simplify; apply bpow_le. + apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify. + rewrite <- Zplus_assoc; rewrite (Zplus_comm (- _)). + destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; + [now apply Hexp; [| |rewrite <- Hxy]|]. + replace (_ - _ + 1)%Z with ((mag x + 1) - mag y)%Z by ring. + apply Hexp. + { now assert (fexp1 (mag x + 1) <= mag x)%Z; + [apply valid_exp|omega]. } + { assumption. } + replace (_ + 1 - _)%Z with (mag x - mag y + 1)%Z by ring. + now rewrite <- Hxy. + + apply Rge_le; rewrite Fx at 1; apply Rle_ge. + replace (u1 * y) with (u1 * (IZR my * bpow (fexp1 (mag y)))); + [|now apply eq_sym; rewrite Fy at 1]. + replace (2 * x' * y) with (2 * x' * (IZR my * bpow (fexp1 (mag y)))); + [|now apply eq_sym; rewrite Fy at 1]. + apply (Rmult_le_reg_r (bpow (- fexp1 (mag (x / y)) + - fexp1 (mag y)))); + [now apply bpow_gt_0|]. + do 2 rewrite Rmult_plus_distr_r. + bpow_simplify. + rewrite (Rmult_comm u1). + unfold u1, ulp, cexp; bpow_simplify. + rewrite (Rmult_assoc 2). + rewrite (Rmult_comm x'). + rewrite (Rmult_assoc 2). + unfold x', round, F2R, scaled_mantissa, cexp; simpl. + bpow_simplify. + rewrite <- (IZR_Zpower _ (_ - _)%Z); [|exact He]. + do 4 rewrite <- mult_IZR. + do 2 rewrite <- plus_IZR. + apply IZR_le. + rewrite Zplus_comm, Zplus_assoc. + apply Zlt_le_succ. + apply lt_IZR. + rewrite plus_IZR. + do 4 rewrite mult_IZR; simpl. + rewrite IZR_Zpower; [|exact He]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag y)))); + [now apply bpow_gt_0|]. + rewrite Rmult_plus_distr_r. + rewrite (Rmult_comm _ (IZR _)). + do 2 rewrite Rmult_assoc. + rewrite <- Fy. + bpow_simplify. + unfold Zminus; rewrite bpow_plus. + rewrite (Rmult_assoc _ (IZR mx)). + rewrite <- (Rmult_assoc (IZR mx)). + rewrite <- Fx. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag (x / y))))); + [now apply bpow_gt_0|]. + rewrite Rmult_plus_distr_r. + bpow_simplify. + rewrite (Rmult_comm _ y). + do 2 rewrite Rmult_assoc. + change (IZR (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 (mag x) < fexp1 (mag (x / y)) + fexp1 (mag y) *) + apply Rlt_le_trans with (2 * x' * y + u1 * y + bpow (fexp1 (mag x))). + + rewrite Rplus_comm, Rplus_assoc; do 2 apply Rplus_lt_compat_l. + apply Rlt_le_trans with (u2 * bpow (mag y)). + * apply Rmult_lt_compat_l. + now apply bpow_gt_0. + now apply Rabs_lt_inv; apply bpow_mag_gt. + * unfold u2, ulp, cexp; bpow_simplify; apply bpow_le. + apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify. + rewrite (Zplus_comm (- _)). + destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy; + apply Hexp; try assumption; rewrite <- Hxy; omega. + + apply Rge_le; rewrite Fx at 1; apply Rle_ge. + rewrite Fy at 1 2. + apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); + [now apply bpow_gt_0|]. + do 2 rewrite Rmult_plus_distr_r. + bpow_simplify. + replace (2 * x' * _ * _) + with (2 * IZR my * x' * bpow (fexp1 (mag y) - fexp1 (mag x))) by ring. + rewrite (Rmult_comm u1). + unfold x', u1, round, F2R, ulp, scaled_mantissa, cexp; simpl. + bpow_simplify. + rewrite <- (IZR_Zpower _ (_ - _)%Z); [|omega]. + do 5 rewrite <- mult_IZR. + do 2 rewrite <- plus_IZR. + apply IZR_le. + apply Zlt_le_succ. + apply lt_IZR. + rewrite plus_IZR. + do 5 rewrite mult_IZR; simpl. + rewrite IZR_Zpower; [|omega]. + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); + [now apply bpow_gt_0|]. + rewrite (Rmult_assoc _ (IZR mx)). + rewrite <- Fx. + rewrite Rmult_plus_distr_r. + bpow_simplify. + rewrite bpow_plus. + rewrite Rmult_assoc. + rewrite <- (Rmult_assoc (IZR _)). + change (IZR _ * bpow _) with x'. + do 2 rewrite (Rmult_comm _ (bpow (fexp1 (mag y)))). + rewrite Rmult_assoc. + do 2 rewrite <- (Rmult_assoc (IZR 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 round_round_div_aux : + forall fexp1 fexp2 : Z -> Z, + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + (exists n, (beta = 2 * n :> Z)%Z) -> + round_round_div_hyp fexp1 fexp2 -> + forall x y, + 0 < x -> 0 < y -> + generic_format beta fexp1 x -> + generic_format beta fexp1 y -> + round_round_eq fexp1 fexp2 choice1 choice2 (x / y). +Proof. +intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Ebeta Hexp x y Px Py Fx Fy. +assert (Pxy : 0 < x / y). +{ apply Rmult_lt_0_compat; [exact Px|]. + now apply Rinv_0_lt_compat. } +apply round_round_all_mid_cases. +- exact Vfexp1. +- exact Vfexp2. +- exact Pxy. +- apply Hexp. +- intros Hf1 Hlxy. + casetype False. + now apply (round_round_div_aux0 fexp1 fexp2 _ _ choice1 choice2 Hexp x y). +- intros Hf1 Hlxy. + casetype False. + now apply (round_round_div_aux1 fexp1 fexp2 _ _ choice1 choice2 Hexp x y). +- intro H. + apply round_round_eq_mid_beta_even; try assumption. + apply Hexp. +- intros Hf1 Hlxy. + casetype False. + now apply (round_round_div_aux2 fexp1 fexp2 _ _ choice1 choice2 Hexp x y). +Qed. + +Lemma round_round_div : + forall fexp1 fexp2 : Z -> Z, + Valid_exp fexp1 -> Valid_exp fexp2 -> + forall (choice1 choice2 : Z -> bool), + (exists n, (beta = 2 * n :> Z)%Z) -> + round_round_div_hyp fexp1 fexp2 -> + forall x y, + y <> 0 -> + generic_format beta fexp1 x -> + generic_format beta fexp1 y -> + round_round_eq fexp1 fexp2 choice1 choice2 (x / y). +Proof. +intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Ebeta Hexp x y Nzy Fx Fy. +unfold round_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 round_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 round_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 round_round_div_aux. + + (* y = 0 *) + now casetype False; apply Nzy. + + (* y > 0 *) + now apply round_round_div_aux. +Qed. + +Section Double_round_div_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_round_round_div_hyp : + (2 * prec <= prec')%Z -> + round_round_div_hyp (FLX_exp prec) (FLX_exp prec'). +Proof. +intros Hprec. +unfold Prec_gt_0 in prec_gt_0_. +unfold FLX_exp. +unfold round_round_div_hyp. +split; [now intro ex; omega|]. +split; [|split; [|split]]; intros ex ey; omega. +Qed. + +Theorem round_round_div_FLX : + forall choice1 choice2, + (exists n, (beta = 2 * n :> Z)%Z) -> + (2 * prec <= prec')%Z -> + forall x y, + y <> 0 -> + FLX_format beta prec x -> FLX_format beta prec y -> + round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x / y). +Proof. +intros choice1 choice2 Ebeta Hprec x y Nzy Fx Fy. +apply round_round_div. +- now apply FLX_exp_valid. +- now apply FLX_exp_valid. +- exact Ebeta. +- now apply FLX_round_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. + +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_round_round_div_hyp : + (emin' <= emin - prec - 2)%Z -> + (2 * prec <= prec')%Z -> + round_round_div_hyp (FLT_exp emin prec) (FLT_exp emin' prec'). +Proof. +intros Hemin Hprec. +unfold FLT_exp. +unfold Prec_gt_0 in prec_gt_0_. +unfold round_round_div_hyp. +split; [intro ex|split; [|split; [|split]]; intros ex ey]. +- generalize (Zmax_spec (ex - prec') emin'). + generalize (Zmax_spec (ex - prec) emin). + 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 round_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 -> + round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec') + choice1 choice2 (x / y). +Proof. +intros choice1 choice2 Ebeta Hemin Hprec x y Nzy Fx Fy. +apply round_round_div. +- now apply FLT_exp_valid. +- now apply FLT_exp_valid. +- exact Ebeta. +- now apply FLT_round_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. + +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_round_round_div_hyp : + (emin' + prec' <= emin - 1)%Z -> + (2 * prec <= prec')%Z -> + round_round_div_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec'). +Proof. +intros Hemin Hprec. +unfold FTZ_exp. +unfold Prec_gt_0 in prec_gt_0_. +unfold Prec_gt_0 in prec_gt_0_. +unfold round_round_div_hyp. +split; [intro ex|split; [|split; [|split]]; intros ex ey]. +- destruct (Z.ltb_spec (ex - prec') emin'); + destruct (Z.ltb_spec (ex - prec) emin); + 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 round_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 -> + round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec') + choice1 choice2 (x / y). +Proof. +intros choice1 choice2 Ebeta Hemin Hprec x y Nzy Fx Fy. +apply round_round_div. +- now apply FTZ_exp_valid. +- now apply FTZ_exp_valid. +- exact Ebeta. +- now apply FTZ_round_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/Prop/Fprop_Sterbenz.v b/flocq/Prop/Fprop_Sterbenz.v deleted file mode 100644 index 4e74f889..00000000 --- a/flocq/Prop/Fprop_Sterbenz.v +++ /dev/null @@ -1,169 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2010-2013 Sylvie Boldo -#
# -Copyright (C) 2010-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** * Sterbenz conditions for exact subtraction *) - -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_generic_fmt. -Require Import Fcalc_ops. - -Section Fprop_Sterbenz. - -Variable beta : radix. -Notation bpow e := (bpow beta e). - -Variable fexp : Z -> Z. -Context { valid_exp : Valid_exp fexp }. -Context { monotone_exp : Monotone_exp fexp }. -Notation format := (generic_format beta fexp). - -Theorem generic_format_plus : - forall x y, - format x -> format y -> - (Rabs (x + y) < bpow (Zmin (ln_beta beta x) (ln_beta beta y)))%R -> - format (x + y)%R. -Proof. -intros x y Fx Fy Hxy. -destruct (Req_dec (x + y) 0) as [Zxy|Zxy]. -rewrite Zxy. -apply generic_format_0. -destruct (Req_dec x R0) as [Zx|Zx]. -now rewrite Zx, Rplus_0_l. -destruct (Req_dec y R0) as [Zy|Zy]. -now rewrite Zy, Rplus_0_r. -revert Hxy. -destruct (ln_beta beta x) as (ex, Ex). simpl. -specialize (Ex Zx). -destruct (ln_beta beta y) as (ey, Ey). simpl. -specialize (Ey Zy). -intros Hxy. -set (fx := Float beta (Ztrunc (scaled_mantissa beta fexp x)) (fexp ex)). -assert (Hx: x = F2R fx). -rewrite Fx at 1. -unfold canonic_exp. -now rewrite ln_beta_unique with (1 := Ex). -set (fy := Float beta (Ztrunc (scaled_mantissa beta fexp y)) (fexp ey)). -assert (Hy: y = F2R fy). -rewrite Fy at 1. -unfold canonic_exp. -now rewrite ln_beta_unique with (1 := Ey). -rewrite Hx, Hy. -rewrite <- F2R_plus. -apply generic_format_F2R. -intros _. -case_eq (Fplus beta fx fy). -intros mxy exy Pxy. -rewrite <- Pxy, F2R_plus, <- Hx, <- Hy. -unfold canonic_exp. -replace exy with (fexp (Zmin ex ey)). -apply monotone_exp. -now apply ln_beta_le_bpow. -replace exy with (Fexp (Fplus beta fx fy)) by exact (f_equal Fexp Pxy). -rewrite Fexp_Fplus. -simpl. clear -monotone_exp. -apply sym_eq. -destruct (Zmin_spec ex ey) as [(H1,H2)|(H1,H2)] ; rewrite H2. -apply Zmin_l. -now apply monotone_exp. -apply Zmin_r. -apply monotone_exp. -apply Zlt_le_weak. -now apply Zgt_lt. -Qed. - -Theorem generic_format_plus_weak : - forall x y, - format x -> format y -> - (Rabs (x + y) <= Rmin (Rabs x) (Rabs y))%R -> - format (x + y)%R. -Proof. -intros x y Fx Fy Hxy. -destruct (Req_dec x R0) as [Zx|Zx]. -now rewrite Zx, Rplus_0_l. -destruct (Req_dec y R0) as [Zy|Zy]. -now rewrite Zy, Rplus_0_r. -apply generic_format_plus ; try assumption. -apply Rle_lt_trans with (1 := Hxy). -unfold Rmin. -destruct (Rle_dec (Rabs x) (Rabs y)) as [Hxy'|Hxy']. -rewrite Zmin_l. -destruct (ln_beta beta x) as (ex, Hx). -now apply Hx. -now apply ln_beta_le_abs. -rewrite Zmin_r. -destruct (ln_beta beta y) as (ex, Hy). -now apply Hy. -apply ln_beta_le_abs. -exact Zy. -apply Rlt_le. -now apply Rnot_le_lt. -Qed. - -Lemma sterbenz_aux : - forall x y, format x -> format y -> - (y <= x <= 2 * y)%R -> - format (x - y)%R. -Proof. -intros x y Hx Hy (Hxy1, Hxy2). -unfold Rminus. -apply generic_format_plus_weak. -exact Hx. -now apply generic_format_opp. -rewrite Rabs_pos_eq. -rewrite Rabs_Ropp. -rewrite Rmin_comm. -assert (Hy0: (0 <= y)%R). -apply Rplus_le_reg_r with y. -apply Rle_trans with x. -now rewrite Rplus_0_l. -now replace (y + y)%R with (2 * y)%R by ring. -rewrite Rabs_pos_eq with (1 := Hy0). -rewrite Rabs_pos_eq. -unfold Rmin. -destruct (Rle_dec y x) as [Hyx|Hyx]. -apply Rplus_le_reg_r with y. -now ring_simplify. -now elim Hyx. -now apply Rle_trans with y. -now apply Rle_0_minus. -Qed. - -Theorem sterbenz : - forall x y, format x -> format y -> - (y / 2 <= x <= 2 * y)%R -> - format (x - y)%R. -Proof. -intros x y Hx Hy (Hxy1, Hxy2). -destruct (Rle_or_lt x y) as [Hxy|Hxy]. -rewrite <- Ropp_minus_distr. -apply generic_format_opp. -apply sterbenz_aux ; try easy. -split. -exact Hxy. -apply Rcompare_not_Lt_inv. -rewrite <- Rcompare_half_r. -now apply Rcompare_not_Lt. -apply sterbenz_aux ; try easy. -split. -now apply Rlt_le. -exact Hxy2. -Qed. - -End Fprop_Sterbenz. diff --git a/flocq/Prop/Fprop_div_sqrt_error.v b/flocq/Prop/Fprop_div_sqrt_error.v deleted file mode 100644 index 422b6b64..00000000 --- a/flocq/Prop/Fprop_div_sqrt_error.v +++ /dev/null @@ -1,300 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2010-2013 Sylvie Boldo -#
# -Copyright (C) 2010-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** * Remainder of the division and square root are in the FLX format *) -Require Import Fcore. -Require Import Fcalc_ops. -Require Import Fprop_relative. - -Section Fprop_divsqrt_error. - -Variable beta : radix. -Notation bpow e := (bpow beta e). - -Variable prec : Z. - -Theorem generic_format_plus_prec: - forall fexp, (forall e, (fexp e <= e - prec)%Z) -> - forall x y (fx fy: float beta), - (x = F2R fx)%R -> (y = F2R fy)%R -> (Rabs (x+y) < bpow (prec+Fexp fx))%R -> (Rabs (x+y) < bpow (prec+Fexp fy))%R - -> generic_format beta fexp (x+y)%R. -intros fexp Hfexp x y fx fy Hx Hy H1 H2. -case (Req_dec (x+y) 0); intros H. -rewrite H; apply generic_format_0. -rewrite Hx, Hy, <- F2R_plus. -apply generic_format_F2R. -intros _. -case_eq (Fplus beta fx fy). -intros mz ez Hz. -rewrite <- Hz. -apply Zle_trans with (Zmin (Fexp fx) (Fexp fy)). -rewrite F2R_plus, <- Hx, <- Hy. -unfold canonic_exp. -apply Zle_trans with (1:=Hfexp _). -apply Zplus_le_reg_l with prec; ring_simplify. -apply ln_beta_le_bpow with (1 := H). -now apply Zmin_case. -rewrite <- Fexp_Fplus, Hz. -apply Zle_refl. -Qed. - -Theorem ex_Fexp_canonic: forall fexp, forall x, generic_format beta fexp x - -> exists fx:float beta, (x=F2R fx)%R /\ Fexp fx = canonic_exp beta fexp x. -intros fexp x; unfold generic_format. -exists (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)). -split; auto. -Qed. - - -Context { prec_gt_0_ : Prec_gt_0 prec }. - -Notation format := (generic_format beta (FLX_exp prec)). -Notation cexp := (canonic_exp beta (FLX_exp prec)). - -Variable choice : Z -> bool. - - -(** Remainder of the division in FLX *) -Theorem div_error_FLX : - forall rnd { Zrnd : Valid_rnd rnd } x y, - format x -> format y -> - format (x - round beta (FLX_exp prec) rnd (x/y) * y)%R. -Proof with auto with typeclass_instances. -intros rnd Zrnd x y Hx Hy. -destruct (Req_dec y 0) as [Zy|Zy]. -now rewrite Zy, Rmult_0_r, Rminus_0_r. -destruct (Req_dec (round beta (FLX_exp prec) rnd (x/y)) 0) as [Hr|Hr]. -rewrite Hr; ring_simplify (x-0*y)%R; assumption. -assert (Zx: x <> R0). -contradict Hr. -rewrite Hr. -unfold Rdiv. -now rewrite Rmult_0_l, round_0. -destruct (ex_Fexp_canonic _ x Hx) as (fx,(Hx1,Hx2)). -destruct (ex_Fexp_canonic _ y Hy) as (fy,(Hy1,Hy2)). -destruct (ex_Fexp_canonic (FLX_exp prec) (round beta (FLX_exp prec) rnd (x / y))) as (fr,(Hr1,Hr2)). -apply generic_format_round... -unfold Rminus; apply generic_format_plus_prec with fx (Fopp beta (Fmult beta fr fy)); trivial. -intros e; apply Zle_refl. -now rewrite F2R_opp, F2R_mult, <- Hr1, <- Hy1. -(* *) -destruct (relative_error_FLX_ex beta prec (prec_gt_0 prec) rnd (x / y)%R) as (eps,(Heps1,Heps2)). -rewrite Heps2. -rewrite <- Rabs_Ropp. -replace (-(x + - (x / y * (1 + eps) * y)))%R with (x * eps)%R by now field. -rewrite Rabs_mult. -apply Rlt_le_trans with (Rabs x * 1)%R. -apply Rmult_lt_compat_l. -now apply Rabs_pos_lt. -apply Rlt_le_trans with (1 := Heps1). -change 1%R with (bpow 0). -apply bpow_le. -generalize (prec_gt_0 prec). -clear ; omega. -rewrite Rmult_1_r. -rewrite Hx2. -unfold canonic_exp. -destruct (ln_beta beta x) as (ex, Hex). -simpl. -specialize (Hex Zx). -apply Rlt_le. -apply Rlt_le_trans with (1 := proj2 Hex). -apply bpow_le. -unfold FLX_exp. -ring_simplify. -apply Zle_refl. -(* *) -replace (Fexp (Fopp beta (Fmult beta fr fy))) with (Fexp fr + Fexp fy)%Z. -2: unfold Fopp, Fmult; destruct fr; destruct fy; now simpl. -replace (x + - (round beta (FLX_exp prec) rnd (x / y) * y))%R with - (y * (-(round beta (FLX_exp prec) rnd (x / y) - x/y)))%R. -2: field; assumption. -rewrite Rabs_mult. -apply Rlt_le_trans with (Rabs y * bpow (Fexp fr))%R. -apply Rmult_lt_compat_l. -now apply Rabs_pos_lt. -rewrite Rabs_Ropp. -replace (bpow (Fexp fr)) with (ulp beta (FLX_exp prec) (F2R fr)). -rewrite <- Hr1. -apply error_lt_ulp_round... -apply Rmult_integral_contrapositive_currified; try apply Rinv_neq_0_compat; assumption. -rewrite ulp_neq_0. -2: now rewrite <- Hr1. -apply f_equal. -now rewrite Hr2, <- Hr1. -replace (prec+(Fexp fr+Fexp fy))%Z with ((prec+Fexp fy)+Fexp fr)%Z by ring. -rewrite bpow_plus. -apply Rmult_le_compat_r. -apply bpow_ge_0. -rewrite Hy2; unfold canonic_exp, FLX_exp. -ring_simplify (prec + (ln_beta beta y - prec))%Z. -destruct (ln_beta beta y); simpl. -left; now apply a. -Qed. - -(** Remainder of the square in FLX (with p>1) and rounding to nearest *) -Variable Hp1 : Zlt 1 prec. - -Theorem sqrt_error_FLX_N : - forall x, format x -> - format (x - Rsqr (round beta (FLX_exp prec) (Znearest choice) (sqrt x)))%R. -Proof with auto with typeclass_instances. -intros x Hx. -destruct (total_order_T x 0) as [[Hxz|Hxz]|Hxz]. -unfold sqrt. -destruct (Rcase_abs x). -rewrite round_0... -unfold Rsqr. -now rewrite Rmult_0_l, Rminus_0_r. -elim (Rlt_irrefl 0). -now apply Rgt_ge_trans with x. -rewrite Hxz, sqrt_0, round_0... -unfold Rsqr. -rewrite Rmult_0_l, Rminus_0_r. -apply generic_format_0. -case (Req_dec (round beta (FLX_exp prec) (Znearest choice) (sqrt x)) 0); intros Hr. -rewrite Hr; unfold Rsqr; ring_simplify (x-0*0)%R; assumption. -destruct (ex_Fexp_canonic _ x Hx) as (fx,(Hx1,Hx2)). -destruct (ex_Fexp_canonic (FLX_exp prec) (round beta (FLX_exp prec) (Znearest choice) (sqrt x))) as (fr,(Hr1,Hr2)). -apply generic_format_round... -unfold Rminus; apply generic_format_plus_prec with fx (Fopp beta (Fmult beta fr fr)); trivial. -intros e; apply Zle_refl. -unfold Rsqr; now rewrite F2R_opp,F2R_mult, <- Hr1. -(* *) -apply Rle_lt_trans with x. -apply Rabs_minus_le. -apply Rle_0_sqr. -destruct (relative_error_N_FLX_ex beta prec (prec_gt_0 prec) choice (sqrt x)) as (eps,(Heps1,Heps2)). -rewrite Heps2. -rewrite Rsqr_mult, Rsqr_sqrt, Rmult_comm. 2: now apply Rlt_le. -apply Rmult_le_compat_r. -now apply Rlt_le. -apply Rle_trans with (5²/4²)%R. -rewrite <- Rsqr_div. -apply Rsqr_le_abs_1. -apply Rle_trans with (1 := Rabs_triang _ _). -rewrite Rabs_R1. -apply Rplus_le_reg_l with (-1)%R. -replace (-1 + (1 + Rabs eps))%R with (Rabs eps) by ring. -apply Rle_trans with (1 := Heps1). -rewrite Rabs_pos_eq. -apply Rmult_le_reg_l with 2%R. -now apply (Z2R_lt 0 2). -rewrite <- Rmult_assoc, Rinv_r, Rmult_1_l. -apply Rle_trans with (bpow (-1)). -apply bpow_le. -omega. -replace (2 * (-1 + 5 / 4))%R with (/2)%R by field. -apply Rinv_le. -now apply (Z2R_lt 0 2). -apply (Z2R_le 2). -unfold Zpower_pos. simpl. -rewrite Zmult_1_r. -apply Zle_bool_imp_le. -apply beta. -apply Rgt_not_eq. -now apply (Z2R_lt 0 2). -unfold Rdiv. -apply Rmult_le_pos. -now apply (Z2R_le 0 5). -apply Rlt_le. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 4). -apply Rgt_not_eq. -now apply (Z2R_lt 0 4). -unfold Rsqr. -replace (5 * 5 / (4 * 4))%R with (25 * /16)%R by field. -apply Rmult_le_reg_r with 16%R. -now apply (Z2R_lt 0 16). -rewrite Rmult_assoc, Rinv_l, Rmult_1_r. -now apply (Z2R_le 25 32). -apply Rgt_not_eq. -now apply (Z2R_lt 0 16). -rewrite Hx2; unfold canonic_exp, FLX_exp. -ring_simplify (prec + (ln_beta beta x - prec))%Z. -destruct (ln_beta beta x); simpl. -rewrite <- (Rabs_right x). -apply a. -now apply Rgt_not_eq. -now apply Rgt_ge. -(* *) -replace (Fexp (Fopp beta (Fmult beta fr fr))) with (Fexp fr + Fexp fr)%Z. -2: unfold Fopp, Fmult; destruct fr; now simpl. -rewrite Hr1. -replace (x + - Rsqr (F2R fr))%R with (-((F2R fr - sqrt x)*(F2R fr + sqrt x)))%R. -2: rewrite <- (sqrt_sqrt x) at 3; auto. -2: unfold Rsqr; ring. -rewrite Rabs_Ropp, Rabs_mult. -apply Rle_lt_trans with ((/2*bpow (Fexp fr))* Rabs (F2R fr + sqrt x))%R. -apply Rmult_le_compat_r. -apply Rabs_pos. -apply Rle_trans with (/2*ulp beta (FLX_exp prec) (F2R fr))%R. -rewrite <- Hr1. -apply error_le_half_ulp_round... -right; rewrite ulp_neq_0. -2: now rewrite <- Hr1. -apply f_equal. -rewrite Hr2, <- Hr1; trivial. -rewrite Rmult_assoc, Rmult_comm. -replace (prec+(Fexp fr+Fexp fr))%Z with (Fexp fr + (prec+Fexp fr))%Z by ring. -rewrite bpow_plus, Rmult_assoc. -apply Rmult_lt_compat_l. -apply bpow_gt_0. -apply Rmult_lt_reg_l with (1 := Rlt_0_2). -apply Rle_lt_trans with (Rabs (F2R fr + sqrt x)). -right; field. -apply Rle_lt_trans with (1:=Rabs_triang _ _). -(* . *) -assert (Rabs (F2R fr) < bpow (prec + Fexp fr))%R. -rewrite Hr2; unfold canonic_exp; rewrite Hr1. -unfold FLX_exp. -ring_simplify (prec + (ln_beta beta (F2R fr) - prec))%Z. -destruct (ln_beta beta (F2R fr)); simpl. -apply a. -rewrite <- Hr1; auto. -(* . *) -apply Rlt_le_trans with (bpow (prec + Fexp fr)+ Rabs (sqrt x))%R. -now apply Rplus_lt_compat_r. -(* . *) -replace (2 * bpow (prec + Fexp fr))%R with (bpow (prec + Fexp fr) + bpow (prec + Fexp fr))%R by ring. -apply Rplus_le_compat_l. -assert (sqrt x <> 0)%R. -apply Rgt_not_eq. -now apply sqrt_lt_R0. -destruct (ln_beta beta (sqrt x)) as (es,Es). -specialize (Es H0). -apply Rle_trans with (bpow es). -now apply Rlt_le. -apply bpow_le. -case (Zle_or_lt es (prec + Fexp fr)) ; trivial. -intros H1. -absurd (Rabs (F2R fr) < bpow (es - 1))%R. -apply Rle_not_lt. -rewrite <- Hr1. -apply abs_round_ge_generic... -apply generic_format_bpow. -unfold FLX_exp; omega. -apply Es. -apply Rlt_le_trans with (1:=H). -apply bpow_le. -omega. -now apply Rlt_le. -Qed. - -End Fprop_divsqrt_error. diff --git a/flocq/Prop/Fprop_mult_error.v b/flocq/Prop/Fprop_mult_error.v deleted file mode 100644 index 44448cd6..00000000 --- a/flocq/Prop/Fprop_mult_error.v +++ /dev/null @@ -1,236 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2010-2013 Sylvie Boldo -#
# -Copyright (C) 2010-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** * Error of the multiplication is in the FLX/FLT format *) -Require Import Fcore. -Require Import Fcalc_ops. - -Section Fprop_mult_error. - -Variable beta : radix. -Notation bpow e := (bpow beta e). - -Variable prec : Z. -Context { prec_gt_0_ : Prec_gt_0 prec }. - -Notation format := (generic_format beta (FLX_exp prec)). -Notation cexp := (canonic_exp beta (FLX_exp prec)). - -Variable rnd : R -> Z. -Context { valid_rnd : Valid_rnd rnd }. - -(** Auxiliary result that provides the exponent *) -Lemma mult_error_FLX_aux: - forall x y, - format x -> format y -> - (round beta (FLX_exp prec) rnd (x * y) - (x * y) <> 0)%R -> - exists f:float beta, - (F2R f = round beta (FLX_exp prec) rnd (x * y) - (x * y))%R - /\ (canonic_exp beta (FLX_exp prec) (F2R f) <= Fexp f)%Z - /\ (Fexp f = cexp x + cexp y)%Z. -Proof with auto with typeclass_instances. -intros x y Hx Hy Hz. -set (f := (round beta (FLX_exp prec) rnd (x * y))). -destruct (Req_dec (x * y) 0) as [Hxy0|Hxy0]. -contradict Hz. -rewrite Hxy0. -rewrite round_0... -ring. -destruct (ln_beta beta (x * y)) as (exy, Hexy). -specialize (Hexy Hxy0). -destruct (ln_beta beta (f - x * y)) as (er, Her). -specialize (Her Hz). -destruct (ln_beta beta x) as (ex, Hex). -assert (Hx0: (x <> 0)%R). -contradict Hxy0. -now rewrite Hxy0, Rmult_0_l. -specialize (Hex Hx0). -destruct (ln_beta beta y) as (ey, Hey). -assert (Hy0: (y <> 0)%R). -contradict Hxy0. -now rewrite Hxy0, Rmult_0_r. -specialize (Hey Hy0). -(* *) -assert (Hc1: (cexp (x * y)%R - prec <= cexp x + cexp y)%Z). -unfold canonic_exp, FLX_exp. -rewrite ln_beta_unique with (1 := Hex). -rewrite ln_beta_unique with (1 := Hey). -rewrite ln_beta_unique with (1 := Hexy). -cut (exy - 1 < ex + ey)%Z. omega. -apply (lt_bpow beta). -apply Rle_lt_trans with (1 := proj1 Hexy). -rewrite Rabs_mult. -rewrite bpow_plus. -apply Rmult_le_0_lt_compat. -apply Rabs_pos. -apply Rabs_pos. -apply Hex. -apply Hey. -(* *) -assert (Hc2: (cexp x + cexp y <= cexp (x * y)%R)%Z). -unfold canonic_exp, FLX_exp. -rewrite ln_beta_unique with (1 := Hex). -rewrite ln_beta_unique with (1 := Hey). -rewrite ln_beta_unique with (1 := Hexy). -cut ((ex - 1) + (ey - 1) < exy)%Z. -generalize (prec_gt_0 prec). -clear ; omega. -apply (lt_bpow beta). -apply Rle_lt_trans with (2 := proj2 Hexy). -rewrite Rabs_mult. -rewrite bpow_plus. -apply Rmult_le_compat. -apply bpow_ge_0. -apply bpow_ge_0. -apply Hex. -apply Hey. -(* *) -assert (Hr: ((F2R (Float beta (- (Ztrunc (scaled_mantissa beta (FLX_exp prec) x) * - Ztrunc (scaled_mantissa beta (FLX_exp prec) y)) + rnd (scaled_mantissa beta (FLX_exp prec) (x * y)) * - beta ^ (cexp (x * y)%R - (cexp x + cexp y))) (cexp x + cexp y))) = f - x * y)%R). -rewrite Hx at 6. -rewrite Hy at 6. -rewrite <- F2R_mult. -simpl. -unfold f, round, Rminus. -rewrite <- F2R_opp, Rplus_comm, <- F2R_plus. -unfold Fplus. simpl. -now rewrite Zle_imp_le_bool with (1 := Hc2). -(* *) -exists (Float beta (- (Ztrunc (scaled_mantissa beta (FLX_exp prec) x) * - Ztrunc (scaled_mantissa beta (FLX_exp prec) y)) + rnd (scaled_mantissa beta (FLX_exp prec) (x * y)) * - beta ^ (cexp (x * y)%R - (cexp x + cexp y))) (cexp x + cexp y)). -split;[assumption|split]. -rewrite Hr. -simpl. -clear Hr. -apply Zle_trans with (cexp (x * y)%R - prec)%Z. -unfold canonic_exp, FLX_exp. -apply Zplus_le_compat_r. -rewrite ln_beta_unique with (1 := Hexy). -apply ln_beta_le_bpow with (1 := Hz). -replace (bpow (exy - prec)) with (ulp beta (FLX_exp prec) (x * y)). -apply error_lt_ulp... -rewrite ulp_neq_0; trivial. -unfold canonic_exp. -now rewrite ln_beta_unique with (1 := Hexy). -apply Hc1. -reflexivity. -Qed. - -(** Error of the multiplication in FLX *) -Theorem mult_error_FLX : - forall x y, - format x -> format y -> - format (round beta (FLX_exp prec) rnd (x * y) - (x * y))%R. -Proof. -intros x y Hx Hy. -destruct (Req_dec (round beta (FLX_exp prec) rnd (x * y) - x * y) 0) as [Hr0|Hr0]. -rewrite Hr0. -apply generic_format_0. -destruct (mult_error_FLX_aux x y Hx Hy Hr0) as ((m,e),(H1,(H2,H3))). -rewrite <- H1. -now apply generic_format_F2R. -Qed. - -End Fprop_mult_error. - -Section Fprop_mult_error_FLT. - -Variable beta : radix. -Notation bpow e := (bpow beta e). - -Variable emin prec : Z. -Context { prec_gt_0_ : Prec_gt_0 prec }. - -Notation format := (generic_format beta (FLT_exp emin prec)). -Notation cexp := (canonic_exp beta (FLT_exp emin prec)). - -Variable rnd : R -> Z. -Context { valid_rnd : Valid_rnd rnd }. - -(** Error of the multiplication in FLT with underflow requirements *) -Theorem mult_error_FLT : - forall x y, - format x -> format y -> - (x*y = 0)%R \/ (bpow (emin + 2*prec - 1) <= Rabs (x * y))%R -> - format (round beta (FLT_exp emin prec) rnd (x * y) - (x * y))%R. -Proof with auto with typeclass_instances. -intros x y Hx Hy Hxy. -set (f := (round beta (FLT_exp emin prec) rnd (x * y))). -destruct (Req_dec (f - x * y) 0) as [Hr0|Hr0]. -rewrite Hr0. -apply generic_format_0. -destruct Hxy as [Hxy|Hxy]. -unfold f. -rewrite Hxy. -rewrite round_0... -ring_simplify (0 - 0)%R. -apply generic_format_0. -destruct (mult_error_FLX_aux beta prec rnd x y) as ((m,e),(H1,(H2,H3))). -now apply generic_format_FLX_FLT with emin. -now apply generic_format_FLX_FLT with emin. -rewrite <- (round_FLT_FLX beta emin). -assumption. -apply Rle_trans with (2:=Hxy). -apply bpow_le. -generalize (prec_gt_0 prec). -clear ; omega. -rewrite <- (round_FLT_FLX beta emin) in H1. -2:apply Rle_trans with (2:=Hxy). -2:apply bpow_le ; generalize (prec_gt_0 prec) ; clear ; omega. -unfold f; rewrite <- H1. -apply generic_format_F2R. -intros _. -simpl in H2, H3. -unfold canonic_exp, FLT_exp. -case (Zmax_spec (ln_beta beta (F2R (Float beta m e)) - prec) emin); - intros (M1,M2); rewrite M2. -apply Zle_trans with (2:=H2). -unfold canonic_exp, FLX_exp. -apply Zle_refl. -rewrite H3. -unfold canonic_exp, FLX_exp. -assert (Hxy0:(x*y <> 0)%R). -contradict Hr0. -unfold f. -rewrite Hr0. -rewrite round_0... -ring. -assert (Hx0: (x <> 0)%R). -contradict Hxy0. -now rewrite Hxy0, Rmult_0_l. -assert (Hy0: (y <> 0)%R). -contradict Hxy0. -now rewrite Hxy0, Rmult_0_r. -destruct (ln_beta beta x) as (ex,Ex) ; simpl. -specialize (Ex Hx0). -destruct (ln_beta beta y) as (ey,Ey) ; simpl. -specialize (Ey Hy0). -assert (emin + 2 * prec -1 < ex + ey)%Z. -2: omega. -apply (lt_bpow beta). -apply Rle_lt_trans with (1:=Hxy). -rewrite Rabs_mult, bpow_plus. -apply Rmult_le_0_lt_compat; try apply Rabs_pos. -apply Ex. -apply Ey. -Qed. - -End Fprop_mult_error_FLT. diff --git a/flocq/Prop/Fprop_plus_error.v b/flocq/Prop/Fprop_plus_error.v deleted file mode 100644 index 9bb5aee8..00000000 --- a/flocq/Prop/Fprop_plus_error.v +++ /dev/null @@ -1,538 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2010-2013 Sylvie Boldo -#
# -Copyright (C) 2010-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** * Error of the rounded-to-nearest addition is representable. *) - -Require Import Psatz. -Require Import Fcore_Raux. -Require Import Fcore_defs. -Require Import Fcore_float_prop. -Require Import Fcore_generic_fmt. -Require Import Fcore_FIX. -Require Import Fcore_FLX. -Require Import Fcore_FLT. -Require Import Fcore_ulp. -Require Import Fcalc_ops. - - -Section Fprop_plus_error. - -Variable beta : radix. -Notation bpow e := (bpow beta e). - -Variable fexp : Z -> Z. -Context { valid_exp : Valid_exp fexp }. - -Section round_repr_same_exp. - -Variable rnd : R -> Z. -Context { valid_rnd : Valid_rnd rnd }. - -Theorem round_repr_same_exp : - forall m e, - exists m', - round beta fexp rnd (F2R (Float beta m e)) = F2R (Float beta m' e). -Proof with auto with typeclass_instances. -intros m e. -set (e' := canonic_exp beta fexp (F2R (Float beta m e))). -unfold round, scaled_mantissa. fold e'. -destruct (Zle_or_lt e' e) as [He|He]. -exists m. -unfold F2R at 2. simpl. -rewrite Rmult_assoc, <- bpow_plus. -rewrite <- Z2R_Zpower. 2: omega. -rewrite <- Z2R_mult, Zrnd_Z2R... -unfold F2R. simpl. -rewrite Z2R_mult. -rewrite Rmult_assoc. -rewrite Z2R_Zpower. 2: omega. -rewrite <- bpow_plus. -apply (f_equal (fun v => Z2R m * bpow v)%R). -ring. -exists ((rnd (Z2R m * bpow (e - e'))) * Zpower beta (e' - e))%Z. -unfold F2R. simpl. -rewrite Z2R_mult. -rewrite Z2R_Zpower. 2: omega. -rewrite 2!Rmult_assoc. -rewrite <- 2!bpow_plus. -apply (f_equal (fun v => _ * bpow v)%R). -ring. -Qed. - -End round_repr_same_exp. - -Context { monotone_exp : Monotone_exp fexp }. -Notation format := (generic_format beta fexp). - -Variable choice : Z -> bool. - -Lemma plus_error_aux : - forall x y, - (canonic_exp beta fexp x <= canonic_exp beta fexp y)%Z -> - format x -> format y -> - format (round beta fexp (Znearest choice) (x + y) - (x + y))%R. -Proof. -intros x y. -set (ex := canonic_exp beta fexp x). -set (ey := canonic_exp beta fexp y). -intros He Hx Hy. -destruct (Req_dec (round beta fexp (Znearest choice) (x + y) - (x + y)) R0) as [H0|H0]. -rewrite H0. -apply generic_format_0. -set (mx := Ztrunc (scaled_mantissa beta fexp x)). -set (my := Ztrunc (scaled_mantissa beta fexp y)). -(* *) -assert (Hxy: (x + y)%R = F2R (Float beta (mx + my * beta ^ (ey - ex)) ex)). -rewrite Hx, Hy. -fold mx my ex ey. -rewrite <- F2R_plus. -unfold Fplus. simpl. -now rewrite Zle_imp_le_bool with (1 := He). -(* *) -rewrite Hxy. -destruct (round_repr_same_exp (Znearest choice) (mx + my * beta ^ (ey - ex)) ex) as (mxy, Hxy'). -rewrite Hxy'. -assert (H: (F2R (Float beta mxy ex) - F2R (Float beta (mx + my * beta ^ (ey - ex)) ex))%R = - F2R (Float beta (mxy - (mx + my * beta ^ (ey - ex))) ex)). -now rewrite <- F2R_minus, Fminus_same_exp. -rewrite H. -apply generic_format_F2R. -intros _. -apply monotone_exp. -rewrite <- H, <- Hxy', <- Hxy. -apply ln_beta_le_abs. -exact H0. -pattern x at 3 ; replace x with (-(y - (x + y)))%R by ring. -rewrite Rabs_Ropp. -now apply (round_N_pt beta _ choice (x + y)). -Qed. - -(** Error of the addition *) -Theorem plus_error : - forall x y, - format x -> format y -> - format (round beta fexp (Znearest choice) (x + y) - (x + y))%R. -Proof. -intros x y Hx Hy. -destruct (Zle_or_lt (canonic_exp beta fexp x) (canonic_exp beta fexp y)). -now apply plus_error_aux. -rewrite Rplus_comm. -apply plus_error_aux ; try easy. -now apply Zlt_le_weak. -Qed. - -End Fprop_plus_error. - -Section Fprop_plus_zero. - -Variable beta : radix. -Notation bpow e := (bpow beta e). - -Variable fexp : Z -> Z. -Context { valid_exp : Valid_exp fexp }. -Context { exp_not_FTZ : Exp_not_FTZ fexp }. -Notation format := (generic_format beta fexp). - -Section round_plus_eq_zero_aux. - -Variable rnd : R -> Z. -Context { valid_rnd : Valid_rnd rnd }. - -Lemma round_plus_eq_zero_aux : - forall x y, - (canonic_exp beta fexp x <= canonic_exp beta fexp y)%Z -> - format x -> format y -> - (0 <= x + y)%R -> - round beta fexp rnd (x + y) = 0%R -> - (x + y = 0)%R. -Proof with auto with typeclass_instances. -intros x y He Hx Hy Hp Hxy. -destruct (Req_dec (x + y) 0) as [H0|H0]. -exact H0. -destruct (ln_beta beta (x + y)) as (exy, Hexy). -simpl. -specialize (Hexy H0). -destruct (Zle_or_lt exy (fexp exy)) as [He'|He']. -(* . *) -assert (H: (x + y)%R = F2R (Float beta (Ztrunc (x * bpow (- fexp exy)) + - Ztrunc (y * bpow (- fexp exy))) (fexp exy))). -rewrite (subnormal_exponent beta fexp exy x He' Hx) at 1. -rewrite (subnormal_exponent beta fexp exy y He' Hy) at 1. -now rewrite <- F2R_plus, Fplus_same_exp. -rewrite H in Hxy. -rewrite round_generic in Hxy... -now rewrite <- H in Hxy. -apply generic_format_F2R. -intros _. -rewrite <- H. -unfold canonic_exp. -rewrite ln_beta_unique with (1 := Hexy). -apply Zle_refl. -(* . *) -elim Rle_not_lt with (1 := round_le beta _ rnd _ _ (proj1 Hexy)). -rewrite (Rabs_pos_eq _ Hp). -rewrite Hxy. -rewrite round_generic... -apply bpow_gt_0. -apply generic_format_bpow. -apply Zlt_succ_le. -now rewrite (Zsucc_pred exy) in He'. -Qed. - -End round_plus_eq_zero_aux. - -Variable rnd : R -> Z. -Context { valid_rnd : Valid_rnd rnd }. - -(** rnd(x+y)=0 -> x+y = 0 provided this is not a FTZ format *) -Theorem round_plus_eq_zero : - forall x y, - format x -> format y -> - round beta fexp rnd (x + y) = 0%R -> - (x + y = 0)%R. -Proof with auto with typeclass_instances. -intros x y Hx Hy. -destruct (Rle_or_lt 0 (x + y)) as [H1|H1]. -(* . *) -revert H1. -destruct (Zle_or_lt (canonic_exp beta fexp x) (canonic_exp beta fexp y)) as [H2|H2]. -now apply round_plus_eq_zero_aux. -rewrite Rplus_comm. -apply round_plus_eq_zero_aux ; try easy. -now apply Zlt_le_weak. -(* . *) -revert H1. -rewrite <- (Ropp_involutive (x + y)), Ropp_plus_distr, <- Ropp_0. -intros H1. -rewrite round_opp. -intros Hxy. -apply f_equal. -cut (round beta fexp (Zrnd_opp rnd) (- x + - y) = 0)%R. -cut (0 <= -x + -y)%R. -destruct (Zle_or_lt (canonic_exp beta fexp (-x)) (canonic_exp beta fexp (-y))) as [H2|H2]. -apply round_plus_eq_zero_aux ; try apply generic_format_opp... -rewrite Rplus_comm. -apply round_plus_eq_zero_aux ; try apply generic_format_opp... -now apply Zlt_le_weak. -apply Rlt_le. -now apply Ropp_lt_cancel. -rewrite <- (Ropp_involutive (round _ _ _ _)). -rewrite Hxy. -apply Ropp_involutive. -Qed. - -End Fprop_plus_zero. - -Section Fprop_plus_FLT. -Variable beta : radix. - -Notation bpow e := (bpow beta e). - -Variable emin prec : Z. -Context { prec_gt_0_ : Prec_gt_0 prec }. - -Theorem FLT_format_plus_small: forall x y, - generic_format beta (FLT_exp emin prec) x -> - generic_format beta (FLT_exp emin prec) y -> - (Rabs (x+y) <= bpow (prec+emin))%R -> - generic_format beta (FLT_exp emin prec) (x+y). -Proof with auto with typeclass_instances. -intros x y Fx Fy H. -apply generic_format_FLT_FIX... -rewrite Zplus_comm; assumption. -apply generic_format_FIX_FLT, FIX_format_generic in Fx. -apply generic_format_FIX_FLT, FIX_format_generic in Fy. -destruct Fx as (nx,(H1x,H2x)). -destruct Fy as (ny,(H1y,H2y)). -apply generic_format_FIX. -exists (Float beta (Fnum nx+Fnum ny)%Z emin). -split;[idtac|reflexivity]. -rewrite H1x,H1y; unfold F2R; simpl. -rewrite H2x, H2y. -rewrite Z2R_plus; ring. -Qed. - -End Fprop_plus_FLT. - -Section Fprop_plus_mult_ulp. - -Variable beta : radix. -Notation bpow e := (bpow beta e). - -Variable fexp : Z -> Z. -Context { valid_exp : Valid_exp fexp }. -Context { monotone_exp : Monotone_exp fexp }. -Variable rnd : R -> Z. -Context { valid_rnd : Valid_rnd rnd }. - -Notation format := (generic_format beta fexp). -Notation cexp := (canonic_exp beta fexp). - -Lemma ex_shift : - forall x e, format x -> (e <= cexp x)%Z -> - exists m, (x = Z2R m * bpow e)%R. -Proof with auto with typeclass_instances. -intros x e Fx He. -exists (Ztrunc (scaled_mantissa beta fexp x)*Zpower beta (cexp x -e))%Z. -rewrite Fx at 1; unfold F2R; simpl. -rewrite Z2R_mult, Rmult_assoc. -f_equal. -rewrite Z2R_Zpower. -2: omega. -rewrite <- bpow_plus; f_equal; ring. -Qed. - -Lemma ln_beta_minus1 : - forall z, z <> 0%R -> - (ln_beta beta z - 1)%Z = ln_beta beta (z / Z2R beta). -Proof. -intros z Hz. -unfold Zminus. -rewrite <- ln_beta_mult_bpow with (1 := Hz). -now rewrite bpow_opp, bpow_1. -Qed. - -Theorem round_plus_mult_ulp : - forall x y, format x -> format y -> (x <> 0)%R -> - exists m, (round beta fexp rnd (x+y) = Z2R m * ulp beta fexp (x/Z2R beta))%R. -Proof with auto with typeclass_instances. -intros x y Fx Fy Zx. -case (Zle_or_lt (ln_beta beta (x/Z2R beta)) (ln_beta beta y)); intros H1. -pose (e:=cexp (x / Z2R beta)). -destruct (ex_shift x e) as (nx, Hnx); try exact Fx. -apply monotone_exp. -rewrite <- (ln_beta_minus1 x Zx); omega. -destruct (ex_shift y e) as (ny, Hny); try assumption. -apply monotone_exp... -destruct (round_repr_same_exp beta fexp rnd (nx+ny) e) as (n,Hn). -exists n. -apply trans_eq with (F2R (Float beta n e)). -rewrite <- Hn; f_equal. -rewrite Hnx, Hny; unfold F2R; simpl; rewrite Z2R_plus; ring. -unfold F2R; simpl. -rewrite ulp_neq_0; try easy. -apply Rmult_integral_contrapositive_currified; try assumption. -apply Rinv_neq_0_compat. -apply Rgt_not_eq. -apply radix_pos. -(* *) -destruct (ex_shift (round beta fexp rnd (x + y)) (cexp (x/Z2R beta))) as (n,Hn). -apply generic_format_round... -apply Zle_trans with (cexp (x+y)). -apply monotone_exp. -rewrite <- ln_beta_minus1 by easy. -rewrite <- (ln_beta_abs beta (x+y)). -(* . *) -assert (U: (Rabs (x+y) = Rabs x + Rabs y)%R \/ (y <> 0 /\ Rabs (x+y) = Rabs x - Rabs y)%R). -assert (V: forall x y, (Rabs y <= Rabs x)%R -> - (Rabs (x+y) = Rabs x + Rabs y)%R \/ (y <> 0 /\ Rabs (x+y) = Rabs x - Rabs y)%R). -clear; intros x y. -case (Rle_or_lt 0 y); intros Hy. -case Hy; intros Hy'. -case (Rle_or_lt 0 x); intros Hx. -intros _; rewrite (Rabs_pos_eq y) by easy. -rewrite (Rabs_pos_eq x) by easy. -left; apply Rabs_pos_eq. -now apply Rplus_le_le_0_compat. -rewrite (Rabs_pos_eq y) by easy. -rewrite (Rabs_left x) by easy. -intros H; right; split. -now apply Rgt_not_eq. -rewrite Rabs_left1. -ring. -apply Rplus_le_reg_l with (-x)%R; ring_simplify; assumption. -intros _; left. -now rewrite <- Hy', Rabs_R0, 2!Rplus_0_r. -case (Rle_or_lt 0 x); intros Hx. -rewrite (Rabs_left y) by easy. -rewrite (Rabs_pos_eq x) by easy. -intros H; right; split. -now apply Rlt_not_eq. -rewrite Rabs_pos_eq. -ring. -apply Rplus_le_reg_l with (-y)%R; ring_simplify; assumption. -intros _; left. -rewrite (Rabs_left y) by easy. -rewrite (Rabs_left x) by easy. -rewrite Rabs_left1. -ring. -lra. -apply V; left. -apply ln_beta_lt_pos with beta. -now apply Rabs_pos_lt. -rewrite <- ln_beta_minus1 in H1; try assumption. -rewrite 2!ln_beta_abs; omega. -(* . *) -destruct U as [U|U]. -rewrite U; apply Zle_trans with (ln_beta beta x). -omega. -rewrite <- ln_beta_abs. -apply ln_beta_le. -now apply Rabs_pos_lt. -apply Rplus_le_reg_l with (-Rabs x)%R; ring_simplify. -apply Rabs_pos. -destruct U as (U',U); rewrite U. -rewrite <- ln_beta_abs. -apply ln_beta_minus_lb. -now apply Rabs_pos_lt. -now apply Rabs_pos_lt. -rewrite 2!ln_beta_abs. -assert (ln_beta beta y < ln_beta beta x - 1)%Z. -now rewrite (ln_beta_minus1 x Zx). -omega. -apply canonic_exp_round_ge... -intros K. -apply round_plus_eq_zero in K... -contradict H1; apply Zle_not_lt. -rewrite <- (ln_beta_minus1 x Zx). -replace y with (-x)%R. -rewrite ln_beta_opp; omega. -lra. -exists n. -rewrite ulp_neq_0. -assumption. -apply Rmult_integral_contrapositive_currified; try assumption. -apply Rinv_neq_0_compat. -apply Rgt_not_eq. -apply radix_pos. -Qed. - -Context {exp_not_FTZ : Exp_not_FTZ fexp}. - -Theorem round_plus_ge_ulp : - forall x y, format x -> format y -> - round beta fexp rnd (x+y) = 0%R \/ - (ulp beta fexp (x/Z2R beta) <= Rabs (round beta fexp rnd (x+y)))%R. -Proof with auto with typeclass_instances. -intros x y Fx Fy. -case (Req_dec x 0); intros Zx. -(* *) -rewrite Zx, Rplus_0_l. -rewrite round_generic... -unfold Rdiv; rewrite Rmult_0_l. -rewrite Fy at 2. -unfold F2R; simpl; rewrite Rabs_mult. -rewrite (Rabs_pos_eq (bpow _)) by apply bpow_ge_0. -case (Z.eq_dec (Ztrunc (scaled_mantissa beta fexp y)) 0); intros Hm. -left. -rewrite Fy, Hm; unfold F2R; simpl; ring. -right. -apply Rle_trans with (1*bpow (cexp y))%R. -rewrite Rmult_1_l. -rewrite <- ulp_neq_0. -apply ulp_ge_ulp_0... -intros K; apply Hm. -rewrite K, scaled_mantissa_0. -apply (Ztrunc_Z2R 0). -apply Rmult_le_compat_r. -apply bpow_ge_0. -rewrite <- Z2R_abs. -apply (Z2R_le 1). -apply (Zlt_le_succ 0). -now apply Z.abs_pos. -(* *) -destruct (round_plus_mult_ulp x y Fx Fy Zx) as (m,Hm). -case (Z.eq_dec m 0); intros Zm. -left. -rewrite Hm, Zm; simpl; ring. -right. -rewrite Hm, Rabs_mult. -rewrite (Rabs_pos_eq (ulp _ _ _)) by apply ulp_ge_0. -apply Rle_trans with (1*ulp beta fexp (x/Z2R beta))%R. -right; ring. -apply Rmult_le_compat_r. -apply ulp_ge_0. -rewrite <- Z2R_abs. -apply (Z2R_le 1). -apply (Zlt_le_succ 0). -now apply Z.abs_pos. -Qed. - -End Fprop_plus_mult_ulp. - -Section Fprop_plus_ge_ulp. - -Variable beta : radix. -Notation bpow e := (bpow beta e). - -Variable rnd : R -> Z. -Context { valid_rnd : Valid_rnd rnd }. -Variable emin prec : Z. -Context { prec_gt_0_ : Prec_gt_0 prec }. - -Theorem round_plus_ge_ulp_FLT : forall x y e, - generic_format beta (FLT_exp emin prec) x -> generic_format beta (FLT_exp emin prec) y -> - (bpow e <= Rabs x)%R -> - round beta (FLT_exp emin prec) rnd (x+y) = 0%R \/ - (bpow (e - prec) <= Rabs (round beta (FLT_exp emin prec) rnd (x+y)))%R. -Proof with auto with typeclass_instances. -intros x y e Fx Fy He. -assert (Zx: x <> 0%R). - contradict He. - apply Rlt_not_le; rewrite He, Rabs_R0. - apply bpow_gt_0. -case round_plus_ge_ulp with beta (FLT_exp emin prec) rnd x y... -intros H; right. -apply Rle_trans with (2:=H). -rewrite ulp_neq_0. -unfold canonic_exp. -rewrite <- ln_beta_minus1 by easy. -unfold FLT_exp; apply bpow_le. -apply Zle_trans with (2:=Z.le_max_l _ _). -destruct (ln_beta beta x) as (n,Hn); simpl. -assert (e < n)%Z; try omega. -apply lt_bpow with beta. -apply Rle_lt_trans with (1:=He). -now apply Hn. -apply Rmult_integral_contrapositive_currified; try assumption. -apply Rinv_neq_0_compat. -apply Rgt_not_eq. -apply radix_pos. -Qed. - -Theorem round_plus_ge_ulp_FLX : forall x y e, - generic_format beta (FLX_exp prec) x -> generic_format beta (FLX_exp prec) y -> - (bpow e <= Rabs x)%R -> - round beta (FLX_exp prec) rnd (x+y) = 0%R \/ - (bpow (e - prec) <= Rabs (round beta (FLX_exp prec) rnd (x+y)))%R. -Proof with auto with typeclass_instances. -intros x y e Fx Fy He. -assert (Zx: x <> 0%R). - contradict He. - apply Rlt_not_le; rewrite He, Rabs_R0. - apply bpow_gt_0. -case round_plus_ge_ulp with beta (FLX_exp prec) rnd x y... -intros H; right. -apply Rle_trans with (2:=H). -rewrite ulp_neq_0. -unfold canonic_exp. -rewrite <- ln_beta_minus1 by easy. -unfold FLX_exp; apply bpow_le. -destruct (ln_beta beta x) as (n,Hn); simpl. -assert (e < n)%Z; try omega. -apply lt_bpow with beta. -apply Rle_lt_trans with (1:=He). -now apply Hn. -apply Rmult_integral_contrapositive_currified; try assumption. -apply Rinv_neq_0_compat. -apply Rgt_not_eq. -apply radix_pos. -Qed. - -End Fprop_plus_ge_ulp. diff --git a/flocq/Prop/Fprop_relative.v b/flocq/Prop/Fprop_relative.v deleted file mode 100644 index 276ccd3b..00000000 --- a/flocq/Prop/Fprop_relative.v +++ /dev/null @@ -1,782 +0,0 @@ -(** -This file is part of the Flocq formalization of floating-point -arithmetic in Coq: http://flocq.gforge.inria.fr/ - -Copyright (C) 2010-2013 Sylvie Boldo -#
# -Copyright (C) 2010-2013 Guillaume Melquiond - -This library is free software; you can redistribute it and/or -modify it under the terms of the GNU Lesser General Public -License as published by the Free Software Foundation; either -version 3 of the License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -COPYING file for more details. -*) - -(** * Relative error of the roundings *) -Require Import Fcore. - -Section Fprop_relative. - -Variable beta : radix. -Notation bpow e := (bpow beta e). - -Section Fprop_relative_generic. - -Variable fexp : Z -> Z. -Context { prop_exp : Valid_exp fexp }. - -Section relative_error_conversion. - -Variable rnd : R -> Z. -Context { valid_rnd : Valid_rnd rnd }. - -Lemma relative_error_lt_conversion : - forall x b, (0 < b)%R -> - (x <> 0 -> Rabs (round beta fexp rnd x - x) < b * Rabs x)%R -> - exists eps, - (Rabs eps < b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R. -Proof with auto with typeclass_instances. -intros x b Hb0 Hxb. -destruct (Req_dec x 0) as [Hx0|Hx0]. -(* *) -exists 0%R. -split. -now rewrite Rabs_R0. -rewrite Hx0, Rmult_0_l. -apply round_0... -(* *) -specialize (Hxb Hx0). -exists ((round beta fexp rnd x - x) / x)%R. -split. 2: now field. -unfold Rdiv. -rewrite Rabs_mult. -apply Rmult_lt_reg_r with (Rabs x). -now apply Rabs_pos_lt. -rewrite Rmult_assoc, <- Rabs_mult. -rewrite Rinv_l with (1 := Hx0). -now rewrite Rabs_R1, Rmult_1_r. -Qed. - -Lemma relative_error_le_conversion : - forall x b, (0 <= b)%R -> - (Rabs (round beta fexp rnd x - x) <= b * Rabs x)%R -> - exists eps, - (Rabs eps <= b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R. -Proof with auto with typeclass_instances. -intros x b Hb0 Hxb. -destruct (Req_dec x 0) as [Hx0|Hx0]. -(* *) -exists 0%R. -split. -now rewrite Rabs_R0. -rewrite Hx0, Rmult_0_l. -apply round_0... -(* *) -exists ((round beta fexp rnd x - x) / x)%R. -split. 2: now field. -unfold Rdiv. -rewrite Rabs_mult. -apply Rmult_le_reg_r with (Rabs x). -now apply Rabs_pos_lt. -rewrite Rmult_assoc, <- Rabs_mult. -rewrite Rinv_l with (1 := Hx0). -now rewrite Rabs_R1, Rmult_1_r. -Qed. - -End relative_error_conversion. - -Variable emin p : Z. -Hypothesis Hmin : forall k, (emin < k)%Z -> (p <= k - fexp k)%Z. - -Variable rnd : R -> Z. -Context { valid_rnd : Valid_rnd rnd }. - -Theorem relative_error : - forall x, - (bpow emin <= Rabs x)%R -> - (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs x)%R. -Proof with auto with typeclass_instances. -intros x Hx. -assert (Hx': (x <> 0)%R). -intros T; contradict Hx; rewrite T, Rabs_R0. -apply Rlt_not_le, bpow_gt_0. -apply Rlt_le_trans with (ulp beta fexp x)%R. -now apply error_lt_ulp... -rewrite ulp_neq_0; trivial. -unfold canonic_exp. -destruct (ln_beta beta x) as (ex, He). -simpl. -specialize (He Hx'). -apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R. -rewrite <- bpow_plus. -apply bpow_le. -assert (emin < ex)%Z. -apply (lt_bpow beta). -apply Rle_lt_trans with (2 := proj2 He). -exact Hx. -generalize (Hmin ex). -omega. -apply Rmult_le_compat_l. -apply bpow_ge_0. -apply He. -Qed. - -(** 1+#ε# property in any rounding *) -Theorem relative_error_ex : - forall x, - (bpow emin <= Rabs x)%R -> - exists eps, - (Rabs eps < bpow (-p + 1))%R /\ round beta fexp rnd x = (x * (1 + eps))%R. -Proof with auto with typeclass_instances. -intros x Hx. -apply relative_error_lt_conversion... -apply bpow_gt_0. -intros _. -now apply relative_error. -Qed. - -Theorem relative_error_F2R_emin : - forall m, let x := F2R (Float beta m emin) in - (x <> 0)%R -> - (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs x)%R. -Proof. -intros m x Hx. -apply relative_error. -unfold x. -rewrite <- F2R_Zabs. -apply bpow_le_F2R. -apply F2R_lt_reg with beta emin. -rewrite F2R_0, F2R_Zabs. -now apply Rabs_pos_lt. -Qed. - -Theorem relative_error_F2R_emin_ex : - forall m, let x := F2R (Float beta m emin) in - exists eps, - (Rabs eps < bpow (-p + 1))%R /\ round beta fexp rnd x = (x * (1 + eps))%R. -Proof with auto with typeclass_instances. -intros m x. -apply relative_error_lt_conversion... -apply bpow_gt_0. -now apply relative_error_F2R_emin. -Qed. - -Theorem relative_error_round : - (0 < p)%Z -> - forall x, - (bpow emin <= Rabs x)%R -> - (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs (round beta fexp rnd x))%R. -Proof with auto with typeclass_instances. -intros Hp x Hx. -assert (Hx': (x <> 0)%R). -intros T; contradict Hx; rewrite T, Rabs_R0. -apply Rlt_not_le, bpow_gt_0. -apply Rlt_le_trans with (ulp beta fexp x)%R. -now apply error_lt_ulp. -rewrite ulp_neq_0; trivial. -unfold canonic_exp. -destruct (ln_beta beta x) as (ex, He). -simpl. -specialize (He Hx'). -assert (He': (emin < ex)%Z). -apply (lt_bpow beta). -apply Rle_lt_trans with (2 := proj2 He). -exact Hx. -apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R. -rewrite <- bpow_plus. -apply bpow_le. -generalize (Hmin ex). -omega. -apply Rmult_le_compat_l. -apply bpow_ge_0. -generalize He. -apply round_abs_abs... -clear rnd valid_rnd x Hx Hx' He. -intros rnd valid_rnd x _ Hx. -rewrite <- (round_generic beta fexp rnd (bpow (ex - 1))). -now apply round_le. -apply generic_format_bpow. -ring_simplify (ex - 1 + 1)%Z. -generalize (Hmin ex). -omega. -Qed. - -Theorem relative_error_round_F2R_emin : - (0 < p)%Z -> - forall m, let x := F2R (Float beta m emin) in - (x <> 0)%R -> - (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs (round beta fexp rnd x))%R. -Proof. -intros Hp m x Hx. -apply relative_error_round. -exact Hp. -unfold x. -rewrite <- F2R_Zabs. -apply bpow_le_F2R. -apply F2R_lt_reg with beta emin. -rewrite F2R_0, F2R_Zabs. -now apply Rabs_pos_lt. -Qed. - -Variable choice : Z -> bool. - -Theorem relative_error_N : - forall x, - (bpow emin <= Rabs x)%R -> - (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs x)%R. -Proof. -intros x Hx. -apply Rle_trans with (/2 * ulp beta fexp x)%R. -now apply error_le_half_ulp. -rewrite Rmult_assoc. -apply Rmult_le_compat_l. -apply Rlt_le. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). -assert (Hx': (x <> 0)%R). -intros H. -apply Rlt_not_le with (2 := Hx). -rewrite H, Rabs_R0. -apply bpow_gt_0. -rewrite ulp_neq_0; trivial. -unfold canonic_exp. -destruct (ln_beta beta x) as (ex, He). -simpl. -specialize (He Hx'). -apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R. -rewrite <- bpow_plus. -apply bpow_le. -assert (emin < ex)%Z. -apply (lt_bpow beta). -apply Rle_lt_trans with (2 := proj2 He). -exact Hx. -generalize (Hmin ex). -omega. -apply Rmult_le_compat_l. -apply bpow_ge_0. -apply He. -Qed. - -(** 1+#ε# property in rounding to nearest *) -Theorem relative_error_N_ex : - forall x, - (bpow emin <= Rabs x)%R -> - exists eps, - (Rabs eps <= /2 * bpow (-p + 1))%R /\ round beta fexp (Znearest choice) x = (x * (1 + eps))%R. -Proof with auto with typeclass_instances. -intros x Hx. -apply relative_error_le_conversion... -apply Rlt_le. -apply Rmult_lt_0_compat. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). -apply bpow_gt_0. -now apply relative_error_N. -Qed. - -Theorem relative_error_N_F2R_emin : - forall m, let x := F2R (Float beta m emin) in - (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs x)%R. -Proof with auto with typeclass_instances. -intros m x. -destruct (Req_dec x 0) as [Hx|Hx]. -(* . *) -rewrite Hx, round_0... -unfold Rminus. -rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0. -rewrite Rmult_0_r. -apply Rle_refl. -(* . *) -apply relative_error_N. -unfold x. -rewrite <- F2R_Zabs. -apply bpow_le_F2R. -apply F2R_lt_reg with beta emin. -rewrite F2R_0, F2R_Zabs. -now apply Rabs_pos_lt. -Qed. - -Theorem relative_error_N_F2R_emin_ex : - forall m, let x := F2R (Float beta m emin) in - exists eps, - (Rabs eps <= /2 * bpow (-p + 1))%R /\ round beta fexp (Znearest choice) x = (x * (1 + eps))%R. -Proof with auto with typeclass_instances. -intros m x. -apply relative_error_le_conversion... -apply Rlt_le. -apply Rmult_lt_0_compat. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). -apply bpow_gt_0. -now apply relative_error_N_F2R_emin. -Qed. - -Theorem relative_error_N_round : - (0 < p)%Z -> - forall x, - (bpow emin <= Rabs x)%R -> - (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs (round beta fexp (Znearest choice) x))%R. -Proof with auto with typeclass_instances. -intros Hp x Hx. -apply Rle_trans with (/2 * ulp beta fexp x)%R. -now apply error_le_half_ulp. -rewrite Rmult_assoc. -apply Rmult_le_compat_l. -apply Rlt_le. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). -assert (Hx': (x <> 0)%R). -intros H. -apply Rlt_not_le with (2 := Hx). -rewrite H, Rabs_R0. -apply bpow_gt_0. -rewrite ulp_neq_0; trivial. -unfold canonic_exp. -destruct (ln_beta beta x) as (ex, He). -simpl. -specialize (He Hx'). -assert (He': (emin < ex)%Z). -apply (lt_bpow beta). -apply Rle_lt_trans with (2 := proj2 He). -exact Hx. -apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R. -rewrite <- bpow_plus. -apply bpow_le. -generalize (Hmin ex). -omega. -apply Rmult_le_compat_l. -apply bpow_ge_0. -generalize He. -apply round_abs_abs... -clear rnd valid_rnd x Hx Hx' He. -intros rnd valid_rnd x _ Hx. -rewrite <- (round_generic beta fexp rnd (bpow (ex - 1))). -now apply round_le. -apply generic_format_bpow. -ring_simplify (ex - 1 + 1)%Z. -generalize (Hmin ex). -omega. -Qed. - -Theorem relative_error_N_round_F2R_emin : - (0 < p)%Z -> - forall m, let x := F2R (Float beta m emin) in - (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs (round beta fexp (Znearest choice) x))%R. -Proof with auto with typeclass_instances. -intros Hp m x. -destruct (Req_dec x 0) as [Hx|Hx]. -(* . *) -rewrite Hx, round_0... -unfold Rminus. -rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0. -rewrite Rmult_0_r. -apply Rle_refl. -(* . *) -apply relative_error_N_round with (1 := Hp). -unfold x. -rewrite <- F2R_Zabs. -apply bpow_le_F2R. -apply F2R_lt_reg with beta emin. -rewrite F2R_0, F2R_Zabs. -now apply Rabs_pos_lt. -Qed. - -End Fprop_relative_generic. - -Section Fprop_relative_FLT. - -Variable emin prec : Z. -Variable Hp : Zlt 0 prec. - -Lemma relative_error_FLT_aux : - forall k, (emin + prec - 1 < k)%Z -> (prec <= k - FLT_exp emin prec k)%Z. -Proof. -intros k Hk. -unfold FLT_exp. -generalize (Zmax_spec (k - prec) emin). -omega. -Qed. - -Variable rnd : R -> Z. -Context { valid_rnd : Valid_rnd rnd }. - -Theorem relative_error_FLT : - forall x, - (bpow (emin + prec - 1) <= Rabs x)%R -> - (Rabs (round beta (FLT_exp emin prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R. -Proof with auto with typeclass_instances. -intros x Hx. -apply relative_error with (emin + prec - 1)%Z... -apply relative_error_FLT_aux. -Qed. - -Theorem relative_error_FLT_F2R_emin : - forall m, let x := F2R (Float beta m emin) in - (x <> 0)%R -> - (Rabs (round beta (FLT_exp emin prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R. -Proof with auto with typeclass_instances. -intros m x Zx. -destruct (Rlt_or_le (Rabs x) (bpow (emin + prec - 1))) as [Hx|Hx]. -rewrite round_generic... -unfold Rminus. -rewrite Rplus_opp_r, Rabs_R0. -apply Rmult_lt_0_compat. -apply bpow_gt_0. -now apply Rabs_pos_lt. -apply generic_format_FLT_FIX... -apply Rlt_le. -apply Rlt_le_trans with (1 := Hx). -apply bpow_le. -apply Zle_pred. -apply generic_format_FIX. -now exists (Float beta m emin). -now apply relative_error_FLT. -Qed. - -Theorem relative_error_FLT_F2R_emin_ex : - forall m, let x := F2R (Float beta m emin) in - exists eps, - (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) rnd x = (x * (1 + eps))%R. -Proof with auto with typeclass_instances. -intros m x. -apply relative_error_lt_conversion... -apply bpow_gt_0. -now apply relative_error_FLT_F2R_emin. -Qed. - -(** 1+#ε# property in any rounding in FLT *) -Theorem relative_error_FLT_ex : - forall x, - (bpow (emin + prec - 1) <= Rabs x)%R -> - exists eps, - (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) rnd x = (x * (1 + eps))%R. -Proof with auto with typeclass_instances. -intros x Hx. -apply relative_error_lt_conversion... -apply bpow_gt_0. -intros _; now apply relative_error_FLT. -Qed. - -Variable choice : Z -> bool. - -Theorem relative_error_N_FLT : - forall x, - (bpow (emin + prec - 1) <= Rabs x)%R -> - (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R. -Proof with auto with typeclass_instances. -intros x Hx. -apply relative_error_N with (emin + prec - 1)%Z... -apply relative_error_FLT_aux. -Qed. - -(** 1+#ε# property in rounding to nearest in FLT *) -Theorem relative_error_N_FLT_ex : - forall x, - (bpow (emin + prec - 1) <= Rabs x)%R -> - exists eps, - (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps))%R. -Proof with auto with typeclass_instances. -intros x Hx. -apply relative_error_le_conversion... -apply Rlt_le. -apply Rmult_lt_0_compat. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). -apply bpow_gt_0. -now apply relative_error_N_FLT. -Qed. - -Theorem relative_error_N_FLT_round : - forall x, - (bpow (emin + prec - 1) <= Rabs x)%R -> - (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLT_exp emin prec) (Znearest choice) x))%R. -Proof with auto with typeclass_instances. -intros x Hx. -apply relative_error_N_round with (emin + prec - 1)%Z... -apply relative_error_FLT_aux. -Qed. - -Theorem relative_error_N_FLT_F2R_emin : - forall m, let x := F2R (Float beta m emin) in - (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R. -Proof with auto with typeclass_instances. -intros m x. -destruct (Rlt_or_le (Rabs x) (bpow (emin + prec - 1))) as [Hx|Hx]. -rewrite round_generic... -unfold Rminus. -rewrite Rplus_opp_r, Rabs_R0. -apply Rmult_le_pos. -apply Rmult_le_pos. -apply Rlt_le. -apply (RinvN_pos 1). -apply bpow_ge_0. -apply Rabs_pos. -apply generic_format_FLT_FIX... -apply Rlt_le. -apply Rlt_le_trans with (1 := Hx). -apply bpow_le. -apply Zle_pred. -apply generic_format_FIX. -now exists (Float beta m emin). -now apply relative_error_N_FLT. -Qed. - -Theorem relative_error_N_FLT_F2R_emin_ex : - forall m, let x := F2R (Float beta m emin) in - exists eps, - (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps))%R. -Proof with auto with typeclass_instances. -intros m x. -apply relative_error_le_conversion... -apply Rmult_le_pos. -apply Rlt_le. -apply (RinvN_pos 1). -apply bpow_ge_0. -now apply relative_error_N_FLT_F2R_emin. -Qed. - - -Theorem relative_error_N_FLT_round_F2R_emin : - forall m, let x := F2R (Float beta m emin) in - (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLT_exp emin prec) (Znearest choice) x))%R. -Proof with auto with typeclass_instances. -intros m x. -destruct (Rlt_or_le (Rabs x) (bpow (emin + prec - 1))) as [Hx|Hx]. -rewrite round_generic... -unfold Rminus. -rewrite Rplus_opp_r, Rabs_R0. -apply Rmult_le_pos. -apply Rmult_le_pos. -apply Rlt_le. -apply (RinvN_pos 1). -apply bpow_ge_0. -apply Rabs_pos. -apply generic_format_FLT_FIX... -apply Rlt_le. -apply Rlt_le_trans with (1 := Hx). -apply bpow_le. -apply Zle_pred. -apply generic_format_FIX. -now exists (Float beta m emin). -apply relative_error_N_round with (emin := (emin + prec - 1)%Z)... -apply relative_error_FLT_aux. -Qed. - -Lemma error_N_FLT_aux : - forall x, - (0 < x)%R -> - exists eps, exists eta, - (Rabs eps <= /2 * bpow (-prec + 1))%R /\ - (Rabs eta <= /2 * bpow (emin))%R /\ - (eps*eta=0)%R /\ - round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps) + eta)%R. -Proof. -intros x Hx2. -case (Rle_or_lt (bpow (emin+prec)) x); intros Hx. -(* *) -destruct relative_error_N_ex with (FLT_exp emin prec) (emin+prec)%Z prec choice x - as (eps,(Heps1,Heps2)). -now apply FLT_exp_valid. -intros; unfold FLT_exp. -rewrite Zmax_left; omega. -rewrite Rabs_right;[assumption|apply Rle_ge; now left]. -exists eps; exists 0%R. -split;[assumption|split]. -rewrite Rabs_R0; apply Rmult_le_pos. -apply Rlt_le, pos_half_prf. -apply bpow_ge_0. -split;[apply Rmult_0_r|idtac]. -now rewrite Rplus_0_r. -(* *) -exists 0%R; exists (round beta (FLT_exp emin prec) (Znearest choice) x - x)%R. -split. -rewrite Rabs_R0; apply Rmult_le_pos. -apply Rlt_le, pos_half_prf. -apply bpow_ge_0. -split. -apply Rle_trans with (/2*ulp beta (FLT_exp emin prec) x)%R. -apply error_le_half_ulp. -now apply FLT_exp_valid. -apply Rmult_le_compat_l. -apply Rlt_le, pos_half_prf. -rewrite ulp_neq_0. -2: now apply Rgt_not_eq. -apply bpow_le. -unfold FLT_exp, canonic_exp. -rewrite Zmax_right. -omega. -destruct (ln_beta beta x) as (e,He); simpl. -assert (e-1 < emin+prec)%Z. -apply (lt_bpow beta). -apply Rle_lt_trans with (2:=Hx). -rewrite <- (Rabs_right x). -apply He; auto with real. -apply Rle_ge; now left. -omega. -split;ring. -Qed. - -End Fprop_relative_FLT. - -Lemma error_N_FLT : - forall (emin prec : Z), (0 < prec)%Z -> - forall (choice : Z -> bool), - forall (x : R), - exists eps eta : R, - (Rabs eps <= /2 * bpow (-prec + 1))%R /\ - (Rabs eta <= /2 * bpow emin)%R /\ - (eps * eta = 0)%R /\ - (round beta (FLT_exp emin prec) (Znearest choice) x - = x * (1 + eps) + eta)%R. -Proof. -intros emin prec Pprec choice x. -destruct (Rtotal_order x 0) as [Nx|[Zx|Px]]. -{ assert (Pmx : (0 < - x)%R). - { now rewrite <- Ropp_0; apply Ropp_lt_contravar. } - destruct (error_N_FLT_aux emin prec Pprec - (fun t : Z => negb (choice (- (t + 1))%Z)) - (- x)%R Pmx) - as (d,(e,(Hd,(He,(Hde,Hr))))). - exists d; exists (- e)%R; split; [exact Hd|split; [|split]]. - { now rewrite Rabs_Ropp. } - { now rewrite Ropp_mult_distr_r_reverse, <- Ropp_0; apply f_equal. } - rewrite <- (Ropp_involutive x), round_N_opp. - now rewrite Ropp_mult_distr_l_reverse, <- Ropp_plus_distr; apply f_equal. } -{ assert (Ph2 : (0 <= / 2)%R). - { apply (Rmult_le_reg_l 2 _ _ Rlt_0_2). - rewrite Rmult_0_r, Rinv_r; [exact Rle_0_1|]. - apply Rgt_not_eq, Rlt_gt, Rlt_0_2. } - exists 0%R; exists 0%R; rewrite Zx; split; [|split; [|split]]. - { now rewrite Rabs_R0; apply Rmult_le_pos; [|apply bpow_ge_0]. } - { now rewrite Rabs_R0; apply Rmult_le_pos; [|apply bpow_ge_0]. } - { now rewrite Rmult_0_l. } - now rewrite Rmult_0_l, Rplus_0_l, round_0; [|apply valid_rnd_N]. } -now apply error_N_FLT_aux. -Qed. - -Section Fprop_relative_FLX. - -Variable prec : Z. -Variable Hp : Zlt 0 prec. - -Lemma relative_error_FLX_aux : - forall k, (prec <= k - FLX_exp prec k)%Z. -Proof. -intros k. -unfold FLX_exp. -omega. -Qed. - -Variable rnd : R -> Z. -Context { valid_rnd : Valid_rnd rnd }. - -Theorem relative_error_FLX : - forall x, - (x <> 0)%R -> - (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R. -Proof with auto with typeclass_instances. -intros x Hx. -destruct (ln_beta beta x) as (ex, He). -specialize (He Hx). -apply relative_error with (ex - 1)%Z... -intros k _. -apply relative_error_FLX_aux. -apply He. -Qed. - -(** 1+#ε# property in any rounding in FLX *) -Theorem relative_error_FLX_ex : - forall x, - exists eps, - (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLX_exp prec) rnd x = (x * (1 + eps))%R. -Proof with auto with typeclass_instances. -intros x. -apply relative_error_lt_conversion... -apply bpow_gt_0. -now apply relative_error_FLX. -Qed. - -Theorem relative_error_FLX_round : - forall x, - (x <> 0)%R -> - (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs (round beta (FLX_exp prec) rnd x))%R. -Proof with auto with typeclass_instances. -intros x Hx. -destruct (ln_beta beta x) as (ex, He). -specialize (He Hx). -apply relative_error_round with (ex - 1)%Z... -intros k _. -apply relative_error_FLX_aux. -apply He. -Qed. - -Variable choice : Z -> bool. - -Theorem relative_error_N_FLX : - forall x, - (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R. -Proof with auto with typeclass_instances. -intros x. -destruct (Req_dec x 0) as [Hx|Hx]. -(* . *) -rewrite Hx, round_0... -unfold Rminus. -rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0. -rewrite Rmult_0_r. -apply Rle_refl. -(* . *) -destruct (ln_beta beta x) as (ex, He). -specialize (He Hx). -apply relative_error_N with (ex - 1)%Z... -intros k _. -apply relative_error_FLX_aux. -apply He. -Qed. - -(** 1+#ε# property in rounding to nearest in FLX *) -Theorem relative_error_N_FLX_ex : - forall x, - exists eps, - (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLX_exp prec) (Znearest choice) x = (x * (1 + eps))%R. -Proof with auto with typeclass_instances. -intros x. -apply relative_error_le_conversion... -apply Rlt_le. -apply Rmult_lt_0_compat. -apply Rinv_0_lt_compat. -now apply (Z2R_lt 0 2). -apply bpow_gt_0. -now apply relative_error_N_FLX. -Qed. - -Theorem relative_error_N_FLX_round : - forall x, - (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLX_exp prec) (Znearest choice) x))%R. -Proof with auto with typeclass_instances. -intros x. -destruct (Req_dec x 0) as [Hx|Hx]. -(* . *) -rewrite Hx, round_0... -unfold Rminus. -rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0. -rewrite Rmult_0_r. -apply Rle_refl. -(* . *) -destruct (ln_beta beta x) as (ex, He). -specialize (He Hx). -apply relative_error_N_round with (ex - 1)%Z. -now apply FLX_exp_valid. -intros k _. -apply relative_error_FLX_aux. -exact Hp. -apply He. -Qed. - -End Fprop_relative_FLX. - -End Fprop_relative. \ No newline at end of file diff --git a/flocq/Prop/Mult_error.v b/flocq/Prop/Mult_error.v new file mode 100644 index 00000000..57a3856f --- /dev/null +++ b/flocq/Prop/Mult_error.v @@ -0,0 +1,335 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2010-2018 Sylvie Boldo +#
# +Copyright (C) 2010-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +(** * Error of the multiplication is in the FLX/FLT format *) +Require Import Core Operations Plus_error. + +Section Fprop_mult_error. + +Variable beta : radix. +Notation bpow e := (bpow beta e). + +Variable prec : Z. +Context { prec_gt_0_ : Prec_gt_0 prec }. + +Notation format := (generic_format beta (FLX_exp prec)). +Notation cexp := (cexp beta (FLX_exp prec)). + +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. + +(** Auxiliary result that provides the exponent *) +Lemma mult_error_FLX_aux: + forall x y, + format x -> format y -> + (round beta (FLX_exp prec) rnd (x * y) - (x * y) <> 0)%R -> + exists f:float beta, + (F2R f = round beta (FLX_exp prec) rnd (x * y) - (x * y))%R + /\ (cexp (F2R f) <= Fexp f)%Z + /\ (Fexp f = cexp x + cexp y)%Z. +Proof with auto with typeclass_instances. +intros x y Hx Hy Hz. +set (f := (round beta (FLX_exp prec) rnd (x * y))). +destruct (Req_dec (x * y) 0) as [Hxy0|Hxy0]. +contradict Hz. +rewrite Hxy0. +rewrite round_0... +ring. +destruct (mag beta (x * y)) as (exy, Hexy). +specialize (Hexy Hxy0). +destruct (mag beta (f - x * y)) as (er, Her). +specialize (Her Hz). +destruct (mag beta x) as (ex, Hex). +assert (Hx0: (x <> 0)%R). +contradict Hxy0. +now rewrite Hxy0, Rmult_0_l. +specialize (Hex Hx0). +destruct (mag beta y) as (ey, Hey). +assert (Hy0: (y <> 0)%R). +contradict Hxy0. +now rewrite Hxy0, Rmult_0_r. +specialize (Hey Hy0). +(* *) +assert (Hc1: (cexp (x * y)%R - prec <= cexp x + cexp y)%Z). +unfold cexp, FLX_exp. +rewrite mag_unique with (1 := Hex). +rewrite mag_unique with (1 := Hey). +rewrite mag_unique with (1 := Hexy). +cut (exy - 1 < ex + ey)%Z. omega. +apply (lt_bpow beta). +apply Rle_lt_trans with (1 := proj1 Hexy). +rewrite Rabs_mult. +rewrite bpow_plus. +apply Rmult_le_0_lt_compat. +apply Rabs_pos. +apply Rabs_pos. +apply Hex. +apply Hey. +(* *) +assert (Hc2: (cexp x + cexp y <= cexp (x * y)%R)%Z). +unfold cexp, FLX_exp. +rewrite mag_unique with (1 := Hex). +rewrite mag_unique with (1 := Hey). +rewrite mag_unique with (1 := Hexy). +cut ((ex - 1) + (ey - 1) < exy)%Z. +generalize (prec_gt_0 prec). +clear ; omega. +apply (lt_bpow beta). +apply Rle_lt_trans with (2 := proj2 Hexy). +rewrite Rabs_mult. +rewrite bpow_plus. +apply Rmult_le_compat. +apply bpow_ge_0. +apply bpow_ge_0. +apply Hex. +apply Hey. +(* *) +assert (Hr: ((F2R (Float beta (- (Ztrunc (scaled_mantissa beta (FLX_exp prec) x) * + Ztrunc (scaled_mantissa beta (FLX_exp prec) y)) + rnd (scaled_mantissa beta (FLX_exp prec) (x * y)) * + beta ^ (cexp (x * y)%R - (cexp x + cexp y))) (cexp x + cexp y))) = f - x * y)%R). +rewrite Hx at 6. +rewrite Hy at 6. +rewrite <- F2R_mult. +simpl. +unfold f, round, Rminus. +rewrite <- F2R_opp, Rplus_comm, <- F2R_plus. +unfold Fplus. simpl. +now rewrite Zle_imp_le_bool with (1 := Hc2). +(* *) +exists (Float beta (- (Ztrunc (scaled_mantissa beta (FLX_exp prec) x) * + Ztrunc (scaled_mantissa beta (FLX_exp prec) y)) + rnd (scaled_mantissa beta (FLX_exp prec) (x * y)) * + beta ^ (cexp (x * y)%R - (cexp x + cexp y))) (cexp x + cexp y)). +split;[assumption|split]. +rewrite Hr. +simpl. +clear Hr. +apply Z.le_trans with (cexp (x * y)%R - prec)%Z. +unfold cexp, FLX_exp. +apply Zplus_le_compat_r. +rewrite mag_unique with (1 := Hexy). +apply mag_le_bpow with (1 := Hz). +replace (bpow (exy - prec)) with (ulp beta (FLX_exp prec) (x * y)). +apply error_lt_ulp... +rewrite ulp_neq_0; trivial. +unfold cexp. +now rewrite mag_unique with (1 := Hexy). +apply Hc1. +reflexivity. +Qed. + +(** Error of the multiplication in FLX *) +Theorem mult_error_FLX : + forall x y, + format x -> format y -> + format (round beta (FLX_exp prec) rnd (x * y) - (x * y))%R. +Proof. +intros x y Hx Hy. +destruct (Req_dec (round beta (FLX_exp prec) rnd (x * y) - x * y) 0) as [Hr0|Hr0]. +rewrite Hr0. +apply generic_format_0. +destruct (mult_error_FLX_aux x y Hx Hy Hr0) as ((m,e),(H1,(H2,H3))). +rewrite <- H1. +now apply generic_format_F2R. +Qed. + +Lemma mult_bpow_exact_FLX : + forall x e, + format x -> + format (x * bpow e)%R. +Proof. +intros x e Fx. +destruct (Req_dec x 0) as [Zx|Nzx]. +{ rewrite Zx, Rmult_0_l; apply generic_format_0. } +rewrite Fx. +set (mx := Ztrunc _); set (ex := cexp _). +pose (f := {| Fnum := mx; Fexp := ex + e |} : float beta). +apply (generic_format_F2R' _ _ _ f). +{ now unfold F2R; simpl; rewrite bpow_plus, Rmult_assoc. } +intro Nzmx; unfold mx, ex; rewrite <- Fx. +unfold f, ex; simpl; unfold cexp; rewrite (mag_mult_bpow _ _ _ Nzx). +unfold FLX_exp; omega. +Qed. + +End Fprop_mult_error. + +Section Fprop_mult_error_FLT. + +Variable beta : radix. +Notation bpow e := (bpow beta e). + +Variable emin prec : Z. +Context { prec_gt_0_ : Prec_gt_0 prec }. + +Notation format := (generic_format beta (FLT_exp emin prec)). +Notation cexp := (cexp beta (FLT_exp emin prec)). + +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. + +(** Error of the multiplication in FLT with underflow requirements *) +Theorem mult_error_FLT : + forall x y, + format x -> format y -> + (x * y <> 0 -> bpow (emin + 2*prec - 1) <= Rabs (x * y))%R -> + format (round beta (FLT_exp emin prec) rnd (x * y) - (x * y))%R. +Proof with auto with typeclass_instances. +intros x y Hx Hy Hxy. +set (f := (round beta (FLT_exp emin prec) rnd (x * y))). +destruct (Req_dec (f - x * y) 0) as [Hr0|Hr0]. +rewrite Hr0. +apply generic_format_0. +destruct (Req_dec (x * y) 0) as [Hxy'|Hxy']. +unfold f. +rewrite Hxy'. +rewrite round_0... +ring_simplify (0 - 0)%R. +apply generic_format_0. +specialize (Hxy Hxy'). +destruct (mult_error_FLX_aux beta prec rnd x y) as ((m,e),(H1,(H2,H3))). +now apply generic_format_FLX_FLT with emin. +now apply generic_format_FLX_FLT with emin. +rewrite <- (round_FLT_FLX beta emin). +assumption. +apply Rle_trans with (2:=Hxy). +apply bpow_le. +generalize (prec_gt_0 prec). +clear ; omega. +rewrite <- (round_FLT_FLX beta emin) in H1. +2:apply Rle_trans with (2:=Hxy). +2:apply bpow_le ; generalize (prec_gt_0 prec) ; clear ; omega. +unfold f; rewrite <- H1. +apply generic_format_F2R. +intros _. +simpl in H2, H3. +unfold cexp, FLT_exp. +case (Zmax_spec (mag beta (F2R (Float beta m e)) - prec) emin); + intros (M1,M2); rewrite M2. +apply Z.le_trans with (2:=H2). +unfold cexp, FLX_exp. +apply Z.le_refl. +rewrite H3. +unfold cexp, FLX_exp. +assert (Hxy0:(x*y <> 0)%R). +contradict Hr0. +unfold f. +rewrite Hr0. +rewrite round_0... +ring. +assert (Hx0: (x <> 0)%R). +contradict Hxy0. +now rewrite Hxy0, Rmult_0_l. +assert (Hy0: (y <> 0)%R). +contradict Hxy0. +now rewrite Hxy0, Rmult_0_r. +destruct (mag beta x) as (ex,Ex) ; simpl. +specialize (Ex Hx0). +destruct (mag beta y) as (ey,Ey) ; simpl. +specialize (Ey Hy0). +assert (emin + 2 * prec -1 < ex + ey)%Z. +2: omega. +apply (lt_bpow beta). +apply Rle_lt_trans with (1:=Hxy). +rewrite Rabs_mult, bpow_plus. +apply Rmult_le_0_lt_compat; try apply Rabs_pos. +apply Ex. +apply Ey. +Qed. + +Lemma F2R_ge: forall (y:float beta), + (F2R y <> 0)%R -> (bpow (Fexp y) <= Rabs (F2R y))%R. +Proof. +intros (ny,ey). +rewrite <- F2R_Zabs; unfold F2R; simpl. +case (Zle_lt_or_eq 0 (Z.abs ny)). +apply Z.abs_nonneg. +intros Hy _. +rewrite <- (Rmult_1_l (bpow _)) at 1. +apply Rmult_le_compat_r. +apply bpow_ge_0. +apply IZR_le; omega. +intros H1 H2; contradict H2. +replace ny with 0%Z. +simpl; ring. +now apply sym_eq, Z.abs_0_iff, sym_eq. +Qed. + +Theorem mult_error_FLT_ge_bpow : + forall x y e, + format x -> format y -> + (bpow (e+2*prec-1) <= Rabs (x * y))%R -> + (round beta (FLT_exp emin prec) rnd (x * y) - (x * y) <> 0)%R -> + (bpow e <= Rabs (round beta (FLT_exp emin prec) rnd (x * y) - (x * y)))%R. +Proof with auto with typeclass_instances. +intros x y e. +set (f := (round beta (FLT_exp emin prec) rnd (x * y))). +intros Fx Fy H1. +unfold f; rewrite Fx, Fy, <- F2R_mult. +simpl Fmult. +destruct (round_repr_same_exp beta (FLT_exp emin prec) + rnd (Ztrunc (scaled_mantissa beta (FLT_exp emin prec) x) * + Ztrunc (scaled_mantissa beta (FLT_exp emin prec) y)) + (cexp x + cexp y)) as (n,Hn). +rewrite Hn; clear Hn. +rewrite <- F2R_minus, Fminus_same_exp. +intros K. +eapply Rle_trans with (2:=F2R_ge _ K). +simpl (Fexp _). +apply bpow_le. +unfold cexp, FLT_exp. +destruct (mag beta x) as (ex,Hx). +destruct (mag beta y) as (ey,Hy). +simpl; apply Z.le_trans with ((ex-prec)+(ey-prec))%Z. +2: apply Zplus_le_compat; apply Z.le_max_l. +assert (e + 2*prec -1< ex+ey)%Z;[idtac|omega]. +apply lt_bpow with beta. +apply Rle_lt_trans with (1:=H1). +rewrite Rabs_mult, bpow_plus. +apply Rmult_lt_compat. +apply Rabs_pos. +apply Rabs_pos. +apply Hx. +intros K'; contradict H1; apply Rlt_not_le. +rewrite K', Rmult_0_l, Rabs_R0; apply bpow_gt_0. +apply Hy. +intros K'; contradict H1; apply Rlt_not_le. +rewrite K', Rmult_0_r, Rabs_R0; apply bpow_gt_0. +Qed. + +Lemma mult_bpow_exact_FLT : + forall x e, + format x -> + (emin + prec - mag beta x <= e)%Z -> + format (x * bpow e)%R. +Proof. +intros x e Fx He. +destruct (Req_dec x 0) as [Zx|Nzx]. +{ rewrite Zx, Rmult_0_l; apply generic_format_0. } +rewrite Fx. +set (mx := Ztrunc _); set (ex := cexp _). +pose (f := {| Fnum := mx; Fexp := ex + e |} : float beta). +apply (generic_format_F2R' _ _ _ f). +{ now unfold F2R; simpl; rewrite bpow_plus, Rmult_assoc. } +intro Nzmx; unfold mx, ex; rewrite <- Fx. +unfold f, ex; simpl; unfold cexp; rewrite (mag_mult_bpow _ _ _ Nzx). +unfold FLT_exp; rewrite Z.max_l; [|omega]; rewrite <- Z.add_max_distr_r. +set (n := (_ - _ + _)%Z); apply (Z.le_trans _ n); [unfold n; omega|]. +apply Z.le_max_l. +Qed. + +End Fprop_mult_error_FLT. diff --git a/flocq/Prop/Plus_error.v b/flocq/Prop/Plus_error.v new file mode 100644 index 00000000..42f80093 --- /dev/null +++ b/flocq/Prop/Plus_error.v @@ -0,0 +1,606 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2010-2018 Sylvie Boldo +#
# +Copyright (C) 2010-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +(** * Error of the rounded-to-nearest addition is representable. *) + +Require Import Psatz. +Require Import Raux Defs Float_prop Generic_fmt. +Require Import FIX FLX FLT Ulp Operations. +Require Import Relative. + + +Section Fprop_plus_error. + +Variable beta : radix. +Notation bpow e := (bpow beta e). + +Variable fexp : Z -> Z. +Context { valid_exp : Valid_exp fexp }. + +Section round_repr_same_exp. + +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. + +Lemma round_repr_same_exp : + forall m e, + exists m', + round beta fexp rnd (F2R (Float beta m e)) = F2R (Float beta m' e). +Proof with auto with typeclass_instances. +intros m e. +set (e' := cexp beta fexp (F2R (Float beta m e))). +unfold round, scaled_mantissa. fold e'. +destruct (Zle_or_lt e' e) as [He|He]. +exists m. +unfold F2R at 2. simpl. +rewrite Rmult_assoc, <- bpow_plus. +rewrite <- IZR_Zpower. 2: omega. +rewrite <- mult_IZR, Zrnd_IZR... +unfold F2R. simpl. +rewrite mult_IZR. +rewrite Rmult_assoc. +rewrite IZR_Zpower. 2: omega. +rewrite <- bpow_plus. +apply (f_equal (fun v => IZR m * bpow v)%R). +ring. +exists ((rnd (IZR m * bpow (e - e'))) * Zpower beta (e' - e))%Z. +unfold F2R. simpl. +rewrite mult_IZR. +rewrite IZR_Zpower. 2: omega. +rewrite 2!Rmult_assoc. +rewrite <- 2!bpow_plus. +apply (f_equal (fun v => _ * bpow v)%R). +ring. +Qed. + +End round_repr_same_exp. + +Context { monotone_exp : Monotone_exp fexp }. +Notation format := (generic_format beta fexp). + +Variable choice : Z -> bool. + +Lemma plus_error_aux : + forall x y, + (cexp beta fexp x <= cexp beta fexp y)%Z -> + format x -> format y -> + format (round beta fexp (Znearest choice) (x + y) - (x + y))%R. +Proof. +intros x y. +set (ex := cexp beta fexp x). +set (ey := cexp beta fexp y). +intros He Hx Hy. +destruct (Req_dec (round beta fexp (Znearest choice) (x + y) - (x + y)) R0) as [H0|H0]. +rewrite H0. +apply generic_format_0. +set (mx := Ztrunc (scaled_mantissa beta fexp x)). +set (my := Ztrunc (scaled_mantissa beta fexp y)). +(* *) +assert (Hxy: (x + y)%R = F2R (Float beta (mx + my * beta ^ (ey - ex)) ex)). +rewrite Hx, Hy. +fold mx my ex ey. +rewrite <- F2R_plus. +unfold Fplus. simpl. +now rewrite Zle_imp_le_bool with (1 := He). +(* *) +rewrite Hxy. +destruct (round_repr_same_exp (Znearest choice) (mx + my * beta ^ (ey - ex)) ex) as (mxy, Hxy'). +rewrite Hxy'. +assert (H: (F2R (Float beta mxy ex) - F2R (Float beta (mx + my * beta ^ (ey - ex)) ex))%R = + F2R (Float beta (mxy - (mx + my * beta ^ (ey - ex))) ex)). +now rewrite <- F2R_minus, Fminus_same_exp. +rewrite H. +apply generic_format_F2R. +intros _. +apply monotone_exp. +rewrite <- H, <- Hxy', <- Hxy. +apply mag_le_abs. +exact H0. +pattern x at 3 ; replace x with (-(y - (x + y)))%R by ring. +rewrite Rabs_Ropp. +now apply (round_N_pt beta _ choice (x + y)). +Qed. + +(** Error of the addition *) +Theorem plus_error : + forall x y, + format x -> format y -> + format (round beta fexp (Znearest choice) (x + y) - (x + y))%R. +Proof. +intros x y Hx Hy. +destruct (Zle_or_lt (cexp beta fexp x) (cexp beta fexp y)). +now apply plus_error_aux. +rewrite Rplus_comm. +apply plus_error_aux ; try easy. +now apply Zlt_le_weak. +Qed. + +End Fprop_plus_error. + +Section Fprop_plus_zero. + +Variable beta : radix. +Notation bpow e := (bpow beta e). + +Variable fexp : Z -> Z. +Context { valid_exp : Valid_exp fexp }. +Context { exp_not_FTZ : Exp_not_FTZ fexp }. +Notation format := (generic_format beta fexp). + +Section round_plus_eq_zero_aux. + +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. + +Lemma round_plus_neq_0_aux : + forall x y, + (cexp beta fexp x <= cexp beta fexp y)%Z -> + format x -> format y -> + (0 < x + y)%R -> + round beta fexp rnd (x + y) <> 0%R. +Proof with auto with typeclass_instances. +intros x y He Hx Hy Hxy. +destruct (mag beta (x + y)) as (exy, Hexy). +simpl. +specialize (Hexy (Rgt_not_eq _ _ Hxy)). +destruct (Zle_or_lt exy (fexp exy)) as [He'|He']. +(* . *) +assert (H: (x + y)%R = F2R (Float beta (Ztrunc (x * bpow (- fexp exy)) + + Ztrunc (y * bpow (- fexp exy))) (fexp exy))). +rewrite (subnormal_exponent beta fexp exy x He' Hx) at 1. +rewrite (subnormal_exponent beta fexp exy y He' Hy) at 1. +now rewrite <- F2R_plus, Fplus_same_exp. +rewrite H. +rewrite round_generic... +rewrite <- H. +now apply Rgt_not_eq. +apply generic_format_F2R. +intros _. +rewrite <- H. +unfold cexp. +rewrite mag_unique with (1 := Hexy). +apply Z.le_refl. +(* . *) +intros H. +elim Rle_not_lt with (1 := round_le beta _ rnd _ _ (proj1 Hexy)). +rewrite (Rabs_pos_eq _ (Rlt_le _ _ Hxy)). +rewrite H. +rewrite round_generic... +apply bpow_gt_0. +apply generic_format_bpow. +apply Zlt_succ_le. +now rewrite (Zsucc_pred exy) in He'. +Qed. + +End round_plus_eq_zero_aux. + +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. + +(** rnd(x+y)=0 -> x+y = 0 provided this is not a FTZ format *) +Theorem round_plus_neq_0 : + forall x y, + format x -> format y -> + (x + y <> 0)%R -> + round beta fexp rnd (x + y) <> 0%R. +Proof with auto with typeclass_instances. +intros x y Hx Hy Hxy. +destruct (Rle_or_lt 0 (x + y)) as [H1|H1]. +(* . *) +destruct (Zle_or_lt (cexp beta fexp x) (cexp beta fexp y)) as [H2|H2]. +apply round_plus_neq_0_aux... +lra. +rewrite Rplus_comm. +apply round_plus_neq_0_aux ; try easy. +now apply Zlt_le_weak. +lra. +(* . *) +rewrite <- (Ropp_involutive (x + y)), Ropp_plus_distr. +rewrite round_opp. +apply Ropp_neq_0_compat. +destruct (Zle_or_lt (cexp beta fexp (-x)) (cexp beta fexp (-y))) as [H2|H2]. +apply round_plus_neq_0_aux; try apply generic_format_opp... +lra. +rewrite Rplus_comm. +apply round_plus_neq_0_aux; try apply generic_format_opp... +now apply Zlt_le_weak. +lra. +Qed. + +Theorem round_plus_eq_0 : + forall x y, + format x -> format y -> + round beta fexp rnd (x + y) = 0%R -> + (x + y = 0)%R. +Proof with auto with typeclass_instances. +intros x y Fx Fy H. +destruct (Req_dec (x + y) 0) as [H'|H']. +exact H'. +contradict H. +now apply round_plus_neq_0. +Qed. + +End Fprop_plus_zero. + +Section Fprop_plus_FLT. +Variable beta : radix. + +Notation bpow e := (bpow beta e). + +Variable emin prec : Z. +Context { prec_gt_0_ : Prec_gt_0 prec }. + +Theorem FLT_format_plus_small: forall x y, + generic_format beta (FLT_exp emin prec) x -> + generic_format beta (FLT_exp emin prec) y -> + (Rabs (x+y) <= bpow (prec+emin))%R -> + generic_format beta (FLT_exp emin prec) (x+y). +Proof with auto with typeclass_instances. +intros x y Fx Fy H. +apply generic_format_FLT_FIX... +rewrite Zplus_comm; assumption. +apply generic_format_FIX_FLT, FIX_format_generic in Fx. +apply generic_format_FIX_FLT, FIX_format_generic in Fy. +destruct Fx as [nx H1x H2x]. +destruct Fy as [ny H1y H2y]. +apply generic_format_FIX. +exists (Float beta (Fnum nx+Fnum ny)%Z emin). +rewrite H1x,H1y; unfold F2R; simpl. +rewrite H2x, H2y. +rewrite plus_IZR; ring. +easy. +Qed. + +Variable choice : Z -> bool. + +Lemma FLT_plus_error_N_ex : forall x y, + generic_format beta (FLT_exp emin prec) x -> + generic_format beta (FLT_exp emin prec) y -> + exists eps, + (Rabs eps <= u_ro beta prec / (1 + u_ro beta prec))%R /\ + round beta (FLT_exp emin prec) (Znearest choice) (x + y) + = ((x + y) * (1 + eps))%R. +Proof. +intros x y Fx Fy. +assert (Pb := u_rod1pu_ro_pos beta prec). +destruct (Rle_or_lt (bpow (emin + prec - 1)) (Rabs (x + y))) as [M|M]. +{ destruct (relative_error_N_FLX'_ex beta prec prec_gt_0_ choice (x + y)) + as (d, (Bd, Hd)). + now exists d; split; [exact Bd|]; rewrite <- Hd; apply round_FLT_FLX. } +exists 0%R; rewrite Rabs_R0; split; [exact Pb|]; rewrite Rplus_0_r, Rmult_1_r. +apply round_generic; [apply valid_rnd_N|]. +apply FLT_format_plus_small; [exact Fx|exact Fy|]. +apply Rlt_le, (Rlt_le_trans _ _ _ M), bpow_le; lia. +Qed. + +Lemma FLT_plus_error_N_round_ex : forall x y, + generic_format beta (FLT_exp emin prec) x -> + generic_format beta (FLT_exp emin prec) y -> + exists eps, + (Rabs eps <= u_ro beta prec)%R /\ + (x + y + = round beta (FLT_exp emin prec) (Znearest choice) (x + y) * (1 + eps))%R. +Proof. +intros x y Fx Fy. +now apply relative_error_N_round_ex_derive, FLT_plus_error_N_ex. +Qed. + +End Fprop_plus_FLT. + +Section Fprop_plus_mult_ulp. + +Variable beta : radix. +Notation bpow e := (bpow beta e). + +Variable fexp : Z -> Z. +Context { valid_exp : Valid_exp fexp }. +Context { monotone_exp : Monotone_exp fexp }. +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. + +Notation format := (generic_format beta fexp). +Notation cexp := (cexp beta fexp). + +Lemma ex_shift : + forall x e, format x -> (e <= cexp x)%Z -> + exists m, (x = IZR m * bpow e)%R. +Proof with auto with typeclass_instances. +intros x e Fx He. +exists (Ztrunc (scaled_mantissa beta fexp x)*Zpower beta (cexp x -e))%Z. +rewrite Fx at 1; unfold F2R; simpl. +rewrite mult_IZR, Rmult_assoc. +f_equal. +rewrite IZR_Zpower. +2: omega. +rewrite <- bpow_plus; f_equal; ring. +Qed. + +Lemma mag_minus1 : + forall z, z <> 0%R -> + (mag beta z - 1)%Z = mag beta (z / IZR beta). +Proof. +intros z Hz. +unfold Zminus. +rewrite <- mag_mult_bpow by easy. +now rewrite bpow_opp, bpow_1. +Qed. + +Theorem round_plus_F2R : + forall x y, format x -> format y -> (x <> 0)%R -> + exists m, + round beta fexp rnd (x+y) = F2R (Float beta m (cexp (x / IZR beta))). +Proof with auto with typeclass_instances. +intros x y Fx Fy Zx. +case (Zle_or_lt (mag beta (x/IZR beta)) (mag beta y)); intros H1. +pose (e:=cexp (x / IZR beta)). +destruct (ex_shift x e) as (nx, Hnx); try exact Fx. +apply monotone_exp. +rewrite <- (mag_minus1 x Zx); omega. +destruct (ex_shift y e) as (ny, Hny); try assumption. +apply monotone_exp... +destruct (round_repr_same_exp beta fexp rnd (nx+ny) e) as (n,Hn). +exists n. +fold e. +rewrite <- Hn; f_equal. +rewrite Hnx, Hny; unfold F2R; simpl; rewrite plus_IZR; ring. +unfold F2R; simpl. +(* *) +destruct (ex_shift (round beta fexp rnd (x + y)) (cexp (x/IZR beta))) as (n,Hn). +apply generic_format_round... +apply Z.le_trans with (cexp (x+y)). +apply monotone_exp. +rewrite <- mag_minus1 by easy. +rewrite <- (mag_abs beta (x+y)). +(* . *) +assert (U: (Rabs (x+y) = Rabs x + Rabs y)%R \/ (y <> 0 /\ Rabs (x+y) = Rabs x - Rabs y)%R). +assert (V: forall x y, (Rabs y <= Rabs x)%R -> + (Rabs (x+y) = Rabs x + Rabs y)%R \/ (y <> 0 /\ Rabs (x+y) = Rabs x - Rabs y)%R). +clear; intros x y. +case (Rle_or_lt 0 y); intros Hy. +case Hy; intros Hy'. +case (Rle_or_lt 0 x); intros Hx. +intros _; rewrite (Rabs_pos_eq y) by easy. +rewrite (Rabs_pos_eq x) by easy. +left; apply Rabs_pos_eq. +now apply Rplus_le_le_0_compat. +rewrite (Rabs_pos_eq y) by easy. +rewrite (Rabs_left x) by easy. +intros H; right; split. +now apply Rgt_not_eq. +rewrite Rabs_left1. +ring. +apply Rplus_le_reg_l with (-x)%R; ring_simplify; assumption. +intros _; left. +now rewrite <- Hy', Rabs_R0, 2!Rplus_0_r. +case (Rle_or_lt 0 x); intros Hx. +rewrite (Rabs_left y) by easy. +rewrite (Rabs_pos_eq x) by easy. +intros H; right; split. +now apply Rlt_not_eq. +rewrite Rabs_pos_eq. +ring. +apply Rplus_le_reg_l with (-y)%R; ring_simplify; assumption. +intros _; left. +rewrite (Rabs_left y) by easy. +rewrite (Rabs_left x) by easy. +rewrite Rabs_left1. +ring. +lra. +apply V; left. +apply lt_mag with beta. +now apply Rabs_pos_lt. +rewrite <- mag_minus1 in H1; try assumption. +rewrite 2!mag_abs; omega. +(* . *) +destruct U as [U|U]. +rewrite U; apply Z.le_trans with (mag beta x). +omega. +rewrite <- mag_abs. +apply mag_le. +now apply Rabs_pos_lt. +apply Rplus_le_reg_l with (-Rabs x)%R; ring_simplify. +apply Rabs_pos. +destruct U as (U',U); rewrite U. +rewrite <- mag_abs. +apply mag_minus_lb. +now apply Rabs_pos_lt. +now apply Rabs_pos_lt. +rewrite 2!mag_abs. +assert (mag beta y < mag beta x - 1)%Z. +now rewrite (mag_minus1 x Zx). +omega. +apply cexp_round_ge... +apply round_plus_neq_0... +contradict H1; apply Zle_not_lt. +rewrite <- (mag_minus1 x Zx). +replace y with (-x)%R. +rewrite mag_opp; omega. +lra. +now exists n. +Qed. + +Context {exp_not_FTZ : Exp_not_FTZ fexp}. + +Theorem round_plus_ge_ulp : + forall x y, format x -> format y -> + round beta fexp rnd (x+y) <> 0%R -> + (ulp beta fexp (x/IZR beta) <= Rabs (round beta fexp rnd (x+y)))%R. +Proof with auto with typeclass_instances. +intros x y Fx Fy KK. +case (Req_dec x 0); intros Zx. +(* *) +rewrite Zx, Rplus_0_l. +rewrite round_generic... +unfold Rdiv; rewrite Rmult_0_l. +rewrite Fy. +unfold F2R; simpl; rewrite Rabs_mult. +rewrite (Rabs_pos_eq (bpow _)) by apply bpow_ge_0. +case (Z.eq_dec (Ztrunc (scaled_mantissa beta fexp y)) 0); intros Hm. +contradict KK. +rewrite Zx, Fy, Hm; unfold F2R; simpl. +rewrite Rplus_0_l, Rmult_0_l. +apply round_0... +apply Rle_trans with (1*bpow (cexp y))%R. +rewrite Rmult_1_l. +rewrite <- ulp_neq_0. +apply ulp_ge_ulp_0... +intros K; apply Hm. +rewrite K, scaled_mantissa_0. +apply Ztrunc_IZR. +apply Rmult_le_compat_r. +apply bpow_ge_0. +rewrite <- abs_IZR. +apply IZR_le. +apply (Zlt_le_succ 0). +now apply Z.abs_pos. +(* *) +destruct (round_plus_F2R x y Fx Fy Zx) as (m,Hm). +case (Z.eq_dec m 0); intros Zm. +contradict KK. +rewrite Hm, Zm. +apply F2R_0. +rewrite Hm, <- F2R_Zabs. +rewrite ulp_neq_0. +rewrite <- (Rmult_1_l (bpow _)). +apply Rmult_le_compat_r. +apply bpow_ge_0. +apply IZR_le. +apply (Zlt_le_succ 0). +now apply Z.abs_pos. +apply Rmult_integral_contrapositive_currified with (1 := Zx). +apply Rinv_neq_0_compat. +apply Rgt_not_eq, radix_pos. +Qed. + +End Fprop_plus_mult_ulp. + +Section Fprop_plus_ge_ulp. + +Variable beta : radix. +Notation bpow e := (bpow beta e). + +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. +Variable emin prec : Z. +Context { prec_gt_0_ : Prec_gt_0 prec }. + +Theorem round_FLT_plus_ge : + forall x y e, + generic_format beta (FLT_exp emin prec) x -> generic_format beta (FLT_exp emin prec) y -> + (bpow (e + prec) <= Rabs x)%R -> + round beta (FLT_exp emin prec) rnd (x + y) <> 0%R -> + (bpow e <= Rabs (round beta (FLT_exp emin prec) rnd (x + y)))%R. +Proof with auto with typeclass_instances. +intros x y e Fx Fy He KK. +assert (Zx: x <> 0%R). + contradict He. + apply Rlt_not_le; rewrite He, Rabs_R0. + apply bpow_gt_0. +apply Rle_trans with (ulp beta (FLT_exp emin prec) (x/IZR beta)). +2: apply round_plus_ge_ulp... +rewrite ulp_neq_0. +unfold cexp. +rewrite <- mag_minus1; try assumption. +unfold FLT_exp; apply bpow_le. +apply Z.le_trans with (2:=Z.le_max_l _ _). +destruct (mag beta x) as (n,Hn); simpl. +assert (e + prec < n)%Z; try omega. +apply lt_bpow with beta. +apply Rle_lt_trans with (1:=He). +now apply Hn. +apply Rmult_integral_contrapositive_currified; try assumption. +apply Rinv_neq_0_compat. +apply Rgt_not_eq. +apply radix_pos. +Qed. + +Lemma round_FLT_plus_ge' : + forall x y e, + generic_format beta (FLT_exp emin prec) x -> generic_format beta (FLT_exp emin prec) y -> + (x <> 0%R -> (bpow (e+prec) <= Rabs x)%R) -> + (x = 0%R -> y <> 0%R -> (bpow e <= Rabs y)%R) -> + round beta (FLT_exp emin prec) rnd (x+y) <> 0%R -> + (bpow e <= Rabs (round beta (FLT_exp emin prec) rnd (x+y)))%R. +Proof with auto with typeclass_instances. +intros x y e Fx Fy H1 H2 H3. +case (Req_dec x 0); intros H4. +case (Req_dec y 0); intros H5. +contradict H3. +rewrite H4, H5, Rplus_0_l; apply round_0... +rewrite H4, Rplus_0_l. +rewrite round_generic... +apply round_FLT_plus_ge; try easy. +now apply H1. +Qed. + +Theorem round_FLX_plus_ge : + forall x y e, + generic_format beta (FLX_exp prec) x -> generic_format beta (FLX_exp prec) y -> + (bpow (e+prec) <= Rabs x)%R -> + (round beta (FLX_exp prec) rnd (x+y) <> 0)%R -> + (bpow e <= Rabs (round beta (FLX_exp prec) rnd (x+y)))%R. +Proof with auto with typeclass_instances. +intros x y e Fx Fy He KK. +assert (Zx: x <> 0%R). + contradict He. + apply Rlt_not_le; rewrite He, Rabs_R0. + apply bpow_gt_0. +apply Rle_trans with (ulp beta (FLX_exp prec) (x/IZR beta)). +2: apply round_plus_ge_ulp... +rewrite ulp_neq_0. +unfold cexp. +rewrite <- mag_minus1 by easy. +unfold FLX_exp; apply bpow_le. +destruct (mag beta x) as (n,Hn); simpl. +assert (e + prec < n)%Z; try omega. +apply lt_bpow with beta. +apply Rle_lt_trans with (1:=He). +now apply Hn. +apply Rmult_integral_contrapositive_currified; try assumption. +apply Rinv_neq_0_compat. +apply Rgt_not_eq. +apply radix_pos. +Qed. + +End Fprop_plus_ge_ulp. + +Section Fprop_plus_le_ops. + +Variable beta : radix. +Variable fexp : Z -> Z. +Context { valid_exp : Valid_exp fexp }. +Variable choice : Z -> bool. + +Lemma plus_error_le_l : + forall x y, + generic_format beta fexp x -> generic_format beta fexp y -> + (Rabs (round beta fexp (Znearest choice) (x + y) - (x + y)) <= Rabs x)%R. +Proof. +intros x y Fx Fy. +apply (Rle_trans _ (Rabs (y - (x + y)))); [now apply round_N_pt|]. +rewrite Rabs_minus_sym; right; f_equal; ring. +Qed. + +Lemma plus_error_le_r : + forall x y, + generic_format beta fexp x -> generic_format beta fexp y -> + (Rabs (round beta fexp (Znearest choice) (x + y) - (x + y)) <= Rabs y)%R. +Proof. now intros x y Fx Fy; rewrite Rplus_comm; apply plus_error_le_l. Qed. + +End Fprop_plus_le_ops. diff --git a/flocq/Prop/Relative.v b/flocq/Prop/Relative.v new file mode 100644 index 00000000..b936f2f7 --- /dev/null +++ b/flocq/Prop/Relative.v @@ -0,0 +1,983 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2010-2018 Sylvie Boldo +#
# +Copyright (C) 2010-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +(** * Relative error of the roundings *) +Require Import Core. +Require Import Psatz. (* for lra *) + +Section Fprop_relative. + +Variable beta : radix. +Notation bpow e := (bpow beta e). + +Section Fprop_relative_generic. + +Variable fexp : Z -> Z. +Context { prop_exp : Valid_exp fexp }. + +Section relative_error_conversion. + +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. + +Lemma relative_error_lt_conversion : + forall x b, (0 < b)%R -> + (x <> 0 -> Rabs (round beta fexp rnd x - x) < b * Rabs x)%R -> + exists eps, + (Rabs eps < b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R. +Proof with auto with typeclass_instances. +intros x b Hb0 Hxb. +destruct (Req_dec x 0) as [Hx0|Hx0]. +(* *) +exists 0%R. +split. +now rewrite Rabs_R0. +rewrite Hx0, Rmult_0_l. +apply round_0... +(* *) +specialize (Hxb Hx0). +exists ((round beta fexp rnd x - x) / x)%R. +split. 2: now field. +unfold Rdiv. +rewrite Rabs_mult. +apply Rmult_lt_reg_r with (Rabs x). +now apply Rabs_pos_lt. +rewrite Rmult_assoc, <- Rabs_mult. +rewrite Rinv_l with (1 := Hx0). +now rewrite Rabs_R1, Rmult_1_r. +Qed. + +Lemma relative_error_le_conversion : + forall x b, (0 <= b)%R -> + (Rabs (round beta fexp rnd x - x) <= b * Rabs x)%R -> + exists eps, + (Rabs eps <= b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R. +Proof with auto with typeclass_instances. +intros x b Hb0 Hxb. +destruct (Req_dec x 0) as [Hx0|Hx0]. +(* *) +exists 0%R. +split. +now rewrite Rabs_R0. +rewrite Hx0, Rmult_0_l. +apply round_0... +(* *) +exists ((round beta fexp rnd x - x) / x)%R. +split. 2: now field. +unfold Rdiv. +rewrite Rabs_mult. +apply Rmult_le_reg_r with (Rabs x). +now apply Rabs_pos_lt. +rewrite Rmult_assoc, <- Rabs_mult. +rewrite Rinv_l with (1 := Hx0). +now rewrite Rabs_R1, Rmult_1_r. +Qed. + +Lemma relative_error_le_conversion_inv : + forall x b, + (exists eps, + (Rabs eps <= b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R) -> + (Rabs (round beta fexp rnd x - x) <= b * Rabs x)%R. +Proof with auto with typeclass_instances. +intros x b (eps, (Beps, Heps)). +assert (Pb : (0 <= b)%R); [now revert Beps; apply Rle_trans, Rabs_pos|]. +rewrite Heps; replace (_ - _)%R with (eps * x)%R; [|ring]. +now rewrite Rabs_mult; apply Rmult_le_compat_r; [apply Rabs_pos|]. +Qed. + +Lemma relative_error_le_conversion_round_inv : + forall x b, + (exists eps, + (Rabs eps <= b)%R /\ x = (round beta fexp rnd x * (1 + eps))%R) -> + (Rabs (round beta fexp rnd x - x) <= b * Rabs (round beta fexp rnd x))%R. +Proof with auto with typeclass_instances. +intros x b. +set (rx := round _ _ _ _). +intros (eps, (Beps, Heps)). +assert (Pb : (0 <= b)%R); [now revert Beps; apply Rle_trans, Rabs_pos|]. +rewrite Heps; replace (_ - _)%R with (- (eps * rx))%R; [|ring]. +now rewrite Rabs_Ropp, Rabs_mult; apply Rmult_le_compat_r; [apply Rabs_pos|]. +Qed. + +End relative_error_conversion. + +Variable emin p : Z. +Hypothesis Hmin : forall k, (emin < k)%Z -> (p <= k - fexp k)%Z. + +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. + +Theorem relative_error : + forall x, + (bpow emin <= Rabs x)%R -> + (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs x)%R. +Proof with auto with typeclass_instances. +intros x Hx. +assert (Hx': (x <> 0)%R). +intros T; contradict Hx; rewrite T, Rabs_R0. +apply Rlt_not_le, bpow_gt_0. +apply Rlt_le_trans with (ulp beta fexp x)%R. +now apply error_lt_ulp... +rewrite ulp_neq_0; trivial. +unfold cexp. +destruct (mag beta x) as (ex, He). +simpl. +specialize (He Hx'). +apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R. +rewrite <- bpow_plus. +apply bpow_le. +assert (emin < ex)%Z. +apply (lt_bpow beta). +apply Rle_lt_trans with (2 := proj2 He). +exact Hx. +generalize (Hmin ex). +omega. +apply Rmult_le_compat_l. +apply bpow_ge_0. +apply He. +Qed. + +(** 1+#ε# property in any rounding *) +Theorem relative_error_ex : + forall x, + (bpow emin <= Rabs x)%R -> + exists eps, + (Rabs eps < bpow (-p + 1))%R /\ round beta fexp rnd x = (x * (1 + eps))%R. +Proof with auto with typeclass_instances. +intros x Hx. +apply relative_error_lt_conversion... +apply bpow_gt_0. +intros _. +now apply relative_error. +Qed. + +Theorem relative_error_F2R_emin : + forall m, let x := F2R (Float beta m emin) in + (x <> 0)%R -> + (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs x)%R. +Proof. +intros m x Hx. +apply relative_error. +unfold x. +rewrite <- F2R_Zabs. +apply bpow_le_F2R. +apply lt_F2R with beta emin. +rewrite F2R_0, F2R_Zabs. +now apply Rabs_pos_lt. +Qed. + +Theorem relative_error_F2R_emin_ex : + forall m, let x := F2R (Float beta m emin) in + exists eps, + (Rabs eps < bpow (-p + 1))%R /\ round beta fexp rnd x = (x * (1 + eps))%R. +Proof with auto with typeclass_instances. +intros m x. +apply relative_error_lt_conversion... +apply bpow_gt_0. +now apply relative_error_F2R_emin. +Qed. + +Theorem relative_error_round : + (0 < p)%Z -> + forall x, + (bpow emin <= Rabs x)%R -> + (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs (round beta fexp rnd x))%R. +Proof with auto with typeclass_instances. +intros Hp x Hx. +assert (Hx': (x <> 0)%R). +intros T; contradict Hx; rewrite T, Rabs_R0. +apply Rlt_not_le, bpow_gt_0. +apply Rlt_le_trans with (ulp beta fexp x)%R. +now apply error_lt_ulp. +rewrite ulp_neq_0; trivial. +unfold cexp. +destruct (mag beta x) as (ex, He). +simpl. +specialize (He Hx'). +assert (He': (emin < ex)%Z). +apply (lt_bpow beta). +apply Rle_lt_trans with (2 := proj2 He). +exact Hx. +apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R. +rewrite <- bpow_plus. +apply bpow_le. +generalize (Hmin ex). +omega. +apply Rmult_le_compat_l. +apply bpow_ge_0. +generalize He. +apply round_abs_abs... +clear rnd valid_rnd x Hx Hx' He. +intros rnd valid_rnd x _ Hx. +rewrite <- (round_generic beta fexp rnd (bpow (ex - 1))). +now apply round_le. +apply generic_format_bpow. +ring_simplify (ex - 1 + 1)%Z. +generalize (Hmin ex). +omega. +Qed. + +Theorem relative_error_round_F2R_emin : + (0 < p)%Z -> + forall m, let x := F2R (Float beta m emin) in + (x <> 0)%R -> + (Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs (round beta fexp rnd x))%R. +Proof. +intros Hp m x Hx. +apply relative_error_round. +exact Hp. +unfold x. +rewrite <- F2R_Zabs. +apply bpow_le_F2R. +apply lt_F2R with beta emin. +rewrite F2R_0, F2R_Zabs. +now apply Rabs_pos_lt. +Qed. + +Variable choice : Z -> bool. + +Theorem relative_error_N : + forall x, + (bpow emin <= Rabs x)%R -> + (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs x)%R. +Proof. +intros x Hx. +apply Rle_trans with (/2 * ulp beta fexp x)%R. +now apply error_le_half_ulp. +rewrite Rmult_assoc. +apply Rmult_le_compat_l. +apply Rlt_le. +apply Rinv_0_lt_compat. +now apply IZR_lt. +assert (Hx': (x <> 0)%R). +intros H. +apply Rlt_not_le with (2 := Hx). +rewrite H, Rabs_R0. +apply bpow_gt_0. +rewrite ulp_neq_0; trivial. +unfold cexp. +destruct (mag beta x) as (ex, He). +simpl. +specialize (He Hx'). +apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R. +rewrite <- bpow_plus. +apply bpow_le. +assert (emin < ex)%Z. +apply (lt_bpow beta). +apply Rle_lt_trans with (2 := proj2 He). +exact Hx. +generalize (Hmin ex). +omega. +apply Rmult_le_compat_l. +apply bpow_ge_0. +apply He. +Qed. + +(** 1+#ε# property in rounding to nearest *) +Theorem relative_error_N_ex : + forall x, + (bpow emin <= Rabs x)%R -> + exists eps, + (Rabs eps <= /2 * bpow (-p + 1))%R /\ round beta fexp (Znearest choice) x = (x * (1 + eps))%R. +Proof with auto with typeclass_instances. +intros x Hx. +apply relative_error_le_conversion... +apply Rlt_le. +apply Rmult_lt_0_compat. +apply Rinv_0_lt_compat. +now apply IZR_lt. +apply bpow_gt_0. +now apply relative_error_N. +Qed. + +Theorem relative_error_N_F2R_emin : + forall m, let x := F2R (Float beta m emin) in + (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs x)%R. +Proof with auto with typeclass_instances. +intros m x. +destruct (Req_dec x 0) as [Hx|Hx]. +(* . *) +rewrite Hx, round_0... +unfold Rminus. +rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0. +rewrite Rmult_0_r. +apply Rle_refl. +(* . *) +apply relative_error_N. +unfold x. +rewrite <- F2R_Zabs. +apply bpow_le_F2R. +apply lt_F2R with beta emin. +rewrite F2R_0, F2R_Zabs. +now apply Rabs_pos_lt. +Qed. + +Theorem relative_error_N_F2R_emin_ex : + forall m, let x := F2R (Float beta m emin) in + exists eps, + (Rabs eps <= /2 * bpow (-p + 1))%R /\ round beta fexp (Znearest choice) x = (x * (1 + eps))%R. +Proof with auto with typeclass_instances. +intros m x. +apply relative_error_le_conversion... +apply Rlt_le. +apply Rmult_lt_0_compat. +apply Rinv_0_lt_compat. +now apply IZR_lt. +apply bpow_gt_0. +now apply relative_error_N_F2R_emin. +Qed. + +Theorem relative_error_N_round : + (0 < p)%Z -> + forall x, + (bpow emin <= Rabs x)%R -> + (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs (round beta fexp (Znearest choice) x))%R. +Proof with auto with typeclass_instances. +intros Hp x Hx. +apply Rle_trans with (/2 * ulp beta fexp x)%R. +now apply error_le_half_ulp. +rewrite Rmult_assoc. +apply Rmult_le_compat_l. +apply Rlt_le. +apply Rinv_0_lt_compat. +now apply IZR_lt. +assert (Hx': (x <> 0)%R). +intros H. +apply Rlt_not_le with (2 := Hx). +rewrite H, Rabs_R0. +apply bpow_gt_0. +rewrite ulp_neq_0; trivial. +unfold cexp. +destruct (mag beta x) as (ex, He). +simpl. +specialize (He Hx'). +assert (He': (emin < ex)%Z). +apply (lt_bpow beta). +apply Rle_lt_trans with (2 := proj2 He). +exact Hx. +apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R. +rewrite <- bpow_plus. +apply bpow_le. +generalize (Hmin ex). +omega. +apply Rmult_le_compat_l. +apply bpow_ge_0. +generalize He. +apply round_abs_abs... +clear rnd valid_rnd x Hx Hx' He. +intros rnd valid_rnd x _ Hx. +rewrite <- (round_generic beta fexp rnd (bpow (ex - 1))). +now apply round_le. +apply generic_format_bpow. +ring_simplify (ex - 1 + 1)%Z. +generalize (Hmin ex). +omega. +Qed. + +Theorem relative_error_N_round_F2R_emin : + (0 < p)%Z -> + forall m, let x := F2R (Float beta m emin) in + (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs (round beta fexp (Znearest choice) x))%R. +Proof with auto with typeclass_instances. +intros Hp m x. +destruct (Req_dec x 0) as [Hx|Hx]. +(* . *) +rewrite Hx, round_0... +unfold Rminus. +rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0. +rewrite Rmult_0_r. +apply Rle_refl. +(* . *) +apply relative_error_N_round with (1 := Hp). +unfold x. +rewrite <- F2R_Zabs. +apply bpow_le_F2R. +apply lt_F2R with beta emin. +rewrite F2R_0, F2R_Zabs. +now apply Rabs_pos_lt. +Qed. + +End Fprop_relative_generic. + +Section Fprop_relative_FLX. + +Variable prec : Z. +Variable Hp : Z.lt 0 prec. + +Lemma relative_error_FLX_aux : + forall k, (prec <= k - FLX_exp prec k)%Z. +Proof. +intros k. +unfold FLX_exp. +omega. +Qed. + +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. + +Theorem relative_error_FLX : + forall x, + (x <> 0)%R -> + (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R. +Proof with auto with typeclass_instances. +intros x Hx. +destruct (mag beta x) as (ex, He). +specialize (He Hx). +apply relative_error with (ex - 1)%Z... +intros k _. +apply relative_error_FLX_aux. +apply He. +Qed. + +(** 1+#ε# property in any rounding in FLX *) +Theorem relative_error_FLX_ex : + forall x, + exists eps, + (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLX_exp prec) rnd x = (x * (1 + eps))%R. +Proof with auto with typeclass_instances. +intros x. +apply relative_error_lt_conversion... +apply bpow_gt_0. +now apply relative_error_FLX. +Qed. + +Theorem relative_error_FLX_round : + forall x, + (x <> 0)%R -> + (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs (round beta (FLX_exp prec) rnd x))%R. +Proof with auto with typeclass_instances. +intros x Hx. +destruct (mag beta x) as (ex, He). +specialize (He Hx). +apply relative_error_round with (ex - 1)%Z... +intros k _. +apply relative_error_FLX_aux. +apply He. +Qed. + +Variable choice : Z -> bool. + +Theorem relative_error_N_FLX : + forall x, + (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R. +Proof with auto with typeclass_instances. +intros x. +destruct (Req_dec x 0) as [Hx|Hx]. +(* . *) +rewrite Hx, round_0... +unfold Rminus. +rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0. +rewrite Rmult_0_r. +apply Rle_refl. +(* . *) +destruct (mag beta x) as (ex, He). +specialize (He Hx). +apply relative_error_N with (ex - 1)%Z... +intros k _. +apply relative_error_FLX_aux. +apply He. +Qed. + +(** unit roundoff *) +Definition u_ro := (/2 * bpow (-prec + 1))%R. + +Lemma u_ro_pos : (0 <= u_ro)%R. +Proof. apply Rmult_le_pos; [lra|apply bpow_ge_0]. Qed. + +Lemma u_ro_lt_1 : (u_ro < 1)%R. +Proof. +unfold u_ro; apply (Rmult_lt_reg_l 2); [lra|]. +rewrite <-Rmult_assoc, Rinv_r, Rmult_1_l, Rmult_1_r; [|lra]. +apply (Rle_lt_trans _ (bpow 0)); + [apply bpow_le; omega|simpl; lra]. +Qed. + +Lemma u_rod1pu_ro_pos : (0 <= u_ro / (1 + u_ro))%R. +Proof. +apply Rmult_le_pos; [|apply Rlt_le, Rinv_0_lt_compat]; +assert (H := u_ro_pos); lra. +Qed. + +Lemma u_rod1pu_ro_le_u_ro : (u_ro / (1 + u_ro) <= u_ro)%R. +Proof. +assert (Pu_ro := u_ro_pos). +apply (Rmult_le_reg_r (1 + u_ro)); [lra|]. +unfold Rdiv; rewrite Rmult_assoc, Rinv_l; [|lra]. +assert (0 <= u_ro * u_ro)%R; [apply Rmult_le_pos|]; lra. +Qed. + +Theorem relative_error_N_FLX' : + forall x, + (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) + <= u_ro / (1 + u_ro) * Rabs x)%R. +Proof with auto with typeclass_instances. +intro x. +assert (Pu_ro : (0 <= u_ro)%R). +{ apply Rmult_le_pos; [lra|apply bpow_ge_0]. } +destruct (Req_dec x 0) as [Zx|Nzx]. +{ rewrite Zx, Rabs_R0, Rmult_0_r, round_0... + now unfold Rminus; rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0; right. } +set (ufpx := bpow (mag beta x - 1)%Z). +set (rx := round _ _ _ _). +assert (Pufpx : (0 <= ufpx)%R); [now apply bpow_ge_0|]. +assert (H_2_1 : (Rabs (rx - x) <= u_ro * ufpx)%R). +{ refine (Rle_trans _ _ _ (error_le_half_ulp _ _ _ _) _); + [now apply FLX_exp_valid|right]. + unfold ulp, cexp, FLX_exp, u_ro, ufpx; rewrite (Req_bool_false _ _ Nzx). + rewrite Rmult_assoc, <-bpow_plus; do 2 f_equal; ring. } +assert (H_2_3 : (ufpx + Rabs (rx - x) <= Rabs x)%R). +{ apply (Rplus_le_reg_r (- ufpx)); ring_simplify. + destruct (Rle_or_lt 0 x) as [Sx|Sx]. + { apply (Rle_trans _ (Rabs (ufpx - x))). + { apply round_N_pt; [now apply FLX_exp_valid|]. + apply generic_format_bpow; unfold FLX_exp; lia. } + rewrite Rabs_minus_sym, Rabs_pos_eq. + { now rewrite Rabs_pos_eq; [right; ring|]. } + apply (Rplus_le_reg_r ufpx); ring_simplify. + now rewrite <-(Rabs_pos_eq _ Sx); apply bpow_mag_le. } + apply (Rle_trans _ (Rabs (- ufpx - x))). + { apply round_N_pt; [now apply FLX_exp_valid|]. + apply generic_format_opp, generic_format_bpow; unfold FLX_exp; lia. } + rewrite Rabs_pos_eq; [now rewrite Rabs_left; [right|]|]. + apply (Rplus_le_reg_r x); ring_simplify. + rewrite <-(Ropp_involutive x); apply Ropp_le_contravar; unfold ufpx. + rewrite <-mag_opp, <-Rabs_pos_eq; [apply bpow_mag_le|]; lra. } +assert (H : (Rabs ((rx - x) / x) <= u_ro / (1 + u_ro))%R). +{ assert (H : (0 < ufpx + Rabs (rx - x))%R). + { apply Rplus_lt_le_0_compat; [apply bpow_gt_0|apply Rabs_pos]. } + apply (Rle_trans _ (Rabs (rx - x) / (ufpx + Rabs (rx - x)))). + { unfold Rdiv; rewrite Rabs_mult; apply Rmult_le_compat_l; [apply Rabs_pos|]. + now rewrite (Rabs_Rinv _ Nzx); apply Rinv_le. } + apply (Rmult_le_reg_r ((ufpx + Rabs (rx - x)) * (1 + u_ro))). + { apply Rmult_lt_0_compat; lra. } + field_simplify; [unfold Rdiv; rewrite Rinv_1, !Rmult_1_r| |]; lra. } +revert H; unfold Rdiv; rewrite Rabs_mult, (Rabs_Rinv _ Nzx); intro H. +apply (Rmult_le_reg_r (/ Rabs x)); [now apply Rinv_0_lt_compat, Rabs_pos_lt|]. +now apply (Rle_trans _ _ _ H); right; field; split; [apply Rabs_no_R0|lra]. +Qed. + +(** 1+#ε# property in rounding to nearest in FLX *) +Theorem relative_error_N_FLX_ex : + forall x, + exists eps, + (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLX_exp prec) (Znearest choice) x = (x * (1 + eps))%R. +Proof with auto with typeclass_instances. +intros x. +apply relative_error_le_conversion... +apply Rlt_le. +apply Rmult_lt_0_compat. +apply Rinv_0_lt_compat. +now apply IZR_lt. +apply bpow_gt_0. +now apply relative_error_N_FLX. +Qed. + +Theorem relative_error_N_FLX'_ex : + forall x, + exists eps, + (Rabs eps <= u_ro / (1 + u_ro))%R /\ + round beta (FLX_exp prec) (Znearest choice) x = (x * (1 + eps))%R. +Proof with auto with typeclass_instances. +intros x. +apply relative_error_le_conversion... +{ apply u_rod1pu_ro_pos. } +now apply relative_error_N_FLX'. +Qed. + +Lemma relative_error_N_round_ex_derive : + forall x rx, + (exists eps, (Rabs eps <= u_ro / (1 + u_ro))%R /\ rx = (x * (1 + eps))%R) -> + exists eps, (Rabs eps <= u_ro)%R /\ x = (rx * (1 + eps))%R. +Proof. +intros x rx (d, (Bd, Hd)). +assert (Pu_ro := u_ro_pos). +assert (H := Rabs_le_inv _ _ Bd). +assert (H' := u_rod1pu_ro_le_u_ro); assert (H'' := u_ro_lt_1). +destruct (Req_dec rx 0) as [Zfx|Nzfx]. +{ exists 0%R; split; [now rewrite Rabs_R0|]. + rewrite Rplus_0_r, Rmult_1_r, Zfx. + now rewrite Zfx in Hd; destruct (Rmult_integral _ _ (sym_eq Hd)); [|lra]. } +destruct (Req_dec x 0) as [Zx|Nzx]. +{ now exfalso; revert Hd; rewrite Zx, Rmult_0_l. } +set (d' := ((x - rx) / rx)%R). +assert (Hd' : (Rabs d' <= u_ro)%R). +{ unfold d'; rewrite Hd. + replace (_ / _)%R with (- d / (1 + d))%R; [|now field; split; lra]. + unfold Rdiv; rewrite Rabs_mult, Rabs_Ropp. + rewrite (Rabs_pos_eq (/ _)); [|apply Rlt_le, Rinv_0_lt_compat; lra]. + apply (Rmult_le_reg_r (1 + d)); [lra|]. + rewrite Rmult_assoc, Rinv_l, Rmult_1_r; [|lra]. + apply (Rle_trans _ _ _ Bd). + unfold Rdiv; apply Rmult_le_compat_l; [now apply u_ro_pos|]. + apply (Rle_trans _ (1 - u_ro / (1 + u_ro))); [right; field|]; lra. } +now exists d'; split; [|unfold d'; field]. +Qed. + +Theorem relative_error_N_FLX_round_ex : + forall x, + exists eps, + (Rabs eps <= u_ro)%R /\ + x = (round beta (FLX_exp prec) (Znearest choice) x * (1 + eps))%R. +Proof. +intro x; apply relative_error_N_round_ex_derive, relative_error_N_FLX'_ex. +Qed. + +Theorem relative_error_N_FLX_round : + forall x, + (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs(round beta (FLX_exp prec) (Znearest choice) x))%R. +Proof. +intro x. +apply relative_error_le_conversion_round_inv, relative_error_N_FLX_round_ex. +Qed. + +End Fprop_relative_FLX. + +Section Fprop_relative_FLT. + +Variable emin prec : Z. +Variable Hp : Z.lt 0 prec. + +Lemma relative_error_FLT_aux : + forall k, (emin + prec - 1 < k)%Z -> (prec <= k - FLT_exp emin prec k)%Z. +Proof. +intros k Hk. +unfold FLT_exp. +generalize (Zmax_spec (k - prec) emin). +omega. +Qed. + +Variable rnd : R -> Z. +Context { valid_rnd : Valid_rnd rnd }. + +Theorem relative_error_FLT : + forall x, + (bpow (emin + prec - 1) <= Rabs x)%R -> + (Rabs (round beta (FLT_exp emin prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R. +Proof with auto with typeclass_instances. +intros x Hx. +apply relative_error with (emin + prec - 1)%Z... +apply relative_error_FLT_aux. +Qed. + +Theorem relative_error_FLT_F2R_emin : + forall m, let x := F2R (Float beta m emin) in + (x <> 0)%R -> + (Rabs (round beta (FLT_exp emin prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R. +Proof with auto with typeclass_instances. +intros m x Zx. +destruct (Rlt_or_le (Rabs x) (bpow (emin + prec - 1))) as [Hx|Hx]. +rewrite round_generic... +unfold Rminus. +rewrite Rplus_opp_r, Rabs_R0. +apply Rmult_lt_0_compat. +apply bpow_gt_0. +now apply Rabs_pos_lt. +apply generic_format_FLT_FIX... +apply Rlt_le. +apply Rlt_le_trans with (1 := Hx). +apply bpow_le. +apply Zle_pred. +apply generic_format_FIX. +now exists (Float beta m emin). +now apply relative_error_FLT. +Qed. + +Theorem relative_error_FLT_F2R_emin_ex : + forall m, let x := F2R (Float beta m emin) in + exists eps, + (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) rnd x = (x * (1 + eps))%R. +Proof with auto with typeclass_instances. +intros m x. +apply relative_error_lt_conversion... +apply bpow_gt_0. +now apply relative_error_FLT_F2R_emin. +Qed. + +(** 1+#ε# property in any rounding in FLT *) +Theorem relative_error_FLT_ex : + forall x, + (bpow (emin + prec - 1) <= Rabs x)%R -> + exists eps, + (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) rnd x = (x * (1 + eps))%R. +Proof with auto with typeclass_instances. +intros x Hx. +apply relative_error_lt_conversion... +apply bpow_gt_0. +intros _; now apply relative_error_FLT. +Qed. + +Variable choice : Z -> bool. + +Theorem relative_error_N_FLT : + forall x, + (bpow (emin + prec - 1) <= Rabs x)%R -> + (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R. +Proof with auto with typeclass_instances. +intros x Hx. +apply relative_error_N with (emin + prec - 1)%Z... +apply relative_error_FLT_aux. +Qed. + +(** 1+#ε# property in rounding to nearest in FLT *) +Theorem relative_error_N_FLT_ex : + forall x, + (bpow (emin + prec - 1) <= Rabs x)%R -> + exists eps, + (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps))%R. +Proof with auto with typeclass_instances. +intros x Hx. +apply relative_error_le_conversion... +apply Rlt_le. +apply Rmult_lt_0_compat. +apply Rinv_0_lt_compat. +now apply IZR_lt. +apply bpow_gt_0. +now apply relative_error_N_FLT. +Qed. + +Theorem relative_error_N_FLT_round : + forall x, + (bpow (emin + prec - 1) <= Rabs x)%R -> + (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLT_exp emin prec) (Znearest choice) x))%R. +Proof with auto with typeclass_instances. +intros x Hx. +apply relative_error_N_round with (emin + prec - 1)%Z... +apply relative_error_FLT_aux. +Qed. + +Theorem relative_error_N_FLT_F2R_emin : + forall m, let x := F2R (Float beta m emin) in + (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R. +Proof with auto with typeclass_instances. +intros m x. +destruct (Rlt_or_le (Rabs x) (bpow (emin + prec - 1))) as [Hx|Hx]. +rewrite round_generic... +unfold Rminus. +rewrite Rplus_opp_r, Rabs_R0. +apply Rmult_le_pos. +apply Rmult_le_pos. +apply Rlt_le. +apply (RinvN_pos 1). +apply bpow_ge_0. +apply Rabs_pos. +apply generic_format_FLT_FIX... +apply Rlt_le. +apply Rlt_le_trans with (1 := Hx). +apply bpow_le. +apply Zle_pred. +apply generic_format_FIX. +now exists (Float beta m emin). +now apply relative_error_N_FLT. +Qed. + +Theorem relative_error_N_FLT_F2R_emin_ex : + forall m, let x := F2R (Float beta m emin) in + exists eps, + (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps))%R. +Proof with auto with typeclass_instances. +intros m x. +apply relative_error_le_conversion... +apply Rmult_le_pos. +apply Rlt_le. +apply (RinvN_pos 1). +apply bpow_ge_0. +now apply relative_error_N_FLT_F2R_emin. +Qed. + + +Theorem relative_error_N_FLT_round_F2R_emin : + forall m, let x := F2R (Float beta m emin) in + (Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLT_exp emin prec) (Znearest choice) x))%R. +Proof with auto with typeclass_instances. +intros m x. +destruct (Rlt_or_le (Rabs x) (bpow (emin + prec - 1))) as [Hx|Hx]. +rewrite round_generic... +unfold Rminus. +rewrite Rplus_opp_r, Rabs_R0. +apply Rmult_le_pos. +apply Rmult_le_pos. +apply Rlt_le. +apply (RinvN_pos 1). +apply bpow_ge_0. +apply Rabs_pos. +apply generic_format_FLT_FIX... +apply Rlt_le. +apply Rlt_le_trans with (1 := Hx). +apply bpow_le. +apply Zle_pred. +apply generic_format_FIX. +now exists (Float beta m emin). +apply relative_error_N_round with (emin := (emin + prec - 1)%Z)... +apply relative_error_FLT_aux. +Qed. + +Lemma error_N_FLT_aux : + forall x, + (0 < x)%R -> + exists eps, exists eta, + (Rabs eps <= /2 * bpow (-prec + 1))%R /\ + (Rabs eta <= /2 * bpow (emin))%R /\ + (eps*eta=0)%R /\ + round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps) + eta)%R. +Proof. +intros x Hx2. +case (Rle_or_lt (bpow (emin+prec)) x); intros Hx. +(* *) +destruct relative_error_N_ex with (FLT_exp emin prec) (emin+prec)%Z prec choice x + as (eps,(Heps1,Heps2)). +now apply FLT_exp_valid. +intros; unfold FLT_exp. +rewrite Zmax_left; omega. +rewrite Rabs_right;[assumption|apply Rle_ge; now left]. +exists eps; exists 0%R. +split;[assumption|split]. +rewrite Rabs_R0; apply Rmult_le_pos. +apply Rlt_le, pos_half_prf. +apply bpow_ge_0. +split;[apply Rmult_0_r|idtac]. +now rewrite Rplus_0_r. +(* *) +exists 0%R; exists (round beta (FLT_exp emin prec) (Znearest choice) x - x)%R. +split. +rewrite Rabs_R0; apply Rmult_le_pos. +apply Rlt_le, pos_half_prf. +apply bpow_ge_0. +split. +apply Rle_trans with (/2*ulp beta (FLT_exp emin prec) x)%R. +apply error_le_half_ulp. +now apply FLT_exp_valid. +apply Rmult_le_compat_l. +apply Rlt_le, pos_half_prf. +rewrite ulp_neq_0. +2: now apply Rgt_not_eq. +apply bpow_le. +unfold FLT_exp, cexp. +rewrite Zmax_right. +omega. +destruct (mag beta x) as (e,He); simpl. +assert (e-1 < emin+prec)%Z. +apply (lt_bpow beta). +apply Rle_lt_trans with (2:=Hx). +rewrite <- (Rabs_pos_eq x) by now apply Rlt_le. +now apply He, Rgt_not_eq. +omega. +split ; ring. +Qed. + +Theorem relative_error_N_FLT'_ex : + forall x, + exists eps eta : R, + (Rabs eps <= u_ro prec / (1 + u_ro prec))%R /\ + (Rabs eta <= /2 * bpow emin)%R /\ + (eps * eta = 0)%R /\ + round beta (FLT_exp emin prec) (Znearest choice) x + = (x * (1 + eps) + eta)%R. +Proof. +intro x. +set (rx := round _ _ _ x). +assert (Pb := u_rod1pu_ro_pos prec). +destruct (Rle_or_lt (bpow (emin + prec - 1)) (Rabs x)) as [MX|Mx]. +{ destruct (relative_error_N_FLX'_ex prec Hp choice x) as (d, (Bd, Hd)). + exists d, 0%R; split; [exact Bd|]; split. + { rewrite Rabs_R0; apply Rmult_le_pos; [lra|apply bpow_ge_0]. } + rewrite Rplus_0_r, Rmult_0_r; split; [reflexivity|]. + now rewrite <- Hd; apply round_FLT_FLX. } +assert (H : (Rabs (rx - x) <= /2 * bpow emin)%R). +{ refine (Rle_trans _ _ _ (error_le_half_ulp _ _ _ _) _); + [now apply FLT_exp_valid|]. + rewrite ulp_FLT_small; [now right|now simpl|]. + apply (Rlt_le_trans _ _ _ Mx), bpow_le; lia. } +exists 0%R, (rx - x)%R; split; [now rewrite Rabs_R0|]; split; [exact H|]. +now rewrite Rmult_0_l, Rplus_0_r, Rmult_1_r; split; [|ring]. +Qed. + +Theorem relative_error_N_FLT'_ex_separate : + forall x, + exists x' : R, + round beta (FLT_exp emin prec) (Znearest choice) x' + = round beta (FLT_exp emin prec) (Znearest choice) x /\ + (exists eta, Rabs eta <= /2 * bpow emin /\ x' = x + eta)%R /\ + (exists eps, Rabs eps <= u_ro prec / (1 + u_ro prec) /\ + round beta (FLT_exp emin prec) (Znearest choice) x' + = x' * (1 + eps))%R. +Proof. +intro x. +set (rx := round _ _ _ x). +destruct (relative_error_N_FLT'_ex x) as (d, (e, (Bd, (Be, (Hde0, Hde))))). +destruct (Rlt_or_le (Rabs (d * x)) (Rabs e)) as [HdxLte|HeLedx]. +{ exists rx; split; [|split]. + { apply round_generic; [now apply valid_rnd_N|]. + now apply generic_format_round; [apply FLT_exp_valid|apply valid_rnd_N]. } + { exists e; split; [exact Be|]. + unfold rx; rewrite Hde; destruct (Rmult_integral _ _ Hde0) as [Zd|Ze]. + { now rewrite Zd, Rplus_0_r, Rmult_1_r. } + exfalso; revert HdxLte; rewrite Ze, Rabs_R0; apply Rle_not_lt, Rabs_pos. } + exists 0%R; split; [now rewrite Rabs_R0; apply u_rod1pu_ro_pos|]. + rewrite Rplus_0_r, Rmult_1_r; apply round_generic; [now apply valid_rnd_N|]. + now apply generic_format_round; [apply FLT_exp_valid|apply valid_rnd_N]. } +exists x; split; [now simpl|split]. +{ exists 0%R; split; + [rewrite Rabs_R0; apply Rmult_le_pos; [lra|apply bpow_ge_0]|ring]. } +exists d; rewrite Hde; destruct (Rmult_integral _ _ Hde0) as [Zd|Ze]. +{ split; [exact Bd|]. + assert (Ze : e = 0%R); [|now rewrite Ze, Rplus_0_r]. + apply Rabs_eq_R0, Rle_antisym; [|now apply Rabs_pos]. + now revert HeLedx; rewrite Zd, Rmult_0_l, Rabs_R0. } +now rewrite Ze, Rplus_0_r. +Qed. + +End Fprop_relative_FLT. + +Theorem error_N_FLT : + forall (emin prec : Z), (0 < prec)%Z -> + forall (choice : Z -> bool), + forall (x : R), + exists eps eta : R, + (Rabs eps <= /2 * bpow (-prec + 1))%R /\ + (Rabs eta <= /2 * bpow emin)%R /\ + (eps * eta = 0)%R /\ + (round beta (FLT_exp emin prec) (Znearest choice) x + = x * (1 + eps) + eta)%R. +Proof. +intros emin prec Pprec choice x. +destruct (Rtotal_order x 0) as [Nx|[Zx|Px]]. +{ assert (Pmx : (0 < - x)%R). + { now rewrite <- Ropp_0; apply Ropp_lt_contravar. } + destruct (@error_N_FLT_aux emin prec Pprec + (fun t : Z => negb (choice (- (t + 1))%Z)) + (- x)%R Pmx) + as (d,(e,(Hd,(He,(Hde,Hr))))). + exists d; exists (- e)%R; split; [exact Hd|split; [|split]]. + { now rewrite Rabs_Ropp. } + { now rewrite Ropp_mult_distr_r_reverse, <- Ropp_0; apply f_equal. } + rewrite <- (Ropp_involutive x), round_N_opp. + now rewrite Ropp_mult_distr_l_reverse, <- Ropp_plus_distr; apply f_equal. } +{ assert (Ph2 : (0 <= / 2)%R). + { apply (Rmult_le_reg_l 2 _ _ Rlt_0_2). + rewrite Rmult_0_r, Rinv_r; [exact Rle_0_1|]. + apply Rgt_not_eq, Rlt_gt, Rlt_0_2. } + exists 0%R; exists 0%R; rewrite Zx; split; [|split; [|split]]. + { now rewrite Rabs_R0; apply Rmult_le_pos; [|apply bpow_ge_0]. } + { now rewrite Rabs_R0; apply Rmult_le_pos; [|apply bpow_ge_0]. } + { now rewrite Rmult_0_l. } + now rewrite Rmult_0_l, Rplus_0_l, round_0; [|apply valid_rnd_N]. } +now apply error_N_FLT_aux. +Qed. + +End Fprop_relative. diff --git a/flocq/Prop/Round_odd.v b/flocq/Prop/Round_odd.v new file mode 100644 index 00000000..df2952cc --- /dev/null +++ b/flocq/Prop/Round_odd.v @@ -0,0 +1,1220 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2013-2018 Sylvie Boldo +#
# +Copyright (C) 2013-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +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 Core Operations. + +Definition Zrnd_odd x := match Req_EM_T x (IZR (Zfloor x)) with + | left _ => Zfloor x + | right _ => match (Z.even (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 Z.le_trans with (Zfloor y). +now apply Zfloor_le. +unfold Zrnd_odd; destruct (Req_EM_T y (IZR (Zfloor y))). +now apply Z.le_refl. +case (Z.even (Zfloor y)). +apply le_IZR. +apply Rle_trans with y. +apply Zfloor_lb. +apply Zceil_ub. +now apply Z.le_refl. +unfold Zrnd_odd at 1. +(* . *) +destruct (Req_EM_T x (IZR (Zfloor x))) as [Hx|Hx]. +(* .. *) +apply H. +(* .. *) +case_eq (Z.even (Zfloor x)); intros Hx2. +2: apply H. +unfold Zrnd_odd; destruct (Req_EM_T y (IZR (Zfloor y))) as [Hy|Hy]. +apply Zceil_glb. +now rewrite <- Hy. +case_eq (Z.even (Zfloor y)); intros Hy2. +now apply Zceil_le. +apply Zceil_glb. +assert (H0:(Zfloor x <= Zfloor y)%Z) by now apply Zfloor_le. +case (Zle_lt_or_eq _ _ H0); intros H1. +apply Rle_trans with (1:=Zceil_ub _). +rewrite Zceil_floor_neq. +apply IZR_le; omega. +now apply sym_not_eq. +contradict Hy2. +rewrite <- H1, Hx2; discriminate. +(* . *) +intros n; unfold Zrnd_odd. +rewrite Zfloor_IZR, Zceil_IZR. +destruct (Req_EM_T (IZR n) (IZR n)); trivial. +case (Z.even n); trivial. +Qed. + + + +Lemma Zrnd_odd_Zodd: forall x, x <> (IZR (Zfloor x)) -> + (Z.even (Zrnd_odd x)) = false. +Proof. +intros x Hx; unfold Zrnd_odd. +destruct (Req_EM_T x (IZR (Zfloor x))) as [H|H]. +now contradict H. +case_eq (Z.even (Zfloor x)). +(* difficult case *) +intros H'. +rewrite Zceil_floor_neq. +rewrite Z.even_add, H'. +reflexivity. +now apply sym_not_eq. +trivial. +Qed. + + +Lemma Zfloor_plus: forall (n:Z) y, + (Zfloor (IZR n+y) = n + Zfloor y)%Z. +Proof. +intros n y; unfold Zfloor. +unfold Zminus; rewrite Zplus_assoc; f_equal. +apply sym_eq, tech_up. +rewrite plus_IZR. +apply Rplus_lt_compat_l. +apply archimed. +rewrite plus_IZR, Rplus_assoc. +apply Rplus_le_compat_l. +apply Rplus_le_reg_r with (-y)%R. +ring_simplify (y+1+-y)%R. +apply archimed. +Qed. + +Lemma Zceil_plus: forall (n:Z) y, + (Zceil (IZR n+y) = n + Zceil y)%Z. +Proof. +intros n y; unfold Zceil. +rewrite Ropp_plus_distr, <- Ropp_Ropp_IZR. +rewrite Zfloor_plus. +ring. +Qed. + + +Lemma Zeven_abs: forall z, Z.even (Z.abs z) = Z.even z. +Proof. +intros z; case (Zle_or_lt z 0); intros H1. +rewrite Z.abs_neq; try assumption. +apply Z.even_opp. +rewrite Z.abs_eq; auto with zarith. +Qed. + + + + +Lemma Zrnd_odd_plus: forall x y, (x = IZR (Zfloor x)) -> + Z.even (Zfloor x) = true -> + (IZR (Zrnd_odd (x+y)) = x+IZR (Zrnd_odd y))%R. +Proof. +intros x y Hx H. +unfold Zrnd_odd; rewrite Hx, Zfloor_plus. +case (Req_EM_T y (IZR (Zfloor y))); intros Hy. +rewrite Hy; repeat rewrite <- plus_IZR. +repeat rewrite Zfloor_IZR. +case (Req_EM_T _ _); intros K; easy. +case (Req_EM_T _ _); intros K. +contradict Hy. +apply Rplus_eq_reg_l with (IZR (Zfloor x)). +now rewrite K, plus_IZR. +rewrite Z.even_add, H; simpl. +case (Z.even (Zfloor y)). +now rewrite Zceil_plus, plus_IZR. +now rewrite plus_IZR. +Qed. + + +Section Fcore_rnd_odd. + +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 canonical := (canonical beta fexp). +Notation cexp := (cexp beta fexp). + + +Definition Rnd_odd_pt (x f : R) := + format f /\ ((f = x)%R \/ + ((Rnd_DN_pt format x f \/ Rnd_UP_pt format x f) /\ + exists g : float beta, f = F2R g /\ canonical g /\ Z.even (Fnum g) = false)). + +Definition Rnd_odd (rnd : R -> R) := + forall x : R, Rnd_odd_pt x (rnd x). + +Theorem Rnd_odd_pt_opp_inv : forall x f : R, + Rnd_odd_pt (-x) (-f) -> Rnd_odd_pt x f. +Proof with auto with typeclass_instances. +intros x f (H1,H2). +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_UP_pt_opp... +apply generic_format_opp. +left. +replace f with (-(-f))%R by ring. +replace x with (-(-x))%R by ring. +apply Rnd_DN_pt_opp... +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 canonical_opp. +simpl. +now rewrite Z.even_opp. +Qed. + + +Theorem round_odd_opp : + forall x, + round beta fexp Zrnd_odd (-x) = (- round beta fexp Zrnd_odd x)%R. +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) (IZR (Zfloor (- r)))). +case (Req_EM_T r (IZR (Zfloor r))). +intros Y1 Y2. +apply eq_IZR. +now rewrite opp_IZR, <- Y1, <-Y2. +intros Y1 Y2. +absurd (r=IZR (Zfloor r)); trivial. +pattern r at 2; replace r with (-(-r))%R by ring. +rewrite Y2, <- opp_IZR. +rewrite Zfloor_IZR. +rewrite opp_IZR, <- Y2. +ring. +case (Req_EM_T r (IZR (Zfloor r))). +intros Y1 Y2. +absurd (-r=IZR (Zfloor (-r)))%R; trivial. +pattern r at 2; rewrite Y1. +rewrite <- opp_IZR, Zfloor_IZR. +now rewrite opp_IZR, <- Y1. +intros Y1 Y2. +unfold Zceil; rewrite Ropp_involutive. +replace (Z.even (Zfloor (- r))) with (negb (Z.even (Zfloor r))). +case (Z.even (Zfloor r)); simpl; ring. +apply trans_eq with (Z.even (Zceil r)). +rewrite Zceil_floor_neq. +rewrite Z.even_add. +destruct (Z.even (Zfloor r)); reflexivity. +now apply sym_not_eq. +rewrite <- (Z.even_opp (Zfloor (- r))). +reflexivity. +apply cexp_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_opp_inv. +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) + (IZR (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 (Z.even (Zfloor (scaled_mantissa beta fexp x))). +(* . *) +generalize (generic_format_round beta fexp Zceil x). +unfold generic_format. +set (f:=round beta fexp Zceil x). +set (ef := cexp f). +set (mf := Ztrunc (scaled_mantissa beta fexp f)). +exists (Float beta mf ef). +unfold canonical. +rewrite <- H0. +repeat split; try assumption. +apply trans_eq with (negb (Z.even (Zfloor (scaled_mantissa beta fexp x)))). +2: rewrite H1; reflexivity. +apply trans_eq with (negb (Z.even (Fnum + (Float beta (Zfloor (scaled_mantissa beta fexp x)) (cexp x))))). +2: reflexivity. +case (Rle_lt_or_eq_dec 0 (round beta fexp Zfloor x)). +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 canonical. +simpl. +apply sym_eq, cexp_DN... +unfold canonical. +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 (mag 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 canonical_0. +unfold canonical. +rewrite <- H0; reflexivity. +rewrite <- Y; unfold F2R; simpl; ring. +apply trans_eq with (round beta fexp Ztrunc (round beta fexp Zceil x)). +reflexivity. +apply round_generic... +simpl. +apply eq_IZR, Rmult_eq_reg_r with (bpow (cexp x)). +unfold round, F2R in Y; simpl in Y; rewrite <- Y. +simpl; ring. +apply Rgt_not_eq, bpow_gt_0. +(* . *) +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 := cexp x). +set (mf := Zfloor (scaled_mantissa beta fexp x)). +exists (Float beta mf ef). +unfold canonical. +repeat split; try assumption. +simpl. +apply trans_eq with (cexp (round beta fexp Zfloor x )). +apply sym_eq, cexp_DN... +reflexivity. +intros Hrx; contradict Y. +replace (Zfloor (scaled_mantissa beta fexp x)) with 0%Z. +simpl; discriminate. +apply eq_IZR, Rmult_eq_reg_r with (bpow (cexp x)). +unfold round, F2R in Hrx; simpl in Hrx; rewrite <- Hrx. +simpl; ring. +apply Rgt_not_eq, bpow_gt_0. +Qed. + +Theorem Rnd_odd_pt_unique : + 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_unique with format x; assumption. +destruct H1' as (ff,(K1,(K2,K3))). +destruct H2' as (gg,(L1,(L2,L3))). +absurd (true = false); try discriminate. +rewrite <- L3. +apply trans_eq with (negb (Z.even (Fnum ff))). +rewrite K3; easy. +apply sym_eq. +generalize (DN_UP_parity_generic beta fexp). +unfold DN_UP_parity_prop; intros T; apply (T x); clear T; try assumption... +rewrite <- K1; apply Rnd_DN_pt_unique with (generic_format beta fexp) x; try easy... +now apply round_DN_pt... +rewrite <- L1; apply Rnd_UP_pt_unique with (generic_format beta fexp) x; try easy... +now apply round_UP_pt... +(* *) +destruct H1' as (ff,(K1,(K2,K3))). +destruct H2' as (gg,(L1,(L2,L3))). +absurd (true = false); try discriminate. +rewrite <- K3. +apply trans_eq with (negb (Z.even (Fnum gg))). +rewrite L3; easy. +apply sym_eq. +generalize (DN_UP_parity_generic beta fexp). +unfold DN_UP_parity_prop; intros T; apply (T x); clear T; try assumption... +rewrite <- L1; apply Rnd_DN_pt_unique with (generic_format beta fexp) x; try easy... +now apply round_DN_pt... +rewrite <- K1; apply Rnd_UP_pt_unique with (generic_format beta fexp) x; try easy... +now apply round_UP_pt... +apply Rnd_UP_pt_unique with format x; assumption. +Qed. + +Theorem Rnd_odd_pt_monotone : + round_pred_monotone (Rnd_odd_pt). +Proof with auto with typeclass_instances. +intros x y f g H1 H2 Hxy. +apply Rle_trans with (round beta fexp Zrnd_odd x). +right; apply Rnd_odd_pt_unique with x; try assumption. +apply round_odd_pt. +apply Rle_trans with (round beta fexp Zrnd_odd y). +apply round_le... +right; apply Rnd_odd_pt_unique with y; try assumption. +apply round_odd_pt. +Qed. + +End Fcore_rnd_odd. + +Section Odd_prop_aux. + +Variable beta : radix. +Hypothesis Even_beta: Z.even (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_mag with fexp; trivial; intros Hx2. +generalize (fexpe_fexp (mag beta x)). +omega. +Qed. + + + +Lemma exists_even_fexp_lt: forall (c:Z->Z), forall (x:R), + (exists f:float beta, F2R f = x /\ (c (mag beta x) < Fexp f)%Z) -> + exists f:float beta, F2R f =x /\ canonical beta c f /\ Z.even (Fnum f) = true. +Proof with auto with typeclass_instances. +intros c x (g,(Hg1,Hg2)). +exists (Float beta + (Fnum g*Z.pow (radix_val beta) (Fexp g - c (mag beta x))) + (c (mag beta x))). +assert (F2R (Float beta + (Fnum g*Z.pow (radix_val beta) (Fexp g - c (mag beta x))) + (c (mag beta x))) = x). +unfold F2R; simpl. +rewrite mult_IZR, IZR_Zpower. +rewrite Rmult_assoc, <- bpow_plus. +rewrite <- Hg1; unfold F2R. +apply f_equal, f_equal. +ring. +omega. +split; trivial. +split. +unfold canonical, cexp. +now rewrite H. +simpl. +rewrite Z.even_mul. +rewrite Z.even_pow. +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: canonical beta fexp d. +Hypothesis Hu: Rnd_UP_pt (generic_format beta fexp) x (F2R u). +Hypothesis Cu: canonical 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_unique with (generic_format beta fexp) x... +apply round_DN_pt... +Qed. + + +Lemma u_eq: F2R u= round beta fexp Zceil x. +Proof with auto with typeclass_instances. +apply Rnd_UP_pt_unique 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 mag_d: (0< F2R d)%R -> + (mag beta (F2R d) = mag beta x :>Z). +Proof with auto with typeclass_instances. +intros Y. +rewrite d_eq; apply mag_DN... +now rewrite <- d_eq. +Qed. + + +Lemma Fexp_d: (0 < F2R d)%R -> Fexp d =fexp (mag beta x). +Proof with auto with typeclass_instances. +intros Y. +now rewrite Cd, <- mag_d. +Qed. + + + +Lemma format_bpow_x: (0 < F2R d)%R + -> generic_format beta fexp (bpow (mag beta x)). +Proof with auto with typeclass_instances. +intros Y. +apply generic_format_bpow. +apply valid_exp. +rewrite <- Fexp_d; trivial. +apply Z.lt_le_trans with (mag beta (F2R d))%Z. +rewrite Cd; apply mag_generic_gt... +now apply Rgt_not_eq. +apply Hd. +apply mag_le; trivial. +apply Hd. +Qed. + + +Lemma format_bpow_d: (0 < F2R d)%R -> + generic_format beta fexp (bpow (mag beta (F2R d))). +Proof with auto with typeclass_instances. +intros Y; apply generic_format_bpow. +apply valid_exp. +apply mag_generic_gt... +now apply Rgt_not_eq. +now apply generic_format_canonical. +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 mag_m: (0 < F2R d)%R -> (mag beta m =mag beta (F2R d) :>Z). +Proof with auto with typeclass_instances. +intros dPos; apply mag_unique_pos. +split. +apply Rle_trans with (F2R d). +destruct (mag 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 mag_generic_gt... +now apply Rgt_not_eq. +now apply generic_format_canonical. +case (Rle_or_lt x (bpow (mag beta (F2R d)))); trivial; intros Z. +absurd ((bpow (mag beta (F2R d)) <= (F2R d)))%R. +apply Rlt_not_le. +destruct (mag 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 mag_generic_gt... +now apply Rgt_not_eq. +now apply generic_format_canonical. +now left. +replace m with (F2R d). +destruct (mag 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 mag_m_0: (0 = F2R d)%R + -> (mag beta m =mag beta (F2R u)-1:>Z)%Z. +Proof with auto with typeclass_instances. +intros Y. +apply mag_unique_pos. +unfold m; rewrite <- Y, Rplus_0_l. +rewrite u_eq. +destruct (mag beta x) as (e,He). +rewrite Rabs_pos_eq in He by now apply Rlt_le. +rewrite round_UP_small_pos with (ex:=e). +rewrite mag_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 IZR_le. +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 (mag beta x) - 1)%Z. +Proof with auto with typeclass_instances. +intros Y. +specialize (Zeven_ex (radix_val beta)); rewrite Even_beta. +intros (b, Hb); rewrite Zplus_0_r in Hb. +destruct u'_eq as (u', (Hu'1,Hu'2)); trivial. +exists (Fmult (Float beta b (-1)) (Fplus d u'))%R. +split. +rewrite F2R_mult, F2R_plus, Hu'1. +unfold m; rewrite Rmult_comm. +unfold Rdiv; apply f_equal. +unfold F2R; simpl; unfold Z.pow_pos; simpl. +rewrite Zmult_1_r, Hb, mult_IZR. +simpl; field. +apply Rgt_not_eq, Rmult_lt_reg_l with (1 := Rlt_0_2). +rewrite Rmult_0_r, <- (mult_IZR 2), <-Hb. +apply radix_pos. +apply trans_eq with (-1+Fexp (Fplus d u'))%Z. +unfold Fmult. +destruct (Fplus 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 (mag beta (F2R u)) -1)%Z. +Proof with auto with typeclass_instances. +intros Y. +specialize (Zeven_ex (radix_val beta)); rewrite Even_beta. +intros (b, Hb); rewrite Zplus_0_r in Hb. +exists (Fmult (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, mult_IZR. +simpl; field. +apply Rgt_not_eq, Rmult_lt_reg_l with (1 := Rlt_0_2). +rewrite Rmult_0_r, <- (mult_IZR 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 (mag beta (F2R u)-1) < fexp (mag beta (F2R u))+1)%Z. +Proof with auto with typeclass_instances. +intros Y. +assert ((fexp (mag beta (F2R u) - 1) <= fexp (mag beta (F2R u))))%Z. +2: omega. +destruct (mag 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 mag_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. +Proof. +case (d_ge_0); intros Y. +(* *) +destruct m_eq as (g,(Hg1,Hg2)); trivial. +apply generic_format_F2R' with g. +now apply sym_eq. +intros H; unfold cexp; rewrite Hg2. +rewrite mag_m; trivial. +rewrite <- Fexp_d; trivial. +rewrite Cd. +unfold cexp. +generalize (fexpe_fexp (mag beta (F2R d))). +omega. +(* *) +destruct m_eq_0 as (g,(Hg1,Hg2)); trivial. +apply generic_format_F2R' with g. +assumption. +intros H; unfold cexp; rewrite Hg2. +rewrite mag_m_0; try assumption. +apply Z.le_trans with (1:=fexpe_fexp _). +generalize (fexp_m_eq_0 Y). +omega. +Qed. + + + +Lemma Zm: + exists g : float beta, F2R g = m /\ canonical beta fexpe g /\ Z.even (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 mag_m; trivial. +rewrite <- Fexp_d; trivial. +rewrite Cd. +unfold cexp. +generalize (fexpe_fexp (mag beta (F2R d))). +omega. +(* *) +destruct m_eq_0 as (g,(Hg1,Hg2)); trivial. +apply exists_even_fexp_lt. +exists g; split; trivial. +rewrite Hg2. +rewrite mag_m_0; trivial. +apply Z.le_lt_trans with (1:=fexpe_fexp _). +generalize (fexp_m_eq_0 Y). +omega. +Qed. + + +Lemma DN_odd_d_aux : + forall z, (F2R d <= z < F2R u)%R -> + Rnd_DN_pt (generic_format beta fexp) z (F2R d). +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 ; elim (Rlt_irrefl z). +apply Rlt_le_trans with (1:=proj2 Hz1), Rle_trans with (1:=Y). +apply round_DN_pt... +Qed. + +Lemma UP_odd_d_aux : + forall z, (F2R d < z <= F2R u)%R -> + Rnd_UP_pt (generic_format beta fexp) z (F2R u). +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 ; elim (Rlt_irrefl z). +apply Rle_lt_trans with (2:=proj1 Hz1), Rle_trans with (2:=Y). +apply round_UP_pt... +intros Y; apply Rle_antisym; trivial. +apply round_UP_pt... +apply Hu. +apply Hz1. +Qed. + + +Lemma round_N_odd_pos : + round beta fexp (Znearest choice) (round beta fexpe Zrnd_odd x) = + round beta fexp (Znearest choice) x. +Proof with auto with typeclass_instances. +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 canonical_unique 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 cexp. +apply Z.le_lt_trans with (1:=fexpe_fexp _). +omega. +absurd (true=false). +discriminate. +rewrite <- Hk3, <- Hk'3. +apply f_equal, f_equal. +apply canonical_unique 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: Z.even (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 round_N_odd : + forall x, + round beta fexp (Znearest choice) (round beta fexpe Zrnd_odd x) = + round beta fexp (Znearest choice) x. +Proof with auto with typeclass_instances. +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 (canonical_generic_format beta fexp (round beta fexp Zfloor (-x))) as (d,(Hd1,Hd2)). +apply generic_format_round... +destruct (canonical_generic_format beta fexp (round beta fexp Zceil (-x))) as (u,(Hu1,Hu2)). +apply generic_format_round... +apply round_N_odd_pos with d u... +rewrite <- Hd1; apply round_DN_pt... +rewrite <- Hu1; apply round_UP_pt... +auto with real. +(* . *) +rewrite H; repeat rewrite round_0... +(* . *) +destruct (canonical_generic_format beta fexp (round beta fexp Zfloor x)) as (d,(Hd1,Hd2)). +apply generic_format_round... +destruct (canonical_generic_format beta fexp (round beta fexp Zceil x)) as (u,(Hu1,Hu2)). +apply generic_format_round... +apply round_N_odd_pos with d u... +rewrite <- Hd1; apply round_DN_pt... +rewrite <- Hu1; apply round_UP_pt... +Qed. + +End Odd_prop. + + +Section Odd_propbis. + +Variable beta : radix. +Hypothesis Even_beta: Z.even (radix_val beta)=true. + +Variable emin prec:Z. +Variable choice:Z->bool. + +Hypothesis prec_gt_1: (1 < prec)%Z. + + +Notation format := (generic_format beta (FLT_exp emin prec)). +Notation round_flt :=(round beta (FLT_exp emin prec) (Znearest choice)). +Notation cexp_flt := (cexp beta (FLT_exp emin prec)). +Notation fexpe k := (FLT_exp (emin-k) (prec+k)). + + + +Lemma Zrnd_odd_plus': forall x y, + (exists n:Z, exists e:Z, (x = IZR n*bpow beta e)%R /\ (1 <= e)%Z) -> + (IZR (Zrnd_odd (x+y)) = x+IZR (Zrnd_odd y))%R. +Proof. +intros x y (n,(e,(H1,H2))). +apply Zrnd_odd_plus. +rewrite H1. +rewrite <- IZR_Zpower. +2: auto with zarith. +now rewrite <- mult_IZR, Zfloor_IZR. +rewrite H1, <- IZR_Zpower. +2: auto with zarith. +rewrite <- mult_IZR, Zfloor_IZR. +rewrite Z.even_mul. +rewrite Z.even_pow. +2: auto with zarith. +rewrite Even_beta. +apply Bool.orb_true_iff; now right. +Qed. + + + +Theorem mag_round_odd: forall (x:R), + (emin < mag beta x)%Z -> + (mag_val beta _ (mag beta (round beta (FLT_exp emin prec) Zrnd_odd x)) + = mag_val beta x (mag beta x))%Z. +Proof with auto with typeclass_instances. +intros x. +assert (T:Prec_gt_0 prec). +unfold Prec_gt_0; auto with zarith. +case (Req_dec x 0); intros Zx. +intros _; rewrite Zx, round_0... +destruct (mag beta x) as (e,He); simpl; intros H. +apply mag_unique; split. +apply abs_round_ge_generic... +apply FLT_format_bpow... +auto with zarith. +now apply He. +assert (V: + (Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) <= bpow beta e)%R). +apply abs_round_le_generic... +apply FLT_format_bpow... +auto with zarith. +left; now apply He. +case V; try easy; intros K. +assert (H0:Rnd_odd_pt beta (FLT_exp emin prec) x (round beta (FLT_exp emin prec) Zrnd_odd x)). +apply round_odd_pt... +destruct H0 as (_,HH); destruct HH as [H0|(H0,(g,(Hg1,(Hg2,Hg3))))]. +absurd (Rabs x < bpow beta e)%R. +apply Rle_not_lt; right. +now rewrite <- H0,K. +now apply He. +pose (gg:=Float beta (Zpower beta (e-FLT_exp emin prec (e+1))) (FLT_exp emin prec (e+1))). +assert (Y1: F2R gg = bpow beta e). +unfold F2R; simpl. +rewrite IZR_Zpower. +rewrite <- bpow_plus. +f_equal; ring. +assert (FLT_exp emin prec (e+1) <= e)%Z; [idtac|auto with zarith]. +unfold FLT_exp. +apply Z.max_case_strong; auto with zarith. +assert (Y2: canonical beta (FLT_exp emin prec) gg). +unfold canonical; rewrite Y1; unfold gg; simpl. +unfold cexp; now rewrite mag_bpow. +assert (Y3: Fnum gg = Z.abs (Fnum g)). +apply trans_eq with (Fnum (Fabs g)). +2: destruct g; unfold Fabs; now simpl. +f_equal. +apply canonical_unique with (FLT_exp emin prec); try assumption. +destruct g; unfold Fabs; apply canonical_abs; easy. +now rewrite Y1, F2R_abs, <- Hg1,K. +assert (Y4: Z.even (Fnum gg) = true). +unfold gg; simpl. +rewrite Z.even_pow; try assumption. +assert (FLT_exp emin prec (e+1) < e)%Z; [idtac|auto with zarith]. +unfold FLT_exp. +apply Z.max_case_strong; auto with zarith. +absurd (true = false). +discriminate. +rewrite <- Hg3. +rewrite <- Zeven_abs. +now rewrite <- Y3. +Qed. + +Theorem fexp_round_odd: forall (x:R), + (cexp_flt (round beta (FLT_exp emin prec) Zrnd_odd x) + = cexp_flt x)%Z. +Proof with auto with typeclass_instances. +intros x. +assert (G0:Valid_exp (FLT_exp emin prec)). +apply FLT_exp_valid; unfold Prec_gt_0; auto with zarith. +case (Req_dec x 0); intros Zx. +rewrite Zx, round_0... +case (Zle_or_lt (mag beta x) emin). +unfold cexp; destruct (mag beta x) as (e,He); simpl. +intros H; unfold FLT_exp at 4. +rewrite Z.max_r. +2: auto with zarith. +apply Z.max_r. +assert (G: Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) = bpow beta emin). +assert (G1: (Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) <= bpow beta emin)%R). +apply abs_round_le_generic... +apply generic_format_bpow'... +unfold FLT_exp; rewrite Z.max_r; auto with zarith. +left; apply Rlt_le_trans with (bpow beta e). +now apply He. +now apply bpow_le. +assert (G2: (0 <= Rabs (round beta (FLT_exp emin prec) Zrnd_odd x))%R). +apply Rabs_pos. +assert (G3: (Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) <> 0)%R). +assert (H0:Rnd_odd_pt beta (FLT_exp emin prec) x + (round beta (FLT_exp emin prec) Zrnd_odd x)). +apply round_odd_pt... +destruct H0 as (_,H0); destruct H0 as [H0|(_,(g,(Hg1,(Hg2,Hg3))))]. +apply Rgt_not_eq; rewrite H0. +apply Rlt_le_trans with (bpow beta (e-1)). +apply bpow_gt_0. +now apply He. +rewrite Hg1; intros K. +contradict Hg3. +replace (Fnum g) with 0%Z. +easy. +case (Z.eq_dec (Fnum g) Z0); intros W; try easy. +contradict K. +apply Rabs_no_R0. +now apply F2R_neq_0. +apply Rle_antisym; try assumption. +apply Rle_trans with (succ beta (FLT_exp emin prec) 0). +right; rewrite succ_0. +rewrite ulp_FLT_small; try easy. +unfold Prec_gt_0; auto with zarith. +rewrite Rabs_R0; apply bpow_gt_0. +apply succ_le_lt... +apply generic_format_0. +apply generic_format_abs; apply generic_format_round... +case G2; [easy|intros; now contradict G3]. +rewrite <- mag_abs. +rewrite G, mag_bpow; auto with zarith. +intros H; unfold cexp. +now rewrite mag_round_odd. +Qed. + + + + +End Odd_propbis. + + diff --git a/flocq/Prop/Sterbenz.v b/flocq/Prop/Sterbenz.v new file mode 100644 index 00000000..746b7026 --- /dev/null +++ b/flocq/Prop/Sterbenz.v @@ -0,0 +1,173 @@ +(** +This file is part of the Flocq formalization of floating-point +arithmetic in Coq: http://flocq.gforge.inria.fr/ + +Copyright (C) 2010-2018 Sylvie Boldo +#
# +Copyright (C) 2010-2018 Guillaume Melquiond + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +COPYING file for more details. +*) + +(** * Sterbenz conditions for exact subtraction *) + +Require Import Raux Defs Generic_fmt Operations. + +Section Fprop_Sterbenz. + +Variable beta : radix. +Notation bpow e := (bpow beta e). + +Variable fexp : Z -> Z. +Context { valid_exp : Valid_exp fexp }. +Context { monotone_exp : Monotone_exp fexp }. +Notation format := (generic_format beta fexp). + +Theorem generic_format_plus : + forall x y, + format x -> format y -> + (Rabs (x + y) <= bpow (Z.min (mag beta x) (mag beta y)))%R -> + format (x + y)%R. +Proof. +intros x y Fx Fy Hxy. +destruct (Req_dec (x + y) 0) as [Zxy|Zxy]. +rewrite Zxy. +apply generic_format_0. +destruct (Req_dec x R0) as [Zx|Zx]. +now rewrite Zx, Rplus_0_l. +destruct (Req_dec y R0) as [Zy|Zy]. +now rewrite Zy, Rplus_0_r. +destruct Hxy as [Hxy|Hxy]. +revert Hxy. +destruct (mag beta x) as (ex, Ex). simpl. +specialize (Ex Zx). +destruct (mag beta y) as (ey, Ey). simpl. +specialize (Ey Zy). +intros Hxy. +set (fx := Float beta (Ztrunc (scaled_mantissa beta fexp x)) (fexp ex)). +assert (Hx: x = F2R fx). +rewrite Fx at 1. +unfold cexp. +now rewrite mag_unique with (1 := Ex). +set (fy := Float beta (Ztrunc (scaled_mantissa beta fexp y)) (fexp ey)). +assert (Hy: y = F2R fy). +rewrite Fy at 1. +unfold cexp. +now rewrite mag_unique with (1 := Ey). +rewrite Hx, Hy. +rewrite <- F2R_plus. +apply generic_format_F2R. +intros _. +case_eq (Fplus fx fy). +intros mxy exy Pxy. +rewrite <- Pxy, F2R_plus, <- Hx, <- Hy. +unfold cexp. +replace exy with (fexp (Z.min ex ey)). +apply monotone_exp. +now apply mag_le_bpow. +replace exy with (Fexp (Fplus fx fy)) by exact (f_equal Fexp Pxy). +rewrite Fexp_Fplus. +simpl. clear -monotone_exp. +apply sym_eq. +destruct (Zmin_spec ex ey) as [(H1,H2)|(H1,H2)] ; rewrite H2. +apply Z.min_l. +now apply monotone_exp. +apply Z.min_r. +apply monotone_exp. +apply Zlt_le_weak. +now apply Z.gt_lt. +apply generic_format_abs_inv. +rewrite Hxy. +apply generic_format_bpow. +apply valid_exp. +case (Zmin_spec (mag beta x) (mag beta y)); intros (H1,H2); + rewrite H2; now apply mag_generic_gt. +Qed. + +Theorem generic_format_plus_weak : + forall x y, + format x -> format y -> + (Rabs (x + y) <= Rmin (Rabs x) (Rabs y))%R -> + format (x + y)%R. +Proof. +intros x y Fx Fy Hxy. +destruct (Req_dec x R0) as [Zx|Zx]. +now rewrite Zx, Rplus_0_l. +destruct (Req_dec y R0) as [Zy|Zy]. +now rewrite Zy, Rplus_0_r. +apply generic_format_plus ; try assumption. +apply Rle_trans with (1 := Hxy). +unfold Rmin. +destruct (Rle_dec (Rabs x) (Rabs y)) as [Hxy'|Hxy']. +rewrite Z.min_l. +destruct (mag beta x) as (ex, Hx). +apply Rlt_le; now apply Hx. +now apply mag_le_abs. +rewrite Z.min_r. +destruct (mag beta y) as (ex, Hy). +apply Rlt_le; now apply Hy. +apply mag_le_abs. +exact Zy. +apply Rlt_le. +now apply Rnot_le_lt. +Qed. + +Lemma sterbenz_aux : + forall x y, format x -> format y -> + (y <= x <= 2 * y)%R -> + format (x - y)%R. +Proof. +intros x y Hx Hy (Hxy1, Hxy2). +unfold Rminus. +apply generic_format_plus_weak. +exact Hx. +now apply generic_format_opp. +rewrite Rabs_pos_eq. +rewrite Rabs_Ropp. +rewrite Rmin_comm. +assert (Hy0: (0 <= y)%R). +apply Rplus_le_reg_r with y. +apply Rle_trans with x. +now rewrite Rplus_0_l. +now replace (y + y)%R with (2 * y)%R by ring. +rewrite Rabs_pos_eq with (1 := Hy0). +rewrite Rabs_pos_eq. +unfold Rmin. +destruct (Rle_dec y x) as [Hyx|Hyx]. +apply Rplus_le_reg_r with y. +now ring_simplify. +now elim Hyx. +now apply Rle_trans with y. +now apply Rle_0_minus. +Qed. + +Theorem sterbenz : + forall x y, format x -> format y -> + (y / 2 <= x <= 2 * y)%R -> + format (x - y)%R. +Proof. +intros x y Hx Hy (Hxy1, Hxy2). +destruct (Rle_or_lt x y) as [Hxy|Hxy]. +rewrite <- Ropp_minus_distr. +apply generic_format_opp. +apply sterbenz_aux ; try easy. +split. +exact Hxy. +apply Rcompare_not_Lt_inv. +rewrite <- Rcompare_half_r. +now apply Rcompare_not_Lt. +apply sterbenz_aux ; try easy. +split. +now apply Rlt_le. +exact Hxy2. +Qed. + +End Fprop_Sterbenz. -- cgit