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

(** * What is a real number belonging to a format, and many properties. *)
Require Import Fcore_Raux.
Require Import Fcore_defs.
Require Import Fcore_rnd.
Require Import Fcore_float_prop.

Section Generic.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Section Format.

Variable fexp : Z -> Z.

(** To be a good fexp *)

Class Valid_exp :=
  valid_exp :
  forall k : Z,
  ( (fexp k < k)%Z -> (fexp (k + 1) <= k)%Z ) /\
  ( (k <= fexp k)%Z ->
    (fexp (fexp k + 1) <= fexp k)%Z /\
    forall l : Z, (l <= fexp k)%Z -> fexp l = fexp k ).

Context { valid_exp_ : Valid_exp }.

Theorem valid_exp_large :
  forall k l,
  (fexp k < k)%Z -> (k <= l)%Z ->
  (fexp l < l)%Z.
Proof.
(* Goal: forall (k l : Z) (_ : Z.lt (fexp k) k) (_ : Z.le l k), Z.lt (fexp l) k *)
intros k l Hk H.
(* Goal: Z.lt (canonic_exp x) (ln_beta_val beta x (ln_beta beta x)) *)
apply Znot_ge_lt.
(* Goal: not (Z.ge (fexp l) l) *)
intros Hl.
(* Goal: False *)
apply Zge_le in Hl.
(* Goal: False *)
assert (H' := proj2 (proj2 (valid_exp l) Hl) k).
(* Goal: Z.le Z0 (Z.opp (Z.add (Zfloor x) (Zpos xH))) *)
omega.
Qed.

Theorem valid_exp_large' :
  forall k l,
  (fexp k < k)%Z -> (l <= k)%Z ->
  (fexp l < k)%Z.
Proof.
(* Goal: forall (k l : Z) (_ : Z.lt (fexp k) k) (_ : Z.le l k), Z.lt (fexp l) k *)
intros k l Hk H.
(* Goal: Z.lt (canonic_exp x) (ln_beta_val beta x (ln_beta beta x)) *)
apply Znot_ge_lt.
(* Goal: not (Z.ge (fexp l) k) *)
intros H'.
(* Goal: False *)
apply Zge_le in H'.
(* Goal: False *)
assert (Hl := Zle_trans _ _ _ H H').
(* Goal: False *)
apply valid_exp in Hl.
(* Goal: False *)
assert (H1 := proj2 Hl k H').
(* Goal: Z.le Z0 (Z.opp (Z.add (Zfloor x) (Zpos xH))) *)
omega.
Qed.

Definition canonic_exp x :=
  fexp (ln_beta beta x).

Definition canonic (f : float beta) :=
  Fexp f = canonic_exp (F2R f).

Definition scaled_mantissa x :=
  (x * bpow (- canonic_exp x))%R.

Definition generic_format (x : R) :=
  x = F2R (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x)).

(** Basic facts *)
Theorem generic_format_0 :
  generic_format 0.
Proof.
(* Goal: generic_format (@F2R beta (Float beta m e)) *)
unfold generic_format, scaled_mantissa.
(* Goal: @eq R (@F2R beta (Float beta (rnd (Rmult (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp (IZR Z0)))))) (canonic_exp (IZR Z0)))) (IZR Z0) *)
rewrite Rmult_0_l.
(* Goal: @eq R (IZR Z0) (@F2R beta (Float beta (Ztrunc (IZR Z0)) (canonic_exp (IZR Z0)))) *)
change (Ztrunc 0) with (Ztrunc (Z2R 0)).
(* Goal: @eq R (IZR Z0) (@F2R beta (Float beta (Ztrunc (Z2R Z0)) (canonic_exp (IZR Z0)))) *)
now rewrite Ztrunc_Z2R, F2R_0.
Qed.

Theorem canonic_exp_opp :
  forall x,
  canonic_exp (-x) = canonic_exp x.
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: Z.le Z0 (Z.add (canonic_exp x) (Z.opp (fexp e))) *)
(* Goal: @eq R x (@F2R beta (Float beta (Ztrunc (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (fexp e))) *)
unfold canonic_exp.
(* Goal: @eq Z (fexp (ln_beta_val beta (Ropp x) (ln_beta beta (Ropp x)))) (fexp (ln_beta_val beta x (ln_beta beta x))) *)
now rewrite ln_beta_opp.
Qed.

Theorem canonic_exp_abs :
  forall x,
  canonic_exp (Rabs x) = canonic_exp x.
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: Z.le Z0 (Z.add (canonic_exp x) (Z.opp (fexp e))) *)
(* Goal: @eq R x (@F2R beta (Float beta (Ztrunc (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (fexp e))) *)
unfold canonic_exp.
(* Goal: @eq Z (fexp (ln_beta_val beta (Rabs x) (ln_beta beta (Rabs x)))) (fexp (ln_beta_val beta x (ln_beta beta x))) *)
now rewrite ln_beta_abs.
Qed.

Theorem generic_format_bpow :
  forall e, (fexp (e + 1) <= e)%Z ->
  generic_format (bpow e).
Proof.
(* Goal: forall (e : Z) (_ : Z.le (fexp (Z.add e (Zpos xH))) e), generic_format (Fcore_Raux.bpow beta e) *)
intros e H.
(* Goal: generic_format (Fcore_Raux.bpow beta e) *)
unfold generic_format, scaled_mantissa, canonic_exp.
(* Goal: @eq R (Fcore_Raux.bpow beta e) (@F2R beta (Float beta (Ztrunc (Rmult (Fcore_Raux.bpow beta e) (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta (Fcore_Raux.bpow beta e) (ln_beta beta (Fcore_Raux.bpow beta e)))))))) (fexp (ln_beta_val beta (Fcore_Raux.bpow beta e) (ln_beta beta (Fcore_Raux.bpow beta e)))))) *)
rewrite ln_beta_bpow.
(* Goal: @eq R (Fcore_Raux.bpow beta e) (@F2R beta (Float beta (Ztrunc (Rmult (Fcore_Raux.bpow beta e) (Fcore_Raux.bpow beta (Z.opp (fexp (Z.add e (Zpos xH))))))) (fexp (Z.add e (Zpos xH))))) *)
rewrite <- bpow_plus.
(* Goal: @eq R (Fcore_Raux.bpow beta e) (@F2R beta (Float beta (Ztrunc (Fcore_Raux.bpow beta (Z.add e (Z.opp (fexp (Z.add e (Zpos xH))))))) (fexp (Z.add e (Zpos xH))))) *)
rewrite <- (Z2R_Zpower beta (e + - fexp (e + 1))).
(* Goal: @eq R (Fcore_Raux.bpow beta e) (@F2R beta (Float beta (Ztrunc (Z2R (Z.pow (radix_val beta) (Z.add e (Z.opp (fexp (Z.add e (Zpos xH)))))))) (fexp (Z.add e (Zpos xH))))) *)
(* Goal: Z.le Z0 (Z.add e (Z.opp (fexp (Z.add e (Zpos xH))))) *)
rewrite Ztrunc_Z2R.
(* Goal: @eq R (round Zceil x) (Fcore_Raux.bpow beta (fexp ex)) *)
rewrite <- F2R_bpow.
(* Goal: @eq R (@F2R beta (Float beta (Zpos xH) e)) (@F2R beta (Float beta (Z.pow (radix_val beta) (Z.add e (Z.opp (fexp (Z.add e (Zpos xH)))))) (fexp (Z.add e (Zpos xH))))) *)
(* Goal: Z.le Z0 (Z.add e (Z.opp (fexp (Z.add e (Zpos xH))))) *)
rewrite F2R_change_exp with (1 := H).
(* Goal: @eq R (@F2R beta (Float beta (Z.mul (Zpos xH) (Z.pow (radix_val beta) (Z.sub e (fexp (Z.add e (Zpos xH)))))) (fexp (Z.add e (Zpos xH))))) (@F2R beta (Float beta (Z.pow (radix_val beta) (Z.add e (Z.opp (fexp (Z.add e (Zpos xH)))))) (fexp (Z.add e (Zpos xH))))) *)
(* Goal: Z.le Z0 (Z.add e (Z.opp (fexp (Z.add e (Zpos xH))))) *)
now rewrite Zmult_1_l.
(* Goal: Z.le Z0 (Z.add e (Z.opp (fexp (Z.add e (Zpos xH))))) *)
now apply Zle_minus_le_0.
Qed.

Theorem generic_format_bpow' :
  forall e, (fexp e <= e)%Z ->
  generic_format (bpow e).
Proof.
(* Goal: forall (e : Z) (_ : generic_format (Fcore_Raux.bpow beta e)), Z.le (fexp e) e *)
intros e He.
(* Goal: generic_format (Fcore_Raux.bpow beta e) *)
apply generic_format_bpow.
(* Goal: Z.le (fexp (Z.add e (Zpos xH))) e *)
destruct (Zle_lt_or_eq _ _ He).
(* Goal: Z.le (fexp (Z.add e (Zpos xH))) e *)
(* Goal: Z.le (fexp (Z.add e (Zpos xH))) e *)
now apply valid_exp_.
(* Goal: @eq R x (@F2R beta (Float beta (Ztrunc (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (fexp e))) *)
rewrite <- H.
(* Goal: Z.le (fexp (Z.add (fexp e) (Zpos xH))) (fexp e) *)
apply valid_exp.
(* Goal: @eq R x (Rmult (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Z2R (Z.pow (radix_val beta) (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (Fcore_Raux.bpow beta (fexp e))) *)
rewrite H.
(* Goal: Z.le e2 e2 *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Rabs x)) (Rle (Rabs x) (Fcore_Raux.bpow beta e2)) *)
apply Zle_refl.
Qed.

Theorem generic_format_F2R :
  forall m e,
  ( m <> 0 -> canonic_exp (F2R (Float beta m e)) <= e )%Z ->
  generic_format (F2R (Float beta m e)).
Proof.
(* Goal: forall (m e : Z) (_ : forall _ : not (@eq Z m Z0), Z.le (canonic_exp (@F2R beta (Float beta m e))) e), generic_format (@F2R beta (Float beta m e)) *)
intros m e.
(* Goal: forall _ : forall _ : not (@eq Z m Z0), Z.le (canonic_exp (@F2R beta (Float beta m e))) e, generic_format (@F2R beta (Float beta m e)) *)
destruct (Z_eq_dec m 0) as [Zm|Zm].
(* Goal: forall _ : @eq R (Rminus (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) (Rminus (Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x)))), @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
(* Goal: forall _ : @eq R (Rminus (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) (Rminus (Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x)))), @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
intros _.
(* Goal: generic_format (@F2R beta (Float beta m e)) *)
(* Goal: forall _ : forall _ : not (@eq Z m Z0), Z.le (canonic_exp (@F2R beta (Float beta m e))) e, generic_format (@F2R beta (Float beta m e)) *)
rewrite Zm, F2R_0.
(* Goal: generic_format (IZR Z0) *)
(* Goal: forall _ : forall _ : not (@eq Z m Z0), Z.le (canonic_exp (@F2R beta (Float beta m e))) e, generic_format (@F2R beta (Float beta m e)) *)
apply generic_format_0.
(* Goal: generic_format (@F2R beta (Float beta m e)) *)
unfold generic_format, scaled_mantissa.
(* Goal: forall _ : forall _ : not (@eq Z m Z0), Z.le (canonic_exp (@F2R beta (Float beta m e))) e, @eq R (@F2R beta (Float beta m e)) (@F2R beta (Float beta (Ztrunc (Rmult (@F2R beta (Float beta m e)) (Fcore_Raux.bpow beta (Z.opp (canonic_exp (@F2R beta (Float beta m e))))))) (canonic_exp (@F2R beta (Float beta m e))))) *)
set (e' := canonic_exp (F2R (Float beta m e))).
(* Goal: forall _ : forall _ : not (@eq Z m Z0), Z.le e' e, @eq R (@F2R beta (Float beta m e)) (@F2R beta (Float beta (Ztrunc (Rmult (@F2R beta (Float beta m e)) (Fcore_Raux.bpow beta (Z.opp e')))) e')) *)
intros He.
(* Goal: @eq R (@F2R beta (Float beta m e)) (@F2R beta (Float beta (Ztrunc (Rmult (@F2R beta (Float beta m e)) (Fcore_Raux.bpow beta (Z.opp e')))) e')) *)
specialize (He Zm).
(* Goal: @eq R (@F2R beta (Float beta m e)) (@F2R beta (Float beta (Ztrunc (Rmult (@F2R beta (Float beta m e)) (Fcore_Raux.bpow beta (Z.opp e')))) e')) *)
unfold F2R at 3. simpl.
rewrite  F2R_change_exp with (1 := He).
(* Goal: @eq R (@F2R beta (Float beta (rnd (Ropp (scaled_mantissa x))) (canonic_exp x))) (@F2R beta (Float beta (Z.opp (Zrnd_opp (scaled_mantissa x))) (canonic_exp x))) *)
apply F2R_eq_compat.
(* Goal: @eq Z (Z.mul m (Z.pow (radix_val beta) (Z.sub e e'))) (Ztrunc (Rmult (Rmult (Z2R m) (Fcore_Raux.bpow beta e)) (Fcore_Raux.bpow beta (Z.opp e')))) *)
rewrite Rmult_assoc, <- bpow_plus, <- Z2R_Zpower, <- Z2R_mult.
(* Goal: @eq R (Fcore_Raux.bpow beta e) (@F2R beta (Float beta (Ztrunc (Z2R (Z.pow (radix_val beta) (Z.add e (Z.opp (fexp (Z.add e (Zpos xH)))))))) (fexp (Z.add e (Zpos xH))))) *)
(* Goal: Z.le Z0 (Z.add e (Z.opp (fexp (Z.add e (Zpos xH))))) *)
now rewrite Ztrunc_Z2R.
(* Goal: Z.le Z0 (Z.add e (Z.opp e')) *)
now apply Zle_left.
Qed.

Lemma generic_format_F2R': forall (x:R) (f:float beta),
       F2R f = x -> ((x <> 0)%R ->
       (canonic_exp x <= Fexp f)%Z) ->
       generic_format x.
Proof.
(* Goal: forall (x : R) (f : float beta) (_ : @eq R (@F2R beta f) x) (_ : forall _ : not (@eq R x (IZR Z0)), Z.le (canonic_exp x) (@Fexp beta f)), generic_format x *)
intros x f H1 H2.
(* Goal: generic_format x *)
rewrite <- H1; destruct f as (m,e).
apply  generic_format_F2R.
(* Goal: forall _ : not (@eq Z m Z0), Z.le (canonic_exp (@F2R beta (Float beta m e))) e *)
simpl in *; intros H3.
(* Goal: Z.le (canonic_exp (@F2R beta (Float beta m e))) e *)
rewrite H1; apply H2.
(* Goal: not (@eq R x (IZR Z0)) *)
intros Y; apply H3.
(* Goal: @eq Z m Z0 *)
apply F2R_eq_0_reg with beta e.
(* Goal: @eq R (@F2R beta (Float beta m e)) (IZR Z0) *)
now rewrite H1.
Qed.


Theorem canonic_opp :
  forall m e,
  canonic (Float beta m e) ->
  canonic (Float beta (-m) e).
Proof.
(* Goal: forall (m e : Z) (_ : canonic (Float beta m e)), canonic (Float beta (Z.abs m) e) *)
intros m e H.
(* Goal: forall (_ : canonic (Float beta m1 e1)) (_ : canonic (Float beta m2 e2)) (_ : @eq R (@F2R beta (Float beta m1 e1)) (@F2R beta (Float beta m2 e2))), @eq (float beta) (Float beta m1 e1) (Float beta m2 e2) *)
unfold canonic.
(* Goal: @eq Z (@Fexp beta (Float beta (Z.opp m) e)) (canonic_exp (@F2R beta (Float beta (Z.opp m) e))) *)
now rewrite F2R_Zopp, canonic_exp_opp.
Qed.

Theorem canonic_abs :
  forall m e,
  canonic (Float beta m e) ->
  canonic (Float beta (Zabs m) e).
Proof.
(* Goal: forall (m e : Z) (_ : canonic (Float beta m e)), canonic (Float beta (Z.abs m) e) *)
intros m e H.
(* Goal: forall (_ : canonic (Float beta m1 e1)) (_ : canonic (Float beta m2 e2)) (_ : @eq R (@F2R beta (Float beta m1 e1)) (@F2R beta (Float beta m2 e2))), @eq (float beta) (Float beta m1 e1) (Float beta m2 e2) *)
unfold canonic.
(* Goal: @eq Z (@Fexp beta (Float beta (Z.abs m) e)) (canonic_exp (@F2R beta (Float beta (Z.abs m) e))) *)
now rewrite F2R_Zabs, canonic_exp_abs.
Qed.

Theorem canonic_0: canonic (Float beta 0 (fexp (ln_beta beta 0%R))).
Proof.
(* Goal: Z.le Z0 (Z.add (canonic_exp x) (Z.opp (fexp e))) *)
(* Goal: @eq R x (@F2R beta (Float beta (Ztrunc (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (fexp e))) *)
unfold canonic; simpl; unfold canonic_exp.
(* Goal: @eq Z (fexp (ln_beta_val beta (IZR Z0) (ln_beta beta (IZR Z0)))) (fexp (ln_beta_val beta (@F2R beta (Float beta Z0 (fexp (ln_beta_val beta (IZR Z0) (ln_beta beta (IZR Z0)))))) (ln_beta beta (@F2R beta (Float beta Z0 (fexp (ln_beta_val beta (IZR Z0) (ln_beta beta (IZR Z0))))))))) *)
replace (F2R {| Fnum := 0; Fexp := fexp (ln_beta beta 0) |}) with 0%R.
(* Goal: @eq Z (fexp (ln_beta_val beta (IZR Z0) (ln_beta beta (IZR Z0)))) (fexp (ln_beta_val beta (IZR Z0) (ln_beta beta (IZR Z0)))) *)
(* Goal: @eq R (IZR Z0) (@F2R beta (Float beta Z0 (fexp (ln_beta_val beta (IZR Z0) (ln_beta beta (IZR Z0)))))) *)
reflexivity.
(* Goal: @eq R (IZR Z0) (@F2R beta (Float beta Z0 (fexp (ln_beta_val beta (IZR Z0) (ln_beta beta (IZR Z0)))))) *)
unfold F2R; simpl; ring.
Qed.



Theorem canonic_unicity :
  forall f1 f2,
  canonic f1 ->
  canonic f2 ->
  F2R f1 = F2R f2 ->
  f1 = f2.
Proof.
(* Goal: forall (f1 f2 : float beta) (_ : canonic f1) (_ : canonic f2) (_ : @eq R (@F2R beta f1) (@F2R beta f2)), @eq (float beta) f1 f2 *)
intros (m1, e1) (m2, e2).
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
unfold canonic. simpl.
(* Goal: forall (_ : @eq Z e1 (canonic_exp (@F2R beta (Float beta m1 e1)))) (_ : @eq Z e2 (canonic_exp (@F2R beta (Float beta m2 e2)))) (_ : @eq R (@F2R beta (Float beta m1 e1)) (@F2R beta (Float beta m2 e2))), @eq (float beta) (Float beta m1 e1) (Float beta m2 e2) *)
intros H1 H2 H.
(* Goal: @eq (float beta) (Float beta m1 e1) (Float beta m2 e2) *)
rewrite H in H1.
(* Goal: @eq (float beta) (Float beta m1 e1) (Float beta m2 e2) *)
rewrite <- H2 in H1. clear H2.
(* Goal: @eq (float beta) (Float beta m1 e1) (Float beta m2 e2) *)
rewrite H1 in H |- *.
(* Goal: @eq (float beta) (Float beta m1 e2) (Float beta m2 e2) *)
apply (f_equal (fun m => Float beta m e2)).
(* Goal: @eq Z m1 m2 *)
apply F2R_eq_reg with (1 := H).
Qed.

Theorem scaled_mantissa_generic :
  forall x,
  generic_format x ->
  scaled_mantissa x = Z2R (Ztrunc (scaled_mantissa x)).
Proof.
(* Goal: forall (x : R) (_ : not (@eq R (Rminus x (Z2R (Zfloor x))) (Rinv (IZR (Zpos (xO xH)))))), Rlt (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
intros x Hx.
(* Goal: @eq R (scaled_mantissa (round Zfloor x)) (Z2R (Zfloor (scaled_mantissa x))) *)
unfold scaled_mantissa.
(* Goal: @eq R (Rmult x (Fcore_Raux.bpow beta (Z.opp (canonic_exp x)))) (Z2R (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (canonic_exp x)))))) *)
pattern x at 1 3 ; rewrite Hx.
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
unfold F2R. simpl.
(* Goal: Rle (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Rmult (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) *)
(* Goal: Rle (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta ex) *)
rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r.
(* Goal: @eq R (Fcore_Raux.bpow beta e) (@F2R beta (Float beta (Ztrunc (Z2R (Z.pow (radix_val beta) (Z.add e (Z.opp (fexp (Z.add e (Zpos xH)))))))) (fexp (Z.add e (Zpos xH))))) *)
(* Goal: Z.le Z0 (Z.add e (Z.opp (fexp (Z.add e (Zpos xH))))) *)
now rewrite Ztrunc_Z2R.
Qed.

Theorem scaled_mantissa_mult_bpow :
  forall x,
  (scaled_mantissa x * bpow (canonic_exp x))%R = x.
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: @eq R (scaled_mantissa (round Zfloor x)) (Z2R (Zfloor (scaled_mantissa x))) *)
unfold scaled_mantissa.
(* Goal: Rlt (Rmult (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (IZR (Zpos xH)) (Fcore_Raux.bpow beta (fexp ex))) *)
rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_l.
(* Goal: @eq R (Rmult x (Fcore_Raux.bpow beta Z0)) x *)
apply Rmult_1_r.
Qed.

Theorem scaled_mantissa_0 :
  scaled_mantissa 0 = 0%R.
Proof.
(* Goal: @eq R (scaled_mantissa (IZR Z0)) (IZR Z0) *)
apply Rmult_0_l.
Qed.

Theorem scaled_mantissa_opp :
  forall x,
  scaled_mantissa (-x) = (-scaled_mantissa x)%R.
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: @eq R (scaled_mantissa (round Zfloor x)) (Z2R (Zfloor (scaled_mantissa x))) *)
unfold scaled_mantissa.
(* Goal: @eq R (Rmult (Z2R (Znearest choice (scaled_mantissa (Ropp x)))) (Fcore_Raux.bpow beta (canonic_exp (Ropp x)))) (Ropp (Rmult (Z2R (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) *)
rewrite canonic_exp_opp.
(* Goal: @eq R (Rmult (Ropp (Z2R (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)))) (Fcore_Raux.bpow beta (canonic_exp x))) (Ropp (Rmult (Z2R (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) *)
now rewrite Ropp_mult_distr_l_reverse.
Qed.

Theorem scaled_mantissa_abs :
  forall x,
  scaled_mantissa (Rabs x) = Rabs (scaled_mantissa x).
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: @eq R (scaled_mantissa (round Zfloor x)) (Z2R (Zfloor (scaled_mantissa x))) *)
unfold scaled_mantissa.
(* Goal: @eq R (Rmult (Rabs x) (Fcore_Raux.bpow beta (Z.opp (canonic_exp (Rabs x))))) (Rabs (Rmult x (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))))) *)
rewrite canonic_exp_abs, Rabs_mult.
(* Goal: @eq R (Rmult (Rabs x) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x)))) (Rmult (Rabs x) (Rabs (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))))) *)
apply f_equal.
(* Goal: @eq Z (rnd (Ropp (scaled_mantissa x))) (Z.opp (Zrnd_opp (scaled_mantissa x))) *)
apply sym_eq.
(* Goal: @eq R (Rabs (Rinv (IZR (Zpos (xO xH))))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
apply Rabs_pos_eq.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_ge_0.
Qed.

Theorem generic_format_opp :
  forall x, generic_format x -> generic_format (-x).
Proof.
(* Goal: forall (x : R) (_ : not (@eq R (Rminus x (Z2R (Zfloor x))) (Rinv (IZR (Zpos (xO xH)))))), Rlt (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
intros x Hx.
(* Goal: generic_format (Rabs x) *)
unfold generic_format.
(* Goal: @eq R (Ropp x) (@F2R beta (Float beta (Ztrunc (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))) *)
rewrite scaled_mantissa_opp, canonic_exp_opp.
(* Goal: @eq R (Ropp x) (@F2R beta (Float beta (Ztrunc (Ropp (scaled_mantissa x))) (canonic_exp x))) *)
rewrite Ztrunc_opp.
(* Goal: @eq R (Ropp x) (@F2R beta (Float beta (Z.opp (Ztrunc (scaled_mantissa x))) (canonic_exp x))) *)
rewrite F2R_Zopp.
(* Goal: @eq R (Rmult (Rabs x) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x)))) (Rmult (Rabs x) (Rabs (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))))) *)
now apply f_equal.
Qed.

Theorem generic_format_abs :
  forall x, generic_format x -> generic_format (Rabs x).
Proof.
(* Goal: forall (x : R) (_ : not (@eq R (Rminus x (Z2R (Zfloor x))) (Rinv (IZR (Zpos (xO xH)))))), Rlt (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
intros x Hx.
(* Goal: generic_format (Rabs x) *)
unfold generic_format.
(* Goal: @eq R (Rabs x) (@F2R beta (Float beta (Ztrunc (scaled_mantissa (Rabs x))) (canonic_exp (Rabs x)))) *)
rewrite scaled_mantissa_abs, canonic_exp_abs.
(* Goal: @eq R (Rabs x) (@F2R beta (Float beta (Ztrunc (Rabs (scaled_mantissa x))) (canonic_exp x))) *)
rewrite Ztrunc_abs.
(* Goal: @eq R (Rabs x) (@F2R beta (Float beta (Z.abs (Ztrunc (scaled_mantissa x))) (canonic_exp x))) *)
rewrite F2R_Zabs.
(* Goal: @eq R (Rmult (Rabs x) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x)))) (Rmult (Rabs x) (Rabs (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))))) *)
now apply f_equal.
Qed.

Theorem generic_format_abs_inv :
  forall x, generic_format (Rabs x) -> generic_format x.
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: forall _ : generic_format (Rabs x), generic_format x *)
unfold generic_format, Rabs.
(* Goal: forall _ : @eq R (Rminus (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) (Rminus (Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x)))), @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
(* Goal: forall _ : @eq R (Rminus (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) (Rminus (Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x)))), @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
case Rcase_abs ; intros _.
(* Goal: @eq R (@F2R beta (Float beta (Ztrunc (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))) (Ropp (@F2R beta (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x)))) *)
rewrite scaled_mantissa_opp, canonic_exp_opp, Ztrunc_opp.
(* Goal: forall _ : @eq R (Rminus (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) (Rminus (Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x)))), @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
intros H.
(* Goal: @eq R x (@F2R beta (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x))) *)
(* Goal: forall _ : @eq R x (@F2R beta (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x))), @eq R x (@F2R beta (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x))) *)
rewrite <- (Ropp_involutive x) at 1.
(* Goal: @eq R (Ropp (Ropp x)) (@F2R beta (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x))) *)
(* Goal: forall _ : @eq R x (@F2R beta (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x))), @eq R x (@F2R beta (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x))) *)
rewrite H, F2R_Zopp.
(* Goal: @eq R (Ropp (Ropp (@F2R beta (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x))))) (@F2R beta (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x))) *)
(* Goal: forall _ : @eq R x (@F2R beta (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x))), @eq R x (@F2R beta (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x))) *)
apply Ropp_involutive.
(* Goal: @eq Z n n *)
(* Goal: Rlt (Rminus (Z2R n) (Z2R n)) (Rinv (IZR (Zpos (xO xH)))) *)
easy.
Qed.

