(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*          Jacques-Henri Jourdan, INRIA Paris-Rocquencourt            *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Additional operations and proofs about IEEE-754 binary
    floating-point numbers, on top of the Flocq library. *)

Require Import Psatz.
Require Import Bool.
Require Import Eqdep_dec.
Require Import Fcore.
Require Import Fcore_digits.
Require Import Fcalc_digits.
Require Import Fcalc_ops.
Require Import Fcalc_round.
Require Import Fcalc_bracket.
Require Import Fprop_Sterbenz.
Require Import Fappli_IEEE.
Require Import Fappli_rnd_odd.

Local Open Scope Z_scope.

Section Extra_ops.

(** [prec] is the number of bits of the mantissa including the implicit one.
    [emax] is the exponent of the infinities.
    Typically p=24 and emax = 128 in single precision. *)

Variable prec emax : Z.
Context (prec_gt_0_ : Prec_gt_0 prec).
Let emin := (3 - emax - prec)%Z.
Let fexp := FLT_exp emin prec.
Hypothesis Hmax : (prec < emax)%Z.
Let binary_float := binary_float prec emax.

(** Remarks on [is_finite] *)

Remark is_finite_not_is_nan:
  forall (f: binary_float), is_finite _ _ f = true -> is_nan _ _ f = false.
Proof.
(* Goal: forall (f : binary_float) (_ : @eq bool (is_finite_strict prec emax f) true), @eq bool (is_finite prec emax f) true *)
  destruct f; reflexivity || discriminate.
Qed.

Remark is_finite_strict_finite:
  forall (f: binary_float), is_finite_strict _ _ f = true -> is_finite _ _ f = true.
Proof.
(* Goal: forall (f : binary_float) (_ : @eq bool (is_finite_strict prec emax f) true), @eq bool (is_finite prec emax f) true *)
  destruct f; reflexivity || discriminate.
Qed.

(** Digression on FP numbers that cannot be [-0.0]. *)

Definition is_finite_pos0 (f: binary_float) : bool :=
  match f with
  | B754_zero _ _ s => negb s
  | B754_infinity _ _ _ => false
  | B754_nan _ _ _ _ => false
  | B754_finite _ _ _ _ _ _ => true
  end.

Lemma Bsign_pos0:
  forall x, is_finite_pos0 x = true -> Bsign _ _ x = Rlt_bool (B2R _ _ x) 0%R.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. destruct x as [ [] | | | [] ex mx Bx ]; try discriminate; simpl.
- rewrite Rlt_bool_false; auto. lra.
- rewrite Rlt_bool_true; auto. apply F2R_lt_0_compat. compute; auto.
- rewrite Rlt_bool_false; auto.
  assert ((F2R (Float radix2 (Z.pos ex) mx) > 0)%R) by
    ( apply F2R_gt_0_compat; compute; auto ).
(* Goal: and (Rle (IZR Z0) (Rinv (IZR (Zpos (xO xH))))) (Rlt (Rinv (IZR (Zpos (xO xH)))) (IZR (Zpos xH))) *)
  lra.
Qed.

Theorem B2R_inj_pos0:
  forall x y,
  is_finite_pos0 x = true -> is_finite_pos0 y = true ->
  B2R _ _ x = B2R _ _ y ->
  x = y.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. apply B2R_Bsign_inj.
(* Goal: @eq bool (is_finite prec emax x) true *)
(* Goal: @eq bool (is_finite prec emax y) true *)
(* Goal: @eq R (B2R prec emax x) (B2R prec emax y) *)
(* Goal: @eq bool (Bsign prec emax x) (Bsign prec emax y) *)
  destruct x; reflexivity||discriminate.
(* Goal: @eq bool (is_finite prec emax y) true *)
(* Goal: @eq R (B2R prec emax x) (B2R prec emax y) *)
(* Goal: @eq bool (Bsign prec emax x) (Bsign prec emax y) *)
  destruct y; reflexivity||discriminate.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite ! Bsign_pos0 by auto. rewrite H1; auto.
Qed.

(** ** Decidable equality *)

Definition Beq_dec: forall (f1 f2: binary_float), {f1 = f2} + {f1 <> f2}.
Proof.
(* Goal: forall f1 f2 : binary_float, sumbool (@eq binary_float f1 f2) (not (@eq binary_float f1 f2)) *)
  assert (UIP_bool: forall (b1 b2: bool) (e e': b1 = b2), e = e').
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  { intros. apply UIP_dec. decide equality. }
(* Goal: forall f1 f2 : binary_float, sumbool (@eq binary_float f1 f2) (not (@eq binary_float f1 f2)) *)
  Ltac try_not_eq := try solve [right; congruence].
  destruct f1 as [| |? []|], f2 as [| |? []|];
  try destruct b; try destruct b0;
  try solve [left; auto]; try_not_eq.
  destruct (Pos.eq_dec x x0); try_not_eq;
    subst; left; f_equal; f_equal; apply UIP_bool.
  destruct (Pos.eq_dec x x0); try_not_eq;
    subst; left; f_equal; f_equal; apply UIP_bool.
  destruct (Pos.eq_dec m m0); try_not_eq;
  destruct (Z.eq_dec e e1); try solve [right; intro H; inversion H; congruence];
  subst; left; f_equal; apply UIP_bool.
  destruct (Pos.eq_dec m m0); try_not_eq;
  destruct (Z.eq_dec e e1); try solve [right; intro H; inversion H; congruence];
  subst; left; f_equal; apply UIP_bool.
Defined.

(** ** Conversion from an integer to a FP number *)

(** Integers that can be represented exactly as FP numbers. *)

Definition integer_representable (n: Z): Prop :=
  Z.abs n <= 2^emax - 2^(emax - prec) /\ generic_format radix2 fexp (Z2R n).

Let int_upper_bound_eq: 2^emax - 2^(emax - prec) = (2^prec - 1) * 2^(emax - prec).
Proof.
(* Goal: @eq Z (Zpos (digits2_pos Bexact_inverse_mantissa)) prec *)
  red in prec_gt_0_.
  ring_simplify. rewrite <- (Zpower_plus radix2) by omega. f_equal. f_equal. omega.
Qed.

Lemma integer_representable_n2p:
  forall n p,
  -2^prec < n < 2^prec -> 0 <= p -> p <= emax - prec ->
  integer_representable (n * 2^p).
Proof.
(* Goal: forall _ : and (Z.le emin e) (Z.le e (Z.sub emax prec)), and (@eq Z (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec (Z.add prec e)) e) (Z.le e (Z.sub emax prec)) *)
  intros; split.
- red in prec_gt_0_. replace (Z.abs (n * 2^p)) with (Z.abs n * 2^p).
(* Goal: Z.divide (Z.pow (Zpos (xO xH)) p) (Z.sub (Z.pow (Zpos (xO xH)) emax) (Z.pow (Zpos (xO xH)) (Z.sub emax prec))) *)
  rewrite int_upper_bound_eq.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  apply Zmult_le_compat. zify; omega. apply (Zpower_le radix2); omega.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  zify; omega. apply (Zpower_ge_0 radix2).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite Z.abs_mul. f_equal. rewrite Z.abs_eq. auto. apply (Zpower_ge_0 radix2).
- apply generic_format_FLT. exists (Float radix2 n p).
(* Goal: @eq R (Z2R n) (@F2R radix2 (Float radix2 n Z0)) *)
  unfold F2R; simpl.
  split. rewrite <- Z2R_Zpower by auto. apply Z2R_mult.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  split. zify; omega.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  unfold emin; red in prec_gt_0_; omega.
Qed.

Lemma integer_representable_2p:
  forall p,
  0 <= p <= emax - 1 ->
  integer_representable (2^p).
Proof.
(* Goal: forall _ : and (Z.le emin e) (Z.le e (Z.sub emax prec)), and (@eq Z (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec (Z.add prec e)) e) (Z.le e (Z.sub emax prec)) *)
  intros; split.
- red in prec_gt_0_.
(* Goal: Z.le (Z.abs (Z.pow (Zpos (xO xH)) p)) (Z.sub (Z.pow (Zpos (xO xH)) emax) (Z.pow (Zpos (xO xH)) (Z.sub emax prec))) *)
  rewrite Z.abs_eq by (apply (Zpower_ge_0 radix2)).
  apply Z.le_trans with (2^(emax-1)).
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  apply (Zpower_le radix2); omega.
  assert (2^emax = 2^(emax-1)*2).
  { change 2 with (2^1) at 3. rewrite <- (Zpower_plus radix2) by omega.
    f_equal. omega. }
  assert (2^(emax - prec) <= 2^(emax - 1)).
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  { apply (Zpower_le radix2). omega. }
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  omega.
- red in prec_gt_0_.
(* Goal: generic_format radix2 fexp (Z2R (Z.sub (Z.pow (Zpos (xO xH)) emax) (Z.pow (Zpos (xO xH)) (Z.sub emax prec)))) *)
(* Goal: Rle (Rabs (Z2R n)) (Z2R (Z.sub (Z.pow (Zpos (xO xH)) emax) (Z.pow (Zpos (xO xH)) (Z.sub emax prec)))) *)
(* Goal: Rlt (Z2R (Z.sub (Z.pow (Zpos (xO xH)) emax) (Z.pow (Zpos (xO xH)) (Z.sub emax prec)))) (bpow radix2 emax) *)
(* Goal: Valid_exp fexp *)
  apply generic_format_FLT. exists (Float radix2 1 p).
(* Goal: @eq R (Z2R n) (@F2R radix2 (Float radix2 n Z0)) *)
  unfold F2R; simpl.
  split. rewrite Rmult_1_l. rewrite <- Z2R_Zpower. auto. omega.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  split. change 1 with (2^0). apply (Zpower_lt radix2). omega. auto.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  unfold emin; omega.
Qed.

Lemma integer_representable_opp:
  forall n, integer_representable n -> integer_representable (-n).
Proof.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  intros n (A & B); split. rewrite Z.abs_opp. auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite Z2R_opp. apply generic_format_opp; auto.
Qed.

Lemma integer_representable_n2p_wide:
  forall n p,
  -2^prec <= n <= 2^prec -> 0 <= p -> p < emax - prec ->
  integer_representable (n * 2^p).
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. red in prec_gt_0_.
  destruct (Z.eq_dec n (2^prec)); [idtac | destruct (Z.eq_dec n (-2^prec))].
- rewrite e. rewrite <- (Zpower_plus radix2) by omega.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  apply integer_representable_2p. omega.
- rewrite e. rewrite <- Zopp_mult_distr_l. apply integer_representable_opp.
  rewrite <- (Zpower_plus radix2) by omega.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  apply integer_representable_2p. omega.
- apply integer_representable_n2p; omega.
Qed.

Lemma integer_representable_n:
  forall n, -2^prec <= n <= 2^prec -> integer_representable n.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  red in prec_gt_0_. intros.
(* Goal: integer_representable n *)
  replace n with (n * 2^0) by (change (2^0) with 1; ring).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply integer_representable_n2p_wide. auto. omega. omega.
Qed.

Lemma round_int_no_overflow:
  forall n,
  Z.abs n <= 2^emax - 2^(emax-prec) ->
  (Rabs (round radix2 fexp (round_mode mode_NE) (Z2R n)) < bpow radix2 emax)%R.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. red in prec_gt_0_.
  rewrite <- round_NE_abs.
  apply Rle_lt_trans with (Z2R (2^emax - 2^(emax-prec))).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply round_le_generic. apply fexp_correct; auto. apply valid_rnd_N.
  apply generic_format_FLT. exists (Float radix2 (2^prec-1) (emax-prec)).
(* Goal: Z.divide (Z.pow (Zpos (xO xH)) p) (Z.sub (Z.pow (Zpos (xO xH)) emax) (Z.pow (Zpos (xO xH)) (Z.sub emax prec))) *)
  rewrite int_upper_bound_eq. unfold F2R; simpl.
  split. rewrite <- Z2R_Zpower by omega. rewrite <- Z2R_mult. auto.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  split. assert (0 < 2^prec) by (apply (Zpower_gt_0 radix2); omega). zify; omega.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  unfold emin; omega.
  rewrite <- Z2R_abs. apply Z2R_le. auto.
  rewrite <- Z2R_Zpower by omega. apply Z2R_lt. simpl.
  assert (0 < 2^(emax-prec)) by (apply (Zpower_gt_0 radix2); omega).
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  omega.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply fexp_correct. auto.
Qed.

(** Conversion from an integer.  Round to nearest. *)

Definition BofZ (n: Z) : binary_float :=
  binary_normalize prec emax prec_gt_0_ Hmax mode_NE n 0 false.

Theorem BofZ_correct:
  forall n,
  if Rlt_bool (Rabs (round radix2 fexp (round_mode mode_NE) (Z2R n))) (bpow radix2 emax)
  then
    B2R prec emax (BofZ n) = round radix2 fexp (round_mode mode_NE) (Z2R n) /\
    is_finite _ _ (BofZ n) = true /\
    Bsign prec emax (BofZ n) = Z.ltb n 0
  else
    B2FF prec emax (BofZ n) = binary_overflow prec emax mode_NE (Z.ltb n 0).
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros.
(* Goal: @eq bool (is_finite_pos0 (BofZ n)) true *)
  generalize (binary_normalize_correct prec emax prec_gt_0_ Hmax mode_NE n 0 false).
(* Goal: forall _ : if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (@F2R radix2 (Float radix2 n Z0)))) (bpow radix2 emax) then and (@eq R (B2R prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode_NE n Z0 false)) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (@F2R radix2 (Float radix2 n Z0)))) (and (@eq bool (is_finite prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode_NE n Z0 false)) true) (@eq bool (Bsign prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode_NE n Z0 false)) match Rcompare (@F2R radix2 (Float radix2 n Z0)) (IZR Z0) with | Eq => false | Lt => true | Gt => false end)) else @eq full_float (B2FF prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode_NE n Z0 false)) (binary_overflow prec emax mode_NE (Rlt_bool (@F2R radix2 (Float radix2 n Z0)) (IZR Z0))), @eq bool (is_finite_pos0 (BofZ n)) true *)
  fold emin; fold fexp; fold (BofZ n).
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  replace (F2R {| Fnum := n; Fexp := 0 |}) with (Z2R n).
(* Goal: forall (_ : if Rlt_bool (Rabs (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (bpow radix2 emax2) then and (@eq R (B2R prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (and (@eq bool (is_finite prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) true) (@eq bool (Bsign prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) match Rcompare (Z2R n) (IZR Z0) with | Eq => false | Lt => true | Gt => false end)) else @eq full_float (B2FF prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) (binary_overflow prec2 emax2 mode_NE (Rlt_bool (Z2R n) (IZR Z0)))) (_ : if Rlt_bool (Rabs (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (bpow radix2 emax2) then and (@eq R (B2R prec2 emax2 (Bconv conv_nan mode_NE f)) (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (and (@eq bool (is_finite prec2 emax2 (Bconv conv_nan mode_NE f)) true) (@eq bool (Bsign prec2 emax2 (Bconv conv_nan mode_NE f)) (Bsign prec1 emax1 f))) else @eq full_float (B2FF prec2 emax2 (Bconv conv_nan mode_NE f)) (binary_overflow prec2 emax2 mode_NE (Bsign prec1 emax1 f))), @eq binary_float2 (Bconv conv_nan mode_NE f) (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false) *)
(* Goal: @eq R (Z2R n) (@F2R radix2 (Float radix2 n Z0)) *)
  destruct Rlt_bool.
- intros (A & B & C). split; [|split].
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  + auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  + auto.
  + rewrite C. change 0%R with (Z2R 0). rewrite Rcompare_Z2R.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    unfold Z.ltb. auto.
- intros A; rewrite A. f_equal. change 0%R with (Z2R 0).
(* Goal: @eq bool (Rlt_bool (Z2R n) (Z2R Z0)) (Z.ltb n Z0) *)
  generalize (Z.ltb_spec n 0); intros SPEC; inversion SPEC.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply Rlt_bool_true; apply Z2R_lt; auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply Rlt_bool_false; apply Z2R_le; auto.
- unfold F2R; simpl. ring.
Qed.

Theorem BofZ_finite:
  forall n,
  Z.abs n <= 2^emax - 2^(emax-prec) ->
  B2R _ _ (BofZ n) = round radix2 fexp (round_mode mode_NE) (Z2R n)
  /\ is_finite _ _ (BofZ n) = true
  /\ Bsign _ _ (BofZ n) = Z.ltb n 0%Z.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  generalize (BofZ_correct n). rewrite Rlt_bool_true. auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply round_int_no_overflow; auto.
Qed.

Theorem BofZ_representable:
  forall n,
  integer_representable n ->
  B2R _ _ (BofZ n) = Z2R n
  /\ is_finite _ _ (BofZ n) = true
  /\ Bsign _ _ (BofZ n) = (n <? 0).
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. destruct H as (P & Q). destruct (BofZ_finite n) as (A & B & C). auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  intuition. rewrite A. apply round_generic. apply valid_rnd_round_mode. auto.
Qed.

Theorem BofZ_exact:
  forall n,
  -2^prec <= n <= 2^prec ->
  B2R _ _ (BofZ n) = Z2R n
  /\ is_finite _ _ (BofZ n) = true
  /\ Bsign _ _ (BofZ n) = Z.ltb n 0%Z.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. apply BofZ_representable. apply integer_representable_n; auto.
Qed.

Lemma BofZ_finite_pos0:
  forall n,
  Z.abs n <= 2^emax - 2^(emax-prec) -> is_finite_pos0 (BofZ n) = true.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros.
(* Goal: @eq bool (is_finite_pos0 (BofZ n)) true *)
  generalize (binary_normalize_correct prec emax prec_gt_0_ Hmax mode_NE n 0 false).
(* Goal: forall _ : if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (@F2R radix2 (Float radix2 n Z0)))) (bpow radix2 emax) then and (@eq R (B2R prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode_NE n Z0 false)) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (@F2R radix2 (Float radix2 n Z0)))) (and (@eq bool (is_finite prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode_NE n Z0 false)) true) (@eq bool (Bsign prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode_NE n Z0 false)) match Rcompare (@F2R radix2 (Float radix2 n Z0)) (IZR Z0) with | Eq => false | Lt => true | Gt => false end)) else @eq full_float (B2FF prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode_NE n Z0 false)) (binary_overflow prec emax mode_NE (Rlt_bool (@F2R radix2 (Float radix2 n Z0)) (IZR Z0))), @eq bool (is_finite_pos0 (BofZ n)) true *)
  fold emin; fold fexp; fold (BofZ n).
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  replace (F2R {| Fnum := n; Fexp := 0 |}) with (Z2R n) by
    (unfold F2R; simpl; ring).
(* Goal: forall _ : if Rlt_bool (Rabs (round radix2 fexp (round_mode mode_NE) (Z2R n))) (bpow radix2 emax) then and (@eq R (B2R prec emax (BofZ n)) (round radix2 fexp (round_mode mode_NE) (Z2R n))) (and (@eq bool (is_finite prec emax (BofZ n)) true) (@eq bool (Bsign prec emax (BofZ n)) match Rcompare (Z2R n) (IZR Z0) with | Eq => false | Lt => true | Gt => false end)) else @eq full_float (B2FF prec emax (BofZ n)) (binary_overflow prec emax mode_NE (Rlt_bool (Z2R n) (IZR Z0))), @eq bool (is_finite_pos0 (BofZ n)) true *)
  rewrite Rlt_bool_true by (apply round_int_no_overflow; auto).
(* Goal: forall _ : and (@eq R (B2R prec2 emax2 f') (B2R prec1 emax1 f)) (and (@eq bool (is_finite prec2 emax2 f') true) (@eq bool (Bsign prec2 emax2 f') (Bsign prec1 emax1 f))), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m f') f *)
  intros (A & B & C).
(* Goal: @eq bool (is_finite_pos0 (BofZ n)) true *)
  destruct (BofZ n); auto; try discriminate.
(* Goal: @eq full_float (binary_overflow prec2 emax2 mode_NE (Bsign prec1 emax1 f)) (binary_overflow prec2 emax2 mode_NE (Rlt_bool (Z2R n) (IZR Z0))) *)
  simpl in *. rewrite C. change 0%R with (Z2R 0). rewrite Rcompare_Z2R.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  generalize (Zcompare_spec n 0); intros SPEC; inversion SPEC; auto.
  assert ((round radix2 fexp ZnearestE (Z2R n) <= -1)%R).
  { change (-1)%R with (Z2R (-1)).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    apply round_le_generic. apply fexp_correct. auto. apply valid_rnd_N.
(* Goal: generic_format radix2 fexp (Z2R (Zneg xH)) *)
(* Goal: Rle (Z2R n) (Z2R (Zneg xH)) *)
    apply (integer_representable_opp 1).
(* Goal: integer_representable (Zpos xH) *)
(* Goal: Rle (Z2R n) (Z2R (Zneg xH)) *)
    apply (integer_representable_2p 0).
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
    red in prec_gt_0_; omega.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
    apply Z2R_le; omega.
  }
(* Goal: and (Rle (IZR Z0) (Rinv (IZR (Zpos (xO xH))))) (Rlt (Rinv (IZR (Zpos (xO xH)))) (IZR (Zpos xH))) *)
  lra.
Qed.

Lemma BofZ_finite_equal:
  forall x y,
  Z.abs x <= 2^emax - 2^(emax-prec) ->
  Z.abs y <= 2^emax - 2^(emax-prec) ->
  B2R _ _ (BofZ x) = B2R _ _ (BofZ y) ->
  BofZ x = BofZ y.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. apply B2R_inj_pos0; auto; apply BofZ_finite_pos0; auto.
Qed.

(** Commutation properties with addition, subtraction, multiplication. *)

Theorem BofZ_plus:
  forall nan p q,
  integer_representable p -> integer_representable q ->
  Bplus _ _ _ Hmax nan mode_NE (BofZ p) (BofZ q) = BofZ (p + q).
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  destruct (BofZ_representable p) as (A & B & C); auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  destruct (BofZ_representable q) as (D & E & F); auto.
(* Goal: @eq (Fappli_IEEE.binary_float prec emax) (Bplus prec emax prec_gt_0_ Hmax nan mode_NE (BofZ p) (BofZ q)) (BofZ (Z.add p q)) *)
  generalize (Bplus_correct _ _ _ Hmax nan mode_NE (BofZ p) (BofZ q) B E).
(* Goal: forall a : let x := @F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0) in let y := @F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0) in let z := f in and (@eq bool (valid_binary prec emax z) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv x y))) (bpow radix2 emax) then and (@eq R (FF2R radix2 z) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv x y))) (and (@eq bool (is_finite_FF z) true) (@eq bool (sign_FF z) (xorb false false))) else @eq full_float z (binary_overflow prec emax mode_NE (xorb false false))), if Rlt_bool (Rabs (round radix2 fexp (round_mode mode_NE) (Rmult (Z2R (Zpos m)) (bpow base (Zneg e))))) (bpow radix2 emax) then and (@eq R (B2R prec emax (FF2B prec emax f (@proj1 (@eq bool (valid_binary prec emax f) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 f) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF f) true) (@eq bool (sign_FF f) (xorb false false))) else @eq full_float f (binary_overflow prec emax mode_NE (xorb false false))) a))) (round radix2 fexp (round_mode mode_NE) (Rmult (Z2R (Zpos m)) (bpow base (Zneg e))))) (and (@eq bool (is_finite prec emax (FF2B prec emax f (@proj1 (@eq bool (valid_binary prec emax f) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 f) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF f) true) (@eq bool (sign_FF f) (xorb false false))) else @eq full_float f (binary_overflow prec emax mode_NE (xorb false false))) a))) true) (@eq bool (Bsign prec emax (FF2B prec emax f (@proj1 (@eq bool (valid_binary prec emax f) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 f) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF f) true) (@eq bool (sign_FF f) (xorb false false))) else @eq full_float f (binary_overflow prec emax mode_NE (xorb false false))) a))) false)) else @eq full_float (B2FF prec emax (FF2B prec emax f (@proj1 (@eq bool (valid_binary prec emax f) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 f) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF f) true) (@eq bool (sign_FF f) (xorb false false))) else @eq full_float f (binary_overflow prec emax mode_NE (xorb false false))) a))) (F754_infinity false) *)
  fold emin; fold fexp.
  rewrite A, D. rewrite <- Z2R_plus.
