Skip to content
GitLab
Commit 1d5a4239 authored by BOLDO Sylvie's avatar BOLDO Sylvie
Browse files

New definitions for ulp, pred, succ. And all the corresponding modifications.

parent 713ce4fa
Expand all Hide whitespace changes
Inline Side-by-side
examples/Average.v
View file @ 1d5a4239
This diff is collapsed.
examples/Double_round_beta_odd.v
View file @ 1d5a4239
......@@ -111,7 +111,7 @@ induction n.
* change 0 with (Z2R 0); apply Z2R_le; omega.
* now apply bpow_ge_0.
+ rewrite <- Hlx'.
apply (ln_beta_succ beta (fun e => (e - (ln_beta x' - ex2'))%Z));
apply (ln_beta_plus_eps beta (fun e => (e - (ln_beta x' - ex2'))%Z));
[| |split].
* exact Px'.
* unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl.
......@@ -120,7 +120,8 @@ induction n.
now apply Rmult_le_pos; [apply Rlt_le|apply bpow_ge_0].
* apply Rmult_le_pos; [|now apply bpow_ge_0].
change 0 with (Z2R 0); apply Z2R_le; omega.
* unfold u, ulp, ex2', canonic_exp; bpow_simplify.
* rewrite ulp_neq_0;[idtac| now apply Rgt_not_eq].
unfold u, ex2', canonic_exp; bpow_simplify.
rewrite Zplus_comm; rewrite bpow_plus.
apply Rmult_lt_compat_r; [now apply bpow_gt_0|].
rewrite bpow_1.
......@@ -203,6 +204,8 @@ Lemma neq_midpoint_beta_odd_aux1 :
double_round_eq beta fexp1 fexp2 choice1 choice2 x.
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hx.
unfold midp in Hx.
rewrite 2!ulp_neq_0 in Hx; try now apply Rgt_not_eq.
unfold double_round_eq.
set (ex1 := fexp1 (ln_beta x)).
set (ex2 := fexp2 (ln_beta x)).
......@@ -246,8 +249,7 @@ assert (Hrx2' : rx1 <= rx2 < rx1 + / 2 * bpow ex1).
apply Rplus_le_compat_l.
apply Rmult_le_compat_l; [lra|].
now apply bpow_le.
- change (_ + _) with (midp beta fexp1 x).
apply (Rle_lt_trans _ _ _ (proj1 Hx') (proj2 Hx)). }
- apply (Rle_lt_trans _ _ _ (proj1 Hx') (proj2 Hx)). }
assert (Hrx2r : rx2 = round beta fexp2 Zfloor x).
{ unfold round, F2R, scaled_mantissa, canonic_exp; simpl.
fold ex2; rewrite Hrx2.
......@@ -317,6 +319,8 @@ Lemma neq_midpoint_beta_odd_aux2 :
double_round_eq beta fexp1 fexp2 choice1 choice2 x.
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hx.
unfold midp in Hx.
rewrite 2!ulp_neq_0 in Hx; try now apply Rgt_not_eq.
unfold double_round_eq.
set (ex1 := fexp1 (ln_beta x)).
set (ex2 := fexp2 (ln_beta x)).
......@@ -341,11 +345,12 @@ assert (NF1x : ~ generic_format beta fexp1 x).
{ now intro H; apply NF2x, (generic_inclusion_ln_beta _ fexp1). }
assert (Hrx1c : rx1c = rx1 + ulp beta fexp1 x).
{ now apply ulp_DN_UP. }
rewrite ulp_neq_0 in Hrx1c; try now apply Rgt_not_eq.
destruct (midpoint_beta_odd_remains rx1 Nnrx1 ex1 ex2 Hf2f1' Hrx1)
as (rx2,(Nnrx2, (Hrx2, Hrx12))).
set (rx2c := rx2 + ulp beta fexp2 x).
set (rx2c := rx2 + bpow (fexp2 (ln_beta x))).
assert (Hx' : rx2c - / 2 * bpow ex2 < x <= rx2c).
{ unfold rx2c, ulp, canonic_exp; fold ex1; fold ex2; split.
{ unfold rx2c, canonic_exp; fold ex1; fold ex2; split.
- replace (_ - _) with (rx2 + / 2 * bpow ex2) by field.
rewrite <- Hrx12; apply Hx.
- replace (_ + _) with (rx2 + / 2 * bpow ex2 + / 2 * bpow ex2) by field.
......@@ -379,7 +384,6 @@ assert (Hrx2' : rx1c - / 2 * bpow ex1 < rx2c <= rx1c).
{ split.
- rewrite Hrx1c; unfold ulp, canonic_exp; fold ex1.
replace (_ - _) with (rx1 + / 2 * bpow ex1) by field.
change (_ + _) with (midp beta fexp1 x).
apply (Rlt_le_trans _ _ _ (proj1 Hx) (proj2 Hx')).
- apply (Rplus_le_reg_r (- / 2 * bpow ex2)).
unfold rx2c, ulp, canonic_exp; fold ex2.
......@@ -471,7 +475,6 @@ assert (Hl2 : ln_beta rx2c = ln_beta x :> Z).
replace (_ + _) with (rx2 + bpow ex2) by field].
split.
- rewrite <- Rplus_assoc.
change (_ + _) with (midp beta fexp1 x + / 2 * ulp beta fexp2 x).
apply Rle_trans with x; [|now apply Hx].
apply Rge_le; rewrite <- (Rabs_right x) at 1; [|now apply Rle_ge, Rlt_le];
apply Rle_ge; destruct (ln_beta x) as (ex,Hex); simpl; apply Hex.
......@@ -481,7 +484,9 @@ assert (Hl2 : ln_beta rx2c = ln_beta x :> Z).
rewrite <- (Rmult_1_l (bpow ex1)) at 2.
replace (1 * bpow ex1) with (/ 2 * bpow ex1 + / 2 * bpow ex1) by field.
now apply Rplus_lt_compat_l, Rmult_lt_compat_l; [lra|apply bpow_lt].
+ unfold ex1; rewrite <- Hl1; apply succ_le_bpow; [exact Prx1| |].
+ unfold ex1; rewrite <- Hl1.
fold (canonic_exp beta fexp1 rx1); rewrite <- ulp_neq_0; try now apply Rgt_not_eq.
apply succ_le_bpow; [exact Prx1| |].
* now apply generic_format_round; [|apply valid_rnd_DN].
* destruct (ln_beta rx1) as (erx1, Herx1); simpl.
rewrite <- (Rabs_right rx1) at 1; [|now apply Rle_ge, Rlt_le].
......@@ -505,7 +510,7 @@ apply Rabs_lt; split.
- apply (Rmult_lt_reg_r (bpow ex1)); [now apply bpow_gt_0|].
rewrite Rmult_minus_distr_r; bpow_simplify.
rewrite Z2R_plus, Rmult_plus_distr_r; simpl; rewrite Rmult_1_l.
change (Z2R _ * _ + _) with (rx1 + ulp beta fexp1 x).
change (Z2R _ * _ + _) with (rx1 + bpow (canonic_exp beta fexp1 x)).
rewrite <- Hrx1c; lra.
Qed.
......@@ -592,6 +597,7 @@ destruct (Zle_or_lt (fexp1 ex) (fexp2 ex)) as [H2|H2].
(* r2 <> 0 *)
assert (B1 : Rabs (r2 - x) <= / 2 * ulp beta fexp2 x);
[now apply ulp_half_error|].
rewrite ulp_neq_0 in B1; try now apply Rgt_not_eq.
unfold round, F2R, scaled_mantissa, canonic_exp; simpl.
apply (Rmult_eq_reg_r (bpow (- fexp1 (ln_beta r2))));
[|now apply Rgt_not_eq, bpow_gt_0].
......@@ -603,7 +609,7 @@ destruct (Zle_or_lt (fexp1 ex) (fexp2 ex)) as [H2|H2].
bpow_simplify.
replace r2 with (r2 - x + x) by ring.
apply (Rle_lt_trans _ _ _ (Rabs_triang _ _)).
apply Rlt_le_trans with (/ 2 * ulp beta fexp2 x + bpow ex);
apply Rlt_le_trans with (/ 2 * bpow (canonic_exp beta fexp2 x) + bpow ex);
[now apply Rplus_le_lt_compat;
[|rewrite Rabs_right; [|apply Rle_ge, Rlt_le]]|].
replace (_ - _ + _) with r2 by ring.
......@@ -617,14 +623,14 @@ destruct (Zle_or_lt (fexp1 ex) (fexp2 ex)) as [H2|H2].
{ apply (ln_beta_le_bpow _ _ _ Nzr2).
replace r2 with (r2 - x + x) by ring.
apply (Rle_lt_trans _ _ _ (Rabs_triang _ _)).
apply Rlt_le_trans with (/ 2 * ulp beta fexp2 x + bpow ex);
apply Rlt_le_trans with (/ 2 * bpow (canonic_exp beta fexp2 x) + bpow ex);
[now apply Rplus_le_lt_compat;
[|rewrite Rabs_right; [|apply Rle_ge, Rlt_le]]|].
apply Rle_trans with (2 * bpow (fexp1 ex - 1)).
- rewrite Rmult_plus_distr_r, Rmult_1_l.
apply Rplus_le_compat; [|now apply bpow_le; omega].
apply Rle_trans with (bpow (fexp2 ex)); [|now apply bpow_le; omega].
rewrite <- (Rmult_1_l (bpow _)); unfold ulp, canonic_exp.
rewrite <- (Rmult_1_l (bpow (fexp2 _))); unfold canonic_exp.
rewrite Hex'; apply Rmult_le_compat_r; [apply bpow_ge_0|lra].
- rewrite <- (Rmult_1_l (bpow (fexp1 _))).
unfold Zminus; rewrite Zplus_comm, bpow_plus, <- Rmult_assoc.
......@@ -657,14 +663,16 @@ destruct (Zle_or_lt (fexp1 ex) (fexp2 ex)) as [H2|H2].
now rewrite Hbeta'.
Qed.
(* argh: was 0 <= Z2R mx. This becomes incorrect in FLX with the new ulp. *)
Lemma float_neq_midpoint_beta_odd :
forall (mx ex : Z),
forall (fexp : Z -> Z),
0 <= Z2R mx ->
0 < Z2R mx ->
Z2R mx * bpow ex <> midp beta fexp (Z2R mx * bpow ex).
Proof.
intros mx ex fexp Hmx.
unfold midp, round, ulp, F2R, scaled_mantissa, canonic_exp; simpl.
unfold midp; rewrite ulp_neq_0.
unfold round, F2R, scaled_mantissa, canonic_exp; simpl.
set (exf := fexp (ln_beta (Z2R mx * bpow ex))).
set (mxf := Zfloor (Z2R mx * bpow ex * bpow (- exf))).
destruct (Zle_or_lt exf ex) as [Hm|Hm].
......@@ -695,7 +703,7 @@ destruct (Zle_or_lt exf ex) as [Hm|Hm].
change 0 with (Z2R 0); apply Z2R_le; unfold mxf.
apply Zfloor_lub; simpl.
apply Rmult_le_pos; [|now apply bpow_ge_0].
now apply Rmult_le_pos; [|apply bpow_ge_0]. }
now apply Rmult_le_pos; [now left|apply bpow_ge_0]. }
destruct (midpoint_beta_odd_remains _ Nnmxy _ _ Hm')
as (x',(_,(Hx',Hxx'))).
{ now bpow_simplify; rewrite Zfloor_Z2R. }
......@@ -718,6 +726,9 @@ destruct (Zle_or_lt exf ex) as [Hm|Hm].
apply (Zodd_not_Zeven 1); [now simpl|].
rewrite <- H.
now apply Zeven_mult_Zeven_l.
- apply Rmult_integral_contrapositive_currified.
now apply Rgt_not_eq, Rlt_gt.
apply Rgt_not_eq, bpow_gt_0.
Qed.
Section Double_round_mult_beta_odd.
......@@ -750,14 +761,14 @@ apply neq_midpoint_beta_odd; try assumption.
with (Z2R mx * Z2R my * bpow (fexp1 ex) * bpow (fexp1 ey)) by ring.
rewrite <- Z2R_mult, Rmult_assoc, <- bpow_plus.
apply float_neq_midpoint_beta_odd.
apply (Rmult_le_reg_r (bpow (fexp1 ex))); [now apply bpow_gt_0|].
apply (Rmult_le_reg_r (bpow (fexp1 ey))); [now apply bpow_gt_0|].
apply (Rmult_lt_reg_r (bpow (fexp1 ex))); [now apply bpow_gt_0|].
apply (Rmult_lt_reg_r (bpow (fexp1 ey))); [now apply bpow_gt_0|].
do 2 rewrite Rmult_0_l.
rewrite Z2R_mult;
replace (_ * _)
with (Z2R mx * bpow (fexp1 ex) * (Z2R my * bpow (fexp1 ey))) by ring.
rewrite <- Fx, <- Fy.
now apply Rmult_le_pos; apply Rlt_le.
now apply Rmult_lt_0_compat.
Qed.
Lemma double_round_mult_beta_odd_aux2 :
......@@ -951,21 +962,21 @@ apply neq_midpoint_beta_odd; try assumption.
rewrite <- Z2R_Zpower; [|now apply Zle_minus_le_0].
rewrite <- Z2R_mult, <- Z2R_plus.
apply float_neq_midpoint_beta_odd.
apply (Rmult_le_reg_r (bpow (fexp1 ex))); [now apply bpow_gt_0|].
apply (Rmult_lt_reg_r (bpow (fexp1 ex))); [now apply bpow_gt_0|].
rewrite Z2R_plus, Z2R_mult, Z2R_Zpower; [|now apply Zle_minus_le_0].
rewrite Rmult_0_l, Rmult_plus_distr_r; bpow_simplify.
rewrite <- Fx, <- Fy.
now apply Rplus_le_le_0_compat; apply Rlt_le.
now apply Rplus_lt_0_compat.
+ replace (fexp1 ex) with (fexp1 ex - fexp1 ey + fexp1 ey)%Z by ring.
rewrite bpow_plus, <- Rmult_assoc, <- Rmult_plus_distr_r.
rewrite <- Z2R_Zpower; [|omega].
rewrite <- Z2R_mult, <- Z2R_plus.
apply float_neq_midpoint_beta_odd.
apply (Rmult_le_reg_r (bpow (fexp1 ey))); [now apply bpow_gt_0|].
apply (Rmult_lt_reg_r (bpow (fexp1 ey))); [now apply bpow_gt_0|].
rewrite Z2R_plus, Z2R_mult, Z2R_Zpower; [|omega].
rewrite Rmult_0_l, Rmult_plus_distr_r; bpow_simplify.
rewrite <- Fx, <- Fy.
now apply Rplus_le_le_0_compat; apply Rlt_le.
now apply Rplus_lt_0_compat.
Qed.
Lemma double_round_plus_beta_odd_aux2 :
......@@ -989,18 +1000,22 @@ destruct (Req_dec x 0) as [Zx|Nzx]; destruct (Req_dec y 0) as [Zy|Nzy].
apply (neq_midpoint_beta_odd _ _ Vfexp1 Vfexp2 _ _ _ Py (Hfexp _)).
rewrite Fy; unfold F2R, scaled_mantissa; simpl.
apply float_neq_midpoint_beta_odd.
change 0 with (Z2R 0); apply Z2R_le.
rewrite <- (Ztrunc_Z2R 0); apply Ztrunc_le; simpl.
now apply Rmult_le_pos; [apply Rlt_le|apply bpow_ge_0].
apply Rmult_lt_reg_r with (bpow (canonic_exp beta fexp1 y)).
apply bpow_gt_0.
rewrite Rmult_0_l.
apply Rlt_le_trans with (1:=Py).
right; rewrite Fy at 1; unfold F2R, scaled_mantissa; now simpl.
- (* 0 < x, y = 0 *)
assert (Px : 0 < x); [lra|].
rewrite Zy, Rplus_0_r.
apply (neq_midpoint_beta_odd _ _ Vfexp1 Vfexp2 _ _ _ Px (Hfexp _)).
rewrite Fx; unfold F2R, scaled_mantissa; simpl.
apply float_neq_midpoint_beta_odd.
change 0 with (Z2R 0); apply Z2R_le.
rewrite <- (Ztrunc_Z2R 0); apply Ztrunc_le; simpl.
now apply Rmult_le_pos; [apply Rlt_le|apply bpow_ge_0].
apply Rmult_lt_reg_r with (bpow (canonic_exp beta fexp1 x)).
apply bpow_gt_0.
rewrite Rmult_0_l.
apply Rlt_le_trans with (1:=Px).
right; rewrite Fx at 1; unfold F2R, scaled_mantissa; now simpl.
- (* 0 < x, 0 < y *)
assert (Px : 0 < x); [lra|].
assert (Py : 0 < y); [lra|].
......@@ -1037,21 +1052,21 @@ apply neq_midpoint_beta_odd; try assumption.
rewrite <- Z2R_Zpower; [|now apply Zle_minus_le_0].
rewrite <- Z2R_mult, <- Z2R_minus.
apply float_neq_midpoint_beta_odd.
apply (Rmult_le_reg_r (bpow (fexp1 ex))); [now apply bpow_gt_0|].
apply (Rmult_lt_reg_r (bpow (fexp1 ex))); [now apply bpow_gt_0|].
rewrite Z2R_minus, Z2R_mult, Z2R_Zpower; [|now apply Zle_minus_le_0].
rewrite Rmult_0_l, Rmult_minus_distr_r; bpow_simplify.
rewrite <- Fx, <- Fy.
now apply Rle_0_minus, Rlt_le.
now apply Rlt_Rminus.
+ replace (fexp1 ex) with (fexp1 ex - fexp1 ey + fexp1 ey)%Z by ring.
rewrite bpow_plus, <- Rmult_assoc, <- Rmult_minus_distr_r.
rewrite <- Z2R_Zpower; [|omega].
rewrite <- Z2R_mult, <- Z2R_minus.
apply float_neq_midpoint_beta_odd.
apply (Rmult_le_reg_r (bpow (fexp1 ey))); [now apply bpow_gt_0|].
apply (Rmult_lt_reg_r (bpow (fexp1 ey))); [now apply bpow_gt_0|].
rewrite Z2R_minus, Z2R_mult, Z2R_Zpower; [|omega].
rewrite Rmult_0_l, Rmult_minus_distr_r; bpow_simplify.
rewrite <- Fx, <- Fy.
now apply Rle_0_minus, Rlt_le.
now apply Rlt_Rminus.
Qed.
Lemma double_round_minus_beta_odd_aux2 :
......@@ -1077,18 +1092,20 @@ destruct (Req_dec x 0) as [Zx|Nzx]; destruct (Req_dec y 0) as [Zy|Nzy].
apply (neq_midpoint_beta_odd _ _ Vfexp1 Vfexp2 _ _ _ Py (Hfexp _)).
rewrite Fy; unfold F2R, scaled_mantissa; simpl.
apply float_neq_midpoint_beta_odd.
change 0 with (Z2R 0); apply Z2R_le.
rewrite <- (Ztrunc_Z2R 0); apply Ztrunc_le; simpl.
now apply Rmult_le_pos; [apply Rlt_le|apply bpow_ge_0].
apply Rmult_lt_reg_r with (bpow (canonic_exp beta fexp1 y)).
apply bpow_gt_0.
rewrite Rmult_0_l; apply Rlt_le_trans with (1:=Py).
right; rewrite Fy at 1; unfold F2R, scaled_mantissa; now simpl.
- (* 0 < x, y = 0 *)
assert (Px : 0 < x); [lra|].
unfold Rminus; rewrite Zy, Ropp_0, Rplus_0_r.
apply (neq_midpoint_beta_odd _ _ Vfexp1 Vfexp2 _ _ _ Px (Hfexp _)).
rewrite Fx; unfold F2R, scaled_mantissa; simpl.
apply float_neq_midpoint_beta_odd.
change 0 with (Z2R 0); apply Z2R_le.
rewrite <- (Ztrunc_Z2R 0); apply Ztrunc_le; simpl.
now apply Rmult_le_pos; [apply Rlt_le|apply bpow_ge_0].
apply Rmult_lt_reg_r with (bpow (canonic_exp beta fexp1 x)).
apply bpow_gt_0.
rewrite Rmult_0_l; apply Rlt_le_trans with (1:=Px).
right; rewrite Fx at 1; unfold F2R, scaled_mantissa; now simpl.
- (* 0 < x, 0 < y *)
assert (Px : 0 < x); [lra|].
assert (Py : 0 < y); [lra|].
......@@ -1305,14 +1322,15 @@ End Double_round_plus_beta_odd.
Section Double_round_sqrt_beta_odd.
(* argh: was forall x, but 0 may be a midpoint now *)
Lemma sqrt_neq_midpoint :
forall fexp : Z -> Z, Valid_exp fexp ->
forall x,
forall x, 0 < x ->
generic_format beta fexp x ->
sqrt x <> midp beta fexp (sqrt x).
Proof.
intros fexp Vfexp x Fx.
destruct (Rle_or_lt x 0) as [Npx|Px].
intros fexp Vfexp x Px Fx.
(*destruct (Rle_or_lt x 0) as [Npx|Px].
{ (* x <= 0 *)
rewrite (sqrt_neg _ Npx).
unfold midp; rewrite round_0; [|apply valid_rnd_DN]; rewrite Rplus_0_l.
......@@ -1320,12 +1338,14 @@ destruct (Rle_or_lt x 0) as [Npx|Px].
apply (Rmult_eq_compat_l 2) in H; field_simplify in H.
unfold Rdiv in H; rewrite Rinv_1 in H; do 2 rewrite Rmult_1_r in H.
apply eq_sym in H.
revert H; apply Rgt_not_eq; apply bpow_gt_0. }
revert H; apply Rgt_not_eq; apply bpow_gt_0. } *)
(* 0 < x *)
unfold midp.
set (r := round beta fexp Zfloor (sqrt x)).
revert Fx.
unfold generic_format, round, ulp, F2R, scaled_mantissa, canonic_exp; simpl.
rewrite ulp_neq_0.
2: now apply Rgt_not_eq, sqrt_lt_R0.
unfold generic_format, round, F2R, scaled_mantissa, canonic_exp; simpl.
set (m := Ztrunc (x * bpow (- fexp (ln_beta x)))).
intro Fx.
assert (Nnr : 0 <= r).
......@@ -1633,8 +1653,9 @@ Lemma double_round_eq_mid_beta_odd_rna_aux1 :
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 x Px Hf2 Hf1.
unfold midp.
rewrite ulp_neq_0; try now apply Rgt_not_eq.
set (rd := round beta fexp1 Zfloor x).
set (u := ulp beta fexp1 x).
set (u := bpow (fexp1 (ln_beta x))).
intro Xmid.
apply (Rplus_eq_compat_l (- rd)) in Xmid; ring_simplify in Xmid.
rewrite Rplus_comm in Xmid; fold (x - rd) in Xmid.
......@@ -1711,13 +1732,14 @@ destruct (Req_dec rd 0) as [Zrd|Nzrd].
omega. }
assert (Hl2 : ln_beta (x2 + / 2 * bpow (fexp2 (ln_beta x)))
= ln_beta x2 :> Z).
{ apply (ln_beta_succ beta fexp2); [| |split].
{ apply (ln_beta_plus_eps beta fexp2); [| |split].
- exact Hx2_0.
- unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl.
rewrite Hx2_1, Hlx'', Ztrunc_floor; [exact Hx2_2|].
now apply Rmult_le_pos; [apply Rlt_le|apply bpow_ge_0].
- apply Rmult_le_pos; [lra|apply bpow_ge_0].
- unfold ulp, canonic_exp; rewrite Hx2_1; rewrite Hlx''.
- rewrite ulp_neq_0; try now apply Rgt_not_eq.
unfold canonic_exp; rewrite Hx2_1; rewrite Hlx''.
rewrite <- Rmult_1_l; apply Rmult_lt_compat_r; [|lra].
apply bpow_gt_0. }
unfold round at 2, F2R, scaled_mantissa, canonic_exp; simpl.
......@@ -1943,14 +1965,15 @@ destruct (Req_dec rd 0) as [Zrd|Nzrd].
{ rewrite Hx2b2.
rewrite Hlr; rewrite Xmid'.
rewrite Rplus_assoc.
apply (ln_beta_succ beta fexp1 rd Prd); [|split].
apply (ln_beta_plus_eps beta fexp1 rd Prd); [|split].
- apply generic_format_round; [exact Vfexp1|apply valid_rnd_DN].
- apply Rplus_le_le_0_compat; (apply Rmult_le_pos; [lra|apply bpow_ge_0]).
- rewrite <- Rmult_plus_distr_l.
apply (Rmult_lt_reg_l 2); [lra|].
rewrite <- Rmult_assoc; replace (2 * / 2) with 1 by field;
rewrite Rmult_1_l.
unfold ulp, canonic_exp; rewrite <- Hlr; change (bpow (fexp1 _)) with u.
rewrite ulp_neq_0; trivial.
unfold canonic_exp; rewrite <- Hlr; change (bpow (fexp1 _)) with u.
rewrite Rmult_plus_distr_r; rewrite Rmult_1_l.
apply Rplus_lt_compat_l; unfold u, ulp, canonic_exp, f2; apply bpow_lt.
omega. }
......@@ -2130,7 +2153,9 @@ destruct (Zle_or_lt (fexp1 ex) (fexp2 ex)) as [H2|H2].
- rewrite Rmult_plus_distr_r, Rmult_1_l.
apply Rplus_le_compat; [|now apply bpow_le; omega].
apply Rle_trans with (bpow (fexp2 ex)); [|now apply bpow_le; omega].
rewrite <- (Rmult_1_l (bpow _)); unfold ulp, canonic_exp.
rewrite <- (Rmult_1_l (bpow _)).
rewrite ulp_neq_0; try now apply Rgt_not_eq.
unfold canonic_exp.
rewrite Hex'; apply Rmult_le_compat_r; [apply bpow_ge_0|lra].
- rewrite <- (Rmult_1_l (bpow (fexp1 _))).
unfold Zminus; rewrite Zplus_comm, bpow_plus, <- Rmult_assoc.
......@@ -2146,7 +2171,8 @@ destruct (Zle_or_lt (fexp1 ex) (fexp2 ex)) as [H2|H2].
rewrite <- Rmult_plus_distr_l; apply Rmult_le_compat_l; [lra|].
apply Rle_trans with (3 * bpow (fexp1 ex - 1)).
+ rewrite (Rmult_plus_distr_r _ 2); rewrite Rmult_1_l; apply Rplus_le_compat.
* apply bpow_le; unfold canonic_exp; rewrite Hex'; omega.
* rewrite ulp_neq_0; try now apply Rgt_not_eq.
apply bpow_le; unfold canonic_exp; rewrite Hex'; omega.
* apply Rmult_le_compat_l; [lra|]; apply bpow_le; omega.
+ rewrite <- (Rmult_1_l (bpow (fexp1 _))).
unfold Zminus; rewrite Zplus_comm, bpow_plus, <- Rmult_assoc.
......
examples/Sqrt_sqr.v
View file @ 1d5a4239
......@@ -30,143 +30,6 @@ Hypothesis Fx: format x.
Let y:=round_flx1(x*x).
Let z:=round_flx2(sqrt y).
Theorem round_le_half_an_ulp:
forall choice, forall u v, format u -> 0 < u -> v < u + (ulp_flx u)/2
-> round beta (FLX_exp prec) (Znearest choice) v <= u.
Proof with auto with typeclass_instances.
intros choice u v Fu Hu H.
(* . *)
assert (0 < ulp_flx u / 2).
unfold Rdiv; apply Rmult_lt_0_compat.
unfold ulp; apply bpow_gt_0.
auto with real.
(* . *)
assert (ulp_flx u / 2 < ulp_flx u).
apply Rlt_le_trans with (ulp_flx u *1);[idtac|right; ring].
unfold Rdiv; apply Rmult_lt_compat_l.
apply bpow_gt_0.
apply Rmult_lt_reg_l with 2.
auto with real.
apply Rle_lt_trans with 1%R.
right; field.
rewrite Rmult_1_r; auto with real.
(* *)
apply Rnd_N_pt_monotone with format v (u + ulp_flx u / 2)...
apply round_N_pt...
apply Rnd_DN_pt_N with (u+ulp_flx u).
pattern u at 3; replace u with (round beta (FLX_exp prec) Zfloor (u + ulp_flx u / 2)).
apply round_DN_pt...
apply round_DN_succ; try assumption.
split; try left; assumption.
replace (u+ulp_flx u) with (round beta (FLX_exp prec) Zceil (u + ulp_flx u / 2)).
apply round_UP_pt...
apply round_UP_succ; try assumption...
split; try left; assumption.
right; field.
Qed.
Theorem round_ge_half_an_ulp:
forall choice, forall u v, format u -> 0 < u -> u <> bpow (ln_beta beta u - 1)
-> u - (ulp_flx u)/2 < v -> u <= round beta (FLX_exp prec) (Znearest choice) v.
Proof with auto with typeclass_instances.
intros choice u v Fu Hupos Hu H.
(* *)
assert (Hu2:(ulp_flx (pred_flx u) = ulp_flx u)).
unfold pred; case Req_bool_spec.
intros V; contradict Hu; auto.
unfold ulp, canonic_exp, FLX_exp.
destruct ln_beta as (e,He); simpl.
intros Hu2.
apply f_equal; apply f_equal2; auto.
apply ln_beta_unique.
rewrite Rabs_right.
split.
(* . *)
assert (bpow (e-prec) = ulp_flx u).
unfold ulp, canonic_exp, FLX_exp.
apply f_equal, f_equal2; auto.
apply sym_eq, ln_beta_unique, He; auto with real.
rewrite H0.
apply pred_ge_bpow.
assumption.
apply Rgt_not_eq, Rlt_gt.
rewrite <- H0.
apply Rlt_le_trans with (bpow (e-1)).
apply bpow_lt; auto with zarith.
rewrite <- (Rabs_right u).
apply He; auto with real.
apply Rle_ge; auto with real.
assert (bpow (e - 1) <= u).
rewrite <- (Rabs_right u).
apply He; auto with real.
apply Rle_ge; auto with real.
case H1; auto.
intros V; contradict Hu2; auto with real.
(* . *)
apply Rle_lt_trans with u.
apply Rplus_le_reg_l with (-u).
ring_simplify.
apply Rle_trans with (-0);[apply Ropp_le_contravar|right; ring].
apply bpow_ge_0.
rewrite <- (Rabs_right u).
apply He; auto with real.
apply Rle_ge; auto with real.
(* . *)
apply Rle_ge; apply Rplus_le_reg_l with (bpow (e-prec)); ring_simplify.
apply Rle_trans with (bpow (e-1)).
apply bpow_le; auto with zarith.
rewrite <- (Rabs_right u).
apply He; auto with real.
apply Rle_ge; auto with real.
(* *)
apply Rnd_N_pt_monotone with format (u - ulp_flx (pred_flx u) / 2) v...
2: apply round_N_pt...
2: rewrite Hu2; assumption.
(* . *)
assert (0 < pred_flx u).
unfold pred; case Req_bool_spec.
intros V; contradict Hu; auto.
intros _; unfold ulp, canonic_exp, FLX_exp.
destruct ln_beta as (e,He); simpl.
apply Rplus_lt_reg_r with (bpow (e-prec)); ring_simplify.
apply Rlt_le_trans with (bpow (e-1)).
apply bpow_lt; auto with zarith.
rewrite <- (Rabs_right u).
apply He; auto with real.
apply Rle_ge; auto with real.
(* . *)
assert (0 < ulp_flx (pred_flx u) / 2).
unfold Rdiv; apply Rmult_lt_0_compat.
unfold ulp; apply bpow_gt_0.
auto with real.
(* . *)
assert (ulp_flx (pred_flx u) / 2 <= ulp_flx (pred_flx u)).
apply Rle_trans with (ulp_flx (pred_flx u) *1);[idtac|right; ring].
unfold Rdiv; apply Rmult_le_compat_l.
apply bpow_ge_0.
apply Rmult_le_reg_l with 2.
auto with real.
apply Rle_trans with 1%R.
right; field.
rewrite Rmult_1_r; auto with real.
(* *)
apply Rnd_UP_pt_N with (pred_flx u).
(* . *)
pattern (pred_flx u) at 2; replace (pred_flx u) with (round beta (FLX_exp prec) Zfloor (u - ulp_flx (pred_flx u) / 2)).
apply round_DN_pt...
apply round_DN_pred; try assumption...
pattern u at 3; replace u with (round beta (FLX_exp prec) Zceil (u - ulp_flx (pred_flx u) / 2)).
apply round_UP_pt...
replace ((u - ulp_flx (pred_flx u) / 2)) with (pred_flx u + ulp_flx (pred_flx u) / 2).
apply round_UP_pred; try assumption...
pattern u at 3; rewrite <- pred_plus_ulp with beta (FLX_exp prec) u...
field.
auto with real.
pattern u at 4; rewrite <- pred_plus_ulp with beta (FLX_exp prec) u...
rewrite Hu2.
right; field.
auto with real.
Qed.
Theorem round_flx_sqr_sqrt_middle: x = sqrt (Z2R beta) * bpow (ln_beta beta x - 1) -> z=x.
Proof with auto with typeclass_instances.
......@@ -209,18 +72,19 @@ assert (0 <= 1 + ulp_flx (x * x) / 2 / (x * x)).
rewrite <- (Rplus_0_l 0).
apply Rplus_le_compat; auto with real.
unfold Rdiv; apply Rmult_le_pos.
apply Rmult_le_pos; auto with real; apply bpow_ge_0.
apply Rmult_le_pos; auto with real; apply ulp_pos.
left; auto with real.
assert (0 <= 1 + ulp_flx x / 2 / x).
rewrite <- (Rplus_0_l 0).
apply Rplus_le_compat; auto with real.
unfold Rdiv; apply Rmult_le_pos.
apply Rmult_le_pos; auto with real; apply bpow_ge_0.
apply Rmult_le_pos; auto with real; apply ulp_pos.
left; auto with real.
(* *)
apply round_le_half_an_ulp; try assumption.
apply rnd_N_le_half; try assumption...
apply Rlt_le_trans with (x*(1+ulp_flx x / 2 / x)).
2: right; field; auto with real.
2: right; rewrite succ_pos_eq; try now left.
2: field; auto with real.
apply Rle_lt_trans with (sqrt ((x*x)*(1+ulp_flx (x*x)/2/(x*x)))).
apply sqrt_le_1_alt.
apply Rplus_le_reg_l with (-x*x).
......@@ -248,9 +112,12 @@ apply Rplus_le_compat_l.
apply Rplus_le_reg_r with (ulp_flx x * ulp_flx x / 2).
apply Rle_trans with 0;[right; ring|idtac].
apply Rle_trans with (ulp_flx x * ulp_flx x).
apply Rmult_le_pos; apply bpow_ge_0.
apply Rmult_le_pos; apply ulp_pos.
right; field.
unfold ulp, canonic_exp, FLX_exp.
rewrite 2!ulp_neq_0.
2: now apply Rgt_not_eq.
2: now apply Rgt_not_eq.
unfold canonic_exp, FLX_exp.
destruct (ln_beta beta x) as (e,He).
simpl.
assert (bpow (e - 1) <= x < bpow e).
......@@ -361,7 +228,11 @@ apply Rmult_le_compat_l.
auto with real.
apply Rle_trans with (2 * bpow (e - 1) + ulp_flx (2 * bpow (e - 1))).
apply Rplus_le_compat_l.
unfold ulp, canonic_exp, FLX_exp.