(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2013 Sylvie Boldo
#<br />#
Copyright (C) 2010-2013 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Unit in the Last Place: our definition using fexp and its properties, successor and predecessor *)
Require Import Reals Psatz.
Require Import Fcore_Raux.
Require Import Fcore_defs.
Require Import Fcore_rnd.
Require Import Fcore_generic_fmt.
Require Import Fcore_float_prop.

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 *)

Lemma Z_le_dec_aux: forall x y : Z, (x <= y)%Z \/ ~ (x <= y)%Z.
Proof.
(* Goal: forall x y : Z, or (Z.le x y) (not (Z.le x y)) *)
intros.
(* Goal: or (Z.le x y) (not (Z.le x y)) *)
destruct (Z_le_dec x y).
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (pred x) *)
(* Goal: generic_format beta fexp (pred x) *)
now left.
(* Goal: Rle (ulp (IZR Z0)) (ulp (IZR Z0)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
now right.
Qed.

(** [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).


Lemma negligible_exp_spec: negligible_exp_prop negligible_exp.
Proof.
(* Goal: or (and (@eq (option Z) negligible_exp (@None Z)) (forall n : Z, Z.lt (fexp n) n)) (@ex Z (fun n : Z => and (@eq (option Z) negligible_exp (@Some Z n)) (Z.le n (fexp n)))) *)
unfold negligible_exp; destruct LPO_Z as [(n,Hn)|Hn].
(* Goal: negligible_exp_prop (@Some Z (@proj1_sig Z (fun n : Z => Z.le n (fexp n)) (@exist Z (fun n : Z => Z.le n (fexp n)) n Hn))) *)
(* Goal: negligible_exp_prop (@None Z) *)
now apply negligible_Some.
(* Goal: negligible_exp_prop (@None Z) *)
apply negligible_None.
(* Goal: forall n : Z, Z.lt (fexp n) n *)
intros n; specialize (Hn n); omega.
Qed.

Lemma negligible_exp_spec': (negligible_exp = None /\ forall n, (fexp n < n)%Z)
           \/ exists n, (negligible_exp = Some n /\ (n <= fexp n)%Z).
Proof.
(* Goal: or (and (@eq (option Z) negligible_exp (@None Z)) (forall n : Z, Z.lt (fexp n) n)) (@ex Z (fun n : Z => and (@eq (option Z) negligible_exp (@Some Z n)) (Z.le n (fexp n)))) *)
unfold negligible_exp; destruct LPO_Z as [(n,Hn)|Hn].
(* Goal: or (and (@eq (option Z) (@Some Z (@proj1_sig Z (fun n : Z => Z.le n (fexp n)) (@exist Z (fun n : Z => Z.le n (fexp n)) n Hn))) (@None Z)) (forall n : Z, Z.lt (fexp n) n)) (@ex Z (fun n0 : Z => and (@eq (option Z) (@Some Z (@proj1_sig Z (fun n : Z => Z.le n (fexp n)) (@exist Z (fun n : Z => Z.le n (fexp n)) n Hn))) (@Some Z n0)) (Z.le n0 (fexp n0)))) *)
(* Goal: or (and (@eq (option Z) (@None Z) (@None Z)) (forall n : Z, Z.lt (fexp n) n)) (@ex Z (fun n : Z => and (@eq (option Z) (@None Z) (@Some Z n)) (Z.le n (fexp n)))) *)
right; simpl; exists n; now split.
(* Goal: or (and (@eq (option Z) (@None Z) (@None Z)) (forall n : Z, Z.lt (fexp n) n)) (@ex Z (fun n : Z => and (@eq (option Z) (@None Z) (@Some Z n)) (Z.le n (fexp n)))) *)
left; split; trivial.
(* Goal: forall n : Z, Z.lt (fexp n) n *)
intros n; specialize (Hn n); omega.
Qed.

Context { valid_exp : Valid_exp fexp }.

Lemma fexp_negligible_exp_eq: forall n m, (n <= fexp n)%Z -> (m <= fexp m)%Z -> fexp n = fexp m.
Proof.
(* Goal: forall (n m : Z) (_ : Z.le n (fexp n)) (_ : Z.le m (fexp m)), @eq Z (fexp n) (fexp m) *)
intros n m Hn Hm.
(* Goal: @eq Z (fexp n) (fexp m) *)
case (Zle_or_lt n m); intros H.
(* Goal: @eq Z (fexp n) (fexp (Z.sub e (Zpos xH))) *)
(* Goal: @eq Z (fexp n) (fexp (Z.sub e (Zpos xH))) *)
apply valid_exp; omega.
(* Goal: @eq Z (fexp n) (fexp (Z.sub e (Zpos xH))) *)
apply sym_eq, valid_exp; omega.
Qed.


(** 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 (canonic_exp beta fexp x)
 end.

Lemma ulp_neq_0 : forall x:R, (x <> 0)%R -> ulp x = bpow (canonic_exp beta fexp x).
Proof.
intros  x Hx.
(* Goal: @eq R (ulp x) (Fcore_Raux.bpow beta (canonic_exp beta fexp x)) *)
unfold ulp; case (Req_bool_spec x); trivial.
(* Goal: forall _ : @eq R x (IZR Z0), @eq R match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end (Fcore_Raux.bpow beta (canonic_exp beta fexp x)) *)
intros H; now contradict H.
Qed.

Notation F := (generic_format beta fexp).

Theorem ulp_opp :
  forall x, ulp (- x) = ulp x.
Proof.
(* Goal: forall x : R, @eq R (ulp (Rabs x)) (ulp x) *)
intros x.
(* Goal: generic_format beta fexp (ulp (IZR Z0)) *)
unfold ulp.
(* Goal: @eq R (if Req_bool (Ropp x) (IZR Z0) then match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end else Fcore_Raux.bpow beta (canonic_exp beta fexp (Ropp x))) (if Req_bool x (IZR Z0) then match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end else Fcore_Raux.bpow beta (canonic_exp beta fexp x)) *)
case Req_bool_spec; intros H1.
(* Goal: Rle (if Req_bool (IZR Z0) (IZR Z0) then match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end else Fcore_Raux.bpow beta (canonic_exp beta fexp (IZR Z0))) (ulp x) *)
rewrite Req_bool_true; trivial.
(* Goal: @eq R x (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (canonic_exp beta fexp (Ropp x))) (if Req_bool x (IZR Z0) then match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end else Fcore_Raux.bpow beta (canonic_exp beta fexp x)) *)
rewrite <- (Ropp_involutive x), H1; ring.
(* Goal: @eq R (if Req_bool (Rabs x) (IZR Z0) then match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end else Fcore_Raux.bpow beta (canonic_exp beta fexp (Rabs x))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x)) *)
rewrite Req_bool_false.
(* Goal: @eq R (Fcore_Raux.bpow beta (canonic_exp beta fexp (Ropp x))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x)) *)
(* Goal: not (@eq R x (IZR Z0)) *)
now rewrite canonic_exp_opp.
(* Goal: not (@eq R x (IZR Z0)) *)
intros H2; apply H1; rewrite H2; ring.
Qed.

Theorem ulp_abs :
  forall x, ulp (Rabs x) = ulp x.
Proof.
(* Goal: forall x : R, @eq R (ulp (Rabs x)) (ulp x) *)
intros x.
(* Goal: @eq R (ulp (Rabs x)) (ulp x) *)
unfold ulp; case (Req_bool_spec x 0); intros H1.
(* Goal: Rle (if Req_bool (IZR Z0) (IZR Z0) then match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end else Fcore_Raux.bpow beta (canonic_exp beta fexp (IZR Z0))) (ulp x) *)
rewrite Req_bool_true; trivial.
(* Goal: @eq R (Rabs x) (IZR Z0) *)
(* Goal: @eq R (if Req_bool (Rabs x) (IZR Z0) then match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end else Fcore_Raux.bpow beta (canonic_exp beta fexp (Rabs x))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x)) *)
now rewrite H1, Rabs_R0.
(* Goal: @eq R (if Req_bool (Rabs x) (IZR Z0) then match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end else Fcore_Raux.bpow beta (canonic_exp beta fexp (Rabs x))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x)) *)
rewrite Req_bool_false.
(* Goal: @eq R (Fcore_Raux.bpow beta (canonic_exp beta fexp (Rabs x))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x)) *)
(* Goal: not (@eq R (Rabs x) (IZR Z0)) *)
now rewrite canonic_exp_abs.
(* Goal: not (@eq R (Rabs x) (IZR Z0)) *)
now apply Rabs_no_R0.
Qed.

Theorem ulp_ge_0:
  forall x, (0 <= ulp x)%R.