(* Goal: forall (_ : if Rlt_bool (Rabs (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (bpow radix2 emax2) then and (@eq R (B2R prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (and (@eq bool (is_finite prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) true) (@eq bool (Bsign prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) match Rcompare (Z2R n) (IZR Z0) with | Eq => false | Lt => true | Gt => false end)) else @eq full_float (B2FF prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) (binary_overflow prec2 emax2 mode_NE (Rlt_bool (Z2R n) (IZR Z0)))) (_ : if Rlt_bool (Rabs (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (bpow radix2 emax2) then and (@eq R (B2R prec2 emax2 (Bconv conv_nan mode_NE f)) (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (and (@eq bool (is_finite prec2 emax2 (Bconv conv_nan mode_NE f)) true) (@eq bool (Bsign prec2 emax2 (Bconv conv_nan mode_NE f)) (Bsign prec1 emax1 f))) else @eq full_float (B2FF prec2 emax2 (Bconv conv_nan mode_NE f)) (binary_overflow prec2 emax2 mode_NE (Bsign prec1 emax1 f))), @eq binary_float2 (Bconv conv_nan mode_NE f) (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false) *)
(* Goal: @eq R (Z2R n) (@F2R radix2 (Float radix2 n Z0)) *)
  generalize (BofZ_correct (p + q)). destruct Rlt_bool.
- intros (P & Q & R) (U & V & W).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply B2R_Bsign_inj; auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite P, U; auto.
(* Goal: @eq bool (Bsign prec emax (Bminus prec emax prec_gt_0_ Hmax nan mode_NE (BofZ p) (BofZ q))) (Bsign prec emax (BofZ (Z.sub p q))) *)
  rewrite R, W, C, F.
(* Goal: @eq bool (Z.ltb n Z0) (Rlt_bool (Z2R n) (IZR Z0)) *)
  change 0%R with (Z2R 0). rewrite Rcompare_Z2R. unfold Z.ltb at 3.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  generalize (Zcompare_spec (p + q) 0); intros SPEC; inversion SPEC; auto.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  assert (EITHER: 0 <= p \/ 0 <= q) by omega.
  destruct EITHER; [apply andb_false_intro1 | apply andb_false_intro2];
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply Zlt_bool_false; auto.
- intros P (U & V).
(* Goal: @eq binary_float2 (Bconv conv_nan mode_NE f) (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false) *)
  apply B2FF_inj.
(* Goal: @eq full_float (binary_overflow prec2 emax2 mode_NE (Z.ltb n Z0)) (binary_overflow prec2 emax2 mode_NE (Rlt_bool (Z2R n) (IZR Z0))) *)
  rewrite P, U, C. f_equal. rewrite C, F in V.
  generalize (Zlt_bool_spec p 0) (Zlt_bool_spec q 0). rewrite <- V.
(* Goal: forall (_ : Zlt_bool_prop p Z0 (Z.ltb p Z0)) (_ : Zlt_bool_prop q Z0 (Z.ltb p Z0)), @eq bool (Z.ltb p Z0) (Z.ltb (Z.add p q) Z0) *)
  intros SPEC1 SPEC2; inversion SPEC1; inversion SPEC2; try congruence; symmetry.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  apply Zlt_bool_true; omega.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  apply Zlt_bool_false; omega.
Qed.

Theorem BofZ_minus:
  forall nan p q,
  integer_representable p -> integer_representable q ->
  Bminus _ _ _ Hmax nan mode_NE (BofZ p) (BofZ q) = BofZ (p - q).
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  destruct (BofZ_representable p) as (A & B & C); auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  destruct (BofZ_representable q) as (D & E & F); auto.
(* Goal: @eq (Fappli_IEEE.binary_float prec emax) (Bminus prec emax prec_gt_0_ Hmax nan mode_NE (BofZ p) (BofZ q)) (BofZ (Z.sub p q)) *)
  generalize (Bminus_correct _ _ _ Hmax nan mode_NE (BofZ p) (BofZ q) B E).
(* Goal: forall a : let x := @F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0) in let y := @F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0) in let z := f in and (@eq bool (valid_binary prec emax z) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv x y))) (bpow radix2 emax) then and (@eq R (FF2R radix2 z) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv x y))) (and (@eq bool (is_finite_FF z) true) (@eq bool (sign_FF z) (xorb false false))) else @eq full_float z (binary_overflow prec emax mode_NE (xorb false false))), if Rlt_bool (Rabs (round radix2 fexp (round_mode mode_NE) (Rmult (Z2R (Zpos m)) (bpow base (Zneg e))))) (bpow radix2 emax) then and (@eq R (B2R prec emax (FF2B prec emax f (@proj1 (@eq bool (valid_binary prec emax f) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 f) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF f) true) (@eq bool (sign_FF f) (xorb false false))) else @eq full_float f (binary_overflow prec emax mode_NE (xorb false false))) a))) (round radix2 fexp (round_mode mode_NE) (Rmult (Z2R (Zpos m)) (bpow base (Zneg e))))) (and (@eq bool (is_finite prec emax (FF2B prec emax f (@proj1 (@eq bool (valid_binary prec emax f) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 f) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF f) true) (@eq bool (sign_FF f) (xorb false false))) else @eq full_float f (binary_overflow prec emax mode_NE (xorb false false))) a))) true) (@eq bool (Bsign prec emax (FF2B prec emax f (@proj1 (@eq bool (valid_binary prec emax f) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 f) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF f) true) (@eq bool (sign_FF f) (xorb false false))) else @eq full_float f (binary_overflow prec emax mode_NE (xorb false false))) a))) false)) else @eq full_float (B2FF prec emax (FF2B prec emax f (@proj1 (@eq bool (valid_binary prec emax f) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 f) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF f) true) (@eq bool (sign_FF f) (xorb false false))) else @eq full_float f (binary_overflow prec emax mode_NE (xorb false false))) a))) (F754_infinity false) *)
  fold emin; fold fexp.
  rewrite A, D. rewrite <- Z2R_minus.
  generalize (BofZ_correct (p - q)). destruct Rlt_bool.
- intros (P & Q & R) (U & V & W).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply B2R_Bsign_inj; auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite P, U; auto.
(* Goal: @eq bool (Bsign prec emax (Bminus prec emax prec_gt_0_ Hmax nan mode_NE (BofZ p) (BofZ q))) (Bsign prec emax (BofZ (Z.sub p q))) *)
  rewrite R, W, C, F.
(* Goal: @eq bool (Z.ltb n Z0) (Rlt_bool (Z2R n) (IZR Z0)) *)
  change 0%R with (Z2R 0). rewrite Rcompare_Z2R. unfold Z.ltb at 3.
  generalize (Zcompare_spec (p - q) 0); intros SPEC; inversion SPEC; auto.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  assert (EITHER: 0 <= p \/ q < 0) by omega.
(* Goal: @eq bool (andb (Z.ltb p Z0) (negb (Z.ltb q Z0))) false *)
  destruct EITHER; [apply andb_false_intro1 | apply andb_false_intro2].
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite Zlt_bool_false; auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite Zlt_bool_true; auto.
- intros P (U & V).
(* Goal: @eq binary_float2 (Bconv conv_nan mode_NE f) (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false) *)
  apply B2FF_inj.
(* Goal: @eq full_float (binary_overflow prec2 emax2 mode_NE (Z.ltb n Z0)) (binary_overflow prec2 emax2 mode_NE (Rlt_bool (Z2R n) (IZR Z0))) *)
  rewrite P, U, C. f_equal. rewrite C, F in V.
(* Goal: @eq bool (Z.ltb p Z0) (Z.ltb (Z.sub p q) Z0) *)
  generalize (Zlt_bool_spec p 0) (Zlt_bool_spec q 0). rewrite V.
(* Goal: forall (_ : Zlt_bool_prop p Z0 (negb (Z.ltb q Z0))) (_ : Zlt_bool_prop q Z0 (Z.ltb q Z0)), @eq bool (negb (Z.ltb q Z0)) (Z.ltb (Z.sub p q) Z0) *)
  intros SPEC1 SPEC2; inversion SPEC1; inversion SPEC2; symmetry.
  rewrite <- H3 in H1; discriminate.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  apply Zlt_bool_true; omega.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  apply Zlt_bool_false; omega.
  rewrite <- H3 in H1; discriminate.
Qed.

Theorem BofZ_mult:
  forall nan p q,
  integer_representable p -> integer_representable q ->
  0 < q ->
  Bmult _ _ _ Hmax nan mode_NE (BofZ p) (BofZ q) = BofZ (p * q).
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros.
(* Goal: @eq (Fappli_IEEE.binary_float prec emax) (Bmult prec emax prec_gt_0_ Hmax nan mode_NE (BofZ p) (BofZ q)) (BofZ (Z.mul p q)) *)
  assert (SIGN: xorb (p <? 0) (q <? 0) = (p * q <? 0)).
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  {
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
    rewrite (Zlt_bool_false q) by omega.
(* Goal: @eq bool (xorb (Z.ltb p Z0) false) (Z.ltb (Z.mul p q) Z0) *)
    generalize (Zlt_bool_spec p 0); intros SPEC; inversion SPEC; simpl; symmetry.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
    apply Zlt_bool_true. rewrite Z.mul_comm. apply Z.mul_pos_neg; omega.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
    apply Zlt_bool_false. apply Zsame_sign_imp; omega.
  }
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  destruct (BofZ_representable p) as (A & B & C); auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  destruct (BofZ_representable q) as (D & E & F); auto.
(* Goal: @eq (Fappli_IEEE.binary_float prec emax) (Bmult prec emax prec_gt_0_ Hmax nan mode_NE (BofZ p) (BofZ q)) (BofZ (Z.mul p q)) *)
  generalize (Bmult_correct _ _ _ Hmax nan mode_NE (BofZ p) (BofZ q)).
(* Goal: forall a : let x := @F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0) in let y := @F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0) in let z := f in and (@eq bool (valid_binary prec emax z) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv x y))) (bpow radix2 emax) then and (@eq R (FF2R radix2 z) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv x y))) (and (@eq bool (is_finite_FF z) true) (@eq bool (sign_FF z) (xorb false false))) else @eq full_float z (binary_overflow prec emax mode_NE (xorb false false))), if Rlt_bool (Rabs (round radix2 fexp (round_mode mode_NE) (Rmult (Z2R (Zpos m)) (bpow base (Zneg e))))) (bpow radix2 emax) then and (@eq R (B2R prec emax (FF2B prec emax f (@proj1 (@eq bool (valid_binary prec emax f) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 f) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF f) true) (@eq bool (sign_FF f) (xorb false false))) else @eq full_float f (binary_overflow prec emax mode_NE (xorb false false))) a))) (round radix2 fexp (round_mode mode_NE) (Rmult (Z2R (Zpos m)) (bpow base (Zneg e))))) (and (@eq bool (is_finite prec emax (FF2B prec emax f (@proj1 (@eq bool (valid_binary prec emax f) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 f) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF f) true) (@eq bool (sign_FF f) (xorb false false))) else @eq full_float f (binary_overflow prec emax mode_NE (xorb false false))) a))) true) (@eq bool (Bsign prec emax (FF2B prec emax f (@proj1 (@eq bool (valid_binary prec emax f) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 f) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF f) true) (@eq bool (sign_FF f) (xorb false false))) else @eq full_float f (binary_overflow prec emax mode_NE (xorb false false))) a))) false)) else @eq full_float (B2FF prec emax (FF2B prec emax f (@proj1 (@eq bool (valid_binary prec emax f) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 f) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF f) true) (@eq bool (sign_FF f) (xorb false false))) else @eq full_float f (binary_overflow prec emax mode_NE (xorb false false))) a))) (F754_infinity false) *)
  fold emin; fold fexp.
  rewrite A, B, C, D, E, F. rewrite <- Z2R_mult.
(* Goal: forall (_ : if Rlt_bool (Rabs (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (bpow radix2 emax2) then and (@eq R (B2R prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (and (@eq bool (is_finite prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) true) (@eq bool (Bsign prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) match Rcompare (Z2R n) (IZR Z0) with | Eq => false | Lt => true | Gt => false end)) else @eq full_float (B2FF prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) (binary_overflow prec2 emax2 mode_NE (Rlt_bool (Z2R n) (IZR Z0)))) (_ : if Rlt_bool (Rabs (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (bpow radix2 emax2) then and (@eq R (B2R prec2 emax2 (Bconv conv_nan mode_NE f)) (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (and (@eq bool (is_finite prec2 emax2 (Bconv conv_nan mode_NE f)) true) (@eq bool (Bsign prec2 emax2 (Bconv conv_nan mode_NE f)) (Bsign prec1 emax1 f))) else @eq full_float (B2FF prec2 emax2 (Bconv conv_nan mode_NE f)) (binary_overflow prec2 emax2 mode_NE (Bsign prec1 emax1 f))), @eq binary_float2 (Bconv conv_nan mode_NE f) (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false) *)
(* Goal: @eq R (Z2R n) (@F2R radix2 (Float radix2 n Z0)) *)
  generalize (BofZ_correct (p * q)). destruct Rlt_bool.
- intros (P & Q & R) (U & V & W).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply B2R_Bsign_inj; auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite P, U; auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite R, W; auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply is_finite_not_is_nan; auto.
- intros P U.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply B2FF_inj. rewrite P, U. f_equal. auto.
Qed.

Theorem BofZ_mult_2p:
  forall nan x p,
  Z.abs x <= 2^emax - 2^(emax-prec) ->
  2^prec <= Z.abs x ->
  0 <= p <= emax - 1 ->
  Bmult _ _ _ Hmax nan mode_NE (BofZ x) (BofZ (2^p)) = BofZ (x * 2^p).
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros.
(* Goal: @eq (Fappli_IEEE.binary_float prec emax) (Bmult prec emax prec_gt_0_ Hmax nan mode_NE (BofZ x) (BofZ (Z.pow (Zpos (xO xH)) p))) (BofZ (Z.mul x (Z.pow (Zpos (xO xH)) p))) *)
  destruct (Z.eq_dec x 0).
- subst x. apply BofZ_mult.
(* Goal: generic_format radix2 fexp (Z2R q) *)
(* Goal: and (Rle (Z2R q) (B2R prec emax f)) (Rle (B2R prec emax f) (Rmult (IZR (Zpos (xO xH))) (Z2R q))) *)
    apply integer_representable_n.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
    generalize (Zpower_ge_0 radix2 prec). simpl; omega.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    apply integer_representable_2p. auto.
(* Goal: Z.lt Z0 (Z.pow (Zpos (xO xH)) p) *)
(* Goal: @eq Z (Z.modulo x (Z.pow (Zpos (xO xH)) p)) Z0 *)
    apply (Zpower_gt_0 radix2).
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
    omega.
- assert (Z2R x <> 0%R) by (apply (Z2R_neq _ _ n)).
(* Goal: @eq (Fappli_IEEE.binary_float prec emax) (Bmult prec emax prec_gt_0_ Hmax nan mode_NE (BofZ x) (BofZ (Z.pow (Zpos (xO xH)) p))) (BofZ (Z.mul x (Z.pow (Zpos (xO xH)) p))) *)
  destruct (BofZ_finite x H) as (A & B & C).
(* Goal: @eq (Fappli_IEEE.binary_float prec emax) (Bmult prec emax prec_gt_0_ Hmax nan mode_NE (BofZ x) (BofZ (Z.pow (Zpos (xO xH)) p))) (BofZ (Z.mul x (Z.pow (Zpos (xO xH)) p))) *)
  destruct (BofZ_representable (2^p)) as (D & E & F).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    apply integer_representable_2p. auto.
  assert (canonic_exp radix2 fexp (Z2R (x * 2^p)) =
          canonic_exp radix2 fexp (Z2R x) + p).
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  {
(* Goal: @eq Z (canonic_exp radix2 fexp (Z2R (Z.mul x (Z.pow (Zpos (xO xH)) p)))) (Z.add (canonic_exp radix2 fexp (Z2R x)) p) *)
    unfold canonic_exp, fexp. rewrite Z2R_mult.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
    change (2^p) with (radix2^p). rewrite Z2R_Zpower by omega.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    rewrite ln_beta_mult_bpow by auto.
    assert (prec + 1 <= ln_beta radix2 (Z2R x)).
    { rewrite <- (ln_beta_abs radix2 (Z2R x)).
      rewrite <- (ln_beta_bpow radix2 prec).
(* Goal: Z.le (ln_beta_val radix2 (bpow radix2 prec) (ln_beta radix2 (bpow radix2 prec))) (ln_beta_val radix2 (Rabs (Z2R x)) (ln_beta radix2 (Rabs (Z2R x)))) *)
      apply ln_beta_le.
      apply bpow_gt_0. rewrite <- Z2R_Zpower by (red in prec_gt_0_;omega).
      rewrite <- Z2R_abs. apply Z2R_le; auto. }
(* Goal: @eq Z (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec (Z.add prec e)) e *)
(* Goal: Z.le e (Z.sub emax prec) *)
    unfold FLT_exp.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
    unfold emin; red in prec_gt_0_; zify; omega.
  }
  assert (forall m, round radix2 fexp m (Z2R x) * Z2R (2^p) =
                    round radix2 fexp m (Z2R (x * 2^p)))%R.
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  {
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
    intros. unfold round, scaled_mantissa. rewrite H3.
(* Goal: @eq R (Z2R (Z.mul (Zrnd_odd (Rmult (Z2R x) (bpow radix2 (Z.opp p)))) (Z.pow (Zpos (xO xH)) p))) (Rmult (Z2R (Zrnd_odd (Rmult (Z2R x) (bpow radix2 (Z.opp p))))) (bpow radix2 p)) *)
    rewrite Z2R_mult. rewrite Z.opp_add_distr. rewrite bpow_plus.
    set (a := Z2R x); set (b := bpow radix2 (- canonic_exp radix2 fexp a)).
    replace (a * Z2R (2^p) * (b * bpow radix2 (-p)))%R with (a * b)%R.
(* Goal: @eq full_float (binary_overflow prec2 emax2 mode_NE (Z.ltb n Z0)) (binary_overflow prec2 emax2 mode_NE (Rlt_bool (Z2R n) (IZR Z0))) *)
    unfold F2R; simpl. rewrite Rmult_assoc. f_equal.
(* Goal: @eq full_float (binary_overflow prec2 emax2 mode_NE (Z.ltb n Z0)) (binary_overflow prec2 emax2 mode_NE (Rlt_bool (Z2R n) (IZR Z0))) *)
    rewrite bpow_plus.  f_equal. apply (Z2R_Zpower radix2). omega.
    transitivity ((a * b) * (Z2R (2^p) * bpow radix2 (-p)))%R.
    rewrite (Z2R_Zpower radix2). rewrite <- bpow_plus.
    replace (p + -p) with 0 by omega. change (bpow radix2 0) with 1%R. ring.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
    omega.
(* Goal: @eq R (Rmult (Z2R x) (IZR (Zpos xH))) (Z2R x) *)
    ring.
  }
  assert (forall m x,
    round radix2 fexp (round_mode m) (round radix2 fexp (round_mode m) x) =
    round radix2 fexp (round_mode m) x).
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  {
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
    intros. apply round_generic. apply valid_rnd_round_mode.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    apply generic_format_round.  apply fexp_correct; auto.
(* Goal: Valid_rnd (round_mode m) *)
(* Goal: generic_format radix2 fexp1 (B2R prec1 emax1 f) *)
    apply valid_rnd_round_mode.
  }
(* Goal: @eq (Fappli_IEEE.binary_float prec emax) (Bmult prec emax prec_gt_0_ Hmax nan mode_NE (BofZ x) (BofZ (Z.pow (Zpos (xO xH)) p))) (BofZ (Z.mul x (Z.pow (Zpos (xO xH)) p))) *)
  assert (xorb (x <? 0) (2^p <? 0) = (x * 2^p <? 0)).
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  {
(* Goal: @eq Z (Z.mul (Zrnd_odd (Rmult (Z2R n) (bpow radix2 (Z.opp p)))) (Z.pow (Zpos (xO xH)) p)) (int_round_odd n p) *)
    assert (0 < 2^p) by (apply (Zpower_gt_0 radix2); omega).
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
    rewrite (Zlt_bool_false (2^p)) by omega. rewrite xorb_false_r.
(* Goal: @eq Z (Z.div (Zpos m) (Z.pow_pos (Zpos (xO xH)) p)) (Zfloor (Rmult (Z2R (Zpos m)) (Rinv (Z2R (Z.pow_pos (Zpos (xO xH)) p))))) *)
(* Goal: Rle (IZR Z0) (Rmult (Z2R (Zpos m)) (Rinv (Z2R (Z.pow_pos (Zpos (xO xH)) p)))) *)
    symmetry. generalize (Zlt_bool_spec x 0); intros SPEC; inversion SPEC.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    apply Zlt_bool_true. apply Z.mul_neg_pos; auto.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
    apply Zlt_bool_false. apply Z.mul_nonneg_nonneg; omega.
  }
  generalize (Bmult_correct _ _ _ Hmax nan mode_NE (BofZ x) (BofZ (2^p)))
             (BofZ_correct (x * 2^p)).
(* Goal: forall a : let x := @F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0) in let y := @F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0) in let z := f in and (@eq bool (valid_binary prec emax z) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv x y))) (bpow radix2 emax) then and (@eq R (FF2R radix2 z) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv x y))) (and (@eq bool (is_finite_FF z) true) (@eq bool (sign_FF z) (xorb false false))) else @eq full_float z (binary_overflow prec emax mode_NE (xorb false false))), if Rlt_bool (Rabs (round radix2 fexp (round_mode mode_NE) (Rmult (Z2R (Zpos m)) (bpow base (Zneg e))))) (bpow radix2 emax) then and (@eq R (B2R prec emax (FF2B prec emax f (@proj1 (@eq bool (valid_binary prec emax f) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 f) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF f) true) (@eq bool (sign_FF f) (xorb false false))) else @eq full_float f (binary_overflow prec emax mode_NE (xorb false false))) a))) (round radix2 fexp (round_mode mode_NE) (Rmult (Z2R (Zpos m)) (bpow base (Zneg e))))) (and (@eq bool (is_finite prec emax (FF2B prec emax f (@proj1 (@eq bool (valid_binary prec emax f) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 f) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF f) true) (@eq bool (sign_FF f) (xorb false false))) else @eq full_float f (binary_overflow prec emax mode_NE (xorb false false))) a))) true) (@eq bool (Bsign prec emax (FF2B prec emax f (@proj1 (@eq bool (valid_binary prec emax f) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 f) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF f) true) (@eq bool (sign_FF f) (xorb false false))) else @eq full_float f (binary_overflow prec emax mode_NE (xorb false false))) a))) false)) else @eq full_float (B2FF prec emax (FF2B prec emax f (@proj1 (@eq bool (valid_binary prec emax f) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 f) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF f) true) (@eq bool (sign_FF f) (xorb false false))) else @eq full_float f (binary_overflow prec emax mode_NE (xorb false false))) a))) (F754_infinity false) *)
  fold emin; fold fexp. rewrite A, B, C, D, E, F, H4, H5.