Theorem canonic_exp_fexp :
  forall x ex,
  (bpow (ex - 1) <= Rabs x < bpow ex)%R ->
  canonic_exp x = fexp ex.
Proof.
(* Goal: forall (x : R) (ex : Z) (_ : and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) x) (Rlt x (Fcore_Raux.bpow beta ex))), @eq Z (canonic_exp x) (fexp ex) *)
intros x ex Hx.
(* Goal: Z.le Z0 (Z.add (canonic_exp x) (Z.opp (fexp e))) *)
(* Goal: @eq R x (@F2R beta (Float beta (Ztrunc (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (fexp e))) *)
unfold canonic_exp.
(* Goal: @eq Z (fexp (ln_beta_val beta x (ln_beta beta x))) (fexp ex) *)
now rewrite ln_beta_unique with (1 := Hx).
Qed.

Theorem canonic_exp_fexp_pos :
  forall x ex,
  (bpow (ex - 1) <= x < bpow ex)%R ->
  canonic_exp x = fexp ex.
Proof.
(* Goal: forall (x : R) (ex : Z) (_ : and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) x) (Rlt x (Fcore_Raux.bpow beta ex))), @eq Z (canonic_exp x) (fexp ex) *)
intros x ex Hx.
(* Goal: @eq Z (canonic_exp x) (fexp ex) *)
apply canonic_exp_fexp.
(* Goal: Rle x (Rabs f) *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
rewrite Rabs_pos_eq.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) x) (Rlt x (Fcore_Raux.bpow beta ex)) *)
(* Goal: Rle (IZR Z0) x *)
exact Hx.
(* Goal: Rle (IZR Z0) x *)
apply Rle_trans with (2 := proj1 Hx).
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_ge_0.
Qed.

(** Properties when the real number is "small" (kind of subnormal) *)
Theorem mantissa_small_pos :
  forall x ex,
  (bpow (ex - 1) <= x < bpow ex)%R ->
  (ex <= fexp ex)%Z ->
  (0 < x * bpow (- fexp ex) < 1)%R.
Proof.
(* Goal: forall (x : R) (ex : Z) (_ : and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) x) (Rlt x (Fcore_Raux.bpow beta ex))) (_ : Z.le ex (fexp ex)), @eq R (round Zceil x) (Fcore_Raux.bpow beta (fexp ex)) *)
intros x ex Hx He.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
split.
(* Goal: Rlt (IZR Z0) (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) *)
(* Goal: Rlt (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (IZR (Zpos xH)) *)
apply Rmult_lt_0_compat.
(* Goal: Rlt (IZR Z0) x *)
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (fexp ex))) *)
(* Goal: Rlt (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (IZR (Zpos xH)) *)
apply Rlt_le_trans with (2 := proj1 Hx).
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_gt_0.
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_gt_0.
(* Goal: Rlt (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (IZR (Zpos xH)) *)
apply Rmult_lt_reg_r with (bpow (fexp ex)).
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_gt_0.
(* Goal: Rlt (Rmult (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (IZR (Zpos xH)) (Fcore_Raux.bpow beta (fexp ex))) *)
rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_l.
(* Goal: Rlt (Rmult x (Fcore_Raux.bpow beta Z0)) (Rmult (IZR (Zpos xH)) (Fcore_Raux.bpow beta (fexp ex))) *)
rewrite Rmult_1_r, Rmult_1_l.
(* Goal: Rlt x (Fcore_Raux.bpow beta (fexp ex)) *)
apply Rlt_le_trans with (1 := proj2 Hx).
(* Goal: Rle (Fcore_Raux.bpow beta emin) (Fcore_Raux.bpow beta (fexp (ln_beta_val beta x (ln_beta beta x)))) *)
(* Goal: Rle (Fcore_Raux.bpow beta (fexp (ln_beta_val beta x (ln_beta beta x)))) (@F2R beta (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x))) *)
now apply bpow_le.
Qed.

Theorem scaled_mantissa_small :
  forall x ex,
  (Rabs x < bpow ex)%R ->
  (ex <= fexp ex)%Z ->
  (Rabs (scaled_mantissa x) < 1)%R.
Proof.
(* Goal: forall (x : R) (ex : Z) (_ : Rlt (Rabs x) (Fcore_Raux.bpow beta ex)) (_ : Z.le ex (fexp ex)), Rlt (Rabs (scaled_mantissa x)) (IZR (Zpos xH)) *)
intros x ex Ex He.
(* Goal: Rlt (Rabs (scaled_mantissa x)) (Fcore_Raux.bpow beta (Z.sub (ln_beta_val beta x (ln_beta beta x)) (canonic_exp x))) *)
destruct (Req_dec x 0) as [Zx|Zx].
(* Goal: Rlt (Rabs (scaled_mantissa x)) (Fcore_Raux.bpow beta (Z.sub (ln_beta_val beta x (ln_beta beta x)) (canonic_exp x))) *)
(* Goal: Rlt (Rabs (scaled_mantissa x)) (Fcore_Raux.bpow beta (Z.sub (ln_beta_val beta x (ln_beta beta x)) (canonic_exp x))) *)
rewrite Zx, scaled_mantissa_0, Rabs_R0.
(* Goal: Rlt (IZR Z0) (IZR (Zpos xH)) *)
(* Goal: Rlt (Rabs (scaled_mantissa x)) (IZR (Zpos xH)) *)
now apply (Z2R_lt 0 1).
(* Goal: Rlt (Rabs (scaled_mantissa x)) (IZR (Zpos xH)) *)
rewrite <- scaled_mantissa_abs.
(* Goal: @eq R (scaled_mantissa (round Zfloor x)) (Z2R (Zfloor (scaled_mantissa x))) *)
unfold scaled_mantissa.
(* Goal: Rlt (Rmult (Rabs x) (Fcore_Raux.bpow beta (Z.opp (canonic_exp (Rabs x))))) (IZR (Zpos xH)) *)
rewrite canonic_exp_abs.
(* Goal: Z.le Z0 (Z.add (canonic_exp x) (Z.opp (fexp e))) *)
(* Goal: @eq R x (@F2R beta (Float beta (Ztrunc (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (fexp e))) *)
unfold canonic_exp.
(* Goal: Rlt (Rmult (Rabs x) (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x)))))) (IZR (Zpos xH)) *)
destruct (ln_beta beta x) as (ex', Ex').
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
simpl.
(* Goal: Rlt (Rmult (Rabs x) (Fcore_Raux.bpow beta (Z.opp (fexp ex')))) (IZR (Zpos xH)) *)
specialize (Ex' Zx).
(* Goal: Rlt (Rmult (Rabs x) (Fcore_Raux.bpow beta (Z.opp (fexp ex')))) (IZR (Zpos xH)) *)
apply (mantissa_small_pos _ _ Ex').
(* Goal: Z.le ex' (fexp ex') *)
assert (ex' <= fexp ex)%Z.
(* Goal: Z.le ex' (fexp ex) *)
(* Goal: Z.le ex' (fexp ex') *)
apply Zle_trans with (2 := He).
(* Goal: Z.le ex' ex *)
(* Goal: Z.le ex' (fexp ex') *)
apply bpow_lt_bpow with beta.
(* Goal: Rlt (Fcore_Raux.bpow beta (Z.sub ex' (Zpos xH))) (Fcore_Raux.bpow beta ex) *)
(* Goal: Z.le ex' (fexp ex') *)
now apply Rle_lt_trans with (2 := Ex).
(* Goal: Z.le ex' (fexp ex') *)
now rewrite (proj2 (proj2 (valid_exp _) He)).
Qed.

Theorem abs_scaled_mantissa_lt_bpow :
  forall x,
  (Rabs (scaled_mantissa x) < bpow (ln_beta beta x - canonic_exp x))%R.
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: Rlt (Rabs (scaled_mantissa x)) (Fcore_Raux.bpow beta (Z.sub (ln_beta_val beta x (ln_beta beta x)) (canonic_exp x))) *)
destruct (Req_dec x 0) as [Zx|Zx].
(* Goal: Rlt (Rabs (scaled_mantissa x)) (Fcore_Raux.bpow beta (Z.sub (ln_beta_val beta x (ln_beta beta x)) (canonic_exp x))) *)
(* Goal: Rlt (Rabs (scaled_mantissa x)) (Fcore_Raux.bpow beta (Z.sub (ln_beta_val beta x (ln_beta beta x)) (canonic_exp x))) *)
rewrite Zx, scaled_mantissa_0, Rabs_R0.
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_gt_0.
(* Goal: Rlt (Rabs (scaled_mantissa x)) (Fcore_Raux.bpow beta (Z.sub (ln_beta_val beta x (ln_beta beta x)) (canonic_exp x))) *)
apply Rlt_le_trans with (1 := bpow_ln_beta_gt beta _).
(* Goal: Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2) *)
(* Goal: Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2) *)
apply bpow_le.
(* Goal: @eq R (scaled_mantissa (round Zfloor x)) (Z2R (Zfloor (scaled_mantissa x))) *)
unfold scaled_mantissa.
(* Goal: Z.le (ln_beta_val beta (Rmult x (Fcore_Raux.bpow beta (Z.opp (canonic_exp x)))) (ln_beta beta (Rmult x (Fcore_Raux.bpow beta (Z.opp (canonic_exp x)))))) (Z.sub (ln_beta_val beta x (ln_beta beta x)) (canonic_exp x)) *)
rewrite ln_beta_mult_bpow with (1 := Zx).
(* Goal: Z.le e2 e2 *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Rabs x)) (Rle (Rabs x) (Fcore_Raux.bpow beta e2)) *)
apply Zle_refl.
Qed.

Theorem ln_beta_generic_gt :
  forall x, (x <> 0)%R ->
  generic_format x ->
  (canonic_exp x < ln_beta beta x)%Z.
Proof.
(* Goal: forall (x : R) (_ : not (@eq R x (IZR Z0))) (_ : generic_format x), Z.lt (canonic_exp x) (ln_beta_val beta x (ln_beta beta x)) *)
intros x Zx Gx.
(* Goal: Z.lt (canonic_exp x) (ln_beta_val beta x (ln_beta beta x)) *)
apply Znot_ge_lt.
(* Goal: Z.le Z0 (Z.add (canonic_exp x) (Z.opp (fexp e))) *)
(* Goal: @eq R x (@F2R beta (Float beta (Ztrunc (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (fexp e))) *)
unfold canonic_exp.
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
destruct (ln_beta beta x) as (ex,Ex) ; simpl.
(* Goal: not (Z.ge (fexp ex) ex) *)
specialize (Ex Zx).
(* Goal: forall _ : @eq R (Rminus (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) (Rminus (Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x)))), @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
intros H.
(* Goal: False *)
apply Zge_le in H.
(* Goal: False *)
generalize (scaled_mantissa_small x ex (proj2 Ex) H).
(* Goal: not (@eq R x R0) *)
contradict Zx.
(* Goal: @eq R x (IZR Z0) *)
rewrite Gx.
(* Goal: @eq R (@F2R beta (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x))) (IZR Z0) *)
replace (Ztrunc (scaled_mantissa x)) with Z0.
(* Goal: @eq R (@F2R beta (Float beta Z0 (canonic_exp (Z2R Z0)))) (Z2R Z0) *)
apply F2R_0.
(* Goal: @eq Z Z0 (Ztrunc (scaled_mantissa x)) *)
cut (Zabs (Ztrunc (scaled_mantissa x)) < 1)%Z.
(* Goal: Z.le Z0 (Z.opp (Z.add (Zfloor x) (Zpos xH))) *)
clear ; zify ; omega.
(* Goal: Z.lt (Zfloor (scaled_mantissa x)) Z0 *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply lt_Z2R.
(* Goal: Rlt (Z2R (Z.abs (Ztrunc (scaled_mantissa x)))) (Z2R (Zpos xH)) *)
rewrite Z2R_abs.
(* Goal: Rlt (Rabs (Z2R (Ztrunc (scaled_mantissa x)))) (Z2R (Zpos xH)) *)
now rewrite <- scaled_mantissa_generic.
Qed.

Theorem mantissa_DN_small_pos :
  forall x ex,
  (bpow (ex - 1) <= x < bpow ex)%R ->
  (ex <= fexp ex)%Z ->
  Zfloor (x * bpow (- fexp ex)) = Z0.
Proof.
(* Goal: forall (x : R) (ex : Z) (_ : and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) x) (Rlt x (Fcore_Raux.bpow beta ex))) (_ : Z.le ex (fexp ex)), @eq R (round Zceil x) (Fcore_Raux.bpow beta (fexp ex)) *)
intros x ex Hx He.
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
apply Zfloor_imp. simpl.
(* Goal: and (Rlt (IZR Z0) (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) (Rle (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (IZR (Zpos xH))) *)
assert (H := mantissa_small_pos x ex Hx He).
(* Goal: and (Rlt (IZR Z0) (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) (Rle (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (IZR (Zpos xH))) *)
split ; try apply Rlt_le ; apply H.
Qed.

Theorem mantissa_UP_small_pos :
  forall x ex,
  (bpow (ex - 1) <= x < bpow ex)%R ->
  (ex <= fexp ex)%Z ->
  Zceil (x * bpow (- fexp ex)) = 1%Z.
Proof.
(* Goal: forall (x : R) (ex : Z) (_ : and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) x) (Rlt x (Fcore_Raux.bpow beta ex))) (_ : Z.le ex (fexp ex)), @eq R (round Zceil x) (Fcore_Raux.bpow beta (fexp ex)) *)
intros x ex Hx He.
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
apply Zceil_imp. simpl.
(* Goal: and (Rlt (IZR Z0) (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) (Rle (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (IZR (Zpos xH))) *)
assert (H := mantissa_small_pos x ex Hx He).
(* Goal: and (Rlt (IZR Z0) (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) (Rle (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (IZR (Zpos xH))) *)
split ; try apply Rlt_le ; apply H.
Qed.

(** Generic facts about any format *)
Theorem generic_format_discrete :
  forall x m,
  let e := canonic_exp x in
  (F2R (Float beta m e) < x < F2R (Float beta (m + 1) e))%R ->
  ~ generic_format x.
Proof.
(* Goal: forall (x : R) (m : Z), let e := canonic_exp x in forall _ : and (Rlt (@F2R beta (Float beta m e)) x) (Rlt x (@F2R beta (Float beta (Z.add m (Zpos xH)) e))), not (generic_format x) *)
intros x m e (Hx,Hx2) Hf.
(* Goal: False *)
apply Rlt_not_le with (1 := Hx2). clear Hx2.
(* Goal: Z.le (Zceil x) match Rcompare (Rminus y (Z2R (Zfloor y))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor y) then Zceil y else Zfloor y | Lt => Zfloor y | Gt => Zceil y end *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
rewrite Hf.
(* Goal: Rle (@F2R beta (Float beta (Z.add m (Zpos xH)) e)) (@F2R beta (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x))) *)
fold e.
(* Goal: Rle (@F2R beta (Float beta (Z.add m (Zpos xH)) e)) (@F2R beta (Float beta (Ztrunc (scaled_mantissa x)) e)) *)
apply F2R_le_compat.
(* Goal: Z.le (Z.succ (Z.pred e)) (ln_beta_val beta x (ln_beta beta x)) *)
apply Zlt_le_succ.
(* Goal: Z.lt (Zfloor (scaled_mantissa x)) Z0 *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply lt_Z2R.
(* Goal: Rlt (Z2R m) (Z2R (Ztrunc (scaled_mantissa x))) *)
rewrite <- scaled_mantissa_generic with (1 := Hf).
(* Goal: Rlt (Z2R m) (scaled_mantissa x) *)
apply Rmult_lt_reg_r with (bpow e).
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_gt_0.
(* Goal: Rlt (Rmult (Z2R m) (Fcore_Raux.bpow beta e)) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta e)) *)
now rewrite scaled_mantissa_mult_bpow.
Qed.

Theorem generic_format_canonic :
  forall f, canonic f ->
  generic_format (F2R f).
Proof.
(* Goal: forall (f : float beta) (_ : canonic f), generic_format (@F2R beta f) *)
intros (m, e) Hf.
(* Goal: generic_format (@F2R beta (Float beta m e)) *)
unfold canonic in Hf. simpl in Hf.
(* Goal: generic_format (@F2R beta (Float beta m e)) *)
unfold generic_format, scaled_mantissa.
(* Goal: Z.le (Zfloor x) (Znearest y) *)
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (Znearest y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
rewrite <- Hf.
(* Goal: @eq R (@F2R beta (Float beta (rnd (Ropp (scaled_mantissa x))) (canonic_exp x))) (@F2R beta (Float beta (Z.opp (Zrnd_opp (scaled_mantissa x))) (canonic_exp x))) *)
apply F2R_eq_compat.
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
unfold F2R. simpl.
(* Goal: Rle (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Rmult (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) *)
(* Goal: Rle (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta ex) *)
rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r.
(* Goal: @eq R (Fcore_Raux.bpow beta e) (@F2R beta (Float beta (Ztrunc (Z2R (Z.pow (radix_val beta) (Z.add e (Z.opp (fexp (Z.add e (Zpos xH)))))))) (fexp (Z.add e (Zpos xH))))) *)
(* Goal: Z.le Z0 (Z.add e (Z.opp (fexp (Z.add e (Zpos xH))))) *)
now rewrite Ztrunc_Z2R.
Qed.

Theorem generic_format_ge_bpow :
  forall emin,
  ( forall e, (emin <= fexp e)%Z ) ->
  forall x,
  (0 < x)%R ->
  generic_format x ->
  (bpow emin <= x)%R.
Proof.
(* Goal: forall (emin : Z) (_ : forall e : Z, Z.le emin (fexp e)) (x : R) (_ : Rlt (IZR Z0) x) (_ : generic_format x), Rle (Fcore_Raux.bpow beta emin) x *)
intros emin Emin x Hx Fx.
(* Goal: generic_format fexp2 x *)
rewrite Fx.
(* Goal: Rle (Fcore_Raux.bpow beta emin) (@F2R beta (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x))) *)
apply Rle_trans with (bpow (fexp (ln_beta beta x))).
(* Goal: Rle (Fcore_Raux.bpow beta emin) (Fcore_Raux.bpow beta (fexp (ln_beta_val beta x (ln_beta beta x)))) *)
(* Goal: Rle (Fcore_Raux.bpow beta (fexp (ln_beta_val beta x (ln_beta beta x)))) (@F2R beta (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x))) *)
now apply bpow_le.
(* Goal: Rle (Fcore_Raux.bpow beta (fexp (ln_beta_val beta x (ln_beta beta x)))) (@F2R beta (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x))) *)
apply bpow_le_F2R.
(* Goal: Z.lt Z0 (Ztrunc (scaled_mantissa x)) *)
apply F2R_gt_0_reg with beta (canonic_exp x).
(* Goal: Rlt (IZR Z0) (@F2R beta (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x))) *)
now rewrite <- Fx.
Qed.

Theorem abs_lt_bpow_prec:
  forall prec,
  (forall e, (e - prec <= fexp e)%Z) ->
  (* OK with FLX, FLT and FTZ *)
  forall x,
  (Rabs x < bpow (prec + canonic_exp x))%R.
(* Goal: forall (prec : Z) (_ : forall e : Z, Z.le (Z.sub e prec) (fexp e)) (x : R), Rlt (Rabs x) (Fcore_Raux.bpow beta (Z.add prec (canonic_exp x))) *)
intros prec Hp x.
(* Goal: Rlt (Rabs x) (Fcore_Raux.bpow beta (Z.add prec (canonic_exp x))) *)
case (Req_dec x 0); intros Hxz.
(* Goal: Rlt (Rabs x) (Fcore_Raux.bpow beta (Z.add prec (canonic_exp x))) *)
(* Goal: Rlt (Rabs x) (Fcore_Raux.bpow beta (Z.add prec (canonic_exp x))) *)
rewrite Hxz, Rabs_R0.
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_gt_0.
(* Goal: Z.le Z0 (Z.add (canonic_exp x) (Z.opp (fexp e))) *)
(* Goal: @eq R x (@F2R beta (Float beta (Ztrunc (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (fexp e))) *)
unfold canonic_exp.
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
destruct (ln_beta beta x) as (ex,Ex) ; simpl.
(* Goal: Rlt (Rabs x) (Fcore_Raux.bpow beta (Z.add prec (fexp ex))) *)
specialize (Ex Hxz).
(* Goal: Rlt (Rabs x) (Fcore_Raux.bpow beta (Z.add prec (fexp ex))) *)
apply Rlt_le_trans with (1 := proj2 Ex).
(* Goal: Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2) *)
(* Goal: Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2) *)
apply bpow_le.
(* Goal: Z.le ex (Z.add prec (fexp ex)) *)
specialize (Hp ex).
(* Goal: Z.le Z0 (Z.opp (Z.add (Zfloor x) (Zpos xH))) *)
omega.
Qed.

Theorem generic_format_bpow_inv' :
  forall e,
  generic_format (bpow e) ->
  (fexp (e + 1) <= e)%Z.
Proof.
(* Goal: forall (e : Z) (_ : generic_format (Fcore_Raux.bpow beta e)), Z.le (fexp e) e *)
intros e He.
apply Znot_gt_le.
contradict He.
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
unfold generic_format, scaled_mantissa, canonic_exp, F2R. simpl.
rewrite ln_beta_bpow, <- bpow_plus.
(* Goal: not (@eq R (Fcore_Raux.bpow beta (canonic_exp x)) (IZR Z0)) *)
apply Rgt_not_eq.
rewrite Ztrunc_floor.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
2: apply bpow_ge_0.
rewrite Zfloor_imp with (n := Z0).
(* Goal: @eq R (@F2R beta (Float beta (rnd (Rmult (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp (IZR Z0)))))) (canonic_exp (IZR Z0)))) (IZR Z0) *)
rewrite Rmult_0_l.
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_gt_0.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
split.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_ge_0.
apply (bpow_lt _ _ 0).
(* Goal: Z.le Z0 (Z.opp (Z.add (Zfloor x) (Zpos xH))) *)
clear -He ; omega.
Qed.

Theorem generic_format_bpow_inv :
  forall e,
  generic_format (bpow e) ->
  (fexp e <= e)%Z.
Proof.
(* Goal: forall (e : Z) (_ : generic_format (Fcore_Raux.bpow beta e)), Z.le (fexp e) e *)
intros e He.
(* Goal: Z.le (fexp e) e *)
apply generic_format_bpow_inv' in He.
(* Goal: Z.le (fexp e) e *)
assert (H := valid_exp_large' (e + 1) e).
(* Goal: Z.le Z0 (Z.opp (Z.add (Zfloor x) (Zpos xH))) *)
omega.
Qed.

Section Fcore_generic_round_pos.

(** Rounding functions: R -> Z *)

Variable rnd : R -> Z.

(* Goal: Rge (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x)))))) (IZR Z0) *)
(* Goal: Rlt (Rabs (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x))))))) (Rinv (IZR (Zpos (xO xH)))) *)
Class Valid_rnd := {
  Zrnd_le : forall x y, (x <= y)%R -> (rnd x <= rnd y)%Z ;
  Zrnd_Z2R : forall n, rnd (Z2R n) = n
}.

Context { valid_rnd : Valid_rnd }.

