Require Import Coq.Lists.List.
Require Import Coq.Arith.Arith.
Require Import Coq.QArith.Qfield.
Require Import Lex.
Require Import Prefix.
Require Import Shorthand.

Local Open Scope nat.

(*Fixpoint repeat (n : nat) (b : bool) : LB :=
  match n with
      | 0 => nil
      | S n' => b :: (repeat n' b)
  end.

Todo: merge with repeat.v *)
Fixpoint repeat {A} (n : nat) (a : A) : list A :=
  match n with
    | 0 => nil
    | (S n) => a :: repeat n a
  end.

Lemma rep_length : forall {A} n (b : A), ll (repeat n b) = n.
Proof.
  intros A n b.
  induction n.
  compute.
  auto.
  replace (repeat (S n) b) with (b :: (repeat n b)).
  replace (Datatypes.length (b :: repeat n b)) with (S (Datatypes.length (repeat n b))).
  replace (Datatypes.length (repeat n b)) with n.
  auto.
  auto.
  auto.
Qed.

Lemma repeat_add : forall {A} n m (b : A), (repeat n b) ++ (repeat m b) = (repeat (n + m) b).
Proof.
  intro A.
  induction n.
  intros m b.
  compute.
  auto.
  intros m b.
  replace (S n + m) with (S (n + m)).
  replace (repeat (S (n + m)) b) with (b :: repeat (n + m) b).
  replace (repeat (S n) b) with (b :: repeat n b).
  replace (repeat (n + m) b) with (repeat n b ++ repeat m b).
  auto.
  apply IHn.
  auto.
  auto.
  auto.
Qed.

Lemma repeat_S : forall {A} l n (b : A), prefix l (repeat n b) -> prefix l (repeat (S n) b).
Proof.
  intro A.
  induction n.
  intros b H.
  replace l with (nil : list A).
  compute.
  exists (b :: nil).
  auto.
  assert (ll l <= 0).
  replace 0 with (ll (repeat 0 b)).
  apply prefix_le.
  apply H.
  auto.
  induction l.
  auto.
  contradict H0.
  replace (ll (a :: l)) with (S (ll l)).
  apply le_Sn_O.
  auto.
  intros b H.
  replace (repeat (S (S n)) b) with ((repeat (S n) b) ++ (repeat 1 b)).
  apply prefix_trans with (repeat (S n) b).
  trivial.
  exists (repeat 1 b).
  auto.
  replace (S (S n)) with ((S n) + 1).
  apply repeat_add.
  replace (S n + 1) with (1 + S n).
  auto.
  apply plus_comm.
Qed.

Lemma repeat_inc : forall {A} l n m (b : A),
                     prefix l (repeat n b) -> m >= n -> prefix l (repeat m b).
Proof.
  intros A l n m b H H0.
  assert (m = n + (m - n)).
  apply le_plus_minus.
  trivial.
  replace m with (n + (m - n)).
  replace (repeat (n + (m - n)) b) with ((repeat n b) ++ (repeat (m - n) b)).
  inversion H.
  replace (repeat n b) with (l ++ x).
  replace ((l ++ x) ++ repeat (m - n) b) with (l ++ x ++ repeat (m - n) b).
  exists (x ++ repeat (m - n) b).
  auto.
  apply Coq.Lists.List.app_assoc.
  apply repeat_add.
Qed.

Lemma repeat_cdr : forall {A} (a : A) b l n,  prefix (a :: l) (repeat n b) -> prefix l (repeat n b).
Proof.
  induction n.
  intros H.
  contradict H.
  intros H.
  inversion H.
  inversion H0.
  intros H.
  apply repeat_S.
  inversion H.
  exists x.
  inversion H0.
  auto.
Qed.

Lemma rep_prefix : forall {A} (b : A) l, (exists n, prefix l (repeat n b)) ->
                                         l = repeat (ll l) b.