Proof.
(* Goal: forall x y : Z, or (Z.le x y) (not (Z.le x y)) *)
intros x; unfold ulp; case Req_bool_spec; intros.
(* Goal: forall x y : Z, or (Z.le x y) (not (Z.le x y)) *)
case negligible_exp; intros.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH)))) *)
(* Goal: Rle (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_ge_0.
(* Goal: Rle (IZR Z0) (IZR Z0) *)
apply Rle_refl.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH)))) *)
(* Goal: Rle (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_ge_0.
Qed.


Theorem ulp_le_id:
  forall x,
    (0 < x)%R ->
    F x ->
    (ulp x <= x)%R.
Proof.
(* Goal: forall (x : R) (_ : Rlt (IZR Z0) x) (_ : generic_format beta fexp x), @eq R (Rplus (pred_pos x) (ulp (pred_pos x))) x *)
intros x Zx Fx.
rewrite <- (Rmult_1_l (ulp x)).
(* Goal: Rle (ulp x) x *)
pattern x at 2; rewrite Fx.
(* Goal: Rle (Rplus (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
rewrite ulp_neq_0.
2: now apply Rgt_not_eq.
(* Goal: @eq R (Rminus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (@F2R beta (Float beta (Z.sub (Z.pow (radix_val beta) (Z.sub (Z.sub e (Zpos xH)) (fexp (Z.sub e (Zpos xH))))) (Zpos xH)) (fexp (Z.sub e (Zpos xH))))) *)
(* Goal: generic_format beta fexp f *)
(* Goal: generic_format beta fexp f *)
unfold F2R; simpl.
(* Goal: Rle (Rmult (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rmult_le_compat_r.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH)))) *)
(* Goal: Rle (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_ge_0.
apply (Z2R_le (Zsucc 0)).
apply Zlt_le_succ.
(* Goal: Z.lt Z0 (Ztrunc (scaled_mantissa beta fexp x)) *)
(* Goal: Rlt (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
(* Goal: Rlt (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
now rewrite <- Fx.
Qed.

Theorem ulp_le_abs:
  forall x,
    (x <> 0)%R ->
    F x ->
    (ulp x <= Rabs x)%R.
Proof.
(* Goal: forall (x : R) (_ : Rlt (IZR Z0) x) (_ : generic_format beta fexp x), @eq R (Rplus (pred_pos x) (ulp (pred_pos x))) x *)
intros x Zx Fx.
(* Goal: Rle (ulp x) (ulp y) *)
rewrite <- ulp_abs.
(* Goal: Rle (ulp (Rabs x)) (Rabs x) *)
apply ulp_le_id.
(* Goal: Rlt (IZR Z0) (Rabs x) *)
(* Goal: generic_format beta fexp (Rabs x) *)
now apply Rabs_pos_lt.
(* Goal: generic_format beta fexp (Rabs x) *)
now apply generic_format_abs.
Qed.


(* was ulp_DN_UP *)
Theorem round_UP_DN_ulp :
  forall x, ~ F x ->
  round beta fexp Zceil x = (round beta fexp Zfloor x + ulp x)%R.
Proof.
(* Goal: forall (x : R) (_ : generic_format beta fexp x), @eq R (pred (succ x)) x *)
intros x Fx.
(* Goal: Rle (Rplus (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
rewrite ulp_neq_0.
(* Goal: @eq R (round beta fexp Zceil x) (Rplus (round beta fexp Zfloor x) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
unfold round. simpl.
(* Goal: Rle (Rplus (Rmult (Z2R (@Fnum beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
unfold F2R. simpl.
(* Goal: @eq R (Rmult (Z2R (Zceil (scaled_mantissa beta fexp x))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Rplus (Rmult (Z2R (Zfloor (scaled_mantissa beta fexp x))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
rewrite Zceil_floor_neq.
(* Goal: Rle (Rplus (Rmult (Z2R (@Fnum beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
rewrite Z2R_plus. simpl.
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
ring.
(* Goal: not (Rle (succ y) (succ x)) *)
intros H.
(* Goal: False *)
(* Goal: not (@eq R x (IZR Z0)) *)
apply Fx.
(* Goal: Rle (Rplus (Rmult (Z2R (@Fnum beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
unfold generic_format, F2R. simpl.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub (Z.sub e (Zpos xH)) (Zpos xH))) (Rabs (@F2R beta (Float beta (Z.sub (Z.pow (radix_val beta) (Z.sub (Z.sub e (Zpos xH)) (fexp (Z.sub e (Zpos xH))))) (Zpos xH)) (fexp (Z.sub e (Zpos xH))))))) (Rlt (Rabs (@F2R beta (Float beta (Z.sub (Z.pow (radix_val beta) (Z.sub (Z.sub e (Zpos xH)) (fexp (Z.sub e (Zpos xH))))) (Zpos xH)) (fexp (Z.sub e (Zpos xH)))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH)))) *)
(* Goal: generic_format beta fexp f *)
rewrite <- H.
(* Goal: @eq R (Rplus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (Z2R (Ztrunc (Z2R (Z.add (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) (Zpos xH))))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x (ulp x)))) (Rlt (Rabs (Rplus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
rewrite Ztrunc_Z2R.
(* Goal: Rle (Fcore_Raux.bpow beta (fexp (Z.sub (ln_beta_val beta x (ln_beta beta x)) (Zpos xH)))) x *)
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
rewrite H.
(* Goal: @eq R x (Rmult (scaled_mantissa beta fexp x) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
now rewrite scaled_mantissa_mult_bpow.
(* Goal: False *)
(* Goal: not (@eq R x (IZR Z0)) *)
intros V; apply Fx.
(* Goal: generic_format beta fexp x *)
rewrite V.
(* Goal: generic_format beta fexp (IZR Z0) *)
(* Goal: @eq R (IZR Z0) f *)
apply generic_format_0.
Qed.


Theorem ulp_bpow :
  forall e, ulp (bpow e) = bpow (fexp (e + 1)).
Proof.
(* Goal: forall e : Z, @eq R (ulp (Fcore_Raux.bpow beta e)) (Fcore_Raux.bpow beta (fexp (Z.add e (Zpos xH)))) *)
intros e.
(* Goal: Rle (Rplus (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
rewrite ulp_neq_0.
(* Goal: @eq R (Ropp (round beta fexp Zceil (Ropp (Rplus x eps)))) (Ropp (Ropp x)) *)
apply f_equal.
(* Goal: @eq Z (canonic_exp beta fexp (@F2R beta (Float beta (Z.sub (Z.pow (radix_val beta) (Z.sub (Z.sub e (Zpos xH)) (fexp (Z.sub e (Zpos xH))))) (Zpos xH)) (fexp (Z.sub e (Zpos xH)))))) (fexp (Z.sub e (Zpos xH))) *)
(* Goal: generic_format beta fexp f *)
apply canonic_exp_fexp.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x eps))) (Rlt (Rabs (Rplus x eps)) (Fcore_Raux.bpow beta ex)) *)
rewrite Rabs_pos_eq.
(* Goal: and (Rlt (IZR Z0) (Rminus (ulp (pred (Ropp x))) eps)) (Rle (Rminus (ulp (pred (Ropp x))) eps) (ulp (pred (Ropp x)))) *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
split.
(* Goal: Rle (Fcore_Raux.bpow beta (Z.sub (Z.add e (Zpos xH)) (Zpos xH))) (Fcore_Raux.bpow beta e) *)
(* Goal: Rlt (Fcore_Raux.bpow beta e) (Fcore_Raux.bpow beta (Z.add e (Zpos xH))) *)
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta e) *)
(* Goal: not (@eq R (Fcore_Raux.bpow beta e) (IZR Z0)) *)
ring_simplify (e + 1 - 1)%Z.
(* Goal: Rle (IZR Z0) (IZR Z0) *)
apply Rle_refl.
(* Goal: Rlt (Fcore_Raux.bpow beta e) (Fcore_Raux.bpow beta (Z.add e (Zpos xH))) *)
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta e) *)
(* Goal: not (@eq R (Fcore_Raux.bpow beta e) (IZR Z0)) *)
apply bpow_lt.
(* Goal: Z.lt e (Z.add e (Zpos xH)) *)
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta e) *)
(* Goal: not (@eq R (Fcore_Raux.bpow beta e) (IZR Z0)) *)
apply Zlt_succ.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH)))) *)
(* Goal: Rle (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_ge_0.
(* Goal: not (@eq R (Fcore_Raux.bpow beta e) (IZR Z0)) *)
apply Rgt_not_eq, Rlt_gt, bpow_gt_0.
Qed.


Lemma generic_format_ulp_0:
  F (ulp 0).
Proof.
(* Goal: generic_format beta fexp (ulp (IZR Z0)) *)
unfold ulp.
(* Goal: Rle (if Req_bool (IZR Z0) (IZR Z0) then match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end else Fcore_Raux.bpow beta (canonic_exp beta fexp (IZR Z0))) (ulp x) *)
rewrite Req_bool_true; trivial.
(* Goal: @eq R match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end x *)
case negligible_exp_spec.
(* Goal: generic_format beta fexp (IZR Z0) *)
(* Goal: @eq R (IZR Z0) f *)
intros _; apply generic_format_0.
(* Goal: forall (n : Z) (_ : Z.le n (fexp n)), generic_format beta fexp (Fcore_Raux.bpow beta (fexp n)) *)
intros n H1.
(* Goal: generic_format beta fexp (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
apply generic_format_bpow.
(* Goal: Z.le (fexp (Z.add (fexp n) (Zpos xH))) (fexp n) *)
now apply valid_exp.
Qed.

Lemma generic_format_bpow_ge_ulp_0:  forall e,
    (ulp 0 <= bpow e)%R -> F (bpow e).
Proof.
(* Goal: generic_format beta fexp (ulp (IZR Z0)) *)
intros e; unfold ulp.
(* Goal: Rle (if Req_bool (IZR Z0) (IZR Z0) then match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end else Fcore_Raux.bpow beta (canonic_exp beta fexp (IZR Z0))) (ulp x) *)
rewrite Req_bool_true; trivial.
(* Goal: @eq R match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end x *)
case negligible_exp_spec.
(* Goal: forall (_ : forall n : Z, Z.lt (fexp n) n) (_ : Rle (IZR Z0) (Fcore_Raux.bpow beta e)), generic_format beta fexp (Fcore_Raux.bpow beta e) *)
(* Goal: forall (n : Z) (_ : Z.le n (fexp n)) (_ : Rle (Fcore_Raux.bpow beta (fexp n)) (Fcore_Raux.bpow beta e)), generic_format beta fexp (Fcore_Raux.bpow beta e) *)
intros H1 _.
(* Goal: generic_format beta fexp (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
apply generic_format_bpow.
(* Goal: Z.le (fexp (Z.add e (Zpos xH))) e *)
(* Goal: forall (n : Z) (_ : Z.le n (fexp n)) (_ : Rle (Fcore_Raux.bpow beta (fexp n)) (Fcore_Raux.bpow beta e)), generic_format beta fexp (Fcore_Raux.bpow beta e) *)
specialize (H1 (e+1)%Z); omega.
(* Goal: forall (n : Z) (_ : Z.le n (fexp n)) (_ : Rle (Fcore_Raux.bpow beta (fexp n)) (Fcore_Raux.bpow beta e)), generic_format beta fexp (Fcore_Raux.bpow beta e) *)
intros n H1 H2.
(* Goal: generic_format beta fexp (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
apply generic_format_bpow.
(* Goal: Z.le (fexp (Z.add e (Zpos xH))) e *)
case (Zle_or_lt (e+1) (fexp (e+1))); intros H4.
(* Goal: Z.le (fexp (Z.add e (Zpos xH))) e *)
(* Goal: Z.le (fexp (Z.add e (Zpos xH))) e *)
absurd (e+1 <= e)%Z.
(* Goal: Z.le (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
omega.
(* Goal: Z.le (Z.add e (Zpos xH)) e *)
(* Goal: Z.le (fexp (Z.add e (Zpos xH))) e *)
apply Zle_trans with (1:=H4).
(* Goal: Z.le (fexp (Z.add e (Zpos xH))) e *)
(* Goal: Z.le (fexp (Z.add e (Zpos xH))) e *)
replace (fexp (e+1)) with (fexp n).
(* Goal: Z.le (fexp n) e *)
(* Goal: @eq Z (fexp n) (fexp (Z.add e (Zpos xH))) *)
(* Goal: Z.le (fexp (Z.add e (Zpos xH))) e *)
now apply le_bpow with beta.
(* Goal: @eq Z (fexp n) (fexp (Z.add e (Zpos xH))) *)
(* Goal: Z.le (fexp (Z.add e (Zpos xH))) e *)
now apply fexp_negligible_exp_eq.
(* Goal: Z.le (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
omega.
Qed.

(** The three following properties are equivalent:
      [Exp_not_FTZ] ;  forall x, F (ulp x) ; forall x, ulp 0 <= ulp x *)

Lemma generic_format_ulp: Exp_not_FTZ fexp ->
  forall x,  F (ulp x).
Proof.
(* Goal: forall (_ : Exp_not_FTZ fexp) (x : R), Rle (ulp (IZR Z0)) (ulp x) *)
unfold Exp_not_FTZ; intros H x.
(* Goal: Rle (ulp (IZR Z0)) (ulp x) *)
case (Req_dec x 0); intros Hx.
(* Goal: generic_format beta fexp (ulp x) *)
(* Goal: generic_format beta fexp (ulp x) *)
rewrite Hx; apply generic_format_ulp_0.
(* Goal: generic_format beta fexp (ulp x) *)
rewrite (ulp_neq_0 _ Hx).
(* Goal: generic_format beta fexp (Fcore_Raux.bpow beta (canonic_exp beta fexp x)) *)
apply generic_format_bpow; unfold canonic_exp.
(* Goal: Rle (ulp (IZR Z0)) (ulp (Fcore_Raux.bpow beta (Z.sub e (Zpos xH)))) *)
apply H.
Qed.

Lemma not_FTZ_generic_format_ulp:
   (forall x,  F (ulp x)) -> Exp_not_FTZ fexp.
Proof.
(* Goal: forall _ : forall x : R, Rle (ulp (IZR Z0)) (ulp x), Exp_not_FTZ fexp *)
intros H e.
specialize (H (bpow (e-1))).
rewrite ulp_neq_0 in H.
2: apply Rgt_not_eq, bpow_gt_0.
unfold canonic_exp in H.
rewrite ln_beta_bpow in H.
apply generic_format_bpow_inv' in H...
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
now replace (e-1+1)%Z with e in H by ring.
Qed.


Lemma ulp_ge_ulp_0: Exp_not_FTZ fexp ->
  forall x,  (ulp 0 <= ulp x)%R.
Proof.
(* Goal: forall (_ : Exp_not_FTZ fexp) (x : R), Rle (ulp (IZR Z0)) (ulp x) *)
unfold Exp_not_FTZ; intros H x.
(* Goal: Rle (ulp (IZR Z0)) (ulp x) *)
case (Req_dec x 0); intros Hx.
(* Goal: Rle (ulp (IZR Z0)) (ulp (IZR Z0)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
rewrite Hx; now right.
(* Goal: Rle (ulp (IZR Z0)) (ulp x) *)
unfold ulp at 1.
(* Goal: Rle (if Req_bool (IZR Z0) (IZR Z0) then match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end else Fcore_Raux.bpow beta (canonic_exp beta fexp (IZR Z0))) (ulp x) *)
rewrite Req_bool_true; trivial.
(* Goal: Rle match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end (ulp x) *)
case negligible_exp_spec'.
(* Goal: forall _ : and (@eq (option Z) negligible_exp (@None Z)) (forall n : Z, Z.lt (fexp n) n), Rle match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end (ulp x) *)
(* Goal: forall _ : @ex Z (fun n : Z => and (@eq (option Z) negligible_exp (@Some Z n)) (Z.le n (fexp n))), Rle match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end (ulp x) *)
intros (H1,H2); rewrite H1; apply ulp_ge_0.
(* Goal: forall _ : @ex Z (fun n : Z => and (@eq (option Z) negligible_exp (@Some Z n)) (Z.le n (fexp n))), Rle match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end (ulp x) *)
intros (n,(H1,H2)); rewrite H1.
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite ulp_neq_0; trivial.
(* Goal: Rle (Fcore_Raux.bpow beta (fexp n)) (Fcore_Raux.bpow beta (canonic_exp beta fexp x)) *)
apply bpow_le; unfold canonic_exp.
(* Goal: Z.le (fexp n) (fexp (ln_beta_val beta x (ln_beta beta x))) *)
generalize (ln_beta beta x); intros l.
(* Goal: Z.le (fexp n) (fexp (ln_beta_val beta x l)) *)
case (Zle_or_lt l (fexp l)); intros Hl.
(* Goal: Z.le (fexp n) (fexp (ln_beta_val beta x l)) *)
(* Goal: Z.le (fexp n) (fexp (ln_beta_val beta x l)) *)
rewrite (fexp_negligible_exp_eq n l); trivial; apply Zle_refl.
(* Goal: Z.le (fexp n) (fexp (ln_beta_val beta x l)) *)
case (Zle_or_lt (fexp n) (fexp l)); trivial; intros K.
(* Goal: Z.le (fexp n) (fexp (ln_beta_val beta x l)) *)
absurd (fexp n <= fexp l)%Z.
(* Goal: Z.le (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
omega.
(* Goal: Z.le (fexp n) (fexp (ln_beta_val beta x l)) *)
apply Zle_trans with (2:= H _).
(* Goal: Z.le (fexp n) (fexp (Z.add (fexp (ln_beta_val beta x l)) (Zpos xH))) *)
apply Zeq_le, sym_eq, valid_exp; trivial.
(* Goal: Z.le (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
omega.
Qed.

Lemma not_FTZ_ulp_ge_ulp_0:
   (forall x,  (ulp 0 <= ulp x)%R) -> Exp_not_FTZ fexp.
Proof.
(* Goal: forall _ : forall x : R, Rle (ulp (IZR Z0)) (ulp x), Exp_not_FTZ fexp *)
intros H e.
(* Goal: Z.le (fexp (Z.add (fexp e) (Zpos xH))) (fexp e) *)
apply generic_format_bpow_inv' with beta.
(* Goal: generic_format beta fexp (Fcore_Raux.bpow beta (fexp e)) *)
apply generic_format_bpow_ge_ulp_0.
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
replace e with ((e-1)+1)%Z by ring.
(* Goal: Rle (ulp (IZR Z0)) (Fcore_Raux.bpow beta (fexp (Z.add (Z.sub e (Zpos xH)) (Zpos xH)))) *)
rewrite <- ulp_bpow.
(* Goal: Rle (ulp (IZR Z0)) (ulp (Fcore_Raux.bpow beta (Z.sub e (Zpos xH)))) *)
apply H.
Qed.



Theorem ulp_le_pos :
  forall { Hm : Monotone_exp fexp },
  forall x y: R,
  (0 <= x)%R -> (x <= y)%R ->
  (ulp x <= ulp y)%R.
Proof with auto with typeclass_instances.
intros Hm x y Hx Hxy.
destruct Hx as [Hx|Hx].
(* Goal: Rle (Rplus (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
rewrite ulp_neq_0.
(* Goal: Rle (Rplus (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
rewrite ulp_neq_0.
(* Goal: Rle (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_le.
apply Hm.
now apply ln_beta_le.
(* Goal: not (@eq R x (IZR Z0)) *)
apply Rgt_not_eq, Rlt_gt.
now apply Rlt_le_trans with (1:=Hx).
(* Goal: not (@eq R x (IZR Z0)) *)
now apply Rgt_not_eq.
(* Goal: @eq R (succ (pred x)) x *)
(* Goal: @eq R (succ (pred x)) x *)
rewrite <- Hx.
apply ulp_ge_ulp_0.
apply monotone_exp_not_FTZ...
Qed.


Theorem ulp_le :
  forall { Hm : Monotone_exp fexp },
  forall x y: R,
  (Rabs x <= Rabs y)%R ->
  (ulp x <= ulp y)%R.
Proof.
(* Goal: forall (_ : Monotone_exp fexp) (x y : R) (_ : Rle (Rabs x) (Rabs y)), Rle (ulp x) (ulp y) *)
intros Hm x y Hxy.
(* Goal: Rle (ulp x) (ulp y) *)
rewrite <- ulp_abs.
(* Goal: Rle (ulp (Rabs x)) (ulp y) *)
rewrite <- (ulp_abs y).
(* Goal: Rle (ulp (Rabs x)) (ulp (Rabs y)) *)
apply ulp_le_pos; trivial.
(* Goal: Rle (IZR Z0) (Rabs x) *)
apply Rabs_pos.
Qed.



(** Definition and properties of pred and succ *)

Definition pred_pos x :=
  if Req_bool x (bpow (ln_beta beta x - 1)) then
    (x - bpow (fexp (ln_beta 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.

Theorem pred_eq_pos:
  forall x, (0 <= x)%R -> (pred x = pred_pos x)%R.
Proof.
intros x Hx; unfold pred, succ.
case Rle_bool_spec; intros Hx'.
assert (K:(x = 0)%R).
apply Rle_antisym; try assumption.
apply Ropp_le_cancel.
now rewrite Ropp_0.
rewrite K; unfold pred_pos.
(* Goal: @eq R (if Req_bool (Rabs x) (IZR Z0) then match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end else Fcore_Raux.bpow beta (canonic_exp beta fexp (Rabs x))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x)) *)
rewrite Req_bool_false.
2: apply Rlt_not_eq, bpow_gt_0.
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
rewrite Ropp_0; ring.
(* Goal: @eq R (succ x) (Ropp (Ropp (succ (Ropp (Ropp x))))) *)
now rewrite 2!Ropp_involutive.
Qed.

Theorem succ_eq_pos:
  forall x, (0 <= x)%R -> (succ x = x + ulp x)%R.
Proof.
(* Goal: forall (x : R) (_ : Rle (IZR Z0) x), @eq R (succ x) (Rplus x (ulp x)) *)
intros x Hx; unfold succ.
(* Goal: @eq R (if Rle_bool (IZR Z0) x then Rplus x (ulp x) else Ropp (pred_pos (Ropp x))) (Rplus x (ulp x)) *)
now rewrite Rle_bool_true.
Qed.

Lemma pred_eq_opp_succ_opp: forall x, pred x = (- succ (-x))%R.
Proof.
(* Goal: forall x : R, @eq R (pred x) (Ropp (succ (Ropp x))) *)
reflexivity.
Qed.

Lemma succ_eq_opp_pred_opp: forall x, succ x = (- pred (-x))%R.
Proof.
(* Goal: forall x : R, Rle (pred x) x *)
intros x; unfold pred.
(* Goal: @eq R (succ x) (Ropp (Ropp (succ (Ropp (Ropp x))))) *)
now rewrite 2!Ropp_involutive.
Qed.

Lemma succ_opp: forall x, (succ (-x) = - pred x)%R.
Proof.
(* Goal: forall x : R, @eq R (succ (Ropp x)) (Ropp (pred x)) *)
intros x; rewrite succ_eq_opp_pred_opp.
(* Goal: @eq R (Ropp (succ (Ropp (Ropp x)))) (Ropp (succ x)) *)
now rewrite Ropp_involutive.
Qed.

Lemma pred_opp: forall x, (pred (-x) = - succ x)%R.
Proof.
(* Goal: forall x : R, @eq R (pred (Ropp x)) (Ropp (succ x)) *)
intros x; rewrite pred_eq_opp_succ_opp.
(* Goal: @eq R (Ropp (succ (Ropp (Ropp x)))) (Ropp (succ x)) *)
now rewrite Ropp_involutive.
Qed.




(** pred and succ are in the format *)

(* cannont be x <> ulp 0, due to the counter-example 1-bit FP format fexp: e -> e-1 *)
(* was pred_ge_bpow *)
Theorem id_m_ulp_ge_bpow :
  forall x e,  F x ->
  x <> ulp x ->
  (bpow e < x)%R ->
  (bpow e <= x - ulp x)%R.
Proof.
(* Goal: forall (x : R) (e : Z) (_ : generic_format beta fexp x) (_ : not (@eq R x (ulp x))) (_ : Rlt (Fcore_Raux.bpow beta e) x), Rle (Fcore_Raux.bpow beta e) (Rminus x (ulp x)) *)
intros x e Fx Hx' Hx.
(* *)
(* Goal: Rle (Fcore_Raux.bpow beta e) (Rminus x (ulp x)) *)
assert (1 <= Ztrunc (scaled_mantissa beta fexp x))%Z.
assert (0 <  Ztrunc (scaled_mantissa beta fexp x))%Z.
(* Goal: Z.lt Z0 (Ztrunc (scaled_mantissa beta fexp x)) *)
(* Goal: Rlt (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
(* Goal: Rlt (IZR Z0) (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) *)
(* Goal: Z.le (Zpos xH) (Ztrunc (scaled_mantissa beta fexp x)) *)
(* Goal: not (@eq R x (IZR Z0)) *)
rewrite <- Fx.
(* Goal: Rlt (IZR Z0) x *)
(* Goal: Z.le (Zpos xH) (Ztrunc (scaled_mantissa beta fexp x)) *)
(* Goal: Rle (Fcore_Raux.bpow beta e) (Rminus x (ulp x)) *)
apply Rle_lt_trans with (2:=Hx).
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH)))) *)
(* Goal: Rle (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_ge_0.
(* Goal: Z.le (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
omega.
(* Goal: Rle (Fcore_Raux.bpow beta e) (Rminus x (ulp x)) *)
case (Zle_lt_or_eq _ _ H); intros Hm.
(* *)
(* Goal: Rle (Rplus x (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
pattern x at 1 ; rewrite Fx.
(* Goal: Rle (Rplus (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
rewrite ulp_neq_0.
(* Goal: Rle (Rplus (Rmult (Z2R (@Fnum beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
unfold F2R. simpl.
(* Goal: Rle (Rplus (Rmult (Z2R (Ztrunc (scaled_mantissa beta fexp x))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l.
(* Goal: Rle (Fcore_Raux.bpow beta e) (Rminus (Rmult (Z2R (Ztrunc (scaled_mantissa beta fexp x))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Rmult (IZR (Zpos xH)) (Fcore_Raux.bpow beta (canonic_exp beta fexp x)))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (Fcore_Raux.bpow beta e) (Rminus x (ulp x)) *)
rewrite <- Rmult_minus_distr_r.
(* Goal: Rle (Rmult (Rplus (Z2R (Ztrunc (scaled_mantissa beta fexp x))) (IZR (Zpos xH))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
change 1%R with (Z2R 1).
(* Goal: @eq R (Rminus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (Z2R (Ztrunc (Rminus (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Z2R (Zpos xH))))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rminus x (ulp x)))) (Rlt (Rabs (Rminus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
rewrite <- Z2R_minus.
(* Goal: Rle (Fcore_Raux.bpow beta e) (Rmult (Z2R (Z.sub (Ztrunc (scaled_mantissa beta fexp x)) (Zpos xH))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (Fcore_Raux.bpow beta e) (Rminus x (ulp x)) *)
change (bpow e <= F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) - 1) (canonic_exp beta fexp x)))%R.
(* Goal: Rle (Fcore_Raux.bpow beta e) (@F2R beta (Float beta (Z.sub (Ztrunc (scaled_mantissa beta fexp x)) (Zpos xH)) (canonic_exp beta fexp x))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (Fcore_Raux.bpow beta e) (Rminus x (ulp x)) *)
apply bpow_le_F2R_m1; trivial.
(* Goal: Rlt (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
now rewrite <- Fx.
(* Goal: not (@eq R x (IZR Z0)) *)
apply Rgt_not_eq, Rlt_gt.
(* Goal: Rlt (IZR Z0) x *)
apply Rlt_trans with (2:=Hx), bpow_gt_0.
(* *)
(* Goal: Rle (Fcore_Raux.bpow beta e) (Rminus x (ulp x)) *)
contradict Hx'.
(* Goal: Rle (Rplus x (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
pattern x at 1; rewrite Fx.
rewrite  <- Hm.
(* Goal: Rle (Rplus (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
rewrite ulp_neq_0.
(* Goal: @eq R (Rminus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (@F2R beta (Float beta (Z.sub (Z.pow (radix_val beta) (Z.sub (Z.sub e (Zpos xH)) (fexp (Z.sub e (Zpos xH))))) (Zpos xH)) (fexp (Z.sub e (Zpos xH))))) *)
(* Goal: generic_format beta fexp f *)
(* Goal: generic_format beta fexp f *)
unfold F2R; simpl.
(* Goal: @eq R (Rplus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) (Rplus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (Z2R (Zpos xH)) (Fcore_Raux.bpow beta (fexp ex)))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x (ulp x)))) (Rlt (Rabs (Rplus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
now rewrite Rmult_1_l.
(* Goal: not (@eq R x (IZR Z0)) *)
apply Rgt_not_eq, Rlt_gt.
(* Goal: Rlt (IZR Z0) x *)
apply Rlt_trans with (2:=Hx), bpow_gt_0.
Qed.

(* was succ_le_bpow *)
Theorem id_p_ulp_le_bpow :
  forall x e, (0 < x)%R -> F x ->
  (x < bpow e)%R ->
  (x + ulp x <= bpow e)%R.
Proof.
(* Goal: forall (x : R) (e : Z) (_ : Rlt (IZR Z0) x) (_ : generic_format beta fexp x) (_ : Rlt x (Fcore_Raux.bpow beta e)), Rle (Rplus x (ulp x)) (Fcore_Raux.bpow beta e) *)
intros x e Zx Fx Hx.
(* Goal: Rle (Rplus x (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
pattern x at 1 ; rewrite Fx.
(* Goal: Rle (Rplus (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
rewrite ulp_neq_0.
(* Goal: Rle (Rplus (Rmult (Z2R (@Fnum beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
unfold F2R. simpl.
(* Goal: Rle (Rplus (Rmult (Z2R (Ztrunc (scaled_mantissa beta fexp x))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l.
(* Goal: Rle (Rplus (Rmult (Z2R (Ztrunc (scaled_mantissa beta fexp x))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Rmult (IZR (Zpos xH)) (Fcore_Raux.bpow beta (canonic_exp beta fexp x)))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
rewrite <- Rmult_plus_distr_r.
(* Goal: Rle (Rmult (Rplus (Z2R (Ztrunc (scaled_mantissa beta fexp x))) (IZR (Zpos xH))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
change 1%R with (Z2R 1).
(* Goal: Rle (Rmult (Rplus (Z2R (Ztrunc (scaled_mantissa beta fexp x))) (Z2R (Zpos xH))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
rewrite <- Z2R_plus.
(* Goal: Rle (Rmult (Z2R (Z.add (Ztrunc (scaled_mantissa beta fexp x)) (Zpos xH))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta e) *)
(* Goal: not (@eq R x (IZR Z0)) *)
change (F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) + 1) (canonic_exp beta fexp x)) <= bpow e)%R.
(* Goal: Rle (@F2R beta (Float beta (Z.add (Ztrunc (scaled_mantissa beta fexp x)) (Zpos xH)) (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
apply F2R_p1_le_bpow.
(* Goal: Z.lt Z0 (Ztrunc (scaled_mantissa beta fexp x)) *)
(* Goal: Rlt (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
(* Goal: Rlt (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
now rewrite <- Fx.
(* Goal: Rlt (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
now rewrite <- Fx.
(* Goal: not (@eq R x (IZR Z0)) *)
now apply Rgt_not_eq.
Qed.



Lemma generic_format_pred_aux1:
  forall x, (0 < x)%R -> F x ->
  x <> bpow (ln_beta beta x - 1) ->
  F (x - ulp x).
Proof.
(* Goal: forall (x : R) (_ : Rlt (IZR Z0) x) (_ : generic_format beta fexp x) (_ : not (@eq R x (Fcore_Raux.bpow beta (Z.sub (ln_beta_val beta x (ln_beta beta x)) (Zpos xH))))), generic_format beta fexp (Rminus x (ulp x)) *)
intros x Zx Fx Hx.
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
destruct (ln_beta beta x) as (ex, Ex).
(* Goal: generic_format beta fexp (Rminus x (ulp x)) *)
simpl in Hx.
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
specialize (Ex (Rgt_not_eq _ _ Zx)).
(* Goal: generic_format beta fexp (Rminus x (ulp x)) *)
assert (Ex' : (bpow (ex - 1) < x < bpow ex)%R).
(* Goal: and (Rlt (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) x) (Rlt x (Fcore_Raux.bpow beta ex)) *)
(* Goal: generic_format beta fexp (Rminus x (ulp x)) *)
rewrite Rabs_pos_eq in Ex.
(* Goal: and (Rlt (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) x) (Rlt x (Fcore_Raux.bpow beta ex)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: generic_format beta fexp (Rminus x (ulp x)) *)
destruct Ex as (H,H'); destruct H; split; trivial.
(* Goal: Rlt (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) x *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: generic_format beta fexp (Rminus x (ulp x)) *)
contradict Hx; easy.
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) eps *)
now apply Rlt_le.
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
unfold generic_format, scaled_mantissa, canonic_exp.
(* Goal: @eq R (Rminus x (ulp x)) (@F2R beta (Float beta (Ztrunc (Rmult (Rminus x (ulp x)) (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta (Rminus x (ulp x)) (ln_beta beta (Rminus x (ulp x))))))))) (fexp (ln_beta_val beta (Rminus x (ulp x)) (ln_beta beta (Rminus x (ulp x))))))) *)
rewrite ln_beta_unique with beta (x - ulp x)%R ex.
(* Goal: @eq R (Rplus x (ulp x)) (@F2R beta (Float beta (Ztrunc (Rmult (Rplus x (ulp x)) (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) (fexp ex))) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x (ulp x)))) (Rlt (Rabs (Rplus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
pattern x at 1 3 ; rewrite Fx.
(* Goal: Rle (Rplus (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
rewrite ulp_neq_0.
(* Goal: @eq Z Z0 (Ztrunc (scaled_mantissa beta fexp x)) *)
(* Goal: Rle (IZR Z0) x *)
unfold scaled_mantissa.
(* Goal: @eq Z Z0 (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (canonic_exp beta fexp x))))) *)
(* Goal: Rle (IZR Z0) x *)
rewrite canonic_exp_fexp with (1 := Ex).
(* Goal: Rle (Rplus (Rmult (Z2R (@Fnum beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
unfold F2R. simpl.
(* Goal: @eq R (Rminus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (Rminus (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Z2R (Zpos xH))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rminus x (ulp x)))) (Rlt (Rabs (Rminus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
rewrite Rmult_minus_distr_r.
(* Goal: @eq R (Rplus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (Z2R (Ztrunc (Rplus (Rmult (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Rmult (Fcore_Raux.bpow beta (fexp ex)) (Fcore_Raux.bpow beta (Z.opp (fexp ex))))))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x (ulp x)))) (Rlt (Rabs (Rplus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
rewrite Rmult_assoc.
(* Goal: @eq R (Rplus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (Z2R (Ztrunc (Rplus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Rmult (Fcore_Raux.bpow beta (fexp ex)) (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) (Rmult (Fcore_Raux.bpow beta (fexp ex)) (Fcore_Raux.bpow beta (Z.opp (fexp ex))))))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x (ulp x)))) (Rlt (Rabs (Rplus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
rewrite <- bpow_plus, Zplus_opp_r, Rmult_1_r.
(* Goal: @eq R (Rplus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (Z2R (Ztrunc (Rplus (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta Z0)))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x (ulp x)))) (Rlt (Rabs (Rplus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
change (bpow 0) with (Z2R 1).
(* Goal: @eq R (Rminus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (Z2R (Ztrunc (Rminus (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Z2R (Zpos xH))))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rminus x (ulp x)))) (Rlt (Rabs (Rminus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
rewrite <- Z2R_minus.
(* Goal: @eq R (Rplus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (Z2R (Ztrunc (Z2R (Z.add (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) (Zpos xH))))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x (ulp x)))) (Rlt (Rabs (Rplus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
rewrite Ztrunc_Z2R.
(* Goal: @eq R (Rminus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (Z2R (Z.sub (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) (Zpos xH))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rminus x (ulp x)))) (Rlt (Rabs (Rminus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
rewrite Z2R_minus.
(* Goal: @eq R (Rminus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (Rminus (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Z2R (Zpos xH))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rminus x (ulp x)))) (Rlt (Rabs (Rminus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
rewrite Rmult_minus_distr_r.
(* Goal: @eq R (Rplus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) (Rplus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (Z2R (Zpos xH)) (Fcore_Raux.bpow beta (fexp ex)))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x (ulp x)))) (Rlt (Rabs (Rplus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
now rewrite Rmult_1_l.
(* Goal: not (@eq R x (IZR Z0)) *)
now apply Rgt_not_eq.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x eps))) (Rlt (Rabs (Rplus x eps)) (Fcore_Raux.bpow beta ex)) *)
rewrite Rabs_pos_eq.
(* Goal: and (Rlt (IZR Z0) (Rminus (ulp (pred (Ropp x))) eps)) (Rle (Rminus (ulp (pred (Ropp x))) eps) (ulp (pred (Ropp x)))) *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
split.
(* Goal: Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rminus x (ulp x)) *)
(* Goal: Rlt (Rminus x (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
apply id_m_ulp_ge_bpow; trivial.
(* Goal: Rle (Rplus (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
rewrite ulp_neq_0.
(* Goal: not (@eq R x (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rlt (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) x *)
(* Goal: Rlt (Rminus x (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
intro H.
assert (ex-1 < canonic_exp beta fexp x  < ex)%Z.
(* Goal: and (Z.lt (Z.sub ex (Zpos xH)) (canonic_exp beta fexp x)) (Z.lt (canonic_exp beta fexp x) ex) *)
(* Goal: False *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rlt (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) x *)
(* Goal: Rlt (Rminus x (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
split ; apply (lt_bpow beta) ; rewrite <- H ; easy.
(* Goal: Z.le (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
clear -H0. omega.
(* Goal: not (@eq R x (IZR Z0)) *)
now apply Rgt_not_eq.
(* Goal: Rlt (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) x *)
(* Goal: Rlt (Rminus x (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
apply Ex'.
(* Goal: Rlt (Rminus x (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
apply Rle_lt_trans with (2 := proj2 Ex').
(* Goal: Rle (Rminus x (ulp x)) x *)
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
pattern x at 3 ; rewrite <- Rplus_0_r.
(* Goal: Rle (Rplus x (IZR Z0)) (Rplus x (ulp x)) *)
(* Goal: Rlt (Rplus x (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) (Rplus x (ulp x)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
apply Rplus_le_compat_l.
(* Goal: Rlt (Ropp (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite <-Ropp_0.
(* Goal: Rle (Ropp (succ (Ropp x))) (Ropp (Ropp x)) *)
apply Ropp_le_contravar.
(* Goal: Rle (IZR Z0) (ulp x) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
apply ulp_ge_0.
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
apply Rle_0_minus.
(* Goal: Rle (ulp x) x *)
pattern x at 2; rewrite Fx.
(* Goal: Rle (Rplus (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
rewrite ulp_neq_0.
(* Goal: @eq R (Rminus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (@F2R beta (Float beta (Z.sub (Z.pow (radix_val beta) (Z.sub (Z.sub e (Zpos xH)) (fexp (Z.sub e (Zpos xH))))) (Zpos xH)) (fexp (Z.sub e (Zpos xH))))) *)
(* Goal: generic_format beta fexp f *)
(* Goal: generic_format beta fexp f *)
unfold F2R; simpl.
(* Goal: Rle (Fcore_Raux.bpow beta (canonic_exp beta fexp x)) (Rmult (Z2R (Ztrunc (scaled_mantissa beta fexp x))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
pattern (bpow (canonic_exp beta fexp x)) at 1; rewrite <- Rmult_1_l.
(* Goal: Rle (Rmult (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rmult_le_compat_r.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH)))) *)
(* Goal: Rle (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_ge_0.
(* Goal: forall x : R, @eq R (pred x) (Ropp (succ (Ropp x))) *)
replace 1%R with (Z2R 1) by reflexivity.
(* Goal: Rle (Z2R (Zpos (xO xH))) (Z2R (radix_val beta)) *)
(* Goal: @eq R (Z2R (radix_val beta)) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Z2R_le.
assert (0 <  Ztrunc (scaled_mantissa beta fexp x))%Z.
(* Goal: Z.lt Z0 (Ztrunc (scaled_mantissa beta fexp x)) *)
(* Goal: Rlt (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
(* Goal: Rlt (IZR Z0) (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) *)
(* Goal: Z.le (Zpos xH) (Ztrunc (scaled_mantissa beta fexp x)) *)
(* Goal: not (@eq R x (IZR Z0)) *)
rewrite <- Fx.
(* Goal: Rlt (IZR Z0) x *)
(* Goal: Z.le (Zpos xH) (Ztrunc (scaled_mantissa beta fexp x)) *)
(* Goal: not (@eq R x (IZR Z0)) *)
apply Rle_lt_trans with (2:=proj1 Ex').
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH)))) *)
(* Goal: Rle (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_ge_0.
(* Goal: Z.le (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
omega.
(* Goal: not (@eq R x (IZR Z0)) *)
now apply Rgt_not_eq.
Qed.

Lemma generic_format_pred_aux2 :
  forall x, (0 < x)%R -> F x ->
  let e := ln_beta_val beta x (ln_beta beta x) in
  x =  bpow (e - 1) ->
  F (x - bpow (fexp (e - 1))).
Proof.
(* Goal: forall (x : R) (_ : Rlt (IZR Z0) x) (_ : generic_format beta fexp x), let e := ln_beta_val beta x (ln_beta beta x) in forall _ : @eq R x (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))), generic_format beta fexp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) *)
intros x Zx Fx e Hx.
(* Goal: generic_format beta fexp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) *)
pose (f:=(x - bpow (fexp (e - 1)))%R).
(* Goal: generic_format beta fexp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) *)
fold f.
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
assert (He:(fexp (e-1) <= e-1)%Z).
(* Goal: Z.le (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply generic_format_bpow_inv with beta; trivial.
(* Goal: generic_format beta fexp (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: generic_format beta fexp f *)
rewrite <- Hx; assumption.
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
case (Zle_lt_or_eq _ _ He); clear He; intros He.
(* Goal: generic_format beta fexp f *)
(* Goal: generic_format beta fexp f *)
assert (f = F2R (Float beta (Zpower beta (e-1-(fexp (e-1))) -1) (fexp (e-1))))%R.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub (Z.sub e (Zpos xH)) (Zpos xH))) (Rabs f)) (Rlt (Rabs f) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH)))) *)
(* Goal: generic_format beta fexp f *)
unfold f; rewrite Hx.
(* Goal: @eq R (Rminus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (@F2R beta (Float beta (Z.sub (Z.pow (radix_val beta) (Z.sub (Z.sub e (Zpos xH)) (fexp (Z.sub e (Zpos xH))))) (Zpos xH)) (fexp (Z.sub e (Zpos xH))))) *)
(* Goal: generic_format beta fexp f *)
(* Goal: generic_format beta fexp f *)
unfold F2R; simpl.
(* Goal: @eq R (Rminus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Rmult (Z2R (Z.sub (Z.pow (radix_val beta) (Z.sub (Z.sub e (Zpos xH)) (fexp (Z.sub e (Zpos xH))))) (Zpos xH))) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) *)
(* Goal: generic_format beta fexp f *)
(* Goal: generic_format beta fexp f *)
rewrite Z2R_minus, Z2R_Zpower.
(* Goal: @eq R (Rminus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Rmult (Rminus (Fcore_Raux.bpow beta (Z.sub (Z.sub e (Zpos xH)) (fexp (Z.sub e (Zpos xH))))) (Z2R (Zpos xH))) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) *)
(* Goal: Z.le Z0 (Z.sub (Z.sub e (Zpos xH)) (fexp (Z.sub e (Zpos xH)))) *)
(* Goal: generic_format beta fexp f *)
(* Goal: generic_format beta fexp f *)
rewrite Rmult_minus_distr_r, Rmult_1_l.
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite <- bpow_plus.
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
now replace (e - 1 - fexp (e - 1) + fexp (e - 1))%Z with (e-1)%Z by ring.
(* Goal: Z.le (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
omega.
(* Goal: Rle (Fcore_Raux.bpow beta (fexp (Z.sub (ln_beta_val beta x (ln_beta beta x)) (Zpos xH)))) x *)
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
rewrite H.
(* Goal: generic_format beta fexp (@F2R beta (Float beta (Z.sub (Z.pow (radix_val beta) (Z.sub (Z.sub e (Zpos xH)) (fexp (Z.sub e (Zpos xH))))) (Zpos xH)) (fexp (Z.sub e (Zpos xH))))) *)
(* Goal: generic_format beta fexp f *)
apply generic_format_F2R.
(* Goal: forall _ : not (@eq Z (Z.sub (Z.pow (radix_val beta) (Z.sub (Z.sub e (Zpos xH)) (fexp (Z.sub e (Zpos xH))))) (Zpos xH)) Z0), Z.le (canonic_exp beta fexp (@F2R beta (Float beta (Z.sub (Z.pow (radix_val beta) (Z.sub (Z.sub e (Zpos xH)) (fexp (Z.sub e (Zpos xH))))) (Zpos xH)) (fexp (Z.sub e (Zpos xH)))))) (fexp (Z.sub e (Zpos xH))) *)
(* Goal: generic_format beta fexp f *)
intros _.
(* Goal: Z.le (canonic_exp beta fexp (@F2R beta (Float beta (Z.sub (Z.pow (radix_val beta) (Z.sub (Z.sub e (Zpos xH)) (fexp (Z.sub e (Zpos xH))))) (Zpos xH)) (fexp (Z.sub e (Zpos xH)))))) (fexp (Z.sub e (Zpos xH))) *)
(* Goal: generic_format beta fexp f *)
apply Zeq_le.
(* Goal: @eq Z (canonic_exp beta fexp (@F2R beta (Float beta (Z.sub (Z.pow (radix_val beta) (Z.sub (Z.sub e (Zpos xH)) (fexp (Z.sub e (Zpos xH))))) (Zpos xH)) (fexp (Z.sub e (Zpos xH)))))) (fexp (Z.sub e (Zpos xH))) *)
(* Goal: generic_format beta fexp f *)
apply canonic_exp_fexp.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub (Z.sub e (Zpos xH)) (Zpos xH))) (Rabs (@F2R beta (Float beta (Z.sub (Z.pow (radix_val beta) (Z.sub (Z.sub e (Zpos xH)) (fexp (Z.sub e (Zpos xH))))) (Zpos xH)) (fexp (Z.sub e (Zpos xH))))))) (Rlt (Rabs (@F2R beta (Float beta (Z.sub (Z.pow (radix_val beta) (Z.sub (Z.sub e (Zpos xH)) (fexp (Z.sub e (Zpos xH))))) (Zpos xH)) (fexp (Z.sub e (Zpos xH)))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH)))) *)
(* Goal: generic_format beta fexp f *)
rewrite <- H.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub (Z.sub e (Zpos xH)) (Zpos xH))) (Rabs f)) (Rlt (Rabs f) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH)))) *)
(* Goal: generic_format beta fexp f *)
unfold f; rewrite Hx.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub (Z.sub e (Zpos xH)) (Zpos xH))) (Rabs (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))))) (Rlt (Rabs (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH)))) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite Rabs_right.
(* Goal: and (Rlt (IZR Z0) (Rminus (ulp (pred (Ropp x))) eps)) (Rle (Rminus (ulp (pred (Ropp x))) eps) (ulp (pred (Ropp x)))) *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
split.
(* Goal: Rle (Fcore_Raux.bpow beta (Z.sub (Z.sub e (Zpos xH)) (Zpos xH))) (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rplus_le_reg_l with (bpow (fexp (e-1))).
(* Goal: Rle (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Fcore_Raux.bpow beta (Z.sub (Z.sub e (Zpos xH)) (Zpos xH)))) (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
ring_simplify.
(* Goal: Rle (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Fcore_Raux.bpow beta (Z.sub (Z.sub e (Zpos xH)) (Zpos xH)))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rle_trans with (bpow (e - 2) + bpow (e - 2))%R.
(* Goal: Z.le (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rplus_le_compat ; apply bpow_le ; omega.
(* Goal: Rle (Rplus (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH)))) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rle_trans with (2*bpow (e - 2))%R;[right; ring|idtac].
(* Goal: Rle (Rmult (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rle_trans with (bpow 1*bpow (e - 2))%R.
(* Goal: Rle (Rmult (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rmult_le_compat_r.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH)))) *)
(* Goal: Rle (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_ge_0.
(* Goal: forall x : R, @eq R (pred x) (Ropp (succ (Ropp x))) *)
replace 2%R with (Z2R 2) by reflexivity.
(* Goal: Rle (Z2R (Zpos (xO xH))) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
replace (bpow 1) with (Z2R beta).
(* Goal: Rle (Z2R (Zpos (xO xH))) (Z2R (radix_val beta)) *)
(* Goal: @eq R (Z2R (radix_val beta)) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Z2R_le.
(* Goal: Z.le (Zpos (xO xH)) (radix_val beta) *)
(* Goal: @eq R (Z2R (radix_val beta)) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply <- Zle_is_le_bool.
(* Goal: @eq bool (Z.leb (Zpos (xO xH)) (radix_val beta)) true *)
(* Goal: @eq R (Z2R (radix_val beta)) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
now destruct beta.
(* Goal: Rle (Rplus (Rmult (Z2R (@Fnum beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
simpl.
(* Goal: Rle (Rplus (Rmult (Z2R (@Fnum beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
unfold Zpower_pos; simpl.
(* Goal: @eq R (Z2R (radix_val beta)) (Z2R (Z.mul (radix_val beta) (Zpos xH))) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
now rewrite Zmult_1_r.
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite <- bpow_plus.
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
replace (1+(e-2))%Z with (e-1)%Z by ring.
(* Goal: Rle (ulp (IZR Z0)) (ulp (IZR Z0)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
now right.
(* Goal: Rlt (Rminus x (ulp x)) x *)
rewrite <- Rplus_0_r.
(* Goal: Rlt (Rminus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Rplus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (IZR Z0)) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rplus_lt_compat_l.
(* Goal: Rlt (Ropp (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite <- Ropp_0.
(* Goal: Rlt (Ropp (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Ropp (IZR Z0)) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Ropp_lt_contravar.
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_gt_0.
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
apply Rle_ge; apply Rle_0_minus.
(* Goal: Rle (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_le.
(* Goal: Z.le (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
omega.
(* Goal: generic_format beta fexp f *)
replace f with 0%R.
(* Goal: generic_format beta fexp (IZR Z0) *)
(* Goal: @eq R (IZR Z0) f *)
apply generic_format_0.
(* Goal: generic_format beta fexp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) *)
unfold f.
(* Goal: @eq R (IZR Z0) (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) *)
rewrite Hx, He.
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
ring.
Qed.


Theorem generic_format_succ_aux1 :
  forall x, (0 < x)%R -> F x ->
  F (x + ulp x).
Proof.
(* Goal: forall (x : R) (_ : Rlt (IZR Z0) x) (_ : generic_format beta fexp x), @eq R (Rplus (pred_pos x) (ulp (pred_pos x))) x *)
intros x Zx Fx.
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
destruct (ln_beta beta x) as (ex, Ex).
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
specialize (Ex (Rgt_not_eq _ _ Zx)).
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
assert (Ex' := Ex).
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
rewrite Rabs_pos_eq in Ex'.
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
destruct (id_p_ulp_le_bpow x ex) ; try easy.
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
unfold generic_format, scaled_mantissa, canonic_exp.
(* Goal: @eq R (Rplus x (ulp x)) (@F2R beta (Float beta (Ztrunc (Rmult (Rplus x (ulp x)) (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta (Rplus x (ulp x)) (ln_beta beta (Rplus x (ulp x))))))))) (fexp (ln_beta_val beta (Rplus x (ulp x)) (ln_beta beta (Rplus x (ulp x))))))) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
rewrite ln_beta_unique with beta (x + ulp x)%R ex.
(* Goal: @eq R (Rplus x (ulp x)) (@F2R beta (Float beta (Ztrunc (Rmult (Rplus x (ulp x)) (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) (fexp ex))) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x (ulp x)))) (Rlt (Rabs (Rplus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
pattern x at 1 3 ; rewrite Fx.
(* Goal: Rle (Rplus (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
rewrite ulp_neq_0.
(* Goal: @eq Z Z0 (Ztrunc (scaled_mantissa beta fexp x)) *)
(* Goal: Rle (IZR Z0) x *)
unfold scaled_mantissa.
(* Goal: @eq Z Z0 (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (canonic_exp beta fexp x))))) *)
(* Goal: Rle (IZR Z0) x *)
rewrite canonic_exp_fexp with (1 := Ex).
(* Goal: Rle (Rplus (Rmult (Z2R (@Fnum beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
unfold F2R. simpl.
(* Goal: @eq R (Rplus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (Rplus (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Z2R (Zpos xH))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x (ulp x)))) (Rlt (Rabs (Rplus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
rewrite Rmult_plus_distr_r.
(* Goal: @eq R (Rplus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (Z2R (Ztrunc (Rplus (Rmult (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Rmult (Fcore_Raux.bpow beta (fexp ex)) (Fcore_Raux.bpow beta (Z.opp (fexp ex))))))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x (ulp x)))) (Rlt (Rabs (Rplus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
rewrite Rmult_assoc.
(* Goal: @eq R (Rplus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (Z2R (Ztrunc (Rplus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Rmult (Fcore_Raux.bpow beta (fexp ex)) (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) (Rmult (Fcore_Raux.bpow beta (fexp ex)) (Fcore_Raux.bpow beta (Z.opp (fexp ex))))))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x (ulp x)))) (Rlt (Rabs (Rplus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
rewrite <- bpow_plus, Zplus_opp_r, Rmult_1_r.
(* Goal: @eq R (Rplus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (Z2R (Ztrunc (Rplus (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta Z0)))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x (ulp x)))) (Rlt (Rabs (Rplus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
change (bpow 0) with (Z2R 1).
(* Goal: Rle (Rmult (Rplus (Z2R (Ztrunc (scaled_mantissa beta fexp x))) (Z2R (Zpos xH))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
rewrite <- Z2R_plus.
(* Goal: @eq R (Rplus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (Z2R (Ztrunc (Z2R (Z.add (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) (Zpos xH))))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x (ulp x)))) (Rlt (Rabs (Rplus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
rewrite Ztrunc_Z2R.
(* Goal: @eq R (Rplus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (Z2R (Z.add (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) (Zpos xH))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x (ulp x)))) (Rlt (Rabs (Rplus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
rewrite Z2R_plus.
(* Goal: @eq R (Rplus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (Rplus (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Z2R (Zpos xH))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x (ulp x)))) (Rlt (Rabs (Rplus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
rewrite Rmult_plus_distr_r.
(* Goal: @eq R (Rplus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) (Rplus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (Z2R (Zpos xH)) (Fcore_Raux.bpow beta (fexp ex)))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x (ulp x)))) (Rlt (Rabs (Rplus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
now rewrite Rmult_1_l.
(* Goal: not (@eq R x (IZR Z0)) *)
now apply Rgt_not_eq.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x eps))) (Rlt (Rabs (Rplus x eps)) (Fcore_Raux.bpow beta ex)) *)
rewrite Rabs_pos_eq.
(* Goal: and (Rlt (IZR Z0) (Rminus (ulp (pred (Ropp x))) eps)) (Rle (Rminus (ulp (pred (Ropp x))) eps) (ulp (pred (Ropp x)))) *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
split.
(* Goal: Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rplus x (ulp x)) *)
(* Goal: Rlt (Rplus x (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) (Rplus x (ulp x)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
apply Rle_trans with (1 := proj1 Ex').
(* Goal: Rlt (Rminus x (ulp x)) x *)
pattern x at 1 ; rewrite <- Rplus_0_r.
(* Goal: Rle (Rplus x (IZR Z0)) (Rplus x (ulp x)) *)
(* Goal: Rlt (Rplus x (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) (Rplus x (ulp x)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
apply Rplus_le_compat_l.
(* Goal: Rle (IZR Z0) (ulp x) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
apply ulp_ge_0.
(* Goal: Rlt (Rplus x (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) (Rplus x (ulp x)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
exact H.
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
apply Rplus_le_le_0_compat.
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) eps *)
now apply Rlt_le.
(* Goal: Rle (IZR Z0) (ulp x) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
apply ulp_ge_0.
(* Goal: Rle (Fcore_Raux.bpow beta (fexp (Z.sub (ln_beta_val beta x (ln_beta beta x)) (Zpos xH)))) x *)
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
rewrite H.
(* Goal: generic_format beta fexp (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
apply generic_format_bpow.
(* Goal: Z.le (fexp (Z.add ex (Zpos xH))) ex *)
(* Goal: Rle (IZR Z0) x *)
apply valid_exp.
(* Goal: Z.lt (fexp ex) ex *)
(* Goal: Rle (IZR Z0) x *)
destruct (Zle_or_lt ex (fexp ex)) ; trivial.
(* Goal: Z.lt (fexp ex) ex *)
(* Goal: Rle (IZR Z0) x *)
elim Rlt_not_le with (1 := Zx).
(* Goal: Rle x (IZR Z0) *)
(* Goal: Rle (IZR Z0) x *)
rewrite Fx.
(* Goal: Rle (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (IZR Z0) *)
(* Goal: Rle (IZR Z0) x *)
replace (Ztrunc (scaled_mantissa beta fexp x)) with Z0.
(* Goal: Rle (@F2R beta (Float beta Z0 (canonic_exp beta fexp x))) (IZR Z0) *)
(* Goal: @eq Z Z0 (Ztrunc (scaled_mantissa beta fexp x)) *)
(* Goal: Rle (IZR Z0) x *)
rewrite F2R_0.
(* Goal: Rle (IZR Z0) (IZR Z0) *)
apply Rle_refl.
(* Goal: @eq Z Z0 (Ztrunc (scaled_mantissa beta fexp x)) *)
(* Goal: Rle (IZR Z0) x *)
unfold scaled_mantissa.
(* Goal: @eq Z Z0 (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (canonic_exp beta fexp x))))) *)
(* Goal: Rle (IZR Z0) x *)
rewrite canonic_exp_fexp with (1 := Ex).
(* Goal: @eq Z Z0 (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) *)
(* Goal: Rle (IZR Z0) x *)
destruct (mantissa_small_pos beta fexp x ex) ; trivial.
(* Goal: @eq Z Z0 (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) *)
(* Goal: Rle (IZR Z0) x *)
rewrite Ztrunc_floor.
(* Goal: @eq Z (Z.sub e (Zpos xH)) (ln_beta_val beta (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (ln_beta beta (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))))) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply sym_eq.
(* Goal: @eq Z (Zfloor (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) Z0 *)
(* Goal: Rle (IZR Z0) (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) *)
(* Goal: Rle (IZR Z0) x *)
apply Zfloor_imp.
(* Goal: and (Rlt (IZR Z0) (Rminus (ulp (pred (Ropp x))) eps)) (Rle (Rminus (ulp (pred (Ropp x))) eps) (ulp (pred (Ropp x)))) *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
split.
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) eps *)
now apply Rlt_le.
(* Goal: Rlt (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Z2R (Z.add Z0 (Zpos xH))) *)
(* Goal: Rle (IZR Z0) (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) *)
(* Goal: Rle (IZR Z0) x *)
exact H2.
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) eps *)
now apply Rlt_le.
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) eps *)
now apply Rlt_le.
Qed.

Theorem generic_format_pred_pos :
  forall x, F x -> (0 < x)%R ->
  F (pred_pos x).
Proof.
(* Goal: forall (x : R) (_ : generic_format beta fexp x) (_ : Rlt (IZR Z0) x), generic_format beta fexp (pred_pos x) *)
intros x Fx Zx.
(* Goal: not (Rle (succ y) (succ x)) *)
unfold pred_pos; case Req_bool_spec; intros H.
(* Goal: generic_format beta fexp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub (ln_beta_val beta x (ln_beta beta x)) (Zpos xH))))) *)
(* Goal: generic_format beta fexp (Rminus x (ulp x)) *)
now apply generic_format_pred_aux2.
(* Goal: generic_format beta fexp (Rminus x (ulp x)) *)
now apply generic_format_pred_aux1.
Qed.


Theorem generic_format_succ :
  forall x, F x ->
  F (succ x).
Proof.
(* Goal: forall (x : R) (_ : generic_format beta fexp x), @eq R (pred (succ x)) x *)
intros x Fx.
(* Goal: generic_format beta fexp (succ x) *)
unfold succ; case Rle_bool_spec; intros Zx.
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: generic_format beta fexp (Ropp (pred_pos (Ropp x))) *)
destruct Zx as [Zx|Zx].
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: generic_format beta fexp (Ropp (pred_pos (Ropp x))) *)
now apply generic_format_succ_aux1.
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: generic_format beta fexp (Ropp (pred_pos (Ropp x))) *)
rewrite <- Zx, Rplus_0_l.
(* Goal: generic_format beta fexp (ulp (IZR Z0)) *)
(* Goal: generic_format beta fexp (Ropp (pred_pos (Ropp x))) *)
apply generic_format_ulp_0.
(* Goal: generic_format beta fexp (Ropp (succ (Ropp x))) *)
apply generic_format_opp.
(* Goal: generic_format beta fexp (pred_pos (Ropp x)) *)
apply generic_format_pred_pos.
(* Goal: generic_format beta fexp (Ropp (succ (Ropp x))) *)
now apply generic_format_opp.
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: Rle (Ropp x) (succ (Ropp x)) *)
(* Goal: Rlt (IZR Z0) (succ (Ropp x)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
now apply Ropp_0_gt_lt_contravar.
Qed.

Theorem generic_format_pred :
  forall x, F x ->
  F (pred x).
Proof.
(* Goal: forall (x : R) (_ : generic_format beta fexp x), @eq R (pred (succ x)) x *)
intros x Fx.
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
unfold pred.
(* Goal: generic_format beta fexp (Ropp (succ (Ropp x))) *)
apply generic_format_opp.
(* Goal: generic_format beta fexp (succ (Ropp x)) *)
apply generic_format_succ.
(* Goal: generic_format beta fexp (Ropp (succ (Ropp x))) *)
now apply generic_format_opp.
Qed.



Theorem pred_pos_lt_id :
  forall x, (x <> 0)%R ->
  (pred_pos x < x)%R.
Proof.
(* Goal: forall (x : R) (_ : not (@eq R x (IZR Z0))), Rlt (pred_pos x) x *)
intros x Zx.
(* Goal: @eq R (Rplus (pred_pos x) (ulp (pred_pos x))) x *)
unfold pred_pos.
(* Goal: not (Rle (succ y) (succ x)) *)
case Req_bool_spec; intros H.
(* *)
(* Goal: Rlt (Rminus x (ulp x)) x *)
rewrite <- Rplus_0_r.
(* Goal: Rlt (Rminus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Rplus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (IZR Z0)) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rplus_lt_compat_l.
(* Goal: Rlt (Ropp (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite <- Ropp_0.
(* Goal: Rlt (Ropp (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Ropp (IZR Z0)) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Ropp_lt_contravar.
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_gt_0.
(* *)
(* Goal: Rlt (Rminus x (ulp x)) x *)
rewrite <- Rplus_0_r.
(* Goal: Rlt (Rminus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Rplus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (IZR Z0)) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rplus_lt_compat_l.
(* Goal: Rlt (Ropp (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite <- Ropp_0.
(* Goal: Rlt (Ropp (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Ropp (IZR Z0)) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Ropp_lt_contravar.
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite ulp_neq_0; trivial.
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_gt_0.
Qed.

Theorem succ_gt_id :
  forall x, (x <> 0)%R ->
  (x < succ x)%R.
Proof.
(* Goal: forall (x : R) (_ : not (@eq R x (IZR Z0))), Rlt x (succ x) *)
intros x Zx; unfold succ.
(* Goal: Rlt x (if Rle_bool (IZR Z0) x then Rplus x (ulp x) else Ropp (pred_pos (Ropp x))) *)
case Rle_bool_spec; intros Hx.
(* Goal: Rlt x (Rplus x (ulp x)) *)
(* Goal: Rlt x (Ropp (pred_pos (Ropp x))) *)
pattern x at 1; rewrite <- (Rplus_0_r x).
(* Goal: Rlt (Rminus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Rplus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (IZR Z0)) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rplus_lt_compat_l.
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite ulp_neq_0; trivial.
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_gt_0.
(* Goal: Rlt x (Ropp (pred_pos (Ropp x))) *)
pattern x at 1; rewrite <- (Ropp_involutive x).
(* Goal: Rlt (Ropp (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Ropp (IZR Z0)) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Ropp_lt_contravar.
(* Goal: Rlt (pred_pos (Ropp x)) (Ropp x) *)
apply pred_pos_lt_id.
(* Goal: not (@eq R (Ropp x) (IZR Z0)) *)
now auto with real.
Qed.


Theorem pred_lt_id :
  forall x,  (x <> 0)%R ->
  (pred x < x)%R.
Proof.
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
intros x Zx; unfold pred.
(* Goal: @eq R (round beta fexp Zfloor (Ropp (Ropp (Rplus x eps)))) x *)
pattern x at 2; rewrite <- (Ropp_involutive x).
(* Goal: Rlt (Ropp (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Ropp (IZR Z0)) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Ropp_lt_contravar.
(* Goal: Rlt x (succ x) *)
apply succ_gt_id.
(* Goal: not (@eq R (Ropp x) (IZR Z0)) *)
now auto with real.
Qed.

Theorem succ_ge_id :
  forall x, (x <= succ x)%R.
Proof.
(* Goal: forall x : R, Rle x (succ x) *)
intros x; case (Req_dec x 0).
(* Goal: generic_format beta fexp x *)
intros V; rewrite V.
(* Goal: Rle (IZR Z0) (succ (IZR Z0)) *)
(* Goal: forall _ : not (@eq R x (IZR Z0)), Rle x (succ x) *)
unfold succ; rewrite Rle_bool_true;[idtac|now right].
(* Goal: Rle (IZR Z0) (ulp x) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
rewrite Rplus_0_l; apply ulp_ge_0.
(* Goal: Rlt x (succ x) *)
intros; left; now apply succ_gt_id.
Qed.


Theorem pred_le_id :
  forall x,  (pred x <= x)%R.
Proof.
(* Goal: forall x : R, Rle (pred x) x *)
intros x; unfold pred.
(* Goal: @eq R (round beta fexp Zfloor (Ropp (Ropp (Rplus x eps)))) x *)
pattern x at 2; rewrite <- (Ropp_involutive x).
(* Goal: Rle (Ropp (succ (Ropp x))) (Ropp (Ropp x)) *)
apply Ropp_le_contravar.
(* Goal: Rle (Ropp x) (succ (Ropp x)) *)
(* Goal: Rlt (IZR Z0) (succ (Ropp x)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
apply succ_ge_id.
Qed.


Theorem pred_pos_ge_0 :
  forall x,
  (0 < x)%R -> F x -> (0 <= pred_pos x)%R.
Proof.
(* Goal: forall (x : R) (_ : Rlt (IZR Z0) x) (_ : generic_format beta fexp x), @eq R (Rplus (pred_pos x) (ulp (pred_pos x))) x *)
intros x Zx Fx.
(* Goal: @eq R (Rplus (pred_pos x) (ulp (pred_pos x))) x *)
unfold pred_pos.
(* Goal: not (Rle (succ y) (succ x)) *)
case Req_bool_spec; intros H.
(* *)
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
apply Rle_0_minus.
(* Goal: Rle (Fcore_Raux.bpow beta (fexp (Z.sub (ln_beta_val beta x (ln_beta beta x)) (Zpos xH)))) x *)
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
rewrite H.
(* Goal: Rle (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_le.
(* Goal: Rle (Rplus (Rmult (Z2R (@Fnum beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
destruct (ln_beta beta x) as (ex,Ex) ; simpl.
(* Goal: Z.le (fexp (Z.sub (ln_beta_val beta (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (ln_beta beta (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))))) (Zpos xH))) (Z.sub ex (Zpos xH)) *)
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
rewrite ln_beta_bpow.
(* Goal: Z.le (fexp (Z.sub (Z.add (Z.sub ex (Zpos xH)) (Zpos xH)) (Zpos xH))) (Z.sub ex (Zpos xH)) *)
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
ring_simplify (ex - 1 + 1 - 1)%Z.
(* Goal: Z.le (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply generic_format_bpow_inv with beta; trivial.
(* Goal: generic_format beta fexp (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) *)
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
simpl in H.
(* Goal: generic_format beta fexp (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) *)
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
rewrite <- H; assumption.
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
apply Rle_0_minus.
(* Goal: Rle (ulp (Rabs x)) (Rabs x) *)
now apply ulp_le_id.
Qed.

Theorem pred_ge_0 :
  forall x,
  (0 < x)%R -> F x -> (0 <= pred x)%R.
Proof.
(* Goal: forall (x : R) (_ : Rlt (IZR Z0) x) (_ : generic_format beta fexp x), @eq R (Rplus (pred_pos x) (ulp (pred_pos x))) x *)
intros x Zx Fx.
(* Goal: @eq R (Rplus (pred x) (ulp (pred x))) x *)
(* Goal: Rle (IZR Z0) (pred x) *)
(* Goal: generic_format beta fexp (pred x) *)
rewrite pred_eq_pos.
(* Goal: Rle (IZR Z0) (pred_pos x) *)
(* Goal: Rle (IZR Z0) x *)
now apply pred_pos_ge_0.
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (pred x) *)
(* Goal: generic_format beta fexp (pred x) *)
now left.
Qed.


Lemma pred_pos_plus_ulp_aux1 :
  forall x, (0 < x)%R -> F x ->
  x <> bpow (ln_beta beta x - 1) ->
  ((x - ulp x) + ulp (x-ulp x) = x)%R.
Proof.
(* Goal: forall (x : R) (_ : Rlt (IZR Z0) x) (_ : generic_format beta fexp x) (_ : not (@eq R x (Fcore_Raux.bpow beta (Z.sub (ln_beta_val beta x (ln_beta beta x)) (Zpos xH))))), generic_format beta fexp (Rminus x (ulp x)) *)
intros x Zx Fx Hx.
replace (ulp (x - ulp x)) with (ulp x).
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
ring.
assert (H:(x <> 0)%R) by auto with real.
assert (H':(x <> bpow (canonic_exp beta fexp x))%R).
unfold canonic_exp; intros M.
case_eq (ln_beta beta x); intros ex Hex T.
assert (Lex:(ln_beta_val beta x (ln_beta beta x) = ex)%Z).
(* Goal: forall x : R, @eq R (pred x) (Ropp (succ (Ropp x))) *)
rewrite T; reflexivity.
rewrite Lex in *.
clear T; simpl in *; specialize (Hex H).
rewrite Rabs_right in Hex.
2: apply Rle_ge; apply Rlt_le; easy.
assert (ex-1 < fexp ex  < ex)%Z.
split ; apply (lt_bpow beta); rewrite <- M;[idtac|easy].
destruct (proj1 Hex);[trivial|idtac].
contradict Hx; auto with real.
(* Goal: Z.le (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
omega.
rewrite 2!ulp_neq_0; try auto with real.
(* Goal: @eq R (Ropp (round beta fexp Zceil (Ropp (Rplus x eps)))) (Ropp (Ropp x)) *)
apply f_equal.
(* Goal: @eq R (Ropp (round beta fexp Zceil (Ropp (Rplus x eps)))) (Ropp (Ropp x)) *)
unfold canonic_exp; apply f_equal.
case_eq (ln_beta beta x); intros ex Hex T.
assert (Lex:(ln_beta_val beta x (ln_beta beta x) = ex)%Z).
(* Goal: forall x : R, @eq R (pred x) (Ropp (succ (Ropp x))) *)
rewrite T; reflexivity.
rewrite Lex in *; simpl in *; clear T.
specialize (Hex H).
apply sym_eq, ln_beta_unique.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub (Z.sub e (Zpos xH)) (Zpos xH))) (Rabs (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))))) (Rlt (Rabs (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH)))) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite Rabs_right.
rewrite Rabs_right in Hex.
2: apply Rle_ge; apply Rlt_le; easy.
(* Goal: and (Rlt (IZR Z0) (Rminus (ulp (pred (Ropp x))) eps)) (Rle (Rminus (ulp (pred (Ropp x))) eps) (ulp (pred (Ropp x)))) *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
split.
destruct Hex as ([H1|H1],H2).
apply Rle_trans with (x-ulp x)%R.
(* Goal: Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rminus x (ulp x)) *)
(* Goal: Rlt (Rminus x (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
apply id_m_ulp_ge_bpow; trivial.
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite ulp_neq_0; trivial.
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite ulp_neq_0; trivial.
right; unfold canonic_exp; now rewrite Lex.
contradict Hx; auto with real.
apply Rle_lt_trans with (2:=proj2 Hex).
(* Goal: Rlt (Rminus x (ulp x)) x *)
rewrite <- Rplus_0_r.
(* Goal: Rle (Rplus x (IZR Z0)) (Rplus x (ulp x)) *)
(* Goal: Rlt (Rplus x (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) (Rplus x (ulp x)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
apply Rplus_le_compat_l.
(* Goal: Rlt (Ropp (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite <- Ropp_0.
(* Goal: Rle (Ropp (succ (Ropp x))) (Ropp (Ropp x)) *)
apply Ropp_le_contravar.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH)))) *)
(* Goal: Rle (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_ge_0.
apply Rle_ge.
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
apply Rle_0_minus.
(* Goal: Rle x (IZR Z0) *)
(* Goal: Rle (IZR Z0) x *)
rewrite Fx.
(* Goal: Rle (Rplus (Rmult (Z2R (@Fnum beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
unfold F2R, canonic_exp; simpl.
rewrite Lex.
pattern (bpow (fexp ex)) at 1; rewrite <- Rmult_1_l.
(* Goal: Rle (Rmult (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rmult_le_compat_r.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH)))) *)
(* Goal: Rle (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_ge_0.
(* Goal: forall x : R, @eq R (pred x) (Ropp (succ (Ropp x))) *)
replace 1%R with (Z2R (Zsucc 0)) by reflexivity.
(* Goal: Rle (Z2R (Zpos (xO xH))) (Z2R (radix_val beta)) *)
(* Goal: @eq R (Z2R (radix_val beta)) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Z2R_le.
apply Zlt_le_succ.
(* Goal: Z.lt Z0 (Ztrunc (scaled_mantissa beta fexp x)) *)
(* Goal: Rlt (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
(* Goal: Rlt (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
now rewrite <- Fx.
Qed.


Lemma pred_pos_plus_ulp_aux2 :
  forall x, (0 < x)%R -> F x ->
  let e := ln_beta_val beta x (ln_beta beta x) in
  x =  bpow (e - 1) ->
  (x - bpow (fexp (e-1)) <> 0)%R ->
  ((x - bpow (fexp (e-1))) + ulp (x - bpow (fexp (e-1))) = x)%R.
Proof.
(* Goal: forall (x : R) (_ : Rlt (IZR Z0) x) (_ : generic_format beta fexp x), let e := ln_beta_val beta x (ln_beta beta x) in forall (_ : @eq R x (Fcore_Raux.bpow beta (Z.sub e (Zpos xH)))) (_ : not (@eq R (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0))), @eq R (Rplus (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))))) x *)
intros x Zx Fx e Hxe Zp.
(* Goal: @eq R (Rplus (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))))) x *)
replace (ulp (x - bpow (fexp (e - 1)))) with (bpow (fexp (e - 1))).
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
ring.
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
assert (He:(fexp (e-1) <= e-1)%Z).
(* Goal: Z.le (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply generic_format_bpow_inv with beta; trivial.
(* Goal: generic_format beta fexp (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite <- Hxe; assumption.
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
case (Zle_lt_or_eq _ _ He); clear He; intros He.
(* *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite ulp_neq_0; trivial.
(* Goal: @eq R (Ropp (round beta fexp Zceil (Ropp (Rplus x eps)))) (Ropp (Ropp x)) *)
apply f_equal.
(* Goal: @eq R (Ropp (round beta fexp Zceil (Ropp (Rplus x eps)))) (Ropp (Ropp x)) *)
unfold canonic_exp; apply f_equal.
(* Goal: @eq Z (Z.sub e (Zpos xH)) (ln_beta_val beta (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (ln_beta beta (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))))) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply sym_eq.
(* Goal: @eq Z (ln_beta_val beta (Rplus x eps) (ln_beta beta (Rplus x eps))) ex *)
apply ln_beta_unique.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub (Z.sub e (Zpos xH)) (Zpos xH))) (Rabs (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))))) (Rlt (Rabs (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH)))) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite Rabs_right.
(* Goal: and (Rlt (IZR Z0) (Rminus (ulp (pred (Ropp x))) eps)) (Rle (Rminus (ulp (pred (Ropp x))) eps) (ulp (pred (Ropp x)))) *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
split.
(* Goal: Rle (Fcore_Raux.bpow beta (Z.sub (Z.sub e (Zpos xH)) (Zpos xH))) (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rplus_le_reg_l with (bpow (fexp (e-1))).
(* Goal: Rle (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Fcore_Raux.bpow beta (Z.sub (Z.sub e (Zpos xH)) (Zpos xH)))) (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
ring_simplify.
(* Goal: Rle (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Fcore_Raux.bpow beta (Z.sub (Z.sub e (Zpos xH)) (Zpos xH)))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rle_trans with (bpow (e - 2) + bpow (e - 2))%R.
(* Goal: Z.le (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rplus_le_compat; apply bpow_le; omega.
(* Goal: Rle (Rplus (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH)))) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rle_trans with (2*bpow (e - 2))%R;[right; ring|idtac].
(* Goal: Rle (Rmult (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rle_trans with (bpow 1*bpow (e - 2))%R.
(* Goal: Rle (Rmult (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rmult_le_compat_r.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH)))) *)
(* Goal: Rle (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_ge_0.
(* Goal: forall x : R, @eq R (pred x) (Ropp (succ (Ropp x))) *)
replace 2%R with (Z2R 2) by reflexivity.
(* Goal: Rle (Z2R (Zpos (xO xH))) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
replace (bpow 1) with (Z2R beta).
(* Goal: Rle (Z2R (Zpos (xO xH))) (Z2R (radix_val beta)) *)
(* Goal: @eq R (Z2R (radix_val beta)) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Z2R_le.
(* Goal: Z.le (Zpos (xO xH)) (radix_val beta) *)
(* Goal: @eq R (Z2R (radix_val beta)) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply <- Zle_is_le_bool.
(* Goal: @eq bool (Z.leb (Zpos (xO xH)) (radix_val beta)) true *)
(* Goal: @eq R (Z2R (radix_val beta)) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
now destruct beta.
(* Goal: Rle (Rplus (Rmult (Z2R (@Fnum beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
simpl.
(* Goal: Rle (Rplus (Rmult (Z2R (@Fnum beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
unfold Zpower_pos; simpl.
(* Goal: @eq R (Z2R (radix_val beta)) (Z2R (Z.mul (radix_val beta) (Zpos xH))) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
now rewrite Zmult_1_r.
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite <- bpow_plus.
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
replace (1+(e-2))%Z with (e-1)%Z by ring.
(* Goal: Rle (ulp (IZR Z0)) (ulp (IZR Z0)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
now right.
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite <- Rplus_0_r, Hxe.
(* Goal: Rlt (Rminus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Rplus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (IZR Z0)) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rplus_lt_compat_l.
(* Goal: Rlt (Ropp (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite <- Ropp_0.
(* Goal: Rlt (Ropp (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Ropp (IZR Z0)) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Ropp_lt_contravar.
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_gt_0.
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
apply Rle_ge; apply Rle_0_minus.
(* Goal: Rle (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) x *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite Hxe.
(* Goal: Rle (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_le.
(* Goal: Z.le (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
omega.
(* *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
contradict Zp.
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
rewrite Hxe, He; ring.
Qed.

Lemma pred_pos_plus_ulp_aux3 :
  forall x, (0 < x)%R -> F x ->
  let e := ln_beta_val beta x (ln_beta beta x) in
  x =  bpow (e - 1) ->
  (x - bpow (fexp (e-1)) = 0)%R ->
  (ulp 0 = x)%R.
Proof.
(* Goal: forall (x : R) (_ : Rlt (IZR Z0) x) (_ : generic_format beta fexp x), let e := ln_beta_val beta x (ln_beta beta x) in forall (_ : @eq R x (Fcore_Raux.bpow beta (Z.sub e (Zpos xH)))) (_ : @eq R (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0)), @eq R (ulp (IZR Z0)) x *)
intros x Hx Fx e H1 H2.
(* Goal: @eq R (ulp (IZR Z0)) x *)
assert (H3:(x = bpow (fexp (e - 1)))).
(* Goal: @eq R x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) *)
(* Goal: @eq R (ulp (IZR Z0)) x *)
now apply Rminus_diag_uniq.
(* Goal: @eq R (ulp (IZR Z0)) x *)
assert (H4: (fexp (e-1) = e-1)%Z).
(* Goal: @eq Z (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (ulp (IZR Z0)) x *)
apply bpow_inj with beta.
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: @eq R (ulp (IZR Z0)) x *)
now rewrite <- H1.
(* Goal: Rle (if Req_bool (IZR Z0) (IZR Z0) then match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end else Fcore_Raux.bpow beta (canonic_exp beta fexp (IZR Z0))) (ulp x) *)
unfold ulp; rewrite Req_bool_true; trivial.
(* Goal: @eq R match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end x *)
case negligible_exp_spec.
(* Goal: forall _ : forall n : Z, Z.lt (fexp n) n, @eq R (IZR Z0) x *)
(* Goal: forall (n : Z) (_ : Z.le n (fexp n)), @eq R (Fcore_Raux.bpow beta (fexp n)) x *)
intros K.
(* Goal: @eq R (IZR Z0) x *)
(* Goal: forall (n : Z) (_ : Z.le n (fexp n)), @eq R (Fcore_Raux.bpow beta (fexp n)) x *)
specialize (K (e-1)%Z).
(* Goal: Z.le (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
contradict K; omega.
(* Goal: forall (n : Z) (_ : Z.le n (fexp n)), @eq R (Fcore_Raux.bpow beta (fexp n)) x *)
intros n Hn.
(* Goal: @eq R (Ropp (round beta fexp Zceil (Ropp (Rplus x eps)))) (Ropp (Ropp x)) *)
rewrite H3; apply f_equal.
(* Goal: @eq Z (fexp n) (fexp (Z.sub e (Zpos xH))) *)
case (Zle_or_lt n (e-1)); intros H6.
(* Goal: @eq Z (fexp n) (fexp (Z.sub e (Zpos xH))) *)
(* Goal: @eq Z (fexp n) (fexp (Z.sub e (Zpos xH))) *)
apply valid_exp; omega.
(* Goal: @eq Z (fexp n) (fexp (Z.sub e (Zpos xH))) *)
apply sym_eq, valid_exp; omega.
Qed.




(** The following one is false for x = 0 in FTZ *)

Theorem pred_pos_plus_ulp :
  forall x, (0 < x)%R -> F x ->
  (pred_pos x + ulp (pred_pos x) = x)%R.
Proof.
(* Goal: forall (x : R) (_ : Rlt (IZR Z0) x) (_ : generic_format beta fexp x), @eq R (Rplus (pred_pos x) (ulp (pred_pos x))) x *)
intros x Zx Fx.
(* Goal: @eq R (Rplus (pred_pos x) (ulp (pred_pos x))) x *)
unfold pred_pos.
(* Goal: not (Rle (succ y) (succ x)) *)
case Req_bool_spec; intros H.
(* Goal: @eq R (Rplus (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub (ln_beta_val beta x (ln_beta beta x)) (Zpos xH))))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub (ln_beta_val beta x (ln_beta beta x)) (Zpos xH))))))) x *)
(* Goal: @eq R (Rplus (Rminus x (ulp x)) (ulp (Rminus x (ulp x)))) x *)
case (Req_EM_T (x - bpow (fexp (ln_beta_val beta x (ln_beta beta x) -1))) 0); intros H1.
(* Goal: @eq R (Rplus (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub (ln_beta_val beta x (ln_beta beta x)) (Zpos xH))))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub (ln_beta_val beta x (ln_beta beta x)) (Zpos xH))))))) x *)
(* Goal: @eq R (Rplus (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub (ln_beta_val beta x (ln_beta beta x)) (Zpos xH))))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub (ln_beta_val beta x (ln_beta beta x)) (Zpos xH))))))) x *)
(* Goal: @eq R (Rplus (Rminus x (ulp x)) (ulp (Rminus x (ulp x)))) x *)
rewrite H1, Rplus_0_l.
(* Goal: @eq R (ulp (IZR Z0)) x *)
(* Goal: @eq R (Rplus (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub (ln_beta_val beta x (ln_beta beta x)) (Zpos xH))))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub (ln_beta_val beta x (ln_beta beta x)) (Zpos xH))))))) x *)
(* Goal: @eq R (Rplus (Rminus x (ulp x)) (ulp (Rminus x (ulp x)))) x *)
now apply pred_pos_plus_ulp_aux3.
(* Goal: @eq R (Rplus (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub (ln_beta_val beta x (ln_beta beta x)) (Zpos xH))))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub (ln_beta_val beta x (ln_beta beta x)) (Zpos xH))))))) x *)
(* Goal: @eq R (Rplus (Rminus x (ulp x)) (ulp (Rminus x (ulp x)))) x *)
now apply pred_pos_plus_ulp_aux2.
(* Goal: @eq R (Rplus (Rminus x (ulp x)) (ulp (Rminus x (ulp x)))) x *)
now apply pred_pos_plus_ulp_aux1.
Qed.




(** Rounding x + small epsilon *)

Theorem ln_beta_plus_eps:
  forall x, (0 < x)%R -> F x ->
  forall eps, (0 <= eps < ulp x)%R ->
  ln_beta beta (x + eps) = ln_beta beta x :> Z.
Proof.
(* Goal: forall (x : R) (_ : Rlt (IZR Z0) x) (_ : generic_format beta fexp x) (eps : R) (_ : and (Rle (IZR Z0) eps) (Rlt eps (ulp x))), @eq Z (ln_beta_val beta (Rplus x eps) (ln_beta beta (Rplus x eps))) (ln_beta_val beta x (ln_beta beta x)) *)
intros x Zx Fx eps Heps.
(* Goal: @eq Z (ln_beta_val beta (Rplus x eps) (ln_beta beta (Rplus x eps))) (ln_beta_val beta x (ln_beta beta x)) *)
destruct (ln_beta beta x) as (ex, He).
(* Goal: Rle (Rplus (Rmult (Z2R (@Fnum beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
simpl.
(* Goal: @eq Z (ln_beta_val beta (Rplus x eps) (ln_beta beta (Rplus x eps))) ex *)
specialize (He (Rgt_not_eq _ _ Zx)).
(* Goal: @eq Z (ln_beta_val beta (Rplus x eps) (ln_beta beta (Rplus x eps))) ex *)
apply ln_beta_unique.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x eps))) (Rlt (Rabs (Rplus x eps)) (Fcore_Raux.bpow beta ex)) *)
rewrite Rabs_pos_eq.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rplus x eps)) (Rlt (Rplus x eps) (Fcore_Raux.bpow beta ex)) *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
rewrite Rabs_pos_eq in He.
(* Goal: and (Rlt (IZR Z0) (Rminus (ulp (pred (Ropp x))) eps)) (Rle (Rminus (ulp (pred (Ropp x))) eps) (ulp (pred (Ropp x)))) *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
split.
(* Goal: Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rplus x eps) *)
(* Goal: Rlt (Rplus x eps) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
apply Rle_trans with (1 := proj1 He).
(* Goal: Rlt (Rminus x (ulp x)) x *)
pattern x at 1 ; rewrite <- Rplus_0_r.
(* Goal: Rle (Rplus x (IZR Z0)) (Rplus x (ulp x)) *)
(* Goal: Rlt (Rplus x (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) (Rplus x (ulp x)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
now apply Rplus_le_compat_l.
(* Goal: Rlt (Rplus x eps) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
apply Rlt_le_trans with (x + ulp x)%R.
(* Goal: Rlt (Rminus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Rplus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (IZR Z0)) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
now apply Rplus_lt_compat_l.
(* Goal: Rle (Rplus x (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
pattern x at 1 ; rewrite Fx.
(* Goal: Rle (Rplus (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
rewrite ulp_neq_0.
(* Goal: Rle (Rplus (Rmult (Z2R (@Fnum beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
unfold F2R. simpl.
(* Goal: Rle (Rplus (Rmult (Z2R (Ztrunc (scaled_mantissa beta fexp x))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l.
(* Goal: Rle (Rplus (Rmult (Z2R (Ztrunc (scaled_mantissa beta fexp x))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Rmult (IZR (Zpos xH)) (Fcore_Raux.bpow beta (canonic_exp beta fexp x)))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
rewrite <- Rmult_plus_distr_r.
(* Goal: Rle (Rmult (Rplus (Z2R (Ztrunc (scaled_mantissa beta fexp x))) (IZR (Zpos xH))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
change 1%R with (Z2R 1).
(* Goal: Rle (Rmult (Rplus (Z2R (Ztrunc (scaled_mantissa beta fexp x))) (Z2R (Zpos xH))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
rewrite <- Z2R_plus.
(* Goal: Rle (Rmult (Z2R (Z.add (Ztrunc (scaled_mantissa beta fexp x)) (Zpos xH))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
change (F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) + 1) (canonic_exp beta fexp x)) <= bpow ex)%R.
(* Goal: Rle (@F2R beta (Float beta (Z.add (Ztrunc (scaled_mantissa beta fexp x)) (Zpos xH)) (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
apply F2R_p1_le_bpow.
(* Goal: Z.lt Z0 (Ztrunc (scaled_mantissa beta fexp x)) *)
(* Goal: Rlt (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
(* Goal: Rlt (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
now rewrite <- Fx.
(* Goal: Rlt (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
now rewrite <- Fx.
(* Goal: not (@eq R x (IZR Z0)) *)
now apply Rgt_not_eq.
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) eps *)
now apply Rlt_le.
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
apply Rplus_le_le_0_compat.
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) eps *)
now apply Rlt_le.
(* Goal: Rle (IZR Z0) eps *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
apply Heps.
Qed.

Theorem round_DN_plus_eps_pos:
  forall x, (0 <= x)%R -> F x ->
  forall eps, (0 <= eps < ulp x)%R ->
  round beta fexp Zfloor (x + eps) = x.
Proof.
(* Goal: forall (x : R) (_ : Rlt (IZR Z0) x) (_ : generic_format beta fexp x) (eps : R) (_ : and (Rle (IZR Z0) eps) (Rlt eps (ulp x))), @eq Z (ln_beta_val beta (Rplus x eps) (ln_beta beta (Rplus x eps))) (ln_beta_val beta x (ln_beta beta x)) *)
intros x Zx Fx eps Heps.
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: generic_format beta fexp (Ropp (pred_pos (Ropp x))) *)
destruct Zx as [Zx|Zx].
(* . 0 < x *)
(* Goal: Rle x (IZR Z0) *)
(* Goal: Rle (IZR Z0) x *)
pattern x at 2 ; rewrite Fx.
(* Goal: @eq R (round beta fexp Zceil x) (Rplus (round beta fexp Zfloor x) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
unfold round.
(* Goal: Rle (Rplus (Rmult (Z2R (@Fnum beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
unfold scaled_mantissa. simpl.
unfold canonic_exp at 1 2.
rewrite ln_beta_plus_eps ; trivial.
apply (f_equal (fun m => F2R (Float beta m _))).
(* Goal: @eq Z Z0 (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) *)
(* Goal: Rle (IZR Z0) x *)
rewrite Ztrunc_floor.
(* Goal: @eq Z (Zfloor (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) Z0 *)
(* Goal: Rle (IZR Z0) (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) *)
(* Goal: Rle (IZR Z0) x *)
apply Zfloor_imp.
(* Goal: and (Rlt (IZR Z0) (Rminus (ulp (pred (Ropp x))) eps)) (Rle (Rminus (ulp (pred (Ropp x))) eps) (ulp (pred (Ropp x)))) *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
split.
apply (Rle_trans _ _ _ (Zfloor_lb _)).
(* Goal: Rle (Rmult (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rmult_le_compat_r.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH)))) *)
(* Goal: Rle (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_ge_0.
(* Goal: Rlt (Rminus x (ulp x)) x *)
pattern x at 1 ; rewrite <- Rplus_0_r.
(* Goal: Rle (Rplus x (IZR Z0)) (Rplus x (ulp x)) *)
(* Goal: Rlt (Rplus x (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) (Rplus x (ulp x)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
now apply Rplus_le_compat_l.
apply Rlt_le_trans with ((x + ulp x) * bpow (- canonic_exp beta fexp x))%R.
apply Rmult_lt_compat_r.
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_gt_0.
(* Goal: Rlt (Rminus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Rplus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (IZR Z0)) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
now apply Rplus_lt_compat_l.
(* Goal: @eq R (Rplus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (Rplus (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Z2R (Zpos xH))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x (ulp x)))) (Rlt (Rabs (Rplus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
rewrite Rmult_plus_distr_r.
(* Goal: @eq R (Rplus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (Z2R (Z.add (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) (Zpos xH))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x (ulp x)))) (Rlt (Rabs (Rplus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
rewrite Z2R_plus.
apply Rplus_le_compat.
(* Goal: @eq R (Rplus x (ulp x)) (@F2R beta (Float beta (Ztrunc (Rmult (Rplus x (ulp x)) (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) (fexp ex))) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x (ulp x)))) (Rlt (Rabs (Rplus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
pattern x at 1 3 ; rewrite Fx.
(* Goal: Rle (Rplus (Rmult (Z2R (@Fnum beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
unfold F2R. simpl.
(* Goal: @eq R (Rplus (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (Z2R (Ztrunc (Rplus (Rmult (Rmult (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Rmult (Fcore_Raux.bpow beta (fexp ex)) (Fcore_Raux.bpow beta (Z.opp (fexp ex))))))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x (ulp x)))) (Rlt (Rabs (Rplus x (ulp x))) (Fcore_Raux.bpow beta ex)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
rewrite Rmult_assoc.
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite <- bpow_plus.
rewrite Zplus_opp_r.
rewrite Rmult_1_r.
rewrite Zfloor_Z2R.
(* Goal: Rle (IZR Z0) (IZR Z0) *)
apply Rle_refl.
(* Goal: Rle (Rplus (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (ulp x)) (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
rewrite ulp_neq_0.
2: now apply Rgt_not_eq.
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite <- bpow_plus.
rewrite Zplus_opp_r.
(* Goal: Rle (IZR Z0) (IZR Z0) *)
apply Rle_refl.
apply Rmult_le_pos.
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) eps *)
now apply Rlt_le.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH)))) *)
(* Goal: Rle (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_ge_0.
(* . x=0 *)
rewrite <- Zx, Rplus_0_l; rewrite <- Zx in Heps.
case (proj1 Heps); intros P.
unfold round, scaled_mantissa, canonic_exp.
(* Goal: generic_format beta fexp (ulp (IZR Z0)) *)
revert Heps; unfold ulp.
(* Goal: Rle (if Req_bool (IZR Z0) (IZR Z0) then match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end else Fcore_Raux.bpow beta (canonic_exp beta fexp (IZR Z0))) (ulp x) *)
rewrite Req_bool_true; trivial.
(* Goal: @eq R match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end x *)
case negligible_exp_spec.
intros _ (H1,H2).
absurd (0 < 0)%R; auto with real.
now apply Rle_lt_trans with (1:=H1).
intros n Hn H.
assert (fexp (ln_beta beta eps) = fexp n).
apply valid_exp; try assumption.
assert(ln_beta beta eps-1 < fexp n)%Z;[idtac|omega].
apply lt_bpow with beta.
apply Rle_lt_trans with (2:=proj2 H).
destruct (ln_beta beta eps) as (e,He).
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rplus x eps)) (Rlt (Rplus x eps) (Fcore_Raux.bpow beta ex)) *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
simpl; rewrite Rabs_pos_eq in He.
now apply He, Rgt_not_eq.
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (pred x) *)
(* Goal: generic_format beta fexp (pred x) *)
now left.
replace (Zfloor (eps * bpow (- fexp (ln_beta beta eps)))) with 0%Z.
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
unfold F2R; simpl; ring.
apply sym_eq, Zfloor_imp.
(* Goal: and (Rlt (IZR Z0) (Rminus (ulp (pred (Ropp x))) eps)) (Rle (Rminus (ulp (pred (Ropp x))) eps) (ulp (pred (Ropp x)))) *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
split.
apply Rmult_le_pos.
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (pred x) *)
(* Goal: generic_format beta fexp (pred x) *)
now left.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH)))) *)
(* Goal: Rle (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_ge_0.
apply Rmult_lt_reg_r with (bpow (fexp n)).
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
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.
(* Goal: Rle (ulp (IZR Z0)) (ulp (Fcore_Raux.bpow beta (Z.sub e (Zpos xH)))) *)
apply H.
rewrite <- P, round_0; trivial.
apply valid_rnd_DN.
Qed.


Theorem round_UP_plus_eps_pos :
  forall x, (0 <= x)%R -> F x ->
  forall eps, (0 < eps <= ulp x)%R ->
  round beta fexp Zceil (x + eps) = (x + ulp x)%R.
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).
(* Goal: and (Rlt (IZR Z0) (Rminus (ulp (pred (Ropp x))) eps)) (Rle (Rminus (ulp (pred (Ropp x))) eps) (ulp (pred (Ropp x)))) *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
split.
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) eps *)
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 canonic_exp.
now rewrite ln_beta_plus_eps.
(* Goal: not (@eq R x (IZR Z0)) *)
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).
(* Goal: Rlt (Rminus x (ulp x)) x *)
pattern x at 2 ; rewrite <- Rplus_0_r.
(* Goal: Rlt (Rminus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Rplus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (IZR Z0)) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
now apply Rplus_lt_compat_l.
rewrite Heps2.
apply round_generic...
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: generic_format beta fexp (Ropp (pred_pos (Ropp x))) *)
now apply generic_format_succ_aux1.
(* . x=0 *)
rewrite <- Zx1, 2!Rplus_0_l.
intros Heps.
case (proj2 Heps).
unfold round, scaled_mantissa, canonic_exp.
(* Goal: generic_format beta fexp (ulp (IZR Z0)) *)
unfold ulp.
(* Goal: Rle (if Req_bool (IZR Z0) (IZR Z0) then match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end else Fcore_Raux.bpow beta (canonic_exp beta fexp (IZR Z0))) (ulp x) *)
rewrite Req_bool_true; trivial.
(* Goal: @eq R match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end x *)
case negligible_exp_spec.
intros H2.
intros J; absurd (0 < 0)%R; auto with real.
(* Goal: Rle (IZR Z0) eps *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
apply Rlt_trans with eps; try assumption; apply Heps.
intros n Hn H.
assert (fexp (ln_beta beta eps) = fexp n).
apply valid_exp; try assumption.
assert(ln_beta beta eps-1 < fexp n)%Z;[idtac|omega].
apply lt_bpow with beta.
apply Rle_lt_trans with (2:=H).
destruct (ln_beta beta eps) as (e,He).
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rplus x eps)) (Rlt (Rplus x eps) (Fcore_Raux.bpow beta ex)) *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
simpl; rewrite Rabs_pos_eq in He.
now apply He, Rgt_not_eq.
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (pred x) *)
(* Goal: generic_format beta fexp (pred x) *)
now left.
replace (Zceil (eps * bpow (- fexp (ln_beta beta eps)))) with 1%Z.
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
unfold F2R; simpl; rewrite H0; ring.
apply sym_eq, Zceil_imp.
(* Goal: and (Rlt (IZR Z0) (Rminus (ulp (pred (Ropp x))) eps)) (Rle (Rminus (ulp (pred (Ropp x))) eps) (ulp (pred (Ropp x)))) *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
split.
simpl; apply Rmult_lt_0_compat.
(* Goal: Rle (IZR Z0) eps *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
apply Heps.
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_gt_0.
apply Rmult_le_reg_r with (bpow (fexp n)).
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
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.
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (pred x) *)
(* Goal: generic_format beta fexp (pred x) *)
now left.
intros P; rewrite P.
apply round_generic...
(* Goal: generic_format beta fexp (ulp (IZR Z0)) *)
(* Goal: generic_format beta fexp (Ropp (pred_pos (Ropp x))) *)
apply generic_format_ulp_0.
Qed.


Theorem round_UP_pred_plus_eps_pos :
  forall x, (0 < x)%R -> F x ->
  forall eps, (0 < eps <= ulp (pred x) )%R ->
  round beta fexp Zceil (pred x + eps) = x.
Proof.
(* Goal: forall (x : R) (_ : Rlt (IZR Z0) x) (_ : generic_format beta fexp x) (eps : R) (_ : and (Rlt (IZR Z0) eps) (Rle eps (ulp (pred x)))), @eq R (round beta fexp Zceil (Rplus (pred x) eps)) x *)
intros x Hx Fx eps Heps.
(* Goal: @eq R (round beta fexp Zceil (Rplus (pred x) eps)) x *)
rewrite round_UP_plus_eps_pos; trivial.
(* Goal: @eq R (Rplus (pred x) (ulp (pred x))) x *)
(* Goal: Rle (IZR Z0) (pred x) *)
(* Goal: generic_format beta fexp (pred x) *)
rewrite pred_eq_pos.
(* Goal: @eq R (Rplus (pred_pos x) (ulp (pred_pos x))) x *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (pred x) *)
(* Goal: generic_format beta fexp (pred x) *)
apply pred_pos_plus_ulp; trivial.
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (pred x) *)
(* Goal: generic_format beta fexp (pred x) *)
now left.
(* Goal: Rle (IZR Z0) (pred x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
now apply pred_ge_0.
(* Goal: generic_format beta fexp (pred x) *)
apply generic_format_pred; trivial.
Qed.

Theorem round_DN_minus_eps_pos :
  forall x,  (0 < x)%R -> F x ->
  forall eps, (0 < eps <= ulp (pred x))%R ->
  round beta fexp Zfloor (x - eps) = pred x.
Proof.
intros x Hpx Fx eps.
rewrite pred_eq_pos;[intros Heps|now left].
replace (x-eps)%R with (pred_pos x + (ulp (pred_pos x)-eps))%R.
2: pattern x at 3; rewrite <- (pred_pos_plus_ulp x); trivial.
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
2: ring.
rewrite round_DN_plus_eps_pos; trivial.
(* Goal: Rle (IZR Z0) (pred_pos x) *)
(* Goal: Rle (IZR Z0) x *)
now apply pred_pos_ge_0.
(* Goal: generic_format beta fexp (pred_pos (Ropp x)) *)
now apply generic_format_pred_pos.
(* Goal: and (Rlt (IZR Z0) (Rminus (ulp (pred (Ropp x))) eps)) (Rle (Rminus (ulp (pred (Ropp x))) eps) (ulp (pred (Ropp x)))) *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
split.
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
apply Rle_0_minus.
(* Goal: Rle (IZR Z0) eps *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
now apply Heps.
(* Goal: Rlt (Rminus x (ulp x)) x *)
rewrite <- Rplus_0_r.
(* Goal: Rlt (Rminus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Rplus (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (IZR Z0)) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rplus_lt_compat_l.
(* Goal: Rlt (Ropp (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite <- Ropp_0.
(* Goal: Rlt (Ropp (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Ropp (IZR Z0)) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Ropp_lt_contravar.
(* Goal: Rle (IZR Z0) eps *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
now apply Heps.
Qed.


Theorem round_DN_plus_eps:
  forall x, F x ->
  forall eps, (0 <= eps < if (Rle_bool 0 x) then (ulp x)
                                     else (ulp (pred (-x))))%R ->
  round beta fexp Zfloor (x + eps) = x.
Proof.
(* Goal: forall (x : R) (_ : generic_format beta fexp x) (eps : R) (_ : and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool x (IZR Z0) then ulp x else ulp (pred x)))), @eq R (round beta fexp Zfloor (Rminus x eps)) (pred x) *)
intros x Fx eps Heps.
(* Goal: @eq R (round beta fexp Zfloor (Rplus x eps)) x *)
case (Rle_or_lt 0 x); intros Zx.
(* Goal: @eq R (round beta fexp Zfloor (Rplus x eps)) x *)
(* Goal: @eq R (round beta fexp Zfloor (Rplus x eps)) x *)
apply round_DN_plus_eps_pos; try assumption.
(* Goal: Rle (IZR Z0) eps *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
split; try apply Heps.
(* Goal: Rlt eps (ulp x) *)
(* Goal: @eq R (round beta fexp Zfloor (Rplus x eps)) x *)
rewrite Rle_bool_true in Heps; trivial.
(* Goal: Rle (IZR Z0) eps *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
now apply Heps.
(* *)
(* Goal: @eq R (round beta fexp Zfloor (Rplus x eps)) x *)
rewrite Rle_bool_false in Heps; trivial.
(* Goal: @eq R (round beta fexp Zfloor (Rplus x eps)) x *)
rewrite <- (Ropp_involutive (x+eps)).
(* Goal: @eq R (round beta fexp Zfloor (Ropp (Ropp (Rplus x eps)))) x *)
pattern x at 2; rewrite <- (Ropp_involutive x).
(* Goal: @eq R (round beta fexp Zfloor (Ropp (Rplus (Ropp x) eps))) (pred x) *)
rewrite round_DN_opp.
(* Goal: @eq R (Ropp (round beta fexp Zceil (Ropp (Rplus x eps)))) (Ropp (Ropp x)) *)
apply f_equal.
(* Goal: @eq R (round beta fexp Zceil (Ropp (Rplus x eps))) (Ropp x) *)
replace (-(x+eps))%R with (pred (-x) + (ulp (pred (-x)) - eps))%R.
(* Goal: forall x : R, @eq R (pred x) (Ropp (succ (Ropp x))) *)
rewrite round_UP_pred_plus_eps_pos; try reflexivity.
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: Rle (Ropp x) (succ (Ropp x)) *)
(* Goal: Rlt (IZR Z0) (succ (Ropp x)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
now apply Ropp_0_gt_lt_contravar.
(* Goal: generic_format beta fexp (Ropp (succ (Ropp x))) *)
now apply generic_format_opp.
(* Goal: and (Rlt (IZR Z0) (Rminus (ulp (pred (Ropp x))) eps)) (Rle (Rminus (ulp (pred (Ropp x))) eps) (ulp (pred (Ropp x)))) *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
split.
(* Goal: Rle (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Fcore_Raux.bpow beta (Z.sub (Z.sub e (Zpos xH)) (Zpos xH)))) (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rplus_lt_reg_l with eps; ring_simplify.
(* Goal: Rle (IZR Z0) eps *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
apply Heps.
(* Goal: Rle (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Fcore_Raux.bpow beta (Z.sub (Z.sub e (Zpos xH)) (Zpos xH)))) (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rplus_le_reg_l with (eps-ulp (pred (- x)))%R; ring_simplify.
(* Goal: Rle (IZR Z0) eps *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
apply Heps.
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
unfold pred.
(* Goal: @eq R (Rplus (Ropp (succ (Ropp (Ropp x)))) (Rminus (ulp (Ropp (succ (Ropp (Ropp x))))) eps)) (Ropp (Rplus x eps)) *)
rewrite Ropp_involutive.
(* Goal: @eq R (Rplus (Ropp (succ x)) (Rminus (ulp (Ropp (succ x))) eps)) (Ropp (Rplus x eps)) *)
unfold succ; rewrite Rle_bool_false; try assumption.
(* Goal: @eq R (Rplus (Ropp (Ropp (pred_pos (Ropp x)))) (Rminus (ulp (Ropp (Ropp (pred_pos (Ropp x))))) eps)) (Ropp (Rplus x eps)) *)
rewrite Ropp_involutive; unfold Rminus.
(* Goal: @eq R (Rplus (pred_pos (Ropp x)) (Rplus (ulp (pred_pos (Ropp x))) (Ropp eps))) (Ropp (Rplus x eps)) *)
rewrite <- Rplus_assoc, pred_pos_plus_ulp.
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
ring.
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: Rle (Ropp x) (succ (Ropp x)) *)
(* Goal: Rlt (IZR Z0) (succ (Ropp x)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
now apply Ropp_0_gt_lt_contravar.
(* Goal: generic_format beta fexp (Ropp (succ (Ropp x))) *)
now apply generic_format_opp.
Qed.


Theorem round_UP_plus_eps :
  forall x, F x ->
  forall eps, (0 < eps <= if (Rle_bool 0 x) then (ulp x)
                                     else (ulp (pred (-x))))%R ->
  round beta fexp Zceil (x + eps) = (succ x)%R.
Proof with auto with typeclass_instances.
(* Goal: forall (x : R) (_ : generic_format beta fexp x) (eps : R) (_ : and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool x (IZR Z0) then ulp x else ulp (pred x)))), @eq R (round beta fexp Zfloor (Rminus x eps)) (pred x) *)
intros x Fx eps Heps.
(* Goal: @eq R (round beta fexp Zfloor (Rplus x eps)) x *)
case (Rle_or_lt 0 x); intros Zx.
rewrite succ_eq_pos; try assumption.
(* Goal: Rlt eps (ulp x) *)
(* Goal: @eq R (round beta fexp Zfloor (Rplus x eps)) x *)
rewrite Rle_bool_true in Heps; trivial.
apply round_UP_plus_eps_pos; assumption.
(* *)
(* Goal: @eq R (round beta fexp Zfloor (Rplus x eps)) x *)
rewrite Rle_bool_false in Heps; trivial.
(* Goal: @eq R (round beta fexp Zfloor (Rplus x eps)) x *)
rewrite <- (Ropp_involutive (x+eps)).
rewrite <- (Ropp_involutive (succ x)).
rewrite round_UP_opp.
(* Goal: @eq R (Ropp (round beta fexp Zceil (Ropp (Rplus x eps)))) (Ropp (Ropp x)) *)
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.
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: Rle (Ropp x) (succ (Ropp x)) *)
(* Goal: Rlt (IZR Z0) (succ (Ropp x)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
now apply Ropp_0_gt_lt_contravar.
(* Goal: generic_format beta fexp (Ropp (succ (Ropp x))) *)
now apply generic_format_opp.
now apply generic_format_opp, generic_format_succ.
(* Goal: and (Rlt (IZR Z0) (Rminus (ulp (pred (Ropp x))) eps)) (Rle (Rminus (ulp (pred (Ropp x))) eps) (ulp (pred (Ropp x)))) *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
split.
(* Goal: Rle (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Fcore_Raux.bpow beta (Z.sub (Z.sub e (Zpos xH)) (Zpos xH)))) (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rplus_le_reg_l with eps; ring_simplify.
(* Goal: Rle (IZR Z0) eps *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
apply Heps.
(* Goal: @eq R (Rplus (Ropp (succ (Ropp (Ropp x)))) (Rminus (ulp (Ropp (succ (Ropp (Ropp x))))) eps)) (Ropp (Rplus x eps)) *)
unfold pred; rewrite Ropp_involutive.
(* Goal: Rle (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Fcore_Raux.bpow beta (Z.sub (Z.sub e (Zpos xH)) (Zpos xH)))) (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rplus_lt_reg_l with (eps-ulp (- succ x))%R; ring_simplify.
(* Goal: Rle (IZR Z0) eps *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
apply Heps.
(* Goal: @eq R (Rplus (Ropp (succ x)) (Rminus (ulp (Ropp (succ x))) eps)) (Ropp (Rplus x eps)) *)
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)).
(* Goal: @eq R (Rplus (pred x) (ulp (pred x))) x *)
(* Goal: Rle (IZR Z0) (pred x) *)
(* Goal: generic_format beta fexp (pred x) *)
rewrite pred_eq_pos.
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
ring.
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: Rle (Ropp x) (succ (Ropp x)) *)
(* Goal: Rlt (IZR Z0) (succ (Ropp x)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
left; now apply Ropp_0_gt_lt_contravar.
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: Rle (Ropp x) (succ (Ropp x)) *)
(* Goal: Rlt (IZR Z0) (succ (Ropp x)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
now apply Ropp_0_gt_lt_contravar.
(* Goal: generic_format beta fexp (Ropp (succ (Ropp x))) *)
now apply generic_format_opp.
Qed.


Lemma le_pred_pos_lt :
  forall x y,
  F x -> F y ->
  (0 <= x < y)%R ->
  (x <= pred_pos y)%R.
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).
(* Goal: Rle (ulp (IZR Z0)) (ulp (Fcore_Raux.bpow beta (Z.sub e (Zpos xH)))) *)
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].
(* Goal: @eq R (Rplus (pred_pos x) (ulp (pred_pos x))) x *)
unfold pred_pos.
(* Goal: Rle (Rplus (Rmult (Z2R (@Fnum beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
destruct (ln_beta beta y) as (ey,Hey); simpl.
case Req_bool_spec; intros Hy2.
(* . *)
intros Hy3.
assert (ey-1 = fexp (ey -1))%Z.
(* Goal: @eq Z (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (ulp (IZR Z0)) x *)
apply bpow_inj with beta.
rewrite <- Hy2, <- Rplus_0_l, Hy3.
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
ring.
assert (Zx: (x <> 0)%R).
(* Goal: not (@eq R x (IZR Z0)) *)
now apply Rgt_not_eq.
destruct (ln_beta 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.
(* Goal: Rle (ulp (IZR Z0)) (ulp (Fcore_Raux.bpow beta (Z.sub e (Zpos xH)))) *)
apply H.
now apply Rgt_ge.
now apply Rgt_ge.
apply Hey.
(* Goal: not (@eq R x (IZR Z0)) *)
now apply Rgt_not_eq.
case (Zle_lt_or_eq _ _ H2); intros Hexy.
assert (fexp ex = fexp (ey-1))%Z.
(* Goal: Z.le (fexp (Z.add ex (Zpos xH))) ex *)
(* Goal: Rle (IZR Z0) x *)
apply valid_exp.
(* Goal: Z.le (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
omega.
rewrite <- H1.
(* Goal: Z.le (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
omega.
absurd (0 < Ztrunc (scaled_mantissa beta fexp x) < 1)%Z.
(* Goal: Z.le (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
omega.
(* Goal: and (Rlt (IZR Z0) (Rminus (ulp (pred (Ropp x))) eps)) (Rle (Rminus (ulp (pred (Ropp x))) eps) (ulp (pred (Ropp x)))) *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
split.
(* Goal: Z.lt Z0 (Ztrunc (scaled_mantissa beta fexp x)) *)
(* Goal: Rlt (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
(* Goal: Rlt (@F2R beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
now rewrite <- Fx.
apply lt_Z2R.
apply Rmult_lt_reg_r with (bpow (canonic_exp beta fexp x)).
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_gt_0.
replace (Z2R (Ztrunc (scaled_mantissa beta fexp x)) *
 bpow (canonic_exp beta fexp x))%R with x.
rewrite Rmult_1_l.
unfold canonic_exp.
rewrite ln_beta_unique with beta x ex.
rewrite H3,<-H1, <- Hy2.
(* Goal: Rle (ulp (IZR Z0)) (ulp (Fcore_Raux.bpow beta (Z.sub e (Zpos xH)))) *)
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.
(* Goal: Rle (IZR Z0) (IZR Z0) *)
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 canonic_exp.
rewrite (ln_beta_unique beta y ey); trivial.
apply Hey.
(* Goal: not (@eq R x (IZR Z0)) *)
now apply Rgt_not_eq.
contradict Hy2.
rewrite H1.
(* Goal: @eq R (Ropp (round beta fexp Zceil (Ropp (Rplus x eps)))) (Ropp (Ropp x)) *)
apply f_equal.
apply Zplus_reg_l with 1%Z.
(* Goal: Rle (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Fcore_Raux.bpow beta (Z.sub (Z.sub e (Zpos xH)) (Zpos xH)))) (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
ring_simplify.
apply trans_eq with (ln_beta beta y).
(* Goal: @eq Z (ln_beta_val beta (Rplus x eps) (ln_beta beta (Rplus x eps))) ex *)
apply sym_eq; apply ln_beta_unique.
rewrite H1, Rabs_right.
(* Goal: and (Rlt (IZR Z0) (Rminus (ulp (pred (Ropp x))) eps)) (Rle (Rminus (ulp (pred (Ropp x))) eps) (ulp (pred (Ropp x)))) *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
split.
(* Goal: Rle (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_le.
(* Goal: Z.le (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
omega.
(* Goal: Rlt (Fcore_Raux.bpow beta e) (Fcore_Raux.bpow beta (Z.add e (Zpos xH))) *)
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta e) *)
(* Goal: not (@eq R (Fcore_Raux.bpow beta e) (IZR Z0)) *)
apply bpow_lt.
(* Goal: Z.le (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
omega.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH)))) *)
(* Goal: Rle (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rle_ge; apply bpow_ge_0.
(* Goal: @eq Z (ln_beta_val beta (Rplus x eps) (ln_beta beta (Rplus x eps))) ex *)
apply ln_beta_unique.
apply Hey.
(* Goal: not (@eq R x (IZR Z0)) *)
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.
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
apply Req_le; ring.
(* . *)
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
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.
(* Goal: @eq Z (Z.sub e (Zpos xH)) (ln_beta_val beta (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (ln_beta beta (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))))) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply sym_eq.
apply round_generic...
split; trivial.
now apply Rlt_Rminus.
rewrite pred_eq_pos;[idtac|now left].
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) eps *)
now apply Rlt_le.
rewrite <- V; apply pred_pos_ge_0; trivial.
(* Goal: Rle (ulp (IZR Z0)) (ulp (Fcore_Raux.bpow beta (Z.sub e (Zpos xH)))) *)
apply Rle_lt_trans with (1:=proj1 H); apply H.
Qed.

Theorem succ_le_lt_aux:
  forall x y,
  F x -> F y ->
  (0 <= x)%R -> (x < y)%R ->
  (succ x <= y)%R.
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.
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
replace y with (x+(y-x))%R by ring.
absurd (x < y)%R.
(* Goal: Rle (ulp (IZR Z0)) (ulp (Fcore_Raux.bpow beta (Z.sub e (Zpos xH)))) *)
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.
(* Goal: @eq Z (Z.sub e (Zpos xH)) (ln_beta_val beta (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (ln_beta beta (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))))) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply sym_eq.
apply round_generic...
split; trivial.
apply Rlt_le; now apply Rlt_Rminus.
Qed.

Theorem succ_le_lt:
  forall x y,
  F x -> F y ->
  (x < y)%R ->
  (succ x <= y)%R.
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.
(* Goal: @eq R (Rplus (Ropp (succ x)) (Rminus (ulp (Ropp (succ x))) eps)) (Ropp (Rplus x eps)) *)
unfold succ; rewrite Rle_bool_false; try assumption.
case (Rle_or_lt y 0); intros Hy.
rewrite <- (Ropp_involutive y).
(* Goal: Rle (Ropp (succ (Ropp x))) (Ropp (Ropp x)) *)
apply Ropp_le_contravar.
apply le_pred_pos_lt.
(* Goal: generic_format beta fexp (Ropp (succ (Ropp x))) *)
now apply generic_format_opp.
(* Goal: generic_format beta fexp (Ropp (succ (Ropp x))) *)
now apply generic_format_opp.
(* Goal: and (Rlt (IZR Z0) (Rminus (ulp (pred (Ropp x))) eps)) (Rle (Rminus (ulp (pred (Ropp x))) eps) (ulp (pred (Ropp x)))) *)
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
split.
(* Goal: Rle (Ropp (succ (Ropp x))) (Ropp (Ropp x)) *)
rewrite <- Ropp_0; now apply Ropp_le_contravar.
(* Goal: Rlt (Ropp (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Ropp (IZR Z0)) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
now apply Ropp_lt_contravar.
apply Rle_trans with (-0)%R.
(* Goal: Rle (Ropp (succ (Ropp x))) (Ropp (Ropp x)) *)
apply Ropp_le_contravar.
apply pred_pos_ge_0.
(* Goal: Rlt (Ropp (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Ropp (IZR Z0)) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite <- Ropp_0; now apply Ropp_lt_contravar.
(* Goal: generic_format beta fexp (Ropp (succ (Ropp x))) *)
now apply generic_format_opp.
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (pred x) *)
(* Goal: generic_format beta fexp (pred x) *)
rewrite Ropp_0; now left.
Qed.

Theorem le_pred_lt :
  forall x y,
  F x -> F y ->
  (x < y)%R ->
  (x <= pred y)%R.
Proof.
(* Goal: forall (x y : R) (_ : generic_format beta fexp x) (_ : generic_format beta fexp y) (_ : Rlt x y), Rlt (succ x) (succ y) *)
intros x y Fx Fy Hxy.
(* Goal: @eq R (pred (succ x)) x *)
rewrite <- (Ropp_involutive x).
(* Goal: Rle (Ropp (succ (Ropp x))) (Ropp (Ropp x)) *)
unfold pred; apply Ropp_le_contravar.
(* Goal: Rle (succ (Ropp y)) (Ropp x) *)
apply succ_le_lt.
(* Goal: generic_format beta fexp (Ropp (succ (Ropp x))) *)
now apply generic_format_opp.
(* Goal: generic_format beta fexp (Ropp (succ (Ropp x))) *)
now apply generic_format_opp.
(* Goal: Rlt (Ropp (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Ropp (IZR Z0)) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
now apply Ropp_lt_contravar.
Qed.

Theorem lt_succ_le :
  forall x y,
  (y <> 0)%R ->
  (x <= y)%R ->
  (x < succ y)%R.
Proof.
(* Goal: forall (x y : R) (_ : not (@eq R x (IZR Z0))) (_ : Rle x y), Rlt (pred x) y *)
intros x y Zy Hxy.
(* Goal: Rlt x (succ y) *)
apply Rle_lt_trans with (1 := Hxy).
(* Goal: Rlt x (succ x) *)
now apply succ_gt_id.
Qed.

Theorem pred_lt_le :
  forall x y,
  (x <> 0)%R ->
  (x <= y)%R ->
  (pred x < y)%R.
Proof.
(* Goal: forall (x y : R) (_ : not (@eq R x (IZR Z0))) (_ : Rle x y), Rlt (pred x) y *)
intros x y Zy Hxy.
(* Goal: Rlt (pred x) y *)
apply Rlt_le_trans with (2 := Hxy).
(* Goal: Rlt (pred x) x *)
now apply pred_lt_id.
Qed.

Theorem succ_pred_aux : forall x, F x -> (0 < x)%R -> succ (pred x)=x.
Proof.
(* Goal: forall (x : R) (_ : generic_format beta fexp x) (_ : Rlt (IZR Z0) x), @eq R (pred (succ x)) x *)
intros x Fx Hx.
rewrite pred_eq_pos;[idtac|now left].
rewrite succ_eq_pos.
(* Goal: Rle (IZR Z0) (pred_pos x) *)
(* Goal: Rle (IZR Z0) x *)
2: now apply pred_pos_ge_0.
now apply pred_pos_plus_ulp.
Qed.

Theorem pred_ulp_0 :
  pred (ulp 0) = 0%R.
Proof.
(* Goal: @eq R (Rplus (pred x) (ulp (pred x))) x *)
(* Goal: Rle (IZR Z0) (pred x) *)
(* Goal: generic_format beta fexp (pred x) *)
rewrite pred_eq_pos.
(* Goal: Rle (IZR Z0) (ulp x) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
2: apply ulp_ge_0.
(* Goal: Rle (if Req_bool (IZR Z0) (IZR Z0) then match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end else Fcore_Raux.bpow beta (canonic_exp beta fexp (IZR Z0))) (ulp x) *)
unfold ulp; rewrite Req_bool_true; trivial.
(* Goal: Rle match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end (ulp x) *)
case negligible_exp_spec'.
(* *)
intros [H1 _]; rewrite H1.
(* Goal: @eq R (if Req_bool (Rabs x) (IZR Z0) then match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end else Fcore_Raux.bpow beta (canonic_exp beta fexp (Rabs x))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x)) *)
unfold pred_pos; rewrite Req_bool_false.
2: apply Rlt_not_eq, bpow_gt_0.
(* Goal: Rle (if Req_bool (IZR Z0) (IZR Z0) then match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end else Fcore_Raux.bpow beta (canonic_exp beta fexp (IZR Z0))) (ulp x) *)
unfold ulp; rewrite Req_bool_true; trivial.
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
rewrite H1; ring.
(* *)
(* Goal: forall _ : @ex Z (fun n : Z => and (@eq (option Z) negligible_exp (@Some Z n)) (Z.le n (fexp n))), Rle match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end (ulp x) *)
intros (n,(H1,H2)); rewrite H1.
(* Goal: @eq R (Rplus (pred_pos x) (ulp (pred_pos x))) x *)
unfold pred_pos.
(* Goal: Z.le (fexp (Z.sub (ln_beta_val beta (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (ln_beta beta (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))))) (Zpos xH))) (Z.sub ex (Zpos xH)) *)
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
rewrite ln_beta_bpow.
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
replace (fexp n + 1 - 1)%Z with (fexp n) by ring.
(* Goal: Rle (if Req_bool (IZR Z0) (IZR Z0) then match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end else Fcore_Raux.bpow beta (canonic_exp beta fexp (IZR Z0))) (ulp x) *)
rewrite Req_bool_true; trivial.
apply Rminus_diag_eq, f_equal.
(* Goal: @eq Z (fexp n) (fexp (Z.sub e (Zpos xH))) *)
apply sym_eq, valid_exp; omega.
Qed.

Theorem succ_0 :
  succ 0 = ulp 0.
Proof.
(* Goal: @eq R (succ (IZR Z0)) (ulp (IZR Z0)) *)
unfold succ.
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
rewrite Rle_bool_true.
(* Goal: @eq R (Rplus (IZR Z0) (ulp (IZR Z0))) (ulp (IZR Z0)) *)
(* Goal: Rle (IZR Z0) (IZR Z0) *)
apply Rplus_0_l.
(* Goal: Rle (IZR Z0) (IZR Z0) *)
apply Rle_refl.
Qed.

Theorem pred_0 :
  pred 0 = Ropp (ulp 0).
Proof.
(* Goal: @eq R (pred (IZR Z0)) (Ropp (ulp (IZR Z0))) *)
rewrite <- succ_0.
(* Goal: @eq R (pred (IZR Z0)) (Ropp (succ (IZR Z0))) *)
rewrite <- Ropp_0 at 1.
(* Goal: @eq R (pred (Ropp (IZR Z0))) (Ropp (succ (IZR Z0))) *)
apply pred_opp.
Qed.

Theorem pred_succ_aux :
  forall x, F x -> (0 < x)%R ->
  pred (succ x) = x.
Proof.
(* Goal: forall (x : R) (_ : generic_format beta fexp x) (_ : Rlt (IZR Z0) x), @eq R (pred (succ x)) x *)
intros x Fx Hx.
(* Goal: @eq R (pred (succ x)) x *)
apply Rle_antisym.
- apply Rnot_lt_le.
(* Goal: not (Rle (succ y) (succ x)) *)
  intros H.
(* Goal: False *)
  apply succ_le_lt with (1 := Fx) in H.
(* Goal: False *)
(* Goal: generic_format beta fexp (pred (succ x)) *)
  revert H.
(* Goal: forall _ : Rle (succ x) (pred (succ x)), False *)
(* Goal: generic_format beta fexp (pred (succ x)) *)
  apply Rlt_not_le.
(* Goal: Rlt (pred x) x *)
(* Goal: Rlt (pred x) (IZR Z0) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
  apply pred_lt_id.
(* Goal: not (@eq R (succ x) (IZR Z0)) *)
(* Goal: generic_format beta fexp (pred (succ x)) *)
  apply Rgt_not_eq.
(* Goal: Rgt (succ x) (IZR Z0) *)
(* Goal: generic_format beta fexp (pred (succ x)) *)
  apply Rlt_le_trans with (1 := Hx).
(* Goal: Rle (Ropp x) (succ (Ropp x)) *)
(* Goal: Rlt (IZR Z0) (succ (Ropp x)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
  apply succ_ge_id.
(* Goal: generic_format beta fexp (pred (succ x)) *)
  now apply generic_format_pred, generic_format_succ.
- apply le_pred_lt with (1 := Fx).
(* Goal: generic_format beta fexp (succ (Ropp x)) *)
  now apply generic_format_succ.
(* Goal: Rlt x (succ x) *)
  apply succ_gt_id.
(* Goal: not (@eq R x (IZR Z0)) *)
  now apply Rgt_not_eq.
Qed.

Theorem succ_pred :
  forall x, F x ->
  succ (pred x) = x.
Proof.
(* Goal: forall (x : R) (_ : generic_format beta fexp x), @eq R (pred (succ x)) x *)
intros x Fx.
(* Goal: @eq R (succ (pred x)) x *)
destruct (Rle_or_lt 0 x) as [[Hx|Hx]|Hx].
(* Goal: @eq R (succ (pred x)) x *)
(* Goal: @eq R (succ (pred x)) x *)
(* Goal: @eq R (succ (pred x)) x *)
now apply succ_pred_aux.
(* Goal: @eq R (succ (pred x)) x *)
(* Goal: @eq R (succ (pred x)) x *)
rewrite <- Hx.
(* Goal: @eq R (succ (pred (IZR Z0))) (IZR Z0) *)
(* Goal: @eq R (succ (pred x)) x *)
rewrite pred_0, succ_opp, pred_ulp_0.
(* Goal: @eq R (Ropp (IZR Z0)) (IZR Z0) *)
(* Goal: @eq R (succ (pred x)) x *)
apply Ropp_0.
(* Goal: @eq R (succ (pred x)) x *)
rewrite pred_eq_opp_succ_opp, succ_opp.
(* Goal: @eq R (Ropp (pred (succ (Ropp x)))) x *)
rewrite pred_succ_aux.
(* Goal: @eq R (Ropp (Ropp x)) x *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
apply Ropp_involutive.
(* Goal: generic_format beta fexp (Ropp (succ (Ropp x))) *)
now apply generic_format_opp.
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: Rle (Ropp x) (succ (Ropp x)) *)
(* Goal: Rlt (IZR Z0) (succ (Ropp x)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
now apply Ropp_0_gt_lt_contravar.
Qed.

Theorem pred_succ :
  forall x, F x ->
  pred (succ x) = x.
Proof.
(* Goal: forall (x : R) (_ : generic_format beta fexp x), @eq R (pred (succ x)) x *)
intros x Fx.
(* Goal: @eq R (pred (succ x)) x *)
rewrite <- (Ropp_involutive x).
(* Goal: @eq R (pred (succ (Ropp (Ropp x)))) (Ropp (Ropp x)) *)
rewrite succ_opp, pred_opp.
(* Goal: @eq R (Ropp (succ (pred (Ropp x)))) (Ropp (Ropp x)) *)
apply f_equal, succ_pred.
(* Goal: generic_format beta fexp (Ropp (succ (Ropp x))) *)
now apply generic_format_opp.
Qed.

Theorem round_UP_pred_plus_eps :
  forall x, F x ->
  forall eps, (0 < eps <= if (Rle_bool x 0) then (ulp x)
                                     else (ulp (pred x)))%R ->
  round beta fexp Zceil (pred x + eps) = x.
Proof.
(* Goal: forall (x : R) (_ : generic_format beta fexp x) (eps : R) (_ : and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool x (IZR Z0) then ulp x else ulp (pred x)))), @eq R (round beta fexp Zfloor (Rminus x eps)) (pred x) *)
intros x Fx eps Heps.
(* Goal: @eq R (round beta fexp Zceil (Rplus (pred x) eps)) x *)
rewrite round_UP_plus_eps.
(* Goal: @eq R (succ (pred x)) x *)
(* Goal: generic_format beta fexp (pred x) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp (pred (Ropp (pred x))))) *)
now apply succ_pred.
(* Goal: generic_format beta fexp (pred x) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp (pred (Ropp (pred x))))) *)
now apply generic_format_pred.
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp (pred (Ropp (pred x))))) *)
unfold pred at 4.
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp (pred (Ropp (Ropp (succ (Ropp x))))))) *)
rewrite Ropp_involutive, pred_succ.
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp (Ropp x))) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
rewrite ulp_opp.
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
generalize Heps; case (Rle_bool_spec x 0); intros H1 H2.
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
rewrite Rle_bool_false; trivial.
(* Goal: Rlt (IZR Z0) (succ (Ropp x)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
case H1; intros H1'.
(* Goal: Rlt (pred x) (IZR Z0) *)
(* Goal: Rlt (pred x) (IZR Z0) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
apply Rlt_le_trans with (2:=H1).
(* Goal: Rlt (pred x) x *)
(* Goal: Rlt (pred x) (IZR Z0) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
apply pred_lt_id.
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rlt (pred x) (IZR Z0) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
now apply Rlt_not_eq.
(* Goal: Rlt (pred x) (IZR Z0) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
rewrite H1'; unfold pred, succ.
(* Goal: Rlt (Ropp (if Rle_bool (IZR Z0) (Ropp (IZR Z0)) then Rplus (Ropp (IZR Z0)) (ulp (Ropp (IZR Z0))) else Ropp (pred_pos (Ropp (Ropp (IZR Z0)))))) (IZR Z0) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
rewrite Ropp_0; rewrite Rle_bool_true;[idtac|now right].
(* Goal: Rlt (IZR Z0) (Rplus (IZR Z0) (ulp (IZR Z0))) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
rewrite Rplus_0_l.
(* Goal: Rlt (Ropp (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Ropp (IZR Z0)) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite <- Ropp_0; apply Ropp_lt_contravar.
(* Goal: Rlt (IZR Z0) (ulp (IZR Z0)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
apply Rlt_le_trans with (1:=proj1 H2).
(* Goal: Rle eps (ulp (Ropp (IZR Z0))) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
apply Rle_trans with (1:=proj2 H2).
(* Goal: Rle (ulp x) (ulp (Ropp (IZR Z0))) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
rewrite Ropp_0, H1'.
(* Goal: Rle (ulp (IZR Z0)) (ulp (IZR Z0)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
now right.
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
rewrite Rle_bool_true; trivial.
(* Goal: Rle (IZR Z0) (pred x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
now apply pred_ge_0.
(* Goal: generic_format beta fexp (Ropp (succ (Ropp x))) *)
now apply generic_format_opp.
Qed.


Theorem round_DN_minus_eps:
  forall x,  F x ->
  forall eps, (0 < eps <= if (Rle_bool x 0) then (ulp x)
                                     else (ulp (pred x)))%R ->
  round beta fexp Zfloor (x - eps) = pred x.
Proof.
(* Goal: forall (x : R) (_ : generic_format beta fexp x) (eps : R) (_ : and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool x (IZR Z0) then ulp x else ulp (pred x)))), @eq R (round beta fexp Zfloor (Rminus x eps)) (pred x) *)
intros x Fx eps Heps.
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
replace (x-eps)%R with (-(-x+eps))%R by ring.
(* Goal: @eq R (round beta fexp Zfloor (Ropp (Rplus (Ropp x) eps))) (pred x) *)
rewrite round_DN_opp.
(* Goal: @eq R (Ropp (round beta fexp Zceil (Ropp (Rplus x eps)))) (Ropp (Ropp x)) *)
unfold pred; apply f_equal.
pattern (-x)%R at 1; rewrite <- (pred_succ (-x)).
(* Goal: @eq R (round beta fexp Zceil (Rplus (pred (succ (Ropp x))) eps)) (succ (Ropp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
apply round_UP_pred_plus_eps.
(* Goal: generic_format beta fexp (succ (Ropp x)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp (pred (succ (Ropp x))))) *)
(* Goal: generic_format beta fexp (Ropp x) *)
now apply generic_format_succ, generic_format_opp.
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp (pred (succ (Ropp x))))) *)
(* Goal: generic_format beta fexp (Ropp x) *)
rewrite pred_succ.
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp (Ropp x))) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
rewrite ulp_opp.
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
generalize Heps; case (Rle_bool_spec x 0); intros H1 H2.
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
rewrite Rle_bool_false; trivial.
(* Goal: Rlt (IZR Z0) (succ (Ropp x)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
case H1; intros H1'.
apply Rlt_le_trans with (-x)%R.
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: Rle (Ropp x) (succ (Ropp x)) *)
(* Goal: Rlt (IZR Z0) (succ (Ropp x)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
now apply Ropp_0_gt_lt_contravar.
(* Goal: Rle (Ropp x) (succ (Ropp x)) *)
(* Goal: Rlt (IZR Z0) (succ (Ropp x)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
apply succ_ge_id.
(* Goal: Rlt (IZR Z0) (succ (Ropp x)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
rewrite H1', Ropp_0, succ_eq_pos;[idtac|now right].
(* Goal: Rlt (IZR Z0) (Rplus (IZR Z0) (ulp (IZR Z0))) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
rewrite Rplus_0_l.
(* Goal: Rlt (IZR Z0) (ulp (IZR Z0)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
apply Rlt_le_trans with (1:=proj1 H2).
(* Goal: Rle eps (ulp (IZR Z0)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
rewrite H1' in H2; apply H2.
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
rewrite Rle_bool_true.
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (ulp (succ (Ropp x)))) *)
(* Goal: Rle (succ (Ropp x)) (IZR Z0) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
now rewrite succ_opp, ulp_opp.
(* Goal: Rle (succ (Ropp x)) (IZR Z0) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
rewrite succ_opp.
(* Goal: Rle (Ropp (succ (Ropp x))) (Ropp (Ropp x)) *)
rewrite <- Ropp_0; apply Ropp_le_contravar.
(* Goal: Rle (IZR Z0) (pred x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
now apply pred_ge_0.
(* Goal: generic_format beta fexp (Ropp (succ (Ropp x))) *)
now apply generic_format_opp.
(* Goal: generic_format beta fexp (Ropp (succ (Ropp x))) *)
now apply generic_format_opp.
Qed.

(** Error of a rounding, expressed in number of ulps *)
(** false for x=0 in the FLX format *)
(* was ulp_error *)
Theorem error_lt_ulp :
  forall rnd { Zrnd : Valid_rnd rnd } x,
   (x <> 0)%R ->
  (Rabs (round beta fexp rnd x - x) < ulp x)%R.
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.
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite ulp_neq_0; trivial.
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
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).
(* Goal: Rle (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Fcore_Raux.bpow beta (Z.sub (Z.sub e (Zpos xH)) (Zpos xH)))) (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
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...
(* . *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x eps))) (Rlt (Rabs (Rplus x eps)) (Fcore_Raux.bpow beta ex)) *)
rewrite Rabs_pos_eq.
rewrite round_UP_DN_ulp with (1 := Hx).
apply Rplus_lt_reg_r with (x - ulp x)%R.
(* Goal: Rle (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Fcore_Raux.bpow beta (Z.sub (Z.sub e (Zpos xH)) (Zpos xH)))) (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
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...
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
apply Rle_0_minus.
apply round_UP_pt...
Qed.

(* was ulp_error_le *)
Theorem error_le_ulp :
  forall rnd { Zrnd : Valid_rnd rnd } x,
  (Rabs (round beta fexp rnd x - x) <= ulp x)%R.
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.
(* Goal: Rle (IZR Z0) (ulp x) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
apply ulp_ge_0.
intros Zx; left.
now apply error_lt_ulp.
Qed.

(* was ulp_half_error *)
Theorem error_le_half_ulp :
  forall choice x,
  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * ulp x)%R.
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 (Z2R_lt 0 2).
(* Goal: Rle (IZR Z0) (ulp x) *)
(* Goal: generic_format beta fexp (Rplus x (ulp x)) *)
(* Goal: Rle (IZR Z0) x *)
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 (Z2R_lt 0 2).
apply Rplus_le_reg_r with (d - x)%R.
(* Goal: Rle (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Fcore_Raux.bpow beta (Z.sub (Z.sub e (Zpos xH)) (Zpos xH)))) (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
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).
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs (Rplus x eps))) (Rlt (Rabs (Rplus x eps)) (Fcore_Raux.bpow beta ex)) *)
rewrite Rabs_pos_eq.
apply Rmult_le_reg_r with 2%R.
now apply (Z2R_lt 0 2).
apply Rplus_le_reg_r with (- (d + ulp x - x))%R.
(* Goal: Rle (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Fcore_Raux.bpow beta (Z.sub (Z.sub e (Zpos xH)) (Zpos xH)))) (Rplus (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
ring_simplify.
apply Rlt_le.
apply Rlt_le_trans with (1 := H).
right. field.
(* Goal: Rle (IZR Z0) (Rminus x (ulp x)) *)
apply Rle_0_minus.
rewrite Hu.
apply (round_UP_pt beta fexp x).
Qed.


Theorem ulp_DN :
  forall x,
  (0 < round beta fexp Zfloor x)%R ->
  ulp (round beta fexp Zfloor x) = ulp x.
Proof with auto with typeclass_instances.
intros x Hd.
rewrite 2!ulp_neq_0.
now rewrite canonic_exp_DN with (2 := Hd).
intros T; contradict Hd; rewrite T, round_0...
apply Rlt_irrefl.
(* Goal: not (@eq R x (IZR Z0)) *)
now apply Rgt_not_eq.
Qed.

Theorem round_neq_0_negligible_exp:
    negligible_exp=None -> forall rnd { Zrnd : Valid_rnd rnd } x,
   (x <> 0)%R ->  (round beta fexp rnd x <> 0)%R.
Proof with auto with typeclass_instances.
intros H rndn Hrnd x Hx K.
(* Goal: Rle match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end (ulp x) *)
case negligible_exp_spec'.
intros (_,Hn).
destruct (ln_beta 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 *)
(* was ulp_error_f *)
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.
Proof with auto with typeclass_instances.
intros Hm.
(* wlog *)
cut (forall rnd : R -> Z, Valid_rnd rnd -> forall x : R, (0 < x)%R  ->
    (Rabs (round beta fexp rnd x - x) < ulp (round beta fexp rnd x))%R).
intros M rnd Hrnd x Zx.
case (Rle_or_lt 0 x).
intros H; destruct H.
now apply M.
contradict H; now apply sym_not_eq.
(* Goal: not (Rle (succ y) (succ x)) *)
intros H.
(* Goal: @eq R (pred (succ x)) x *)
rewrite <- (Ropp_involutive x).
rewrite round_opp, ulp_opp.
replace (- round beta fexp (Zrnd_opp rnd) (- x) - - - x)%R with
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
    (-(round beta fexp (Zrnd_opp rnd) (- x) - (-x)))%R by ring.
rewrite Rabs_Ropp.
apply M.
now apply valid_rnd_opp.
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: Rle (Ropp x) (succ (Ropp x)) *)
(* Goal: Rlt (IZR Z0) (succ (Ropp x)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
now apply Ropp_0_gt_lt_contravar.
(* 0 < x *)
intros rnd Hrnd x Hx.
case (Rle_lt_or_eq_dec 0 (round beta fexp Zfloor x)).
apply round_ge_generic...
(* Goal: generic_format beta fexp (IZR Z0) *)
(* Goal: @eq R (IZR Z0) f *)
apply generic_format_0.
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (pred x) *)
(* Goal: generic_format beta fexp (pred x) *)
now left.
(* . 0 < round Zfloor x *)
intros Hx2.
apply Rlt_le_trans with (ulp x).
apply error_lt_ulp...
(* Goal: not (@eq R x (IZR Z0)) *)
now apply Rgt_not_eq.
rewrite <- ulp_DN; trivial.
apply ulp_le_pos.
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (pred x) *)
(* Goal: generic_format beta fexp (pred x) *)
now left.
(* Goal: generic_format beta fexp x *)
case (round_DN_or_UP beta fexp rnd x); intros V; rewrite V.
(* Goal: Rle (IZR Z0) (IZR Z0) *)
apply Rle_refl.
apply Rle_trans with x.
apply round_DN_pt...
apply round_UP_pt...
(* . 0 = round Zfloor x *)
intros Hx2.
case (round_DN_or_UP beta fexp rnd x); intros V; rewrite V; clear V.
(* .. round down -- difficult case *)
rewrite <- Hx2.
unfold Rminus; rewrite Rplus_0_l, Rabs_Ropp.
(* Goal: Rle (if Req_bool (IZR Z0) (IZR Z0) then match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end else Fcore_Raux.bpow beta (canonic_exp beta fexp (IZR Z0))) (ulp x) *)
unfold ulp; rewrite Req_bool_true; trivial.
(* Goal: @eq R match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end x *)
case negligible_exp_spec.
(* without minimal exponent *)
intros K; contradict Hx2.
apply Rlt_not_eq.
(* Goal: Rle (Rplus (Rmult (Z2R (@Fnum beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
apply F2R_gt_0_compat; simpl.
apply Zlt_le_trans with 1%Z.
apply Pos2Z.is_pos.
apply Zfloor_lub.
simpl; unfold scaled_mantissa, canonic_exp.
(* Goal: Rle (Rplus (Rmult (Z2R (@Fnum beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
destruct (ln_beta beta x) as (e,He); simpl.
apply Rle_trans with (bpow (e-1) * bpow (- fexp e))%R.
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite <- bpow_plus.
(* Goal: forall x : R, @eq R (pred x) (Ropp (succ (Ropp x))) *)
replace 1%R with (bpow 0) by reflexivity.
(* Goal: Rle (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_le.
(* Goal: Z.le (fexp (Z.sub e (Zpos xH))) (Z.sub e (Zpos xH)) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
specialize (K e); omega.
(* Goal: Rle (Rmult (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply Rmult_le_compat_r.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH)))) *)
(* Goal: Rle (IZR (Zpos (xO xH))) (Fcore_Raux.bpow beta (Zpos xH)) *)
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Zpos xH)) (Fcore_Raux.bpow beta (Z.sub e (Zpos (xO xH))))) x *)
(* Goal: Rlt (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_ge_0.
rewrite <- (Rabs_pos_eq x).
now apply He, Rgt_not_eq.
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (pred x) *)
(* Goal: generic_format beta fexp (pred x) *)
now left.
(* with a minimal exponent *)
(* Goal: forall (n : Z) (_ : Z.le n (fexp n)), @eq R (Fcore_Raux.bpow beta (fexp n)) x *)
intros n Hn.
rewrite Rabs_pos_eq;[idtac|now left].
case (Rle_or_lt (bpow (fexp n)) x); trivial.
intros K; contradict Hx2.
apply Rlt_not_eq.
apply Rlt_le_trans with (bpow (fexp n)).
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
apply bpow_gt_0.
apply round_ge_generic...
(* Goal: generic_format beta fexp (Fcore_Raux.bpow beta ex) *)
(* Goal: Rle (IZR Z0) x *)
apply generic_format_bpow.
(* Goal: Z.le (fexp (Z.add (fexp n) (Zpos xH))) (fexp n) *)
now apply valid_exp.
(* .. round up *)
apply Rlt_le_trans with (ulp x).
apply error_lt_ulp...
(* Goal: not (@eq R x (IZR Z0)) *)
now apply Rgt_not_eq.
apply ulp_le_pos.
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (pred x) *)
(* Goal: generic_format beta fexp (pred x) *)
now left.
apply round_UP_pt...
Qed.

(** allows both x and rnd x to be 0 *)
(* was ulp_half_error_f *)
Theorem error_le_half_ulp_round :
  forall { Hm : Monotone_exp fexp },
  forall choice x,
  (Rabs (round beta fexp (Znearest choice) x - x) <= /2 * ulp (round beta fexp (Znearest choice) x))%R.
Proof with auto with typeclass_instances.
intros Hm choice x.
case (Req_dec (round beta fexp (Znearest choice) x) 0); intros Hfx.
(* *)
(* Goal: Rle (ulp (IZR Z0)) (ulp x) *)
case (Req_dec x 0); intros Hx.
apply Rle_trans with (1:=error_le_half_ulp _ _).
rewrite Hx, round_0...
(* Goal: @eq R (Rplus (Ropp x) (Ropp eps)) (Ropp (Rplus x eps)) *)
(* Goal: Rlt (IZR Z0) (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
right; ring.
generalize (error_le_half_ulp choice x).
rewrite Hfx.
unfold Rminus; rewrite Rplus_0_l, Rabs_Ropp.
intros N.
(* Goal: Rle (if Req_bool (IZR Z0) (IZR Z0) then match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end else Fcore_Raux.bpow beta (canonic_exp beta fexp (IZR Z0))) (ulp x) *)
unfold ulp; rewrite Req_bool_true; trivial.
(* Goal: Rle match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end (ulp x) *)
case negligible_exp_spec'.
intros (H1,H2).
contradict Hfx.
apply round_neq_0_negligible_exp...
intros (n,(H1,Hn)); rewrite H1.
apply Rle_trans with (1:=N).
(* Goal: @eq R (Ropp (round beta fexp Zceil (Ropp (Rplus x eps)))) (Ropp (Ropp x)) *)
right; apply f_equal.
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
rewrite ulp_neq_0; trivial.
(* Goal: @eq R (Ropp (round beta fexp Zceil (Ropp (Rplus x eps)))) (Ropp (Ropp x)) *)
apply f_equal.
unfold canonic_exp.
apply valid_exp; trivial.
assert (ln_beta beta x -1 < fexp n)%Z;[idtac|omega].
apply lt_bpow with beta.
destruct (ln_beta beta x) as (e,He).
(* Goal: Rle (Rplus (Rmult (Z2R (@Fnum beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x))))) (Fcore_Raux.bpow beta (canonic_exp beta fexp x))) (Fcore_Raux.bpow beta ex) *)
(* Goal: not (@eq R x (IZR Z0)) *)
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (Rplus x eps) *)
simpl.
apply Rle_lt_trans with (Rabs x).
now apply He.
apply Rle_lt_trans with (Rabs (round beta fexp (Znearest choice) x - x)).
(* Goal: Rlt (IZR Z0) (Rplus (IZR Z0) (ulp (IZR Z0))) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (succ (Ropp x)) (IZR Z0) then ulp (succ (Ropp x)) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
right; rewrite Hfx; unfold Rminus; rewrite Rplus_0_l.
apply sym_eq, Rabs_Ropp.
apply Rlt_le_trans with (ulp 0).
rewrite <- Hfx.
apply error_lt_ulp_round...
unfold ulp; rewrite Req_bool_true, H1; trivial.
(* Goal: Rle (ulp (IZR Z0)) (ulp (IZR Z0)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
now right.
(* *)
case (round_DN_or_UP beta fexp (Znearest choice) x); intros Hx.
(* . *)
case (Rle_or_lt 0 (round beta fexp Zfloor x)).
intros H; destruct H.
rewrite Hx at 2.
rewrite ulp_DN; trivial.
apply error_le_half_ulp.
rewrite Hx in Hfx; contradict Hfx; auto with real.
(* Goal: not (Rle (succ y) (succ x)) *)
intros H.
apply Rle_trans with (1:=error_le_half_ulp _ _).
apply Rmult_le_compat_l.
apply Rlt_le, pos_half_prf.
apply ulp_le.
rewrite Hx; rewrite (Rabs_left1 x), Rabs_left; try assumption.
(* Goal: Rle (Ropp (succ (Ropp x))) (Ropp (Ropp x)) *)
apply Ropp_le_contravar.
apply (round_DN_pt beta fexp x).
case (Rle_or_lt x 0); trivial.
intros H1; contradict H.
apply Rle_not_lt.
apply round_ge_generic...
(* Goal: generic_format beta fexp (IZR Z0) *)
(* Goal: @eq R (IZR Z0) f *)
apply generic_format_0.
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (pred x) *)
(* Goal: generic_format beta fexp (pred x) *)
now left.
(* . *)
case (Rle_or_lt 0 (round beta fexp Zceil x)).
intros H; destruct H.
apply Rle_trans with (1:=error_le_half_ulp _ _).
apply Rmult_le_compat_l.
apply Rlt_le, pos_half_prf.
(* Goal: Rle (ulp (Rabs x)) (ulp (Rabs y)) *)
apply ulp_le_pos; trivial.
case (Rle_or_lt 0 x); trivial.
intros H1; contradict H.
apply Rle_not_lt.
apply round_le_generic...
(* Goal: generic_format beta fexp (IZR Z0) *)
(* Goal: @eq R (IZR Z0) f *)
apply generic_format_0.
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (pred x) *)
(* Goal: generic_format beta fexp (pred x) *)
now left.
rewrite Hx; apply (round_UP_pt beta fexp x).
rewrite Hx in Hfx; contradict Hfx; auto with real.
(* Goal: not (Rle (succ y) (succ x)) *)
intros H.
rewrite Hx at 2; rewrite <- (ulp_opp (round beta fexp Zceil x)).
rewrite <- round_DN_opp.
rewrite ulp_DN; trivial.
pattern x at 1 2; rewrite <- Ropp_involutive.
rewrite round_N_opp.
unfold Rminus.
rewrite <- Ropp_plus_distr, Rabs_Ropp.
apply error_le_half_ulp.
rewrite round_DN_opp; apply Ropp_0_gt_lt_contravar; apply Rlt_gt; assumption.
Qed.

Theorem pred_le :
  forall x y, F x -> F y -> (x <= y)%R ->
  (pred x <= pred y)%R.
Proof.
intros x y Fx Fy [Hxy| ->].
(* Goal: Rle (IZR Z0) (IZR Z0) *)
2: apply Rle_refl.
apply le_pred_lt with (2 := Fy).
(* Goal: generic_format beta fexp (pred x) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp (pred (Ropp (pred x))))) *)
now apply generic_format_pred.
apply Rle_lt_trans with (2 := Hxy).
apply pred_le_id.
Qed.

Theorem succ_le: forall x y,
   F x -> F y -> (x <= y)%R -> (succ x <= succ y)%R.
Proof.
(* Goal: forall (x y : R) (_ : generic_format beta fexp x) (_ : generic_format beta fexp y) (_ : Rlt x y), Rlt (succ x) (succ y) *)
intros x y Fx Fy Hxy.
(* Goal: Rle (succ x) (succ y) *)
rewrite 2!succ_eq_opp_pred_opp.
(* Goal: Rle (Ropp (pred (Ropp x))) (Ropp (pred (Ropp y))) *)
apply Ropp_le_contravar, pred_le; try apply generic_format_opp; try assumption.
(* Goal: Rle (Ropp (succ (Ropp x))) (Ropp (Ropp x)) *)
now apply Ropp_le_contravar.
Qed.

Theorem pred_le_inv: forall x y, F x -> F y
   -> (pred x <= pred y)%R -> (x <= y)%R.
Proof.
(* Goal: forall (x y : R) (_ : generic_format beta fexp x) (_ : generic_format beta fexp y) (_ : Rlt x y), Rlt (succ x) (succ y) *)
intros x y Fx Fy Hxy.
rewrite <- (succ_pred x), <- (succ_pred y); try assumption.
(* Goal: generic_format beta fexp (pred x) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp (pred (Ropp (pred x))))) *)
apply succ_le; trivial; now apply generic_format_pred.
Qed.

Theorem succ_le_inv: forall x y, F x -> F y
   -> (succ x <= succ y)%R -> (x <= y)%R.
Proof.
(* Goal: forall (x y : R) (_ : generic_format beta fexp x) (_ : generic_format beta fexp y) (_ : Rlt x y), Rlt (succ x) (succ y) *)
intros x y Fx Fy Hxy.
rewrite <- (pred_succ x), <- (pred_succ y); try assumption.
(* Goal: generic_format beta fexp (succ (Ropp x)) *)
apply pred_le; trivial; now apply generic_format_succ.
Qed.

Theorem pred_lt :
  forall x y, F x -> F y -> (x < y)%R ->
  (pred x < pred y)%R.
Proof.
(* Goal: forall (x y : R) (_ : generic_format beta fexp x) (_ : generic_format beta fexp y) (_ : Rlt x y), Rlt (succ x) (succ y) *)
intros x y Fx Fy Hxy.
(* Goal: Rlt (succ x) (succ y) *)
apply Rnot_le_lt.
(* Goal: not (Rle (succ y) (succ x)) *)
intros H.
(* Goal: False *)
apply Rgt_not_le with (1 := Hxy).
(* Goal: Rle y x *)
now apply pred_le_inv.
Qed.

Theorem succ_lt :
  forall x y, F x -> F y -> (x < y)%R ->
  (succ x < succ y)%R.
Proof.
(* Goal: forall (x y : R) (_ : generic_format beta fexp x) (_ : generic_format beta fexp y) (_ : Rlt x y), Rlt (succ x) (succ y) *)
intros x y Fx Fy Hxy.
(* Goal: Rlt (succ x) (succ y) *)
apply Rnot_le_lt.
(* Goal: not (Rle (succ y) (succ x)) *)
intros H.
(* Goal: False *)
apply Rgt_not_le with (1 := Hxy).
(* Goal: Rle y x *)
now apply succ_le_inv.
Qed.

(* was lt_UP_le_DN *)
Theorem le_round_DN_lt_UP :
  forall x y, F y ->
  (y < round beta fexp Zceil x -> y <= round beta fexp Zfloor x)%R.
Proof with auto with typeclass_instances.
intros x y Fy Hlt.
apply round_DN_pt...
(* Goal: Rle (pred (succ x)) x *)
apply Rnot_lt_le.
contradict Hlt.
apply RIneq.Rle_not_lt.
apply round_UP_pt...
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) eps *)
now apply Rlt_le.
Qed.

(* was lt_DN_le_UP *)
Theorem round_UP_le_gt_DN :
  forall x y, F y ->
   (round beta fexp Zfloor x < y -> round beta fexp Zceil x <= y)%R.
Proof with auto with typeclass_instances.
intros x y Fy Hlt.
apply round_UP_pt...
(* Goal: Rle (pred (succ x)) x *)
apply Rnot_lt_le.
contradict Hlt.
apply RIneq.Rle_not_lt.
apply round_DN_pt...
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) eps *)
now apply Rlt_le.
Qed.



Theorem pred_UP_le_DN :
  forall x, (pred (round beta fexp Zceil x) <= round beta fexp Zfloor x)%R.
Proof with auto with typeclass_instances.
(* Goal: forall x : R, @eq R (ulp (Rabs x)) (ulp x) *)
intros x.
destruct (generic_format_EM beta fexp x) as [Fx|Fx].
rewrite !round_generic...
apply pred_le_id.
case (Req_dec (round beta fexp Zceil x) 0); intros Zx.
rewrite Zx; unfold pred; rewrite Ropp_0.
(* Goal: Rle (IZR Z0) (succ (IZR Z0)) *)
(* Goal: forall _ : not (@eq R x (IZR Z0)), Rle x (succ x) *)
unfold succ; rewrite Rle_bool_true;[idtac|now right].
(* Goal: Rle (if Req_bool (IZR Z0) (IZR Z0) then match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end else Fcore_Raux.bpow beta (canonic_exp beta fexp (IZR Z0))) (ulp x) *)
rewrite Rplus_0_l; unfold ulp; rewrite Req_bool_true; trivial.
(* Goal: Rle match negligible_exp with | Some n => Fcore_Raux.bpow beta (fexp n) | None => IZR Z0 end (ulp x) *)
case negligible_exp_spec'.
intros (H1,H2).
contradict Zx; apply round_neq_0_negligible_exp...
(* Goal: generic_format beta fexp (IZR Z0) *)
(* Goal: @eq R (IZR Z0) f *)
intros L; apply Fx; rewrite L; apply generic_format_0.
intros (n,(H1,Hn)); rewrite H1.
(* Goal: forall _ : forall n : Z, Z.lt (fexp n) n, @eq R (IZR Z0) x *)
(* Goal: forall (n : Z) (_ : Z.le n (fexp n)), @eq R (Fcore_Raux.bpow beta (fexp n)) x *)
case (Rle_or_lt (- bpow (fexp n)) (round beta fexp Zfloor x)); trivial; intros K.
absurd (round beta fexp Zceil x <= - bpow (fexp n))%R.
(* Goal: forall _ : Rle (succ x) (pred (succ x)), False *)
(* Goal: generic_format beta fexp (pred (succ x)) *)
apply Rlt_not_le.
rewrite Zx, <- Ropp_0.
apply Ropp_lt_contravar, bpow_gt_0.
apply round_UP_le_gt_DN; try assumption.
apply generic_format_opp, generic_format_bpow.
(* Goal: Z.le (fexp (Z.add (fexp n) (Zpos xH))) (fexp n) *)
now apply valid_exp.
assert (let u := round beta fexp Zceil x in pred u < u)%R as Hup.
(* Goal: Rlt (pred x) x *)
now apply pred_lt_id.
apply le_round_DN_lt_UP...
apply generic_format_pred...
now apply round_UP_pt.
Qed.

Theorem pred_UP_eq_DN :
  forall x,  ~ F x ->
  (pred (round beta fexp Zceil x) = round beta fexp Zfloor x)%R.
Proof with auto with typeclass_instances.
(* Goal: forall (x : R) (_ : generic_format beta fexp x), @eq R (pred (succ x)) x *)
intros x Fx.
(* Goal: @eq R (pred (succ x)) x *)
apply Rle_antisym.
now apply pred_UP_le_DN.
apply le_pred_lt; try apply generic_format_round...
pose proof round_DN_UP_lt _ _ _ Fx as HE.
now apply Rlt_trans with (1 := proj1 HE) (2 := proj2 HE).
Qed.

Theorem succ_DN_eq_UP :
  forall x,  ~ F x ->
  (succ (round beta fexp Zfloor x) = round beta fexp Zceil x)%R.
Proof with auto with typeclass_instances.
(* Goal: forall (x : R) (_ : generic_format beta fexp x), @eq R (pred (succ x)) x *)
intros x Fx.
rewrite <- pred_UP_eq_DN; trivial.
rewrite succ_pred; trivial.
apply generic_format_round...
Qed.


(* was betw_eq_DN *)
Theorem round_DN_eq_betw: forall x d, F d
     -> (d <= x < succ d)%R
        -> round beta fexp Zfloor x = d.
Proof with auto with typeclass_instances.
intros x d Fd (Hxd1,Hxd2).
generalize (round_DN_pt beta fexp x); intros (T1,(T2,T3)).
apply sym_eq, Rle_antisym.
now apply T3.
destruct (generic_format_EM beta fexp x) as [Fx|NFx].
rewrite round_generic...
apply succ_le_inv; try assumption.
apply succ_le_lt; try assumption.
(* Goal: generic_format beta fexp (succ (Ropp x)) *)
apply generic_format_succ...
apply succ_le_inv; try assumption.
rewrite succ_DN_eq_UP; trivial.
apply round_UP_pt...
(* Goal: generic_format beta fexp (succ (Ropp x)) *)
apply generic_format_succ...
(* Goal: Rle (IZR Z0) x *)
(* Goal: Rle (IZR Z0) (pred x) *)
(* Goal: generic_format beta fexp (pred x) *)
now left.
Qed.

(* was betw_eq_UP *)
Theorem round_UP_eq_betw: forall x u, F u
    -> (pred u < x <= u)%R
    -> round beta fexp Zceil x = u.
Proof with auto with typeclass_instances.
intros x u Fu Hux.
rewrite <- (Ropp_involutive (round beta fexp Zceil x)).
rewrite <- round_DN_opp.
rewrite <- (Ropp_involutive u).
(* Goal: @eq R (Ropp (round beta fexp Zceil (Ropp (Rplus x eps)))) (Ropp (Ropp x)) *)
apply f_equal.
apply round_DN_eq_betw; try assumption.
(* Goal: generic_format beta fexp (Ropp (succ (Ropp x))) *)
now apply generic_format_opp.
split;[now apply Ropp_le_contravar|idtac].
(* Goal: Rle (succ (Ropp x)) (IZR Z0) *)
(* Goal: generic_format beta fexp (Ropp x) *)
(* Goal: generic_format beta fexp (Ropp x) *)
rewrite succ_opp.
(* Goal: Rlt (Ropp (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (Ropp (IZR Z0)) *)
(* Goal: Rge (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH))))) (IZR Z0) *)
(* Goal: @eq R (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))) (ulp (Rminus x (Fcore_Raux.bpow beta (fexp (Z.sub e (Zpos xH)))))) *)
now apply Ropp_lt_contravar.
Qed.




(** Properties of rounding to nearest and ulp *)

Theorem round_N_le_midp: forall choice u v,
  F u -> (v < (u + succ u)/2)%R
      -> (round beta fexp (Znearest choice)  v <= u)%R.
Proof with auto with typeclass_instances.
intros choice u v Fu H.
(* . *)
assert (V: ((succ u = 0 /\ u = 0) \/ u < succ u)%R).
specialize (succ_ge_id u); intros P; destruct P as [P|P].
(* Goal: Rle (ulp (IZR Z0)) (ulp (IZR Z0)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
now right.
case (Req_dec u 0); intros Zu.
(* Goal: or (and (@eq (option Z) (@None Z) (@None Z)) (forall n : Z, Z.lt (fexp n) n)) (@ex Z (fun n : Z => and (@eq (option Z) (@None Z) (@Some Z n)) (Z.le n (fexp n)))) *)
left; split; trivial.
now rewrite <- P.
(* Goal: Rlt x (succ x) *)
right; now apply succ_gt_id.
(* *)
destruct V as [(V1,V2)|V].
rewrite V2; apply round_le_generic...
(* Goal: generic_format beta fexp (IZR Z0) *)
(* Goal: @eq R (IZR Z0) f *)
apply generic_format_0.
left; apply Rlt_le_trans with (1:=H).
rewrite V1,V2; right; field.
(* *)
assert (T: (u < (u + succ u) / 2 < succ u)%R) by lra.
destruct T as (T1,T2).
apply Rnd_N_pt_monotone with F v ((u + succ u) / 2)%R...
apply round_N_pt...
apply Rnd_DN_pt_N with (succ u)%R.
pattern u at 3; replace u with (round beta fexp Zfloor ((u + succ u) / 2)).
apply round_DN_pt...
apply round_DN_eq_betw; trivial.
split; try left; assumption.
pattern (succ u) at 2; replace (succ u) with (round beta fexp Zceil ((u + succ u) / 2)).
apply round_UP_pt...
apply round_UP_eq_betw; trivial.
(* Goal: generic_format beta fexp (succ (Ropp x)) *)
apply generic_format_succ...
rewrite pred_succ; trivial.
split; try left; assumption.
right; field.
Qed.


Theorem round_N_ge_midp: forall choice u v,
 F u ->  ((u + pred u)/2 < v)%R
      -> (u <= round beta fexp (Znearest choice)  v)%R.
Proof with auto with typeclass_instances.
intros choice u v Fu H.
rewrite <- (Ropp_involutive v).
rewrite round_N_opp.
rewrite <- (Ropp_involutive u).
(* Goal: Rle (Ropp (succ (Ropp x))) (Ropp (Ropp x)) *)
apply Ropp_le_contravar.
apply round_N_le_midp.
(* Goal: generic_format beta fexp (Ropp (succ (Ropp x))) *)
now apply generic_format_opp.
apply Ropp_lt_cancel.
(* Goal: @eq R (Rplus (Ropp (succ (Ropp (Ropp x)))) (Rminus (ulp (Ropp (succ (Ropp (Ropp x))))) eps)) (Ropp (Rplus x eps)) *)
rewrite Ropp_involutive.
apply Rle_lt_trans with (2:=H).
(* Goal: @eq R (Rplus (pred (Ropp x)) (Rminus (ulp (pred (Ropp x))) eps)) (Ropp (Rplus x eps)) *)
unfold pred.
right; field.
Qed.


Lemma round_N_eq_DN: forall choice x,
       let d:=round beta fexp Zfloor x in
       let u:=round beta fexp Zceil x in
      (x<(d+u)/2)%R ->
     round beta fexp (Znearest choice) x = d.
Proof with auto with typeclass_instances.
intros choice x d u H.
(* Goal: @eq R (pred (succ x)) x *)
apply Rle_antisym.
destruct (generic_format_EM beta fexp x) as [Fx|Fx].
rewrite round_generic...
(* Goal: Rle (ulp (IZR Z0)) (ulp (IZR Z0)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
apply round_DN_pt; trivial; now right.
apply round_N_le_midp.
apply round_DN_pt...
apply Rlt_le_trans with (1:=H).
(* Goal: @eq R (Ropp (round beta fexp Zceil (Ropp (Rplus x eps)))) (Ropp (Ropp x)) *)
right; apply f_equal2; trivial; apply f_equal.
now apply sym_eq, succ_DN_eq_UP.
apply round_ge_generic; try apply round_DN_pt...
Qed.

Lemma round_N_eq_DN_pt: forall choice x d u,
      Rnd_DN_pt F x d -> Rnd_UP_pt F x u ->
      (x<(d+u)/2)%R ->
     round beta fexp (Znearest choice) x = d.
Proof with auto with typeclass_instances.
intros choice x d u Hd Hu H.
assert (H0:(d = round beta fexp Zfloor x)%R).
apply Rnd_DN_pt_unicity with (1:=Hd).
apply round_DN_pt...
rewrite H0.
apply round_N_eq_DN.
rewrite <- H0.
rewrite Rnd_UP_pt_unicity with F x (round beta fexp Zceil x) u; try assumption.
apply round_UP_pt...
Qed.

Lemma round_N_eq_UP: forall choice x,
      let d:=round beta fexp Zfloor x in
      let u:=round beta fexp Zceil x in
     ((d+u)/2 < x)%R ->
     round beta fexp (Znearest choice) x = u.
Proof with auto with typeclass_instances.
intros choice x d u H.
(* Goal: @eq R (pred (succ x)) x *)
apply Rle_antisym.
apply round_le_generic; try apply round_UP_pt...
destruct (generic_format_EM beta fexp x) as [Fx|Fx].
rewrite round_generic...
(* Goal: Rle (ulp (IZR Z0)) (ulp (IZR Z0)) *)
(* Goal: and (Rlt (IZR Z0) eps) (Rle eps (if Rle_bool (IZR Z0) (pred x) then ulp (pred x) else ulp x)) *)
(* Goal: generic_format beta fexp (Ropp x) *)
apply round_UP_pt; trivial; now right.
apply round_N_ge_midp.
apply round_UP_pt...
apply Rle_lt_trans with (2:=H).
right; apply f_equal2; trivial; rewrite Rplus_comm; apply f_equal2; trivial.
now apply pred_UP_eq_DN.
Qed.

Lemma round_N_eq_UP_pt: forall choice x d u,
      Rnd_DN_pt F x d -> Rnd_UP_pt F x u ->
      ((d+u)/2 < x)%R ->
     round beta fexp (Znearest choice) x = u.
Proof with auto with typeclass_instances.
intros choice x d u Hd Hu H.
assert (H0:(u = round beta fexp Zceil x)%R).
apply Rnd_UP_pt_unicity with (1:=Hu).
apply round_UP_pt...
rewrite H0.
apply round_N_eq_UP.
rewrite <- H0.
rewrite Rnd_DN_pt_unicity with F x (round beta fexp Zfloor x) d; try assumption.
apply round_DN_pt...
Qed.

End Fcore_ulp.