Theorem Zrnd_DN_or_UP :
  forall x, rnd x = Zfloor x \/ rnd x = Zceil x.
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: or (@eq Z (rnd x) (Zfloor x)) (@eq Z (rnd x) (Zceil x)) *)
destruct (Zle_or_lt (rnd x) (Zfloor x)) as [Hx|Hx].
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
left.
(* Goal: @eq Z (rnd x) (Zfloor x) *)
(* Goal: or (@eq Z (rnd x) (Zfloor x)) (@eq Z (rnd x) (Zceil x)) *)
apply Zle_antisym with (1 := Hx).
(* Goal: Z.le (Zfloor x) (rnd x) *)
(* Goal: or (@eq Z (rnd x) (Zfloor x)) (@eq Z (rnd x) (Zceil x)) *)
rewrite <- (Zrnd_Z2R (Zfloor x)).
(* Goal: Z.le (rnd x) (rnd (Z2R (Zceil x))) *)
(* Goal: Z.le (Zceil x) (rnd x) *)
apply Zrnd_le.
(* Goal: Rle (Z2R (Zfloor (scaled_mantissa x))) (scaled_mantissa x) *)
(* Goal: Rlt (scaled_mantissa x) (Z2R Z0) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply Zfloor_lb.
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
right.
(* Goal: @eq Z (rnd x) (Zceil x) *)
apply Zle_antisym.
(* Goal: Z.le (rnd x) (Zceil x) *)
(* Goal: Z.le (Zceil x) (rnd x) *)
rewrite <- (Zrnd_Z2R (Zceil x)).
(* Goal: Z.le (rnd x) (rnd (Z2R (Zceil x))) *)
(* Goal: Z.le (Zceil x) (rnd x) *)
apply Zrnd_le.
(* Goal: Rle x (Z2R (Zceil x)) *)
apply Zceil_ub.
(* Goal: Rle (Rabs (Rminus x (Z2R (Zceil x)))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
rewrite Zceil_floor_neq.
(* Goal: Z.le Z0 (Z.opp (Z.add (Zfloor x) (Zpos xH))) *)
omega.
(* Goal: forall _ : @eq R (Rminus (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) (Rminus (Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x)))), @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
intros H.
(* Goal: False *)
rewrite <- H in Hx.
(* Goal: False *)
rewrite Zfloor_Z2R, Zrnd_Z2R in Hx.
(* Goal: False *)
apply Zlt_irrefl with (1 := Hx).
Qed.

Theorem Zrnd_ZR_or_AW :
  forall x, rnd x = Ztrunc x \/ rnd x = Zaway x.
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: or (@eq Z (rnd x) (Ztrunc x)) (@eq Z (rnd x) (Zaway x)) *)
unfold Ztrunc, Zaway.
destruct (Zrnd_DN_or_UP x) as [Hx|Hx] ;
  case Rlt_bool.
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
now right.
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
now left.
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
now left.
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
now right.
Qed.

(** the most useful one: R -> F *)
Definition round x :=
  F2R (Float beta (rnd (scaled_mantissa x)) (canonic_exp x)).

Theorem round_bounded_large_pos :
  forall x ex,
  (fexp ex < ex)%Z ->
  (bpow (ex - 1) <= x < bpow ex)%R ->
  (bpow (ex - 1) <= round x <= bpow ex)%R.
Proof.
(* Goal: forall (x : R) (ex : Z) (_ : Z.le ex (fexp ex)) (_ : and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) x) (Rlt x (Fcore_Raux.bpow beta ex))), or (@eq R (round x) (IZR Z0)) (@eq R (round x) (Fcore_Raux.bpow beta (fexp ex))) *)
intros x ex He Hx.
(* Goal: @eq R (round (IZR Z0)) (IZR Z0) *)
unfold round, scaled_mantissa.
(* Goal: or (@eq R (@F2R beta (Float beta (rnd (Rmult x (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))))) (canonic_exp x))) (IZR Z0)) (@eq R (@F2R beta (Float beta (rnd (Rmult x (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))))) (canonic_exp x))) (Fcore_Raux.bpow beta (fexp ex))) *)
rewrite (canonic_exp_fexp_pos _ _ Hx).
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
unfold F2R. simpl.
(* Goal: or (@eq R (Rmult (Z2R (rnd (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (IZR Z0)) (@eq R (Rmult (Z2R (rnd (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) *)
destruct (Zrnd_DN_or_UP (x * bpow (- fexp ex))) as [Hr|Hr] ; rewrite Hr.
(* DN *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
split.
(* Goal: Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rmult (Z2R (Zfloor (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: Rle (Rmult (Z2R (Zfloor (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta ex) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex)))) (Rle (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta ex)) *)
replace (ex - 1)%Z with (ex - 1 + - fexp ex + fexp ex)%Z by ring.
(* Goal: Rle (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Fcore_Raux.bpow beta (Z.add ex (Z.opp (fexp ex)))) *)
rewrite bpow_plus.
(* Goal: Rle (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Rmult (Fcore_Raux.bpow beta ex) (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) *)
apply Rmult_le_compat_r.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_ge_0.
(* Goal: Rle (Fcore_Raux.bpow beta (Z.add (Z.sub ex (Zpos xH)) (Z.opp (fexp ex)))) (Z2R (Zfloor (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) *)
(* Goal: Rle (Rmult (Z2R (Zfloor (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta ex) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex)))) (Rle (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta ex)) *)
assert (Hf: Z2R (Zpower beta (ex - 1 - fexp ex)) = bpow (ex - 1 + - fexp ex)).
(* Goal: @eq R (Z2R (Z.pow (radix_val beta) (Z.add (canonic_exp x) (Z.opp (fexp e))))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))) *)
(* Goal: @eq R x (@F2R beta (Float beta (Ztrunc (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (fexp e))) *)
apply Z2R_Zpower.
(* Goal: Z.le Z0 (Z.opp (Z.add (Zfloor x) (Zpos xH))) *)
omega.
(* Goal: Z.le (Zfloor x) (Znearest y) *)
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (Znearest y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
rewrite <- Hf.
(* Goal: Rle (Z2R (Zceil x)) (Z2R (Z.add (Zfloor x) (Zpos xH))) *)
(* Goal: Z.le (Znearest x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
apply Z2R_le.
(* Goal: Z.le Z0 (Zfloor (scaled_mantissa x)) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply Zfloor_lub.
(* Goal: Z.le (Zceil x) match Rcompare (Rminus y (Z2R (Zfloor y))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor y) then Zceil y else Zfloor y | Lt => Zfloor y | Gt => Zceil y end *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
rewrite Hf.
(* Goal: Rle (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Fcore_Raux.bpow beta (Z.add ex (Z.opp (fexp ex)))) *)
rewrite bpow_plus.
(* Goal: Rle (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Rmult (Fcore_Raux.bpow beta ex) (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) *)
apply Rmult_le_compat_r.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_ge_0.
(* Goal: Rlt x (Fcore_Raux.bpow beta ex) *)
apply Hx.
(* Goal: Rle (Rmult (Z2R (Zfloor (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta ex) *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex)))) (Rle (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta ex)) *)
apply Rle_trans with (2 := Rlt_le _ _ (proj2 Hx)).
(* Goal: Rle x (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: Rle (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta ex) *)
apply Rmult_le_reg_r with (bpow (- fexp ex)).
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_gt_0.
(* Goal: Rle (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Rmult (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) *)
(* Goal: Rle (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta ex) *)
rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r.
(* Goal: Rle (Z2R (Zfloor (scaled_mantissa x))) (scaled_mantissa x) *)
(* Goal: Rlt (scaled_mantissa x) (Z2R Z0) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply Zfloor_lb.
(* UP *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
split.
(* Goal: Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: Rle (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta ex) *)
apply Rle_trans with (1 := proj1 Hx).
(* Goal: Rle x (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) *)
(* Goal: Rle (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta ex) *)
apply Rmult_le_reg_r with (bpow (- fexp ex)).
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_gt_0.
(* Goal: Rle (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Rmult (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) *)
(* Goal: Rle (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta ex) *)
rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r.
(* Goal: Rle x (Z2R (Zceil x)) *)
apply Zceil_ub.
(* Goal: Rle (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta ex) *)
pattern ex at 3 ; replace ex with (ex - fexp ex + fexp ex)%Z by ring.
(* Goal: Rle (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Fcore_Raux.bpow beta (Z.add ex (Z.opp (fexp ex)))) *)
rewrite bpow_plus.
(* Goal: Rle (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Rmult (Fcore_Raux.bpow beta ex) (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) *)
apply Rmult_le_compat_r.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_ge_0.
(* Goal: Rle (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (Z.sub ex (fexp ex))) *)
assert (Hf: Z2R (Zpower beta (ex - fexp ex)) = bpow (ex - fexp ex)).
(* Goal: @eq R (Z2R (Z.pow (radix_val beta) (Z.add (canonic_exp x) (Z.opp (fexp e))))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))) *)
(* Goal: @eq R x (@F2R beta (Float beta (Ztrunc (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (fexp e))) *)
apply Z2R_Zpower.
(* Goal: Z.le Z0 (Z.opp (Z.add (Zfloor x) (Zpos xH))) *)
omega.
(* Goal: Z.le (Zfloor x) (Znearest y) *)
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (Znearest y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
rewrite <- Hf.
(* Goal: Rle (Z2R (Zceil x)) (Z2R (Z.add (Zfloor x) (Zpos xH))) *)
(* Goal: Z.le (Znearest x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
apply Z2R_le.
(* Goal: Z.le (Zceil x) (Z.add (Zfloor x) (Zpos xH)) *)
(* Goal: Z.le (Znearest x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
apply Zceil_glb.
(* Goal: Z.le (Zceil x) match Rcompare (Rminus y (Z2R (Zfloor y))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor y) then Zceil y else Zfloor y | Lt => Zfloor y | Gt => Zceil y end *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
rewrite Hf.
(* Goal: Rle (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Fcore_Raux.bpow beta (Z.sub ex (fexp ex))) *)
unfold Zminus.
(* Goal: Rle (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Fcore_Raux.bpow beta (Z.add ex (Z.opp (fexp ex)))) *)
rewrite bpow_plus.
(* Goal: Rle (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Rmult (Fcore_Raux.bpow beta ex) (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) *)
apply Rmult_le_compat_r.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_ge_0.
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
apply Rlt_le.
(* Goal: Rlt x (Fcore_Raux.bpow beta ex) *)
apply Hx.
Qed.

Theorem round_bounded_small_pos :
  forall x ex,
  (ex <= fexp ex)%Z ->
  (bpow (ex - 1) <= x < bpow ex)%R ->
  round x = 0%R \/ round x = bpow (fexp ex).
Proof.
(* Goal: forall (x : R) (ex : Z) (_ : Z.le ex (fexp ex)) (_ : and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) x) (Rlt x (Fcore_Raux.bpow beta ex))), or (@eq R (round x) (IZR Z0)) (@eq R (round x) (Fcore_Raux.bpow beta (fexp ex))) *)
intros x ex He Hx.
(* Goal: @eq R (round (IZR Z0)) (IZR Z0) *)
unfold round, scaled_mantissa.
(* Goal: or (@eq R (@F2R beta (Float beta (rnd (Rmult x (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))))) (canonic_exp x))) (IZR Z0)) (@eq R (@F2R beta (Float beta (rnd (Rmult x (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))))) (canonic_exp x))) (Fcore_Raux.bpow beta (fexp ex))) *)
rewrite (canonic_exp_fexp_pos _ _ Hx).
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
unfold F2R. simpl.
(* Goal: or (@eq R (Rmult (Z2R (rnd (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (IZR Z0)) (@eq R (Rmult (Z2R (rnd (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) *)
destruct (Zrnd_DN_or_UP (x * bpow (-fexp ex))) as [Hr|Hr] ; rewrite Hr.
(* DN *)
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
left.
(* Goal: @eq R (Rmult (Z2R (Zfloor (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (IZR Z0) *)
(* Goal: or (@eq R (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (IZR Z0)) (@eq R (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) *)
apply Rmult_eq_0_compat_r.
(* Goal: @eq R (Z2R (Zfloor (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (IZR Z0) *)
(* Goal: or (@eq R (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (IZR Z0)) (@eq R (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) *)
apply (@f_equal _ _ Z2R _ Z0).
(* Goal: @eq Z (Zfloor y) (Zfloor x) *)
(* Goal: Z.le (Znearest x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
apply Zfloor_imp.
(* Goal: and (Rle (Z2R Z0) (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) (Rlt (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Z2R (Z.add Z0 (Zpos xH)))) *)
(* Goal: or (@eq R (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (IZR Z0)) (@eq R (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex))) *)
refine (let H := _ in conj (Rlt_le _ _ (proj1 H)) (proj2 H)).
(* Goal: and (Rlt (Z2R (Z.sub (Zpos xH) (Zpos xH))) (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) (Rlt (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Z2R (Zpos xH))) *)
now apply mantissa_small_pos.
(* UP *)
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
right.
(* Goal: @eq R (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (fexp ex)) *)
pattern (bpow (fexp ex)) at 2 ; rewrite <- Rmult_1_l.
(* Goal: @eq R (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Rmult (IZR (Zpos xH)) (Fcore_Raux.bpow beta (fexp ex))) *)
apply (f_equal (fun m => (m * bpow (fexp ex))%R)).
(* Goal: @eq R (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (IZR (Zpos xH)) *)
apply (@f_equal _ _ Z2R _ 1%Z).
(* Goal: @eq Z (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) (Zpos xH) *)
apply Zceil_imp.
(* Goal: and (Rlt (Z2R (Z.sub (Zpos xH) (Zpos xH))) (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) (Rle (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Z2R (Zpos xH))) *)
refine (let H := _ in conj (proj1 H) (Rlt_le _ _ (proj2 H))).
(* Goal: and (Rlt (Z2R (Z.sub (Zpos xH) (Zpos xH))) (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) (Rlt (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Z2R (Zpos xH))) *)
now apply mantissa_small_pos.
Qed.

Theorem round_le_pos :
  forall x y, (0 < x)%R -> (x <= y)%R -> (round x <= round y)%R.
Proof.
(* Goal: forall (x y : R) (_ : generic_format x) (_ : Rle x y), Rle x (round rnd y) *)
intros x y Hx Hxy.
destruct (ln_beta beta x) as [ex Hex].
destruct (ln_beta beta y) as [ey Hey].
specialize (Hex (Rgt_not_eq _ _ Hx)).
specialize (Hey (Rgt_not_eq _ _ (Rlt_le_trans _ _ _ Hx Hxy))).
rewrite Rabs_pos_eq in Hex.
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
2: now apply Rlt_le.
rewrite Rabs_pos_eq in Hey.
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
2: apply Rle_trans with (2:=Hxy); now apply Rlt_le.
assert (He: (ex <= ey)%Z).
(* Goal: Z.le ex' ex *)
(* Goal: Z.le ex' (fexp ex') *)
  apply bpow_lt_bpow with beta.
  apply Rle_lt_trans with (1 := proj1 Hex).
  now apply Rle_lt_trans with y.
assert (Heq: fexp ex = fexp ey -> (round x <= round y)%R).
(* Goal: forall _ : @eq R (Rminus (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) (Rminus (Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x)))), @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
  intros H.
  unfold round, scaled_mantissa, canonic_exp.
  rewrite ln_beta_unique_pos with (1 := Hex).
  rewrite ln_beta_unique_pos with (1 := Hey).
(* Goal: @eq R x (Rmult (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Z2R (Z.pow (radix_val beta) (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (Fcore_Raux.bpow beta (fexp e))) *)
  rewrite H.
(* Goal: Rle (@F2R beta (Float beta (Z.add m (Zpos xH)) e)) (@F2R beta (Float beta (Ztrunc (scaled_mantissa x)) e)) *)
  apply F2R_le_compat.
(* Goal: Z.le (rnd x) (rnd (Z2R (Zceil x))) *)
(* Goal: Z.le (Zceil x) (rnd x) *)
  apply Zrnd_le.
  apply Rmult_le_compat_r with (2 := Hxy).
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
  apply bpow_ge_0.
destruct (Zle_or_lt ey (fexp ey)) as [Hy1|Hy1].
  apply Heq.
  apply valid_exp with (1 := Hy1).
  now apply Zle_trans with ey.
destruct (Zle_lt_or_eq _ _ He) as [He'|He'].
2: now apply Heq, f_equal.
apply Rle_trans with (bpow (ey - 1)).
2: now apply round_bounded_large_pos.
destruct (Zle_or_lt ex (fexp ex)) as [Hx1|Hx1].
  destruct (round_bounded_small_pos _ _ Hx1 Hex) as [-> | ->].
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
  apply bpow_ge_0.
(* Goal: Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2) *)
(* Goal: Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2) *)
  apply bpow_le.
  apply valid_exp, proj2 in Hx1.
  specialize (Hx1 ey).
(* Goal: Z.le Z0 (Z.opp (Z.add (Zfloor x) (Zpos xH))) *)
  omega.
apply Rle_trans with (bpow ex).
now apply round_bounded_large_pos.
(* Goal: Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2) *)
(* Goal: Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2) *)
apply bpow_le.
now apply Z.lt_le_pred.
Qed.

Theorem round_generic :
  forall x,
  generic_format x ->
  round x = x.
Proof.
(* Goal: forall (x : R) (_ : not (@eq R (Rminus x (Z2R (Zfloor x))) (Rinv (IZR (Zpos (xO xH)))))), Rlt (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
intros x Hx.
(* Goal: @eq R (round Zaway (Ropp x)) (Ropp (round Zaway x)) *)
unfold round.
(* Goal: @eq R (@F2R beta (Float beta (rnd (scaled_mantissa x)) (canonic_exp x))) x *)
rewrite scaled_mantissa_generic with (1 := Hx).
(* Goal: @eq R (@F2R beta (Float beta (rnd (Z2R Z0)) (canonic_exp (Z2R Z0)))) (Z2R Z0) *)
rewrite Zrnd_Z2R.
(* Goal: @eq Z (rnd (Ropp (scaled_mantissa x))) (Z.opp (Zrnd_opp (scaled_mantissa x))) *)
now apply sym_eq.
Qed.

Theorem round_0 :
  round 0 = 0%R.
Proof.
(* Goal: @eq R (round (IZR Z0)) (IZR Z0) *)
unfold round, scaled_mantissa.
(* Goal: @eq R (@F2R beta (Float beta (rnd (Rmult (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp (IZR Z0)))))) (canonic_exp (IZR Z0)))) (IZR Z0) *)
rewrite Rmult_0_l.
(* Goal: @eq R (@F2R beta (Float beta (Zceil (IZR Z0)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (IZR Z0)) (canonic_exp x))) *)
change 0%R with (Z2R 0).
(* Goal: @eq R (@F2R beta (Float beta (rnd (Z2R Z0)) (canonic_exp (Z2R Z0)))) (Z2R Z0) *)
rewrite Zrnd_Z2R.
(* Goal: @eq R (@F2R beta (Float beta Z0 (canonic_exp (Z2R Z0)))) (Z2R Z0) *)
apply F2R_0.
Qed.

Theorem exp_small_round_0_pos :
  forall x ex,
  (bpow (ex - 1) <= x < bpow ex)%R ->
  round x = 0%R -> (ex <= fexp ex)%Z .
Proof.
(* Goal: forall (x : R) (ex : Z) (_ : and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) x) (Rlt x (Fcore_Raux.bpow beta ex))) (_ : @eq R (round x) (IZR Z0)), Z.le ex (fexp ex) *)
intros x ex H H1.
(* Goal: Z.le ex (fexp ex) *)
case (Zle_or_lt ex (fexp ex)); trivial; intros V.
(* Goal: Z.le ex (fexp ex) *)
contradict H1.
(* Goal: not (@eq R (Fcore_Raux.bpow beta (canonic_exp x)) (IZR Z0)) *)
apply Rgt_not_eq.
(* Goal: Rgt (round x) (IZR Z0) *)
apply Rlt_le_trans with (bpow (ex-1)).
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_gt_0.
(* Goal: Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (round x) *)
apply (round_bounded_large_pos); assumption.
Qed.

Theorem generic_format_round_pos :
  forall x,
  (0 < x)%R ->
  generic_format (round x).
Proof.
intros x Hx0.
destruct (ln_beta beta x) as (ex, Hex).
specialize (Hex (Rgt_not_eq _ _ Hx0)).
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
rewrite Rabs_pos_eq in Hex. 2: now apply Rlt_le.
destruct (Zle_or_lt ex (fexp ex)) as [He|He].
(* small *)
destruct (round_bounded_small_pos _ _ He Hex) as [Hr|Hr] ; rewrite Hr.
(* Goal: generic_format (IZR Z0) *)
(* Goal: forall _ : forall _ : not (@eq Z m Z0), Z.le (canonic_exp (@F2R beta (Float beta m e))) e, generic_format (@F2R beta (Float beta m e)) *)
apply generic_format_0.
(* Goal: generic_format (Fcore_Raux.bpow beta e) *)
apply generic_format_bpow.
(* Goal: Z.le (fexp (Z.add (fexp e) (Zpos xH))) (fexp e) *)
now apply valid_exp.
(* large *)
generalize (round_bounded_large_pos _ _ He Hex).
intros (Hr1, Hr2).
destruct (Rle_or_lt (bpow ex) (round x)) as [Hr|Hr].
rewrite <- (Rle_antisym _ _ Hr Hr2).
(* Goal: generic_format (Fcore_Raux.bpow beta e) *)
apply generic_format_bpow.
(* Goal: Z.le (fexp (Z.add (fexp e) (Zpos xH))) (fexp e) *)
now apply valid_exp.
(* Goal: generic_format fexp2 (@F2R beta (Float beta (Ztrunc (scaled_mantissa fexp1 x)) (canonic_exp fexp1 x))) *)
apply generic_format_F2R.
(* Goal: forall _ : @eq R (Rminus (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) (Rminus (Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x)))), @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
(* Goal: forall _ : @eq R (Rminus (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) (Rminus (Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x)))), @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
intros _.
rewrite (canonic_exp_fexp_pos (F2R _) _ (conj Hr1 Hr)).
rewrite (canonic_exp_fexp_pos _ _ Hex).
now apply Zeq_le.
Qed.

End Fcore_generic_round_pos.

Theorem round_ext :
  forall rnd1 rnd2,
  ( forall x, rnd1 x = rnd2 x ) ->
  forall x,
  round rnd1 x = round rnd2 x.
Proof.
(* Goal: forall (rnd1 rnd2 : forall _ : R, Z) (_ : forall x : R, @eq Z (rnd1 x) (rnd2 x)) (x : R), @eq R (round rnd1 x) (round rnd2 x) *)
intros rnd1 rnd2 Hext x.
(* Goal: @eq R (round Zaway (Ropp x)) (Ropp (round Zaway x)) *)
unfold round.
(* Goal: @eq R (@F2R beta (Float beta (rnd1 (scaled_mantissa x)) (canonic_exp x))) (@F2R beta (Float beta (rnd2 (scaled_mantissa x)) (canonic_exp x))) *)
now rewrite Hext.
Qed.

Section Zround_opp.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Definition Zrnd_opp x := Zopp (rnd (-x)).

Global Instance valid_rnd_opp : Valid_rnd Zrnd_opp.
Proof with auto with typeclass_instances.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
split.
(* *)
(* Goal: forall (x y : R) (_ : Rle x y), Z.le (Znearest x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
intros x y Hxy.
unfold Zrnd_opp.
apply Zopp_le_cancel.
rewrite 2!Zopp_involutive.
(* Goal: Z.le (rnd x) (rnd (Z2R (Zceil x))) *)
(* Goal: Z.le (Zceil x) (rnd x) *)
apply Zrnd_le...
now apply Ropp_le_contravar.
(* *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
intros n.
unfold Zrnd_opp.
rewrite <- Z2R_opp, Zrnd_Z2R...
apply Zopp_involutive.
Qed.

Theorem round_opp :
  forall x,
  round rnd (- x) = Ropp (round Zrnd_opp x).
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: @eq R (round Zaway (Ropp x)) (Ropp (round Zaway x)) *)
unfold round.
(* Goal: @eq R (@F2R beta (Float beta (rnd (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))) (Ropp (@F2R beta (Float beta (Zrnd_opp (scaled_mantissa x)) (canonic_exp x)))) *)
rewrite <- F2R_Zopp, canonic_exp_opp, scaled_mantissa_opp.
(* Goal: @eq R (@F2R beta (Float beta (rnd (Ropp (scaled_mantissa x))) (canonic_exp x))) (@F2R beta (Float beta (Z.opp (Zrnd_opp (scaled_mantissa x))) (canonic_exp x))) *)
apply F2R_eq_compat.
(* Goal: @eq Z (rnd (Ropp (scaled_mantissa x))) (Z.opp (Zrnd_opp (scaled_mantissa x))) *)
apply sym_eq.
(* Goal: @eq Z (Z.opp (Zrnd_opp (scaled_mantissa x))) (rnd (Ropp (scaled_mantissa x))) *)
exact (Zopp_involutive _).
Qed.

End Zround_opp.

(** IEEE-754 roundings: up, down and to zero *)

Global Instance valid_rnd_DN : Valid_rnd Zfloor.
Proof.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
split.
(* Goal: forall (x y : R) (_ : Rle x y), Z.le (Zfloor x) (Zfloor y) *)
(* Goal: forall n : Z, @eq Z (Zfloor (Z2R n)) n *)
apply Zfloor_le.
(* Goal: forall n : Z, @eq Z (Zfloor (Z2R n)) n *)
apply Zfloor_Z2R.
Qed.

Global Instance valid_rnd_UP : Valid_rnd Zceil.
Proof.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
split.
(* Goal: forall (x y : R) (_ : Rle x y), Z.le (Zceil x) (Zceil y) *)
(* Goal: forall n : Z, @eq Z (Zceil (Z2R n)) n *)
apply Zceil_le.
(* Goal: forall n : Z, @eq Z (Zceil (Z2R n)) n *)
apply Zceil_Z2R.
Qed.

Global Instance valid_rnd_ZR : Valid_rnd Ztrunc.
Proof.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
split.
(* Goal: forall (x y : R) (_ : Rle x y), Z.le (Ztrunc x) (Ztrunc y) *)
(* Goal: forall n : Z, @eq Z (Ztrunc (Z2R n)) n *)
apply Ztrunc_le.
(* Goal: forall n : Z, @eq Z (Ztrunc (Z2R n)) n *)
apply Ztrunc_Z2R.
Qed.

Global Instance valid_rnd_AW : Valid_rnd Zaway.
Proof.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
split.
(* Goal: forall (x y : R) (_ : Rle x y), Z.le (Zaway x) (Zaway y) *)
(* Goal: forall n : Z, @eq Z (Zaway (Z2R n)) n *)
apply Zaway_le.
(* Goal: forall n : Z, @eq Z (Zaway (Z2R n)) n *)
apply Zaway_Z2R.
Qed.

Section monotone.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Theorem round_DN_or_UP :
  forall x,
  round rnd x = round Zfloor x \/ round rnd x = round Zceil x.
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: @eq R (round Zaway (Ropp x)) (Ropp (round Zaway x)) *)
unfold round.
(* Goal: or (@eq R (@F2R beta (Float beta (rnd (scaled_mantissa x)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (scaled_mantissa x)) (canonic_exp x)))) (@eq R (@F2R beta (Float beta (rnd (scaled_mantissa x)) (canonic_exp x))) (@F2R beta (Float beta (Zceil (scaled_mantissa x)) (canonic_exp x)))) *)
destruct (Zrnd_DN_or_UP rnd (scaled_mantissa x)) as [Hx|Hx].
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
left. now rewrite Hx.
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
right. now rewrite Hx.
Qed.

Theorem round_ZR_or_AW :
  forall x,
  round rnd x = round Ztrunc x \/ round rnd x = round Zaway x.
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: @eq R (round Zaway (Ropp x)) (Ropp (round Zaway x)) *)
unfold round.
(* Goal: or (@eq R (@F2R beta (Float beta (rnd (scaled_mantissa x)) (canonic_exp x))) (@F2R beta (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x)))) (@eq R (@F2R beta (Float beta (rnd (scaled_mantissa x)) (canonic_exp x))) (@F2R beta (Float beta (Zaway (scaled_mantissa x)) (canonic_exp x)))) *)
destruct (Zrnd_ZR_or_AW rnd (scaled_mantissa x)) as [Hx|Hx].
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
left. now rewrite Hx.
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
right. now rewrite Hx.
Qed.

Theorem round_le :
  forall x y, (x <= y)%R -> (round rnd x <= round rnd y)%R.
Proof with auto with typeclass_instances.
(* Goal: forall (x y : R) (_ : Rle x y), Z.le (Znearest x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
intros x y Hxy.
destruct (total_order_T x 0) as [[Hx|Hx]|Hx].
3: now apply round_le_pos.
(* x < 0 *)
(* Goal: @eq R (round Zaway (Ropp x)) (Ropp (round Zaway x)) *)
unfold round.
destruct (Rlt_or_le y 0) as [Hy|Hy].
(* . y < 0 *)
rewrite <- (Ropp_involutive x), <- (Ropp_involutive y).
rewrite (scaled_mantissa_opp (-x)), (scaled_mantissa_opp (-y)).
rewrite (canonic_exp_opp (-x)), (canonic_exp_opp (-y)).
apply Ropp_le_cancel.
rewrite <- 2!F2R_Zopp.
apply (round_le_pos (Zrnd_opp rnd) (-y) (-x)).
rewrite <- Ropp_0.
now apply Ropp_lt_contravar.
now apply Ropp_le_contravar.
(* . 0 <= y *)
apply Rle_trans with 0%R.
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
apply F2R_le_0_compat. simpl.
rewrite <- (Zrnd_Z2R rnd 0).
(* Goal: Z.le (rnd x) (rnd (Z2R (Zceil x))) *)
(* Goal: Z.le (Zceil x) (rnd x) *)
apply Zrnd_le...
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
simpl.
rewrite <- (Rmult_0_l (bpow (- fexp (ln_beta beta x)))).
(* Goal: Rle (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Rmult (Fcore_Raux.bpow beta ex) (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) *)
apply Rmult_le_compat_r.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_ge_0.
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
now apply Rlt_le.
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
apply F2R_ge_0_compat. simpl.
rewrite <- (Zrnd_Z2R rnd 0).
(* Goal: Z.le (rnd x) (rnd (Z2R (Zceil x))) *)
(* Goal: Z.le (Zceil x) (rnd x) *)
apply Zrnd_le...
apply Rmult_le_pos.
exact Hy.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_ge_0.
(* x = 0 *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Rabs x)) (Rle (Rabs x) (Fcore_Raux.bpow beta e2)) *)
rewrite Hx.
rewrite round_0...
apply F2R_ge_0_compat.
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
simpl.
rewrite <- (Zrnd_Z2R rnd 0).
(* Goal: Z.le (rnd x) (rnd (Z2R (Zceil x))) *)
(* Goal: Z.le (Zceil x) (rnd x) *)
apply Zrnd_le...
apply Rmult_le_pos.
now rewrite <- Hx.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_ge_0.
Qed.

Theorem round_ge_generic :
  forall x y, generic_format x -> (x <= y)%R -> (x <= round rnd y)%R.
Proof.
(* Goal: forall (x y : R) (_ : generic_format x) (_ : Rle x y), Rle x (round rnd y) *)
intros x y Hx Hxy.
(* Goal: Rle x (round rnd y) *)
rewrite <- (round_generic rnd x Hx).
(* Goal: Rle (round rnd x) (round rnd y) *)
now apply round_le.
Qed.

Theorem round_le_generic :
  forall x y, generic_format y -> (x <= y)%R -> (round rnd x <= y)%R.
Proof.
(* Goal: forall (x y : R) (_ : generic_format y) (_ : Rle x y), Rle (round rnd x) y *)
intros x y Hy Hxy.
(* Goal: Rle (round rnd x) y *)
rewrite <- (round_generic rnd y Hy).
(* Goal: Rle (round rnd x) (round rnd y) *)
now apply round_le.
Qed.

End monotone.

Theorem round_abs_abs :
  forall P : R -> R -> Prop,
  ( forall rnd (Hr : Valid_rnd rnd) x, (0 <= x)%R -> P x (round rnd x) ) ->
(* Goal: Rge (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x)))))) (IZR Z0) *)
(* Goal: Rlt (Rabs (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x))))))) (Rinv (IZR (Zpos (xO xH)))) *)
  forall rnd {Hr : Valid_rnd rnd} x, P (Rabs x) (Rabs (round rnd x)).
Proof with auto with typeclass_instances.
intros P HP rnd Hr x.
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
destruct (Rle_or_lt 0 x) as [Hx|Hx].
(* . *)
rewrite 2!Rabs_pos_eq.
now apply HP.
rewrite <- (round_0 rnd).
(* Goal: Rle (round rnd x) (round rnd y) *)
now apply round_le.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) x) (Rlt x (Fcore_Raux.bpow beta ex)) *)
(* Goal: Rle (IZR Z0) x *)
exact Hx.
(* . *)
rewrite (Rabs_left _ Hx).
(* Goal: Rle (Ropp x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
rewrite Rabs_left1.
pattern x at 2 ; rewrite <- Ropp_involutive.
rewrite round_opp.
(* Goal: @eq R (@F2R beta (Float beta (Z.opp (Zfloor (Ropp (Ropp (scaled_mantissa x))))) (canonic_exp (Ropp x)))) (@F2R beta (Float beta (Z.opp (Zfloor (scaled_mantissa x))) (canonic_exp x))) *)
rewrite Ropp_involutive.
apply HP...
rewrite <- Ropp_0.
(* Goal: Rle (Ropp x) (Ropp f) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply Ropp_le_contravar.
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
now apply Rlt_le.
rewrite <- (round_0 rnd).
apply round_le...
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
now apply Rlt_le.
Qed.

Theorem round_bounded_large :
(* Goal: Rge (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x)))))) (IZR Z0) *)
(* Goal: Rlt (Rabs (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x))))))) (Rinv (IZR (Zpos (xO xH)))) *)
  forall rnd {Hr : Valid_rnd rnd} x ex,
  (fexp ex < ex)%Z ->
  (bpow (ex - 1) <= Rabs x < bpow ex)%R ->
  (bpow (ex - 1) <= Rabs (round rnd x) <= bpow ex)%R.
Proof with auto with typeclass_instances.
intros rnd Hr x ex He.
apply round_abs_abs...
clear rnd Hr x.
intros rnd' Hr x _.
apply round_bounded_large_pos...
Qed.

Theorem exp_small_round_0 :
(* Goal: Rge (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x)))))) (IZR Z0) *)
(* Goal: Rlt (Rabs (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x))))))) (Rinv (IZR (Zpos (xO xH)))) *)
  forall rnd {Hr : Valid_rnd rnd} x ex,
  (bpow (ex - 1) <= Rabs x < bpow ex)%R ->
   round rnd x = 0%R -> (ex <= fexp ex)%Z .
Proof.
(* Goal: forall (rnd : forall _ : R, Z) (_ : Valid_rnd rnd) (x : R) (ex : Z) (_ : and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) (Rabs x)) (Rlt (Rabs x) (Fcore_Raux.bpow beta ex))) (_ : @eq R (round rnd x) (IZR Z0)), Z.le ex (fexp ex) *)
intros rnd Hr x ex H1 H2.
(* Goal: Z.le ex (fexp ex) *)
generalize Rabs_R0.
(* Goal: forall _ : @eq R (Rabs (IZR Z0)) (IZR Z0), Z.le ex (fexp ex) *)
rewrite <- H2 at 1.
apply (round_abs_abs (fun t rt => forall (ex : Z),
(bpow (ex - 1) <= t < bpow ex)%R ->
rt = 0%R -> (ex <= fexp ex)%Z)); trivial.
(* Goal: forall (rnd : forall _ : R, Z) (_ : Valid_rnd rnd) (x : R) (_ : Rle (IZR Z0) x) (ex : Z) (_ : and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) x) (Rlt x (Fcore_Raux.bpow beta ex))) (_ : @eq R (round rnd x) (IZR Z0)), Z.le ex (fexp ex) *)
clear; intros rnd Hr x Hx.
(* Goal: forall (ex : Z) (_ : and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) x) (Rlt x (Fcore_Raux.bpow beta ex))) (_ : @eq R (round rnd x) (IZR Z0)), Z.le ex (fexp ex) *)
now apply exp_small_round_0_pos.
Qed.




Section monotone_abs.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Theorem abs_round_ge_generic :
  forall x y, generic_format x -> (x <= Rabs y)%R -> (x <= Rabs (round rnd y))%R.
Proof with auto with typeclass_instances.
intros x y.
apply round_abs_abs...
clear rnd valid_rnd y.
intros rnd' Hrnd y Hy.
apply round_ge_generic...
Qed.

Theorem abs_round_le_generic :
  forall x y, generic_format y -> (Rabs x <= y)%R -> (Rabs (round rnd x) <= y)%R.
Proof with auto with typeclass_instances.
intros x y.
apply round_abs_abs...
clear rnd valid_rnd x.
intros rnd' Hrnd x Hx.
apply round_le_generic...
Qed.

End monotone_abs.

Theorem round_DN_opp :
  forall x,
  round Zfloor (-x) = (- round Zceil x)%R.
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: @eq R (round Zaway (Ropp x)) (Ropp (round Zaway x)) *)
unfold round.
(* Goal: @eq R (Rmult (Z2R (Znearest choice (scaled_mantissa (Ropp x)))) (Fcore_Raux.bpow beta (canonic_exp x))) (Ropp (Rmult (Z2R (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) *)
rewrite scaled_mantissa_opp.
(* Goal: @eq R (@F2R beta (Float beta (Zceil (Ropp (scaled_mantissa x))) (canonic_exp (Ropp x)))) (Ropp (@F2R beta (Float beta (Zfloor (scaled_mantissa x)) (canonic_exp x)))) *)
rewrite <- F2R_Zopp.
(* Goal: @eq R (@F2R beta (Float beta (Zceil (Ropp (scaled_mantissa x))) (canonic_exp (Ropp x)))) (@F2R beta (Float beta (Z.opp (Zfloor (scaled_mantissa x))) (canonic_exp x))) *)
unfold Zceil.
(* Goal: @eq R (@F2R beta (Float beta (Zfloor (Ropp (scaled_mantissa x))) (canonic_exp (Ropp x)))) (@F2R beta (Float beta (Z.opp (Z.opp (Zfloor (Ropp (scaled_mantissa x))))) (canonic_exp x))) *)
rewrite Zopp_involutive.
(* Goal: @eq R (Rmult (Z2R (Znearest choice (scaled_mantissa (Ropp x)))) (Fcore_Raux.bpow beta (canonic_exp (Ropp x)))) (Ropp (Rmult (Z2R (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) *)
now rewrite canonic_exp_opp.
Qed.

Theorem round_UP_opp :
  forall x,
  round Zceil (-x) = (- round Zfloor x)%R.
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: @eq R (round Zaway (Ropp x)) (Ropp (round Zaway x)) *)
unfold round.
(* Goal: @eq R (Rmult (Z2R (Znearest choice (scaled_mantissa (Ropp x)))) (Fcore_Raux.bpow beta (canonic_exp x))) (Ropp (Rmult (Z2R (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) *)
rewrite scaled_mantissa_opp.
(* Goal: @eq R (@F2R beta (Float beta (Zceil (Ropp (scaled_mantissa x))) (canonic_exp (Ropp x)))) (Ropp (@F2R beta (Float beta (Zfloor (scaled_mantissa x)) (canonic_exp x)))) *)
rewrite <- F2R_Zopp.
(* Goal: @eq R (@F2R beta (Float beta (Zceil (Ropp (scaled_mantissa x))) (canonic_exp (Ropp x)))) (@F2R beta (Float beta (Z.opp (Zfloor (scaled_mantissa x))) (canonic_exp x))) *)
unfold Zceil.
(* Goal: @eq R (@F2R beta (Float beta (Z.opp (Zfloor (Ropp (Ropp (scaled_mantissa x))))) (canonic_exp (Ropp x)))) (@F2R beta (Float beta (Z.opp (Zfloor (scaled_mantissa x))) (canonic_exp x))) *)
rewrite Ropp_involutive.
(* Goal: @eq R (Rmult (Z2R (Znearest choice (scaled_mantissa (Ropp x)))) (Fcore_Raux.bpow beta (canonic_exp (Ropp x)))) (Ropp (Rmult (Z2R (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) *)
now rewrite canonic_exp_opp.
Qed.

Theorem round_ZR_opp :
  forall x,
  round Ztrunc (- x) = Ropp (round Ztrunc x).
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: @eq R (round Zaway (Ropp x)) (Ropp (round Zaway x)) *)
unfold round.
(* Goal: @eq R (@F2R beta (Float beta (Ztrunc (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))) (Ropp (@F2R beta (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x)))) *)
rewrite scaled_mantissa_opp, canonic_exp_opp, Ztrunc_opp.
(* Goal: @eq R (@F2R beta (Float beta (Z.opp (Zaway (scaled_mantissa x))) (canonic_exp x))) (Ropp (@F2R beta (Float beta (Zaway (scaled_mantissa x)) (canonic_exp x)))) *)
apply F2R_Zopp.
Qed.

Theorem round_ZR_abs :
  forall x,
  round Ztrunc (Rabs x) = Rabs (round Ztrunc x).
Proof with auto with typeclass_instances.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: @eq Z (rnd (Ropp (scaled_mantissa x))) (Z.opp (Zrnd_opp (scaled_mantissa x))) *)
apply sym_eq.
unfold Rabs at 2.
destruct (Rcase_abs x) as [Hx|Hx].
rewrite round_ZR_opp.
apply Rabs_left1.
rewrite <- (round_0 Ztrunc).
apply round_le...
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
now apply Rlt_le.
(* Goal: @eq R (Rabs (Rinv (IZR (Zpos (xO xH))))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
apply Rabs_pos_eq.
rewrite <- (round_0 Ztrunc).
apply round_le...
(* Goal: Rle (IZR Z0) x *)
now apply Rge_le.
Qed.

Theorem round_AW_opp :
  forall x,
  round Zaway (- x) = Ropp (round Zaway x).
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: @eq R (round Zaway (Ropp x)) (Ropp (round Zaway x)) *)
unfold round.
(* Goal: @eq R (@F2R beta (Float beta (Zaway (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))) (Ropp (@F2R beta (Float beta (Zaway (scaled_mantissa x)) (canonic_exp x)))) *)
rewrite scaled_mantissa_opp, canonic_exp_opp, Zaway_opp.
(* Goal: @eq R (@F2R beta (Float beta (Z.opp (Zaway (scaled_mantissa x))) (canonic_exp x))) (Ropp (@F2R beta (Float beta (Zaway (scaled_mantissa x)) (canonic_exp x)))) *)
apply F2R_Zopp.
Qed.

Theorem round_AW_abs :
  forall x,
  round Zaway (Rabs x) = Rabs (round Zaway x).
Proof with auto with typeclass_instances.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: @eq Z (rnd (Ropp (scaled_mantissa x))) (Z.opp (Zrnd_opp (scaled_mantissa x))) *)
apply sym_eq.
unfold Rabs at 2.
destruct (Rcase_abs x) as [Hx|Hx].
rewrite round_AW_opp.
apply Rabs_left1.
rewrite <- (round_0 Zaway).
apply round_le...
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
now apply Rlt_le.
(* Goal: @eq R (Rabs (Rinv (IZR (Zpos (xO xH))))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
apply Rabs_pos_eq.
rewrite <- (round_0 Zaway).
apply round_le...
(* Goal: Rle (IZR Z0) x *)
now apply Rge_le.
Qed.

Theorem round_ZR_pos :
  forall x,
  (0 <= x)%R ->
  round Ztrunc x = round Zfloor x.
Proof.
(* Goal: forall (x : R) (_ : not (@eq R (Rminus x (Z2R (Zfloor x))) (Rinv (IZR (Zpos (xO xH)))))), Rlt (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
intros x Hx.
(* Goal: @eq R (round Ztrunc x) (round Zceil x) *)
unfold round, Ztrunc.
(* Goal: @eq R (@F2R beta (Float beta (if Rlt_bool (scaled_mantissa x) (IZR Z0) then Zfloor (scaled_mantissa x) else Zceil (scaled_mantissa x)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (scaled_mantissa x)) (canonic_exp x))) *)
case Rlt_bool_spec.
(* Goal: forall _ : @eq R (Rminus (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) (Rminus (Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x)))), @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
intros H.
(* Goal: @eq R (@F2R beta (Float beta (Zceil (scaled_mantissa x)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (scaled_mantissa x)) (canonic_exp x))) *)
(* Goal: @eq R (@F2R beta (Float beta (Zceil (scaled_mantissa x)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (scaled_mantissa x)) (canonic_exp x))) *)
elim Rlt_not_le with (1 := H).
(* Goal: Rlt (scaled_mantissa x) (IZR Z0) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
rewrite <- (Rmult_0_l (bpow (- canonic_exp x))).
(* Goal: Rle (scaled_mantissa x) (Rmult (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x)))) *)
(* Goal: @eq R (@F2R beta (Float beta (Zceil (scaled_mantissa x)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (scaled_mantissa x)) (canonic_exp x))) *)
apply Rmult_le_compat_r with (2 := Hx).
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_ge_0.
(* Goal: @eq Z n n *)
(* Goal: Rlt (Rminus (Z2R n) (Z2R n)) (Rinv (IZR (Zpos (xO xH)))) *)
easy.
Qed.

Theorem round_ZR_neg :
  forall x,
  (x <= 0)%R ->
  round Ztrunc x = round Zceil x.
Proof.
(* Goal: forall (x : R) (_ : not (@eq R (Rminus x (Z2R (Zfloor x))) (Rinv (IZR (Zpos (xO xH)))))), Rlt (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
intros x Hx.
(* Goal: @eq R (round Ztrunc x) (round Zceil x) *)
unfold round, Ztrunc.
(* Goal: @eq R (@F2R beta (Float beta (if Rlt_bool (scaled_mantissa x) (IZR Z0) then Zfloor (scaled_mantissa x) else Zceil (scaled_mantissa x)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (scaled_mantissa x)) (canonic_exp x))) *)
case Rlt_bool_spec.
(* Goal: @eq Z n n *)
(* Goal: Rlt (Rminus (Z2R n) (Z2R n)) (Rinv (IZR (Zpos (xO xH)))) *)
easy.
(* Goal: forall _ : Rle (IZR Z0) (scaled_mantissa x), @eq R (@F2R beta (Float beta (Zceil (scaled_mantissa x)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (scaled_mantissa x)) (canonic_exp x))) *)
intros [H|H].
(* Goal: @eq R (@F2R beta (Float beta (Zceil (scaled_mantissa x)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (scaled_mantissa x)) (canonic_exp x))) *)
(* Goal: @eq R (@F2R beta (Float beta (Zceil (scaled_mantissa x)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (scaled_mantissa x)) (canonic_exp x))) *)
elim Rlt_not_le with (1 := H).
(* Goal: Rlt (scaled_mantissa x) (IZR Z0) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
rewrite <- (Rmult_0_l (bpow (- canonic_exp x))).
(* Goal: Rle (scaled_mantissa x) (Rmult (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x)))) *)
(* Goal: @eq R (@F2R beta (Float beta (Zceil (scaled_mantissa x)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (scaled_mantissa x)) (canonic_exp x))) *)
apply Rmult_le_compat_r with (2 := Hx).
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_ge_0.
(* Goal: @eq R x (@F2R beta (Float beta (Ztrunc (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (fexp e))) *)
rewrite <- H.
(* Goal: @eq R (@F2R beta (Float beta (Zceil (IZR Z0)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (IZR Z0)) (canonic_exp x))) *)
change 0%R with (Z2R 0).
(* Goal: @eq R (@F2R beta (Float beta (Zceil (Z2R Z0)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (Z2R Z0)) (canonic_exp x))) *)
now rewrite Zfloor_Z2R, Zceil_Z2R.
Qed.

Theorem round_AW_pos :
  forall x,
  (0 <= x)%R ->
  round Zaway x = round Zceil x.
Proof.
(* Goal: forall (x : R) (_ : not (@eq R (Rminus x (Z2R (Zfloor x))) (Rinv (IZR (Zpos (xO xH)))))), Rlt (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
intros x Hx.
(* Goal: @eq R (round Zaway x) (round Zfloor x) *)
unfold round, Zaway.
(* Goal: @eq R (@F2R beta (Float beta (if Rlt_bool (scaled_mantissa x) (IZR Z0) then Zfloor (scaled_mantissa x) else Zceil (scaled_mantissa x)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (scaled_mantissa x)) (canonic_exp x))) *)
case Rlt_bool_spec.
(* Goal: forall _ : @eq R (Rminus (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) (Rminus (Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x)))), @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
intros H.
(* Goal: @eq R (@F2R beta (Float beta (Zceil (scaled_mantissa x)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (scaled_mantissa x)) (canonic_exp x))) *)
(* Goal: @eq R (@F2R beta (Float beta (Zceil (scaled_mantissa x)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (scaled_mantissa x)) (canonic_exp x))) *)
elim Rlt_not_le with (1 := H).
(* Goal: Rlt (scaled_mantissa x) (IZR Z0) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
rewrite <- (Rmult_0_l (bpow (- canonic_exp x))).
(* Goal: Rle (scaled_mantissa x) (Rmult (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x)))) *)
(* Goal: @eq R (@F2R beta (Float beta (Zceil (scaled_mantissa x)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (scaled_mantissa x)) (canonic_exp x))) *)
apply Rmult_le_compat_r with (2 := Hx).
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_ge_0.
(* Goal: @eq Z n n *)
(* Goal: Rlt (Rminus (Z2R n) (Z2R n)) (Rinv (IZR (Zpos (xO xH)))) *)
easy.
Qed.

Theorem round_AW_neg :
  forall x,
  (x <= 0)%R ->
  round Zaway x = round Zfloor x.
Proof.
(* Goal: forall (x : R) (_ : not (@eq R (Rminus x (Z2R (Zfloor x))) (Rinv (IZR (Zpos (xO xH)))))), Rlt (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
intros x Hx.
(* Goal: @eq R (round Zaway x) (round Zfloor x) *)
unfold round, Zaway.
(* Goal: @eq R (@F2R beta (Float beta (if Rlt_bool (scaled_mantissa x) (IZR Z0) then Zfloor (scaled_mantissa x) else Zceil (scaled_mantissa x)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (scaled_mantissa x)) (canonic_exp x))) *)
case Rlt_bool_spec.
(* Goal: @eq Z n n *)
(* Goal: Rlt (Rminus (Z2R n) (Z2R n)) (Rinv (IZR (Zpos (xO xH)))) *)
easy.
(* Goal: forall _ : Rle (IZR Z0) (scaled_mantissa x), @eq R (@F2R beta (Float beta (Zceil (scaled_mantissa x)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (scaled_mantissa x)) (canonic_exp x))) *)
intros [H|H].
(* Goal: @eq R (@F2R beta (Float beta (Zceil (scaled_mantissa x)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (scaled_mantissa x)) (canonic_exp x))) *)
(* Goal: @eq R (@F2R beta (Float beta (Zceil (scaled_mantissa x)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (scaled_mantissa x)) (canonic_exp x))) *)
elim Rlt_not_le with (1 := H).
(* Goal: Rlt (scaled_mantissa x) (IZR Z0) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
rewrite <- (Rmult_0_l (bpow (- canonic_exp x))).
(* Goal: Rle (scaled_mantissa x) (Rmult (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x)))) *)
(* Goal: @eq R (@F2R beta (Float beta (Zceil (scaled_mantissa x)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (scaled_mantissa x)) (canonic_exp x))) *)
apply Rmult_le_compat_r with (2 := Hx).
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_ge_0.
(* Goal: @eq R x (@F2R beta (Float beta (Ztrunc (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (fexp e))) *)
rewrite <- H.
(* Goal: @eq R (@F2R beta (Float beta (Zceil (IZR Z0)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (IZR Z0)) (canonic_exp x))) *)
change 0%R with (Z2R 0).
(* Goal: @eq R (@F2R beta (Float beta (Zceil (Z2R Z0)) (canonic_exp x))) (@F2R beta (Float beta (Zfloor (Z2R Z0)) (canonic_exp x))) *)
now rewrite Zfloor_Z2R, Zceil_Z2R.
Qed.

Theorem generic_format_round :
(* Goal: Rge (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x)))))) (IZR Z0) *)
(* Goal: Rlt (Rabs (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x))))))) (Rinv (IZR (Zpos (xO xH)))) *)
  forall rnd { Hr : Valid_rnd rnd } x,
  generic_format (round rnd x).
Proof with auto with typeclass_instances.
intros rnd Zrnd x.
destruct (total_order_T x 0) as [[Hx|Hx]|Hx].
(* Goal: Rnd_UP_pt generic_format x (round Zceil x) *)
rewrite <- (Ropp_involutive x).
destruct (round_DN_or_UP rnd (- - x)) as [Hr|Hr] ; rewrite Hr.
rewrite round_DN_opp.
(* Goal: forall (x : R) (_ : generic_format x), generic_format (Ropp x) *)
(* Goal: Rnd_DN_pt generic_format (Ropp x) (round Zfloor (Ropp x)) *)
apply generic_format_opp.
apply generic_format_round_pos...
now apply Ropp_0_gt_lt_contravar.
(* Goal: Rnd_UP_pt generic_format (Ropp (Ropp x)) (round Zceil (Ropp (Ropp x))) *)
rewrite round_UP_opp.
(* Goal: forall (x : R) (_ : generic_format x), generic_format (Ropp x) *)
(* Goal: Rnd_DN_pt generic_format (Ropp x) (round Zfloor (Ropp x)) *)
apply generic_format_opp.
apply generic_format_round_pos...
now apply Ropp_0_gt_lt_contravar.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Rabs x)) (Rle (Rabs x) (Fcore_Raux.bpow beta e2)) *)
rewrite Hx.
rewrite round_0...
(* Goal: generic_format (IZR Z0) *)
(* Goal: forall _ : forall _ : not (@eq Z m Z0), Z.le (canonic_exp (@F2R beta (Float beta m e))) e, generic_format (@F2R beta (Float beta m e)) *)
apply generic_format_0.
now apply generic_format_round_pos.
Qed.

Theorem round_DN_pt :
  forall x,
  Rnd_DN_pt generic_format x (round Zfloor x).
Proof with auto with typeclass_instances.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
split.
apply generic_format_round...
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
split.
pattern x at 2 ; rewrite <- scaled_mantissa_mult_bpow.
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
unfold round, F2R. simpl.
(* Goal: Rle (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Rmult (Fcore_Raux.bpow beta ex) (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) *)
apply Rmult_le_compat_r.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_ge_0.
(* Goal: Rle (Z2R (Zfloor (scaled_mantissa x))) (scaled_mantissa x) *)
(* Goal: Rlt (scaled_mantissa x) (Z2R Z0) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply Zfloor_lb.
intros g Hg Hgx.
apply round_ge_generic...
Qed.

Theorem generic_format_satisfies_any :
  satisfies_any generic_format.
Proof.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
split.
(* symmetric set *)
(* Goal: generic_format (IZR Z0) *)
(* Goal: Rle x (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
exact generic_format_0.
exact generic_format_opp.
(* round down *)
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
eexists.
(* Goal: Rnd_DN_pt generic_format x (round Zfloor x) *)
(* Goal: Rnd_UP_pt generic_format x (round Zceil x) *)
apply round_DN_pt.
Qed.

Theorem round_UP_pt :
  forall x,
  Rnd_UP_pt generic_format x (round Zceil x).
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: Rnd_UP_pt generic_format x (round Zceil x) *)
rewrite <- (Ropp_involutive x).
(* Goal: Rnd_UP_pt generic_format (Ropp (Ropp x)) (round Zceil (Ropp (Ropp x))) *)
rewrite round_UP_opp.
(* Goal: Rnd_UP_pt generic_format (Ropp (Ropp x)) (Ropp (round Zfloor (Ropp x))) *)
apply Rnd_DN_UP_pt_sym.
(* Goal: forall (x : R) (_ : generic_format x), generic_format (Ropp x) *)
(* Goal: Rnd_DN_pt generic_format (Ropp x) (round Zfloor (Ropp x)) *)
apply generic_format_opp.
(* Goal: Rnd_DN_pt generic_format x (round Zfloor x) *)
(* Goal: Rnd_UP_pt generic_format x (round Zceil x) *)
apply round_DN_pt.
Qed.

Theorem round_ZR_pt :
  forall x,
  Rnd_ZR_pt generic_format x (round Ztrunc x).
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: Rnd_ZR_pt generic_format x (round Ztrunc x) *)
split ; intros Hx.
(* Goal: Rnd_DN_pt generic_format x (round Ztrunc x) *)
(* Goal: Rnd_UP_pt generic_format x (round Ztrunc x) *)
rewrite round_ZR_pos with (1 := Hx).
(* Goal: Rnd_DN_pt generic_format x (round Zfloor x) *)
(* Goal: Rnd_UP_pt generic_format x (round Zceil x) *)
apply round_DN_pt.
(* Goal: Rnd_UP_pt generic_format x (round Ztrunc x) *)
rewrite round_ZR_neg with (1 := Hx).
(* Goal: Rnd_UP_pt generic_format x (round Zceil x) *)
apply round_UP_pt.
Qed.

Theorem round_DN_small_pos :
  forall x ex,
  (bpow (ex - 1) <= x < bpow ex)%R ->
  (ex <= fexp ex)%Z ->
  round Zfloor x = 0%R.
Proof.
(* Goal: forall (x : R) (ex : Z) (_ : and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) x) (Rlt x (Fcore_Raux.bpow beta ex))) (_ : Z.le ex (fexp ex)), @eq R (round Zceil x) (Fcore_Raux.bpow beta (fexp ex)) *)
intros x ex Hx He.
(* Goal: @eq R (round Zfloor x) (IZR Z0) *)
rewrite <- (F2R_0 beta (canonic_exp x)).
(* Goal: @eq R (round Zfloor x) (@F2R beta (Float beta Z0 (canonic_exp x))) *)
rewrite <- mantissa_DN_small_pos with (1 := Hx) (2 := He).
(* Goal: @eq R (round Zceil x) (@F2R beta (Float beta (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) (fexp ex))) *)
now rewrite <- canonic_exp_fexp_pos with (1 := Hx).
Qed.


Theorem round_DN_UP_lt :
  forall x, ~ generic_format x ->
  (round Zfloor x < x < round Zceil x)%R.
Proof with auto with typeclass_instances.
intros x Fx.
assert (Hx:(round  Zfloor x <= x <= round Zceil x)%R).
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
split.
(* Goal: Rnd_DN_pt generic_format x (round Zfloor x) *)
(* Goal: Rnd_UP_pt generic_format x (round Zceil x) *)
apply round_DN_pt.
(* Goal: Rnd_UP_pt generic_format x (round Zceil x) *)
apply round_UP_pt.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
split.
  destruct Hx as [Hx _].
  apply Rnot_le_lt; intro Hle.
  assert (x = round Zfloor x) by now apply Rle_antisym.
  rewrite H in Fx.
  contradict Fx.
  apply generic_format_round...
destruct Hx as [_ Hx].
apply Rnot_le_lt; intro Hle.
assert (x = round Zceil x) by now apply Rle_antisym.
rewrite H in Fx.
contradict Fx.
apply generic_format_round...
Qed.

Theorem round_UP_small_pos :
  forall x ex,
  (bpow (ex - 1) <= x < bpow ex)%R ->
  (ex <= fexp ex)%Z ->
  round Zceil x = (bpow (fexp ex)).
Proof.
(* Goal: forall (x : R) (ex : Z) (_ : and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) x) (Rlt x (Fcore_Raux.bpow beta ex))) (_ : Z.le ex (fexp ex)), @eq R (round Zceil x) (Fcore_Raux.bpow beta (fexp ex)) *)
intros x ex Hx He.
(* Goal: @eq R (round Zceil x) (Fcore_Raux.bpow beta (fexp ex)) *)
rewrite <- F2R_bpow.
(* Goal: @eq R (round Zceil x) (@F2R beta (Float beta (Zpos xH) (fexp ex))) *)
rewrite <- mantissa_UP_small_pos with (1 := Hx) (2 := He).
(* Goal: @eq R (round Zceil x) (@F2R beta (Float beta (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex))))) (fexp ex))) *)
now rewrite <- canonic_exp_fexp_pos with (1 := Hx).
Qed.

Theorem generic_format_EM :
  forall x,
  generic_format x \/ ~generic_format x.
Proof with auto with typeclass_instances.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
destruct (Req_dec (round Zfloor x) x) as [Hx|Hx].
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
left.
(* Goal: Rle (Rinv (IZR (Zpos (xO xH)))) (Rminus y (Z2R (Zfloor x))) *)
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (if choice (Zfloor x) then Zceil y else Zfloor x) *)
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (Zceil y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
rewrite <- Hx.
apply generic_format_round...
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
right.
(* Goal: forall _ : @eq R (Rminus (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) (Rminus (Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x)))), @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
intros H.
(* Goal: Rlt x (Fcore_Raux.bpow beta ex) *)
apply Hx.
apply round_generic...
Qed.

Section round_large.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Theorem round_large_pos_ge_pow :
  forall x e,
  (0 < round rnd x)%R ->
  (bpow e <= x)%R ->
  (bpow e <= round rnd x)%R.
Proof.
intros x e Hd Hex.
destruct (ln_beta beta x) as (ex, He).
assert (Hx: (0 < x)%R).
apply Rlt_le_trans with (2 := Hex).
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_gt_0.
specialize (He (Rgt_not_eq _ _ Hx)).
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
rewrite Rabs_pos_eq in He. 2: now apply Rlt_le.
apply Rle_trans with (bpow (ex - 1)).
(* Goal: Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2) *)
(* Goal: Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2) *)
apply bpow_le.
(* Goal: Z.le Z0 (Z.opp (Z.add (Zfloor x) (Zpos xH))) *)
cut (e < ex)%Z. omega.
apply (lt_bpow beta).
now apply Rle_lt_trans with (2 := proj2 He).
destruct (Zle_or_lt ex (fexp ex)).
destruct (round_bounded_small_pos rnd x ex H He) as [Hr|Hr].
rewrite Hr in Hd.
elim Rlt_irrefl with (1 := Hd).
rewrite Hr.
(* Goal: Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2) *)
(* Goal: Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2) *)
apply bpow_le.
(* Goal: Z.le Z0 (Z.opp (Z.add (Zfloor x) (Zpos xH))) *)
omega.
apply (round_bounded_large_pos rnd x ex H He).
Qed.

End round_large.

Theorem ln_beta_round_ZR :
  forall x,
  (round Ztrunc x <> 0)%R ->
  (ln_beta beta (round Ztrunc x) = ln_beta beta x :> Z).
Proof with auto with typeclass_instances.
intros x Zr.
(* Goal: Rlt (Rabs (scaled_mantissa x)) (Fcore_Raux.bpow beta (Z.sub (ln_beta_val beta x (ln_beta beta x)) (canonic_exp x))) *)
destruct (Req_dec x 0) as [Zx|Zx].
rewrite Zx, round_0...
apply ln_beta_unique.
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
destruct (ln_beta beta x) as (ex, Ex) ; simpl.
(* Goal: not (Z.ge (fexp ex) ex) *)
specialize (Ex Zx).
rewrite <- round_ZR_abs.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
split.
apply round_large_pos_ge_pow...
rewrite round_ZR_abs.
now apply Rabs_pos_lt.
apply Ex.
apply Rle_lt_trans with (2 := proj2 Ex).
rewrite round_ZR_pos.
(* Goal: Rnd_DN_pt generic_format x (round Zfloor x) *)
(* Goal: Rnd_UP_pt generic_format x (round Zceil x) *)
apply round_DN_pt.
apply Rabs_pos.
Qed.

Theorem ln_beta_round :
(* Goal: Rge (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x)))))) (IZR Z0) *)
(* Goal: Rlt (Rabs (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x))))))) (Rinv (IZR (Zpos (xO xH)))) *)
  forall rnd {Hrnd : Valid_rnd rnd} x,
  (round rnd x <> 0)%R ->
  (ln_beta beta (round rnd x) = ln_beta beta x :> Z) \/
  Rabs (round rnd x) = bpow (Zmax (ln_beta beta x) (fexp (ln_beta beta x))).