(* Goal: forall (_ : if Rlt_bool (Rabs (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (bpow radix2 emax2) then and (@eq R (B2R prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (and (@eq bool (is_finite prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) true) (@eq bool (Bsign prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) match Rcompare (Z2R n) (IZR Z0) with | Eq => false | Lt => true | Gt => false end)) else @eq full_float (B2FF prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) (binary_overflow prec2 emax2 mode_NE (Rlt_bool (Z2R n) (IZR Z0)))) (_ : if Rlt_bool (Rabs (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (bpow radix2 emax2) then and (@eq R (B2R prec2 emax2 (Bconv conv_nan mode_NE f)) (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (and (@eq bool (is_finite prec2 emax2 (Bconv conv_nan mode_NE f)) true) (@eq bool (Bsign prec2 emax2 (Bconv conv_nan mode_NE f)) (Bsign prec1 emax1 f))) else @eq full_float (B2FF prec2 emax2 (Bconv conv_nan mode_NE f)) (binary_overflow prec2 emax2 mode_NE (Bsign prec1 emax1 f))), @eq binary_float2 (Bconv conv_nan mode_NE f) (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false) *)
(* Goal: @eq R (Z2R n) (@F2R radix2 (Float radix2 n Z0)) *)
  destruct Rlt_bool.
+ intros (P & Q & R) (U & V & W).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply B2R_Bsign_inj; auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite P, U. auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite R, W. auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply is_finite_not_is_nan; auto.
+ intros P U.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply B2FF_inj. rewrite P, U. f_equal; auto.
Qed.

(** Rounding to odd the argument of [BofZ]. *)

Lemma round_odd_flt:
  forall prec' emin' x choice,
  prec > 1 -> prec' > 1 -> prec' >= prec + 2 -> emin' <= emin - 2 ->
  round radix2 fexp (Znearest choice) (round radix2 (FLT_exp emin' prec') Zrnd_odd x) =
  round radix2 fexp (Znearest choice) x.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. apply round_odd_prop. auto. apply fexp_correct; auto.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  apply exists_NE_FLT. right; omega.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  apply FLT_exp_valid. red; omega.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  apply exists_NE_FLT. right; omega.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  unfold fexp, FLT_exp; intros. zify; omega.
Qed.

Corollary round_odd_fix:
  forall x p choice,
  prec > 1 ->
  0 <= p ->
  (bpow radix2 (prec + p + 1) <= Rabs x)%R ->
  round radix2 fexp (Znearest choice) (round radix2 (FIX_exp p) Zrnd_odd x) =
  round radix2 fexp (Znearest choice) x.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. destruct (Req_EM_T x 0%R).
- subst x. rewrite round_0. auto. apply valid_rnd_odd.
- set (prec' := ln_beta radix2 x - p).
  set (emin' := emin - 2).
  assert (PREC: ln_beta radix2 (bpow radix2 (prec + p + 1)) <= ln_beta radix2 x).
  { rewrite <- (ln_beta_abs radix2 x).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    apply ln_beta_le; auto. apply bpow_gt_0. }
(* Goal: @eq R (round radix2 fexp (Znearest choice) (round radix2 (FIX_exp p) Zrnd_odd x)) (round radix2 fexp (Znearest choice) x) *)
  rewrite ln_beta_bpow in PREC.
  assert (CANON: canonic_exp radix2 (FLT_exp emin' prec') x =
                 canonic_exp radix2 (FIX_exp p) x).
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  {
(* Goal: @eq Z (canonic_exp radix2 (FLT_exp emin' prec') x) (canonic_exp radix2 (FIX_exp p) x) *)
    unfold canonic_exp, FLT_exp, FIX_exp.
    replace (ln_beta radix2 x - prec') with p by (unfold prec'; omega).
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
    apply Z.max_l. unfold emin', emin. red in prec_gt_0_; omega.
  }
  assert (RND: round radix2 (FIX_exp p) Zrnd_odd x =
               round radix2 (FLT_exp emin' prec') Zrnd_odd x).
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  {
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    unfold round, scaled_mantissa. rewrite CANON. auto.
  }
(* Goal: @eq R (round radix2 fexp (Znearest choice) (round radix2 (FIX_exp p) Zrnd_odd x)) (round radix2 fexp (Znearest choice) x) *)
  rewrite RND.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply round_odd_flt. auto.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  unfold prec'. red in prec_gt_0_; omega.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  unfold prec'. omega.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  unfold emin'. omega.
Qed.

Definition int_round_odd (x: Z) (p: Z) :=
  (if Z.eqb (x mod 2^p) 0 || Z.odd (x / 2^p) then x / 2^p else x / 2^p + 1) * 2^p.

Lemma Zrnd_odd_int:
  forall n p, 0 <= p ->
  Zrnd_odd (Z2R n * bpow radix2 (-p)) * 2^p =
  int_round_odd n p.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros.
(* Goal: @eq Z (Z.mul (Zrnd_odd (Rmult (Z2R n) (bpow radix2 (Z.opp p)))) (Z.pow (Zpos (xO xH)) p)) (int_round_odd n p) *)
  assert (0 < 2^p) by (apply (Zpower_gt_0 radix2); omega).
  assert (n = (n / 2^p) * 2^p + n mod 2^p) by (rewrite Z.mul_comm; apply Z.div_mod; omega).
(* Goal: @eq Z (Z.mul (Zrnd_odd (Rmult (Z2R n) (bpow radix2 (Z.opp p)))) (Z.pow (Zpos (xO xH)) p)) (int_round_odd n p) *)
  assert (0 <= n mod 2^p < 2^p) by (apply Z_mod_lt; omega).
(* Goal: @eq Z (int_round_odd x p) (Z.shiftl (if Z.eqb (Z.modulo x (Z.pow (Zpos (xO xH)) p)) Z0 then Z.shiftr x p else Z.lor (Z.shiftr x p) (Zpos xH)) p) *)
  unfold int_round_odd. set (q := n / 2^p) in *; set (r := n mod 2^p) in *.
(* Goal: @eq full_float (binary_overflow prec2 emax2 mode_NE (Z.ltb n Z0)) (binary_overflow prec2 emax2 mode_NE (Rlt_bool (Z2R n) (IZR Z0))) *)
  f_equal.
  pose proof (bpow_gt_0 radix2 (-p)).
  assert (bpow radix2 p * bpow radix2 (-p) = 1)%R.
  { rewrite <- bpow_plus. replace (p + -p) with 0 by omega. auto. }
  assert (Z2R n * bpow radix2 (-p) = Z2R q + Z2R r * bpow radix2 (-p))%R.
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  { rewrite H1. rewrite Z2R_plus, Z2R_mult.
(* Goal: @eq R (Rmult (Rplus (Rmult (Z2R q) (Z2R (Z.pow (Zpos (xO xH)) p))) (Z2R r)) (bpow radix2 (Z.opp p))) (Rplus (Z2R q) (Rmult (Z2R r) (bpow radix2 (Z.opp p)))) *)
    change (Z2R (2^p)) with (Z2R (radix2^p)).
(* Goal: @eq R (Rmult (Rplus (Rmult (Z2R q) (bpow radix2 p)) (Z2R r)) (bpow radix2 (Z.opp p))) (Rplus (Z2R q) (Rmult (Z2R r) (bpow radix2 (Z.opp p)))) *)
    rewrite Z2R_Zpower by omega. ring_simplify.
    rewrite Rmult_assoc. rewrite H4. ring. }
(* Goal: @eq Z (Zrnd_odd (Rmult (Z2R n) (bpow radix2 (Z.opp p)))) (if orb (Z.eqb r Z0) (Z.odd q) then q else Z.add q (Zpos xH)) *)
  assert (0 <= Z2R r < bpow radix2 p)%R.
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  { split. change 0%R with (Z2R 0). apply Z2R_le; omega.
    rewrite <- Z2R_Zpower by omega. apply Z2R_lt; tauto. }
  assert (0 <= Z2R r * bpow radix2 (-p) < 1)%R.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  { generalize (bpow_gt_0 radix2 (-p)). intros.
(* Goal: and (Rle (IZR Z0) (Rinv (IZR (Zpos (xO xH))))) (Rlt (Rinv (IZR (Zpos (xO xH)))) (IZR (Zpos xH))) *)
    split. apply Rmult_le_pos; lra.
    rewrite <- H4. apply Rmult_lt_compat_r. auto. tauto. }
  assert (Zfloor (Z2R n * bpow radix2 (-p)) = q).
(* Goal: and (Rle (IZR Z0) (Rinv (IZR (Zpos (xO xH))))) (Rlt (Rinv (IZR (Zpos (xO xH)))) (IZR (Zpos xH))) *)
  { apply Zfloor_imp. rewrite H5. rewrite Z2R_plus. change (Z2R 1) with 1%R. lra. }
(* Goal: @eq Z (Zrnd_odd (Rmult (Z2R n) (bpow radix2 (Z.opp p)))) (if orb (Z.eqb r Z0) (Z.odd q) then q else Z.add q (Zpos xH)) *)
  unfold Zrnd_odd. destruct Req_EM_T.
- assert (Z2R r * bpow radix2 (-p) = 0)%R.
(* Goal: and (Rle (IZR Z0) (Rinv (IZR (Zpos (xO xH))))) (Rlt (Rinv (IZR (Zpos (xO xH)))) (IZR (Zpos xH))) *)
  { rewrite H8 in e. rewrite e in H5. lra. }
(* Goal: @eq Z (Zfloor (Rmult (Z2R n) (bpow radix2 (Z.opp p)))) (if orb (Z.eqb r Z0) (Z.odd q) then q else Z.add q (Zpos xH)) *)
  apply Rmult_integral in H9. destruct H9; [ | lra ].
  apply (eq_Z2R r 0) in H9. apply <- Z.eqb_eq in H9. rewrite H9. assumption.
- assert (Z2R r * bpow radix2 (-p) <> 0)%R.
(* Goal: and (Rle (IZR Z0) (Rinv (IZR (Zpos (xO xH))))) (Rlt (Rinv (IZR (Zpos (xO xH)))) (IZR (Zpos xH))) *)
  { rewrite H8 in n0. lra. }
(* Goal: @eq Z (if Zeven (Zfloor (Rmult (Z2R n) (bpow radix2 (Z.opp p)))) then Zceil (Rmult (Z2R n) (bpow radix2 (Z.opp p))) else Zfloor (Rmult (Z2R n) (bpow radix2 (Z.opp p)))) (if orb (Z.eqb r Z0) (Z.odd q) then q else Z.add q (Zpos xH)) *)
  destruct (Z.eqb r 0) eqn:RZ.
(* Goal: @eq Z (if Zeven (Zfloor (Rmult (Z2R n) (bpow radix2 (Z.opp p)))) then Zceil (Rmult (Z2R n) (bpow radix2 (Z.opp p))) else Zfloor (Rmult (Z2R n) (bpow radix2 (Z.opp p)))) (if orb true (Z.odd q) then q else Z.add q (Zpos xH)) *)
(* Goal: @eq Z (if Zeven (Zfloor (Rmult (Z2R n) (bpow radix2 (Z.opp p)))) then Zceil (Rmult (Z2R n) (bpow radix2 (Z.opp p))) else Zfloor (Rmult (Z2R n) (bpow radix2 (Z.opp p)))) (if orb false (Z.odd q) then q else Z.add q (Zpos xH)) *)
  apply Z.eqb_eq in RZ. rewrite RZ in H9. change (Z2R 0) with 0%R in H9.
(* Goal: @eq Z (if Zeven (Zfloor (Rmult (Z2R n) (bpow radix2 (Z.opp p)))) then Zceil (Rmult (Z2R n) (bpow radix2 (Z.opp p))) else Zfloor (Rmult (Z2R n) (bpow radix2 (Z.opp p)))) (if orb true (Z.odd q) then q else Z.add q (Zpos xH)) *)
(* Goal: @eq Z (if Zeven (Zfloor (Rmult (Z2R n) (bpow radix2 (Z.opp p)))) then Zceil (Rmult (Z2R n) (bpow radix2 (Z.opp p))) else Zfloor (Rmult (Z2R n) (bpow radix2 (Z.opp p)))) (if orb false (Z.odd q) then q else Z.add q (Zpos xH)) *)
  rewrite Rmult_0_l in H9. congruence.
(* Goal: and (Rle (IZR Z0) (Rinv (IZR (Zpos (xO xH))))) (Rlt (Rinv (IZR (Zpos (xO xH)))) (IZR (Zpos xH))) *)
  rewrite Zceil_floor_neq by lra. rewrite H8.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  change Zeven with Z.even. rewrite Zodd_even_bool. destruct (Z.even q); auto.
Qed.

Lemma int_round_odd_le:
  forall p x y, 0 <= p ->
  x <= y -> int_round_odd x p <= int_round_odd y p.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros.
  assert (Zrnd_odd (Z2R x * bpow radix2 (-p)) <= Zrnd_odd (Z2R y * bpow radix2 (-p))).
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  { apply Zrnd_le. apply valid_rnd_odd. apply Rmult_le_compat_r. apply bpow_ge_0.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    apply Z2R_le; auto. }
  rewrite <- ! Zrnd_odd_int by auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply Zmult_le_compat_r. auto. apply (Zpower_ge_0 radix2).
Qed.

Lemma int_round_odd_exact:
  forall p x, 0 <= p ->
  (2^p | x) -> int_round_odd x p = x.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. unfold int_round_odd. apply Znumtheory.Zdivide_mod in H0.
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m (B754_infinity prec1 emax1 b))) (B754_infinity prec1 emax1 b) *)
  rewrite H0. simpl. rewrite Z.mul_comm. symmetry. apply Z_div_exact_2.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply Z.lt_gt. apply (Zpower_gt_0 radix2). auto. auto.
Qed.

Theorem BofZ_round_odd:
  forall x p,
  prec > 1 ->
  Z.abs x <= 2^emax - 2^(emax-prec) ->
  0 <= p <= emax - prec ->
  2^(prec + p + 1) <= Z.abs x ->
  BofZ x = BofZ (int_round_odd x p).
Proof.
(* Goal: forall (x p : Z) (_ : Z.gt prec (Zpos xH)) (_ : Z.le (Z.abs x) (Z.sub (Z.pow (Zpos (xO xH)) emax) (Z.pow (Zpos (xO xH)) (Z.sub emax prec)))) (_ : and (Z.le Z0 p) (Z.le p (Z.sub emax prec))) (_ : Z.le (Z.pow (Zpos (xO xH)) (Z.add (Z.add prec p) (Zpos xH))) (Z.abs x)), @eq binary_float (BofZ x) (BofZ (int_round_odd x p)) *)
  intros x p PREC XRANGE PRANGE XGE.
  assert (DIV: (2^p | 2^emax - 2^(emax - prec))).
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  { rewrite int_upper_bound_eq. apply Z.divide_mul_r.
    exists (2^(emax - prec - p)). red in prec_gt_0_.
    rewrite <- (Zpower_plus radix2) by omega. f_equal; omega. }
  assert (YRANGE: Z.abs (int_round_odd x p) <= 2^emax - 2^(emax-prec)).
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  { apply Z.abs_le. split.
    replace (-(2^emax - 2^(emax-prec))) with (int_round_odd (-(2^emax - 2^(emax-prec))) p).
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
    apply int_round_odd_le; zify; omega.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    apply int_round_odd_exact. omega. apply Z.divide_opp_r. auto.
    replace (2^emax - 2^(emax-prec)) with (int_round_odd (2^emax - 2^(emax-prec)) p).
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
    apply int_round_odd_le; zify; omega.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    apply int_round_odd_exact. omega. auto. }
(* Goal: @eq binary_float (BofZ x) (BofZ (int_round_odd x p)) *)
  destruct (BofZ_finite x XRANGE) as (X1 & X2 & X3).
(* Goal: @eq binary_float (BofZ x) (BofZ (int_round_odd x p)) *)
  destruct (BofZ_finite (int_round_odd x p) YRANGE) as (Y1 & Y2 & Y3).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply BofZ_finite_equal; auto.
(* Goal: @eq R (B2R prec emax (BofZ x)) (B2R prec emax (BofZ (int_round_odd x p))) *)
  rewrite X1, Y1.
(* Goal: @eq R (round radix2 fexp (round_mode mode_NE) (Z2R x)) (round radix2 fexp (round_mode mode_NE) (Z2R (int_round_odd x p))) *)
  assert (Z2R (int_round_odd x p) = round radix2 (FIX_exp p) Zrnd_odd (Z2R x)).
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  {
(* Goal: @eq R (Z2R (int_round_odd x p)) (round radix2 (FIX_exp p) Zrnd_odd (Z2R x)) *)
     unfold round, scaled_mantissa, canonic_exp, FIX_exp.
     rewrite <- Zrnd_odd_int by omega.
(* Goal: @eq full_float (binary_overflow prec2 emax2 mode_NE (Z.ltb n Z0)) (binary_overflow prec2 emax2 mode_NE (Rlt_bool (Z2R n) (IZR Z0))) *)
     unfold F2R; simpl. rewrite Z2R_mult. f_equal. apply (Z2R_Zpower radix2). omega.
  }
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite H. symmetry. apply round_odd_fix. auto. omega.
  rewrite <- Z2R_Zpower. rewrite <- Z2R_abs. apply Z2R_le; auto.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  red in prec_gt_0_; omega.
Qed.

Lemma int_round_odd_shifts:
  forall x p, 0 <= p ->
  int_round_odd x p =
  Z.shiftl (if Z.eqb (x mod 2^p) 0 then Z.shiftr x p else Z.lor (Z.shiftr x p) 1) p.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  unfold int_round_odd. rewrite Z.shiftl_mul_pow2 by auto. f_equal.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite Z.shiftr_div_pow2 by auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  destruct (x mod 2^p =? 0) eqn:E. auto.
  assert (forall n, (if Z.odd n then n else n + 1) = Z.lor n 1).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  { destruct n; simpl; auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    destruct p0; auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    destruct p0; auto. induction p0; auto. }
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m (B754_infinity prec1 emax1 b))) (B754_infinity prec1 emax1 b) *)
  simpl. apply H0.
Qed.

Lemma int_round_odd_bits:
  forall x y p, 0 <= p ->
  (forall i, 0 <= i < p -> Z.testbit y i = false) ->
  Z.testbit y p = (if Z.eqb (x mod 2^p) 0 then Z.testbit x p else true) ->
  (forall i, p < i -> Z.testbit y i = Z.testbit x i) ->
  int_round_odd x p = y.
Proof.
(* Goal: forall (x y p : Z) (_ : Z.le Z0 p) (_ : forall (i : Z) (_ : and (Z.le Z0 i) (Z.lt i p)), @eq bool (Z.testbit y i) false) (_ : @eq bool (Z.testbit y p) (if Z.eqb (Z.modulo x (Z.pow (Zpos (xO xH)) p)) Z0 then Z.testbit x p else true)) (_ : forall (i : Z) (_ : Z.lt p i), @eq bool (Z.testbit y i) (Z.testbit x i)), @eq Z (int_round_odd x p) y *)
  intros until p; intros PPOS BELOW AT ABOVE.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite int_round_odd_shifts by auto.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  apply Z.bits_inj'. intros.
(* Goal: @eq bool (Z.testbit (Z.shiftl (if Z.eqb (Z.modulo x (Z.pow (Zpos (xO xH)) p)) Z0 then Z.shiftr x p else Z.lor (Z.shiftr x p) (Zpos xH)) p) n) (Z.testbit y n) *)
  generalize (Zcompare_spec n p); intros SPEC; inversion SPEC.
- rewrite BELOW by auto. apply Z.shiftl_spec_low; auto.
- subst n. rewrite AT. rewrite Z.shiftl_spec_high by omega.
  replace (p - p) with 0 by omega.
(* Goal: @eq bool (Z.testbit (if Z.eqb (Z.modulo x (Z.pow (Zpos (xO xH)) p)) Z0 then Z.shiftr x p else Z.lor (Z.shiftr x p) (Zpos xH)) (Z.sub n p)) (Z.testbit x n) *)
  destruct (x mod 2^p =? 0).
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  + rewrite Z.shiftr_spec by omega. f_equal; omega.
  + rewrite Z.lor_spec. apply orb_true_r.
- rewrite ABOVE by auto.  rewrite Z.shiftl_spec_high by omega.
(* Goal: @eq bool (Z.testbit (if Z.eqb (Z.modulo x (Z.pow (Zpos (xO xH)) p)) Z0 then Z.shiftr x p else Z.lor (Z.shiftr x p) (Zpos xH)) (Z.sub n p)) (Z.testbit x n) *)
  destruct (x mod 2^p =? 0).
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  rewrite Z.shiftr_spec by omega. f_equal; omega.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  rewrite Z.lor_spec, Z.shiftr_spec by omega.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  change 1 with (Z.ones 1). rewrite Z.ones_spec_high by omega. rewrite orb_false_r.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  f_equal; omega.
Qed.

(** ** Conversion from a FP number to an integer *)

(** Always rounds toward zero. *)

Definition ZofB (f: binary_float): option Z :=
  match f with
    | B754_finite _ _ s m (Zpos e) _ => Some (cond_Zopp s (Zpos m) * Z.pow_pos radix2 e)%Z
    | B754_finite _ _ s m 0 _ => Some (cond_Zopp s (Zpos m))
    | B754_finite _ _ s m (Zneg e) _ => Some (cond_Zopp s (Zpos m / Z.pow_pos radix2 e))%Z
    | B754_zero _ _ _ => Some 0%Z
    | _ => None
  end.

Theorem ZofB_correct:
  forall f,
  ZofB f = if is_finite _ _ f then Some (Ztrunc (B2R _ _ f)) else None.
Proof.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  destruct f; simpl; auto.
- f_equal. symmetry. apply (Ztrunc_Z2R 0).
- destruct e; f_equal.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  + unfold F2R; simpl. rewrite Rmult_1_r. rewrite Ztrunc_Z2R. auto.
  + unfold F2R; simpl. rewrite <- Z2R_mult. rewrite Ztrunc_Z2R. auto.
  + unfold F2R; simpl. rewrite Z2R_cond_Zopp. rewrite <- cond_Ropp_mult_l.
(* Goal: @eq Z (cond_Zopp b (Z.div (Zpos m) (Z.pow_pos (Zpos (xO xH)) p))) (Ztrunc (cond_Ropp b (Rmult (Z2R (Zpos m)) (Rinv (Z2R (Z.pow_pos (Zpos (xO xH)) p)))))) *)
    assert (EQ: forall x, Ztrunc (cond_Ropp b x) = cond_Zopp b (Ztrunc x)).
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
    {
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
      intros. destruct b; simpl; auto. apply Ztrunc_opp.
    }
(* Goal: @eq full_float (binary_overflow prec2 emax2 mode_NE (Z.ltb n Z0)) (binary_overflow prec2 emax2 mode_NE (Rlt_bool (Z2R n) (IZR Z0))) *)
    rewrite EQ. f_equal.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
    generalize (Zpower_pos_gt_0 2 p (eq_refl _)); intros.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
    rewrite Ztrunc_floor. symmetry. apply Zfloor_div. omega.
(* Goal: @eq Rdefinitions.R (B2R prec2 emax2 (Bconv conv_nan mode_NE f)) (B2R prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) *)
(* Goal: @eq bool (Bsign prec2 emax2 (Bconv conv_nan mode_NE f)) (Bsign prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) *)
    apply Rmult_le_pos. apply (Z2R_le 0). compute; congruence.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    apply Rlt_le. apply Rinv_0_lt_compat. apply (Z2R_lt 0). auto.
Qed.

(** Interval properties. *)

Remark Ztrunc_range_pos:
  forall x, 0 < Ztrunc x -> (Z2R (Ztrunc x) <= x < Z2R (Ztrunc x + 1)%Z)%R.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros.
(* Goal: and (@eq bool (is_finite prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 m (cond_Zopp b (Zpos m0)) e b)) true) (@eq bool (Bsign prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 m (cond_Zopp b (Zpos m0)) e b)) b) *)
  rewrite Ztrunc_floor. split. apply Zfloor_lb. rewrite Z2R_plus. apply Zfloor_ub.
(* Goal: Rle (IZR Z0) x *)
  generalize (Rle_bool_spec 0%R x). intros RLE; inversion RLE; subst; clear RLE.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  auto.
(* Goal: and (Rle (IZR Z0) (Rinv (IZR (Zpos (xO xH))))) (Rlt (Rinv (IZR (Zpos (xO xH)))) (IZR (Zpos xH))) *)
  rewrite Ztrunc_ceil in H by lra. unfold Zceil in H.
  assert (-x < 0)%R.
  { apply Rlt_le_trans with (Z2R (Zfloor (-x)) + 1)%R. apply Zfloor_ub.
    change 0%R with (Z2R 0). change 1%R with (Z2R 1). rewrite <- Z2R_plus.
    apply Z2R_le. omega. }
(* Goal: and (Rle (IZR Z0) (Rinv (IZR (Zpos (xO xH))))) (Rlt (Rinv (IZR (Zpos (xO xH)))) (IZR (Zpos xH))) *)
  lra.
Qed.

Remark Ztrunc_range_zero:
  forall x, Ztrunc x = 0 -> (-1 < x < 1)%R.
Proof.
(* Goal: Rle (IZR Z0) x *)
  intros; generalize (Rle_bool_spec 0%R x). intros RLE; inversion RLE; subst; clear RLE.
- rewrite Ztrunc_floor in H by auto. split.
  + apply Rlt_le_trans with 0%R; auto. rewrite <- Ropp_0. apply Ropp_lt_contravar. apply Rlt_0_1.
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m (B754_infinity prec1 emax1 b))) (B754_infinity prec1 emax1 b) *)
  + replace 1%R with (Z2R (Zfloor x) + 1)%R. apply Zfloor_ub. rewrite H. simpl. apply Rplus_0_l.
