Section Fcore_ulp.
Variable beta : radix.
Notation bpow e := (bpow beta e).
Variable fexp : Z -> Z.
(** Definition and basic properties about the minimal exponent, when it exists *)
(** [negligible_exp] is either none (as in FLX) or Some n such that n <= fexp n. *)
Definition negligible_exp: option Z :=
match (LPO_Z _ (fun z => Z_le_dec_aux z (fexp z))) with
| inleft N => Some (proj1_sig N)
| inright _ => None
end.
Inductive negligible_exp_prop: option Z -> Prop :=
| negligible_None: (forall n, (fexp n < n)%Z) -> negligible_exp_prop None
| negligible_Some: forall n, (n <= fexp n)%Z -> negligible_exp_prop (Some n).
Context { valid_exp : Valid_exp fexp }.
(** Definition and basic properties about the ulp *)
(** Now includes a nice ulp(0): ulp(0) is now 0 when there is no minimal exponent, such as in FLX, and beta^(fexp n) when there is a n such that n <= fexp n. For instance, the value of ulp(O) is then beta^emin in FIX and FLT. The main lemma to use is ulp_neq_0 that is equivalent to the previous "unfold ulp" provided the value is not zero. *)
Definition ulp x := match Req_bool x 0 with
| true   => match negligible_exp with
| Some n => bpow (fexp n)
| None => 0%R
end
| false  => bpow (cexp beta fexp x)
end.
Notation F := (generic_format beta fexp).
(** The three following properties are equivalent: [Exp_not_FTZ] ;  forall x, F (ulp x) ; forall x, ulp 0 <= ulp x *)
Proof with auto with typeclass_instances.
intros Hm x y Hx Hxy.
destruct Hx as [Hx|Hx].
rewrite ulp_neq_0.
rewrite ulp_neq_0.
apply bpow_le.
apply Hm.
now apply mag_le.
apply Rgt_not_eq, Rlt_gt.
now apply Rlt_le_trans with (1:=Hx).
now apply Rgt_not_eq.
rewrite <- Hx.
apply ulp_ge_ulp_0.
apply monotone_exp_not_FTZ...
Qed.
(** Definition and properties of pred and succ *)
Definition pred_pos x :=
if Req_bool x (bpow (mag beta x - 1)) then
(x - bpow (fexp (mag beta x - 1)))%R
else
(x - ulp x)%R.
Definition succ x :=
if (Rle_bool 0 x) then
(x+ulp x)%R
else
(- pred_pos (-x))%R.
Definition pred x := (- succ (-x))%R.
(** pred and succ are in the format *)
(** The following one is false for x = 0 in FTZ *)
(** Rounding x + small epsilon *)
Proof with auto with typeclass_instances.
intros x Zx Fx eps.
case Zx; intros Zx1.
(* . 0 < x *)
intros (Heps1,[Heps2|Heps2]).
assert (Heps: (0 <= eps < ulp x)%R).
split.
now apply Rlt_le.
exact Heps2.
assert (Hd := round_DN_plus_eps_pos x Zx Fx eps Heps).
rewrite round_UP_DN_ulp.
rewrite Hd.
rewrite 2!ulp_neq_0.
unfold cexp.
now rewrite mag_plus_eps.
now apply Rgt_not_eq.
now apply Rgt_not_eq, Rplus_lt_0_compat.
intros Fs.
rewrite round_generic in Hd...
apply Rgt_not_eq with (2 := Hd).
pattern x at 2 ; rewrite <- Rplus_0_r.
now apply Rplus_lt_compat_l.
rewrite Heps2.
apply round_generic...
now apply generic_format_succ_aux1.
(* . x=0 *)
rewrite <- Zx1, 2!Rplus_0_l.
intros Heps.
case (proj2 Heps).
unfold round, scaled_mantissa, cexp.
unfold ulp.
rewrite Req_bool_true; trivial.
case negligible_exp_spec.
lra.
intros n Hn H.
assert (fexp (mag beta eps) = fexp n).
apply valid_exp; try assumption.
assert(mag beta eps-1 < fexp n)%Z;[idtac|omega].
apply lt_bpow with beta.
apply Rle_lt_trans with (2:=H).
destruct (mag beta eps) as (e,He).
simpl; rewrite Rabs_pos_eq in He.
now apply He, Rgt_not_eq.
now left.
replace (Zceil (eps * bpow (- fexp (mag beta eps)))) with 1%Z.
unfold F2R; simpl; rewrite H0; ring.
apply sym_eq, Zceil_imp.
split.
simpl; apply Rmult_lt_0_compat.
apply Heps.
apply bpow_gt_0.
apply Rmult_le_reg_r with (bpow (fexp n)).
apply bpow_gt_0.
rewrite Rmult_assoc, <- bpow_plus.
rewrite H0; ring_simplify (-fexp n + fexp n)%Z.
simpl; rewrite Rmult_1_l, Rmult_1_r.
now left.
intros P; rewrite P.
apply round_generic...
apply generic_format_ulp_0.
Qed.
Proof with auto with typeclass_instances.
intros x Fx eps Heps.
case (Rle_or_lt 0 x); intros Zx.
rewrite succ_eq_pos; try assumption.
rewrite Rle_bool_true in Heps; trivial.
apply round_UP_plus_eps_pos; assumption.
(* *)
rewrite Rle_bool_false in Heps; trivial.
rewrite <- (Ropp_involutive (x+eps)).
rewrite <- (Ropp_involutive (succ x)).
rewrite round_UP_opp.
apply f_equal.
replace (-(x+eps))%R with (-succ x + (-eps + ulp (pred (-x))))%R.
apply round_DN_plus_eps_pos.
rewrite <- pred_opp.
apply pred_ge_0.
now apply Ropp_0_gt_lt_contravar.
now apply generic_format_opp.
now apply generic_format_opp, generic_format_succ.
split.
apply Rplus_le_reg_l with eps; ring_simplify.
apply Heps.
unfold pred; rewrite Ropp_involutive.
apply Rplus_lt_reg_l with (eps-ulp (- succ x))%R; ring_simplify.
apply Heps.
unfold succ; rewrite Rle_bool_false; try assumption.
apply trans_eq with (-x +-eps)%R;[idtac|ring].
pattern (-x)%R at 3; rewrite <- (pred_pos_plus_ulp (-x)).
rewrite pred_eq_pos.
ring.
left; now apply Ropp_0_gt_lt_contravar.
now apply Ropp_0_gt_lt_contravar.
now apply generic_format_opp.
Qed.
Proof with auto with typeclass_instances.
intros x y Fx Fy H.
case (proj1 H); intros V.
assert (Zy:(0 < y)%R).
apply Rle_lt_trans with (1:=proj1 H).
apply H.
(* *)
assert (Zp: (0 < pred y)%R).
assert (Zp:(0 <= pred y)%R).
apply pred_ge_0 ; trivial.
destruct Zp; trivial.
generalize H0.
rewrite pred_eq_pos;[idtac|now left].
unfold pred_pos.
destruct (mag beta y) as (ey,Hey); simpl.
case Req_bool_spec; intros Hy2.
(* . *)
intros Hy3.
assert (ey-1 = fexp (ey -1))%Z.
apply bpow_inj with beta.
rewrite <- Hy2, <- Rplus_0_l, Hy3.
ring.
assert (Zx: (x <> 0)%R).
now apply Rgt_not_eq.
destruct (mag beta x) as (ex,Hex).
specialize (Hex Zx).
assert (ex <= ey)%Z.
apply bpow_lt_bpow with beta.
apply Rle_lt_trans with (1:=proj1 Hex).
apply Rlt_trans with (Rabs y).
rewrite 2!Rabs_right.
apply H.
now apply Rgt_ge.
now apply Rgt_ge.
apply Hey.
now apply Rgt_not_eq.
case (Zle_lt_or_eq _ _ H2); intros Hexy.
assert (fexp ex = fexp (ey-1))%Z.
apply valid_exp.
omega.
rewrite <- H1.
omega.
absurd (0 < Ztrunc (scaled_mantissa beta fexp x) < 1)%Z.
omega.
split.
apply gt_0_F2R with beta (cexp beta fexp x).
now rewrite <- Fx.
apply lt_IZR.
apply Rmult_lt_reg_r with (bpow (cexp beta fexp x)).
apply bpow_gt_0.
replace (IZR (Ztrunc (scaled_mantissa beta fexp x)) *
bpow (cexp beta fexp x))%R with x.
rewrite Rmult_1_l.
unfold cexp.
rewrite mag_unique with beta x ex.
rewrite H3,<-H1, <- Hy2.
apply H.
exact Hex.
absurd (y <= x)%R.
now apply Rlt_not_le.
rewrite Rabs_right in Hex.
apply Rle_trans with (2:=proj1 Hex).
rewrite Hexy, Hy2.
now apply Rle_refl.
now apply Rgt_ge.
(* . *)
intros Hy3.
assert (y = bpow (fexp ey))%R.
apply Rminus_diag_uniq.
rewrite Hy3.
rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq].
unfold cexp.
rewrite (mag_unique beta y ey); trivial.
apply Hey.
now apply Rgt_not_eq.
contradict Hy2.
rewrite H1.
apply f_equal.
apply Zplus_reg_l with 1%Z.
ring_simplify.
apply trans_eq with (mag beta y).
apply sym_eq; apply mag_unique.
rewrite H1, Rabs_right.
split.
apply bpow_le.
omega.
apply bpow_lt.
omega.
apply Rle_ge; apply bpow_ge_0.
apply mag_unique.
apply Hey.
now apply Rgt_not_eq.
(* *)
case (Rle_or_lt (ulp (pred_pos y)) (y-x)); intros H1.
(* . *)
apply Rplus_le_reg_r with (-x + ulp (pred_pos y))%R.
ring_simplify (x+(-x+ulp (pred_pos y)))%R.
apply Rle_trans with (1:=H1).
rewrite <- (pred_pos_plus_ulp y) at 1; trivial.
apply Req_le; ring.
(* . *)
replace x with (y-(y-x))%R by ring.
rewrite <- pred_eq_pos;[idtac|now left].
rewrite <- round_DN_minus_eps_pos with (eps:=(y-x)%R); try easy.
ring_simplify (y-(y-x))%R.
apply Req_le.
apply sym_eq.
apply round_generic...
split; trivial.
now apply Rlt_Rminus.
rewrite pred_eq_pos;[idtac|now left].
now apply Rlt_le.
rewrite <- V; apply pred_pos_ge_0; trivial.
apply Rle_lt_trans with (1:=proj1 H); apply H.
Qed.
Proof with auto with typeclass_instances.
intros x y Hx Hy Zx H.
rewrite succ_eq_pos; trivial.
case (Rle_or_lt (ulp x) (y-x)); intros H1.
apply Rplus_le_reg_r with (-x)%R.
now ring_simplify (x+ulp x + -x)%R.
replace y with (x+(y-x))%R by ring.
absurd (x < y)%R.
2: apply H.
apply Rle_not_lt; apply Req_le.
rewrite <- round_DN_plus_eps_pos with (eps:=(y-x)%R); try easy.
ring_simplify (x+(y-x))%R.
apply sym_eq.
apply round_generic...
split; trivial.
apply Rlt_le; now apply Rlt_Rminus.
Qed.
Proof with auto with typeclass_instances.
intros x y Fx Fy H.
destruct (Rle_or_lt 0 x) as [Hx|Hx].
now apply succ_le_lt_aux.
unfold succ; rewrite Rle_bool_false; try assumption.
case (Rle_or_lt y 0); intros Hy.
rewrite <- (Ropp_involutive y).
apply Ropp_le_contravar.
apply le_pred_pos_lt.
now apply generic_format_opp.
now apply generic_format_opp.
split.
rewrite <- Ropp_0; now apply Ropp_le_contravar.
now apply Ropp_lt_contravar.
apply Rle_trans with (-0)%R.
apply Ropp_le_contravar.
apply pred_pos_ge_0.
rewrite <- Ropp_0; now apply Ropp_lt_contravar.
now apply generic_format_opp.
rewrite Ropp_0; now left.
Qed.
Proof with auto with typeclass_instances.
intros rnd Zrnd x Zx.
destruct (generic_format_EM beta fexp x) as [Hx|Hx].
(* x = rnd x *)
rewrite round_generic...
unfold Rminus.
rewrite Rplus_opp_r, Rabs_R0.
rewrite ulp_neq_0; trivial.
apply bpow_gt_0.
(* x <> rnd x *)
destruct (round_DN_or_UP beta fexp rnd x) as [H|H] ; rewrite H ; clear H.
(* . *)
rewrite Rabs_left1.
rewrite Ropp_minus_distr.
apply Rplus_lt_reg_l with (round beta fexp Zfloor x).
rewrite <- round_UP_DN_ulp with (1 := Hx).
ring_simplify.
assert (Hu: (x <= round beta fexp Zceil x)%R).
apply round_UP_pt...
destruct Hu as [Hu|Hu].
exact Hu.
elim Hx.
rewrite Hu.
apply generic_format_round...
apply Rle_minus.
apply round_DN_pt...
(* . *)
rewrite Rabs_pos_eq.
rewrite round_UP_DN_ulp with (1 := Hx).
apply Rplus_lt_reg_r with (x - ulp x)%R.
ring_simplify.
assert (Hd: (round beta fexp Zfloor x <= x)%R).
apply round_DN_pt...
destruct Hd as [Hd|Hd].
exact Hd.
elim Hx.
rewrite <- Hd.
apply generic_format_round...
apply Rle_0_minus.
apply round_UP_pt...
Qed.
Proof with auto with typeclass_instances.
intros  rnd Zrnd x.
case (Req_dec x 0).
intros Zx; rewrite Zx, round_0...
unfold Rminus; rewrite Rplus_0_l, Ropp_0, Rabs_R0.
apply ulp_ge_0.
intros Zx; left.
now apply error_lt_ulp.
Qed.
Proof with auto with typeclass_instances.
intros choice x.
destruct (generic_format_EM beta fexp x) as [Hx|Hx].
(* x = rnd x *)
rewrite round_generic...
unfold Rminus.
rewrite Rplus_opp_r, Rabs_R0.
apply Rmult_le_pos.
apply Rlt_le.
apply Rinv_0_lt_compat.
now apply IZR_lt.
apply ulp_ge_0.
(* x <> rnd x *)
set (d := round beta fexp Zfloor x).
destruct (round_N_pt beta fexp choice x) as (Hr1, Hr2).
destruct (Rle_or_lt (x - d) (d + ulp x - x)) as [H|H].
(* . rnd(x) = rndd(x) *)
apply Rle_trans with (Rabs (d - x)).
apply Hr2.
apply (round_DN_pt beta fexp x).
rewrite Rabs_left1.
rewrite Ropp_minus_distr.
apply Rmult_le_reg_r with 2%R.
now apply IZR_lt.
apply Rplus_le_reg_r with (d - x)%R.
ring_simplify.
apply Rle_trans with (1 := H).
right. field.
apply Rle_minus.
apply (round_DN_pt beta fexp x).
(* . rnd(x) = rndu(x) *)
assert (Hu: (d + ulp x)%R = round beta fexp Zceil x).
unfold d.
now rewrite <- round_UP_DN_ulp.
apply Rle_trans with (Rabs (d + ulp x - x)).
apply Hr2.
rewrite Hu.
apply (round_UP_pt beta fexp x).
rewrite Rabs_pos_eq.
apply Rmult_le_reg_r with 2%R.
now apply IZR_lt.
apply Rplus_le_reg_r with (- (d + ulp x - x))%R.
ring_simplify.
apply Rlt_le.
apply Rlt_le_trans with (1 := H).
right. field.
apply Rle_0_minus.
rewrite Hu.
apply (round_UP_pt beta fexp x).
Qed.
Proof with auto with typeclass_instances.
intros x [Hx|Hx].
- rewrite (ulp_neq_0 x) by now apply Rgt_not_eq.
destruct (round_ge_generic beta fexp Zfloor 0 x) as [Hd|Hd].
apply generic_format_0.
now apply Rlt_le.
+ rewrite ulp_neq_0 by now apply Rgt_not_eq.
now rewrite cexp_DN with (2 := Hd).
+ rewrite <- Hd.
unfold cexp.
destruct (mag beta x) as [e He].
simpl.
specialize (He (Rgt_not_eq _ _ Hx)).
apply sym_eq in Hd.
assert (H := exp_small_round_0 _ _ _ _ _ He Hd).
unfold ulp.
rewrite Req_bool_true by easy.
destruct negligible_exp_spec as [H0|k Hk].
now elim Zlt_not_le with (1 := H0 e).
now apply f_equal, fexp_negligible_exp_eq.
- rewrite <- Hx, round_0...
Qed.
Proof with auto with typeclass_instances.
intros H rndn Hrnd x Hx K.
case negligible_exp_spec'.
intros (_,Hn).
destruct (mag beta x) as (e,He).
absurd (fexp e < e)%Z.
apply Zle_not_lt.
apply exp_small_round_0 with beta rndn x...
apply (Hn e).
intros (n,(H1,_)).
rewrite H in H1; discriminate.
Qed.

(** allows rnd x to be 0 *)
Theorem error_lt_ulp_round :
forall { Hm : Monotone_exp fexp } rnd { Zrnd : Valid_rnd rnd } x,
(x <> 0)%R ->
(Rabs (round beta fexp rnd x - x) < ulp (round beta fexp rnd x))%R.