Proof with auto with typeclass_instances.
intros rnd Hrnd x.
destruct (round_ZR_or_AW rnd x) as [Hr|Hr] ; rewrite Hr ; clear Hr rnd Hrnd.
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
left.
now apply ln_beta_round_ZR.
intros Zr.
(* Goal: Rlt (Rabs (scaled_mantissa x)) (Fcore_Raux.bpow beta (Z.sub (ln_beta_val beta x (ln_beta beta x)) (canonic_exp x))) *)
destruct (Req_dec x 0) as [Zx|Zx].
rewrite Zx, round_0...
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
destruct (ln_beta beta x) as (ex, Ex) ; simpl.
(* Goal: not (Z.ge (fexp ex) ex) *)
specialize (Ex Zx).
rewrite <- ln_beta_abs.
rewrite <- round_AW_abs.
destruct (Zle_or_lt ex (fexp ex)) as [He|He].
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
right.
rewrite Zmax_r with (1 := He).
rewrite round_AW_pos with (1 := Rabs_pos _).
now apply round_UP_small_pos.
destruct (round_bounded_large_pos Zaway _ ex He Ex) as (H1,[H2|H2]).
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
left.
apply ln_beta_unique.
rewrite <- round_AW_abs, Rabs_Rabsolu.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
now split.
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
right.
now rewrite Zmax_l with (1 := Zlt_le_weak _ _ He).
Qed.