- rewrite Ztrunc_ceil in H by (apply Rlt_le; auto). split.
  + apply (Ropp_lt_cancel (-(1))). rewrite Ropp_involutive.
    replace 1%R with (Z2R (Zfloor (-x)) + 1)%R. apply Zfloor_ub.
    unfold Zceil in H. replace (Zfloor (-x)) with 0 by omega. simpl. apply Rplus_0_l.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  + apply Rlt_le_trans with 0%R; auto. apply Rle_0_1.
Qed.

Theorem ZofB_range_pos:
  forall f n, ZofB f = Some n -> 0 < n -> (Z2R n <= B2R _ _ f < Z2R (n + 1)%Z)%R.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. rewrite ZofB_correct in H. destruct (is_finite prec emax f) eqn:FIN; inversion H.
(* Goal: @eq Rdefinitions.R (B2R prec2 emax2 (Bconv conv_nan mode_NE f)) (B2R prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) *)
(* Goal: @eq bool (Bsign prec2 emax2 (Bconv conv_nan mode_NE f)) (Bsign prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) *)
  apply Ztrunc_range_pos. congruence.
Qed.

Theorem ZofB_range_neg:
  forall f n, ZofB f = Some n -> n < 0 -> (Z2R (n - 1)%Z < B2R _ _ f <= Z2R n)%R.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. rewrite ZofB_correct in H. destruct (is_finite prec emax f) eqn:FIN; inversion H.
  set (x := B2R prec emax f) in *. set (y := (-x)%R).
  assert (A: (Z2R (Ztrunc y) <= y < Z2R (Ztrunc y + 1)%Z)%R).
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  { apply Ztrunc_range_pos. unfold y. rewrite Ztrunc_opp. omega. }
(* Goal: and (Rlt (Z2R (Z.sub (Ztrunc x) (Zpos xH))) x) (Rle x (Z2R (Ztrunc x))) *)
  destruct A as [B C].
(* Goal: and (Rlt (Z2R (Z.sub (Ztrunc x) (Zpos xH))) x) (Rle x (Z2R (Ztrunc x))) *)
  unfold y in B, C. rewrite Ztrunc_opp in B, C.
  replace (- Ztrunc x + 1) with (- (Ztrunc x - 1)) in C by omega.
(* Goal: and (Rle (IZR Z0) (Rinv (IZR (Zpos (xO xH))))) (Rlt (Rinv (IZR (Zpos (xO xH)))) (IZR (Zpos xH))) *)
  rewrite Z2R_opp in B, C. lra.
Qed.

Theorem ZofB_range_zero:
  forall f, ZofB f = Some 0 -> (-1 < B2R _ _ f < 1)%R.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. rewrite ZofB_correct in H. destruct (is_finite prec emax f) eqn:FIN; inversion H.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply Ztrunc_range_zero. auto.
Qed.

Theorem ZofB_range_nonneg:
  forall f n, ZofB f = Some n -> 0 <= n -> (-1 < B2R _ _ f < Z2R (n + 1)%Z)%R.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. destruct (Z.eq_dec n 0).
- subst n. apply ZofB_range_zero. auto.
- destruct (ZofB_range_pos f n) as (A & B). auto. omega.
(* Goal: and (Rle (IZR Z0) (Rinv (IZR (Zpos (xO xH))))) (Rlt (Rinv (IZR (Zpos (xO xH)))) (IZR (Zpos xH))) *)
  split; auto. apply Rlt_le_trans with (Z2R 0). simpl; lra.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply Rle_trans with (Z2R n); auto. apply Z2R_le; auto.
Qed.

(** For representable integers, [ZofB] is left inverse of [BofZ]. *)

Theorem ZofBofZ_exact:
  forall n, integer_representable n -> ZofB (BofZ n) = Some n.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. destruct (BofZ_representable n H) as (A & B & C).
(* Goal: @eq full_float (binary_overflow prec2 emax2 mode_NE (Z.ltb n Z0)) (binary_overflow prec2 emax2 mode_NE (Rlt_bool (Z2R n) (IZR Z0))) *)
  rewrite ZofB_correct. rewrite A, B. f_equal. apply Ztrunc_Z2R.
Qed.

(** Compatibility with subtraction *)

Remark Zfloor_minus:
  forall x n, Zfloor (x - Z2R n) = Zfloor x - n.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. apply Zfloor_imp. replace (Zfloor x - n + 1) with ((Zfloor x + 1) - n) by omega.
(* Goal: and (@eq bool (is_finite prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 m (cond_Zopp b (Zpos m0)) e b)) true) (@eq bool (Bsign prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 m (cond_Zopp b (Zpos m0)) e b)) b) *)
  rewrite ! Z2R_minus. unfold Rminus. split.
(* Goal: Rle (Z2R (Zfloor x)) x *)
(* Goal: Rlt (Rplus x (Ropp (Z2R n))) (Rplus (Z2R (Z.add (Zfloor x) (Zpos xH))) (Ropp (Z2R n))) *)
  apply Rplus_le_compat_r. apply Zfloor_lb.
(* Goal: Rlt x (Z2R (Z.add (Zfloor x) (Zpos xH))) *)
  apply Rplus_lt_compat_r. rewrite Z2R_plus. apply Zfloor_ub.
Qed.

Theorem ZofB_minus:
  forall minus_nan m f p q,
  ZofB f = Some p -> 0 <= p < 2*q -> q <= 2^prec -> (Z2R q <= B2R _ _ f)%R ->
  ZofB (Bminus _ _ _ Hmax minus_nan m f (BofZ q)) = Some (p - q).
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros.
  assert (Q: -2^prec <= q <= 2^prec).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  { split; auto.  generalize (Zpower_ge_0 radix2 prec); simpl; omega. }
  assert (RANGE: (-1 < B2R _ _ f < Z2R (p + 1)%Z)%R) by (apply ZofB_range_nonneg; auto; omega).
(* Goal: @eq (option Z) (ZofB (Bminus prec emax prec_gt_0_ Hmax minus_nan m f (BofZ q))) (@Some Z (Z.sub p q)) *)
  rewrite ZofB_correct in H. destruct (is_finite prec emax f) eqn:FIN; try discriminate.
  assert (PQ2: (Z2R (p + 1) <= Z2R q * 2)%R).
  { change 2%R with (Z2R 2). rewrite <- Z2R_mult. apply Z2R_le. omega. }
  assert (EXACT: round radix2 fexp (round_mode m) (B2R _ _ f - Z2R q)%R = (B2R _ _ f - Z2R q)%R).
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  { apply round_generic. apply valid_rnd_round_mode.
(* Goal: generic_format radix2 fexp (Rminus (B2R prec emax f) (Z2R q)) *)
    apply sterbenz_aux. apply FLT_exp_monotone. apply generic_format_B2R.
(* Goal: and (Rle (IZR Z0) (Rinv (IZR (Zpos (xO xH))))) (Rlt (Rinv (IZR (Zpos (xO xH)))) (IZR (Zpos xH))) *)
    apply integer_representable_n. auto. lra. }
(* Goal: @eq (option Z) (ZofB (Bminus prec emax prec_gt_0_ Hmax minus_nan m f (BofZ q))) (@Some Z (Z.sub p q)) *)
  destruct (BofZ_exact q Q) as (A & B & C).
(* Goal: @eq (option Z) (ZofB (Bminus prec emax prec_gt_0_ Hmax minus_nan m f (BofZ q))) (@Some Z (Z.sub p q)) *)
  generalize (Bminus_correct _ _ _ Hmax minus_nan m f (BofZ q) FIN B).