Proof.
induction l.
intros H.
compute.
auto.
intros H.
inversion H.
inversion H0.
inversion H1.
replace (ll (a :: l)) with (S (ll l)).
replace (repeat (S (ll l)) b) with (b :: repeat (ll l) b).
replace a with b.
f_equal.
apply IHl.
exists x.
apply (repeat_cdr a).
exists x0.
trivial.
assert (exists y, x = S y).
assert (x > 0).
apply not_le.
intros Q.
contradict H3.
replace x with 0.
intros Q2.
inversion Q2.
apply le_n_0_eq.
trivial.
induction x.
contradict H2.
intros Q.
inversion Q.
exists x.
auto.
inversion H2.
assert (a :: l ++ x0 = b :: (repeat x1 b)).
replace (b :: (repeat x1 b)) with (repeat x b).
trivial.
replace x with (S x1).
auto.
inversion H5.
auto.
auto.
auto.
Qed.

Lemma rep_prefix_1 : forall {A} (a b : A) n l, l <> nil -> prefix l (a :: (repeat n b)) ->
                                               l = a :: (repeat (pred (ll l)) b).
Proof.
intros A a b n l H H0.
induction l.
contradict H.
auto.
inversion H0 as [H1 H2].
inversion H2.
f_equal.
replace (ll (a :: l)) with (S (ll l)).
unfold pred.
apply rep_prefix.
exists n.
exists H1.
trivial.
reflexivity.
Qed.

Lemma prefix_repeat : forall {A} a (b : A) n, prefix a (repeat n b) -> a = repeat (ll a) b.
Proof.
  intro A.
  induction a.
  intro b.
  induction n.
  auto.
  auto.
  intro b.
  destruct n as [|n].
  intro Q.
  destruct Q as [pr1 pr2].
  compute in pr2.
  inversion pr2.
  intros Q.
  destruct Q as [pr1 pr2].
  inversion pr2 as [ab].
  compute in pr2.
  compute.
  f_equal.
  apply IHa with n.
  exists pr1.
  trivial.
Qed.

Lemma lex_0_x : forall x, lex (repeat (ll x) false) x.
Proof.
  induction x.
  apply nil_lex.
  induction a.
  replace (repeat (ll (true :: x)) false) with
  (false :: repeat (ll x) false).
  apply car_lex.
  replace (repeat (ll (true :: x)) false) with
  (false :: repeat (ll x) false).
  auto.
  compute.
  auto.
  replace (repeat (ll (false :: x)) false) with
  (false :: repeat (ll x) false).
  apply cdr_lex.
  apply IHx.
  auto.
Qed.

Lemma lex_1_is_1 : forall l, lex (repeat (ll l) true) l -> l = (repeat (ll l) true).
Proof.
  induction l.
  auto.
  intros lx.
  induction a.
  assert (lxx : lex (repeat (ll l) true) l).
  apply (lex_cdr _ _ true).
  apply lx.
  rewrite -> IHl.
  replace (ll (true :: repeat (ll l) true)) with (S (ll (repeat (ll l) true))).
  rewrite -> rep_length.
  auto.
  auto.
  auto.
  inversion lx.
Qed.

Lemma lex_1_prefix : forall n b,
                       lex (repeat n true) b -> prefix (repeat n true) b.
Proof.
  induction n.
  intros b bb.
  exists b.
  auto.
  destruct b.
  intros contr.
  inversion contr.
  intros lex1.
  inversion lex1.
  assert (H4:prefix (repeat n true) b0).
  apply IHn.
  rewrite <- H2 in lex1.
  apply (lex_cdr _ _ true).
  apply lex1.
  elim H4.
  intros x k.
  exists x.
  rewrite <- k.
  auto.
Qed.

Lemma prefix_ext : forall {A} (a b c : list A),
                     prefix a (b ++ c) -> ~ prefix a b -> prefix b a.