Theorem ln_beta_DN :
  forall x,
  (0 < round Zfloor x)%R ->
  (ln_beta beta (round Zfloor x) = ln_beta beta x :> Z).
Proof.
(* Goal: forall (x : R) (_ : Rlt (IZR Z0) (round Zfloor x)), @eq R (scaled_mantissa (round Zfloor x)) (Z2R (Zfloor (scaled_mantissa x))) *)
intros x Hd.
(* Goal: @eq Z (ln_beta_val beta (round Zfloor x) (ln_beta beta (round Zfloor x))) (ln_beta_val beta x (ln_beta beta x)) *)
assert (0 < x)%R.
(* Goal: Rlt (IZR Z0) x *)
(* Goal: @eq Z (ln_beta_val beta (round Zfloor x) (ln_beta beta (round Zfloor x))) (ln_beta_val beta x (ln_beta beta x)) *)
apply Rlt_le_trans with (1 := Hd).
(* Goal: Rnd_DN_pt generic_format x (round Zfloor x) *)
(* Goal: Rnd_UP_pt generic_format x (round Zceil x) *)
apply round_DN_pt.
(* Goal: @eq Z (ln_beta_val beta (round Zfloor x) (ln_beta beta (round Zfloor x))) (ln_beta_val beta x (ln_beta beta x)) *)
revert Hd.
(* Goal: forall _ : Rlt (IZR Z0) (round Zfloor x), @eq Z (ln_beta_val beta (round Zfloor x) (ln_beta beta (round Zfloor x))) (ln_beta_val beta x (ln_beta beta x)) *)
rewrite <- round_ZR_pos.
(* Goal: forall _ : Rlt (IZR Z0) (round Ztrunc x), @eq Z (ln_beta_val beta (round Ztrunc x) (ln_beta beta (round Ztrunc x))) (ln_beta_val beta x (ln_beta beta x)) *)
(* Goal: Rle (IZR Z0) x *)
intros Hd.
(* Goal: @eq Z (ln_beta_val beta (round Ztrunc x) (ln_beta beta (round Ztrunc x))) (ln_beta_val beta x (ln_beta beta x)) *)
(* Goal: Rle (IZR Z0) x *)
apply ln_beta_round_ZR.
(* Goal: not (@eq R (Fcore_Raux.bpow beta (canonic_exp x)) (IZR Z0)) *)
now apply Rgt_not_eq.
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
now apply Rlt_le.
Qed.

Theorem canonic_exp_DN :
  forall x,
  (0 < round Zfloor x)%R ->
  canonic_exp (round Zfloor x) = canonic_exp x.
Proof.
(* Goal: forall (x : R) (_ : Rlt (IZR Z0) (round Zfloor x)), @eq R (scaled_mantissa (round Zfloor x)) (Z2R (Zfloor (scaled_mantissa x))) *)
intros x Hd.
(* Goal: @eq Z (canonic_exp (round Zfloor x)) (canonic_exp x) *)
apply (f_equal fexp).
(* Goal: @eq Z (ln_beta_val beta (round Zfloor x) (ln_beta beta (round Zfloor x))) (ln_beta_val beta x (ln_beta beta x)) *)
now apply ln_beta_DN.
Qed.

Theorem scaled_mantissa_DN :
  forall x,
  (0 < round Zfloor x)%R ->
  scaled_mantissa (round Zfloor x) = Z2R (Zfloor (scaled_mantissa x)).
Proof.
(* Goal: forall (x : R) (_ : Rlt (IZR Z0) (round Zfloor x)), @eq R (scaled_mantissa (round Zfloor x)) (Z2R (Zfloor (scaled_mantissa x))) *)
intros x Hd.
(* Goal: @eq R (scaled_mantissa (round Zfloor x)) (Z2R (Zfloor (scaled_mantissa x))) *)
unfold scaled_mantissa.
(* Goal: @eq R (Rmult (round Zfloor x) (Fcore_Raux.bpow beta (Z.opp (canonic_exp (round Zfloor x))))) (Z2R (Zfloor (Rmult x (Fcore_Raux.bpow beta (Z.opp (canonic_exp x)))))) *)
rewrite canonic_exp_DN with (1 := Hd).
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
unfold round, F2R. simpl.
(* Goal: Rle (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Rmult (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) *)
(* Goal: Rle (Rmult (Z2R (Zceil (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))))) (Fcore_Raux.bpow beta (fexp ex))) (Fcore_Raux.bpow beta ex) *)
now rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r.
Qed.

Theorem generic_N_pt_DN_or_UP :
  forall x f,
  Rnd_N_pt generic_format x f ->
  f = round Zfloor x \/ f = round Zceil x.
Proof.
(* Goal: forall (x f : R) (_ : Rnd_N_pt generic_format x f), or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
intros x f Hxf.
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf).
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
left.
(* Goal: @eq R f (round Zfloor x) *)
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
apply Rnd_DN_pt_unicity with (1 := H).
(* Goal: Rnd_DN_pt generic_format x (round Zfloor x) *)
(* Goal: Rnd_UP_pt generic_format x (round Zceil x) *)
apply round_DN_pt.
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
right.
(* Goal: @eq R f (round Zceil x) *)
apply Rnd_UP_pt_unicity with (1 := H).
(* Goal: Rnd_UP_pt generic_format x (round Zceil x) *)
apply round_UP_pt.
Qed.

Section not_FTZ.

Class Exp_not_FTZ :=
  exp_not_FTZ : forall e, (fexp (fexp e + 1) <= fexp e)%Z.

Context { exp_not_FTZ_ : Exp_not_FTZ }.

Theorem subnormal_exponent :
  forall e x,
  (e <= fexp e)%Z ->
  generic_format x ->
  x = F2R (Float beta (Ztrunc (x * bpow (- fexp e))) (fexp e)).