(* Goal: forall _ : if Rlt_bool (Rabs (B2R prec1 emax1 f)) (bpow radix2 emax1) then and (@eq R (B2R prec1 emax1 (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m f')) (B2R prec1 emax1 f)) (and (@eq bool (is_finite prec1 emax1 (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m f')) true) (@eq bool (Bsign prec1 emax1 (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m f')) (Bsign prec1 emax1 f))) else @eq full_float (B2FF prec1 emax1 (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m f')) (binary_overflow prec1 emax1 m (Bsign prec1 emax1 f)), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m f') f *)
  rewrite Rlt_bool_true.
- fold emin; fold fexp. intros (D & E & F).
(* Goal: @eq (option Z) (@Some Z (Ztrunc (B2R prec2 emax2 (Bconv conv_nan m f)))) (@Some Z (Ztrunc (B2R prec1 emax1 f))) *)
  rewrite ZofB_correct. rewrite E. rewrite D. rewrite A. rewrite EXACT.
(* Goal: @eq full_float (binary_overflow prec2 emax2 mode_NE (Z.ltb n Z0)) (binary_overflow prec2 emax2 mode_NE (Rlt_bool (Z2R n) (IZR Z0))) *)
  inversion H. f_equal. rewrite ! Ztrunc_floor. apply Zfloor_minus.
(* Goal: and (Rle (IZR Z0) (Rinv (IZR (Zpos (xO xH))))) (Rlt (Rinv (IZR (Zpos (xO xH)))) (IZR (Zpos xH))) *)
  lra. lra.
- rewrite A. fold emin; fold fexp. rewrite EXACT.
(* Goal: Rlt (Rabs (Rminus (B2R prec emax f) (Z2R q))) (bpow radix2 emax) *)
  apply Rle_lt_trans with (bpow radix2 prec).
(* Goal: and (Rle (IZR Z0) (Rinv (IZR (Zpos (xO xH))))) (Rlt (Rinv (IZR (Zpos (xO xH)))) (IZR (Zpos xH))) *)
  apply Rle_trans with (Z2R q). apply Rabs_le. lra.
  rewrite <- Z2R_Zpower. apply Z2R_le; auto. red in prec_gt_0_; omega.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply bpow_lt. auto.
Qed.

(** A variant of [ZofB] that bounds the range of representable integers. *)

Definition ZofB_range (f: binary_float) (zmin zmax: Z): option Z :=
  match ZofB f with
  | None => None
  | Some z => if Z.leb zmin z && Z.leb z zmax then Some z else None
  end.

Theorem ZofB_range_correct:
  forall f min max,
  let n := Ztrunc (B2R _ _ f) in
  ZofB_range f min max =
  if is_finite _ _ f && Z.leb min n && Z.leb n max then Some n else None.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. unfold ZofB_range. rewrite ZofB_correct. fold n.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  destruct (is_finite prec emax f); auto.
Qed.

Lemma ZofB_range_inversion:
  forall f min max n,
  ZofB_range f min max = Some n ->
  min <= n /\ n <= max /\ ZofB f = Some n.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. rewrite ZofB_range_correct in H. rewrite ZofB_correct.
(* Goal: and (Z.le min n) (and (Z.le n max) (@eq (option Z) (if is_finite prec emax f then @Some Z (Ztrunc (B2R prec emax f)) else @None Z) (@Some Z n))) *)
  destruct (is_finite prec emax f); try discriminate.
(* Goal: and (Z.le min n) (and (Z.le n max) (@eq (option Z) (@Some Z (Ztrunc (B2R prec emax f))) (@Some Z n))) *)
  set (n1 := Ztrunc (B2R _ _ f)) in *.
(* Goal: and (Z.le min n) (and (Z.le n max) (@eq (option Z) (@Some Z n1) (@Some Z n))) *)
  destruct (min <=? n1) eqn:MIN; try discriminate.
(* Goal: and (Z.le min n) (and (Z.le n max) (@eq (option Z) (@Some Z n1) (@Some Z n))) *)
  destruct (n1 <=? max) eqn:MAX; try discriminate.
(* Goal: and (Z.le min n1) (and (Z.le n1 max) (@eq (option Z) (@Some Z n1) (@Some Z n1))) *)
  simpl in H. inversion H. subst n.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  split. apply Zle_bool_imp_le; auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  split. apply Zle_bool_imp_le; auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  auto.
Qed.

Theorem ZofB_range_minus:
  forall minus_nan m f p q,
  ZofB_range f 0 (2 * q - 1) = Some p -> q <= 2^prec -> (Z2R q <= B2R _ _ f)%R ->
  ZofB_range (Bminus _ _ _ Hmax minus_nan m f (BofZ q)) (-q) (q - 1) = Some (p - q).
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. destruct (ZofB_range_inversion _ _ _ _ H) as (A & B & C).
(* Goal: @eq (option Z) (ZofB_range (Bminus prec emax prec_gt_0_ Hmax minus_nan m f (BofZ q)) (Z.opp q) (Z.sub q (Zpos xH))) (@Some Z (Z.sub p q)) *)
  set (f' := Bminus prec emax prec_gt_0_ Hmax minus_nan m f (BofZ q)).
  assert (D: ZofB f' = Some (p - q)).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  { apply ZofB_minus. auto. omega. auto. auto. }
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  unfold ZofB_range. rewrite D. rewrite Zle_bool_true by omega. rewrite Zle_bool_true by omega. auto.
Qed.

(** ** Algebraic identities *)

(** Commutativity of addition and multiplication *)

Theorem Bplus_commut:
  forall plus_nan mode (x y: binary_float),
  plus_nan x y = plus_nan y x ->
  Bplus _ _ _ Hmax plus_nan mode x y = Bplus _ _ _ Hmax plus_nan mode y x.
Proof.
(* Goal: forall (plus_nan : forall (_ : binary_float) (_ : binary_float), prod bool (nan_pl prec)) (mode : mode) (x y : binary_float) (_ : @eq (prod bool (nan_pl prec)) (plus_nan x y) (plus_nan y x)), @eq (Fappli_IEEE.binary_float prec emax) (Bplus prec emax prec_gt_0_ Hmax plus_nan mode x y) (Bplus prec emax prec_gt_0_ Hmax plus_nan mode y x) *)
  intros until y; intros NAN.
(* Goal: @eq (Fappli_IEEE.binary_float prec emax) (Bplus prec emax prec_gt_0_ Hmax plus_nan mode x y) (Bplus prec emax prec_gt_0_ Hmax plus_nan mode y x) *)
  pose proof (Bplus_correct _ _ _ Hmax plus_nan mode x y).
(* Goal: @eq (Fappli_IEEE.binary_float prec emax) (Bplus prec emax prec_gt_0_ Hmax plus_nan mode x y) (Bplus prec emax prec_gt_0_ Hmax plus_nan mode y x) *)
  pose proof (Bplus_correct _ _ _ Hmax plus_nan mode y x).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  unfold Bplus in *; destruct x; destruct y; auto.
- rewrite (eqb_sym b0 b). destruct (eqb b b0) eqn:EQB; auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  f_equal; apply eqb_prop; auto.
- rewrite NAN; auto.
- rewrite (eqb_sym b0 b). destruct (eqb b b0) eqn:EQB.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  f_equal; apply eqb_prop; auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite NAN; auto.
- rewrite NAN; auto.
- rewrite NAN; auto.
- rewrite NAN; auto.
- rewrite NAN; auto.
- rewrite NAN; auto.
- rewrite NAN; auto.
- generalize (H (eq_refl _) (eq_refl _)); clear H.
(* Goal: forall _ : if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode) (Rplus (B2R prec emax (B754_finite prec emax b m e e0)) (B2R prec emax (B754_finite prec emax b0 m0 e1 e2))))) (bpow radix2 emax) then and (@eq R (B2R prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode) (Rplus (B2R prec emax (B754_finite prec emax b m e e0)) (B2R prec emax (B754_finite prec emax b0 m0 e1 e2))))) (and (@eq bool (is_finite prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) true) (@eq bool (Bsign prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) match Rcompare (Rplus (B2R prec emax (B754_finite prec emax b m e e0)) (B2R prec emax (B754_finite prec emax b0 m0 e1 e2))) (IZR Z0) with | Eq => match mode with | mode_NE => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) | mode_ZR => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) | mode_DN => orb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) | mode_UP => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) | mode_NA => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) end | Lt => true | Gt => false end)) else and (@eq full_float (B2FF prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) (binary_overflow prec emax mode (Bsign prec emax (B754_finite prec emax b m e e0)))) (@eq bool (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2))), @eq (Fappli_IEEE.binary_float prec emax) (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end) (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end) *)
  generalize (H0 (eq_refl _) (eq_refl _)); clear H0.
(* Goal: forall (_ : if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode) (Rplus (B2R prec emax (B754_finite prec emax b0 m0 e1 e2)) (B2R prec emax (B754_finite prec emax b m e e0))))) (bpow radix2 emax) then and (@eq R (B2R prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode) (Rplus (B2R prec emax (B754_finite prec emax b0 m0 e1 e2)) (B2R prec emax (B754_finite prec emax b m e e0))))) (and (@eq bool (is_finite prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) true) (@eq bool (Bsign prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) match Rcompare (Rplus (B2R prec emax (B754_finite prec emax b0 m0 e1 e2)) (B2R prec emax (B754_finite prec emax b m e e0))) (IZR Z0) with | Eq => match mode with | mode_NE => andb (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) (Bsign prec emax (B754_finite prec emax b m e e0)) | mode_ZR => andb (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) (Bsign prec emax (B754_finite prec emax b m e e0)) | mode_DN => orb (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) (Bsign prec emax (B754_finite prec emax b m e e0)) | mode_UP => andb (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) (Bsign prec emax (B754_finite prec emax b m e e0)) | mode_NA => andb (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) (Bsign prec emax (B754_finite prec emax b m e e0)) end | Lt => true | Gt => false end)) else and (@eq full_float (B2FF prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) (binary_overflow prec emax mode (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)))) (@eq bool (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) (Bsign prec emax (B754_finite prec emax b m e e0)))) (_ : if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode) (Rplus (B2R prec emax (B754_finite prec emax b m e e0)) (B2R prec emax (B754_finite prec emax b0 m0 e1 e2))))) (bpow radix2 emax) then and (@eq R (B2R prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode) (Rplus (B2R prec emax (B754_finite prec emax b m e e0)) (B2R prec emax (B754_finite prec emax b0 m0 e1 e2))))) (and (@eq bool (is_finite prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) true) (@eq bool (Bsign prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) match Rcompare (Rplus (B2R prec emax (B754_finite prec emax b m e e0)) (B2R prec emax (B754_finite prec emax b0 m0 e1 e2))) (IZR Z0) with | Eq => match mode with | mode_NE => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) | mode_ZR => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) | mode_DN => orb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) | mode_UP => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) | mode_NA => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) end | Lt => true | Gt => false end)) else and (@eq full_float (B2FF prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) (binary_overflow prec emax mode (Bsign prec emax (B754_finite prec emax b m e e0)))) (@eq bool (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)))), @eq (Fappli_IEEE.binary_float prec emax) (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end) (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end) *)
  fold emin. fold fexp.
(* Goal: forall (_ : if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) (Rplus (B2R prec emax (B754_finite prec emax b0 m0 e1 e2)) (B2R prec emax (B754_finite prec emax b m e e0))))) (bpow radix2 emax) then and (@eq R (B2R prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) (round radix2 fexp (round_mode mode) (Rplus (B2R prec emax (B754_finite prec emax b0 m0 e1 e2)) (B2R prec emax (B754_finite prec emax b m e e0))))) (and (@eq bool (is_finite prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) true) (@eq bool (Bsign prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) match Rcompare (Rplus (B2R prec emax (B754_finite prec emax b0 m0 e1 e2)) (B2R prec emax (B754_finite prec emax b m e e0))) (IZR Z0) with | Eq => match mode with | mode_NE => andb (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) (Bsign prec emax (B754_finite prec emax b m e e0)) | mode_ZR => andb (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) (Bsign prec emax (B754_finite prec emax b m e e0)) | mode_DN => orb (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) (Bsign prec emax (B754_finite prec emax b m e e0)) | mode_UP => andb (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) (Bsign prec emax (B754_finite prec emax b m e e0)) | mode_NA => andb (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) (Bsign prec emax (B754_finite prec emax b m e e0)) end | Lt => true | Gt => false end)) else and (@eq full_float (B2FF prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) (binary_overflow prec emax mode (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)))) (@eq bool (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) (Bsign prec emax (B754_finite prec emax b m e e0)))) (_ : if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) (Rplus (B2R prec emax (B754_finite prec emax b m e e0)) (B2R prec emax (B754_finite prec emax b0 m0 e1 e2))))) (bpow radix2 emax) then and (@eq R (B2R prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) (round radix2 fexp (round_mode mode) (Rplus (B2R prec emax (B754_finite prec emax b m e e0)) (B2R prec emax (B754_finite prec emax b0 m0 e1 e2))))) (and (@eq bool (is_finite prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) true) (@eq bool (Bsign prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) match Rcompare (Rplus (B2R prec emax (B754_finite prec emax b m e e0)) (B2R prec emax (B754_finite prec emax b0 m0 e1 e2))) (IZR Z0) with | Eq => match mode with | mode_NE => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) | mode_ZR => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) | mode_DN => orb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) | mode_UP => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) | mode_NA => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) end | Lt => true | Gt => false end)) else and (@eq full_float (B2FF prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) (binary_overflow prec emax mode (Bsign prec emax (B754_finite prec emax b m e e0)))) (@eq bool (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)))), @eq (Fappli_IEEE.binary_float prec emax) (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end) (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end) *)
  set (x := B754_finite prec emax b0 m0 e1 e2). set (rx := B2R _ _ x).
(* Goal: forall (_ : if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) (Rplus rx (B2R prec emax (B754_finite prec emax b m e e0))))) (bpow radix2 emax) then and (@eq R (B2R prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) (round radix2 fexp (round_mode mode) (Rplus rx (B2R prec emax (B754_finite prec emax b m e e0))))) (and (@eq bool (is_finite prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) true) (@eq bool (Bsign prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) match Rcompare (Rplus rx (B2R prec emax (B754_finite prec emax b m e e0))) (IZR Z0) with | Eq => match mode with | mode_NE => andb (Bsign prec emax x) (Bsign prec emax (B754_finite prec emax b m e e0)) | mode_ZR => andb (Bsign prec emax x) (Bsign prec emax (B754_finite prec emax b m e e0)) | mode_DN => orb (Bsign prec emax x) (Bsign prec emax (B754_finite prec emax b m e e0)) | mode_UP => andb (Bsign prec emax x) (Bsign prec emax (B754_finite prec emax b m e e0)) | mode_NA => andb (Bsign prec emax x) (Bsign prec emax (B754_finite prec emax b m e e0)) end | Lt => true | Gt => false end)) else and (@eq full_float (B2FF prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) (binary_overflow prec emax mode (Bsign prec emax x))) (@eq bool (Bsign prec emax x) (Bsign prec emax (B754_finite prec emax b m e e0)))) (_ : if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) (Rplus (B2R prec emax (B754_finite prec emax b m e e0)) rx))) (bpow radix2 emax) then and (@eq R (B2R prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) (round radix2 fexp (round_mode mode) (Rplus (B2R prec emax (B754_finite prec emax b m e e0)) rx))) (and (@eq bool (is_finite prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) true) (@eq bool (Bsign prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) match Rcompare (Rplus (B2R prec emax (B754_finite prec emax b m e e0)) rx) (IZR Z0) with | Eq => match mode with | mode_NE => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax x) | mode_ZR => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax x) | mode_DN => orb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax x) | mode_UP => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax x) | mode_NA => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax x) end | Lt => true | Gt => false end)) else and (@eq full_float (B2FF prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) (binary_overflow prec emax mode (Bsign prec emax (B754_finite prec emax b m e e0)))) (@eq bool (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax x))), @eq (Fappli_IEEE.binary_float prec emax) (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end) (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end) *)
  set (y := B754_finite prec emax b m e e0). set (ry := B2R _ _ y).
(* Goal: forall (_ : if Rlt_bool (Rabs (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (bpow radix2 emax2) then and (@eq R (B2R prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (and (@eq bool (is_finite prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) true) (@eq bool (Bsign prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) match Rcompare (Z2R n) (IZR Z0) with | Eq => false | Lt => true | Gt => false end)) else @eq full_float (B2FF prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) (binary_overflow prec2 emax2 mode_NE (Rlt_bool (Z2R n) (IZR Z0)))) (_ : if Rlt_bool (Rabs (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (bpow radix2 emax2) then and (@eq R (B2R prec2 emax2 (Bconv conv_nan mode_NE f)) (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (and (@eq bool (is_finite prec2 emax2 (Bconv conv_nan mode_NE f)) true) (@eq bool (Bsign prec2 emax2 (Bconv conv_nan mode_NE f)) (Bsign prec1 emax1 f))) else @eq full_float (B2FF prec2 emax2 (Bconv conv_nan mode_NE f)) (binary_overflow prec2 emax2 mode_NE (Bsign prec1 emax1 f))), @eq binary_float2 (Bconv conv_nan mode_NE f) (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false) *)
(* Goal: @eq R (Z2R n) (@F2R radix2 (Float radix2 n Z0)) *)
  rewrite (Rplus_comm ry rx). destruct Rlt_bool.
  + intros (A1 & A2 & A3) (B1 & B2 & B3).
    apply B2R_Bsign_inj; auto. rewrite <- B1 in A1. auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    rewrite Z.add_comm. rewrite Z.min_comm. auto.
  + intros (A1 & A2) (B1 & B2). apply B2FF_inj. rewrite B2 in B1. rewrite <- B1 in A1. auto.
Qed.

Theorem Bmult_commut:
  forall mult_nan mode (x y: binary_float),
  mult_nan x y = mult_nan y x ->
  Bmult _ _ _ Hmax mult_nan mode x y = Bmult _ _ _ Hmax mult_nan mode y x.
Proof.
(* Goal: forall (plus_nan : forall (_ : binary_float) (_ : binary_float), prod bool (nan_pl prec)) (mode : mode) (x y : binary_float) (_ : @eq (prod bool (nan_pl prec)) (plus_nan x y) (plus_nan y x)), @eq (Fappli_IEEE.binary_float prec emax) (Bplus prec emax prec_gt_0_ Hmax plus_nan mode x y) (Bplus prec emax prec_gt_0_ Hmax plus_nan mode y x) *)
  intros until y; intros NAN.
  pose proof (Bmult_correct _ _ _ Hmax mult_nan mode x y).
  pose proof (Bmult_correct _ _ _ Hmax mult_nan mode y x).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  unfold Bmult in *; destruct x; destruct y; auto.
- rewrite (xorb_comm b0 b); auto.
- rewrite NAN; auto.
- rewrite NAN; auto.
- rewrite (xorb_comm b0 b); auto.
- rewrite NAN; auto.
- rewrite (xorb_comm b0 b); auto.
- rewrite NAN; auto.
- rewrite (xorb_comm b0 b); auto.
- rewrite NAN; auto.
- rewrite NAN; auto.
- rewrite NAN; auto.
- rewrite NAN; auto.
- rewrite (xorb_comm b0 b); auto.
- rewrite (xorb_comm b0 b); auto.
- rewrite NAN; auto.
- revert H H0. fold emin. fold fexp.
(* Goal: forall (_ : if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) (Rplus (B2R prec emax (B754_finite prec emax b0 m0 e1 e2)) (B2R prec emax (B754_finite prec emax b m e e0))))) (bpow radix2 emax) then and (@eq R (B2R prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) (round radix2 fexp (round_mode mode) (Rplus (B2R prec emax (B754_finite prec emax b0 m0 e1 e2)) (B2R prec emax (B754_finite prec emax b m e e0))))) (and (@eq bool (is_finite prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) true) (@eq bool (Bsign prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) match Rcompare (Rplus (B2R prec emax (B754_finite prec emax b0 m0 e1 e2)) (B2R prec emax (B754_finite prec emax b m e e0))) (IZR Z0) with | Eq => match mode with | mode_NE => andb (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) (Bsign prec emax (B754_finite prec emax b m e e0)) | mode_ZR => andb (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) (Bsign prec emax (B754_finite prec emax b m e e0)) | mode_DN => orb (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) (Bsign prec emax (B754_finite prec emax b m e e0)) | mode_UP => andb (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) (Bsign prec emax (B754_finite prec emax b m e e0)) | mode_NA => andb (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) (Bsign prec emax (B754_finite prec emax b m e e0)) end | Lt => true | Gt => false end)) else and (@eq full_float (B2FF prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) (binary_overflow prec emax mode (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)))) (@eq bool (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) (Bsign prec emax (B754_finite prec emax b m e e0)))) (_ : if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) (Rplus (B2R prec emax (B754_finite prec emax b m e e0)) (B2R prec emax (B754_finite prec emax b0 m0 e1 e2))))) (bpow radix2 emax) then and (@eq R (B2R prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) (round radix2 fexp (round_mode mode) (Rplus (B2R prec emax (B754_finite prec emax b m e e0)) (B2R prec emax (B754_finite prec emax b0 m0 e1 e2))))) (and (@eq bool (is_finite prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) true) (@eq bool (Bsign prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) match Rcompare (Rplus (B2R prec emax (B754_finite prec emax b m e e0)) (B2R prec emax (B754_finite prec emax b0 m0 e1 e2))) (IZR Z0) with | Eq => match mode with | mode_NE => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) | mode_ZR => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) | mode_DN => orb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) | mode_UP => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) | mode_NA => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)) end | Lt => true | Gt => false end)) else and (@eq full_float (B2FF prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) (binary_overflow prec emax mode (Bsign prec emax (B754_finite prec emax b m e e0)))) (@eq bool (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax (B754_finite prec emax b0 m0 e1 e2)))), @eq (Fappli_IEEE.binary_float prec emax) (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end) (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end) *)
  set (x := B754_finite prec emax b0 m0 e1 e2). set (rx := B2R _ _ x).
(* Goal: forall (_ : if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) (Rplus rx (B2R prec emax (B754_finite prec emax b m e e0))))) (bpow radix2 emax) then and (@eq R (B2R prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) (round radix2 fexp (round_mode mode) (Rplus rx (B2R prec emax (B754_finite prec emax b m e e0))))) (and (@eq bool (is_finite prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) true) (@eq bool (Bsign prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) match Rcompare (Rplus rx (B2R prec emax (B754_finite prec emax b m e e0))) (IZR Z0) with | Eq => match mode with | mode_NE => andb (Bsign prec emax x) (Bsign prec emax (B754_finite prec emax b m e e0)) | mode_ZR => andb (Bsign prec emax x) (Bsign prec emax (B754_finite prec emax b m e e0)) | mode_DN => orb (Bsign prec emax x) (Bsign prec emax (B754_finite prec emax b m e e0)) | mode_UP => andb (Bsign prec emax x) (Bsign prec emax (B754_finite prec emax b m e e0)) | mode_NA => andb (Bsign prec emax x) (Bsign prec emax (B754_finite prec emax b m e e0)) end | Lt => true | Gt => false end)) else and (@eq full_float (B2FF prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) (binary_overflow prec emax mode (Bsign prec emax x))) (@eq bool (Bsign prec emax x) (Bsign prec emax (B754_finite prec emax b m e e0)))) (_ : if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) (Rplus (B2R prec emax (B754_finite prec emax b m e e0)) rx))) (bpow radix2 emax) then and (@eq R (B2R prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) (round radix2 fexp (round_mode mode) (Rplus (B2R prec emax (B754_finite prec emax b m e e0)) rx))) (and (@eq bool (is_finite prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) true) (@eq bool (Bsign prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) match Rcompare (Rplus (B2R prec emax (B754_finite prec emax b m e e0)) rx) (IZR Z0) with | Eq => match mode with | mode_NE => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax x) | mode_ZR => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax x) | mode_DN => orb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax x) | mode_UP => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax x) | mode_NA => andb (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax x) end | Lt => true | Gt => false end)) else and (@eq full_float (B2FF prec emax (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end)) (binary_overflow prec emax mode (Bsign prec emax (B754_finite prec emax b m e e0)))) (@eq bool (Bsign prec emax (B754_finite prec emax b m e e0)) (Bsign prec emax x))), @eq (Fappli_IEEE.binary_float prec emax) (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e e1))))) (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e e1)))))) (Z.min e e1) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end) (binary_normalize prec emax prec_gt_0_ Hmax mode (Z.add (cond_Zopp b0 (Zpos (@fst positive Z (shl_align m0 e1 (Z.min e1 e))))) (cond_Zopp b (Zpos (@fst positive Z (shl_align m e (Z.min e1 e)))))) (Z.min e1 e) match mode with | mode_NE => false | mode_ZR => false | mode_DN => true | mode_UP => false | mode_NA => false end) *)
  set (y := B754_finite prec emax b m e e0). set (ry := B2R _ _ y).
  rewrite (Rmult_comm ry rx).
  destruct (Rlt_bool (Rabs (round radix2 fexp (round_mode mode) (rx * ry)))
                     (bpow radix2 emax)).
  + intros (A1 & A2 & A3) (B1 & B2 & B3).
    apply B2R_Bsign_inj; auto. rewrite <- B1 in A1. auto.
