(** * Conditions for innocuous double rounding. *)
Require Fcore_FLX Fcore_FLT Fcore_FTZ.
Open Scope R_scope.
Section Double_round.
Variable beta : radix.
Notation bpow e := (bpow beta e).
Notation ln_beta x := (ln_beta beta x).
Definition double_round_eq fexp1 fexp2 choice1 choice2 x :=
round beta fexp1 (Znearest choice1) (round beta fexp2 (Znearest choice2) x)
= round beta fexp1 (Znearest choice1) x.
(** A little tactic to simplify terms of the form [bpow a * bpow b]. *)
Ltac bpow_simplify :=
(* bpow ex * bpow ey ~~> bpow (ex + ey) *)
repeat
match goal with
| |- context [(Fcore_Raux.bpow _ _ * Fcore_Raux.bpow _ _)] =>
rewrite <- bpow_plus
| |- context [(?X1 * Fcore_Raux.bpow _ _ * Fcore_Raux.bpow _ _)] =>
rewrite (Rmult_assoc X1); rewrite <- bpow_plus
| |- context [(?X1 * (?X2 * Fcore_Raux.bpow _ _) * Fcore_Raux.bpow _ _)] =>
rewrite <- (Rmult_assoc X1 X2); rewrite (Rmult_assoc (X1 * X2));
rewrite <- bpow_plus
end;
(* ring_simplify arguments of bpow *)
repeat
match goal with
| |- context [(Fcore_Raux.bpow _ ?X)] =>
progress ring_simplify X
end;
(* bpow 0 ~~> 1 *)
change (Fcore_Raux.bpow _ 0) with 1;
repeat
match goal with
| |- context [(_ * 1)] =>
rewrite Rmult_1_r
end.
Definition midp (fexp : Z -> Z) (x : R) :=
round beta fexp Zfloor x + / 2 * ulp beta fexp x.
Definition midp' (fexp : Z -> Z) (x : R) :=
round beta fexp Zceil x - / 2 * ulp beta fexp x.

Lemma double_round_gt_mid :
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
forall x,
0 < x ->
(fexp2 (ln_beta x) <= fexp1 (ln_beta x))%Z ->
(fexp1 (ln_beta x) <= ln_beta x)%Z ->
midp' fexp1 x < x ->
((fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z ->
midp' fexp1 x + / 2 * ulp beta fexp2 x < x) ->
double_round_eq fexp1 fexp2 choice1 choice2 x.