Proof.
  intros A a b c pf1 pf2.
  refine ((fix f x y z
               (qf1 : prefix x (y ++ z))
               (qf2 : ~ prefix x y) : prefix y x :=
             match x as k return (x = k -> _) with
               | nil => fun eq => _
               | x' :: x'' =>
                 fun eq =>
                   match y as kk return (y = kk -> _) with
                     | nil => fun eq => _
                     | y' :: y'' => _
                   end eq_refl
             end eq_refl) a b c pf1 pf2).
  destruct y.
  exists (nil (A:=A)).
  auto.
  contradict qf2.
  rewrite -> eq.
  exists (a0 :: y).
  auto.
  exists (x' :: x'').
  auto.
  intros eq2.
  rewrite -> eq in qf1.
  rewrite -> eq2 in qf1.
  inversion qf1.
  inversion H.
  assert (pref : prefix y'' x'').
  apply (f _ _ z).
  exists x0.
  auto.
  contradict qf2.
  elim qf2.
  intros r rr.
  exists r.
  rewrite -> eq.
  rewrite -> eq2.
  rewrite <- rr.
  rewrite -> H1.
  auto.
  elim pref.
  intros x1 x1x.
  exists x1.
  rewrite <- x1x.
  auto.
Qed.

Lemma lex_0_is_prefix : forall d n, lex d (repeat n false) -> prefix d (repeat n false).
Proof.
  refine (fix f d n lx :=
            match d as e return (d = e -> _) with
                | nil => _
                | (x :: r) =>
                  match n as m return (n = m -> _) with
                      | 0%nat => fun eq => _
                      | (S n_) => fun eq => _
                  end eq_refl
            end eq_refl).
  exists (repeat n false).
  rewrite -> H.
  auto.
  intros deq.
  contradict lx.
  rewrite deq.
  rewrite eq.
  apply nnil_lex.
  intros deq.
  rewrite deq.
  assert (lx' : lex (x :: r) (repeat (S n_) false)).
  rewrite <- deq.
  rewrite <- eq.
  auto.
  inversion lx'.
  assert (pref : prefix r (repeat n_ false)).
  apply f.
  auto.
  elim pref.
  intros x0 quak.
  exists x0.
  replace ((false :: r) ++ x0) with (false :: (r ++ x0)).
  rewrite -> quak.
  reflexivity.
  auto.
Qed.

(* TODO: geht allgemeiner *)
Lemma prefix_antisym : forall (a b : LB), prefix a b -> prefix b a -> a = b.
Proof.
  refine (fix f a b :=
            match (a, b) as R return (R = (a, b) -> _) with
                | (nil, nil) => fun eq => _
                | (xa :: a', nil) => fun eq => _
                | (nil, xb :: b') => fun eq => _
                | (xa :: a', xb :: b') => fun eq => _
            end eq_refl).
inversion eq.
reflexivity.
inversion eq.
intros _ Q.
contradict Q.
apply prefix_nnil.
inversion eq.
intros Q.
contradict Q.
apply prefix_nnil.
inversion eq.
intros pab pba.
elim (bool_dec xa xb).
intros xa_eq_xb.
rewrite -> xa_eq_xb.
f_equal.
apply f.
apply (prefix_cdr xa xb).
apply pab.
apply (prefix_cdr xb xa).
apply pba.
intros xa_neq_xb.
inversion pab.
inversion H.
contradict xa_neq_xb.
auto.
Qed.

Lemma prefix_app : forall (a b c : LB),
                     prefix a (b ++ c) ->
                     (ll a <= ll b)%nat -> prefix a b.
Proof.
  induction a.
  intros b c pref ll_.
  exists b.
  auto.
  intros b c pref ll_.
  destruct b.
  inversion ll_.
  inversion pref.
  inversion H.
  apply prefix_cons.
  apply (IHa _ c).
  exists x.
  apply H2.
  apply le_S_n.
  replace (S (ll a0)) with (ll (a :: a0)).
  replace (S (ll b0)) with (ll (b :: b0)).
  apply ll_.
  auto.
  auto.
Qed.

(* Check bool_dec. *)

(* Lemma max_common_prefix : forall {A : Set} (eqdec : forall b1 b2 : A, {b1 = b2} + {b1 <> b2}) (a b : list A), *)
(*     {c | (prefix c a) /\ (prefix c b) /\ forall d, prefix d a -> prefix d b -> prefix d c }. *)
(* Proof. *)
(*   intros A a b. *)

(* TODO: geht allgemeiner *)
(* Lemma max_common_prefix : forall (a b : LB), {c | (prefix c a) /\ (prefix c b) /\ *)
(*                                                   forall d, prefix d a -> prefix d b -> prefix d c}. *)
(* Proof. *)
(*   intros aq bq. *)
(*   refine ((fix f a b :=  *)
(*             match a as A return (a = A -> _) with *)
(*                 | nil => fun eq => _ *)
(*                 | (xa :: a') => *)
(*                   fun eq => *)
(*                   match b as B return (b = B -> _) with *)
(*                       | nil => fun eq2 => _ *)
(*                       | (xb :: b') => fun eq2 => _ *)
(*                   end eq_refl *)
(*             end eq_refl) aq bq). *)
(* exists Bnil. *)
(* split. *)
(* exists Bnil. *)
(* auto. *)
(* split. *)
(* exists b. *)
(* auto. *)
(* intros d pb db. *)
(* apply pb. *)
(* exists Bnil. *)
(* split. *)
(* exists (xa :: a'). *)
(* auto. *)
(* split. *)
(* exists Bnil. *)
(* auto. *)

(* intros d da db. *)
(* match goal with *)
(* | X : prefix d b, Y : b = Bnil |- prefix d Bnil => rewrite -> Y in X *)
(* | _ => idtac *)
(* end. *)
(* apply db. *)
(* elim (bool_dec xa xb). *)
(* intros xa_eq_xb. *)
(* elim (f a' b'). *)
(* intros x x_ex. *)
(* elim x_ex. *)
(* intros xa' xex2. *)
(* elim xex2. *)
(* intros xb' xex3. *)
(* exists (xb :: x). *)
(* split. *)
(* rewrite -> xa_eq_xb. *)
(* apply prefix_cons. *)
(* apply xa'. *)
(* split. *)
(* match goal with *)
(* | |- prefix _ b => rewrite -> eq2 *)
(* | _ => idtac *)
(* end. *)
(* apply prefix_cons. *)
(* apply xb'. *)
(* intros d. *)
(* destruct d. *)
(* intros _ _. *)
(* exists (xb :: x). *)
(* auto. *)
(* intros pda pdb. *)
(* inversion pdb *)
(* inversion H. *)
(* apply prefix_cons. *)
(* apply xex3. *)
(* apply (prefix_cdr b0 xa). *)
(* apply pda. *)
(* apply (prefix_cdr b0 xb). *)
(* apply pdb. *)
(* exists Bnil. *)
(* split. *)
(* exists (xa :: a'). *)
(* auto. *)
(* split. *)
(* exists (xb :: b'). *)
(* auto. *)
(* intros d. *)
(* intros pda pdb. *)
(* induction d. *)
(* exists Bnil. *)
(* auto. *)
(* inversion pda. *)
(* inversion H. *)
(* inversion pdb. *)
(* inversion H0. *)
(* rewrite <- H4 in b0. *)
(* rewrite <- H1 in b0. *)
(* contradict b0. *)
(* reflexivity. *)
(* Qed. *)

Lemma repeat_forall : forall {A} n (Q : A -> Prop) a,
                        Q a -> Forall Q (repeat n a).
Proof.
  intros A.
  induction n.
  constructor.
  intros Q a Qa.
  constructor.
  exact Qa.
  apply IHn.
  exact Qa.
Qed.

Lemma repeat_map : forall {A B : Set} (c : A) (f : A -> B) n,
                     map f (repeat n c) = repeat n (f c).
Proof.
  intros A B c f.
  induction n as [|n IHn].
  reflexivity.
  simpl.
  rewrite -> IHn.
  reflexivity.
Qed.


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

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

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

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

(** * Basic properties of floating-point formats: lemmas about mantissa, exponent... *)
Require Import Fcore_Raux.
Require Import Fcore_defs.

Section Float_prop.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Theorem Rcompare_F2R :
  forall e m1 m2 : Z,
  Rcompare (F2R (Float beta m1 e)) (F2R (Float beta m2 e)) = Z.compare m1 m2.
Proof.
intros e m1 m2.
unfold F2R. simpl.
rewrite Rcompare_mult_r.
apply Rcompare_Z2R.
apply bpow_gt_0.
Qed.

(** Basic facts *)
Theorem F2R_le_reg :
  forall e m1 m2 : Z,
  (F2R (Float beta m1 e) <= F2R (Float beta m2 e))%R ->
  (m1 <= m2)%Z.
Proof.
intros e m1 m2 H.
apply le_Z2R.
apply Rmult_le_reg_r with (bpow e).
apply bpow_gt_0.
exact H.
Qed.

Theorem F2R_le_compat :
  forall m1 m2 e : Z,
  (m1 <= m2)%Z ->
  (F2R (Float beta m1 e) <= F2R (Float beta m2 e))%R.
Proof.
intros m1 m2 e H.
unfold F2R. simpl.
apply Rmult_le_compat_r.
apply bpow_ge_0.
now apply Z2R_le.
Qed.

Theorem F2R_lt_reg :
  forall e m1 m2 : Z,
  (F2R (Float beta m1 e) < F2R (Float beta m2 e))%R ->
  (m1 < m2)%Z.
Proof.
intros e m1 m2 H.
apply lt_Z2R.
apply Rmult_lt_reg_r with (bpow e).
apply bpow_gt_0.
exact H.
Qed.

Theorem F2R_lt_compat :
  forall e m1 m2 : Z,
  (m1 < m2)%Z ->
  (F2R (Float beta m1 e) < F2R (Float beta m2 e))%R.
Proof.
intros e m1 m2 H.
unfold F2R. simpl.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
now apply Z2R_lt.
Qed.

Theorem F2R_eq_compat :
  forall e m1 m2 : Z,
  (m1 = m2)%Z ->
  (F2R (Float beta m1 e) = F2R (Float beta m2 e))%R.
Proof.
intros e m1 m2 H.
now apply (f_equal (fun m => F2R (Float beta m e))).
Qed.

Theorem F2R_eq_reg :
  forall e m1 m2 : Z,
  F2R (Float beta m1 e) = F2R (Float beta m2 e) ->
  m1 = m2.
Proof.
intros e m1 m2 H.
apply Zle_antisym ;
  apply F2R_le_reg with e ;
  rewrite H ;
  apply Rle_refl.
Qed.

Theorem F2R_Zabs:
  forall m e : Z,
   F2R (Float beta (Z.abs m) e) = Rabs (F2R (Float beta m e)).
Proof.
intros m e.
unfold F2R.
rewrite Rabs_mult.
rewrite <- Z2R_abs.
simpl.
apply f_equal.
apply sym_eq; apply Rabs_right.
apply Rle_ge.
apply bpow_ge_0.
Qed.

Theorem F2R_Zopp :
  forall m e : Z,
  F2R (Float beta (Z.opp m) e) = Ropp (F2R (Float beta m e)).
Proof.
intros m e.
unfold F2R. simpl.
rewrite <- Ropp_mult_distr_l_reverse.
now rewrite Z2R_opp.
Qed.

(** Sign facts *)
Theorem F2R_0 :
  forall e : Z,
  F2R (Float beta 0 e) = 0%R.
Proof.
intros e.
unfold F2R. simpl.
apply Rmult_0_l.
Qed.

Theorem F2R_eq_0_reg :
  forall m e : Z,
  F2R (Float beta m e) = 0%R ->
  m = Z0.
Proof.
intros m e H.
apply F2R_eq_reg with e.
now rewrite F2R_0.
Qed.

Theorem F2R_ge_0_reg :
  forall m e : Z,
  (0 <= F2R (Float beta m e))%R ->
  (0 <= m)%Z.
Proof.
intros m e H.
apply F2R_le_reg with e.
now rewrite F2R_0.
Qed.

Theorem F2R_le_0_reg :
  forall m e : Z,
  (F2R (Float beta m e) <= 0)%R ->
  (m <= 0)%Z.
Proof.
intros m e H.
apply F2R_le_reg with e.
now rewrite F2R_0.
Qed.

Theorem F2R_gt_0_reg :
  forall m e : Z,
  (0 < F2R (Float beta m e))%R ->
  (0 < m)%Z.
Proof.
intros m e H.
apply F2R_lt_reg with e.
now rewrite F2R_0.
Qed.

Theorem F2R_lt_0_reg :
  forall m e : Z,
  (F2R (Float beta m e) < 0)%R ->
  (m < 0)%Z.
Proof.
intros m e H.
apply F2R_lt_reg with e.
now rewrite F2R_0.
Qed.

Theorem F2R_ge_0_compat :
  forall f : float beta,
  (0 <= Fnum f)%Z ->
  (0 <= F2R f)%R.
Proof.
intros f H.
rewrite <- F2R_0 with (Fexp f).
now apply F2R_le_compat.
Qed.

Theorem F2R_le_0_compat :
  forall f : float beta,
  (Fnum f <= 0)%Z ->
  (F2R f <= 0)%R.
Proof.
intros f H.
rewrite <- F2R_0 with (Fexp f).
now apply F2R_le_compat.
Qed.

Theorem F2R_gt_0_compat :
  forall f : float beta,
  (0 < Fnum f)%Z ->
  (0 < F2R f)%R.
Proof.
intros f H.
rewrite <- F2R_0 with (Fexp f).
now apply F2R_lt_compat.
Qed.

Theorem F2R_lt_0_compat :
  forall f : float beta,
  (Fnum f < 0)%Z ->
  (F2R f < 0)%R.
Proof.
intros f H.
rewrite <- F2R_0 with (Fexp f).
now apply F2R_lt_compat.
Qed.

Theorem F2R_neq_0_compat :
 forall f : float beta,
  (Fnum f <> 0)%Z ->
  (F2R f <> 0)%R.
Proof.
intros f H H1.
apply H.
now apply F2R_eq_0_reg with (Fexp f).
Qed.

Lemma Fnum_ge_0_compat: forall (f : float beta),
  (0 <= F2R f)%R -> (0 <= Fnum f)%Z.
Proof.
intros f H.
case (Zle_or_lt 0 (Fnum f)); trivial.
intros H1; contradict H.
apply Rlt_not_le.
now apply F2R_lt_0_compat.
Qed.

Lemma Fnum_le_0_compat: forall (f : float beta),
  (F2R f <= 0)%R -> (Fnum f <= 0)%Z.
Proof.
intros f H.
case (Zle_or_lt (Fnum f) 0); trivial.
intros H1; contradict H.
apply Rlt_not_le.
now apply F2R_gt_0_compat.
Qed.

(** Floats and bpow *)
Theorem F2R_bpow :
  forall e : Z,
  F2R (Float beta 1 e) = bpow e.
Proof.
intros e.
unfold F2R. simpl.
apply Rmult_1_l.
Qed.

Theorem bpow_le_F2R :
  forall m e : Z,
  (0 < m)%Z ->
  (bpow e <= F2R (Float beta m e))%R.
Proof.
intros m e H.
rewrite <- F2R_bpow.
apply F2R_le_compat.
now apply (Zlt_le_succ 0).
Qed.

Theorem F2R_p1_le_bpow :
  forall m e1 e2 : Z,
  (0 < m)%Z ->
  (F2R (Float beta m e1) < bpow e2)%R ->
  (F2R (Float beta (m + 1) e1) <= bpow e2)%R.
Proof.
intros m e1 e2 Hm.
intros H.
assert (He : (e1 <= e2)%Z).
(* . *)
apply (le_bpow beta).
apply Rle_trans with (F2R (Float beta m e1)).
unfold F2R. simpl.
rewrite <- (Rmult_1_l (bpow e1)) at 1.
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply (Z2R_le 1).
now apply (Zlt_le_succ 0).
now apply Rlt_le.
(* . *)
revert H.
replace e2 with (e2 - e1 + e1)%Z by ring.
rewrite bpow_plus.
unfold F2R. simpl.
rewrite <- (Z2R_Zpower beta (e2 - e1)).
intros H.
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply Rmult_lt_reg_r in H.
apply Z2R_le.
apply Zlt_le_succ.
now apply lt_Z2R.
apply bpow_gt_0.
now apply Zle_minus_le_0.
Qed.

Theorem bpow_le_F2R_m1 :
  forall m e1 e2 : Z,
  (1 < m)%Z ->
  (bpow e2 < F2R (Float beta m e1))%R ->
  (bpow e2 <= F2R (Float beta (m - 1) e1))%R.
Proof.
intros m e1 e2 Hm.
case (Zle_or_lt e1 e2); intros He.
replace e2 with (e2 - e1 + e1)%Z by ring.
rewrite bpow_plus.
unfold F2R. simpl.
rewrite <- (Z2R_Zpower beta (e2 - e1)).
intros H.
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply Rmult_lt_reg_r in H.
apply Z2R_le.
rewrite (Zpred_succ (Zpower _ _)).
apply Zplus_le_compat_r.
apply Zlt_le_succ.
now apply lt_Z2R.
apply bpow_gt_0.
now apply Zle_minus_le_0.
intros H.
apply Rle_trans with (1*bpow e1)%R.
rewrite Rmult_1_l.
apply bpow_le.
now apply Zlt_le_weak.
unfold F2R. simpl.
apply Rmult_le_compat_r.
apply bpow_ge_0.
replace 1%R with (Z2R 1) by reflexivity.
apply Z2R_le.
omega.
Qed.

Theorem F2R_lt_bpow :
  forall f : float beta, forall e',
  (Z.abs (Fnum f) < Zpower beta (e' - Fexp f))%Z ->
  (Rabs (F2R f) < bpow e')%R.
Proof.
intros (m, e) e' Hm.
rewrite <- F2R_Zabs.
destruct (Zle_or_lt e e') as [He|He].
unfold F2R. simpl.
apply Rmult_lt_reg_r with (bpow (-e)).
apply bpow_gt_0.
rewrite Rmult_assoc, <- 2!bpow_plus, Zplus_opp_r, Rmult_1_r.
rewrite <-Z2R_Zpower. 2: now apply Zle_left.
now apply Z2R_lt.
elim Zlt_not_le with (1 := Hm).
simpl.
cut (e' - e < 0)%Z. 2: omega.
clear.
case (e' - e)%Z ; try easy.
intros p _.
apply Zabs_pos.
Qed.

Theorem F2R_change_exp :
  forall e' m e : Z,
  (e' <= e)%Z ->
  F2R (Float beta m e) = F2R (Float beta (m * Zpower beta (e - e')) e').
Proof.
intros e' m e He.
unfold F2R. simpl.
rewrite Z2R_mult, Z2R_Zpower, Rmult_assoc.
apply f_equal.
pattern e at 1 ; replace e with (e - e' + e')%Z by ring.
apply bpow_plus.
now apply Zle_minus_le_0.
Qed.

Theorem F2R_prec_normalize :
  forall m e e' p : Z,
  (Z.abs m < Zpower beta p)%Z ->
  (bpow (e' - 1)%Z <= Rabs (F2R (Float beta m e)))%R ->
  F2R (Float beta m e) = F2R (Float beta (m * Zpower beta (e - e' + p)) (e' - p)).
Proof.
intros m e e' p Hm Hf.
assert (Hp: (0 <= p)%Z).
destruct p ; try easy.
now elim (Zle_not_lt _ _ (Zabs_pos m)).
(* . *)
replace (e - e' + p)%Z with (e - (e' - p))%Z by ring.
apply F2R_change_exp.
cut (e' - 1 < e + p)%Z. omega.
apply (lt_bpow beta).
apply Rle_lt_trans with (1 := Hf).
rewrite <- F2R_Zabs, Zplus_comm, bpow_plus.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
rewrite <- Z2R_Zpower.
now apply Z2R_lt.
exact Hp.
Qed.

(** Floats and ln_beta *)
Theorem ln_beta_F2R_bounds :
  forall x m e, (0 < m)%Z ->
  (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R ->
  ln_beta beta x = ln_beta beta (F2R (Float beta m e)) :> Z.
Proof.
intros x m e Hp (Hx,Hx2).
destruct (ln_beta beta (F2R (Float beta m e))) as (ex, He).
simpl.
apply ln_beta_unique.
assert (Hp1: (0 < F2R (Float beta m e))%R).
now apply F2R_gt_0_compat.
specialize (He (Rgt_not_eq _ _ Hp1)).
rewrite Rabs_pos_eq in He. 2: now apply Rlt_le.
destruct He as (He1, He2).
assert (Hx1: (0 < x)%R).
now apply Rlt_le_trans with (2 := Hx).
rewrite Rabs_pos_eq. 2: now apply Rlt_le.
split.
now apply Rle_trans with (1 := He1).
apply Rlt_le_trans with (1 := Hx2).
now apply F2R_p1_le_bpow.
Qed.

Theorem ln_beta_F2R :
  forall m e : Z,
  m <> Z0 ->
  (ln_beta beta (F2R (Float beta m e)) = ln_beta beta (Z2R m) + e :> Z)%Z.
Proof.
intros m e H.
unfold F2R ; simpl.
apply ln_beta_mult_bpow.
exact (Z2R_neq m 0 H).
Qed.

Theorem float_distribution_pos :
  forall m1 e1 m2 e2 : Z,
  (0 < m1)%Z ->
  (F2R (Float beta m1 e1) < F2R (Float beta m2 e2) < F2R (Float beta (m1 + 1) e1))%R ->
  (e2 < e1)%Z /\ (e1 + ln_beta beta (Z2R m1) = e2 + ln_beta beta (Z2R m2))%Z.
Proof.
intros m1 e1 m2 e2 Hp1 (H12, H21).
assert (He: (e2 < e1)%Z).
(* . *)
apply Znot_ge_lt.
intros H0.
elim Rlt_not_le with (1 := H21).
apply Z.ge_le in H0.
apply (F2R_change_exp e1 m2 e2) in H0.
rewrite H0.
apply F2R_le_compat.
apply Zlt_le_succ.
apply (F2R_lt_reg e1).
now rewrite <- H0.
(* . *)
split.
exact He.
rewrite (Zplus_comm e1), (Zplus_comm e2).
assert (Hp2: (0 < m2)%Z).
apply (F2R_gt_0_reg m2 e2).
apply Rlt_trans with (2 := H12).
now apply F2R_gt_0_compat.
rewrite <- 2!ln_beta_F2R.
destruct (ln_beta beta (F2R (Float beta m1 e1))) as (e1', H1).
simpl.
apply sym_eq.
apply ln_beta_unique.
assert (H2 : (bpow (e1' - 1) <= F2R (Float beta m1 e1) < bpow e1')%R).
rewrite <- (Z.abs_eq m1), F2R_Zabs.
apply H1.
apply Rgt_not_eq.
apply Rlt_gt.
now apply F2R_gt_0_compat.
now apply Zlt_le_weak.
clear H1.
rewrite <- F2R_Zabs, Z.abs_eq.
split.
apply Rlt_le.
apply Rle_lt_trans with (2 := H12).
apply H2.
apply Rlt_le_trans with (1 := H21).
now apply F2R_p1_le_bpow.
now apply Zlt_le_weak.
apply sym_not_eq.
now apply Zlt_not_eq.
apply sym_not_eq.
now apply Zlt_not_eq.
Qed.

Theorem F2R_cond_Zopp :
  forall b m e,
  F2R (Float beta (cond_Zopp b m) e) = cond_Ropp b (F2R (Float beta m e)).
Proof.
intros [|] m e ; unfold F2R ; simpl.
now rewrite Z2R_opp, Ropp_mult_distr_l_reverse.
apply refl_equal.
Qed.

End Float_prop.