(* Goal: @eq full_float (binary_overflow prec2 emax2 mode_NE (Z.ltb n Z0)) (binary_overflow prec2 emax2 mode_NE (Rlt_bool (Z2R n) (IZR Z0))) *)
    rewrite ! Bsign_FF2B. f_equal. f_equal. apply xorb_comm. apply Pos.mul_comm. apply Z.add_comm.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  + intros A B. apply B2FF_inj. etransitivity. eapply A. rewrite xorb_comm. auto.
Qed.

(** Multiplication by 2 is diagonal addition. *)

Theorem Bmult2_Bplus:
  forall plus_nan mult_nan mode (f: binary_float),
  (forall (x y: binary_float),
   is_nan _ _ x = true -> is_finite _ _ y = true -> plus_nan x x = mult_nan x y) ->
  Bplus _ _ _ Hmax plus_nan mode f f = Bmult _ _ _ Hmax mult_nan mode f (BofZ 2%Z).
Proof.
(* Goal: forall (plus_nan mult_nan : forall (_ : binary_float) (_ : binary_float), prod bool (nan_pl prec)) (mode : mode) (f : binary_float) (_ : forall (x y : binary_float) (_ : @eq bool (is_nan prec emax x) true) (_ : @eq bool (is_finite prec emax y) true), @eq (prod bool (nan_pl prec)) (plus_nan x x) (mult_nan x y)), @eq (Fappli_IEEE.binary_float prec emax) (Bplus prec emax prec_gt_0_ Hmax plus_nan mode f f) (Bmult prec emax prec_gt_0_ Hmax mult_nan mode f (BofZ (Zpos (xO xH)))) *)
  intros until f; intros NAN.
(* Goal: @eq (Fappli_IEEE.binary_float prec emax) (Bplus prec emax prec_gt_0_ Hmax plus_nan mode f f) (Bmult prec emax prec_gt_0_ Hmax mult_nan mode f (BofZ (Zpos (xO xH)))) *)
  destruct (BofZ_representable 2) as (A & B & C).
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  apply (integer_representable_2p 1). red in prec_gt_0_; omega.
(* Goal: @eq (Fappli_IEEE.binary_float prec emax) (Bplus prec emax prec_gt_0_ Hmax plus_nan mode f f) (Bmult prec emax prec_gt_0_ Hmax mult_nan mode f (BofZ (Zpos (xO xH)))) *)
  pose proof (Bmult_correct _ _ _ Hmax mult_nan mode f (BofZ 2%Z)). fold emin in H.
(* Goal: @eq (Fappli_IEEE.binary_float prec emax) (Bplus prec emax prec_gt_0_ Hmax plus_nan mode f f) (Bmult prec emax prec_gt_0_ Hmax mult_nan mode f (BofZ (Zpos (xO xH)))) *)
  rewrite A, B, C in H. rewrite xorb_false_r in H.
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  destruct (is_finite _ _ f) eqn:FIN.
- pose proof (Bplus_correct _ _ _ Hmax plus_nan mode f f FIN FIN). fold emin in H0.
  assert (EQ: (B2R prec emax f * Z2R 2%Z = B2R prec emax f + B2R prec emax f)%R).
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  { change (Z2R 2%Z) with 2%R. ring. }
  rewrite <- EQ in H0. destruct Rlt_bool.
  + destruct H0 as (P & Q & R). destruct H as (S & T & U).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    apply B2R_Bsign_inj; auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    rewrite P, S. auto.
(* Goal: @eq bool (Bsign prec emax (Bplus prec emax prec_gt_0_ Hmax plus_nan mode f f)) (Bsign prec emax (Bmult prec emax prec_gt_0_ Hmax mult_nan mode f (BofZ (Zpos (xO xH))))) *)
    rewrite R, U.
(* Goal: @eq R (Rmult (Z2R x) (IZR (Zpos xH))) (Z2R x) *)
    replace 0%R with (0 * Z2R 2%Z)%R by ring. rewrite Rcompare_mult_r.
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m (B754_infinity prec1 emax1 b))) (B754_infinity prec1 emax1 b) *)
    rewrite andb_diag, orb_diag. destruct f; try discriminate; simpl.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    rewrite Rcompare_Eq by auto. destruct mode; auto.
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
    replace 0%R with (@F2R radix2 {| Fnum := 0%Z; Fexp := e |}).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    rewrite Rcompare_F2R. destruct b; auto.
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m (B754_infinity prec1 emax1 b))) (B754_infinity prec1 emax1 b) *)
    unfold F2R. simpl. ring.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
    change 0%R with (Z2R 0%Z). apply Z2R_lt. omega.
(* Goal: @eq bool (is_nan prec emax (Bmult prec emax prec_gt_0_ Hmax mult_nan mode f (BofZ (Zpos (xO xH))))) false *)
    destruct (Bmult prec emax prec_gt_0_ Hmax mult_nan mode f (BofZ 2)); reflexivity || discriminate.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  + destruct H0 as (P & Q). apply B2FF_inj. rewrite P, H. auto.
- destruct f; try discriminate.
  + simpl Bplus. rewrite eqb_true. destruct (BofZ 2) eqn:B2; try discriminate; simpl in *.
(* Goal: @eq (Fappli_IEEE.binary_float prec emax) (B754_infinity prec emax b) (B754_nan prec emax (@fst bool (nan_pl prec) (mult_nan (B754_infinity prec emax b) (B754_zero prec emax b0))) (@snd bool (nan_pl prec) (mult_nan (B754_infinity prec emax b) (B754_zero prec emax b0)))) *)
(* Goal: @eq (Fappli_IEEE.binary_float prec emax) (B754_infinity prec emax b) (B754_infinity prec emax (xorb b b0)) *)
(* Goal: @eq bool b b *)
    assert ((0 = 2)%Z) by (apply eq_Z2R; auto). discriminate.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    subst b0. rewrite xorb_false_r. auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    auto.
  + unfold Bplus, Bmult. rewrite <- NAN by auto. auto.
Qed.

(** Divisions that can be turned into multiplications by an inverse *)

Definition Bexact_inverse_mantissa := Z.iter (prec - 1) xO xH.

Remark Bexact_inverse_mantissa_value:
  Zpos Bexact_inverse_mantissa = 2 ^ (prec - 1).
Proof.
(* Goal: @eq Z (Zpos Bexact_inverse_mantissa) (Z.pow (Zpos (xO xH)) (Z.sub prec (Zpos xH))) *)
  assert (REC: forall n, Z.pos (nat_rect _ xH (fun _ => xO) n) = 2 ^ (Z.of_nat n)).
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  { induction n. reflexivity.
(* Goal: @eq Z (Zpos (xO (nat_rect (fun _ : nat => positive) xH (fun _ : nat => xO) n))) (Z.mul (Zpos (xO xH)) (Zpos (nat_rect (fun _ : nat => positive) xH (fun _ : nat => xO) n))) *)
(* Goal: @eq Z (Z.mul (Zpos (xO xH)) (Zpos (nat_rect (fun _ : nat => positive) xH (fun _ : nat => xO) n))) (Z.pow (Zpos (xO xH)) (Z.of_nat (S n))) *)
    simpl nat_rect. transitivity (2 * Z.pos (nat_rect _ xH (fun _ => xO) n)). reflexivity.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
    rewrite Nat2Z.inj_succ. rewrite IHn. unfold Z.succ. rewrite Zpower_plus by omega.
    change (2 ^ 1) with 2. ring. }
(* Goal: @eq Z (Zpos (digits2_pos Bexact_inverse_mantissa)) prec *)
  red in prec_gt_0_.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  unfold Bexact_inverse_mantissa. rewrite iter_nat_of_Z by omega. rewrite REC.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite Zabs2Nat.id_abs. rewrite Z.abs_eq by omega. auto.
Qed.

Remark Bexact_inverse_mantissa_digits2_pos:
  Z.pos (digits2_pos Bexact_inverse_mantissa) = prec.
Proof.
  assert (DIGITS: forall n, digits2_pos (nat_rect _ xH (fun _ => xO) n) = Pos.of_nat (n+1)).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  { induction n; simpl. auto. rewrite IHn. destruct n; auto. }
(* Goal: @eq Z (Zpos (digits2_pos Bexact_inverse_mantissa)) prec *)
  red in prec_gt_0_.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  unfold Bexact_inverse_mantissa. rewrite iter_nat_of_Z by omega. rewrite DIGITS.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  rewrite Zabs2Nat.abs_nat_nonneg, Z2Nat.inj_sub by omega.
(* Goal: @eq (Fappli_IEEE.binary_float prec emax) (B754_infinity prec emax b) (B754_nan prec emax (@fst bool (nan_pl prec) (mult_nan (B754_infinity prec emax b) (B754_zero prec emax b0))) (@snd bool (nan_pl prec) (mult_nan (B754_infinity prec emax b) (B754_zero prec emax b0)))) *)
(* Goal: @eq (Fappli_IEEE.binary_float prec emax) (B754_infinity prec emax b) (B754_infinity prec emax (xorb b b0)) *)
(* Goal: @eq bool b b *)
  destruct prec; try  discriminate. rewrite Nat.sub_add.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  simpl. rewrite Pos2Nat.id. auto.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  simpl. zify; omega.
Qed.

Remark bounded_Bexact_inverse:
  forall e,
  emin <= e <= emax - prec <-> bounded prec emax Bexact_inverse_mantissa e = true.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. unfold bounded, canonic_mantissa. rewrite andb_true_iff.
  rewrite <- Zeq_is_eq_bool. rewrite <- Zle_is_le_bool.
(* Goal: iff (and (Z.le emin e) (Z.le e (Z.sub emax prec))) (and (@eq Z (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec (Z.add (Zpos (digits2_pos Bexact_inverse_mantissa)) e)) e) (Z.le e (Z.sub emax prec))) *)
  rewrite Bexact_inverse_mantissa_digits2_pos.
(* Goal: and (@eq bool (is_finite prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 m (cond_Zopp b (Zpos m0)) e b)) true) (@eq bool (Bsign prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 m (cond_Zopp b (Zpos m0)) e b)) b) *)
  split.
- intros; split. unfold FLT_exp. unfold emin in H. zify; omega. omega.
- intros [A B]. unfold FLT_exp in A. unfold emin. zify; omega.
Qed.