Proof.
(* Goal: forall (e : Z) (x : R) (_ : Z.le e (fexp e)) (_ : generic_format x), @eq R x (@F2R beta (Float beta (Ztrunc (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp e))))) (fexp e))) *)
intros e x He Hx.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Rabs x)) (Rle (Rabs x) (Fcore_Raux.bpow beta e2)) *)
pattern x at 2 ; rewrite Hx.
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
unfold F2R at 2. simpl.
(* Goal: Rlt (Rmult (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x)))))) (Fcore_Raux.bpow beta (fexp (ln_beta_val beta x (ln_beta beta x))))) (Rmult (Rinv (IZR (Zpos (xO xH)))) (Fcore_Raux.bpow beta (fexp (ln_beta_val beta x (ln_beta beta x))))) *)
rewrite Rmult_assoc, <- bpow_plus.
(* Goal: @eq R x (@F2R beta (Float beta (Ztrunc (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (fexp e))) *)
assert (H: Z2R (Zpower beta (canonic_exp x + - fexp e)) = bpow (canonic_exp x + - fexp e)).
(* Goal: @eq R (Z2R (Z.pow (radix_val beta) (Z.add (canonic_exp x) (Z.opp (fexp e))))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))) *)
(* Goal: @eq R x (@F2R beta (Float beta (Ztrunc (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (fexp e))) *)
apply Z2R_Zpower.
(* Goal: Z.le Z0 (Z.add (canonic_exp x) (Z.opp (fexp e))) *)
(* Goal: @eq R x (@F2R beta (Float beta (Ztrunc (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (fexp e))) *)
unfold canonic_exp.
(* Goal: Z.le Z0 (Z.add (fexp (ln_beta_val beta x (ln_beta beta x))) (Z.opp (fexp e))) *)
(* Goal: @eq R x (@F2R beta (Float beta (Ztrunc (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (fexp e))) *)
set (ex := ln_beta beta x).
(* Goal: Z.le Z0 (Z.add (fexp (ln_beta_val beta x ex)) (Z.opp (fexp e))) *)
(* Goal: @eq R x (@F2R beta (Float beta (Ztrunc (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (fexp e))) *)
generalize (exp_not_FTZ ex).
(* Goal: forall _ : Z.le (fexp (Z.add (fexp (ln_beta_val beta x ex)) (Zpos xH))) (fexp (ln_beta_val beta x ex)), Z.le Z0 (Z.add (fexp (ln_beta_val beta x ex)) (Z.opp (fexp e))) *)
(* Goal: @eq R x (@F2R beta (Float beta (Ztrunc (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (fexp e))) *)
generalize (proj2 (proj2 (valid_exp _) He) (fexp ex + 1)%Z).
(* Goal: Z.le Z0 (Z.opp (Z.add (Zfloor x) (Zpos xH))) *)
omega.
(* Goal: @eq R x (@F2R beta (Float beta (Ztrunc (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (fexp e))) *)
rewrite <- H.
(* Goal: @eq R x (@F2R beta (Float beta (Ztrunc (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Z2R (Z.pow (radix_val beta) (Z.add (canonic_exp x) (Z.opp (fexp e))))))) (fexp e))) *)
rewrite <- Z2R_mult, Ztrunc_Z2R.
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
unfold F2R. simpl.
(* Goal: @eq R x (Rmult (Z2R (Z.mul (Ztrunc (scaled_mantissa x)) (Z.pow (radix_val beta) (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (Fcore_Raux.bpow beta (fexp e))) *)
rewrite Z2R_mult.
(* Goal: @eq R x (Rmult (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Z2R (Z.pow (radix_val beta) (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (Fcore_Raux.bpow beta (fexp e))) *)
rewrite H.
(* Goal: Rlt (Rmult (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x)))))) (Fcore_Raux.bpow beta (fexp (ln_beta_val beta x (ln_beta beta x))))) (Rmult (Rinv (IZR (Zpos (xO xH)))) (Fcore_Raux.bpow beta (fexp (ln_beta_val beta x (ln_beta beta x))))) *)
rewrite Rmult_assoc, <- bpow_plus.
(* Goal: @eq R x (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Fcore_Raux.bpow beta (Z.add (Z.add (canonic_exp x) (Z.opp (fexp e))) (fexp e)))) *)
now ring_simplify (canonic_exp x + - fexp e + fexp e)%Z.
Qed.

End not_FTZ.

Section monotone_exp.

Class Monotone_exp :=
  monotone_exp : forall ex ey, (ex <= ey)%Z -> (fexp ex <= fexp ey)%Z.

Context { monotone_exp_ : Monotone_exp }.

Global Instance monotone_exp_not_FTZ : Exp_not_FTZ.
Proof.
(* Goal: Exp_not_FTZ *)
intros e.
(* Goal: Z.le (fexp (Z.add (fexp e) (Zpos xH))) (fexp e) *)
destruct (Z_lt_le_dec (fexp e) e) as [He|He].
(* Goal: Z.le (fexp e) (canonic_exp x) *)
apply monotone_exp.
(* Goal: Z.le (Z.succ (Z.pred e)) (ln_beta_val beta x (ln_beta beta x)) *)
now apply Zlt_le_succ.
(* Goal: Z.le (fexp (Z.add (fexp e) (Zpos xH))) (fexp e) *)
now apply valid_exp.
Qed.

Lemma canonic_exp_le_bpow :
  forall (x : R) (e : Z),
  x <> 0%R ->
  (Rabs x < bpow e)%R ->
  (canonic_exp x <= fexp e)%Z.
Proof.
(* Goal: forall (x : R) (e : Z) (_ : not (@eq R x (IZR Z0))) (_ : Rlt (Rabs x) (Fcore_Raux.bpow beta e)), Z.le (canonic_exp x) (fexp e) *)
intros x e Zx Hx.
(* Goal: Z.le (fexp e) (canonic_exp x) *)
apply monotone_exp.
(* Goal: Z.le (ln_beta_val beta x (ln_beta beta x)) e2 *)
(* Goal: forall _ : generic_format fexp1 x, generic_format fexp2 x *)
now apply ln_beta_le_bpow.
Qed.

Lemma canonic_exp_ge_bpow :
  forall (x : R) (e : Z),
  (bpow (e - 1) <= Rabs x)%R ->
  (fexp e <= canonic_exp x)%Z.
Proof.
(* Goal: forall (x : R) (e : Z) (_ : Rle (Fcore_Raux.bpow beta (Z.sub e (Zpos xH))) (Rabs x)), Z.le (fexp e) (canonic_exp x) *)
intros x e Hx.
(* Goal: Z.le (fexp e) (canonic_exp x) *)
apply monotone_exp.
(* Goal: Z.le e (ln_beta_val beta x (ln_beta beta x)) *)
rewrite (Zsucc_pred e).
(* Goal: Z.le (Z.succ (Z.pred e)) (ln_beta_val beta x (ln_beta beta x)) *)
apply Zlt_le_succ.
(* Goal: Z.lt e1 (ln_beta_val beta x (ln_beta beta x)) *)
now apply ln_beta_gt_bpow.
Qed.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Theorem ln_beta_round_ge :
  forall x,
  round rnd x <> 0%R ->
  (ln_beta beta x <= ln_beta beta (round rnd x))%Z.
Proof with auto with typeclass_instances.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
destruct (round_ZR_or_AW rnd x) as [H|H] ; rewrite H ; clear H ; intros Zr.
rewrite ln_beta_round_ZR with (1 := Zr).
(* Goal: Z.le e2 e2 *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Rabs x)) (Rle (Rabs x) (Fcore_Raux.bpow beta e2)) *)
apply Zle_refl.
apply ln_beta_le_abs.
contradict Zr.
rewrite Zr.
apply round_0...
rewrite <- round_AW_abs.
rewrite round_AW_pos.
(* Goal: Rnd_UP_pt generic_format x (round Zceil x) *)
apply round_UP_pt.
apply Rabs_pos.
Qed.

Theorem canonic_exp_round_ge :
  forall x,
  round rnd x <> 0%R ->
  (canonic_exp x <= canonic_exp (round rnd x))%Z.
Proof with auto with typeclass_instances.
intros x Zr.
(* Goal: Z.le Z0 (Z.add (canonic_exp x) (Z.opp (fexp e))) *)
(* Goal: @eq R x (@F2R beta (Float beta (Ztrunc (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (fexp e))) *)
unfold canonic_exp.
(* Goal: Z.le (fexp e) (canonic_exp x) *)
apply monotone_exp.
now apply ln_beta_round_ge.
Qed.

End monotone_exp.

Section Znearest.

(** Roundings to nearest: when in the middle, use the choice function *)
Variable choice : Z -> bool.

Definition Znearest x :=
  match Rcompare (x - Z2R (Zfloor x)) (/2) with
  | Lt => Zfloor x
  | Eq => if choice (Zfloor x) then Zceil x else Zfloor x
  | Gt => Zceil x
  end.

Theorem Znearest_DN_or_UP :
  forall x,
  Znearest x = Zfloor x \/ Znearest x = Zceil x.
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: @eq Z (Znearest (fun t : Z => negb (Z.leb Z0 (Z.opp (Z.add t (Zpos xH))))) x) (Znearest (Z.leb Z0) x) *)
unfold Znearest.
(* Goal: forall _ : @eq R (Rminus (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) (Rminus (Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x)))), @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
(* Goal: forall _ : @eq R (Rminus (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) (Rminus (Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x)))), @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
case Rcompare_spec ; intros _.
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
now left.
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (Zceil x) *)
(* Goal: Z.le (Zceil x) (Zceil y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
case choice.
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
now right.
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
now left.
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
now right.
Qed.

Theorem Znearest_ge_floor :
  forall x,
  (Zfloor x <= Znearest x)%Z.
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Rabs x)) (Rle (Rabs x) (Fcore_Raux.bpow beta e2)) *)
destruct (Znearest_DN_or_UP x) as [Hx|Hx] ; rewrite Hx.
(* Goal: Z.le e2 e2 *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Rabs x)) (Rle (Rabs x) (Fcore_Raux.bpow beta e2)) *)
apply Zle_refl.
(* Goal: Z.le (Zfloor x) (Zceil x) *)
(* Goal: Z.le (Zceil x) (Zceil y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
apply le_Z2R.
(* Goal: Rle (Z2R (Zfloor x)) (Z2R (Zceil x)) *)
(* Goal: Z.le (Zceil x) (Zceil y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
apply Rle_trans with x.
(* Goal: Rle (Z2R (Zfloor (scaled_mantissa x))) (scaled_mantissa x) *)
(* Goal: Rlt (scaled_mantissa x) (Z2R Z0) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply Zfloor_lb.
(* Goal: Rle x (Z2R (Zceil x)) *)
apply Zceil_ub.
Qed.

Theorem Znearest_le_ceil :
  forall x,
  (Znearest x <= Zceil x)%Z.
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Rabs x)) (Rle (Rabs x) (Fcore_Raux.bpow beta e2)) *)
destruct (Znearest_DN_or_UP x) as [Hx|Hx] ; rewrite Hx.
(* Goal: Z.le (Zfloor x) (Zceil x) *)
(* Goal: Z.le (Zceil x) (Zceil y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
apply le_Z2R.
(* Goal: Rle (Z2R (Zfloor x)) (Z2R (Zceil x)) *)
(* Goal: Z.le (Zceil x) (Zceil y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
apply Rle_trans with x.
(* Goal: Rle (Z2R (Zfloor (scaled_mantissa x))) (scaled_mantissa x) *)
(* Goal: Rlt (scaled_mantissa x) (Z2R Z0) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply Zfloor_lb.
(* Goal: Rle x (Z2R (Zceil x)) *)
apply Zceil_ub.
(* Goal: Z.le e2 e2 *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Rabs x)) (Rle (Rabs x) (Fcore_Raux.bpow beta e2)) *)
apply Zle_refl.
Qed.

Global Instance valid_rnd_N : Valid_rnd Znearest.
Proof.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
split.
(* *)
(* Goal: forall (x y : R) (_ : Rle x y), Z.le (Znearest x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
intros x y Hxy.
(* Goal: Z.le (Znearest x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
destruct (Rle_or_lt (Z2R (Zceil x)) y) as [H|H].
(* Goal: Z.le (Znearest x) (Znearest y) *)
(* Goal: Z.le (Znearest x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
apply Zle_trans with (1 := Znearest_le_ceil x).
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: Z.le (Znearest x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
apply Zle_trans with (2 := Znearest_ge_floor y).
(* Goal: Z.le Z0 (Zfloor (scaled_mantissa x)) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
now apply Zfloor_lub.
(* . *)
(* Goal: Z.le (Znearest x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
assert (Hf: Zfloor y = Zfloor x).
(* Goal: @eq Z (Zfloor y) (Zfloor x) *)
(* Goal: Z.le (Znearest x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
apply Zfloor_imp.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
split.
(* Goal: Rle (Z2R (Zfloor x)) y *)
(* Goal: Rlt y (Z2R (Z.add (Zfloor x) (Zpos xH))) *)
(* Goal: Z.le (Znearest x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
apply Rle_trans with (2 := Zfloor_lb y).
(* Goal: Rle (Z2R (Zceil x)) (Z2R (Z.add (Zfloor x) (Zpos xH))) *)
(* Goal: Z.le (Znearest x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
apply Z2R_le.
(* Goal: forall (x y : R) (_ : Rle x y), Z.le (Zfloor x) (Zfloor y) *)
(* Goal: forall n : Z, @eq Z (Zfloor (Z2R n)) n *)
now apply Zfloor_le.
(* Goal: Rlt y (Z2R (Z.add (Zfloor x) (Zpos xH))) *)
(* Goal: Z.le (Znearest x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
apply Rlt_le_trans with (1 := H).
(* Goal: Rle (Z2R (Zceil x)) (Z2R (Z.add (Zfloor x) (Zpos xH))) *)
(* Goal: Z.le (Znearest x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
apply Z2R_le.
(* Goal: Z.le (Zceil x) (Z.add (Zfloor x) (Zpos xH)) *)
(* Goal: Z.le (Znearest x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
apply Zceil_glb.
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
apply Rlt_le.
(* Goal: Rle (Rabs (Rminus x (Z2R (Z.add (Zfloor x) (Zpos xH))))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: not (@eq R (Z2R (Zfloor x)) x) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
rewrite Z2R_plus.
(* Goal: Rlt x (Rplus (Z2R (Zfloor x)) (Z2R (Zpos xH))) *)
(* Goal: Z.le (Znearest x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
apply Zfloor_ub.
(* . *)
(* Goal: Z.le (Znearest x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
unfold Znearest at 1.
(* Goal: Z.le match Rcompare (Rminus x (Z2R (Zfloor x))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor x) then Zceil x else Zfloor x | Lt => Zfloor x | Gt => Zceil x end (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
case Rcompare_spec ; intro Hx.
(* .. *)
(* Goal: Z.le (Zfloor x) (Znearest y) *)
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (Znearest y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
rewrite <- Hf.
(* Goal: Z.le (Zfloor y) (Znearest y) *)
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (Znearest y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
apply Znearest_ge_floor.
(* .. *)
(* Goal: @eq Z (Znearest (fun t : Z => negb (Z.leb Z0 (Z.opp (Z.add t (Zpos xH))))) x) (Znearest (Z.leb Z0) x) *)
unfold Znearest.
(* Goal: Z.le (Zceil x) match Rcompare (Rminus y (Z2R (Zfloor y))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor y) then Zceil y else Zfloor y | Lt => Zfloor y | Gt => Zceil y end *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
rewrite Hf.
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) match Rcompare (Rminus y (Z2R (Zfloor x))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor x) then Zceil y else Zfloor x | Lt => Zfloor x | Gt => Zceil y end *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
case Rcompare_spec ; intro Hy.
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (Zfloor x) *)
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (if choice (Zfloor x) then Zceil y else Zfloor x) *)
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (Zceil y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
elim Rlt_not_le with (1 := Hy).
(* Goal: Rle (Rinv (IZR (Zpos (xO xH)))) (Rminus y (Z2R (Zfloor x))) *)
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (if choice (Zfloor x) then Zceil y else Zfloor x) *)
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (Zceil y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
rewrite <- Hx.
(* Goal: Rle (Rminus x (Z2R (Zfloor x))) (Rminus y (Z2R (Zfloor x))) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
now apply Rplus_le_compat_r.
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (if choice (Zfloor x) then Zceil y else Zfloor x) *)
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (Zceil y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
replace y with x.
(* Goal: Z.le e2 e2 *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Rabs x)) (Rle (Rabs x) (Fcore_Raux.bpow beta e2)) *)
apply Zle_refl.
(* Goal: @eq R x y *)
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (Zceil y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
apply Rplus_eq_reg_l with (- Z2R (Zfloor x))%R.
(* Goal: @eq R (Rplus (Ropp (Z2R (Zfloor x))) x) (Rplus (Ropp (Z2R (Zfloor x))) y) *)
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (Zceil y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
rewrite 2!(Rplus_comm (- (Z2R (Zfloor x)))).
(* Goal: @eq R (Rplus x (Ropp (Z2R (Zfloor x)))) (Rplus y (Ropp (Z2R (Zfloor x)))) *)
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (Zceil y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
change (x - Z2R (Zfloor x) = y - Z2R (Zfloor x))%R.
(* Goal: @eq R (Rminus x (Z2R (Zfloor x))) (Rminus y (Z2R (Zfloor x))) *)
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (Zceil y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
now rewrite Hy.
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (Zceil y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
apply Zle_trans with (Zceil x).
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (Zceil x) *)
(* Goal: Z.le (Zceil x) (Zceil y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
case choice.
(* Goal: Z.le e2 e2 *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Rabs x)) (Rle (Rabs x) (Fcore_Raux.bpow beta e2)) *)
apply Zle_refl.
(* Goal: Z.le (Zfloor x) (Zceil x) *)
(* Goal: Z.le (Zceil x) (Zceil y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
apply le_Z2R.
(* Goal: Rle (Z2R (Zfloor x)) (Z2R (Zceil x)) *)
(* Goal: Z.le (Zceil x) (Zceil y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
apply Rle_trans with x.
(* Goal: Rle (Z2R (Zfloor (scaled_mantissa x))) (scaled_mantissa x) *)
(* Goal: Rlt (scaled_mantissa x) (Z2R Z0) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply Zfloor_lb.
(* Goal: Rle x (Z2R (Zceil x)) *)
apply Zceil_ub.
(* Goal: forall (x y : R) (_ : Rle x y), Z.le (Zceil x) (Zceil y) *)
(* Goal: forall n : Z, @eq Z (Zceil (Z2R n)) n *)
now apply Zceil_le.
(* .. *)
(* Goal: @eq Z (Znearest (fun t : Z => negb (Z.leb Z0 (Z.opp (Z.add t (Zpos xH))))) x) (Znearest (Z.leb Z0) x) *)
unfold Znearest.
(* Goal: Z.le (Zceil x) match Rcompare (Rminus y (Z2R (Zfloor y))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor y) then Zceil y else Zfloor y | Lt => Zfloor y | Gt => Zceil y end *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
rewrite Hf.
(* Goal: Z.le (Zceil x) match Rcompare (Rminus y (Z2R (Zfloor x))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor x) then Zceil y else Zfloor x | Lt => Zfloor x | Gt => Zceil y end *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
rewrite Rcompare_Gt.
(* Goal: forall (x y : R) (_ : Rle x y), Z.le (Zceil x) (Zceil y) *)
(* Goal: forall n : Z, @eq Z (Zceil (Z2R n)) n *)
now apply Zceil_le.
(* Goal: Rlt (Rinv (IZR (Zpos (xO xH)))) (Rminus y (Z2R (Zfloor x))) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
apply Rlt_le_trans with (1 := Hx).
(* Goal: Rle (Rminus x (Z2R (Zfloor x))) (Rminus y (Z2R (Zfloor x))) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
now apply Rplus_le_compat_r.
(* *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
intros n.
(* Goal: @eq Z (Znearest (fun t : Z => negb (Z.leb Z0 (Z.opp (Z.add t (Zpos xH))))) x) (Znearest (Z.leb Z0) x) *)
unfold Znearest.
(* Goal: @eq Z match Rcompare (Rminus (Z2R n) (Z2R (Zfloor (Z2R n)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (Z2R n)) then Zceil (Z2R n) else Zfloor (Z2R n) | Lt => Zfloor (Z2R n) | Gt => Zceil (Z2R n) end n *)
rewrite Zfloor_Z2R.
(* Goal: @eq Z match Rcompare (Rminus (Z2R n) (Z2R n)) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice n then Zceil (Z2R n) else n | Lt => n | Gt => Zceil (Z2R n) end n *)
rewrite Rcompare_Lt.
(* Goal: @eq Z n n *)
(* Goal: Rlt (Rminus (Z2R n) (Z2R n)) (Rinv (IZR (Zpos (xO xH)))) *)
easy.
(* Goal: Rlt (Rminus (Z2R n) (Z2R n)) (Rinv (IZR (Zpos (xO xH)))) *)
unfold Rminus.
(* Goal: Rlt (Rplus (Z2R n) (Ropp (Z2R n))) (Rinv (IZR (Zpos (xO xH)))) *)
rewrite Rplus_opp_r.
(* Goal: Rlt (IZR Z0) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
apply Rinv_0_lt_compat.
(* Goal: Rlt (IZR Z0) (IZR (Zpos (xO xH))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
now apply (Z2R_lt 0 2).
Qed.

Theorem Rcompare_floor_ceil_mid :
  forall x,
  Z2R (Zfloor x) <> x ->
  Rcompare (x - Z2R (Zfloor x)) (/ 2) = Rcompare (x - Z2R (Zfloor x)) (Z2R (Zceil x) - x).
Proof.
(* Goal: forall (x : R) (_ : not (@eq R (Rminus x (Z2R (Zfloor x))) (Rinv (IZR (Zpos (xO xH)))))), Rlt (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
intros x Hx.
(* Goal: @eq comparison (Rcompare (Rminus (Z2R (Zceil x)) x) (Rinv (IZR (Zpos (xO xH))))) (Rcompare (Rminus (Z2R (Zceil x)) x) (Rminus x (Z2R (Zfloor x)))) *)
rewrite Zceil_floor_neq with (1 := Hx).
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
rewrite Z2R_plus. simpl.
(* Goal: @eq Z (rnd (Ropp (scaled_mantissa x))) (Z.opp (Zrnd_opp (scaled_mantissa x))) *)
destruct (Rcompare_spec (x - Z2R (Zfloor x)) (/ 2)) as [H1|H1|H1] ; apply sym_eq.
(* . *)
(* Goal: @eq comparison (Rcompare (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) Lt *)
(* Goal: @eq comparison (Rcompare (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) Eq *)
(* Goal: @eq comparison (Rcompare (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) Gt *)
apply Rcompare_Lt.
(* Goal: Rlt (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x))) *)
apply Rplus_lt_reg_l with (x - Z2R (Zfloor x))%R.
(* Goal: Rlt (Rplus (Rminus x (Z2R (Zfloor x))) (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x)) (Rplus (Rminus x (Z2R (Zfloor x))) (Rminus x (Z2R (Zfloor x)))) *)
replace (x - Z2R (Zfloor x) + (x - Z2R (Zfloor x)))%R with ((x - Z2R (Zfloor x)) * 2)%R by ring.
(* Goal: Rlt (Rplus (Rminus x (Z2R (Zfloor x))) (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x)) (Rmult (Rminus x (Z2R (Zfloor x))) (IZR (Zpos (xO xH)))) *)
replace (x - Z2R (Zfloor x) + (Z2R (Zfloor x) + 1 - x))%R with (/2 * 2)%R by field.
(* Goal: Rlt (Rmult (Rinv (IZR (Zpos (xO xH)))) (IZR (Zpos (xO xH)))) (Rmult (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (IZR (Zpos (xO xH)))) *)
apply Rmult_lt_compat_r with (2 := H1).
(* Goal: Rlt (IZR Z0) (IZR (Zpos (xO xH))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
now apply (Z2R_lt 0 2).
(* . *)
(* Goal: @eq comparison (Rcompare (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) Eq *)
(* Goal: @eq comparison (Rcompare (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) Gt *)
apply Rcompare_Eq.
(* Goal: @eq R (Rminus x (Z2R (Zfloor x))) (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) *)
(* Goal: @eq comparison (Rcompare (Rminus x (Z2R (Zfloor x))) (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x)) Gt *)
replace (Z2R (Zfloor x) + 1 - x)%R with (1 - (x - Z2R (Zfloor x)))%R by ring.
(* Goal: @eq R (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus (IZR (Zpos xH)) (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x)) *)
(* Goal: @eq comparison (Rcompare (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) Gt *)
rewrite H1.
(* Goal: @eq R (Rinv (IZR (Zpos (xO xH)))) (Rminus (IZR (Zpos xH)) (Rinv (IZR (Zpos (xO xH))))) *)
(* Goal: @eq comparison (Rcompare (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) Gt *)
field.
(* . *)
(* Goal: @eq comparison (Rcompare (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) Gt *)
apply Rcompare_Gt.
(* Goal: Rlt (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x))) *)
apply Rplus_lt_reg_l with (x - Z2R (Zfloor x))%R.
(* Goal: Rlt (Rplus (Rminus x (Z2R (Zfloor x))) (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x)) (Rplus (Rminus x (Z2R (Zfloor x))) (Rminus x (Z2R (Zfloor x)))) *)
replace (x - Z2R (Zfloor x) + (x - Z2R (Zfloor x)))%R with ((x - Z2R (Zfloor x)) * 2)%R by ring.
(* Goal: Rlt (Rplus (Rminus x (Z2R (Zfloor x))) (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x)) (Rmult (Rminus x (Z2R (Zfloor x))) (IZR (Zpos (xO xH)))) *)
replace (x - Z2R (Zfloor x) + (Z2R (Zfloor x) + 1 - x))%R with (/2 * 2)%R by field.
(* Goal: Rlt (Rmult (Rinv (IZR (Zpos (xO xH)))) (IZR (Zpos (xO xH)))) (Rmult (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (IZR (Zpos (xO xH)))) *)
apply Rmult_lt_compat_r with (2 := H1).
(* Goal: Rlt (IZR Z0) (IZR (Zpos (xO xH))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
now apply (Z2R_lt 0 2).
Qed.

Theorem Rcompare_ceil_floor_mid :
  forall x,
  Z2R (Zfloor x) <> x ->
  Rcompare (Z2R (Zceil x) - x) (/ 2) = Rcompare (Z2R (Zceil x) - x) (x - Z2R (Zfloor x)).
Proof.
(* Goal: forall (x : R) (_ : not (@eq R (Rminus x (Z2R (Zfloor x))) (Rinv (IZR (Zpos (xO xH)))))), Rlt (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
intros x Hx.
(* Goal: @eq comparison (Rcompare (Rminus (Z2R (Zceil x)) x) (Rinv (IZR (Zpos (xO xH))))) (Rcompare (Rminus (Z2R (Zceil x)) x) (Rminus x (Z2R (Zfloor x)))) *)
rewrite Zceil_floor_neq with (1 := Hx).
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
rewrite Z2R_plus. simpl.
(* Goal: @eq Z (rnd (Ropp (scaled_mantissa x))) (Z.opp (Zrnd_opp (scaled_mantissa x))) *)
destruct (Rcompare_spec (Z2R (Zfloor x) + 1 - x) (/ 2)) as [H1|H1|H1] ; apply sym_eq.
(* . *)
(* Goal: @eq comparison (Rcompare (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) Lt *)
(* Goal: @eq comparison (Rcompare (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) Eq *)
(* Goal: @eq comparison (Rcompare (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) Gt *)
apply Rcompare_Lt.
(* Goal: Rlt (Rminus x (Z2R (Zfloor x))) (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) *)
apply Rplus_lt_reg_l with (Z2R (Zfloor x) + 1 - x)%R.
(* Goal: Rlt (Rplus (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) (Rplus (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x)) *)
replace (Z2R (Zfloor x) + 1 - x + (Z2R (Zfloor x) + 1 - x))%R with ((Z2R (Zfloor x) + 1 - x) * 2)%R by ring.
(* Goal: @eq R (Rinv (IZR (Zpos (xO xH)))) (Rminus (IZR (Zpos xH)) (Rinv (IZR (Zpos (xO xH))))) *)
(* Goal: @eq comparison (Rcompare (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) Gt *)
replace (Z2R (Zfloor x) + 1 - x + (x - Z2R (Zfloor x)))%R with (/2 * 2)%R by field.
(* Goal: Rlt (Rmult (Rinv (IZR (Zpos (xO xH)))) (IZR (Zpos (xO xH)))) (Rmult (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (IZR (Zpos (xO xH)))) *)
apply Rmult_lt_compat_r with (2 := H1).
(* Goal: Rlt (IZR Z0) (IZR (Zpos (xO xH))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
now apply (Z2R_lt 0 2).
(* . *)
(* Goal: @eq comparison (Rcompare (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) Eq *)
(* Goal: @eq comparison (Rcompare (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) Gt *)
apply Rcompare_Eq.
(* Goal: @eq R (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x))) *)
(* Goal: @eq comparison (Rcompare (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) Gt *)
replace (x - Z2R (Zfloor x))%R with (1 - (Z2R (Zfloor x) + 1 - x))%R by ring.
(* Goal: @eq R (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus (IZR (Zpos xH)) (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x)) *)
(* Goal: @eq comparison (Rcompare (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) Gt *)
rewrite H1.
(* Goal: @eq R (Rinv (IZR (Zpos (xO xH)))) (Rminus (IZR (Zpos xH)) (Rinv (IZR (Zpos (xO xH))))) *)
(* Goal: @eq comparison (Rcompare (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) Gt *)
field.
(* . *)
(* Goal: @eq comparison (Rcompare (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) Gt *)
apply Rcompare_Gt.
(* Goal: Rlt (Rminus x (Z2R (Zfloor x))) (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) *)
apply Rplus_lt_reg_l with (Z2R (Zfloor x) + 1 - x)%R.
(* Goal: Rlt (Rplus (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) (Rplus (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x)) *)
replace (Z2R (Zfloor x) + 1 - x + (Z2R (Zfloor x) + 1 - x))%R with ((Z2R (Zfloor x) + 1 - x) * 2)%R by ring.
(* Goal: @eq R (Rinv (IZR (Zpos (xO xH)))) (Rminus (IZR (Zpos xH)) (Rinv (IZR (Zpos (xO xH))))) *)
(* Goal: @eq comparison (Rcompare (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) Gt *)
replace (Z2R (Zfloor x) + 1 - x + (x - Z2R (Zfloor x)))%R with (/2 * 2)%R by field.
(* Goal: Rlt (Rmult (Rinv (IZR (Zpos (xO xH)))) (IZR (Zpos (xO xH)))) (Rmult (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (IZR (Zpos (xO xH)))) *)
apply Rmult_lt_compat_r with (2 := H1).
(* Goal: Rlt (IZR Z0) (IZR (Zpos (xO xH))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
now apply (Z2R_lt 0 2).
Qed.

Theorem Znearest_N_strict :
  forall x,
  (x - Z2R (Zfloor x) <> /2)%R ->
  (Rabs (x - Z2R (Znearest x)) < /2)%R.
Proof.
(* Goal: forall (x : R) (_ : not (@eq R (Rminus x (Z2R (Zfloor x))) (Rinv (IZR (Zpos (xO xH)))))), Rlt (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
intros x Hx.
(* Goal: @eq Z (Znearest (fun t : Z => negb (Z.leb Z0 (Z.opp (Z.add t (Zpos xH))))) x) (Znearest (Z.leb Z0) x) *)
unfold Znearest.
(* Goal: forall _ : @eq R (Rminus (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) (Rminus (Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x)))), @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
case Rcompare_spec ; intros H.
(* Goal: Rle x (Rabs f) *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
rewrite Rabs_pos_eq.
(* Goal: Rlt (Rminus x (Z2R (Zfloor x))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (IZR Z0) (Rminus x (Z2R (Zfloor x))) *)
(* Goal: Rlt (Rabs (Rminus x (Z2R (if choice (Zfloor x) then Zceil x else Zfloor x)))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rlt (Rabs (Rminus x (Z2R (Zceil x)))) (Rinv (IZR (Zpos (xO xH)))) *)
exact H.
(* Goal: Rle (IZR Z0) (Rminus x (Z2R (Zfloor x))) *)
(* Goal: Rlt (Rabs (Rminus x (Z2R (if choice (Zfloor x) then Zceil x else Zfloor x)))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rlt (Rabs (Rminus x (Z2R (Zceil x)))) (Rinv (IZR (Zpos (xO xH)))) *)
apply Rle_0_minus.
(* Goal: Rle (Z2R (Zfloor (scaled_mantissa x))) (scaled_mantissa x) *)
(* Goal: Rlt (scaled_mantissa x) (Z2R Z0) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply Zfloor_lb.
(* Goal: Rlt (Rabs (Rminus x (Z2R (if choice (Zfloor x) then Zceil x else Zfloor x)))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rlt (Rabs (Rminus x (Z2R (Zceil x)))) (Rinv (IZR (Zpos (xO xH)))) *)
now elim Hx.
(* Goal: Rle (Ropp x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
rewrite Rabs_left1.
(* Goal: Rlt (Ropp (Rminus x (Z2R (Zceil x)))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (Rminus x (Z2R (Zceil x))) (IZR Z0) *)
rewrite Ropp_minus_distr.
(* Goal: Rle (Rabs (Rminus x (Z2R (Zceil x)))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
rewrite Zceil_floor_neq.
(* Goal: Rle (Rabs (Rminus x (Z2R (Z.add (Zfloor x) (Zpos xH))))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: not (@eq R (Z2R (Zfloor x)) x) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
rewrite Z2R_plus.
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
simpl.
(* Goal: Rlt (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: not (@eq R (Z2R (Zfloor x)) x) *)
(* Goal: Rle (Rminus x (Z2R (Zceil x))) (IZR Z0) *)
apply Ropp_lt_cancel.
(* Goal: Rlt (Ropp (Rinv (IZR (Zpos (xO xH))))) (Ropp (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x)) *)
(* Goal: not (@eq R (Z2R (Zfloor x)) x) *)
(* Goal: Rle (Rminus x (Z2R (Zceil x))) (IZR Z0) *)
apply Rplus_lt_reg_l with 1%R.
(* Goal: @eq R (Rinv (IZR (Zpos (xO xH)))) (Rminus (IZR (Zpos xH)) (Rinv (IZR (Zpos (xO xH))))) *)
(* Goal: @eq comparison (Rcompare (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) Gt *)
replace (1 + -/2)%R with (/2)%R by field.
(* Goal: Rlt (Rinv (IZR (Zpos (xO xH)))) (Rplus (IZR (Zpos xH)) (Ropp (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x))) *)
(* Goal: not (@eq R (Z2R (Zfloor x)) x) *)
(* Goal: Rle (Rminus x (Z2R (Zceil x))) (IZR Z0) *)
now replace (1 + - (Z2R (Zfloor x) + 1 - x))%R with (x - Z2R (Zfloor x))%R by ring.
(* Goal: not (@eq R (Z2R (Zfloor x)) x) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
apply Rlt_not_eq.
(* Goal: Rlt (Z2R (Zfloor x)) x *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
apply Rplus_lt_reg_l with (- Z2R (Zfloor x))%R.
(* Goal: Rlt (Rplus (Ropp (Z2R (Zfloor x))) (Z2R (Zfloor x))) (Rplus (Ropp (Z2R (Zfloor x))) x) *)
(* Goal: Rle (Rminus x (Z2R (Zceil x))) (IZR Z0) *)
apply Rlt_trans with (/2)%R.
(* Goal: Rlt (Rplus (Ropp (Z2R (Zfloor x))) (Z2R (Zfloor x))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rlt (Rinv (IZR (Zpos (xO xH)))) (Rplus (Ropp (Z2R (Zfloor x))) x) *)
(* Goal: Rle (Rminus x (Z2R (Zceil x))) (IZR Z0) *)
rewrite Rplus_opp_l.
(* Goal: Rlt (IZR Z0) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
apply Rinv_0_lt_compat.
(* Goal: Rlt (IZR Z0) (IZR (Zpos (xO xH))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
now apply (Z2R_lt 0 2).
(* Goal: Rlt (Rinv (IZR (Zpos (xO xH)))) (Rplus (Ropp (Z2R (Zfloor x))) x) *)
(* Goal: Rle (Rminus x (Z2R (Zceil x))) (IZR Z0) *)
now rewrite <- (Rplus_comm x).
(* Goal: Rle (Rminus x (Z2R (Zceil x))) (IZR Z0) *)
apply Rle_minus.
(* Goal: Rle x (Z2R (Zceil x)) *)
apply Zceil_ub.
Qed.

Theorem Znearest_N :
  forall x,
  (Rabs (x - Z2R (Znearest x)) <= /2)%R.
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
destruct (Req_dec (x - Z2R (Zfloor x)) (/2)) as [Hx|Hx].
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
assert (K: (Rabs (/2) <= /2)%R).
(* Goal: Rle (Rabs (Rinv (IZR (Zpos (xO xH))))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
apply Req_le.
(* Goal: @eq R (Rabs (Rinv (IZR (Zpos (xO xH))))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
apply Rabs_pos_eq.
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
apply Rlt_le.
(* Goal: Rlt (IZR Z0) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
apply Rinv_0_lt_compat.
(* Goal: Rlt (IZR Z0) (IZR (Zpos (xO xH))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
now apply (Z2R_lt 0 2).
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
destruct (Znearest_DN_or_UP x) as [H|H] ; rewrite H ; clear H.
(* Goal: Rle (Rabs (Rminus x (Z2R (Zfloor x)))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Zceil x)))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
now rewrite Hx.
(* Goal: Rle (Rabs (Rminus x (Z2R (Zceil x)))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
rewrite Zceil_floor_neq.
(* Goal: Rle (Rabs (Rminus x (Z2R (Z.add (Zfloor x) (Zpos xH))))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: not (@eq R (Z2R (Zfloor x)) x) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
rewrite Z2R_plus.
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
simpl.
(* Goal: Rle (Rabs (Rminus x (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: not (@eq R (Z2R (Zfloor x)) x) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
replace (x - (Z2R (Zfloor x) + 1))%R with (x - Z2R (Zfloor x) - 1)%R by ring.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Rabs x)) (Rle (Rabs x) (Fcore_Raux.bpow beta e2)) *)
rewrite Hx.
(* Goal: Rle (Rabs (Rminus (Rinv (IZR (Zpos (xO xH)))) (IZR (Zpos xH)))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: not (@eq R (Z2R (Zfloor x)) x) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
rewrite Rabs_minus_sym.
(* Goal: @eq R (Rinv (IZR (Zpos (xO xH)))) (Rminus (IZR (Zpos xH)) (Rinv (IZR (Zpos (xO xH))))) *)
(* Goal: @eq comparison (Rcompare (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) Gt *)
now replace (1 - /2)%R with (/2)%R by field.
(* Goal: not (@eq R (Z2R (Zfloor x)) x) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
apply Rlt_not_eq.
(* Goal: Rlt (Z2R (Zfloor x)) x *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
apply Rplus_lt_reg_l with (- Z2R (Zfloor x))%R.
(* Goal: Rlt (Rplus (Ropp (Z2R (Zfloor x))) (Z2R (Zfloor x))) (Rplus (Ropp (Z2R (Zfloor x))) x) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
rewrite Rplus_opp_l, Rplus_comm.
(* Goal: Rlt (IZR Z0) (Rplus x (Ropp (Z2R (Zfloor x)))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
fold (x - Z2R (Zfloor x))%R.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Rabs x)) (Rle (Rabs x) (Fcore_Raux.bpow beta e2)) *)
rewrite Hx.
(* Goal: Rlt (IZR Z0) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
apply Rinv_0_lt_compat.
(* Goal: Rlt (IZR Z0) (IZR (Zpos (xO xH))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
now apply (Z2R_lt 0 2).
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
apply Rlt_le.
(* Goal: Rlt (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
now apply Znearest_N_strict.
Qed.

Theorem Znearest_imp :
  forall x n,
  (Rabs (x - Z2R n) < /2)%R ->
  Znearest x = n.
Proof.
(* Goal: forall (x : R) (n : Z) (_ : Rlt (Rabs (Rminus x (Z2R n))) (Rinv (IZR (Zpos (xO xH))))), @eq Z (Znearest x) n *)
intros x n Hd.
(* Goal: @eq Z (Znearest x) n *)
cut (Zabs (Znearest x - n) < 1)%Z.
(* Goal: Z.le Z0 (Z.opp (Z.add (Zfloor x) (Zpos xH))) *)
clear ; zify ; omega.
(* Goal: Z.lt (Zfloor (scaled_mantissa x)) Z0 *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply lt_Z2R.
(* Goal: Rlt (Z2R (Z.abs (Z.sub (Znearest x) n))) (Z2R (Zpos xH)) *)
rewrite Z2R_abs, Z2R_minus.
(* Goal: Rlt (Rabs (Rminus (Z2R (Znearest x)) (Z2R n))) (Z2R (Zpos xH)) *)
replace (Z2R (Znearest x) - Z2R n)%R with (- (x - Z2R (Znearest x)) + (x - Z2R n))%R by ring.
(* Goal: Rlt (Rabs (Rplus (Ropp (Rminus x (Z2R (Znearest x)))) (Rminus x (Z2R n)))) (Z2R (Zpos xH)) *)
apply Rle_lt_trans with (1 := Rabs_triang _ _).
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
simpl.
(* Goal: @eq R (Rinv (IZR (Zpos (xO xH)))) (Rminus (IZR (Zpos xH)) (Rinv (IZR (Zpos (xO xH))))) *)
(* Goal: @eq comparison (Rcompare (Rminus (Rplus (Z2R (Zfloor x)) (IZR (Zpos xH))) x) (Rminus x (Z2R (Zfloor x)))) Gt *)
replace 1%R with (/2 + /2)%R by field.
(* Goal: Rlt (Rplus (Rabs (Ropp (Rminus x (Z2R (Znearest x))))) (Rabs (Rminus x (Z2R n)))) (Rplus (Rinv (IZR (Zpos (xO xH)))) (Rinv (IZR (Zpos (xO xH))))) *)
apply Rplus_le_lt_compat with (2 := Hd).
(* Goal: Rle (Rabs (Ropp (Rminus x (Z2R (Znearest x))))) (Rinv (IZR (Zpos (xO xH)))) *)
rewrite Rabs_Ropp.
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
apply Znearest_N.
Qed.

Theorem round_N_pt :
  forall x,
  Rnd_N_pt generic_format x (round Znearest x).
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
set (d := round Zfloor x).
set (u := round Zceil x).
set (mx := scaled_mantissa x).
set (bx := bpow (canonic_exp x)).
(* . *)
assert (H: (Rabs (round Znearest x - x) <= Rmin (x - d) (u - x))%R).
pattern x at -1 ; rewrite <- scaled_mantissa_mult_bpow.
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
unfold d, u, round, F2R. simpl.
fold mx bx.
rewrite <- 3!Rmult_minus_distr_r.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
rewrite Rabs_mult, (Rabs_pos_eq bx). 2: apply bpow_ge_0.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
rewrite <- Rmult_min_distr_r. 2: apply bpow_ge_0.
(* Goal: Rle (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Rmult (Fcore_Raux.bpow beta ex) (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) *)
apply Rmult_le_compat_r.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_ge_0.
(* Goal: @eq Z (Znearest (fun t : Z => negb (Z.leb Z0 (Z.opp (Z.add t (Zpos xH))))) x) (Znearest (Z.leb Z0) x) *)
unfold Znearest.
destruct (Req_dec (Z2R (Zfloor mx)) mx) as [Hm|Hm].
(* .. *)
rewrite Hm.
unfold Rminus at 2.
(* Goal: Rlt (Rplus (Z2R n) (Ropp (Z2R n))) (Rinv (IZR (Zpos (xO xH)))) *)
rewrite Rplus_opp_r.
(* Goal: @eq Z match Rcompare (Rminus (Z2R n) (Z2R n)) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice n then Zceil (Z2R n) else n | Lt => n | Gt => Zceil (Z2R n) end n *)
rewrite Rcompare_Lt.
rewrite Hm.
unfold Rminus at -3.
(* Goal: Rlt (Rplus (Z2R n) (Ropp (Z2R n))) (Rinv (IZR (Zpos (xO xH)))) *)
rewrite Rplus_opp_r.
rewrite Rabs_R0.
unfold Rmin.
destruct (Rle_dec 0 (Z2R (Zceil mx) - mx)) as [H|H].
(* Goal: Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2) *)
apply Rle_refl.
(* Goal: Rle (IZR Z0) (Rminus x (Z2R (Zfloor x))) *)
(* Goal: Rlt (Rabs (Rminus x (Z2R (if choice (Zfloor x) then Zceil x else Zfloor x)))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rlt (Rabs (Rminus x (Z2R (Zceil x)))) (Rinv (IZR (Zpos (xO xH)))) *)
apply Rle_0_minus.
(* Goal: Rle x (Z2R (Zceil x)) *)
apply Zceil_ub.
(* Goal: Rlt (IZR Z0) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
apply Rinv_0_lt_compat.
(* Goal: Rlt (IZR Z0) (IZR (Zpos (xO xH))) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
now apply (Z2R_lt 0 2).
(* .. *)
rewrite Rcompare_floor_ceil_mid with (1 := Hm).
rewrite Rmin_compare.
assert (H: (Rabs (mx - Z2R (Zfloor mx)) <= mx - Z2R (Zfloor mx))%R).
(* Goal: Rle x (Rabs f) *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
rewrite Rabs_pos_eq.
(* Goal: Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2) *)
apply Rle_refl.
(* Goal: Rle (IZR Z0) (Rminus x (Z2R (Zfloor x))) *)
(* Goal: Rlt (Rabs (Rminus x (Z2R (if choice (Zfloor x) then Zceil x else Zfloor x)))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rlt (Rabs (Rminus x (Z2R (Zceil x)))) (Rinv (IZR (Zpos (xO xH)))) *)
apply Rle_0_minus.
(* Goal: Rle (Z2R (Zfloor (scaled_mantissa x))) (scaled_mantissa x) *)
(* Goal: Rlt (scaled_mantissa x) (Z2R Z0) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply Zfloor_lb.
case Rcompare_spec ; intros Hm'.
(* Goal: Rle (Rabs (Rminus (Rinv (IZR (Zpos (xO xH)))) (IZR (Zpos xH)))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: not (@eq R (Z2R (Zfloor x)) x) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
now rewrite Rabs_minus_sym.
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (Zceil x) *)
(* Goal: Z.le (Zceil x) (Zceil y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
case choice.
rewrite <- Hm'.
(* Goal: Rlt (Rminus x (Z2R (Zfloor x))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rle (IZR Z0) (Rminus x (Z2R (Zfloor x))) *)
(* Goal: Rlt (Rabs (Rminus x (Z2R (if choice (Zfloor x) then Zceil x else Zfloor x)))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rlt (Rabs (Rminus x (Z2R (Zceil x)))) (Rinv (IZR (Zpos (xO xH)))) *)
exact H.
(* Goal: Rle (Rabs (Rminus (Rinv (IZR (Zpos (xO xH)))) (IZR (Zpos xH)))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: not (@eq R (Z2R (Zfloor x)) x) *)
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
now rewrite Rabs_minus_sym.
(* Goal: Rle x (Rabs f) *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
rewrite Rabs_pos_eq.
(* Goal: Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2) *)
apply Rle_refl.
(* Goal: Rle (IZR Z0) (Rminus x (Z2R (Zfloor x))) *)
(* Goal: Rlt (Rabs (Rminus x (Z2R (if choice (Zfloor x) then Zceil x else Zfloor x)))) (Rinv (IZR (Zpos (xO xH)))) *)
(* Goal: Rlt (Rabs (Rminus x (Z2R (Zceil x)))) (Rinv (IZR (Zpos (xO xH)))) *)
apply Rle_0_minus.
(* Goal: Rle x (Z2R (Zceil x)) *)
apply Zceil_ub.
(* . *)
apply Rnd_DN_UP_pt_N with d u.
apply generic_format_round.
auto with typeclass_instances.
(* Goal: Rnd_DN_pt generic_format x (round Zfloor x) *)
(* Goal: Rnd_UP_pt generic_format x (round Zceil x) *)
now apply round_DN_pt.
(* Goal: Rnd_UP_pt generic_format x (round Zceil x) *)
now apply round_UP_pt.
apply Rle_trans with (1 := H).
apply Rmin_l.
apply Rle_trans with (1 := H).
apply Rmin_r.
Qed.

Theorem round_N_middle :
  forall x,
  (x - round Zfloor x = round Zceil x - x)%R ->
  round Znearest x = if choice (Zfloor (scaled_mantissa x)) then round Zceil x else round Zfloor x.
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: forall _ : @eq R (Rminus x (round Zfloor x)) (Rminus (round Zceil x) x), @eq R (round Znearest x) (if choice (Zfloor (scaled_mantissa x)) then round Zceil x else round Zfloor x) *)
pattern x at 1 4 ; rewrite <- scaled_mantissa_mult_bpow.
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
unfold round, Znearest, F2R. simpl.
(* Goal: forall _ : @eq R (Rminus (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) (Rminus (Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x)))), @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
destruct (Req_dec (Z2R (Zfloor (scaled_mantissa x))) (scaled_mantissa x)) as [Fx|Fx].
(* *)
(* Goal: forall _ : @eq R (Rminus (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) (Rminus (Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x)))), @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
(* Goal: forall _ : @eq R (Rminus (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) (Rminus (Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x)))), @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
intros _.
(* Goal: Z.le (canonic_exp fexp2 (@F2R beta (Float beta (Ztrunc (scaled_mantissa fexp1 x)) (canonic_exp fexp1 x)))) (canonic_exp fexp1 x) *)
rewrite <- Fx.
(* Goal: @eq R (Rmult (Z2R match Rcompare (Rminus (Z2R (Zfloor (scaled_mantissa x))) (Z2R (Zfloor (Z2R (Zfloor (scaled_mantissa x)))))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (Z2R (Zfloor (scaled_mantissa x)))) then Zceil (Z2R (Zfloor (scaled_mantissa x))) else Zfloor (Z2R (Zfloor (scaled_mantissa x))) | Lt => Zfloor (Z2R (Zfloor (scaled_mantissa x))) | Gt => Zceil (Z2R (Zfloor (scaled_mantissa x))) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (Z2R (Zfloor (scaled_mantissa x)))) then Rmult (Z2R (Zceil (Z2R (Zfloor (scaled_mantissa x))))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (Z2R (Zfloor (scaled_mantissa x))))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
(* Goal: forall _ : @eq R (Rminus (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) (Rminus (Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x)))), @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
rewrite Zceil_Z2R, Zfloor_Z2R.
(* Goal: @eq R (Rmult (Z2R match Rcompare (Rminus (Z2R (Zfloor (scaled_mantissa x))) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zfloor (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zfloor (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
(* Goal: forall _ : @eq R (Rminus (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) (Rminus (Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x)))), @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
set (m := Zfloor (scaled_mantissa x)).
(* Goal: @eq R (Rmult (Z2R match Rcompare (Rminus (Z2R m) (Z2R m)) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice m then m else m | Lt => m | Gt => m end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice m then Rmult (Z2R m) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R m) (Fcore_Raux.bpow beta (canonic_exp x))) *)
(* Goal: forall _ : @eq R (Rminus (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) (Rminus (Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x)))), @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
now case (Rcompare (Z2R m - Z2R m) (/ 2)) ; case (choice m).
(* *)
(* Goal: forall _ : @eq R (Rminus (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) (Rminus (Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (scaled_mantissa x) (Fcore_Raux.bpow beta (canonic_exp x)))), @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
intros H.
(* Goal: @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
rewrite Rcompare_floor_ceil_mid with (1 := Fx).
(* Goal: @eq R (Rmult (Z2R match Rcompare (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rminus (Z2R (Zceil (scaled_mantissa x))) (scaled_mantissa x)) with | Eq => if choice (Zfloor (scaled_mantissa x)) then Zceil (scaled_mantissa x) else Zfloor (scaled_mantissa x) | Lt => Zfloor (scaled_mantissa x) | Gt => Zceil (scaled_mantissa x) end) (Fcore_Raux.bpow beta (canonic_exp x))) (if choice (Zfloor (scaled_mantissa x)) then Rmult (Z2R (Zceil (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)) else Rmult (Z2R (Zfloor (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x))) *)
rewrite Rcompare_Eq.
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (Zceil x) *)
(* Goal: Z.le (Zceil x) (Zceil y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
now case choice.
(* Goal: @eq R (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Rminus (Z2R (Zceil (scaled_mantissa x))) (scaled_mantissa x)) *)
apply Rmult_eq_reg_r with (bpow (canonic_exp x)).
(* Goal: @eq R (Rmult (Rminus (scaled_mantissa x) (Z2R (Zfloor (scaled_mantissa x)))) (Fcore_Raux.bpow beta (canonic_exp x))) (Rmult (Rminus (Z2R (Zceil (scaled_mantissa x))) (scaled_mantissa x)) (Fcore_Raux.bpow beta (canonic_exp x))) *)
(* Goal: not (@eq R (Fcore_Raux.bpow beta (canonic_exp x)) (IZR Z0)) *)
now rewrite 2!Rmult_minus_distr_r.
(* Goal: not (@eq R (Fcore_Raux.bpow beta (canonic_exp x)) (IZR Z0)) *)
apply Rgt_not_eq.
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_gt_0.
Qed.

Lemma round_N_really_small_pos :
  forall x,
  forall ex,
  (Fcore_Raux.bpow beta (ex - 1) <= x < Fcore_Raux.bpow beta ex)%R ->
  (ex < fexp ex)%Z ->
  (round Znearest x = 0)%R.
Proof.
(* Goal: forall (x : R) (ex : Z) (_ : and (Rle (Fcore_Raux.bpow beta (Z.sub ex (Zpos xH))) x) (Rlt x (Fcore_Raux.bpow beta ex))) (_ : Z.lt ex (fexp ex)), @eq R (round Znearest x) (IZR Z0) *)
intros x ex Hex Hf.
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
unfold round, F2R, scaled_mantissa, canonic_exp; simpl.
apply (Rmult_eq_reg_r (bpow (- fexp (ln_beta beta x))));
  [|now apply Rgt_not_eq; apply bpow_gt_0].
(* Goal: @eq R (Rmult (Rmult (Z2R (Znearest (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x)))))))) (Fcore_Raux.bpow beta (fexp (ln_beta_val beta x (ln_beta beta x))))) (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x)))))) (Rmult (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x)))))) *)
rewrite Rmult_0_l, Rmult_assoc, <- bpow_plus.
(* Goal: @eq R (Rmult (Z2R (Znearest (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x)))))))) (Fcore_Raux.bpow beta (Z.add (fexp (ln_beta_val beta x (ln_beta beta x))) (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x))))))) (IZR Z0) *)
replace (_ + - _)%Z with 0%Z by ring; simpl; rewrite Rmult_1_r.
(* Goal: @eq R (Rmult (Rabs x) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x)))) (Rmult (Rabs x) (Rabs (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))))) *)
change 0%R with (Z2R 0); apply f_equal.
(* Goal: @eq Z (Znearest (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x))))))) Z0 *)
apply Znearest_imp.
(* Goal: Rlt (Rabs (Rminus (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x)))))) (Z2R Z0))) (Rinv (IZR (Zpos (xO xH)))) *)
simpl; unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r.
(* Goal: Rlt (Rabs (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x))))))) (Rinv (IZR (Zpos (xO xH)))) *)
assert (H : (x >= 0)%R).
(* Goal: Rge (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x)))))) (IZR Z0) *)
(* Goal: Rlt (Rabs (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x))))))) (Rinv (IZR (Zpos (xO xH)))) *)
{ apply Rle_ge; apply Rle_trans with (bpow (ex - 1)); [|exact (proj1 Hex)].
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
  now apply bpow_ge_0. }
(* Goal: Rlt (Rabs (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x))))))) (Rinv (IZR (Zpos (xO xH)))) *)
assert (H' : (x * bpow (- fexp (ln_beta beta x)) >= 0)%R).
{ apply Rle_ge; apply Rmult_le_pos.
(* Goal: Rle (IZR Z0) x *)
  - now apply Rge_le.
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
  - now apply bpow_ge_0. }
(* Goal: Rlt (Rabs (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x))))))) (Rinv (IZR (Zpos (xO xH)))) *)
rewrite Rabs_right; [|exact H'].
(* Goal: Rlt (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x)))))) (Rinv (IZR (Zpos (xO xH)))) *)
apply (Rmult_lt_reg_r (bpow (fexp (ln_beta beta x)))); [now apply bpow_gt_0|].
(* Goal: Rlt (Rmult (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x)))))) (Fcore_Raux.bpow beta (fexp (ln_beta_val beta x (ln_beta beta x))))) (Rmult (Rinv (IZR (Zpos (xO xH)))) (Fcore_Raux.bpow beta (fexp (ln_beta_val beta x (ln_beta beta x))))) *)
rewrite Rmult_assoc, <- bpow_plus.
replace (- _ + _)%Z with 0%Z by ring; simpl; rewrite Rmult_1_r.
(* Goal: Rlt x (Rmult (Rinv (IZR (Zpos (xO xH)))) (Fcore_Raux.bpow beta (fexp (ln_beta_val beta x (ln_beta beta x))))) *)
apply (Rlt_le_trans _ _ _ (proj2 Hex)).
apply Rle_trans with (bpow (fexp (ln_beta beta x) - 1)).
(* Goal: Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2) *)
(* Goal: Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2) *)
- apply bpow_le.
(* Goal: Z.le ex (Z.sub (fexp (ln_beta_val beta x (ln_beta beta x))) (Zpos xH)) *)
  rewrite (ln_beta_unique beta x ex); [omega|].
(* Goal: or (@eq R f (round Zfloor x)) (@eq R f (round Zceil x)) *)
  now rewrite Rabs_right.
(* Goal: Rle (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp ex)))) (Fcore_Raux.bpow beta (Z.add ex (Z.opp (fexp ex)))) *)
- unfold Zminus; rewrite bpow_plus.
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (fexp (ln_beta_val beta x (ln_beta beta x)))) (Fcore_Raux.bpow beta (Z.opp (Zpos xH)))) (Rmult (Rinv (IZR (Zpos (xO xH)))) (Fcore_Raux.bpow beta (fexp (ln_beta_val beta x (ln_beta beta x))))) *)
  rewrite Rmult_comm.
(* Goal: Rle (Rmult (Fcore_Raux.bpow beta (Z.opp (Zpos xH))) (Fcore_Raux.bpow beta (fexp (ln_beta_val beta x (ln_beta beta x))))) (Rmult (Rinv (IZR (Zpos (xO xH)))) (Fcore_Raux.bpow beta (fexp (ln_beta_val beta x (ln_beta beta x))))) *)
  apply Rmult_le_compat_r; [now apply bpow_ge_0|].
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
  unfold Fcore_Raux.bpow, Z.pow_pos; simpl.
(* Goal: Rle (Rinv (Z2R (Z.mul (radix_val beta) (Zpos xH)))) (Rinv (IZR (Zpos (xO xH)))) *)
  rewrite Zmult_1_r.
(* Goal: Rle (Rinv (Z2R (radix_val beta))) (Rinv (IZR (Zpos (xO xH)))) *)
  apply Rinv_le; [exact Rlt_0_2|].
(* Goal: Rle (Z2R (Zceil x)) (Z2R (Z.add (Zfloor x) (Zpos xH))) *)
(* Goal: Z.le (Znearest x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
  change 2%R with (Z2R 2); apply Z2R_le.
(* Goal: Z.le (Zpos (xO xH)) (radix_val beta) *)
  destruct beta as (beta_val,beta_prop).
(* Goal: Z.le (Zpos (xO xH)) (radix_val (Build_radix beta_val beta_prop)) *)
  now apply Zle_bool_imp_le.
Qed.

End Znearest.

Section rndNA.

Global Instance valid_rnd_NA : Valid_rnd (Znearest (Zle_bool 0)) := valid_rnd_N _.

Theorem round_NA_pt :
  forall x,
  Rnd_NA_pt generic_format x (round (Znearest (Zle_bool 0)) x).
Proof.
(* Goal: forall x : R, Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
intros x.
(* Goal: Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
generalize (round_N_pt (Zle_bool 0) x).
(* Goal: forall _ : Rnd_N_pt generic_format x (round (Znearest (Z.leb Z0)) x), Rnd_NA_pt generic_format x (round (Znearest (Z.leb Z0)) x) *)
set (f := round (Znearest (Zle_bool 0)) x).
(* Goal: forall _ : Rnd_N_pt generic_format x f, Rnd_NA_pt generic_format x f *)
intros Rxf.
destruct (Req_dec (x - round Zfloor x) (round Zceil x - x)) as [Hm|Hm].
(* *)
(* Goal: Rnd_NA_pt generic_format x f *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply Rnd_NA_N_pt.
(* Goal: generic_format (IZR Z0) *)
(* Goal: Rle x (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
exact generic_format_0.
(* Goal: Rnd_N_pt generic_format x f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
exact Rxf.
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
destruct (Rle_or_lt 0 x) as [Hx|Hx].
(* . *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
rewrite Rabs_pos_eq with (1 := Hx).
(* Goal: Rle x (Rabs f) *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
rewrite Rabs_pos_eq.
(* Goal: Rle f x *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
unfold f.
(* Goal: Rle (round (Znearest (Z.leb Z0)) x) x *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
rewrite round_N_middle with (1 := Hm).
(* Goal: Rle x (if Z.leb Z0 (Zfloor (scaled_mantissa x)) then round Zceil x else round Zfloor x) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
rewrite Zle_bool_true.
(* Goal: Rle x (round Zceil x) *)
(* Goal: Z.le Z0 (Zfloor (scaled_mantissa x)) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply (round_UP_pt x).
(* Goal: Z.le Z0 (Zfloor (scaled_mantissa x)) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply Zfloor_lub.
(* Goal: Rle (Z2R Z0) (scaled_mantissa x) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply Rmult_le_pos with (1 := Hx).
(* Goal: Rle (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_ge_0.
(* Goal: Rle (IZR Z0) f *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply Rnd_N_pt_pos with (2 := Hx) (3 := Rxf).
(* Goal: generic_format (IZR Z0) *)
(* Goal: Rle x (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
exact generic_format_0.
(* . *)
(* Goal: Rle (Rabs x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
rewrite Rabs_left with (1 := Hx).
(* Goal: Rle (Ropp x) (Rabs f) *)
(* Goal: Rnd_NA_pt generic_format x f *)
rewrite Rabs_left1.
(* Goal: Rle (Ropp x) (Ropp f) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply Ropp_le_contravar.
(* Goal: Rle f x *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
unfold f.
(* Goal: Rle (round (Znearest (Z.leb Z0)) x) x *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
rewrite round_N_middle with (1 := Hm).
(* Goal: Rle (if Z.leb Z0 (Zfloor (scaled_mantissa x)) then round Zceil x else round Zfloor x) x *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
rewrite Zle_bool_false.
(* Goal: Rle (round Zfloor x) x *)
(* Goal: Z.lt (Zfloor (scaled_mantissa x)) Z0 *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply (round_DN_pt x).
(* Goal: Z.lt (Zfloor (scaled_mantissa x)) Z0 *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply lt_Z2R.
(* Goal: Rlt (Z2R (Zfloor (scaled_mantissa x))) (Z2R Z0) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply Rle_lt_trans with (scaled_mantissa x).
(* Goal: Rle (Z2R (Zfloor (scaled_mantissa x))) (scaled_mantissa x) *)
(* Goal: Rlt (scaled_mantissa x) (Z2R Z0) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply Zfloor_lb.
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
simpl.
(* Goal: Rlt (scaled_mantissa x) (IZR Z0) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
rewrite <- (Rmult_0_l (bpow (- canonic_exp x))).
(* Goal: Rlt (scaled_mantissa x) (Rmult (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x)))) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply Rmult_lt_compat_r with (2 := Hx).
(* Goal: Rlt (IZR Z0) (Fcore_Raux.bpow beta (Z.opp (canonic_exp x))) *)
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply bpow_gt_0.
(* Goal: Rle f (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
apply Rnd_N_pt_neg with (3 := Rxf).
(* Goal: generic_format (IZR Z0) *)
(* Goal: Rle x (IZR Z0) *)
(* Goal: Rnd_NA_pt generic_format x f *)
exact generic_format_0.
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
now apply Rlt_le.
(* *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
split.
(* Goal: Rnd_N_pt generic_format x f *)
(* Goal: forall (f2 : R) (_ : Rnd_N_pt generic_format x f2), Rle (Rabs f2) (Rabs f) *)
apply Rxf.
(* Goal: forall (f2 : R) (_ : Rnd_N_pt generic_format x f2), Rle (Rabs f2) (Rabs f) *)
intros g Rxg.
(* Goal: Rle (Rabs g) (Rabs f) *)
rewrite Rnd_N_pt_unicity with (3 := Hm) (4 := Rxf) (5 := Rxg).
(* Goal: Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2) *)
apply Rle_refl.
(* Goal: Rnd_DN_pt generic_format x (round Zfloor x) *)
(* Goal: Rnd_UP_pt generic_format x (round Zceil x) *)
apply round_DN_pt.
(* Goal: Rnd_UP_pt generic_format x (round Zceil x) *)
apply round_UP_pt.
Qed.

End rndNA.

Section rndN_opp.

Theorem Znearest_opp :
  forall choice x,
  Znearest choice (- x) = (- Znearest (fun t => negb (choice (- (t + 1))%Z)) x)%Z.
Proof with auto with typeclass_instances.
(* Goal: forall (choice : forall _ : Z, bool) (x : R), @eq R (round (Znearest choice) (Ropp x)) (Ropp (round (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH)))))) x)) *)
intros choice x.
destruct (Req_dec (Z2R (Zfloor x)) x) as [Hx|Hx].
(* Goal: Rle (Rinv (IZR (Zpos (xO xH)))) (Rminus y (Z2R (Zfloor x))) *)
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (if choice (Zfloor x) then Zceil y else Zfloor x) *)
(* Goal: Z.le (if choice (Zfloor x) then Zceil x else Zfloor x) (Zceil y) *)
(* Goal: Z.le (Zceil x) (Znearest y) *)
(* Goal: forall n : Z, @eq Z (Znearest (Z2R n)) n *)
rewrite <- Hx.
rewrite <- Z2R_opp.
rewrite 2!Zrnd_Z2R...
(* Goal: @eq Z (Znearest (fun t : Z => negb (Z.leb Z0 (Z.opp (Z.add t (Zpos xH))))) x) (Znearest (Z.leb Z0) x) *)
unfold Znearest.
replace (- x - Z2R (Zfloor (-x)))%R with (Z2R (Zceil x) - x)%R.
rewrite Rcompare_ceil_floor_mid with (1 := Hx).
rewrite Rcompare_floor_ceil_mid with (1 := Hx).
rewrite Rcompare_sym.
rewrite <- Zceil_floor_neq with (1 := Hx).
(* Goal: @eq R (@F2R beta (Float beta (Zceil (Ropp (scaled_mantissa x))) (canonic_exp (Ropp x)))) (@F2R beta (Float beta (Z.opp (Zfloor (scaled_mantissa x))) (canonic_exp x))) *)
unfold Zceil.
(* Goal: @eq R (@F2R beta (Float beta (Z.opp (Zfloor (Ropp (Ropp (scaled_mantissa x))))) (canonic_exp (Ropp x)))) (@F2R beta (Float beta (Z.opp (Zfloor (scaled_mantissa x))) (canonic_exp x))) *)
rewrite Ropp_involutive.
case Rcompare ; simpl ; trivial.
(* Goal: @eq R (@F2R beta (Float beta (Zfloor (Ropp (scaled_mantissa x))) (canonic_exp (Ropp x)))) (@F2R beta (Float beta (Z.opp (Z.opp (Zfloor (Ropp (scaled_mantissa x))))) (canonic_exp x))) *)
rewrite Zopp_involutive.
case (choice (Zfloor (- x))) ; simpl ; trivial.
(* Goal: @eq R (@F2R beta (Float beta (Zfloor (Ropp (scaled_mantissa x))) (canonic_exp (Ropp x)))) (@F2R beta (Float beta (Z.opp (Z.opp (Zfloor (Ropp (scaled_mantissa x))))) (canonic_exp x))) *)
now rewrite Zopp_involutive.
(* Goal: @eq R (@F2R beta (Float beta (Zfloor (Ropp (scaled_mantissa x))) (canonic_exp (Ropp x)))) (@F2R beta (Float beta (Z.opp (Z.opp (Zfloor (Ropp (scaled_mantissa x))))) (canonic_exp x))) *)
now rewrite Zopp_involutive.
(* Goal: @eq R (@F2R beta (Float beta (Zceil (Ropp (scaled_mantissa x))) (canonic_exp (Ropp x)))) (@F2R beta (Float beta (Z.opp (Zfloor (scaled_mantissa x))) (canonic_exp x))) *)
unfold Zceil.
(* Goal: @eq R (Rmult (Z2R (Z.opp (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)))) (Fcore_Raux.bpow beta (canonic_exp x))) (Ropp (Rmult (Z2R (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) *)
rewrite Z2R_opp.
apply Rplus_comm.
Qed.

Theorem round_N_opp :
  forall choice,
  forall x,
  round (Znearest choice) (-x) = (- round (Znearest (fun t => negb (choice (- (t + 1))%Z))) x)%R.
Proof.
(* Goal: forall (choice : forall _ : Z, bool) (x : R), @eq R (round (Znearest choice) (Ropp x)) (Ropp (round (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH)))))) x)) *)
intros choice x.
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
unfold round, F2R. simpl.
(* Goal: @eq R (Rmult (Z2R (Znearest choice (scaled_mantissa (Ropp x)))) (Fcore_Raux.bpow beta (canonic_exp (Ropp x)))) (Ropp (Rmult (Z2R (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) *)
rewrite canonic_exp_opp.
(* Goal: @eq R (Rmult (Z2R (Znearest choice (scaled_mantissa (Ropp x)))) (Fcore_Raux.bpow beta (canonic_exp x))) (Ropp (Rmult (Z2R (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) *)
rewrite scaled_mantissa_opp.
(* Goal: @eq R (Rmult (Z2R (Znearest choice (Ropp (scaled_mantissa x)))) (Fcore_Raux.bpow beta (canonic_exp x))) (Ropp (Rmult (Z2R (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) *)
rewrite Znearest_opp.
(* Goal: @eq R (Rmult (Z2R (Z.opp (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)))) (Fcore_Raux.bpow beta (canonic_exp x))) (Ropp (Rmult (Z2R (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) *)
rewrite Z2R_opp.
(* Goal: @eq R (Rmult (Ropp (Z2R (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)))) (Fcore_Raux.bpow beta (canonic_exp x))) (Ropp (Rmult (Z2R (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x))) (Fcore_Raux.bpow beta (canonic_exp x)))) *)
now rewrite Ropp_mult_distr_l_reverse.
Qed.

End rndN_opp.

End Format.

(** Inclusion of a format into an extended format *)
Section Inclusion.

Variables fexp1 fexp2 : Z -> Z.

(* Goal: Rge (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x)))))) (IZR Z0) *)
(* Goal: Rlt (Rabs (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x))))))) (Rinv (IZR (Zpos (xO xH)))) *)
Context { valid_exp1 : Valid_exp fexp1 }.
(* Goal: Rge (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x)))))) (IZR Z0) *)
(* Goal: Rlt (Rabs (Rmult x (Fcore_Raux.bpow beta (Z.opp (fexp (ln_beta_val beta x (ln_beta beta x))))))) (Rinv (IZR (Zpos (xO xH)))) *)
Context { valid_exp2 : Valid_exp fexp2 }.

Theorem generic_inclusion_ln_beta :
  forall x,
  ( x <> R0 -> (fexp2 (ln_beta beta x) <= fexp1 (ln_beta beta x))%Z ) ->
  generic_format fexp1 x ->
  generic_format fexp2 x.
Proof.
(* Goal: forall (x : R) (_ : forall _ : not (@eq R x R0), Z.le (fexp2 (ln_beta_val beta x (ln_beta beta x))) (fexp1 (ln_beta_val beta x (ln_beta beta x)))) (_ : generic_format fexp1 x), generic_format fexp2 x *)
intros x He Fx.
(* Goal: generic_format fexp2 x *)
rewrite Fx.
(* Goal: generic_format fexp2 (@F2R beta (Float beta (Ztrunc (scaled_mantissa fexp1 x)) (canonic_exp fexp1 x))) *)
apply generic_format_F2R.
(* Goal: forall _ : not (@eq R x R0), Z.le (fexp2 (ln_beta_val beta x (ln_beta beta x))) (fexp1 (ln_beta_val beta x (ln_beta beta x))) *)
intros Zx.
(* Goal: Z.le (canonic_exp fexp2 (@F2R beta (Float beta (Ztrunc (scaled_mantissa fexp1 x)) (canonic_exp fexp1 x)))) (canonic_exp fexp1 x) *)
rewrite <- Fx.
(* Goal: Z.le (fexp2 (ln_beta_val beta x (ln_beta beta x))) (fexp1 (ln_beta_val beta x (ln_beta beta x))) *)
apply He.
(* Goal: not (@eq R x R0) *)
contradict Zx.
(* Goal: @eq Z (Ztrunc (scaled_mantissa fexp1 x)) Z0 *)
rewrite Zx, scaled_mantissa_0.
(* Goal: @eq Z (Ztrunc (IZR Z0)) Z0 *)
apply (Ztrunc_Z2R 0).
Qed.

Theorem generic_inclusion_lt_ge :
  forall e1 e2,
  ( forall e, (e1 < e <= e2)%Z -> (fexp2 e <= fexp1 e)%Z ) ->
  forall x,
  (bpow e1 <= Rabs x < bpow e2)%R ->
  generic_format fexp1 x ->
  generic_format fexp2 x.
Proof.
(* Goal: forall (e1 e2 : Z) (_ : forall (e : Z) (_ : and (Z.lt e1 e) (Z.le e e2)), Z.le (fexp2 e) (fexp1 e)) (x : R) (_ : and (Rle (Fcore_Raux.bpow beta e1) (Rabs x)) (Rlt (Rabs x) (Fcore_Raux.bpow beta e2))) (_ : generic_format fexp1 x), generic_format fexp2 x *)
intros e1 e2 He x (Hx1,Hx2).
(* Goal: forall _ : generic_format fexp1 x, generic_format fexp2 x *)
apply generic_inclusion_ln_beta.
(* Goal: forall _ : not (@eq R x R0), Z.le (fexp2 (ln_beta_val beta x (ln_beta beta x))) (fexp1 (ln_beta_val beta x (ln_beta beta x))) *)
intros Zx.
(* Goal: Z.le (fexp2 (ln_beta_val beta x (ln_beta beta x))) (fexp1 (ln_beta_val beta x (ln_beta beta x))) *)
apply He.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
split.
(* Goal: Z.lt e1 (ln_beta_val beta x (ln_beta beta x)) *)
now apply ln_beta_gt_bpow.
(* Goal: Z.le (ln_beta_val beta x (ln_beta beta x)) e2 *)
(* Goal: forall _ : generic_format fexp1 x, generic_format fexp2 x *)
now apply ln_beta_le_bpow.
Qed.

Theorem generic_inclusion :
  forall e,
  (fexp2 e <= fexp1 e)%Z ->
  forall x,
  (bpow (e - 1) <= Rabs x <= bpow e)%R ->
  generic_format fexp1 x ->
  generic_format fexp2 x.
Proof with auto with typeclass_instances.
intros e He x (Hx1,[Hx2|Hx2]).
(* Goal: forall _ : generic_format fexp1 x, generic_format fexp2 x *)
apply generic_inclusion_ln_beta.
now rewrite ln_beta_unique with (1 := conj Hx1 Hx2).
intros Fx.
apply generic_format_abs_inv.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Rabs x)) (Rle (Rabs x) (Fcore_Raux.bpow beta e2)) *)
rewrite Hx2.
apply generic_format_bpow'...
apply Zle_trans with (1 := He).
apply generic_format_bpow_inv...
rewrite <- Hx2.
now apply generic_format_abs.
Qed.

Theorem generic_inclusion_le_ge :
  forall e1 e2,
  (e1 < e2)%Z ->
  ( forall e, (e1 < e <= e2)%Z -> (fexp2 e <= fexp1 e)%Z ) ->
  forall x,
  (bpow e1 <= Rabs x <= bpow e2)%R ->
  generic_format fexp1 x ->
  generic_format fexp2 x.
Proof.
(* Goal: forall (e1 e2 : Z) (_ : Z.lt e1 e2) (_ : forall (e : Z) (_ : and (Z.lt e1 e) (Z.le e e2)), Z.le (fexp2 e) (fexp1 e)) (x : R) (_ : and (Rle (Fcore_Raux.bpow beta e1) (Rabs x)) (Rle (Rabs x) (Fcore_Raux.bpow beta e2))) (_ : generic_format fexp1 x), generic_format fexp2 x *)
intros e1 e2 He' He x (Hx1,[Hx2|Hx2]).
(* *)
(* Goal: forall _ : generic_format fexp1 x, generic_format fexp2 x *)
apply generic_inclusion_ln_beta.
(* Goal: forall _ : not (@eq R x R0), Z.le (fexp2 (ln_beta_val beta x (ln_beta beta x))) (fexp1 (ln_beta_val beta x (ln_beta beta x))) *)
intros Zx.
(* Goal: Z.le (fexp2 (ln_beta_val beta x (ln_beta beta x))) (fexp1 (ln_beta_val beta x (ln_beta beta x))) *)
apply He.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
split.
(* Goal: Z.lt e1 (ln_beta_val beta x (ln_beta beta x)) *)
now apply ln_beta_gt_bpow.
(* Goal: Z.le (ln_beta_val beta x (ln_beta beta x)) e2 *)
(* Goal: forall _ : generic_format fexp1 x, generic_format fexp2 x *)
now apply ln_beta_le_bpow.
(* *)
(* Goal: forall _ : generic_format fexp1 x, generic_format fexp2 x *)
apply generic_inclusion with (e := e2).
(* Goal: Z.le (fexp2 (ln_beta_val beta x (ln_beta beta x))) (fexp1 (ln_beta_val beta x (ln_beta beta x))) *)
apply He.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
split.
(* Goal: Z.lt e1 e2 *)
(* Goal: Z.le e2 e2 *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Rabs x)) (Rle (Rabs x) (Fcore_Raux.bpow beta e2)) *)
apply He'.
(* Goal: Z.le e2 e2 *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Rabs x)) (Rle (Rabs x) (Fcore_Raux.bpow beta e2)) *)
apply Zle_refl.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Rabs x)) (Rle (Rabs x) (Fcore_Raux.bpow beta e2)) *)
rewrite Hx2.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
split.
(* Goal: Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2) *)
(* Goal: Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2) *)
apply bpow_le.
(* Goal: Z.le (Z.sub e2 (Zpos xH)) e2 *)
(* Goal: Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2) *)
apply Zle_pred.
(* Goal: Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2) *)
apply Rle_refl.
Qed.

Theorem generic_inclusion_le :
  forall e2,
  ( forall e, (e <= e2)%Z -> (fexp2 e <= fexp1 e)%Z ) ->
  forall x,
  (Rabs x <= bpow e2)%R ->
  generic_format fexp1 x ->
  generic_format fexp2 x.
Proof.
(* Goal: forall (e2 : Z) (_ : forall (e : Z) (_ : Z.le e e2), Z.le (fexp2 e) (fexp1 e)) (x : R) (_ : Rle (Rabs x) (Fcore_Raux.bpow beta e2)) (_ : generic_format fexp1 x), generic_format fexp2 x *)
intros e2 He x [Hx|Hx].
(* Goal: forall _ : generic_format fexp1 x, generic_format fexp2 x *)
apply generic_inclusion_ln_beta.
(* Goal: forall _ : not (@eq R x R0), Z.le (fexp2 (ln_beta_val beta x (ln_beta beta x))) (fexp1 (ln_beta_val beta x (ln_beta beta x))) *)
intros Zx.
(* Goal: Z.le (fexp2 (ln_beta_val beta x (ln_beta beta x))) (fexp1 (ln_beta_val beta x (ln_beta beta x))) *)
apply He.
(* Goal: Z.le (ln_beta_val beta x (ln_beta beta x)) e2 *)
(* Goal: forall _ : generic_format fexp1 x, generic_format fexp2 x *)
now apply ln_beta_le_bpow.
(* Goal: forall _ : generic_format fexp1 x, generic_format fexp2 x *)
apply generic_inclusion with (e := e2).
(* Goal: Z.le (fexp2 (ln_beta_val beta x (ln_beta beta x))) (fexp1 (ln_beta_val beta x (ln_beta beta x))) *)
apply He.
(* Goal: Z.le e2 e2 *)
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Rabs x)) (Rle (Rabs x) (Fcore_Raux.bpow beta e2)) *)
apply Zle_refl.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Rabs x)) (Rle (Rabs x) (Fcore_Raux.bpow beta e2)) *)
rewrite Hx.
(* Goal: and (Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2)) (Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2)) *)
split.
(* Goal: Rle (Fcore_Raux.bpow beta (Z.sub e2 (Zpos xH))) (Fcore_Raux.bpow beta e2) *)
(* Goal: Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2) *)
apply bpow_le.
(* Goal: Z.le (Z.sub e2 (Zpos xH)) e2 *)
(* Goal: Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2) *)
apply Zle_pred.
(* Goal: Rle (Fcore_Raux.bpow beta e2) (Fcore_Raux.bpow beta e2) *)
apply Rle_refl.
Qed.

Theorem generic_inclusion_ge :
  forall e1,
  ( forall e, (e1 < e)%Z -> (fexp2 e <= fexp1 e)%Z ) ->
  forall x,
  (bpow e1 <= Rabs x)%R ->
  generic_format fexp1 x ->
  generic_format fexp2 x.
Proof.
(* Goal: forall (e1 : Z) (_ : forall (e : Z) (_ : Z.lt e1 e), Z.le (fexp2 e) (fexp1 e)) (x : R) (_ : Rle (Fcore_Raux.bpow beta e1) (Rabs x)) (_ : generic_format fexp1 x), generic_format fexp2 x *)
intros e1 He x Hx.
(* Goal: forall _ : generic_format fexp1 x, generic_format fexp2 x *)
apply generic_inclusion_ln_beta.
(* Goal: forall _ : not (@eq R x R0), Z.le (fexp2 (ln_beta_val beta x (ln_beta beta x))) (fexp1 (ln_beta_val beta x (ln_beta beta x))) *)
intros Zx.
(* Goal: Z.le (fexp2 (ln_beta_val beta x (ln_beta beta x))) (fexp1 (ln_beta_val beta x (ln_beta beta x))) *)
apply He.
(* Goal: Z.lt e1 (ln_beta_val beta x (ln_beta beta x)) *)
now apply ln_beta_gt_bpow.
Qed.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Theorem generic_round_generic :
  forall x,
  generic_format fexp1 x ->
  generic_format fexp1 (round fexp2 rnd x).
Proof with auto with typeclass_instances.
intros x Gx.
apply generic_format_abs_inv.
apply generic_format_abs in Gx.
revert rnd valid_rnd x Gx.
refine (round_abs_abs _ (fun x y => generic_format fexp1 x -> generic_format fexp1 y) _).
intros rnd valid_rnd x [Hx|Hx] Gx.
(* x > 0 *)
generalize (ln_beta_generic_gt _ x (Rgt_not_eq _ _ Hx) Gx).
(* Goal: Z.le Z0 (Z.add (canonic_exp x) (Z.opp (fexp e))) *)
(* Goal: @eq R x (@F2R beta (Float beta (Ztrunc (Rmult (Z2R (Ztrunc (scaled_mantissa x))) (Fcore_Raux.bpow beta (Z.add (canonic_exp x) (Z.opp (fexp e)))))) (fexp e))) *)
unfold canonic_exp.
(* Goal: @eq R (Rmult (Z2R (@Fnum beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x))))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest choice (scaled_mantissa (Ropp x))) (canonic_exp (Ropp x)))))) (Ropp (Rmult (Z2R (@Fnum beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))) (Fcore_Raux.bpow beta (@Fexp beta (Float beta (Znearest (fun t : Z => negb (choice (Z.opp (Z.add t (Zpos xH))))) (scaled_mantissa x)) (canonic_exp x)))))) *)
destruct (ln_beta beta x) as (ex,Ex) ; simpl.
specialize (Ex (Rgt_not_eq _ _ Hx)).
intros He'.
(* Goal: Rle (Rabs (Rminus x (Z2R (Znearest x)))) (Rinv (IZR (Zpos (xO xH)))) *)
rewrite Rabs_pos_eq in Ex by now apply Rlt_le.
destruct (Zle_or_lt ex (fexp2 ex)) as [He|He].
(* - x near 0 for fexp2 *)
destruct (round_bounded_small_pos fexp2 rnd x ex He Ex) as [Hr|Hr].
rewrite Hr.
(* Goal: generic_format (IZR Z0) *)
(* Goal: forall _ : forall _ : not (@eq Z m Z0), Z.le (canonic_exp (@F2R beta (Float beta m e))) e, generic_format (@F2R beta (Float beta m e)) *)
apply generic_format_0.
rewrite Hr.
apply generic_format_bpow'...
apply Zlt_le_weak.
apply valid_exp_large with ex...
(* - x large for fexp2 *)
destruct (Zle_or_lt (canonic_exp fexp2 x) (canonic_exp fexp1 x)) as [He''|He''].
(* - - round fexp2 x is representable for fexp1 *)
rewrite round_generic...
(* Goal: @eq R x (IZR Z0) *)
rewrite Gx.
(* Goal: generic_format fexp2 (@F2R beta (Float beta (Ztrunc (scaled_mantissa fexp1 x)) (canonic_exp fexp1 x))) *)
apply generic_format_F2R.
fold (round fexp1 Ztrunc x).
(* Goal: forall _ : not (@eq R x R0), Z.le (fexp2 (ln_beta_val beta x (ln_beta beta x))) (fexp1 (ln_beta_val beta x (ln_beta beta x))) *)
intros Zx.
unfold canonic_exp at 1.
rewrite ln_beta_round_ZR...
(* Goal: not (@eq R x R0) *)
contradict Zx.
apply F2R_eq_0_reg with (1 := Zx).
(* - - round fexp2 x has too many digits for fexp1 *)
destruct (round_bounded_large_pos fexp2 rnd x ex He Ex) as (Hr1,[Hr2|Hr2]).
(* Goal: generic_format fexp2 (@F2R beta (Float beta (Ztrunc (scaled_mantissa fexp1 x)) (canonic_exp fexp1 x))) *)
apply generic_format_F2R.
(* Goal: forall _ : not (@eq R x R0), Z.le (fexp2 (ln_beta_val beta x (ln_beta beta x))) (fexp1 (ln_beta_val beta x (ln_beta beta x))) *)
intros Zx.
fold (round fexp2 rnd x).
unfold canonic_exp at 1.
rewrite ln_beta_unique_pos with (1 := conj Hr1 Hr2).
rewrite <- ln_beta_unique_pos with (1 := Ex).
now apply Zlt_le_weak.
rewrite Hr2.
apply generic_format_bpow'...
now apply Zlt_le_weak.
(* x = 0 *)
rewrite <- Hx, round_0...
(* Goal: generic_format (IZR Z0) *)
(* Goal: forall _ : forall _ : not (@eq Z m Z0), Z.le (canonic_exp (@F2R beta (Float beta m e))) e, generic_format (@F2R beta (Float beta m e)) *)
apply generic_format_0.
Qed.

End Inclusion.

End Generic.

Notation ZnearestA := (Znearest (Zle_bool 0)).

Section rndNA_opp.

Lemma round_NA_opp :
  forall beta : radix,
  forall (fexp : Z -> Z),
  forall x,
  (round beta fexp ZnearestA (- x) = - round beta fexp ZnearestA x)%R.
Proof.
(* Goal: forall (beta : radix) (fexp : forall _ : Z, Z) (x : R), @eq R (round beta fexp (Znearest (Z.leb Z0)) (Ropp x)) (Ropp (round beta fexp (Znearest (Z.leb Z0)) x)) *)
intros beta fexp x.
(* Goal: @eq R (round beta fexp (Znearest (Z.leb Z0)) (Ropp x)) (Ropp (round beta fexp (Znearest (Z.leb Z0)) x)) *)
rewrite round_N_opp.
(* Goal: @eq R (Ropp (round beta fexp (Znearest (fun t : Z => negb (Z.leb Z0 (Z.opp (Z.add t (Zpos xH)))))) x)) (Ropp (round beta fexp (Znearest (Z.leb Z0)) x)) *)
apply Ropp_eq_compat.
(* Goal: @eq R (round beta fexp (Znearest (fun t : Z => negb (Z.leb Z0 (Z.opp (Z.add t (Zpos xH)))))) x) (round beta fexp (Znearest (Z.leb Z0)) x) *)
apply round_ext.
(* Goal: forall x : R, @eq Z (Znearest (fun t : Z => negb (Z.leb Z0 (Z.opp (Z.add t (Zpos xH))))) x) (Znearest (Z.leb Z0) x) *)
clear x; intro x.
(* Goal: @eq Z (Znearest (fun t : Z => negb (Z.leb Z0 (Z.opp (Z.add t (Zpos xH))))) x) (Znearest (Z.leb Z0) x) *)
unfold Znearest.
case_eq (Rcompare (x - Z2R (Zfloor x)) (/ 2)); intro C;
[|reflexivity|reflexivity].
(* Goal: @eq Z (if negb (Z.leb Z0 (Z.opp (Z.add (Zfloor x) (Zpos xH)))) then Zceil x else Zfloor x) (if Z.leb Z0 (Zfloor x) then Zceil x else Zfloor x) *)
apply Rcompare_Eq_inv in C.
assert (H : negb (0 <=? - (Zfloor x + 1))%Z = (0 <=? Zfloor x)%Z);
  [|now rewrite H].
(* Goal: @eq bool (negb (Z.leb Z0 (Z.opp (Z.add (Zfloor x) (Zpos xH))))) (Z.leb Z0 (Zfloor x)) *)
rewrite negb_Zle_bool.
(* Goal: @eq bool (Z.ltb (Z.opp (Z.add (Zfloor x) (Zpos xH))) Z0) (Z.leb Z0 (Zfloor x)) *)
case_eq (0 <=? Zfloor x)%Z; intro C'.
- apply Zle_bool_imp_le in C'.
(* Goal: @eq bool (Z.ltb (Z.opp (Z.add (Zfloor x) (Zpos xH))) Z0) true *)
  apply Zlt_bool_true.
(* Goal: Z.le Z0 (Z.opp (Z.add (Zfloor x) (Zpos xH))) *)
  omega.
- rewrite Z.leb_gt in C'.
(* Goal: @eq bool (Z.ltb (Z.opp (Z.add (Zfloor x) (Zpos xH))) Z0) false *)
  apply Zlt_bool_false.
(* Goal: Z.le Z0 (Z.opp (Z.add (Zfloor x) (Zpos xH))) *)
  omega.
Qed.

End rndNA_opp.

(** Notations for backward-compatibility with Flocq 1.4. *)
Notation rndDN := Zfloor (only parsing).
Notation rndUP := Zceil (only parsing).
Notation rndZR := Ztrunc (only parsing).
Notation rndNA := ZnearestA (only parsing).