Program Definition Bexact_inverse (f: binary_float) : option binary_float :=
  match f with
  | B754_finite _ _ s m e B =>
      if Pos.eq_dec m Bexact_inverse_mantissa then
      let e' := -e - (prec - 1) * 2 in
      if Z_le_dec emin e' then
      if Z_le_dec e' emax then
        Some(B754_finite _ _ s m e' _)
      else None else None else None
  | _ => None
  end.
Next Obligation.
  rewrite <- bounded_Bexact_inverse in B. rewrite <- bounded_Bexact_inverse.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  unfold emin in *. omega.
Qed.

Lemma Bexact_inverse_correct:
  forall f f', Bexact_inverse f = Some f' ->
  is_finite_strict _ _ f = true
  /\ is_finite_strict _ _ f' = true
  /\ B2R _ _ f' = (/ B2R _ _ f)%R
  /\ B2R _ _ f <> 0%R
  /\ Bsign _ _ f' = Bsign _ _ f.
Proof with (try discriminate).
  intros f f' EI. unfold Bexact_inverse in EI. destruct f...
  destruct (Pos.eq_dec m Bexact_inverse_mantissa)...
  set (e' := -e - (prec - 1) * 2) in *.
  destruct (Z_le_dec emin e')...
  destruct (Z_le_dec e' emax)...
  inversion EI; clear EI; subst f' m.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  split. auto. split. auto. split. unfold B2R. rewrite Bexact_inverse_mantissa_value.
(* Goal: @eq R (Z2R n) (@F2R radix2 (Float radix2 n Z0)) *)
  unfold F2R; simpl. rewrite Z2R_cond_Zopp.
  rewrite <- ! cond_Ropp_mult_l.
(* Goal: @eq Z (Zpos (digits2_pos Bexact_inverse_mantissa)) prec *)
  red in prec_gt_0_.
  replace (Z2R (2 ^ (prec - 1))) with (bpow radix2 (prec - 1))
  by (symmetry; apply (Z2R_Zpower radix2); omega).
  rewrite <- ! bpow_plus.
  replace (prec - 1 + e') with (- (prec - 1 + e)) by (unfold e'; omega).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite bpow_opp. unfold cond_Ropp; destruct b; auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite Ropp_inv_permute. auto. apply Rgt_not_eq. apply bpow_gt_0.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  split. simpl. red; intros. apply F2R_eq_0_reg in H. destruct b; simpl in H; discriminate.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  auto.
Qed.

Theorem Bdiv_mult_inverse:
  forall div_nan mult_nan mode x y z,
  (forall (x y z: binary_float),
   is_nan _ _ x = true -> is_finite _ _ y = true -> is_finite _ _ z = true ->
   div_nan x y = mult_nan x z) ->
  Bexact_inverse y = Some z ->
  Bdiv _ _ _ Hmax div_nan mode x y = Bmult _ _ _ Hmax mult_nan mode x z.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros until z; intros NAN; intros. destruct (Bexact_inverse_correct _ _ H) as (A & B & C & D & E).
(* Goal: @eq (Fappli_IEEE.binary_float prec emax) (Bdiv prec emax prec_gt_0_ Hmax div_nan mode x y) (Bmult prec emax prec_gt_0_ Hmax mult_nan mode x z) *)
  pose proof (Bmult_correct _ _ _ Hmax mult_nan mode x z).
(* Goal: @eq (Fappli_IEEE.binary_float prec emax) (Bdiv prec emax prec_gt_0_ Hmax div_nan mode x y) (Bmult prec emax prec_gt_0_ Hmax mult_nan mode x z) *)
  fold emin in H0. fold fexp in H0.
(* Goal: @eq (Fappli_IEEE.binary_float prec emax) (Bdiv prec emax prec_gt_0_ Hmax div_nan mode x y) (Bmult prec emax prec_gt_0_ Hmax mult_nan mode x z) *)
  pose proof (Bdiv_correct _ _ _ Hmax div_nan mode x y D).
(* Goal: @eq (Fappli_IEEE.binary_float prec emax) (Bdiv prec emax prec_gt_0_ Hmax div_nan mode x y) (Bmult prec emax prec_gt_0_ Hmax mult_nan mode x z) *)
  fold emin in H1. fold fexp in H1.
  unfold Rdiv in H1. rewrite <- C in H1.
(* Goal: @eq (Fappli_IEEE.binary_float prec emax) (Bdiv prec emax prec_gt_0_ Hmax div_nan mode x y) (Bmult prec emax prec_gt_0_ Hmax mult_nan mode x z) *)
  destruct (is_finite _ _ x) eqn:FINX.
- destruct Rlt_bool.
  + destruct H0 as (P & Q & R). destruct H1 as (S & T & U).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    apply B2R_Bsign_inj; auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    rewrite Q. simpl. apply is_finite_strict_finite; auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    rewrite P, S. auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    rewrite R, U, E. auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    apply is_finite_not_is_nan; auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    apply is_finite_not_is_nan. rewrite Q. simpl. apply is_finite_strict_finite; auto.  + apply B2FF_inj. rewrite H0, H1. rewrite E. auto.
- destruct y; try discriminate. destruct z; try discriminate.
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m (B754_infinity prec1 emax1 b))) (B754_infinity prec1 emax1 b) *)
  destruct x; try discriminate; simpl.
  + simpl in E; congruence.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  + erewrite NAN; eauto.
Qed.

(** ** Conversion from scientific notation *)

(** Russian peasant exponentiation *)

Fixpoint pos_pow (x y: positive) : positive :=
  match y with
  | xH => x
  | xO y => Pos.square (pos_pow x y)
  | xI y => Pos.mul x (Pos.square (pos_pow x y))
  end.

Lemma pos_pow_spec:
  forall x y, Z.pos (pos_pow x y) = Z.pos x ^ Z.pos y.
Proof.
(* Goal: forall x y : positive, @eq Z (Zpos (pos_pow x y)) (Z.pow (Zpos x) (Zpos y)) *)
  intros x.
(* Goal: forall y : positive, @eq Z (Zpos (pos_pow x y)) (Z.pow (Zpos x) (Zpos y)) *)
  assert (REC: forall y a, Pos.iter (Pos.mul x) a y = Pos.mul (pos_pow x y) a).
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  { induction y; simpl; intros.
  - rewrite ! IHy, Pos.square_spec, ! Pos.mul_assoc. auto.
  - rewrite ! IHy, Pos.square_spec, ! Pos.mul_assoc. auto.
  - auto.
  }
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. simpl. rewrite <- Pos2Z.inj_pow_pos. unfold Pos.pow. rewrite REC. rewrite Pos.mul_1_r. auto.
Qed.

(** Given a base [base], a mantissa [m] and an exponent [e], the following function
  computes the FP number closest to [m * base ^ e], using round to odd, ties break to even.
  The algorithm is naive, computing [base ^ |e|] exactly before doing a multiplication or
  division with [m].  However, we treat specially very large or very small values of [e],
  when the result is known to be [+infinity] or [0.0] respectively. *)

Definition Bparse (base: positive) (m: positive) (e: Z): binary_float :=
  match e with
  | Z0 =>
     BofZ (Zpos m)
  | Zpos p =>
     if e * Z.log2 (Zpos base) <? emax
     then BofZ (Zpos m * Zpos (pos_pow base p))
     else B754_infinity _ _ false
  | Zneg p =>
     if e * Z.log2 (Zpos base) + Z.log2_up (Zpos m) <? emin
     then B754_zero _ _ false
     else FF2B prec emax _ (proj1 (Bdiv_correct_aux prec emax prec_gt_0_ Hmax mode_NE
                                     false m Z0 false (pos_pow base p) Z0))
  end.

(** Properties of [Z.log2] and [Z.log2_up]. *)

Lemma Zpower_log:
  forall (base: radix) n,
  0 < n ->
  2 ^ (n * Z.log2 base) <= base ^ n <= 2 ^ (n * Z.log2_up base).
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros.
(* Goal: and (Z.le (Z.pow (Zpos (xO xH)) (Z.mul n (Z.log2 (radix_val base)))) (Z.pow (radix_val base) n)) (Z.le (Z.pow (radix_val base) n) (Z.pow (Zpos (xO xH)) (Z.mul n (Z.log2_up (radix_val base))))) *)
  assert (A: 0 < base) by apply radix_gt_0.
(* Goal: and (Z.le (Z.pow (Zpos (xO xH)) (Z.mul n (Z.log2 (radix_val base)))) (Z.pow (radix_val base) n)) (Z.le (Z.pow (radix_val base) n) (Z.pow (Zpos (xO xH)) (Z.mul n (Z.log2_up (radix_val base))))) *)
  assert (B: 0 <= Z.log2 base) by apply Z.log2_nonneg.
(* Goal: and (Z.le (Z.pow (Zpos (xO xH)) (Z.mul n (Z.log2 (radix_val base)))) (Z.pow (radix_val base) n)) (Z.le (Z.pow (radix_val base) n) (Z.pow (Zpos (xO xH)) (Z.mul n (Z.log2_up (radix_val base))))) *)
  assert (C: 0 <= Z.log2_up base) by apply Z.log2_up_nonneg.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  destruct (Z.log2_spec base) as [D E]; auto.
(* Goal: and (Z.le (Z.pow (Zpos (xO xH)) (Z.mul n (Z.log2 (radix_val base)))) (Z.pow (radix_val base) n)) (Z.le (Z.pow (radix_val base) n) (Z.pow (Zpos (xO xH)) (Z.mul n (Z.log2_up (radix_val base))))) *)
  destruct (Z.log2_up_spec base) as [F G]. apply radix_gt_1.
(* Goal: and (Z.le (Z.pow (Zpos (xO xH)) (Z.mul n (Z.log2 (radix_val base)))) (Z.pow (radix_val base) n)) (Z.le (Z.pow (radix_val base) n) (Z.pow (Zpos (xO xH)) (Z.mul n (Z.log2_up (radix_val base))))) *)
  assert (K: 0 <= 2 ^ Z.log2 base) by (apply Z.pow_nonneg; omega).
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  rewrite ! (Z.mul_comm n). rewrite ! Z.pow_mul_r by omega.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  split; apply Z.pow_le_mono_l; omega.
Qed.

Lemma bpow_log_pos:
  forall (base: radix) n,
  0 < n ->
  (bpow radix2 (n * Z.log2 base)%Z <= bpow base n)%R.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. rewrite <- ! Z2R_Zpower. apply Z2R_le; apply Zpower_log; auto.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  omega.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  rewrite Z.mul_comm; apply Zmult_gt_0_le_0_compat. omega. apply Z.log2_nonneg.
Qed.

Lemma bpow_log_neg:
  forall (base: radix) n,
  n < 0 ->
  (bpow base n <= bpow radix2 (n * Z.log2 base)%Z)%R.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. set (m := -n). replace n with (-m) by (unfold m; omega).
(* Goal: Rle (bpow base (Z.opp m)) (bpow radix2 (Z.mul (Z.opp m) (Z.log2 (radix_val base)))) *)
  rewrite ! Z.mul_opp_l, ! bpow_opp. apply Rinv_le.
(* Goal: Rlt (IZR Z0) (bpow radix2 emax1) *)
(* Goal: Rlt (Rabs (@F2R radix2 (Float radix2 (cond_Zopp b (Zpos m0)) e))) (bpow radix2 emax1) *)
  apply bpow_gt_0.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  apply bpow_log_pos. unfold m; omega.
Qed.

(** Overflow and underflow conditions. *)

Lemma round_integer_overflow:
  forall (base: radix) e m,
  0 < e ->
  emax <= e * Z.log2 base ->
  (bpow radix2 emax <= round radix2 fexp (round_mode mode_NE) (Z2R (Zpos m) * bpow base e))%R.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros.
  rewrite <- (round_generic radix2 fexp (round_mode mode_NE) (bpow radix2 emax)); auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply round_le; auto. apply fexp_correct; auto. apply valid_rnd_round_mode.
  rewrite <- (Rmult_1_l (bpow radix2 emax)). apply Rmult_le_compat.
(* Goal: Rle (IZR Z0) (IZR (Zpos xH)) *)
  apply Rle_0_1.
(* Goal: Rle (IZR Z0) (bpow base e) *)
(* Goal: Rle (Z2R (Zpos m)) (bpow radix2 (Z.log2_up (Zpos m))) *)
(* Goal: Rle (bpow base e) (bpow radix2 (Z.mul e (Z.log2 (radix_val base)))) *)
  apply bpow_ge_0.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  apply (Z2R_le 1). zify; omega.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  eapply Rle_trans. eapply bpow_le. eassumption. apply bpow_log_pos; auto.
(* Goal: generic_format radix2 fexp (Z2R (Z.sub (Z.pow (Zpos (xO xH)) emax) (Z.pow (Zpos (xO xH)) (Z.sub emax prec)))) *)
(* Goal: Rle (Rabs (Z2R n)) (Z2R (Z.sub (Z.pow (Zpos (xO xH)) emax) (Z.pow (Zpos (xO xH)) (Z.sub emax prec)))) *)
(* Goal: Rlt (Z2R (Z.sub (Z.pow (Zpos (xO xH)) emax) (Z.pow (Zpos (xO xH)) (Z.sub emax prec)))) (bpow radix2 emax) *)
(* Goal: Valid_exp fexp *)
  apply generic_format_FLT. exists (Float radix2 1 emax).
(* Goal: @eq R (Z2R n) (@F2R radix2 (Float radix2 n Z0)) *)
  split. unfold F2R; simpl. ring.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  split. simpl. apply (Zpower_gt_1 radix2); auto.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  simpl. unfold emin; red in prec_gt_0_; omega.
Qed.

Lemma round_NE_underflows:
  forall x,
  (0 <= x <= bpow radix2 (emin - 1))%R ->
  round radix2 fexp (round_mode mode_NE) x = 0%R.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros.
  set (eps := bpow radix2 (emin - 1)) in *.
(* Goal: @eq R (round radix2 fexp (round_mode mode_NE) x) (IZR Z0) *)
  assert (A: round radix2 fexp (round_mode mode_NE) eps = 0%R).
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  { unfold round. simpl.
(* Goal: @eq R (@F2R radix2 (Float radix2 (Znearest (fun x : Z => negb (Zeven x)) (scaled_mantissa radix2 fexp eps)) (canonic_exp radix2 fexp eps))) (IZR Z0) *)
    assert (E: canonic_exp radix2 fexp eps = emin).
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
    { unfold canonic_exp, eps. rewrite ln_beta_bpow. unfold fexp, FLT_exp. zify; red in prec_gt_0_; omega. }
(* Goal: @eq full_float (binary_overflow prec emax mode (xorb (Bsign prec emax x) (Bsign prec emax y))) (binary_overflow prec emax mode (xorb (Bsign prec emax x) (Bsign prec emax z))) *)
    unfold scaled_mantissa; rewrite E.
    assert (P: (eps * bpow radix2 (-emin) = / 2)%R).
    { unfold eps. rewrite <- bpow_plus. replace (emin - 1 + -emin) with (-1) by omega. auto. }
(* Goal: @eq R (@F2R radix2 (Float radix2 (Znearest (fun x : Z => negb (Zeven x)) (Rmult eps (bpow radix2 (Z.opp emin)))) emin)) (IZR Z0) *)
    rewrite P. unfold Znearest.
(* Goal: @eq R (@F2R radix2 (Float radix2 match Rcompare (Rminus (Rinv (IZR (Zpos (xO xH)))) (Z2R (Zfloor (Rinv (IZR (Zpos (xO xH))))))) (Rinv (IZR (Zpos (xO xH)))) with | Eq => if negb (Zeven (Zfloor (Rinv (IZR (Zpos (xO xH)))))) then Zceil (Rinv (IZR (Zpos (xO xH)))) else Zfloor (Rinv (IZR (Zpos (xO xH)))) | Lt => Zfloor (Rinv (IZR (Zpos (xO xH)))) | Gt => Zceil (Rinv (IZR (Zpos (xO xH)))) end emin)) (IZR Z0) *)
    assert (F: Zfloor (/ 2)%R = 0).
(* Goal: and (Rle (IZR Z0) (Rinv (IZR (Zpos (xO xH))))) (Rlt (Rinv (IZR (Zpos (xO xH)))) (IZR (Zpos xH))) *)
    { apply Zfloor_imp. simpl. lra. }
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    rewrite F. change (Z2R 0) with 0%R. rewrite Rminus_0_r. rewrite Rcompare_Eq by auto.
(* Goal: @eq R (Z2R n) (@F2R radix2 (Float radix2 n Z0)) *)
    simpl. unfold F2R; simpl. apply Rmult_0_l.
  }
(* Goal: @eq R (round radix2 fexp (round_mode mode_NE) x) (IZR Z0) *)
  apply Rle_antisym.
- rewrite <- A. apply round_le. apply fexp_correct; auto. apply valid_rnd_round_mode. tauto.
- rewrite <- (round_0 radix2 fexp (round_mode mode_NE)).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply round_le. apply fexp_correct; auto. apply valid_rnd_round_mode. tauto.
Qed.

Lemma round_integer_underflow:
  forall (base: radix) e m,
  e < 0 ->
  e * Z.log2 base + Z.log2_up (Zpos m) < emin ->
  round radix2 fexp (round_mode mode_NE) (Z2R (Zpos m) * bpow base e) = 0%R.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. apply round_NE_underflows. split.
- apply Rmult_le_pos. apply (Z2R_le 0). zify; omega. apply bpow_ge_0.
- apply Rle_trans with (bpow radix2 (Z.log2_up (Z.pos m) + e * Z.log2 base)).
+ rewrite bpow_plus. apply Rmult_le_compat.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  apply (Z2R_le 0); zify; omega.
(* Goal: Rle (IZR Z0) (bpow base e) *)
(* Goal: Rle (Z2R (Zpos m)) (bpow radix2 (Z.log2_up (Zpos m))) *)
(* Goal: Rle (bpow base e) (bpow radix2 (Z.mul e (Z.log2 (radix_val base)))) *)
  apply bpow_ge_0.
  rewrite <- Z2R_Zpower. apply Z2R_le.
(* Goal: Z.le (Zpos m) (Z.pow (radix_val radix2) (Z.log2_up (Zpos m))) *)
(* Goal: Z.le Z0 (Z.log2_up (Zpos m)) *)
(* Goal: Rle (bpow base e) (bpow radix2 (Z.mul e (Z.log2 (radix_val base)))) *)
  destruct (Z.eq_dec (Z.pos m) 1).
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  rewrite e0. simpl. omega.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  apply Z.log2_up_spec. zify; omega.
(* Goal: Z.le Z0 (Z.log2_up (Zpos m)) *)
(* Goal: Rle (bpow base e) (bpow radix2 (Z.mul e (Z.log2 (radix_val base)))) *)
  apply Z.log2_up_nonneg.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply bpow_log_neg. auto.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
+ apply bpow_le. omega.
Qed.

(** Correctness of Bparse *)

Theorem Bparse_correct:
  forall b m e (BASE: 2 <= Zpos b),
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  let base := {| radix_val := Zpos b; radix_prop := Zle_imp_le_bool _ _ BASE |} in
  let r := round radix2 fexp (round_mode mode_NE) (Z2R (Zpos m) * bpow base e) in
  if Rlt_bool (Rabs r) (bpow radix2 emax) then
     B2R _ _ (Bparse b m e) = r
  /\ is_finite _ _ (Bparse b m e) = true
  /\ Bsign _ _ (Bparse b m e) = false
  else
    B2FF _ _ (Bparse b m e) = F754_infinity false.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros.
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  assert (A: forall x, @F2R radix2 {| Fnum := x; Fexp := 0 |} = Z2R x).
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  { intros. unfold F2R, Fnum; simpl. ring. }
(* Goal: if Rlt_bool (Rabs r) (bpow radix2 emax) then and (@eq R (B2R prec emax (Bparse b m e)) r) (and (@eq bool (is_finite prec emax (Bparse b m e)) true) (@eq bool (Bsign prec emax (Bparse b m e)) false)) else @eq full_float (B2FF prec emax (Bparse b m e)) (F754_infinity false) *)
  unfold Bparse, r. destruct e as [ | e | e].
- (* e = Z0 *)
(* Goal: @eq R (Z2R n) (Rmult (Z2R n) (IZR (Zpos xH))) *)
  change (bpow base 0) with 1%R. rewrite Rmult_1_r.
(* Goal: if Rlt_bool (Rabs (round radix2 fexp (round_mode mode_NE) (Z2R (Zpos m)))) (bpow radix2 emax) then and (@eq R (B2R prec emax (BofZ (Zpos m))) (round radix2 fexp (round_mode mode_NE) (Z2R (Zpos m)))) (and (@eq bool (is_finite prec emax (BofZ (Zpos m))) true) (@eq bool (Bsign prec emax (BofZ (Zpos m))) false)) else @eq full_float (B2FF prec emax (BofZ (Zpos m))) (F754_infinity false) *)
  exact (BofZ_correct (Z.pos m)).
- (* e = Zpos e *)
(* Goal: if Rlt_bool (Rabs (round radix2 fexp (round_mode mode_NE) (Rmult (Z2R (Zpos m)) (bpow base (Zpos e))))) (bpow radix2 emax) then and (@eq R (B2R prec emax (if Z.ltb (Z.mul (Zpos e) (Z.log2 (Zpos b))) emax then BofZ (Z.mul (Zpos m) (Zpos (pos_pow b e))) else B754_infinity prec emax false)) (round radix2 fexp (round_mode mode_NE) (Rmult (Z2R (Zpos m)) (bpow base (Zpos e))))) (and (@eq bool (is_finite prec emax (if Z.ltb (Z.mul (Zpos e) (Z.log2 (Zpos b))) emax then BofZ (Z.mul (Zpos m) (Zpos (pos_pow b e))) else B754_infinity prec emax false)) true) (@eq bool (Bsign prec emax (if Z.ltb (Z.mul (Zpos e) (Z.log2 (Zpos b))) emax then BofZ (Z.mul (Zpos m) (Zpos (pos_pow b e))) else B754_infinity prec emax false)) false)) else @eq full_float (B2FF prec emax (if Z.ltb (Z.mul (Zpos e) (Z.log2 (Zpos b))) emax then BofZ (Z.mul (Zpos m) (Zpos (pos_pow b e))) else B754_infinity prec emax false)) (F754_infinity false) *)
  destruct (Z.ltb_spec (Z.pos e * Z.log2 (Z.pos b)) emax).
+ (* no overflow *)
  rewrite pos_pow_spec. rewrite <- Z2R_Zpower by (zify; omega). rewrite <- Z2R_mult.
(* Goal: if Rlt_bool (Rabs (round radix2 fexp (round_mode mode_NE) (Z2R (Z.mul (Zpos m) (Z.pow (radix_val base) (Zpos e)))))) (bpow radix2 emax) then and (@eq R (B2R prec emax (BofZ (Z.mul (Zpos m) (Z.pow (Zpos b) (Zpos e))))) (round radix2 fexp (round_mode mode_NE) (Z2R (Z.mul (Zpos m) (Z.pow (radix_val base) (Zpos e)))))) (and (@eq bool (is_finite prec emax (BofZ (Z.mul (Zpos m) (Z.pow (Zpos b) (Zpos e))))) true) (@eq bool (Bsign prec emax (BofZ (Z.mul (Zpos m) (Z.pow (Zpos b) (Zpos e))))) false)) else @eq full_float (B2FF prec emax (BofZ (Z.mul (Zpos m) (Z.pow (Zpos b) (Zpos e))))) (F754_infinity false) *)
  replace false with (Z.pos m * Z.pos b ^ Z.pos e <? 0).
(* Goal: if Rlt_bool (Rabs (round radix2 fexp (round_mode mode_NE) (Z2R (Z.mul (Zpos m) (Z.pow (radix_val base) (Zpos e)))))) (bpow radix2 emax) then and (@eq R (B2R prec emax (BofZ (Z.mul (Zpos m) (Z.pow (Zpos b) (Zpos e))))) (round radix2 fexp (round_mode mode_NE) (Z2R (Z.mul (Zpos m) (Z.pow (radix_val base) (Zpos e)))))) (and (@eq bool (is_finite prec emax (BofZ (Z.mul (Zpos m) (Z.pow (Zpos b) (Zpos e))))) true) (@eq bool (Bsign prec emax (BofZ (Z.mul (Zpos m) (Z.pow (Zpos b) (Zpos e))))) (Z.ltb (Z.mul (Zpos m) (Z.pow (Zpos b) (Zpos e))) Z0))) else @eq full_float (B2FF prec emax (BofZ (Z.mul (Zpos m) (Z.pow (Zpos b) (Zpos e))))) (F754_infinity (Z.ltb (Z.mul (Zpos m) (Z.pow (Zpos b) (Zpos e))) Z0)) *)
(* Goal: @eq bool (Z.ltb (Z.mul (Zpos m) (Z.pow (Zpos b) (Zpos e))) Z0) false *)
  exact (BofZ_correct (Z.pos m * Z.pos b ^ Z.pos e)).
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  rewrite Z.ltb_ge. rewrite Z.mul_comm. apply Zmult_gt_0_le_0_compat. zify; omega.  apply (Zpower_ge_0 base).
+ (* overflow *)
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite Rlt_bool_false. auto. eapply Rle_trans; [idtac|apply Rle_abs].
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply (round_integer_overflow base). zify; omega. auto.
- (* e = Zneg e *)
  destruct (Z.ltb_spec (Z.neg e * Z.log2 (Z.pos b) + Z.log2_up (Z.pos m)) emin).
+ (* undeflow *)
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite round_integer_underflow; auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite Rlt_bool_true. auto.
(* Goal: Rlt (IZR Z0) (bpow radix2 emax1) *)
(* Goal: Rlt (Rabs (@F2R radix2 (Float radix2 (cond_Zopp b (Zpos m0)) e))) (bpow radix2 emax1) *)
  replace (Rabs 0)%R with 0%R. apply bpow_gt_0. apply (Z2R_abs 0).
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
  zify; omega.
+ (* no underflow *)
(* Goal: if Rlt_bool (Rabs (round radix2 fexp (round_mode mode_NE) (Rmult (Z2R (Zpos m)) (bpow base (Zneg e))))) (bpow radix2 emax) then and (@eq R (B2R prec emax (FF2B prec emax match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end (@proj1 (@eq bool (valid_binary prec emax match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end) true) (@eq bool (sign_FF match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end) (xorb false false))) else @eq full_float match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end (binary_overflow prec emax mode_NE (xorb false false))) (Bdiv_correct_aux prec emax prec_gt_0_ Hmax mode_NE false m Z0 false (pos_pow b e) Z0)))) (round radix2 fexp (round_mode mode_NE) (Rmult (Z2R (Zpos m)) (bpow base (Zneg e))))) (and (@eq bool (is_finite prec emax (FF2B prec emax match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end (@proj1 (@eq bool (valid_binary prec emax match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end) true) (@eq bool (sign_FF match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end) (xorb false false))) else @eq full_float match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end (binary_overflow prec emax mode_NE (xorb false false))) (Bdiv_correct_aux prec emax prec_gt_0_ Hmax mode_NE false m Z0 false (pos_pow b e) Z0)))) true) (@eq bool (Bsign prec emax (FF2B prec emax match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end (@proj1 (@eq bool (valid_binary prec emax match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end) true) (@eq bool (sign_FF match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end) (xorb false false))) else @eq full_float match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end (binary_overflow prec emax mode_NE (xorb false false))) (Bdiv_correct_aux prec emax prec_gt_0_ Hmax mode_NE false m Z0 false (pos_pow b e) Z0)))) false)) else @eq full_float (B2FF prec emax (FF2B prec emax match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end (@proj1 (@eq bool (valid_binary prec emax match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end) true) (@eq bool (sign_FF match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end) (xorb false false))) else @eq full_float match Fdiv_core_binary prec (Zpos m) Z0 (Zpos (pos_pow b e)) Z0 with | pair (pair (Z0 as mz) ez as p) lz => F754_nan false xH | pair (pair (Zpos mz0 as mz) ez as p) lz => binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz | pair (pair (Zneg p0 as mz) ez as p) lz => F754_nan false xH end (binary_overflow prec emax mode_NE (xorb false false))) (Bdiv_correct_aux prec emax prec_gt_0_ Hmax mode_NE false m Z0 false (pos_pow b e) Z0)))) (F754_infinity false) *)
  generalize (Bdiv_correct_aux prec emax prec_gt_0_ Hmax mode_NE false m 0 false (pos_pow b e) 0).
  set (f := match Fdiv_core_binary prec (Z.pos m) 0 (Z.pos (pos_pow b e)) 0 with
      | (0, _, _) => F754_nan false 1
      | (Z.pos mz0, ez, lz) =>
          binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz
      | (Z.neg _, _, _) => F754_nan false 1
      end).
(* Goal: forall a : let x := @F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0) in let y := @F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0) in let z := f in and (@eq bool (valid_binary prec emax z) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv x y))) (bpow radix2 emax) then and (@eq R (FF2R radix2 z) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv x y))) (and (@eq bool (is_finite_FF z) true) (@eq bool (sign_FF z) (xorb false false))) else @eq full_float z (binary_overflow prec emax mode_NE (xorb false false))), if Rlt_bool (Rabs (round radix2 fexp (round_mode mode_NE) (Rmult (Z2R (Zpos m)) (bpow base (Zneg e))))) (bpow radix2 emax) then and (@eq R (B2R prec emax (FF2B prec emax f (@proj1 (@eq bool (valid_binary prec emax f) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 f) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF f) true) (@eq bool (sign_FF f) (xorb false false))) else @eq full_float f (binary_overflow prec emax mode_NE (xorb false false))) a))) (round radix2 fexp (round_mode mode_NE) (Rmult (Z2R (Zpos m)) (bpow base (Zneg e))))) (and (@eq bool (is_finite prec emax (FF2B prec emax f (@proj1 (@eq bool (valid_binary prec emax f) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 f) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF f) true) (@eq bool (sign_FF f) (xorb false false))) else @eq full_float f (binary_overflow prec emax mode_NE (xorb false false))) a))) true) (@eq bool (Bsign prec emax (FF2B prec emax f (@proj1 (@eq bool (valid_binary prec emax f) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 f) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF f) true) (@eq bool (sign_FF f) (xorb false false))) else @eq full_float f (binary_overflow prec emax mode_NE (xorb false false))) a))) false)) else @eq full_float (B2FF prec emax (FF2B prec emax f (@proj1 (@eq bool (valid_binary prec emax f) true) (if Rlt_bool (Rabs (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (bpow radix2 emax) then and (@eq R (FF2R radix2 f) (round radix2 (FLT_exp (Z.sub (Z.sub (Zpos (xI xH)) emax) prec) prec) (round_mode mode_NE) (Rdiv (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m)) Z0)) (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos (pos_pow b e))) Z0))))) (and (@eq bool (is_finite_FF f) true) (@eq bool (sign_FF f) (xorb false false))) else @eq full_float f (binary_overflow prec emax mode_NE (xorb false false))) a))) (F754_infinity false) *)
  fold emin; fold fexp. rewrite ! A. unfold cond_Zopp. rewrite pos_pow_spec.
  assert (B: (Z2R (Z.pos m) / Z2R (Z.pos b ^ Z.pos e) =
              Z2R (Z.pos m) * bpow base (Z.neg e))%R).
  { change (Z.neg e) with (- (Z.pos e)). rewrite bpow_opp. auto. }
(* Goal: @eq (option Z) (if is_finite prec2 emax2 (Bconv conv_nan m f) then @Some Z (Ztrunc (B2R prec2 emax2 (Bconv conv_nan m f))) else @None Z) (@Some Z (Ztrunc (B2R prec1 emax1 f))) *)
  rewrite B. intros [P Q].
  destruct (Rlt_bool
     (Rabs
        (round radix2 fexp (round_mode mode_NE)
           (Z2R (Z.pos m) * bpow base (Z.neg e))))
    (bpow radix2 emax)).
* destruct Q as (Q1 & Q2 & Q3).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  split. rewrite B2R_FF2B, Q1. auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  split. rewrite is_finite_FF2B. auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite Bsign_FF2B. auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
* rewrite B2FF_FF2B. auto.
Qed.

End Extra_ops.

(** ** Conversions between two FP formats *)

Section Conversions.

Variable prec1 emax1 prec2 emax2 : Z.
Context (prec1_gt_0_ : Prec_gt_0 prec1) (prec2_gt_0_ : Prec_gt_0 prec2).
Let emin1 := (3 - emax1 - prec1)%Z.
Let fexp1 := FLT_exp emin1 prec1.
Let emin2 := (3 - emax2 - prec2)%Z.
Let fexp2 := FLT_exp emin2 prec2.
Hypothesis Hmax1 : (prec1 < emax1)%Z.
Hypothesis Hmax2 : (prec2 < emax2)%Z.
Let binary_float1 := binary_float prec1 emax1.
Let binary_float2 := binary_float prec2 emax2.

Definition Bconv (conv_nan: bool -> nan_pl prec1 -> bool * nan_pl prec2) (md: mode) (f: binary_float1) : binary_float2 :=
  match f with
    | B754_nan _ _ s pl => let '(s, pl) := conv_nan s pl in B754_nan _ _ s pl
    | B754_infinity _ _ s => B754_infinity _ _ s
    | B754_zero _ _ s => B754_zero _ _ s
    | B754_finite _ _ s m e _ => binary_normalize _ _ _ Hmax2 md (cond_Zopp s (Zpos m)) e s
  end.

Theorem Bconv_correct:
  forall conv_nan m f,
  is_finite _ _ f = true ->
  if Rlt_bool (Rabs (round radix2 fexp2 (round_mode m) (B2R _ _ f))) (bpow radix2 emax2)
  then
     B2R _ _ (Bconv conv_nan m f) = round radix2 fexp2 (round_mode m) (B2R _ _ f)
  /\ is_finite _ _ (Bconv conv_nan m f) = true
  /\ Bsign _ _ (Bconv conv_nan m f) = Bsign _ _ f
  else
     B2FF _ _ (Bconv conv_nan m f) = binary_overflow prec2 emax2 m (Bsign _ _ f).
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. destruct f; try discriminate.
- simpl. rewrite round_0. rewrite Rabs_R0. rewrite Rlt_bool_true. auto.
(* Goal: Valid_rnd (round_mode m) *)
(* Goal: generic_format radix2 fexp1 (B2R prec1 emax1 f) *)
  apply bpow_gt_0. apply valid_rnd_round_mode.
- generalize (binary_normalize_correct _ _ _ Hmax2 m (cond_Zopp b (Zpos m0)) e b).
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m (B754_infinity prec1 emax1 b))) (B754_infinity prec1 emax1 b) *)
  fold emin2; fold fexp2. simpl. destruct Rlt_bool.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  + intros (A & B & C). split. auto. split. auto. rewrite C.
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m (B754_infinity prec1 emax1 b))) (B754_infinity prec1 emax1 b) *)
    destruct b; simpl.
(* Goal: Rlt (@F2R radix2 (Float radix2 (cond_Zopp true (Zpos m0)) e)) (IZR Z0) *)
(* Goal: @eq bool (Rlt_bool (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m0)) e)) (IZR Z0)) false *)
    rewrite Rcompare_Lt. auto. apply F2R_lt_0_compat. simpl. compute; auto.
(* Goal: Z.lt Z0 (Zpos m0) *)
    rewrite Rcompare_Gt. auto. apply F2R_gt_0_compat. simpl. compute; auto.
(* Goal: @eq full_float (binary_overflow prec2 emax2 mode_NE (Z.ltb n Z0)) (binary_overflow prec2 emax2 mode_NE (Rlt_bool (Z2R n) (IZR Z0))) *)
  + intros A. rewrite A. f_equal. destruct b.
(* Goal: Rlt (@F2R radix2 (Float radix2 (cond_Zopp true (Zpos m0)) e)) (IZR Z0) *)
(* Goal: @eq bool (Rlt_bool (@F2R radix2 (Float radix2 (cond_Zopp false (Zpos m0)) e)) (IZR Z0)) false *)
    apply Rlt_bool_true. apply F2R_lt_0_compat. simpl. compute; auto.
(* Goal: Z.lt Z0 (Zpos m0) *)
    apply Rlt_bool_false. apply Rlt_le. apply Rgt_lt. apply F2R_gt_0_compat. simpl. compute; auto.
Qed.

(** Converting a finite FP number to higher or equal precision preserves its value. *)

Theorem Bconv_widen_exact:
  (prec2 >= prec1)%Z -> (emax2 >= emax1)%Z ->
  forall conv_nan m f,
  is_finite _ _ f = true ->
     B2R _ _ (Bconv conv_nan m f) = B2R _ _ f
  /\ is_finite _ _ (Bconv conv_nan m f) = true
  /\ Bsign _ _ (Bconv conv_nan m f) = Bsign _ _ f.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros PREC EMAX; intros. generalize (Bconv_correct conv_nan m f H).
  assert (LT: (Rabs (B2R _ _ f) < bpow radix2 emax2)%R).
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  {
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m (B754_infinity prec1 emax1 b))) (B754_infinity prec1 emax1 b) *)
    destruct f; try discriminate; simpl.
(* Goal: Rlt (IZR Z0) (bpow radix2 emax1) *)
(* Goal: Rlt (Rabs (@F2R radix2 (Float radix2 (cond_Zopp b (Zpos m0)) e))) (bpow radix2 emax1) *)
    rewrite Rabs_R0. apply bpow_gt_0.
    apply Rlt_le_trans with (bpow radix2 emax1).
    rewrite F2R_cond_Zopp. rewrite abs_cond_Ropp. rewrite <- F2R_Zabs. simpl Z.abs.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    eapply bounded_lt_emax; eauto.
(* Goal: Z.le (Z.add (Z.log2_up (Zpos m)) (Z.mul e (Z.log2 (radix_val base)))) (Z.sub emin (Zpos xH)) *)
    apply bpow_le. omega.
  }
  assert (EQ: round radix2 fexp2 (round_mode m) (B2R prec1 emax1 f) = B2R prec1 emax1 f).
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  {
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
    apply round_generic. apply valid_rnd_round_mode. eapply generic_inclusion_le.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    5: apply generic_format_B2R. apply fexp_correct; auto. apply fexp_correct; auto.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
    instantiate (1 := emax2). intros. unfold fexp2, FLT_exp. unfold emin2. zify; omega.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
    apply Rlt_le; auto.
  }
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite EQ. rewrite Rlt_bool_true by auto. auto.
Qed.

(** Conversion from integers and change of format *)

Theorem Bconv_BofZ:
  forall conv_nan n,
  integer_representable prec1 emax1 n ->
  Bconv conv_nan mode_NE (BofZ prec1 emax1 _ Hmax1 n) = BofZ prec2 emax2 _ Hmax2 n.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros.
(* Goal: @eq binary_float2 (Bconv conv_nan mode_NE (BofZ prec1 emax1 prec1_gt_0_ Hmax1 n)) (BofZ prec2 emax2 prec2_gt_0_ Hmax2 n) *)
  destruct (BofZ_representable _ _ _ Hmax1 n H) as (A & B & C).
  set (f := BofZ prec1 emax1 prec1_gt_0_ Hmax1 n) in *.
(* Goal: @eq binary_float2 (Bconv conv_nan mode_NE f) (BofZ prec2 emax2 prec2_gt_0_ Hmax2 n) *)
  generalize (Bconv_correct conv_nan mode_NE f B).
(* Goal: forall _ : if Rlt_bool (Rabs (round radix2 fexp2 (round_mode mode_NE) (B2R prec1 emax1 f))) (bpow radix2 emax2) then and (@eq R (B2R prec2 emax2 (Bconv conv_nan mode_NE f)) (round radix2 fexp2 (round_mode mode_NE) (B2R prec1 emax1 f))) (and (@eq bool (is_finite prec2 emax2 (Bconv conv_nan mode_NE f)) true) (@eq bool (Bsign prec2 emax2 (Bconv conv_nan mode_NE f)) (Bsign prec1 emax1 f))) else @eq full_float (B2FF prec2 emax2 (Bconv conv_nan mode_NE f)) (binary_overflow prec2 emax2 mode_NE (Bsign prec1 emax1 f)), @eq binary_float2 (Bconv conv_nan mode_NE f) (BofZ prec2 emax2 prec2_gt_0_ Hmax2 n) *)
  unfold BofZ.
(* Goal: forall _ : if Rlt_bool (Rabs (round radix2 fexp2 (round_mode mode_NE) (B2R prec1 emax1 f))) (bpow radix2 emax2) then and (@eq R (B2R prec2 emax2 (Bconv conv_nan mode_NE f)) (round radix2 fexp2 (round_mode mode_NE) (B2R prec1 emax1 f))) (and (@eq bool (is_finite prec2 emax2 (Bconv conv_nan mode_NE f)) true) (@eq bool (Bsign prec2 emax2 (Bconv conv_nan mode_NE f)) (Bsign prec1 emax1 f))) else @eq full_float (B2FF prec2 emax2 (Bconv conv_nan mode_NE f)) (binary_overflow prec2 emax2 mode_NE (Bsign prec1 emax1 f)), @eq binary_float2 (Bconv conv_nan mode_NE f) (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false) *)
  generalize (binary_normalize_correct _ _ _ Hmax2 mode_NE n 0 false).
(* Goal: @eq (option Z) (@Some Z (Ztrunc (B2R prec2 emax2 (Bconv conv_nan m f)))) (@Some Z (Ztrunc (B2R prec1 emax1 f))) *)
  fold emin2; fold fexp2. rewrite A.
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  replace (F2R {| Fnum := n; Fexp := 0 |}) with (Z2R n).
(* Goal: forall (_ : if Rlt_bool (Rabs (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (bpow radix2 emax2) then and (@eq R (B2R prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (and (@eq bool (is_finite prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) true) (@eq bool (Bsign prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) match Rcompare (Z2R n) (IZR Z0) with | Eq => false | Lt => true | Gt => false end)) else @eq full_float (B2FF prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) (binary_overflow prec2 emax2 mode_NE (Rlt_bool (Z2R n) (IZR Z0)))) (_ : if Rlt_bool (Rabs (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (bpow radix2 emax2) then and (@eq R (B2R prec2 emax2 (Bconv conv_nan mode_NE f)) (round radix2 fexp2 (round_mode mode_NE) (Z2R n))) (and (@eq bool (is_finite prec2 emax2 (Bconv conv_nan mode_NE f)) true) (@eq bool (Bsign prec2 emax2 (Bconv conv_nan mode_NE f)) (Bsign prec1 emax1 f))) else @eq full_float (B2FF prec2 emax2 (Bconv conv_nan mode_NE f)) (binary_overflow prec2 emax2 mode_NE (Bsign prec1 emax1 f))), @eq binary_float2 (Bconv conv_nan mode_NE f) (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false) *)
(* Goal: @eq R (Z2R n) (@F2R radix2 (Float radix2 n Z0)) *)
  destruct Rlt_bool.
- intros (P & Q & R) (D & E & F). apply B2R_Bsign_inj; auto.
(* Goal: @eq bool (Z.ltb n Z0) (Rlt_bool (Z2R n) (IZR Z0)) *)
  congruence. rewrite F, C, R. change 0%R with (Z2R 0). rewrite Rcompare_Z2R.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  unfold Z.ltb. auto.
- intros P Q. apply B2FF_inj. rewrite P, Q. rewrite C. f_equal. change 0%R with (Z2R 0).
(* Goal: @eq bool (Z.ltb n Z0) (Rlt_bool (Z2R n) (Z2R Z0)) *)
  generalize (Zlt_bool_spec n 0); intros LT; inversion LT.
(* Goal: @eq bool true (Rlt_bool (Z2R n) (Z2R Z0)) *)
(* Goal: @eq bool false (Rlt_bool (Z2R n) (Z2R Z0)) *)
  rewrite Rlt_bool_true; auto. apply Z2R_lt; auto.
(* Goal: @eq bool false (Rlt_bool (Z2R n) (Z2R Z0)) *)
  rewrite Rlt_bool_false; auto. apply Z2R_le; auto.
- unfold F2R; simpl. rewrite Rmult_1_r. auto.
Qed.

(** Change of format (to higher precision) and conversion to integer. *)

Theorem ZofB_Bconv:
  prec2 >= prec1 -> emax2 >= emax1 ->
  forall conv_nan m f n,
  ZofB _ _ f = Some n -> ZofB _ _ (Bconv conv_nan m f) = Some n.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. rewrite ZofB_correct in H1. destruct (is_finite _ _ f) eqn:FIN; inversion H1.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  destruct (Bconv_widen_exact H H0 conv_nan m f) as (A & B & C). auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite ZofB_correct. rewrite B. rewrite A. auto.
Qed.

Theorem ZofB_range_Bconv:
  forall min1 max1 min2 max2,
  prec2 >= prec1 -> emax2 >= emax1 -> min2 <= min1 -> max1 <= max2 ->
  forall conv_nan m f n,
  ZofB_range _ _ f min1 max1 = Some n ->
  ZofB_range _ _ (Bconv conv_nan m f) min2 max2 = Some n.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros.
(* Goal: @eq (option Z) (ZofB_range prec2 emax2 (Bconv conv_nan m f) min2 max2) (@Some Z n) *)
  destruct (ZofB_range_inversion _ _ _ _ _ _ H3) as (A & B & C).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  unfold ZofB_range. erewrite ZofB_Bconv by eauto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite ! Zle_bool_true by omega. auto.
Qed.

(** Change of format (to higher precision) and comparison. *)

Theorem Bcompare_Bconv_widen:
  prec2 >= prec1 -> emax2 >= emax1 ->
  forall conv_nan m x y,
  Bcompare _ _ (Bconv conv_nan m x) (Bconv conv_nan m y) = Bcompare _ _ x y.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. destruct (is_finite _ _ x && is_finite _ _ y) eqn:FIN.
- apply andb_true_iff in FIN. destruct FIN.
(* Goal: @eq (option comparison) (Bcompare prec2 emax2 (Bconv conv_nan m x) (Bconv conv_nan m y)) (Bcompare prec1 emax1 x y) *)
  destruct (Bconv_widen_exact H H0 conv_nan m x H1) as (A & B & C).
(* Goal: @eq (option comparison) (Bcompare prec2 emax2 (Bconv conv_nan m x) (Bconv conv_nan m y)) (Bcompare prec1 emax1 x y) *)
  destruct (Bconv_widen_exact H H0 conv_nan m y H2) as (D & E & F).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  rewrite ! Bcompare_correct by auto. rewrite A, D. auto.
- generalize (Bconv_widen_exact H H0 conv_nan m x)
(* Goal: forall (_ : @eq full_float (B2FF prec2 emax2 (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false)) (binary_overflow prec2 emax2 mode_NE (Rlt_bool (Z2R n) (IZR Z0)))) (_ : @eq full_float (B2FF prec2 emax2 (Bconv conv_nan mode_NE f)) (binary_overflow prec2 emax2 mode_NE (Bsign prec1 emax1 f))), @eq binary_float2 (Bconv conv_nan mode_NE f) (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 mode_NE n Z0 false) *)
             (Bconv_widen_exact H H0 conv_nan m y); intros P Q.
  destruct x, y; try discriminate; simpl in P, Q; simpl;
  repeat (match goal with |- context [conv_nan ?b ?pl] => destruct (conv_nan b pl) end);
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  destruct Q as (D & E & F); auto.
  destruct (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 m (cond_Zopp b0 (Z.pos m0)) e b0);
(* Goal: @eq Z (Zpos (xO (nat_rect (fun _ : nat => positive) xH (fun _ : nat => xO) n))) (Z.mul (Zpos (xO xH)) (Zpos (nat_rect (fun _ : nat => positive) xH (fun _ : nat => xO) n))) *)
(* Goal: @eq Z (Z.mul (Zpos (xO xH)) (Zpos (nat_rect (fun _ : nat => positive) xH (fun _ : nat => xO) n))) (Z.pow (Zpos (xO xH)) (Z.of_nat (S n))) *)
  discriminate || reflexivity.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  destruct P as (A & B & C); auto.
  destruct (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 m (cond_Zopp b (Z.pos m0)) e b);
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  try discriminate; simpl. destruct b; auto. destruct b, b1; auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  destruct P as (A & B & C); auto.
  destruct (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 m (cond_Zopp b (Z.pos m0)) e b);
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  try discriminate; simpl. destruct b; auto.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  destruct b, b2; auto.
Qed.

End Conversions.

Section Compose_Conversions.

Variable prec1 emax1 prec2 emax2 : Z.
Context (prec1_gt_0_ : Prec_gt_0 prec1) (prec2_gt_0_ : Prec_gt_0 prec2).
Let emin1 := (3 - emax1 - prec1)%Z.
Let fexp1 := FLT_exp emin1 prec1.
Let emin2 := (3 - emax2 - prec2)%Z.
Let fexp2 := FLT_exp emin2 prec2.
Hypothesis Hmax1 : (prec1 < emax1)%Z.
Hypothesis Hmax2 : (prec2 < emax2)%Z.
Let binary_float1 := binary_float prec1 emax1.
Let binary_float2 := binary_float prec2 emax2.

(** Converting to a higher precision then down to the original format
    is the identity. *)
Theorem Bconv_narrow_widen:
  prec2 >= prec1 -> emax2 >= emax1 ->
  forall narrow_nan widen_nan m f,
  is_nan _ _ f = false ->
  Bconv prec2 emax2 prec1 emax1 _ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 _ Hmax2 widen_nan m f) = f.
Proof.
(* Goal: forall (_ : Z.ge prec2 prec1) (_ : Z.ge emax2 emax1) (narrow_nan : forall (_ : bool) (_ : nan_pl prec2), prod bool (nan_pl prec1)) (widen_nan : forall (_ : bool) (_ : nan_pl prec1), prod bool (nan_pl prec2)) (m : mode) (f : binary_float prec1 emax1) (_ : @eq bool (is_nan prec1 emax1 f) false), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  intros. destruct (is_finite _ _ f) eqn:FIN.
- assert (EQ: round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f) = B2R prec1 emax1 f).
(* Goal: @eq R (round radix2 fexp1 (round_mode m) (B2R prec1 emax1 f)) (B2R prec1 emax1 f) *)
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  { apply round_generic. apply valid_rnd_round_mode. apply generic_format_B2R. }
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  generalize (Bconv_widen_exact _ _ _ _ _ _ Hmax2 H H0 widen_nan m f FIN).
(* Goal: forall _ : and (@eq R (B2R prec2 emax2 (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) (B2R prec1 emax1 f)) (and (@eq bool (is_finite prec2 emax2 (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) true) (@eq bool (Bsign prec2 emax2 (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) (Bsign prec1 emax1 f))), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m f)) f *)
  set (f' := Bconv prec1 emax1 prec2 emax2 _ Hmax2 widen_nan m f).
(* Goal: forall _ : and (@eq R (B2R prec2 emax2 f') (B2R prec1 emax1 f)) (and (@eq bool (is_finite prec2 emax2 f') true) (@eq bool (Bsign prec2 emax2 f') (Bsign prec1 emax1 f))), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m f') f *)
  intros (A & B & C).
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m f') f *)
  generalize (Bconv_correct _ _ _ _ _ Hmax1 narrow_nan m f' B).
(* Goal: forall _ : if Rlt_bool (Rabs (B2R prec1 emax1 f)) (bpow radix2 emax1) then and (@eq R (B2R prec1 emax1 (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m f')) (B2R prec1 emax1 f)) (and (@eq bool (is_finite prec1 emax1 (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m f')) true) (@eq bool (Bsign prec1 emax1 (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m f')) (Bsign prec1 emax1 f))) else @eq full_float (B2FF prec1 emax1 (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m f')) (binary_overflow prec1 emax1 m (Bsign prec1 emax1 f)), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m f') f *)
  fold emin1. fold fexp1. rewrite A, C, EQ. rewrite Rlt_bool_true.
(* Goal: forall _ : and (@eq R (B2R prec1 emax1 (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m f')) (B2R prec1 emax1 f)) (and (@eq bool (is_finite prec1 emax1 (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m f')) true) (@eq bool (Bsign prec1 emax1 (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m f')) (Bsign prec1 emax1 f))), @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m f') f *)
(* Goal: Rlt (Rabs (B2R prec1 emax1 f)) (bpow radix2 emax1) *)
  intros (D & E & F).
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  apply B2R_Bsign_inj; auto.
(* Goal: @eq (binary_float prec1 emax1) (Bconv prec2 emax2 prec1 emax1 prec1_gt_0_ Hmax1 narrow_nan m (Bconv prec1 emax1 prec2 emax2 prec2_gt_0_ Hmax2 widen_nan m (B754_infinity prec1 emax1 b))) (B754_infinity prec1 emax1 b) *)
  destruct f; try discriminate; simpl.
(* Goal: Rlt (IZR Z0) (bpow radix2 emax1) *)
(* Goal: Rlt (Rabs (@F2R radix2 (Float radix2 (cond_Zopp b (Zpos m0)) e))) (bpow radix2 emax1) *)
  rewrite Rabs_R0. apply bpow_gt_0.
  rewrite F2R_cond_Zopp. rewrite abs_cond_Ropp. rewrite <- F2R_Zabs. simpl Z.abs.
(* Goal: @eq (binary_float prec1 emax1) (B754_infinity prec1 emax1 b) (B754_infinity prec1 emax1 b) *)
  eapply bounded_lt_emax; eauto.
- destruct f; try discriminate. simpl. auto.
Qed.

End Compose_Conversions.
