(* This program 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 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Set Automatic Coercions Import.
Set Implicit Arguments.
Unset Strict Implicit.
Require Export Integral_domain_facts.
Require Export Cfield_cat.
Require Export Abelian_group_facts.
Require Export Ring_util.
(** Title "The field of fractions of an integral domain" "with decidable equality." *)
Section Def.
Variable R : INTEGRAL_DOMAIN.
Variable diff10 : ~ Equal (ring_unit R) (monoid_unit R).
Set Strict Implicit.
Unset Implicit Arguments.

Record fraction : Type :=
  {num : R; den : R; den_prf : ~ Equal den (monoid_unit R)}.
Set Implicit Arguments.
Unset Strict Implicit.
Hint Resolve den_prf: algebra.

Definition eqfraction (x y : fraction) :=
  Equal (ring_mult (num x) (den y)) (ring_mult (num y) (den x)).

Lemma eqfraction_refl : reflexive eqfraction.
red in |- *.
intros x; red in |- *.
red in |- *.
auto with algebra.
Qed.

Definition fraction0 := Build_fraction (monoid_unit R) (ring_unit R) diff10.

Lemma eqfraction0 :
 forall x : fraction, eqfraction x fraction0 -> Equal (num x) (monoid_unit R).
intros x; try assumption.
case x; unfold eqfraction, fraction0 in |- *; simpl in |- *.
intros numer denom H' H'0; try assumption.
apply Trans with (ring_mult numer (ring_unit R)); auto with algebra.
apply Trans with (ring_mult (monoid_unit R) denom); auto with algebra.
Qed.

Lemma eqfraction_num0 :
 forall x : fraction, Equal (num x) (monoid_unit R) -> eqfraction x fraction0.
intros x; try assumption.
case x; unfold eqfraction, fraction0 in |- *; simpl in |- *.
intros numer denom H' H'0; try assumption.
apply Trans with numer; auto with algebra.
apply Trans with (monoid_unit R); auto with algebra.
Qed.

Lemma eqfraction_sym : symmetric eqfraction.
red in |- *.
unfold app_rel, eqfraction in |- *; auto with algebra.
Qed.

Lemma eqfraction_trans : transitive eqfraction.
red in |- *.
unfold app_rel, eqfraction in |- *.
intros x y z H' H'0; try assumption.
apply INTEGRAL_DOMAIN_simpl_l with (den y).
auto with algebra.
apply Trans with (ring_mult (ring_mult (den y) (num x)) (den z)).
auto with algebra.
apply Trans with (ring_mult (ring_mult (num x) (den y)) (den z)).
auto with algebra.
apply Trans with (ring_mult (ring_mult (num y) (den x)) (den z)).
auto with algebra.
apply Trans with (ring_mult (ring_mult (den x) (num y)) (den z)).
auto with algebra.
apply Trans with (ring_mult (den x) (ring_mult (num y) (den z))).
auto with algebra.
apply Trans with (ring_mult (den x) (ring_mult (num z) (den y))).
auto with algebra.
apply Trans with (ring_mult (ring_mult (den x) (num z)) (den y)).
auto with algebra.
apply Trans with (ring_mult (ring_mult (num z) (den x)) (den y));
 auto with algebra.
Qed.

Definition fraction_set : SET.
apply (Build_Setoid (Carrier:=fraction) (Equal:=eqfraction)).
red in |- *.
split; [ try assumption | idtac ].
exact eqfraction_refl.
red in |- *.
split; [ try assumption | idtac ].
exact eqfraction_trans.
exact eqfraction_sym.
Defined.

Definition addfraction_fun (x y : fraction_set) : fraction_set :=
  Build_fraction
    (sgroup_law R (ring_mult (num x) (den y)) (ring_mult (num y) (den x)))
    (ring_mult (den x) (den y))
    (INTEGRAL_DOMAIN_prop_rev (den_prf x) (den_prf y)).

Definition opfraction_fun (x : fraction_set) : fraction_set :=
  Build_fraction (group_inverse R (num x)) (den x) (den_prf x).

Definition multfraction_fun (x y : fraction_set) : fraction_set :=
  Build_fraction (ring_mult (num x) (num y)) (ring_mult (den x) (den y))
    (INTEGRAL_DOMAIN_prop_rev (den_prf x) (den_prf y)).

Definition fraction1 : fraction_set :=
  Build_fraction (ring_unit R) (ring_unit R) diff10.

Lemma addfraction_law_l :
 forall x x' y : fraction_set,
 Equal x x' -> Equal (addfraction_fun x y) (addfraction_fun x' y).
unfold addfraction_fun in |- *; simpl in |- *.
unfold eqfraction in |- *; simpl in |- *.
intros x x' y H'; try assumption.
apply
 Trans
  with
    (ring_mult
       (ring_mult
          (sgroup_law R (ring_mult (num x) (den y))
             (ring_mult (num y) (den x))) (den x'))
       (den y)).
auto with algebra.
apply
 Trans
  with
    (ring_mult
       (ring_mult
          (sgroup_law R (ring_mult (num x') (den y))
             (ring_mult (num y) (den x'))) (den x))
       (den y)).
apply RING_comp.
apply
 Trans
  with
    (sgroup_law R (ring_mult (ring_mult (num x) (den y)) (den x'))
       (ring_mult (ring_mult (num y) (den x)) (den x'))).
auto with algebra.
apply
 Trans
  with
    (sgroup_law R (ring_mult (ring_mult (num x') (den y)) (den x))
       (ring_mult (ring_mult (num y) (den x')) (den x))).
apply SGROUP_comp.
apply Trans with (ring_mult (ring_mult (den y) (num x)) (den x')).
auto with algebra.
apply Trans with (ring_mult (ring_mult (den y) (num x')) (den x)).
apply Trans with (ring_mult (den y) (ring_mult (num x) (den x'))).
auto with algebra.
apply Trans with (ring_mult (den y) (ring_mult (num x') (den x))).
auto with algebra.
auto with algebra.
auto with algebra.
apply Trans with (ring_mult (num y) (ring_mult (den x) (den x'))).
auto with algebra.
apply Trans with (ring_mult (num y) (ring_mult (den x') (den x))).
auto with algebra.
auto with algebra.
auto with algebra.
auto with algebra.
auto with algebra.
Qed.

Lemma addfraction_fun_com :
 forall x y : fraction_set, Equal (addfraction_fun x y) (addfraction_fun y x).
unfold addfraction_fun in |- *; simpl in |- *.
unfold eqfraction in |- *; simpl in |- *.
intros x y; try assumption.
apply RING_comp; auto with algebra.
Qed.

Lemma addfraction_law_r :
 forall x y y' : fraction_set,
 Equal y y' -> Equal (addfraction_fun x y) (addfraction_fun x y').
intros x y y' H'; try assumption.
apply Trans with (addfraction_fun y x).
apply addfraction_fun_com.
apply Trans with (addfraction_fun y' x).
apply addfraction_law_l; auto with algebra.
apply addfraction_fun_com.
Qed.

Lemma addfraction_law : fun2_compatible addfraction_fun.
red in |- *.
intros x x' y y' H' H'0; try assumption.
apply Trans with (addfraction_fun x' y).
apply addfraction_law_l; auto with algebra.
apply addfraction_law_r; auto with algebra.
Qed.

Lemma multfraction_dist_l :
 forall x y z : fraction_set,
 Equal (multfraction_fun x (addfraction_fun y z))
   (addfraction_fun (multfraction_fun x y) (multfraction_fun x z)).
simpl in |- *.
unfold multfraction_fun, eqfraction in |- *; simpl in |- *.
intros x y z; try assumption.
apply
 Trans
  with
    (ring_mult
       (ring_mult (num x)
          (sgroup_law R (ring_mult (num y) (den z))
             (ring_mult (num z) (den y))))
       (ring_mult (den x) (ring_mult (den y) (ring_mult (den x) (den z))))).
auto with algebra.
apply
 Trans
  with
    (ring_mult
       (ring_mult
          (ring_mult (num x)
             (sgroup_law R (ring_mult (num y) (den z))
                (ring_mult (num z) (den y)))) (den x))
       (ring_mult (den y) (ring_mult (den x) (den z)))).
auto with algebra.
apply RING_comp.
apply
 Trans
  with
    (ring_mult
       (sgroup_law R (ring_mult (num x) (ring_mult (num y) (den z)))
          (ring_mult (num x) (ring_mult (num z) (den y))))
       (den x)).
auto with algebra.
apply
 Trans
  with
    (sgroup_law R
       (ring_mult (ring_mult (num x) (ring_mult (num y) (den z))) (den x))
       (ring_mult (ring_mult (num x) (ring_mult (num z) (den y))) (den x))).
auto with algebra.
apply SGROUP_comp.
apply
 Trans
  with (ring_mult (ring_mult (ring_mult (num x) (num y)) (den z)) (den x)).
auto with algebra.
apply
 Trans
  with (ring_mult (ring_mult (num x) (num y)) (ring_mult (den z) (den x)));
 auto with algebra.
apply
 Trans
  with (ring_mult (ring_mult (ring_mult (num x) (num z)) (den y)) (den x)).
auto with algebra.
apply
 Trans
  with (ring_mult (ring_mult (num x) (num z)) (ring_mult (den y) (den x)));
 auto with algebra.
auto with algebra.
Qed.

Lemma multfraction_com :
 forall x y : fraction_set,
 Equal (multfraction_fun x y) (multfraction_fun y x).
simpl in |- *.
unfold multfraction_fun, eqfraction in |- *; simpl in |- *; auto with algebra.
Qed.

Definition fract_field_ring_aux : RING.
apply
 (BUILD_RING (E:=fraction_set) (ringplus:=addfraction_fun)
    (ringmult:=multfraction_fun) (zero:=fraction0) (un:=fraction1)
    (ringopp:=opfraction_fun)).
exact addfraction_law.
simpl in |- *.
unfold addfraction_fun, eqfraction in |- *; simpl in |- *.
intros x y z; try assumption.
apply
 Trans
  with
    (ring_mult
       (sgroup_law R
          (ring_mult
             (sgroup_law R (ring_mult (num x) (den y))
                (ring_mult (num y) (den x))) (den z))
          (ring_mult (num z) (ring_mult (den x) (den y))))
       (ring_mult (ring_mult (den x) (den y)) (den z))).
auto with algebra.
apply RING_comp.
apply
 Trans
  with
    (sgroup_law R
       (sgroup_law R (ring_mult (ring_mult (num x) (den y)) (den z))
          (ring_mult (ring_mult (num y) (den x)) (den z)))
       (ring_mult (num z) (ring_mult (den x) (den y)))).
auto with algebra.
apply
 Trans
  with
    (sgroup_law R (ring_mult (ring_mult (num x) (den y)) (den z))
       (sgroup_law R (ring_mult (ring_mult (num y) (den x)) (den z))
          (ring_mult (num z) (ring_mult (den x) (den y))))).
auto with algebra.
apply SGROUP_comp.
auto with algebra.
apply
 Trans
  with
    (sgroup_law R (ring_mult (ring_mult (num y) (den z)) (den x))
       (ring_mult (ring_mult (num z) (den y)) (den x))).
apply SGROUP_comp.
auto with algebra.
apply Trans with (ring_mult (num z) (ring_mult (den y) (den x)));
 auto with algebra.
auto with algebra.
auto with algebra.
simpl in |- *.
unfold addfraction_fun, eqfraction in |- *; simpl in |- *.
intros x; try assumption.
apply Trans with (ring_mult (sgroup_law R (num x) (monoid_unit R)) (den x));
 auto with algebra.
simpl in |- *.
unfold opfraction_fun, eqfraction in |- *; simpl in |- *.
intros x y H'; try assumption.
apply Trans with (group_inverse R (ring_mult (num x) (den y)));
 auto with algebra.
apply Trans with (group_inverse R (ring_mult (num y) (den x)));
 auto with algebra.
simpl in |- *.
unfold addfraction_fun, opfraction_fun, eqfraction in |- *; simpl in |- *.
intros x; try assumption.
apply
 Trans
  with
    (sgroup_law R (ring_mult (num x) (den x))
       (ring_mult (group_inverse R (num x)) (den x)));
 auto with algebra.
apply
 Trans
  with (ring_mult (sgroup_law R (num x) (group_inverse R (num x))) (den x));
 auto with algebra.
apply Trans with (ring_mult (monoid_unit R) (den x)); auto with algebra.
apply Trans with (monoid_unit R); auto with algebra.
exact addfraction_fun_com.
simpl in |- *.
unfold multfraction_fun, eqfraction in |- *; simpl in |- *.
intros x x' y y' H' H'0; try assumption.
apply
 Trans
  with (ring_mult (ring_mult (num x) (den x')) (ring_mult (num y) (den y')));
 auto with algebra.
apply
 Trans
  with (ring_mult (ring_mult (num x') (den x)) (ring_mult (num y') (den y)));
 auto with algebra.
simpl in |- *.
unfold multfraction_fun, eqfraction in |- *; simpl in |- *.
auto with algebra.
simpl in |- *.
unfold multfraction_fun, eqfraction in |- *; simpl in |- *.
auto with algebra.
intros x; try assumption.
apply Trans with (multfraction_fun x fraction1); auto with algebra.
apply multfraction_com.
unfold multfraction_fun, eqfraction in |- *; simpl in |- *.
unfold multfraction_fun, eqfraction in |- *; simpl in |- *.
auto with algebra.
exact multfraction_dist_l.
intros x y z; try assumption.
apply Trans with (multfraction_fun z (addfraction_fun x y));
 auto with algebra.
apply multfraction_com.
apply
 Trans with (addfraction_fun (multfraction_fun z x) (multfraction_fun z y));
 auto with algebra.
apply multfraction_dist_l.
apply addfraction_law.
apply multfraction_com.
apply multfraction_com.
Defined.

Definition fract_field_ring : CRING.
apply (Build_cring (cring_ring:=fract_field_ring_aux)).
apply (Build_cring_on (R:=fract_field_ring_aux)).
exact multfraction_com.
Defined.
Variable
  zero_dec :
    forall x : R, {Equal x (monoid_unit R)} + {~ Equal x (monoid_unit R)}.

Definition invfraction_fun : fract_field_ring -> fract_field_ring :=
  fun x : fraction_set =>
  match zero_dec (num x) with
  | left _ => x
  | right n => Build_fraction (den x) (num x) n
  end.

Definition invfraction : MAP fract_field_ring fract_field_ring.
apply
 (Build_Map (A:=fract_field_ring) (B:=fract_field_ring) (Ap:=invfraction_fun)).
red in |- *.
simpl in |- *.
unfold invfraction_fun, eqfraction in |- *; simpl in |- *.
intros x y; try assumption.
case (zero_dec (num x)); intros.
case (zero_dec (num y)); intros.
auto with algebra.
simpl in |- *.
cut (Equal (den x) (monoid_unit R)).
intros H'; try assumption.
apply Trans with (ring_mult (monoid_unit R) (num y)).
auto with algebra.
apply Trans with (monoid_unit R); auto with algebra.
apply Trans with (ring_mult (den y) (monoid_unit R)); auto with algebra.
apply INTEGRAL_DOMAIN_mult_n0_l with (num y); auto with algebra.
apply Trans with (ring_mult (num x) (den y)); auto with algebra.
apply Trans with (ring_mult (monoid_unit R) (den y)); auto with algebra.
case (zero_dec (num y)); intros.
simpl in |- *.
cut (Equal (den y) (monoid_unit R)).
intros H'; try assumption.
apply Trans with (ring_mult (monoid_unit R) (num x)).
auto with algebra.
apply Trans with (monoid_unit R); auto with algebra.
apply Trans with (ring_mult (den x) (monoid_unit R)); auto with algebra.
auto with algebra.
apply INTEGRAL_DOMAIN_mult_n0_l with (num x); auto with algebra.
apply Trans with (ring_mult (num y) (den x)); auto with algebra.
apply Trans with (ring_mult (monoid_unit R) (den x)); auto with algebra.
simpl in |- *.
apply Trans with (ring_mult (num y) (den x)); auto with algebra.
apply Trans with (ring_mult (num x) (den y)); auto with algebra.
Defined.

Let ff_inr_r :
  forall x : fract_field_ring,
  ~ Equal x (monoid_unit fract_field_ring) ->
  Equal (ring_mult x (Ap invfraction x)) (ring_unit fract_field_ring).
simpl in |- *.
unfold invfraction_fun, eqfraction in |- *; simpl in |- *.
intros x; try assumption.
case (zero_dec (num x)); simpl in |- *; intros.
absurd (Equal (num x) (monoid_unit R)); auto with algebra.
intuition.
apply H.
apply Trans with (num x); auto with algebra.
apply Trans with (monoid_unit R); auto with algebra.
apply Trans with (ring_mult (num x) (den x)); auto with algebra.
apply Trans with (ring_mult (den x) (num x)); auto with algebra.
Qed.

Hint Resolve ff_inr_r: algebra.

Let ff_field_on : field_on fract_field_ring.
apply (Build_field_on (R:=fract_field_ring) (field_inverse_map:=invfraction)).
exact ff_inr_r.
intros x H'; try assumption.
apply Trans with (ring_mult x (Ap invfraction x)); auto with algebra.
simpl in |- *.
unfold eqfraction in |- *; simpl in |- *.
unfold not in |- *.
intros H'; try assumption.
absurd (Equal (ring_unit R:R) (monoid_unit R)); auto with algebra.
apply Trans with (ring_mult (ring_unit R) (ring_unit R)); auto with algebra.
apply Trans with (ring_mult (monoid_unit R) (ring_unit R)); auto with algebra.
Defined.

Definition fraction_cfield := Build_cfield ff_field_on.
End Def.


(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir
     Arthur Charg\'eraud *)

Require Export Coq.Arith.Arith.
Require Export Coq.FSets.FSets.
Require Export Coq.Lists.List.

Require Export Metalib.CoqEqDec.
Require Export Metalib.CoqListFacts.
Require Export Metalib.LibTactics.
Require Export Metalib.MetatheoryAtom.
(* Require Export MetatheoryEnv. *)

Require Export Metalib.AssumeList.

(* ********************************************************************** *)
(** * Decidable equality *)

(** We prefer that "==" refer to decidable equality at [eq], as
    defined by the [EqDec_eq] class from the CoqEqDec library. *)

Notation " x  == y " := (eq_dec x y) (at level 70) : coqeqdec_scope.

Open Scope coqeqdec_scope.

(* ********************************************************************** *)
(** * Notations for finite sets of atoms *)

(** Common set operations and constants may be written using more
    convenient notations. *)

Notation "E [=] F" :=
  (AtomSetImpl.Equal E F)
  (at level 70, no associativity)
  : set_scope.

Notation "E [<=] F" :=
  (AtomSetImpl.Subset E F)
  (at level 70, no associativity)
  : set_scope.

Notation "{}" :=
  (AtomSetImpl.empty)
  : set_scope.

Notation "{{  x  }}" :=
  (AtomSetImpl.singleton x)
  : set_scope.

Notation "x `in` E" :=
  (AtomSetImpl.In x E)
  (at level 70)
  : set_hs_scope.

Notation "x `notin` E" :=
  (~ AtomSetImpl.In x E)
  (at level 70)
  : set_hs_scope.

Notation "E `union` F" :=
  (AtomSetImpl.union E F)
  (at level 65, right associativity, format "E  `union`  '/' F")
  : set_hs_scope.

(** We define some abbreviations for the empty set, singleton
    sets, and the union of two sets. *)

Notation add := AtomSetImpl.add.
Notation empty := AtomSetImpl.empty.
Notation remove := AtomSetImpl.remove.
Notation singleton := AtomSetImpl.singleton.
Notation union := AtomSetImpl.union.

(** Open the notation scopes declared above. *)

Open Scope set_scope.
Open Scope set_hs_scope.

(* ********************************************************************** *)
(** * Environments *)

(** As an alternative to the [x ~ a] notation, we also provide more
    list-like notation for writing association lists consisting of a
    single binding.

    Implementation note: The following notation overlaps with the
    standard recursive notation for lists, e.g., the one found in the
    Program library of Coq's standard library. *)

(* Notation "[ x ]" := (EnvImpl.one x) : env_scope.

Open Scope env_scope.
*)

(* ********************************************************************** *)
(** * Cofinite quantification *)

(** Consider a rule [H] (equivalently, constructor, lemma, etc.) whose
    type begins with [forall L, ...] and contains hypotheses of the
    form [(forall y, y `notin` L -> ...)].

    The tactic [(pick fresh x excluding F and apply H)] applies [H] to
    the current goal, instantiating [H]'s first argument ([L]) with
    the finite set of atoms [F].  In each new subgoal of the form
    [(forall y, y `notin` F -> ...)], the atom [y] is introduced as
    [x], and [(y `notin` F)] is introduced using a generated name.

    If we view [H] as a rule that uses cofinite quantification, the
    tactic can be read as picking a sufficiently fresh atom to open a
    term with. *)

Tactic Notation
  "pick" "fresh" ident(atom_name)
  "excluding" constr(L)
  "and" "apply" constr(H)
  :=
    first [apply (@H L) | eapply (@H L)];
      match goal with
        | |- forall _, _ `notin` _ -> _ =>
          let Fr := fresh "Fr" in intros atom_name Fr
        | |- forall _, _ `notin` _ -> _ =>
          fail 1 "because" atom_name "is already defined"
        | _ =>
          idtac
      end.

(** The following variant of the tactic excludes the set of atoms
    returned by the [gather_atoms] tactic.  Redefine [gather_atoms] if
    you wish to modify the behavior of this tactic. *)

Tactic Notation
  "pick" "fresh" ident(atom_name)
  "and" "apply" constr(H)
  :=
    let L := gather_atoms in
    let L := beautify_fset L in
    pick fresh atom_name excluding L and apply H.

(* ********************************************************************** *)
(** * Lemma aliases *)

(** A number of useful lemmas are given standardized, if somewhat
    unintuitive, names.  Here, we define some intuitive aliases for
    them. *)

Notation uniq_one := uniq_one_1.
Notation uniq_cons := uniq_cons_3.
Notation uniq_app := uniq_app_4.
Notation uniq_map := uniq_map_2.

Notation binds_one := binds_one_3.
Notation binds_cons := binds_cons_3.
Notation binds_app_l := binds_app_2.
Notation binds_app_r := binds_app_3.
Notation binds_map := binds_map_2.

Notation notin_empty := notin_empty_1.
Notation notin_add := notin_add_3.
Notation notin_singleton := notin_singleton_2.
Notation notin_union := notin_union_3.

(* ********************************************************************** *)
(** * Hints *)

(** The next block of hints is to help [auto] discharge many of the
    inequality and freshness goals that arise in programming language
    metatheory proofs. *)

Ltac hint_extern_solve_notin :=
  autorewrite with rewr_dom in *;
  destruct_notin;
  repeat first [ apply notin_union_3
               | apply notin_add_3
               | apply notin_singleton_2
               | apply notin_empty_1
               ];
  try tauto.

Hint Extern 1 (_ <> _ :> _) => hint_extern_solve_notin.

Hint Extern 1 (_ `notin` _) => hint_extern_solve_notin.

(** The next block of hints are occasionally useful when reasoning
    about finite sets.  In some instances, they obviate the need to
    use [auto with set]. *)

Hint Resolve
  AtomSetImpl.add_1 AtomSetImpl.add_2 AtomSetImpl.remove_1
  AtomSetImpl.remove_2 AtomSetImpl.singleton_2 AtomSetImpl.union_2
  AtomSetImpl.union_3 AtomSetImpl.inter_3 AtomSetImpl.diff_3.

(* ********************************************************************** *)
(** * Ott compatibility *)

(** Implementation note (BEA): The following definitions make this
    library usable with the output of Ott's locally nameless backend.
    They may disappear or change as Ott changes. *)

Notation var := atom (only parsing).

Notation vars := atoms (only parsing).

Notation eq_var := eq_dec (only parsing).

Notation "x  ===  y" :=
  (x == y)
  (at level 70, only parsing)
  : coqeqdec_scope.

Notation "x \in s" :=
  (x `in` s)
  (at level 70, only parsing)
  : set_sl_scope.

Notation "x \notin s" :=
  (x `notin` s)
  (at level 70, only parsing)
  : set_sl_scope.

Notation "s \u t" :=
  (s `union` t)
  (at level 65, right associativity, only parsing)
  : set_sl_scope.

Open Scope set_sl_scope.

Ltac gather_vars_with F := gather_atoms_with.

Ltac pick_fresh_gen L Y := pick fresh Y for L.

Tactic Notation "auto" "*" := auto.

Ltac apply_fresh_base H gather_vars atom_name :=
  let L := gather_vars in
  let L := beautify_fset L in
  pick fresh x excluding L and apply H.

Definition env (A : Type) := list (atom * A).

(** We provide alternative names for tactics on association lists. *)

Ltac simpl_env :=
  simpl_asnlist.

Tactic Notation "simpl_env" "in" hyp(H) :=
  simpl_asnlist in H.

Tactic Notation "simpl_env" "in" "*" :=
  simpl_asnlist in *.

Tactic Notation "rewrite_env" constr(E) :=
  rewrite_asnlist E.

Tactic Notation "rewrite_env" constr(E) "in" hyp(H) :=
  rewrite_asnlist E in H.


(* *********************************************************************)
(*                                                                     *)
(*              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 Lesser General Public License as        *)
(*  published by the Free Software Foundation, either version 2.1 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.                            *)
(*                                                                     *)
(* *********************************************************************)

(** Formalization of floating-point numbers, using the Flocq library. *)

Require Import Coqlib Zbits Integers.
Require Import Coq.micromega.Lia.
(*From Flocq*)
From Flocq Require Import Binary Bits Core.
Require Import IEEE754_extra.
Require Import Program.
Require Archi.

Close Scope R_scope.
Open Scope Z_scope.

Definition float := binary64. (**r the type of IEE754 double-precision FP numbers *)
Definition float32 := binary32. (**r the type of IEE754 single-precision FP numbers *)

(** Boolean-valued comparisons *)

Definition cmp_of_comparison (c: comparison) (x: option Datatypes.comparison) : bool :=
  match c with
  | Ceq =>
      match x with Some Eq => true | _ => false end
  | Cne =>
      match x with Some Eq => false | _ => true end
  | Clt =>
      match x with Some Lt => true | _ => false end
  | Cle =>
      match x with Some(Lt|Eq) => true | _ => false end
  | Cgt =>
      match x with Some Gt => true | _ => false end
  | Cge =>
      match x with Some(Gt|Eq) => true | _ => false end
  end.

Definition ordered_of_comparison (x: option Datatypes.comparison) : bool :=
  match x with None => false | Some _ => true end.

Lemma cmp_of_comparison_swap:
  forall c x,
  cmp_of_comparison (swap_comparison c) x =
  cmp_of_comparison c (match x with None => None | Some x => Some (CompOpp x) end).
Proof.
  intros. destruct c; destruct x as [[]|]; reflexivity.
Qed.

Lemma cmp_of_comparison_ne_eq:
  forall x, cmp_of_comparison Cne x = negb (cmp_of_comparison Ceq x).
Proof.
  intros. destruct x as [[]|]; reflexivity.
Qed.

Lemma cmp_of_comparison_lt_eq_false:
  forall x, cmp_of_comparison Clt x = true -> cmp_of_comparison Ceq x = true -> False.
Proof.
  destruct x as [[]|]; simpl; intros; discriminate.
Qed.

Lemma cmp_of_comparison_le_lt_eq:
  forall x, cmp_of_comparison Cle x = cmp_of_comparison Clt x || cmp_of_comparison Ceq x.
Proof.
  destruct x as [[]|]; reflexivity.
Qed.

Lemma cmp_of_comparison_gt_eq_false:
  forall x, cmp_of_comparison Cgt x = true -> cmp_of_comparison Ceq x = true -> False.
Proof.
  destruct x as [[]|]; simpl; intros; discriminate.
Qed.

Lemma cmp_of_comparison_ge_gt_eq:
  forall x, cmp_of_comparison Cge x = cmp_of_comparison Cgt x || cmp_of_comparison Ceq x.
Proof.
  destruct x as [[]|]; reflexivity.
Qed.

Lemma cmp_of_comparison_lt_gt_false:
  forall x, cmp_of_comparison Clt x = true -> cmp_of_comparison Cgt x = true -> False.
Proof.
  destruct x as [[]|]; simpl; intros; discriminate.
Qed.

(** Normalization of NaN payloads *)

Lemma normalized_nan: forall prec n p,
  Z.of_nat n = prec - 1 -> 1 < prec ->
  nan_pl prec (Z.to_pos (P_mod_two_p p n)) = true.
Proof.
  intros. unfold nan_pl. apply Z.ltb_lt. rewrite Digits.Zpos_digits2_pos.
  set (p' := P_mod_two_p p n).
  assert (A: 0 <= p' < 2 ^ Z.of_nat n).
  { rewrite <- two_power_nat_equiv; apply P_mod_two_p_range. }
  assert (B: Digits.Zdigits radix2 p' <= prec - 1).
  { apply Digits.Zdigits_le_Zpower. rewrite <- H. rewrite Z.abs_eq; tauto. }
  destruct (zeq p' 0).
- rewrite e. simpl; auto.
- rewrite Z2Pos.id by lia. lia.
Qed.

(** Transform a Nan payload to a quiet Nan payload. *)

Definition quiet_nan_64_payload (p: positive) :=
  Z.to_pos (P_mod_two_p (Pos.lor p ((iter_nat xO 51 1%positive))) 52%nat).

Lemma quiet_nan_64_proof: forall p, nan_pl 53 (quiet_nan_64_payload p) = true.
Proof. intros; apply normalized_nan; auto; lia. Qed.

Definition quiet_nan_64 (sp: bool * positive) : {x :float | is_nan _ _ x = true} :=
  let (s, p) := sp in
  exist _ (B754_nan 53 1024 s (quiet_nan_64_payload p) (quiet_nan_64_proof p)) (eq_refl true).

Definition default_nan_64 := quiet_nan_64 Archi.default_nan_64.

Definition quiet_nan_32_payload (p: positive) :=
  Z.to_pos (P_mod_two_p (Pos.lor p ((iter_nat xO 22 1%positive))) 23%nat).

Lemma quiet_nan_32_proof: forall p, nan_pl 24 (quiet_nan_32_payload p) = true.
Proof. intros; apply normalized_nan; auto; lia. Qed.

Definition quiet_nan_32 (sp: bool * positive) : {x :float32 | is_nan _ _ x = true} :=
  let (s, p) := sp in
  exist _ (B754_nan 24 128 s (quiet_nan_32_payload p) (quiet_nan_32_proof p)) (eq_refl true).

Definition default_nan_32 := quiet_nan_32 Archi.default_nan_32.

Local Notation __ := (eq_refl Datatypes.Lt).

Local Hint Extern 1 (Prec_gt_0 _) => exact (eq_refl Datatypes.Lt) : core.
Local Hint Extern 1 (_ < _) => exact (eq_refl Datatypes.Lt) : core.

(** * Double-precision FP numbers *)

Module Float.

(** ** NaN payload manipulations *)

(** The following definitions are not part of the IEEE754 standard but
    apply to all architectures supported by CompCert. *)

(** Nan payload operations for single <-> double conversions. *)

Definition expand_nan_payload (p: positive) := Pos.shiftl_nat p 29.

Lemma expand_nan_proof (p : positive) :
  nan_pl 24 p = true ->
  nan_pl 53 (expand_nan_payload p) = true.
Proof.
  unfold nan_pl, expand_nan_payload. intros K.
  rewrite Z.ltb_lt in *.
  unfold Pos.shiftl_nat, nat_rect, Digits.digits2_pos.
  fold (Digits.digits2_pos p).
  zify; lia.
Qed.

Definition expand_nan s p H : {x | is_nan _ _ x = true} :=
  exist _ (B754_nan 53 1024 s (expand_nan_payload p) (expand_nan_proof p H)) (eq_refl true).

Definition of_single_nan (f : float32) : { x : float | is_nan _ _ x = true } :=
  match f with
  | B754_nan _ _ s p H =>
    if Archi.float_of_single_preserves_sNaN
    then expand_nan s p H
    else quiet_nan_64 (s, expand_nan_payload p)
  | _ => default_nan_64
  end.

Definition reduce_nan_payload (p: positive) :=
  (* The [quiet_nan_64_payload p] before the right shift is redundant with
     the [quiet_nan_32_payload p] performed after, in [to_single_nan].
     However the former ensures that the result of the right shift is
     not 0 and therefore representable as a positive. *)
  Pos.shiftr_nat (quiet_nan_64_payload p) 29.

Definition to_single_nan (f : float) : { x : float32 | is_nan _ _ x = true } :=
  match f with
  | B754_nan _ _ s p H => quiet_nan_32 (s, reduce_nan_payload p)
  | _ => default_nan_32
  end.

(** NaN payload operations for opposite and absolute value. *)

Definition neg_nan (f : float) : { x : float | is_nan _ _ x = true } :=
  match f with
  | B754_nan _ _ s p H => exist _ (B754_nan 53 1024 (negb s) p H) (eq_refl true)
  | _ => default_nan_64
  end.

Definition abs_nan (f : float) : { x : float | is_nan _ _ x = true } :=
  match f with
  | B754_nan _ _ s p H => exist _ (B754_nan 53 1024 false p H) (eq_refl true)
  | _ => default_nan_64
  end.

(** When an arithmetic operation returns a NaN, the sign and payload
  of this NaN are not fully specified by the IEEE standard, and vary
  among the architectures supported by CompCert.  However, the following
  behavior applies to all the supported architectures: the payload is either
- a default payload, independent of the arguments, or
- the payload of one of the NaN arguments, if any.

For each supported architecture, the functions [Archi.choose_nan_64]
and [Archi.choose_nan_32] determine the payload of the result as a
function of the payloads of the NaN arguments.

Additionally, signaling NaNs are converted to quiet NaNs, as required by the standard.
*)

Definition cons_pl (x: float) (l: list (bool * positive)) :=
  match x with B754_nan _ _ s p _ => (s, p) :: l | _ => l end.

Definition unop_nan (x: float) : {x : float | is_nan _ _ x = true} :=
  quiet_nan_64 (Archi.choose_nan_64 (cons_pl x nil)).

Definition binop_nan (x y: float) : {x : float | is_nan _ _ x = true} :=
  quiet_nan_64 (Archi.choose_nan_64 (cons_pl x (cons_pl y nil))).

(** For fused multiply-add, the order in which arguments are examined
  to select a NaN payload varies across platforms.  E.g. in [fma x y z],
  x86 considers [x] first, then [y], then [z], while ARM considers [z] first,
  then [x], then [y].  The corresponding permutation is defined
  for each target, as function [Archi.fma_order]. *)

Definition fma_nan_1 (x y z: float) : {x : float | is_nan _ _ x = true} :=
  let '(a, b, c) := Archi.fma_order x y z in
  quiet_nan_64 (Archi.choose_nan_64 (cons_pl a (cons_pl b (cons_pl c nil)))).

(** One last wrinkle for fused multiply-add: [fma zero infinity nan]
  can return either the quiesced [nan], or the default NaN arising out
  of the invalid operation [zero * infinity].  Of our target platforms,
  only ARM honors the latter case.  The choice between the default NaN
  and [nan] is done as in the case of two-argument arithmetic operations. *)

Definition fma_nan (x y z: float) : {x : float | is_nan _ _ x = true} :=
  match x, y with
  | B754_infinity _ _ _, B754_zero _ _ _ | B754_zero _ _ _, B754_infinity _ _ _ =>
      if Archi.fma_invalid_mul_is_nan
      then quiet_nan_64 (Archi.choose_nan_64 (Archi.default_nan_64 :: cons_pl z nil))
      else fma_nan_1 x y z
  | _, _ =>
      fma_nan_1 x y z
  end.

(** ** Operations over double-precision floats *)

Definition zero: float := B754_zero _ _ false. (**r the float [+0.0] *)

Definition eq_dec: forall (f1 f2: float), {f1 = f2} + {f1 <> f2} := Beq_dec _ _.

(** Arithmetic operations *)

Definition neg: float -> float := Bopp _ _ neg_nan. (**r opposite (change sign) *)
Definition abs: float -> float := Babs _ _ abs_nan. (**r absolute value (set sign to [+]) *)
Definition sqrt: float -> float :=
  Bsqrt 53 1024 __ __ unop_nan mode_NE.  (**r square root *)
Definition add: float -> float -> float :=
  Bplus 53 1024 __ __ binop_nan mode_NE. (**r addition *)
Definition sub: float -> float -> float :=
  Bminus 53 1024 __ __ binop_nan mode_NE. (**r subtraction *)
Definition mul: float -> float -> float :=
  Bmult 53 1024 __ __ binop_nan mode_NE. (**r multiplication *)
Definition div: float -> float -> float :=
  Bdiv 53 1024 __ __ binop_nan mode_NE. (**r division *)
Definition fma: float -> float -> float -> float :=
  Bfma 53 1024 __ __ fma_nan mode_NE. (**r fused multiply-add [x * y + z] *)
Definition compare (f1 f2: float) : option Datatypes.comparison := (**r general comparison *)
  Bcompare 53 1024 f1 f2.
Definition cmp (c:comparison) (f1 f2: float) : bool := (**r Boolean comparison *)
  cmp_of_comparison c (compare f1 f2).
Definition ordered (f1 f2: float) : bool :=
  ordered_of_comparison (compare f1 f2).

(** Conversions *)

Definition of_single: float32 -> float := Bconv _ _ 53 1024 __ __ of_single_nan mode_NE.
Definition to_single: float -> float32 := Bconv _ _ 24 128 __ __ to_single_nan mode_NE.

Definition to_int (f:float): option int := (**r conversion to signed 32-bit int *)
  option_map Int.repr (ZofB_range _ _ f Int.min_signed Int.max_signed).
Definition to_intu (f:float): option int := (**r conversion to unsigned 32-bit int *)
  option_map Int.repr (ZofB_range _ _ f 0 Int.max_unsigned).
Definition to_long (f:float): option int64 := (**r conversion to signed 64-bit int *)
  option_map Int64.repr (ZofB_range _ _ f Int64.min_signed Int64.max_signed).
Definition to_longu (f:float): option int64 := (**r conversion to unsigned 64-bit int *)
  option_map Int64.repr (ZofB_range _ _ f 0 Int64.max_unsigned).

Definition of_int (n:int): float := (**r conversion from signed 32-bit int *)
  BofZ 53 1024 __ __ (Int.signed n).
Definition of_intu (n:int): float:= (**r conversion from unsigned 32-bit int *)
  BofZ 53 1024 __ __ (Int.unsigned n).

Definition of_long (n:int64): float := (**r conversion from signed 64-bit int *)
  BofZ 53 1024 __ __ (Int64.signed n).
Definition of_longu (n:int64): float:= (**r conversion from unsigned 64-bit int *)
  BofZ 53 1024 __ __ (Int64.unsigned n).

Definition from_parsed (base:positive) (intPart:positive) (expPart:Z) : float :=
  Bparse 53 1024 __ __ base intPart expPart.

(** Conversions between floats and their concrete in-memory representation
    as a sequence of 64 bits. *)

Definition to_bits (f: float): int64 := Int64.repr (bits_of_b64 f).
Definition of_bits (b: int64): float := b64_of_bits (Int64.unsigned b).

Definition from_words (hi lo: int) : float := of_bits (Int64.ofwords hi lo).

(** ** Properties *)

(** Below are the only properties of floating-point arithmetic that we
  rely on in the compiler proof. *)

(** Some tactics **)

Ltac compute_this val :=
  let x := fresh in set val as x in *; vm_compute in x; subst x.

Ltac smart_lia :=
  simpl radix_val in *; simpl Z.pow in *;
  compute_this Int.modulus; compute_this Int.half_modulus;
  compute_this Int.max_unsigned;
  compute_this Int.min_signed; compute_this Int.max_signed;
  compute_this Int64.modulus; compute_this Int64.half_modulus;
  compute_this Int64.max_unsigned;
  compute_this (Z.pow_pos 2 1024); compute_this (Z.pow_pos 2 53); compute_this (Z.pow_pos 2 52); compute_this (Z.pow_pos 2 32);
  zify; lia.

(** Commutativity properties of addition and multiplication. *)

Theorem add_commut:
  forall x y, is_nan _ _ x = false \/ is_nan _ _ y = false -> add x y = add y x.
Proof.
  intros. apply Bplus_commut.
  destruct x, y; try reflexivity; now destruct H.
Qed.

Theorem mul_commut:
  forall x y, is_nan _ _ x = false \/ is_nan _ _ y = false -> mul x y = mul y x.
Proof.
  intros. apply Bmult_commut.
  destruct x, y; try reflexivity; now destruct H.
Qed.

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

Theorem mul2_add:
  forall f, add f f = mul f (of_int (Int.repr 2%Z)).
Proof.
  intros. apply Bmult2_Bplus.
  intros x y Hx Hy. unfold binop_nan.
  destruct x; try discriminate. simpl. rewrite Archi.choose_nan_64_idem.
  destruct y; reflexivity || discriminate.
Qed.

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

Definition exact_inverse : float -> option float := Bexact_inverse 53 1024 __ __.

Theorem div_mul_inverse:
  forall x y z, exact_inverse y = Some z -> div x y = mul x z.
Proof.
  intros. apply Bdiv_mult_inverse. 2: easy.
  intros x0 y0 z0 Hx Hy Hz. unfold binop_nan.
  destruct x0; try discriminate.
  destruct y0, z0; reflexivity || discriminate.
Qed.

(** Properties of comparisons. *)

Theorem cmp_swap:
  forall c x y, cmp (swap_comparison c) x y = cmp c y x.
Proof.
  unfold cmp, compare; intros. rewrite (Bcompare_swap _ _ x y).
  apply cmp_of_comparison_swap.
Qed.

Theorem cmp_ne_eq:
  forall f1 f2, cmp Cne f1 f2 = negb (cmp Ceq f1 f2).
Proof.
  intros; apply cmp_of_comparison_ne_eq.
Qed.

Theorem cmp_lt_eq_false:
  forall f1 f2, cmp Clt f1 f2 = true -> cmp Ceq f1 f2 = true -> False.
Proof.
  intros f1 f2; apply cmp_of_comparison_lt_eq_false.
Qed.

Theorem cmp_le_lt_eq:
  forall f1 f2, cmp Cle f1 f2 = cmp Clt f1 f2 || cmp Ceq f1 f2.
Proof.
  intros f1 f2; apply cmp_of_comparison_le_lt_eq.
Qed.

Theorem cmp_gt_eq_false:
  forall x y, cmp Cgt x y = true -> cmp Ceq x y = true -> False.
Proof.
  intros f1 f2; apply cmp_of_comparison_gt_eq_false.
Qed.

Theorem cmp_ge_gt_eq:
  forall f1 f2, cmp Cge f1 f2 = cmp Cgt f1 f2 || cmp Ceq f1 f2.
Proof.
  intros f1 f2; apply cmp_of_comparison_ge_gt_eq.
Qed.

Theorem cmp_lt_gt_false:
  forall f1 f2, cmp Clt f1 f2 = true -> cmp Cgt f1 f2 = true -> False.
Proof.
  intros f1 f2; apply cmp_of_comparison_lt_gt_false.
Qed.

(** Properties of conversions to/from in-memory representation.
  The conversions are bijective (one-to-one). *)

Theorem of_to_bits:
  forall f, of_bits (to_bits f) = f.
Proof.
  intros; unfold of_bits, to_bits, bits_of_b64, b64_of_bits.
  rewrite Int64.unsigned_repr, binary_float_of_bits_of_binary_float; [reflexivity|].
  generalize (bits_of_binary_float_range 52 11 __ __ f).
  change (2^(52+11+1)) with (Int64.max_unsigned + 1). lia.
Qed.

Theorem to_of_bits:
  forall b, to_bits (of_bits b) = b.
Proof.
  intros; unfold of_bits, to_bits, bits_of_b64, b64_of_bits.
  rewrite bits_of_binary_float_of_bits. apply Int64.repr_unsigned.
  apply Int64.unsigned_range.
Qed.

(** Conversions between floats and unsigned ints can be defined
  in terms of conversions between floats and signed ints.
  (Most processors provide only the latter, forcing the compiler
  to emulate the former.)   *)

Definition ox8000_0000 := Int.repr Int.half_modulus.  (**r [0x8000_0000] *)
Definition ox7FFF_FFFF := Int.repr Int.max_signed.    (**r [0x7FFF_FFFF] *)

Theorem of_intu_of_int_1:
  forall x,
  Int.ltu x ox8000_0000 = true ->
  of_intu x = of_int x.
Proof.
  unfold of_intu, of_int, Int.signed, Int.ltu; intro.
  change (Int.unsigned ox8000_0000) with Int.half_modulus.
  destruct (zlt (Int.unsigned x) Int.half_modulus); now intuition.
Qed.

Theorem of_intu_of_int_2:
  forall x,
  Int.ltu x ox8000_0000 = false ->
  of_intu x = add (of_int (Int.sub x ox8000_0000)) (of_intu ox8000_0000).
Proof.
  unfold add, of_intu, of_int; intros.
  set (y := Int.sub x ox8000_0000).
  pose proof (Int.unsigned_range x); pose proof (Int.signed_range y).
  assert (Ry: integer_representable 53 1024 (Int.signed y)).
  { apply integer_representable_n; auto; smart_lia. }
  assert (R8: integer_representable 53 1024 (Int.unsigned ox8000_0000)).
  { apply integer_representable_2p with (p := 31);auto; smart_lia. }
  rewrite BofZ_plus by auto.
  f_equal.
  unfold Int.ltu in H. destruct zlt in H; try discriminate.
  unfold y, Int.sub. rewrite Int.signed_repr. lia.
  compute_this (Int.unsigned ox8000_0000); smart_lia.
Qed.

Theorem of_intu_of_int_3:
  forall x,
  of_intu x = sub (of_int (Int.and x ox7FFF_FFFF)) (of_int (Int.and x ox8000_0000)).
Proof.
  intros.
  set (hi := Int.and x ox8000_0000).
  set (lo := Int.and x ox7FFF_FFFF).
  assert (R: forall n, integer_representable 53 1024 (Int.signed n)).
  { intros. pose proof (Int.signed_range n).
    apply integer_representable_n; auto; smart_lia. }
  unfold sub, of_int. rewrite BofZ_minus by auto. unfold of_intu. f_equal.
  assert (E: Int.add hi lo = x).
  { unfold hi, lo. rewrite Int.add_is_or.
  - rewrite <- Int.and_or_distrib. apply Int.and_mone.
  - rewrite Int.and_assoc. rewrite (Int.and_commut ox8000_0000). rewrite Int.and_assoc.
    change (Int.and ox7FFF_FFFF ox8000_0000) with Int.zero. rewrite ! Int.and_zero; auto.
  }
  assert (RNG: 0 <= Int.unsigned lo < two_p 31).
  { unfold lo. change ox7FFF_FFFF with (Int.repr (two_p 31 - 1)). rewrite <- Int.zero_ext_and by lia.
    apply Int.zero_ext_range. compute_this Int.zwordsize. lia. }
  assert (B: forall i, 0 <= i < Int.zwordsize -> Int.testbit ox8000_0000 i = if zeq i 31 then true else false).
  { intros; unfold Int.testbit. change (Int.unsigned ox8000_0000) with (2^31).
    destruct (zeq i 31). subst i; auto. apply Z.pow2_bits_false; auto. }
  assert (EITHER: hi = Int.zero \/ hi = ox8000_0000).
  { unfold hi; destruct (Int.testbit x 31) eqn:B31; [right|left];
    Int.bit_solve; rewrite B by auto.
  - destruct (zeq i 31). subst i; rewrite B31; auto. apply andb_false_r.
  - destruct (zeq i 31). subst i; rewrite B31; auto. apply andb_false_r.
  }
  assert (SU: - Int.signed hi = Int.unsigned hi).
  { destruct EITHER as [EQ|EQ]; rewrite EQ; reflexivity. }
  unfold Z.sub; rewrite SU, <- E.
  unfold Int.add; rewrite Int.unsigned_repr, Int.signed_eq_unsigned. lia.
  - assert (Int.max_signed = two_p 31 - 1) by reflexivity. lia.
  - assert (Int.unsigned hi = 0 \/ Int.unsigned hi = two_p 31)
    by (destruct EITHER as [EQ|EQ]; rewrite EQ; [left|right]; reflexivity).
    assert (Int.max_unsigned = two_p 31 + two_p 31 - 1) by reflexivity.
    lia.
Qed.

Theorem to_intu_to_int_1:
  forall x n,
  cmp Clt x (of_intu ox8000_0000) = true ->
  to_intu x = Some n ->
  to_int x = Some n.
Proof.
  intros. unfold to_intu in H0.
  destruct (ZofB_range 53 1024 x 0 Int.max_unsigned) as [p|] eqn:E; simpl in H0; inv H0.
  exploit ZofB_range_inversion; eauto. intros (A & B & C).
  unfold to_int, ZofB_range. rewrite C.
  rewrite Zle_bool_true by smart_lia. rewrite Zle_bool_true; auto.
  exploit (BofZ_exact 53 1024 __ __ (Int.unsigned ox8000_0000)).
  vm_compute; intuition congruence.
  set (y := of_intu ox8000_0000) in *.
  change (BofZ 53 1024 eq_refl eq_refl (Int.unsigned ox8000_0000)) with y.
  intros (EQy & FINy & SIGNy).
  assert (FINx: is_finite _ _ x = true).
  { rewrite ZofB_correct in C. destruct (is_finite _ _ x) eqn:FINx; congruence. }
  destruct (zeq p 0).
  subst p; smart_lia.
  destruct (ZofB_range_pos 53 1024 __ __ x p C) as [P Q]. lia.
  assert (CMP: Bcompare _ _ x y = Some Lt).
  { unfold cmp, cmp_of_comparison, compare in H. destruct (Bcompare _ _ x y) as [[]|]; auto; discriminate. }
  rewrite Bcompare_correct in CMP by auto.
  inv CMP. apply Rcompare_Lt_inv in H1. rewrite EQy in H1.
  assert (p < Int.unsigned ox8000_0000).
  { apply lt_IZR. apply Rle_lt_trans with (1 := P) (2 := H1). }
  change Int.max_signed with (Int.unsigned ox8000_0000 - 1). lia.
Qed.

Theorem to_intu_to_int_2:
  forall x n,
  cmp Clt x (of_intu ox8000_0000) = false ->
  to_intu x = Some n ->
  to_int (sub x (of_intu ox8000_0000)) = Some (Int.sub n ox8000_0000).
Proof.
  intros. unfold to_intu in H0.
  destruct (ZofB_range _ _ x 0 Int.max_unsigned) as [p|] eqn:E; simpl in H0; inv H0.
  exploit ZofB_range_inversion; eauto. intros (A & B & C).
  exploit (BofZ_exact 53 1024 __ __ (Int.unsigned ox8000_0000)).
  vm_compute; intuition congruence.
  set (y := of_intu ox8000_0000) in *.
  change (BofZ 53 1024 __ __ (Int.unsigned ox8000_0000)) with y.
  intros (EQy & FINy & SIGNy).
  assert (FINx: is_finite _ _ x = true).
  { rewrite ZofB_correct in C. destruct (is_finite _ _ x) eqn:FINx; congruence. }
  assert (GE: (B2R _ _ x >= IZR (Int.unsigned ox8000_0000))%R).
  { rewrite <- EQy. unfold cmp, cmp_of_comparison, compare in H.
    rewrite Bcompare_correct in H by auto.
    destruct (Rcompare (B2R 53 1024 x) (B2R 53 1024 y)) eqn:CMP.
    apply Req_ge; apply Rcompare_Eq_inv; auto.
    discriminate.
    apply Rgt_ge; apply Rcompare_Gt_inv; auto.
  }
  assert (EQ: ZofB_range _ _ (sub x y) Int.min_signed Int.max_signed = Some (p - Int.unsigned ox8000_0000)).
  { apply ZofB_range_minus. exact E.
    compute_this (Int.unsigned ox8000_0000). smart_lia.
    apply Rge_le; auto.
  }
  unfold to_int; rewrite EQ. simpl. unfold Int.sub. rewrite Int.unsigned_repr by lia. auto.
Qed.

(** Conversions from ints to floats can be defined as bitwise manipulations
  over the in-memory representation.  This is what the PowerPC port does.
  The trick is that [from_words 0x4330_0000 x] is the float
  [2^52 + of_intu x]. *)

Definition ox4330_0000 := Int.repr 1127219200.        (**r [0x4330_0000] *)

Lemma split_bits_or:
  forall x,
  split_bits 52 11 (Int64.unsigned (Int64.ofwords ox4330_0000 x)) = (false, Int.unsigned x, 1075).
Proof.
  intros.
  transitivity (split_bits 52 11 (join_bits 52 11 false (Int.unsigned x) 1075)).
  - f_equal. rewrite Int64.ofwords_add'. reflexivity.
  - apply split_join_bits.
    generalize (Int.unsigned_range x).
    compute_this Int.modulus; compute_this (2^52); lia.
    compute_this (2^11); lia.
Qed.

Lemma from_words_value:
  forall x,
     B2R _ _ (from_words ox4330_0000 x) = (bpow radix2 52 + IZR (Int.unsigned x))%R
  /\ is_finite _ _ (from_words ox4330_0000 x) = true
  /\ Bsign _ _ (from_words ox4330_0000 x) = false.
Proof.
  intros; unfold from_words, of_bits, b64_of_bits, binary_float_of_bits.
  rewrite B2R_FF2B, is_finite_FF2B, Bsign_FF2B.
  unfold binary_float_of_bits_aux; rewrite split_bits_or; simpl; pose proof (Int.unsigned_range x).
  destruct (Int.unsigned x + Z.pow_pos 2 52) eqn:?.
  exfalso; now smart_lia.
  simpl; rewrite <- Heqz;  unfold F2R; simpl. split; auto.
  rewrite Rmult_1_r, plus_IZR. apply Rplus_comm.
  exfalso; now smart_lia.
Qed.

Lemma from_words_eq:
  forall x, from_words ox4330_0000 x = BofZ 53 1024 __ __ (2^52 + Int.unsigned x).
Proof.
  intros.
  pose proof (Int.unsigned_range x).
  destruct (from_words_value x) as (A & B & C).
  destruct (BofZ_exact 53 1024 __ __ (2^52 + Int.unsigned x)) as (D & E & F).
  smart_lia.
  apply B2R_Bsign_inj; auto.
  rewrite A, D. rewrite plus_IZR. auto.
  rewrite C, F. symmetry. apply Zlt_bool_false. smart_lia.
Qed.

Theorem of_intu_from_words:
  forall x,
  of_intu x = sub (from_words ox4330_0000 x) (from_words ox4330_0000 Int.zero).
Proof.
  intros. pose proof (Int.unsigned_range x).
  rewrite ! from_words_eq. unfold sub. rewrite BofZ_minus.
  unfold of_intu. apply (f_equal (BofZ 53 1024 __ __)). rewrite Int.unsigned_zero. lia.
  apply integer_representable_n; auto; smart_lia.
  apply integer_representable_n; auto; rewrite Int.unsigned_zero; smart_lia.
Qed.

Lemma ox8000_0000_signed_unsigned:
  forall x,
    Int.unsigned (Int.add x ox8000_0000) = Int.signed x + Int.half_modulus.
Proof.
  intro; unfold Int.signed, Int.add; pose proof (Int.unsigned_range x).
  destruct (zlt (Int.unsigned x) Int.half_modulus).
  rewrite Int.unsigned_repr; compute_this (Int.unsigned ox8000_0000); now smart_lia.
  rewrite (Int.eqm_samerepr _ (Int.unsigned x + -2147483648)).
  rewrite Int.unsigned_repr; now smart_lia.
  apply Int.eqm_add; [now apply Int.eqm_refl|exists 1;reflexivity].
Qed.

Theorem of_int_from_words:
  forall x,
  of_int x = sub (from_words ox4330_0000 (Int.add x ox8000_0000))
                 (from_words ox4330_0000 ox8000_0000).
Proof.
  intros.
  pose proof (Int.signed_range x).
  rewrite ! from_words_eq. rewrite ox8000_0000_signed_unsigned.
  change (Int.unsigned ox8000_0000) with Int.half_modulus.
  unfold sub. rewrite BofZ_minus.
  unfold of_int. apply f_equal. lia.
  apply integer_representable_n; auto; smart_lia.
  apply integer_representable_n; auto; smart_lia.
Qed.

Definition ox4530_0000 := Int.repr 1160773632.        (**r [0x4530_0000] *)

Lemma split_bits_or':
  forall x,
  split_bits 52 11 (Int64.unsigned (Int64.ofwords ox4530_0000 x)) = (false, Int.unsigned x, 1107).
Proof.
  intros.
  transitivity (split_bits 52 11 (join_bits 52 11 false (Int.unsigned x) 1107)).
  - f_equal. rewrite Int64.ofwords_add'. reflexivity.
  - apply split_join_bits.
    generalize (Int.unsigned_range x).
    compute_this Int.modulus; compute_this (2^52); lia.
    compute_this (2^11); lia.
Qed.

Lemma from_words_value':
  forall x,
     B2R _ _ (from_words ox4530_0000 x) = (bpow radix2 84 + IZR (Int.unsigned x * two_p 32))%R
  /\ is_finite _ _ (from_words ox4530_0000 x) = true
  /\ Bsign _ _ (from_words ox4530_0000 x) = false.
Proof.
  intros; unfold from_words, of_bits, b64_of_bits, binary_float_of_bits.
  rewrite B2R_FF2B, is_finite_FF2B, Bsign_FF2B.
  unfold binary_float_of_bits_aux; rewrite split_bits_or'; simpl; pose proof (Int.unsigned_range x).
  destruct (Int.unsigned x + Z.pow_pos 2 52) eqn:?.
  exfalso; now smart_lia.
  simpl; rewrite <- Heqz;  unfold F2R; simpl. split; auto.
  rewrite plus_IZR, Rmult_plus_distr_r, <- 2!mult_IZR, Rplus_comm.
  easy.
  assert (Zneg p < 0) by reflexivity.
  exfalso; now smart_lia.
Qed.

Lemma from_words_eq':
  forall x, from_words ox4530_0000 x = BofZ 53 1024 __ __ (2^84 + Int.unsigned x * 2^32).
Proof.
  intros.
  pose proof (Int.unsigned_range x).
  destruct (from_words_value' x) as (A & B & C).
  destruct (BofZ_representable 53 1024 __ __ (2^84 + Int.unsigned x * 2^32)) as (D & E & F).
  replace (2^84 + Int.unsigned x * 2^32)
    with  ((2^52 + Int.unsigned x) * 2^32) by ring.
  apply integer_representable_n2p; auto. smart_lia. lia. lia.
  apply B2R_Bsign_inj; auto.
  rewrite A, D. rewrite <- IZR_Zpower by lia. rewrite <- plus_IZR. auto.
  rewrite C, F. symmetry. apply Zlt_bool_false.
  compute_this (2^84); compute_this (2^32); lia.
Qed.

Theorem of_longu_from_words:
  forall l,
  of_longu l =
    add (sub (from_words ox4530_0000 (Int64.hiword l))
             (from_words ox4530_0000 (Int.repr (two_p 20))))
        (from_words ox4330_0000 (Int64.loword l)).
Proof.
  intros.
  pose proof (Int64.unsigned_range l).
  pose proof (Int.unsigned_range (Int64.hiword l)).
  pose proof (Int.unsigned_range (Int64.loword l)).
  rewrite ! from_words_eq, ! from_words_eq'.
  set (p20 := Int.unsigned (Int.repr (two_p 20))).
  set (x := Int64.unsigned l) in *;
  set (xl := Int.unsigned (Int64.loword l)) in *;
  set (xh := Int.unsigned (Int64.hiword l)) in *.
  unfold sub. rewrite BofZ_minus.
  replace (2^84 + xh * 2^32 - (2^84 + p20 * 2^32))
     with ((xh - p20) * 2^32) by ring.
  unfold add. rewrite BofZ_plus.
  unfold of_longu. f_equal.
  rewrite <- (Int64.ofwords_recompose l) at 1. rewrite Int64.ofwords_add'.
  fold xh; fold xl. compute_this (two_p 32); compute_this p20; ring.
  apply integer_representable_n2p; auto.
  compute_this p20; smart_lia. lia. lia.
  apply integer_representable_n; auto; smart_lia.
  replace (2^84 + xh * 2^32) with ((2^52 + xh) * 2^32) by ring.
  apply integer_representable_n2p; auto. smart_lia. lia. lia.
  change (2^84 + p20 * 2^32) with ((2^52 + 1048576) * 2^32).
  apply integer_representable_n2p; auto. lia. lia.
Qed.

Theorem of_long_from_words:
  forall l,
  of_long l =
    add (sub (from_words ox4530_0000 (Int.add (Int64.hiword l) ox8000_0000))
             (from_words ox4530_0000 (Int.repr (two_p 20+two_p 31))))
        (from_words ox4330_0000 (Int64.loword l)).
Proof.
  intros.
  pose proof (Int64.signed_range l).
  pose proof (Int.signed_range (Int64.hiword l)).
  pose proof (Int.unsigned_range (Int64.loword l)).
  rewrite ! from_words_eq, ! from_words_eq'.
  set (p := Int.unsigned (Int.repr (two_p 20 + two_p 31))).
  set (x := Int64.signed l) in *;
  set (xl := Int.unsigned (Int64.loword l)) in *;
  set (xh := Int.signed (Int64.hiword l)) in *.
  rewrite ox8000_0000_signed_unsigned. fold xh.
  unfold sub. rewrite BofZ_minus.
  replace (2^84 + (xh + Int.half_modulus) * 2^32 - (2^84 + p * 2^32))
     with ((xh - 2^20) * 2^32)
       by (compute_this p; compute_this Int.half_modulus; ring).
  unfold add. rewrite BofZ_plus.
  unfold of_long. apply f_equal.
  rewrite <- (Int64.ofwords_recompose l) at 1. rewrite Int64.ofwords_add''.
  fold xh; fold xl. compute_this (two_p 32); ring.
  apply integer_representable_n2p; auto.
  compute_this (2^20); smart_lia. lia. lia.
  apply integer_representable_n; auto; smart_lia.
  replace (2^84 + (xh + Int.half_modulus) * 2^32)
     with ((2^52 + xh + Int.half_modulus) * 2^32)
       by (compute_this Int.half_modulus; ring).
  apply integer_representable_n2p; auto. smart_lia. lia. lia.
  change (2^84 + p * 2^32) with ((2^52 + p) * 2^32).
  apply integer_representable_n2p; auto.
  compute_this p; smart_lia. lia.
Qed.

(** Conversions from 64-bit integers can be expressed in terms of
  conversions from their 32-bit halves. *)

Theorem of_longu_decomp:
  forall l,
  of_longu l = add (mul (of_intu (Int64.hiword l)) (BofZ 53 1024 __ __ (2^32)))
                   (of_intu (Int64.loword l)).
Proof.
  intros.
  unfold of_longu, of_intu, add, mul.
  pose proof (Int.unsigned_range (Int64.loword l)).
  pose proof (Int.unsigned_range (Int64.hiword l)).
  pose proof (Int64.unsigned_range l).
  set (x := Int64.unsigned l) in *.
  set (yl := Int.unsigned (Int64.loword l)) in *.
  set (yh := Int.unsigned (Int64.hiword l)) in *.
  assert (DECOMP: x = yh * 2^32 + yl).
  { unfold x. rewrite <- (Int64.ofwords_recompose l). apply Int64.ofwords_add'. }
  rewrite BofZ_mult. rewrite BofZ_plus. rewrite DECOMP; auto.
  apply integer_representable_n2p; auto. smart_lia. lia. lia.
  apply integer_representable_n; auto; smart_lia.
  apply integer_representable_n; auto; smart_lia.
  apply integer_representable_n; auto; smart_lia.
  compute; auto.
Qed.

Theorem of_long_decomp:
  forall l,
  of_long l = add (mul (of_int (Int64.hiword l)) (BofZ 53 1024 __ __ (2^32)))
                  (of_intu (Int64.loword l)).
Proof.
  intros.
  unfold of_long, of_int, of_intu, add, mul.
  pose proof (Int.unsigned_range (Int64.loword l)).
  pose proof (Int.signed_range (Int64.hiword l)).
  pose proof (Int64.signed_range l).
  set (x := Int64.signed l) in *.
  set (yl := Int.unsigned (Int64.loword l)) in *.
  set (yh := Int.signed (Int64.hiword l)) in *.
  assert (DECOMP: x = yh * 2^32 + yl).
  { unfold x. rewrite <- (Int64.ofwords_recompose l), Int64.ofwords_add''. auto. }
  rewrite BofZ_mult. rewrite BofZ_plus. rewrite DECOMP; auto.
  apply integer_representable_n2p; auto. smart_lia. lia. lia.
  apply integer_representable_n; auto; smart_lia.
  apply integer_representable_n; auto; smart_lia.
  apply integer_representable_n; auto. compute; intuition congruence.
  compute; auto.
Qed.

(** Conversions from unsigned longs can be expressed in terms of conversions from signed longs.
    If the unsigned long is too big, a round-to-odd must be performed on it
    to avoid double rounding. *)

Theorem of_longu_of_long_1:
  forall x,
  Int64.ltu x (Int64.repr Int64.half_modulus) = true ->
  of_longu x = of_long x.
Proof.
  unfold of_longu, of_long, Int64.signed, Int64.ltu; intro.
  change (Int64.unsigned (Int64.repr Int64.half_modulus)) with Int64.half_modulus.
  destruct (zlt (Int64.unsigned x) Int64.half_modulus); now intuition.
Qed.

Theorem of_longu_of_long_2:
  forall x,
  Int64.ltu x (Int64.repr Int64.half_modulus) = false ->
  of_longu x = mul (of_long (Int64.or (Int64.shru x Int64.one)
                                      (Int64.and x Int64.one)))
                   (of_int (Int.repr 2)).
Proof.
  intros. change (of_int (Int.repr 2)) with (BofZ 53 1024 __ __ (2^1)).
  pose proof (Int64.unsigned_range x).
  unfold Int64.ltu in H.
  change (Int64.unsigned (Int64.repr Int64.half_modulus)) with (2^63) in H.
  destruct (zlt (Int64.unsigned x) (2^63)); inv H.
  assert (Int64.modulus <= 2^1024 - 2^(1024-53)) by (vm_compute; intuition congruence).
  set (n := Int64.or (Int64.shru x Int64.one) (Int64.and x Int64.one)).
  assert (NB: forall i, 0 <= i < 64 ->
              Int64.testbit n i =
                if zeq i 0 then Int64.testbit x 1 || Int64.testbit x 0
                else if zeq i 63 then false else Int64.testbit x (i + 1)).
  { intros; unfold n; autorewrite with ints; auto. rewrite Int64.unsigned_one.
    rewrite Int64.bits_one. compute_this Int64.zwordsize.
    destruct (zeq i 0); simpl proj_sumbool.
    rewrite zlt_true by lia. rewrite andb_true_r. subst i; auto.
    rewrite andb_false_r, orb_false_r.
    destruct (zeq i 63). subst i. apply zlt_false; lia.
    apply zlt_true; lia. }
  assert (NB2: forall i, 0 <= i ->
               Z.testbit (Int64.signed n * 2^1) i =
               if zeq i 0 then false else
               if zeq i 1 then Int64.testbit x 1 || Int64.testbit x 0 else
               Int64.testbit x i).
  { intros. rewrite Z.mul_pow2_bits by lia. destruct (zeq i 0).
    apply Z.testbit_neg_r; lia.
    rewrite Int64.bits_signed by lia. compute_this Int64.zwordsize.
    destruct (zlt (i-1) 64).
    rewrite NB by lia. destruct (zeq i 1).
    subst. rewrite dec_eq_true by auto. auto.
    rewrite dec_eq_false by lia. destruct (zeq (i - 1) 63).
    symmetry. apply Int64.bits_above. compute_this Int64.zwordsize; lia.
    f_equal; lia.
    rewrite NB by lia. rewrite dec_eq_false by lia. rewrite dec_eq_true by auto.
    rewrite dec_eq_false by lia. symmetry. apply Int64.bits_above. compute_this Int64.zwordsize; lia.
  }
  assert (EQ: Int64.signed n * 2 = int_round_odd (Int64.unsigned x) 1).
  {
  symmetry. apply (int_round_odd_bits 53 1024). lia.
  intros. rewrite NB2 by lia. replace i with 0 by lia. auto.
  rewrite NB2 by lia. rewrite dec_eq_false by lia. rewrite dec_eq_true.
  rewrite orb_comm. unfold Int64.testbit. change (2^1) with 2.
  destruct (Z.testbit (Int64.unsigned x) 0) eqn:B0;
  [rewrite Z.testbit_true in B0 by lia|rewrite Z.testbit_false in B0 by lia];
  change (2^0) with 1 in B0; rewrite Zdiv_1_r in B0; rewrite B0; auto.
  intros. rewrite NB2 by lia. rewrite ! dec_eq_false by lia. auto.
  }
  unfold mul, of_long, of_longu.
  rewrite BofZ_mult_2p.
- change (2^1) with 2. rewrite EQ. apply BofZ_round_odd with (p := 1).
+ lia.
+ apply Z.le_trans with Int64.modulus; trivial. smart_lia.
+ lia.
+ apply Z.le_trans with (2^63). compute; intuition congruence. lia.
- apply Z.le_trans with Int64.modulus; trivial.
  pose proof (Int64.signed_range n).
  compute_this Int64.min_signed; compute_this Int64.max_signed;
  compute_this Int64.modulus; lia.
- assert (2^63 <= int_round_odd (Int64.unsigned x) 1).
  { change (2^63) with (int_round_odd (2^63) 1). apply (int_round_odd_le 0 0); lia. }
  rewrite <- EQ in H1. compute_this (2^63). compute_this (2^53). lia.
- lia.
Qed.

(** Conversions to/from 32-bit integers can be implemented by going through 64-bit integers. *)

Remark ZofB_range_widen:
  forall (f: float) n min1 max1 min2 max2,
  ZofB_range _ _ f min1 max1 = Some n ->
  min2 <= min1 -> max1 <= max2 ->
  ZofB_range _ _ f min2 max2 = Some n.
Proof.
  intros. exploit ZofB_range_inversion; eauto. intros (A & B & C).
  unfold ZofB_range; rewrite C.
  replace (min2 <=? n) with true. replace (n <=? max2) with true. auto.
  symmetry; apply Z.leb_le; lia.
  symmetry; apply Z.leb_le; lia.
Qed.

Theorem to_int_to_long:
  forall f n, to_int f = Some n -> to_long f = Some (Int64.repr (Int.signed n)).
Proof.
  unfold to_int, to_long; intros.
  destruct (ZofB_range 53 1024 f Int.min_signed Int.max_signed) as [z|] eqn:Z; inv H.
  exploit ZofB_range_inversion; eauto. intros (A & B & C).
  replace (ZofB_range 53 1024 f Int64.min_signed Int64.max_signed) with (Some z).
  simpl. rewrite Int.signed_repr; auto.
  symmetry; eapply ZofB_range_widen; eauto. compute; congruence. compute; congruence.
Qed.

Theorem to_intu_to_longu:
  forall f n, to_intu f = Some n -> to_longu f = Some (Int64.repr (Int.unsigned n)).
Proof.
  unfold to_intu, to_longu; intros.
  destruct (ZofB_range 53 1024 f 0 Int.max_unsigned) as [z|] eqn:Z; inv H.
  exploit ZofB_range_inversion; eauto. intros (A & B & C).
  replace (ZofB_range 53 1024 f 0 Int64.max_unsigned) with (Some z).
  simpl. rewrite Int.unsigned_repr; auto.
  symmetry; eapply ZofB_range_widen; eauto. lia. compute; congruence.
Qed.

Theorem to_intu_to_long:
  forall f n, to_intu f = Some n -> to_long f = Some (Int64.repr (Int.unsigned n)).
Proof.
  unfold to_intu, to_long; intros.
  destruct (ZofB_range 53 1024 f 0 Int.max_unsigned) as [z|] eqn:Z; inv H.
  exploit ZofB_range_inversion; eauto. intros (A & B & C).
  replace (ZofB_range 53 1024 f Int64.min_signed Int64.max_signed) with (Some z).
  simpl. rewrite Int.unsigned_repr; auto.
  symmetry; eapply ZofB_range_widen; eauto. compute; congruence. compute; congruence.
Qed.

Theorem of_int_of_long:
  forall n, of_int n = of_long (Int64.repr (Int.signed n)).
Proof.
  unfold of_int, of_long. intros. f_equal. rewrite Int64.signed_repr. auto.
  generalize (Int.signed_range n). compute_this Int64.min_signed. compute_this Int64.max_signed. smart_lia.
Qed.

Theorem of_intu_of_longu:
  forall n, of_intu n = of_longu (Int64.repr (Int.unsigned n)).
Proof.
  unfold of_intu, of_longu. intros. f_equal. rewrite Int64.unsigned_repr. auto.
  generalize (Int.unsigned_range n). smart_lia.
Qed.

Theorem of_intu_of_long:
  forall n, of_intu n = of_long (Int64.repr (Int.unsigned n)).
Proof.
  unfold of_intu, of_long. intros. f_equal. rewrite Int64.signed_repr. auto.
  generalize (Int.unsigned_range n). compute_this Int64.min_signed; compute_this Int64.max_signed; smart_lia.
Qed.

End Float.

(** * Single-precision FP numbers *)

Module Float32.

Definition neg_nan (f : float32) : { x : float32 | is_nan _ _ x = true } :=
  match f with
  | B754_nan _ _ s p H => exist _ (B754_nan 24 128 (negb s) p H) (eq_refl true)
  | _ => default_nan_32
  end.

Definition abs_nan (f : float32) : { x : float32 | is_nan _ _ x = true } :=
  match f with
  | B754_nan _ _ s p H => exist _ (B754_nan 24 128 false p H) (eq_refl true)
  | _ => default_nan_32
  end.

Definition cons_pl (x: float32) (l: list (bool * positive)) :=
  match x with B754_nan _ _ s p _ => (s, p) :: l | _ => l end.

Definition unop_nan (x: float32) : {x : float32 | is_nan _ _ x = true} :=
  quiet_nan_32 (Archi.choose_nan_32 (cons_pl x nil)).

Definition binop_nan (x y: float32) : {x : float32 | is_nan _ _ x = true} :=
  quiet_nan_32 (Archi.choose_nan_32 (cons_pl x (cons_pl y nil))).

Definition fma_nan_1 (x y z: float32) : {x : float32 | is_nan _ _ x = true} :=
  let '(a, b, c) := Archi.fma_order x y z in
  quiet_nan_32 (Archi.choose_nan_32 (cons_pl a (cons_pl b (cons_pl c nil)))).

Definition fma_nan (x y z: float32) : {x : float32 | is_nan _ _ x = true} :=
  match x, y with
  | B754_infinity _ _ _, B754_zero _ _ _ | B754_zero _ _ _, B754_infinity _ _ _ =>
      if Archi.fma_invalid_mul_is_nan
      then quiet_nan_32 (Archi.choose_nan_32 (Archi.default_nan_32 :: cons_pl z nil))
      else fma_nan_1 x y z
  | _, _ =>
      fma_nan_1 x y z
  end.

(** ** Operations over single-precision floats *)

Definition zero: float32 := B754_zero _ _ false. (**r the float [+0.0] *)

Definition eq_dec: forall (f1 f2: float32), {f1 = f2} + {f1 <> f2} := Beq_dec _ _.

(** Arithmetic operations *)

Definition neg: float32 -> float32 := Bopp _ _ neg_nan. (**r opposite (change sign) *)
Definition abs: float32 -> float32 := Babs _ _ abs_nan. (**r absolute value (set sign to [+]) *)
Definition sqrt: float32 -> float32 :=
  Bsqrt 24 128 __ __ unop_nan mode_NE.  (**r square root *)
Definition add: float32 -> float32 -> float32 :=
  Bplus 24 128 __ __ binop_nan mode_NE. (**r addition *)
Definition sub: float32 -> float32 -> float32 :=
  Bminus 24 128 __ __ binop_nan mode_NE. (**r subtraction *)
Definition mul: float32 -> float32 -> float32 :=
  Bmult 24 128 __ __ binop_nan mode_NE. (**r multiplication *)
Definition div: float32 -> float32 -> float32 :=
  Bdiv 24 128 __ __ binop_nan mode_NE. (**r division *)
Definition fma: float32 -> float32 -> float32 -> float32 :=
  Bfma 24 128 __ __ fma_nan mode_NE. (**r fused multiply-add [x * y + z] *)
Definition compare (f1 f2: float32) : option Datatypes.comparison := (**r general comparison *)
  Bcompare 24 128 f1 f2.
Definition cmp (c:comparison) (f1 f2: float32) : bool := (**r comparison *)
  cmp_of_comparison c (compare f1 f2).
Definition ordered (f1 f2: float32) : bool :=
  ordered_of_comparison (compare f1 f2).

(** Conversions *)

Definition of_double : float -> float32 := Float.to_single.
Definition to_double : float32 -> float := Float.of_single.

Definition to_int (f:float32): option int := (**r conversion to signed 32-bit int *)
  option_map Int.repr (ZofB_range _ _ f Int.min_signed Int.max_signed).
Definition to_intu (f:float32): option int := (**r conversion to unsigned 32-bit int *)
  option_map Int.repr (ZofB_range _ _ f 0 Int.max_unsigned).
Definition to_long (f:float32): option int64 := (**r conversion to signed 64-bit int *)
  option_map Int64.repr (ZofB_range _ _ f Int64.min_signed Int64.max_signed).
Definition to_longu (f:float32): option int64 := (**r conversion to unsigned 64-bit int *)
  option_map Int64.repr (ZofB_range _ _ f 0 Int64.max_unsigned).

Definition of_int (n:int): float32 := (**r conversion from signed 32-bit int to single-precision float *)
  BofZ 24 128 __ __ (Int.signed n).
Definition of_intu (n:int): float32 := (**r conversion from unsigned 32-bit int to single-precision float *)
  BofZ 24 128 __ __ (Int.unsigned n).

Definition of_long (n:int64): float32 := (**r conversion from signed 64-bit int to single-precision float *)
  BofZ 24 128 __ __ (Int64.signed n).
Definition of_longu (n:int64): float32 := (**r conversion from unsigned 64-bit int to single-precision float *)
  BofZ 24 128 __ __ (Int64.unsigned n).

Definition from_parsed (base:positive) (intPart:positive) (expPart:Z) : float32 :=
  Bparse 24 128 __ __ base intPart expPart.

(** Conversions between floats and their concrete in-memory representation
    as a sequence of 32 bits. *)

Definition to_bits (f: float32) : int := Int.repr (bits_of_b32 f).
Definition of_bits (b: int): float32 := b32_of_bits (Int.unsigned b).

(** ** Properties *)

(** Commutativity properties of addition and multiplication. *)

Theorem add_commut:
  forall x y, is_nan _ _ x = false \/ is_nan _ _ y = false -> add x y = add y x.
Proof.
  intros. apply Bplus_commut.
  destruct x, y; try reflexivity; now destruct H.
Qed.

Theorem mul_commut:
  forall x y, is_nan _ _ x = false \/ is_nan _ _ y = false -> mul x y = mul y x.
Proof.
  intros. apply Bmult_commut.
  destruct x, y; try reflexivity; now destruct H.
Qed.

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

Theorem mul2_add:
  forall f, add f f = mul f (of_int (Int.repr 2%Z)).
Proof.
  intros. apply Bmult2_Bplus.
  intros x y Hx Hy. unfold binop_nan.
  destruct x; try discriminate. simpl. rewrite Archi.choose_nan_32_idem.
  destruct y; reflexivity || discriminate.
Qed.

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

Definition exact_inverse : float32 -> option float32 := Bexact_inverse 24 128 __ __.

Theorem div_mul_inverse:
  forall x y z, exact_inverse y = Some z -> div x y = mul x z.
Proof.
  intros. apply Bdiv_mult_inverse. 2: easy.
  intros x0 y0 z0 Hx Hy Hz. unfold binop_nan.
  destruct x0; try discriminate.
  destruct y0, z0; reflexivity || discriminate.
Qed.

(** Properties of comparisons. *)

Theorem cmp_swap:
  forall c x y, cmp (swap_comparison c) x y = cmp c y x.
Proof.
  unfold cmp, compare; intros. rewrite (Bcompare_swap _ _ x y).
  apply cmp_of_comparison_swap.
Qed.

Theorem cmp_ne_eq:
  forall f1 f2, cmp Cne f1 f2 = negb (cmp Ceq f1 f2).
Proof.
  intros; apply cmp_of_comparison_ne_eq.
Qed.

Theorem cmp_lt_eq_false:
  forall f1 f2, cmp Clt f1 f2 = true -> cmp Ceq f1 f2 = true -> False.
Proof.
  intros f1 f2; apply cmp_of_comparison_lt_eq_false.
Qed.

Theorem cmp_le_lt_eq:
  forall f1 f2, cmp Cle f1 f2 = cmp Clt f1 f2 || cmp Ceq f1 f2.
Proof.
  intros f1 f2; apply cmp_of_comparison_le_lt_eq.
Qed.

Theorem cmp_gt_eq_false:
  forall x y, cmp Cgt x y = true -> cmp Ceq x y = true -> False.
Proof.
  intros f1 f2; apply cmp_of_comparison_gt_eq_false.
Qed.

Theorem cmp_ge_gt_eq:
  forall f1 f2, cmp Cge f1 f2 = cmp Cgt f1 f2 || cmp Ceq f1 f2.
Proof.
  intros f1 f2; apply cmp_of_comparison_ge_gt_eq.
Qed.

Theorem cmp_lt_gt_false:
  forall f1 f2, cmp Clt f1 f2 = true -> cmp Cgt f1 f2 = true -> False.
Proof.
  intros f1 f2; apply cmp_of_comparison_lt_gt_false.
Qed.

Theorem cmp_double:
  forall f1 f2 c, cmp c f1 f2 = Float.cmp c (to_double f1) (to_double f2).
Proof.
  unfold cmp, Float.cmp; intros. f_equal. symmetry. apply Bcompare_Bconv_widen.
  red; lia. lia. lia.
Qed.

(** Properties of conversions to/from in-memory representation.
  The conversions are bijective (one-to-one). *)

Theorem of_to_bits:
  forall f, of_bits (to_bits f) = f.
Proof.
  intros; unfold of_bits, to_bits, bits_of_b32, b32_of_bits.
  rewrite Int.unsigned_repr, binary_float_of_bits_of_binary_float; [reflexivity|].
  generalize (bits_of_binary_float_range 23 8 __ __ f).
  change (2^(23+8+1)) with (Int.max_unsigned + 1). lia.
Qed.

Theorem to_of_bits:
  forall b, to_bits (of_bits b) = b.
Proof.
  intros; unfold of_bits, to_bits, bits_of_b32, b32_of_bits.
  rewrite bits_of_binary_float_of_bits. apply Int.repr_unsigned.
  apply Int.unsigned_range.
Qed.

(** Conversions from 32-bit integers to single-precision floats can
  be decomposed into a conversion to a double-precision float,
  followed by a [Float32.of_double] conversion.  No double rounding occurs. *)

Theorem of_int_double:
  forall n, of_int n = of_double (Float.of_int n).
Proof.
  intros. symmetry. apply Bconv_BofZ.
  apply integer_representable_n; auto. generalize (Int.signed_range n); Float.smart_lia.
Qed.

Theorem of_intu_double:
  forall n, of_intu n = of_double (Float.of_intu n).
Proof.
  intros. symmetry. apply Bconv_BofZ.
  apply integer_representable_n; auto. generalize (Int.unsigned_range n); Float.smart_lia.
Qed.

(** Conversion of single-precision floats to integers can be decomposed
  into a [Float32.to_double] extension, followed by a double-precision-to-int
  conversion. *)

Theorem to_int_double:
  forall f n, to_int f = Some n -> Float.to_int (to_double f) = Some n.
Proof.
  intros.
  unfold to_int in H.
  destruct (ZofB_range _ _ f Int.min_signed Int.max_signed) as [n'|] eqn:E; inv H.
  unfold Float.to_int, to_double, Float.of_single.
  erewrite ZofB_range_Bconv; eauto. auto. lia. lia. lia. lia.
Qed.

Theorem to_intu_double:
  forall f n, to_intu f = Some n -> Float.to_intu (to_double f) = Some n.
Proof.
  intros.
  unfold to_intu in H.
  destruct (ZofB_range _ _ f 0 Int.max_unsigned) as [n'|] eqn:E; inv H.
  unfold Float.to_intu, to_double, Float.of_single.
  erewrite ZofB_range_Bconv; eauto. auto. lia. lia. lia. lia.
Qed.

Theorem to_long_double:
  forall f n, to_long f = Some n -> Float.to_long (to_double f) = Some n.
Proof.
  intros.
  unfold to_long in H.
  destruct (ZofB_range _ _ f Int64.min_signed Int64.max_signed) as [n'|] eqn:E; inv H.
  unfold Float.to_long, to_double, Float.of_single.
  erewrite ZofB_range_Bconv; eauto. auto. lia. lia. lia. lia.
Qed.

Theorem to_longu_double:
  forall f n, to_longu f = Some n -> Float.to_longu (to_double f) = Some n.
Proof.
  intros.
  unfold to_longu in H.
  destruct (ZofB_range _ _ f 0 Int64.max_unsigned) as [n'|] eqn:E; inv H.
  unfold Float.to_longu, to_double, Float.of_single.
  erewrite ZofB_range_Bconv; eauto. auto. lia. lia. lia. lia.
Qed.

(** Conversions from 64-bit integers to single-precision floats can be expressed
  as conversion to a double-precision float followed by a [Float32.of_double] conversion.
  To avoid double rounding when the integer is large (above [2^53]), a round
  to odd must be performed on the integer before conversion to double-precision float. *)

Lemma int_round_odd_plus:
  forall p n, 0 <= p ->
  int_round_odd n p = Z.land (Z.lor n (Z.land n (2^p-1) + (2^p-1))) (-(2^p)).
Proof.
  intros.
  assert (POS: 0 < 2^p) by (apply (Zpower_gt_0 radix2); auto).
  assert (A: Z.land n (2^p-1) = n mod 2^p).
  { rewrite <- Z.land_ones by auto. f_equal. rewrite Z.ones_equiv. lia. }
  rewrite A.
  assert (B: 0 <= n mod 2^p < 2^p).
  { apply Z_mod_lt. lia. }
  set (m := n mod 2^p + (2^p-1)) in *.
  assert (C: m / 2^p = if zeq (n mod 2^p) 0 then 0 else 1).
  { unfold m. destruct (zeq (n mod 2^p) 0).
    rewrite e. apply Z.div_small. lia.
    eapply Coqlib.Zdiv_unique with (n mod 2^p - 1). ring. lia. }
  assert (D: Z.testbit m p = if zeq (n mod 2^p) 0 then false else true).
  { destruct (zeq (n mod 2^p) 0).
    apply Z.testbit_false; auto. rewrite C; auto.
    apply Z.testbit_true; auto. rewrite C; auto. }
  assert (E: forall i, p < i -> Z.testbit m i = false).
  { intros. apply Z.testbit_false. lia.
    replace (m / 2^i) with 0. auto. symmetry. apply Z.div_small.
    unfold m. split. lia. apply Z.lt_le_trans with (2 * 2^p). lia.
    change 2 with (2^1) at 1. rewrite <- (Zpower_plus radix2) by lia.
    apply Zpower_le. lia. }
  assert (F: forall i, 0 <= i -> Z.testbit (-2^p) i = if zlt i p then false else true).
  { intros. rewrite Z.bits_opp by auto. rewrite <- Z.ones_equiv.
    destruct (zlt i p).
    rewrite Z.ones_spec_low by lia. auto.
    rewrite Z.ones_spec_high by lia. auto. }
  apply int_round_odd_bits; auto.
  - intros. rewrite Z.land_spec, F, zlt_true by lia. apply andb_false_r.
  - rewrite Z.land_spec, Z.lor_spec, D, F, zlt_false, andb_true_r by lia.
    destruct (Z.eqb (n mod 2^p) 0) eqn:Z.
    rewrite Z.eqb_eq in Z. rewrite Z, zeq_true. apply orb_false_r.
    rewrite Z.eqb_neq in Z. rewrite zeq_false by auto. apply orb_true_r.
  - intros. rewrite Z.land_spec, Z.lor_spec, E, F, zlt_false, andb_true_r by lia.
    apply orb_false_r.
Qed.

Lemma of_long_round_odd:
  forall n conv_nan,
  2^36 <= Z.abs n < 2^64 ->
  BofZ 24 128 __ __ n = Bconv _ _ 24 128 __ __ conv_nan mode_NE (BofZ 53 1024 __ __ (Z.land (Z.lor n ((Z.land n 2047) + 2047)) (-2048))).
Proof.
  intros. rewrite <- (int_round_odd_plus 11) by lia.
  assert (-2^64 <= int_round_odd n 11).
  { change (-2^64) with (int_round_odd (-2^64) 11). apply (int_round_odd_le 0 0); lia. }
  assert (int_round_odd n 11 <= 2^64).
  { change (2^64) with (int_round_odd (2^64) 11). apply (int_round_odd_le 0 0); lia. }
  rewrite Bconv_BofZ.
  apply BofZ_round_odd with (p := 11).
  lia.
  apply Z.le_trans with (2^64). lia. compute; intuition congruence.
  lia.
  exact (proj1 H).
  unfold int_round_odd. apply integer_representable_n2p_wide. auto. lia.
  unfold int_round_odd in H0, H1.
  split; (apply Zmult_le_reg_r with (2^11); [compute; auto | assumption]).
  lia.
  lia.
Qed.

Theorem of_longu_double_1:
  forall n,
  Int64.unsigned n <= 2^53 ->
  of_longu n = of_double (Float.of_longu n).
Proof.
  intros. symmetry; apply Bconv_BofZ. apply integer_representable_n; auto.
  pose proof (Int64.unsigned_range n); lia.
Qed.

Theorem of_longu_double_2:
  forall n,
  2^36 <= Int64.unsigned n ->
  of_longu n = of_double (Float.of_longu
                           (Int64.and (Int64.or n
                                                (Int64.add (Int64.and n (Int64.repr 2047))
                                                           (Int64.repr 2047)))
                                      (Int64.repr (-2048)))).
Proof.
  intros.
  pose proof (Int64.unsigned_range n).
  unfold of_longu. erewrite of_long_round_odd.
  unfold of_double, Float.to_single. instantiate (1 := Float.to_single_nan).
  f_equal. unfold Float.of_longu. f_equal.
  set (n' := Z.land (Z.lor (Int64.unsigned n) (Z.land (Int64.unsigned n) 2047 + 2047)) (-2048)).
  assert (int_round_odd (Int64.unsigned n) 11 = n') by (apply int_round_odd_plus; lia).
  assert (0 <= n').
  { rewrite <- H1. change 0 with (int_round_odd 0 11). apply (int_round_odd_le 0 0); lia. }
  assert (n' < Int64.modulus).
  { apply Z.le_lt_trans with (int_round_odd (Int64.modulus - 1) 11).
    rewrite <- H1. apply (int_round_odd_le 0 0); lia.
    compute; auto. }
  rewrite <- (Int64.unsigned_repr n') by (unfold Int64.max_unsigned; lia).
  f_equal. Int64.bit_solve. rewrite Int64.testbit_repr by auto. unfold n'.
  rewrite Z.land_spec, Z.lor_spec. f_equal. f_equal.
  unfold Int64.testbit. rewrite Int64.add_unsigned.
  fold (Int64.testbit (Int64.repr
        (Int64.unsigned (Int64.and n (Int64.repr 2047)) +
         Int64.unsigned (Int64.repr 2047))) i).
  rewrite Int64.testbit_repr by auto. f_equal. f_equal. unfold Int64.and.
  symmetry. apply Int64.unsigned_repr. change 2047 with (Z.ones 11).
  rewrite Z.land_ones by lia.
  exploit (Z_mod_lt (Int64.unsigned n) (2^11)). compute; auto.
  assert (2^11 < Int64.max_unsigned) by (compute; auto). lia.
  apply Int64.same_bits_eqm; auto. exists (-1); auto.
  split. lia. change (2^64) with Int64.modulus. lia.
Qed.

Theorem of_long_double_1:
  forall n,
  Z.abs (Int64.signed n) <= 2^53 ->
  of_long n = of_double (Float.of_long n).
Proof.
  intros. symmetry; apply Bconv_BofZ. apply integer_representable_n; auto. lia.
Qed.

Theorem of_long_double_2:
  forall n,
  2^36 <= Z.abs (Int64.signed n) ->
  of_long n = of_double (Float.of_long
                           (Int64.and (Int64.or n
                                                (Int64.add (Int64.and n (Int64.repr 2047))
                                                           (Int64.repr 2047)))
                                      (Int64.repr (-2048)))).
Proof.
  intros.
  pose proof (Int64.signed_range n).
  unfold of_long. erewrite of_long_round_odd.
  unfold of_double, Float.to_single. instantiate (1 := Float.to_single_nan).
  f_equal. unfold Float.of_long. f_equal.
  set (n' := Z.land (Z.lor (Int64.signed n) (Z.land (Int64.signed n) 2047 + 2047)) (-2048)).
  assert (int_round_odd (Int64.signed n) 11 = n') by (apply int_round_odd_plus; lia).
  assert (Int64.min_signed <= n').
  { rewrite <- H1. change Int64.min_signed with (int_round_odd Int64.min_signed 11). apply (int_round_odd_le 0 0); lia. }
  assert (n' <= Int64.max_signed).
  { apply Z.le_trans with (int_round_odd Int64.max_signed 11).
    rewrite <- H1. apply (int_round_odd_le 0 0); lia.
    compute; intuition congruence. }
  rewrite <- (Int64.signed_repr n') by lia.
  f_equal. Int64.bit_solve. rewrite Int64.testbit_repr by auto. unfold n'.
  rewrite Z.land_spec, Z.lor_spec. f_equal. f_equal.
  rewrite Int64.bits_signed by lia. rewrite zlt_true by lia. auto.
  unfold Int64.testbit. rewrite Int64.add_unsigned.
  fold (Int64.testbit (Int64.repr
        (Int64.unsigned (Int64.and n (Int64.repr 2047)) +
         Int64.unsigned (Int64.repr 2047))) i).
  rewrite Int64.testbit_repr by auto. f_equal. f_equal. unfold Int64.and.
  change (Int64.unsigned (Int64.repr 2047)) with 2047.
  change 2047 with (Z.ones 11). rewrite ! Z.land_ones by lia.
  rewrite Int64.unsigned_repr. apply eqmod_mod_eq.
  apply Z.lt_gt. apply (Zpower_gt_0 radix2); lia.
  apply eqmod_divides with (2^64). apply Int64.eqm_signed_unsigned.
  exists (2^(64-11)); auto.
  exploit (Z_mod_lt (Int64.unsigned n) (2^11)). compute; auto.
  assert (2^11 < Int64.max_unsigned) by (compute; auto). lia.
  apply Int64.same_bits_eqm; auto. exists (-1); auto.
  split. auto. assert (-2^64 < Int64.min_signed) by (compute; auto).
  assert (Int64.max_signed < 2^64) by (compute; auto).
  lia.
Qed.

End Float32.

Global Opaque
  Float.zero Float.eq_dec Float.neg Float.abs Float.of_single Float.to_single
  Float.of_int Float.of_intu Float.of_long Float.of_longu
  Float.to_int Float.to_intu Float.to_long Float.to_longu
  Float.add Float.sub Float.mul Float.div Float.cmp Float.ordered
  Float.to_bits Float.of_bits Float.from_words.

Global Opaque
  Float32.zero Float32.eq_dec Float32.neg Float32.abs
  Float32.of_int Float32.of_intu Float32.of_long Float32.of_longu
  Float32.to_int Float32.to_intu Float32.to_long Float32.to_longu
  Float32.add Float32.sub Float32.mul Float32.div Float32.cmp Float32.ordered
  Float32.to_bits Float32.of_bits.


(* This program 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 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V5.10.14                              *)
(*                                 April 1995                               *)
(*                                                                          *)
(****************************************************************************)
(*                                Streams.v                                 *)
(****************************************************************************)
(*       An example of the new implementation of co-inductive types         *)
(*                       by Eduardo Gimenez                                 *)
(****************************************************************************)

Set Asymmetric Patterns.

Require Import Plus.
Require Import Streams.

Section Examples. (* Introducing some streams *)

Section Map.

Variable A B : Set.
Variable f : A -> B.

CoFixpoint map  : Stream A -> Stream B :=
  fun s : Stream A => match s with
                      | Cons a s => Cons (f a) (map s)
                      end.

End Map.

CoFixpoint zeros  : Stream nat := Cons 0 zeros.

CoFixpoint alter  : Stream nat := Cons 0 (Cons 1 alter).

CoFixpoint alter1  : Stream nat := Cons 0 alter2
 with alter2  : Stream nat := Cons 1 alter1.

CoFixpoint from  : nat -> Stream nat := fun n : nat => Cons n (from (S n)).
Definition allnats : Stream nat := from 0.

Lemma all_greater_than_m__are_here :
 forall n m : nat, Str_nth n (from m) = n + m.
simple induction n.
trivial.
intros.
rewrite plus_Snm_nSm.
unfold Str_nth in |- *.
unfold Str_nth in H.
simpl in |- *.
apply H.
Qed.

(*
CoFixpoint mapS : (Stream nat)->(Stream nat) :=
  [s:(Stream nat)]
    <(Stream nat)>Case s of
	            [n:nat][s1:(Stream nat)](Cons (S n) (mapS s1))
  	          end.
*)

CoFixpoint mapS  : Stream nat -> Stream nat :=
  fun s : Stream nat => match s with
                        | Cons n s1 => Cons (S n) (mapS s1)
                        end.

(* A different way of defining the set of streams *)

Inductive Times (A B : Set) : Set :=
    times : A -> B -> Times A B.

CoInductive St2 : Set :=
    Cons2 : Times nat St2 -> St2.

CoFixpoint mapS2  : St2 -> St2 :=
  fun x : St2 =>
  match x return St2 with
  | Cons2 (times x1 x2) => Cons2 (times nat St2 (S x1) (mapS2 x2))
  end.

(* Some examples of  wrong definitions *)
(*
(* 1: Un unguarded recursive call *)

CoFixpoint filter : (nat->bool)->(Stream nat)->(Stream nat) :=
  [p:nat->bool]
     [x:(Stream nat)] Cases x of
	              (Cons n s) =>
                          <(Stream nat)>if  (p n) then (Cons n (filter p s))
				       	          else (filter p s)
	               end.

(* 2: A recursive call in the argument of a Case *)

CoFixpoint wrong : (Stream nat) := (Cons O (tl nat wrong)).

(* 3: Nested recursive calls *)

CoFixpoint nested : (Stream nat)->(Stream nat) := [s:(Stream nat)](Cons O (nested (nested s))).

(* An inductive definition on a coinductive set *)

Fixpoint wrong_mapS [s:(Stream nat)] : (Stream nat) :=
     Cases s of
	 (Cons n s1) => (Cons (S n) (wrong_mapS s1))
      end.

(* A Cofixpoint definition defining an infinite element of an inductive set *)

CoFixpoint u:nat := (S u).

(* A recursive call in a non-recursive argument of a constructor *)

Mutual CoInductive V : Prop := Consv : (A:Prop)A->(not A)->V.
(*
Definition V_is_false :=
    [x:V]<False>Case x of
	            [A:Prop][a:A][h:(not A)](h a)
	        end.
*)
Definition V_is_false :=
    [x:V]<False>Cases x of
	        (Consv _ a h) => (h a)
	        end.

CoFixpoint V_is_true : V := (Consv V  V_is_true V_is_false).

(* A sound definition which does not verfy the guarded condition *)

CoFixpoint good_from : (Stream nat) := (Cons O (mapS good_from)).

*)

(* Unfolding the definition of a stream *)

Theorem zeros_unfold : zeros = Cons 0 zeros.
apply (unfold_Stream zeros).
Qed.

End Examples.

Section Stream_Equalities.

Variable A : Set.

(* The definition given in theories/Streams.v
   is equivalent to require the elements at each position to be equal *)

Theorem Equiv1 :
 forall s1 s2 : Stream A,
 EqSt s1 s2 -> forall n : nat, Str_nth n s1 = Str_nth n s2.
unfold Str_nth in |- *.
fix u 4.
intros s1 s2 H n.
case H.
intros.
case n.
assumption.
intros.
simpl in |- *.
apply u.
assumption.
Qed.

Theorem Equiv2 :
 forall s1 s2 : Stream A,
 (forall n : nat, Str_nth n s1 = Str_nth n s2) -> EqSt s1 s2.
unfold Str_nth in |- *.
cofix u.
intros.
apply eqst.
apply (H 0).
apply u.
intros n.
apply (H (S n)).
Qed.

Section Example.

Variable f : A -> A.

CoFixpoint iter  : A -> Stream A := fun x : A => Cons (f x) (iter (f x)).

Lemma map_iter_eq : forall x : A, EqSt (iter (f x)) (map A A f (iter x)).
cofix u.
intros.
apply eqst.
trivial.
simpl in |- *.
apply u.
Qed.

End Example.

(* Extensional Equality between two streams (opus II) *)

CoInductive EqSt2 (A : Set) : Stream A -> Stream A -> Prop :=
    eqst2 :
      forall (s1 s2 : Stream A) (a : A),
      EqSt2 A s1 s2 -> EqSt2 A (Cons a s1) (Cons a s2).

(* The proof that this description  is equivalent to the one in the
   directory theories *)

(* The proof that EqSt2 is an equivalence relation *)

Theorem EqSt2_reflex : forall s : Stream A, EqSt2 A s s.
cofix u.
intros.
case s.
intros.
apply eqst2.
apply u.
Qed.

Theorem EqSt2_sym : forall s1 s2 : Stream A, EqSt2 A s1 s2 -> EqSt2 A s2 s1.
cofix u.
intros.
case H.
intros.
apply eqst2.
apply u.
assumption.
Qed.

Theorem EqSt2_trans :
 forall s1 s2 s3 : Stream A, EqSt2 A s1 s2 -> EqSt2 A s2 s3 -> EqSt2 A s1 s3.
cofix u.
intros s1 s2 s3.
intro.
inversion_clear H.
intro.
inversion_clear H.
apply eqst2.
apply (u s0 s4 s6).
assumption.
assumption.
Qed.

Definition derived_eqst (s1 s2 : Stream A) (a : A)
  (H : EqSt s1 s2) : EqSt (Cons a s1) (Cons a s2) :=
  eqst (Cons a s1) (Cons a s2) (refl_equal (hd (Cons a s2))) H.

Definition derived_eqst2 (s1 s2 : Stream A) :
  hd s1 = hd s2 -> EqSt2 A (tl s1) (tl s2) -> EqSt2 A s1 s2 :=
  let (x, x0) as s
      return (hd s = hd s2 -> EqSt2 A (tl s) (tl s2) -> EqSt2 A s s2) :=
      s1 in
  (let (a, s) as s
       return
         (forall (a : A) (s0 : Stream A),
          hd (Cons a s0) = hd s ->
          EqSt2 A (tl (Cons a s0)) (tl s) -> EqSt2 A (Cons a s0) s) := s2 in
   fun (a0 : A) (s0 : Stream A) (H : hd (Cons a0 s0) = hd (Cons a s))
     (H0 : EqSt2 A (tl (Cons a0 s0)) (tl (Cons a s))) =>
   match H in (_ = a1) return (EqSt2 A (Cons a0 s0) (Cons a1 s)) with
   | refl_equal => eqst2 A s0 s a0 H0
   end) x x0.

End Stream_Equalities.

(* $Id$ *)


Require Import List.
Import ListNotations.

From RelationAlgebra Require Import kat regex kat_tac.

Lemma test : forall (r1 r2 : regex'), r1 + r2 == r2 + r1.
Proof.
  intros.
  ka.
Qed.


Unset Strict Universe Declaration.
Set Universe Polymorphism.
Set Printing Universes.
Record Cat := { Obj :> Type }.
Definition set_cat := {| Obj := Type |}.
Goal Type@{i} = Type@{j}.
Proof.
  (* 1 subgoals
, subgoal 1 (ID 3)

  ============================
   Type@{Top.368} = Type@{Top.370}
(dependent evars:) *)
  let x := constr:(Type) in
  let y := constr:(Obj set_cat) in
  unify x y. (* success *)
  let x := constr:(Type) in
  let y := constr:(Obj set_cat) in
  first [ unify x y | fail 2 "no unify" ];
    change x with y at -1. (* Error: Not convertible. *)
  reflexivity.
Defined.


Require Import VST.floyd.proofauto.

Definition def_float (x: val) : Prop :=
 match x with
 | Vfloat x' => Binary.is_finite 53 1024 x' = true
 | _ => False
 end.

Definition f_cmp op x y :=
 match x, y with
 | Vfloat x', Vfloat y' => Float.cmp op x' y' = true
 | _, _ => False
 end.

Lemma float_cmp_eq_refl:
  forall x, def_float x -> f_cmp Ceq x x.
Proof.
intros.
destruct x; try contradiction.
simpl in *.
pose proof (Binary.Bcompare_correct _ _ _ _ H H).
change (cmp_of_comparison Ceq (Float.compare f f) = true).
simpl.
unfold Float.compare.
rewrite H0.
rewrite Raux.Rcompare_Eq; auto.
Qed.

Lemma f_le_refl: forall x, def_float x -> f_cmp Cle x x.
intros.
destruct x; try contradiction; simpl in *.
rewrite Float.cmp_le_lt_eq.
rewrite orb_true_iff; right.
pose proof (Binary.Bcompare_correct _ _ _ _ H H).
change (cmp_of_comparison Ceq (Float.compare f f) = true).
simpl.
unfold Float.compare.
rewrite H0.
rewrite Raux.Rcompare_Eq; auto.
Qed.

Lemma f_cmp_false:
  forall op a b, def_float (Vfloat a) -> def_float (Vfloat b) ->
     Float.cmp op a b = false ->
     f_cmp (negate_comparison op) (Vfloat a) (Vfloat b).
Proof.
intros.
simpl in *.
Transparent Float.cmp.
unfold Float.cmp in *.
Opaque Float.cmp.
unfold cmp_of_comparison in *.
pose proof (Binary.Bcompare_correct _ _ _ _ H H0).
set (c := Raux.Rcompare (Binary.B2R 53 1024 a) (Binary.B2R 53 1024 b)) in *.
change (Binary.Bcompare 53 1024 a b) with (Float.compare a b) in H2.
rewrite H2 in *.
destruct op; inv H1; simpl; auto;
destruct c; inv H4; auto.
Qed.

Lemma f_lt_irrefl:
   forall a, f_cmp Clt a a -> False.
Proof.
intros.
destruct a; simpl in H; auto.
Transparent Float.cmp.
unfold Float.cmp in *.
Opaque Float.cmp.
simpl in H.
unfold Float.compare in *.
destruct (Binary.Bcompare 53 1024 f f) eqn:?; inv H.
destruct c; inv H1.
pose proof (Binary.Bcompare_swap 53 1024 f f).
rewrite Heqo in H. inv H.
Qed.

Lemma is_float_middle:
  forall (before: list val) (bl: list val) (after: list val) i,
       Forall def_float bl ->
       Zlength before <= i < Zlength before + Zlength bl ->
       val_lemmas.is_float (Znth i (before ++ bl ++ after)).
Proof.
intros.
rewrite app_Znth2 by rep_lia.
rewrite app_Znth1 by (autorewrite with sublist; rep_lia).
eapply Forall_Znth; eauto; try lia.
eapply Forall_impl; try eassumption.
intros. destruct a; try contradiction; simpl; auto.
Qed.

Lemma f_cmp_lt_ge_false:
  forall a b, f_cmp Clt a b -> f_cmp Cge a b -> False.
Proof.
intros.
hnf in *.
destruct a; try contradiction.
destruct b; try contradiction.
rewrite Float.cmp_ge_gt_eq in H0.
rewrite orb_true_iff in H0; destruct H0.
eapply Float.cmp_lt_gt_false; eauto.
eapply Float.cmp_lt_eq_false; eauto.
Qed.

Lemma float_cmp_gt_le_false:
  forall a b, f_cmp Cgt a b -> f_cmp Cle a b -> False.
Proof.
intros.
hnf in *.
destruct a; try contradiction.
destruct b; try contradiction.
rewrite Float.cmp_le_lt_eq in H0.
rewrite orb_true_iff in H0; destruct H0.
eapply Float.cmp_lt_gt_false; eauto.
eapply Float.cmp_gt_eq_false; eauto.
Qed.

Lemma both_float_cmp_true:
  forall op a b,
    def_float a -> def_float b ->
   typed_true tint (force_val
     (both_float (fun n1 n2 : float => Some (Val.of_bool (Float.cmp op n1 n2)))
        sem_cast_f2f sem_cast_f2f a b)) ->
   f_cmp op a b.
Proof.
intros.
destruct a; try contradiction.
destruct b; try contradiction.
apply typed_true_of_bool in H1.
apply H1.
Qed.

Lemma both_float_cmp_false:
  forall op a b,
    def_float a -> def_float b ->
   typed_false tint (force_val
     (both_float (fun n1 n2 : float => Some (Val.of_bool (Float.cmp op n1 n2)))
        sem_cast_f2f sem_cast_f2f a b)) ->
   f_cmp (negate_comparison op) a b.
Proof.
intros.
destruct a; try contradiction.
destruct b; try contradiction.
apply typed_false_of_bool in H1.
apply f_cmp_false; auto.
Qed.

Lemma f_cmp_swap:
  forall op a b, f_cmp op a b -> f_cmp (swap_comparison op) b a.
Proof.
intros.
destruct a,b; try contradiction; simpl in *.
rewrite Float.cmp_swap; auto.
Qed.

Lemma f_cmp_ge_gt_eq:
  forall a b, f_cmp Cge a b <-> (f_cmp Cgt a b \/ f_cmp Ceq a b).
Proof.
intros.
unfold f_cmp.
destruct a,b; simpl; try solve [split; [intro; contradiction | intros [?|?]; auto]].
rewrite Float.cmp_ge_gt_eq.
rewrite orb_true_iff. split; auto.
Qed.

Lemma f_cmp_le_lt_eq:
  forall a b, f_cmp Cle a b <-> (f_cmp Clt a b \/ f_cmp Ceq a b).
Proof.
intros.
unfold f_cmp.
destruct a,b; simpl; try solve [split; [intro; contradiction | intros [?|?]; auto]].
rewrite Float.cmp_le_lt_eq.
rewrite orb_true_iff. split; auto.
Qed.

Lemma def_float_f2f:
 forall a, def_float a -> force_val (sem_cast_f2f a) = a.
Proof.
intros. destruct a; simpl in *; try contradiction; reflexivity.
Qed.

Lemma f_cmp_le_ge:
  forall a b, f_cmp Cle a b -> f_cmp Cge a b -> f_cmp Ceq a b.
Proof.
intros.
rewrite f_cmp_le_lt_eq in H.
destruct H; auto.
contradiction (f_cmp_lt_ge_false _ _ H H0).
Qed.

Lemma f_cmp_le_trans:
   transitive val (f_cmp Cle).
Proof.
intros.
intros a b c ? ?.
destruct a,b; try contradiction.
destruct c; try contradiction.
simpl in *.
Transparent Float.cmp.
unfold Float.cmp in *.
Opaque Float.cmp.
simpl in *.
unfold Float.compare in *.
unfold Binary.Bcompare in *.
destruct f,f0,f1; simpl in *; auto; try discriminate;
destruct s,s0,s1; simpl in *; auto; try discriminate;
destruct (e ?= e1) eqn:?H;
destruct (e1 ?= e3) eqn:?H;
auto; try discriminate.
-
apply Z.compare_eq_iff in H1. apply Z.compare_eq_iff in H2.
subst.
rewrite Z.compare_refl.
destruct (Pos.compare_cont Eq m m0) eqn:?H; simpl in H; try discriminate.
apply Pcompare_Eq_eq in H1. subst m0. auto.
destruct (Pos.compare_cont Eq m0 m1) eqn:?H; simpl in H; try discriminate.
apply Pcompare_Eq_eq in H2. subst m0. rewrite H1. auto.
apply nat_of_P_gt_Gt_compare_morphism in H1.
apply nat_of_P_gt_Gt_compare_morphism in H2.
rewrite nat_of_P_gt_Gt_compare_complement_morphism.
auto.
lia.
-
apply Z.compare_eq_iff in H1.
subst e1.
rewrite H2.
auto.
-
apply Z.compare_eq_iff in H2.
subst e1.
rewrite H1.
auto.
-
rewrite (Zcompare_Gt_trans _ _ _ H1 H2).
auto.
-
apply Z.compare_eq_iff in H1. apply Z.compare_eq_iff in H2.
subst.
rewrite Z.compare_refl.
destruct (Pos.compare_cont Eq m m0) eqn:?H; simpl in H; try discriminate.
apply Pcompare_Eq_eq in H1. subst m0. auto.
destruct (Pos.compare_cont Eq m0 m1) eqn:?H; simpl in H; try discriminate.
apply Pcompare_Eq_eq in H2. subst m0. rewrite H1. auto.
apply nat_of_P_lt_Lt_compare_morphism in H1.
apply nat_of_P_lt_Lt_compare_morphism in H2.
rewrite nat_of_P_lt_Lt_compare_complement_morphism.
auto.
lia.
-
apply Z.compare_eq_iff in H1.
subst e1.
rewrite H2.
auto.
-
apply Z.compare_eq_iff in H2.
subst e1.
rewrite H1.
auto.
-
rewrite (Zcompare_Lt_trans _ _ _ H1 H2).
auto.
Qed.

Theorem Forall_perm: forall {A} (f: A -> Prop) al bl,
  Permutation al bl ->
  Forall f al -> Forall f bl.
Proof.
  induction 1; simpl; intros; auto.
  inv H0; constructor; auto.
  inv H. inv H3. constructor; auto.
Qed.

Lemma Exists_app:
  forall {A} (P: A->Prop) (l1 l2: list A),
     Exists P (l1++l2) <-> Exists P l1 \/ Exists P l2.
Proof.
intros.
induction l1; simpl; auto.
split; intros. right; auto. destruct H; auto. inv H.
split; intro.
inv H. left. left. auto.
rewrite IHl1 in H1.
destruct H1; auto.
destruct H.
inv H. left; auto.
right. rewrite IHl1; auto.
right. rewrite IHl1; auto.
Qed.

Inductive sorted {A} (le: A -> A -> Prop): list A -> Prop :=
| sorted_nil:
    sorted le nil
| sorted_1: forall x,
    sorted le (x::nil)
| sorted_cons: forall x y l,
     le x y -> sorted le (y::l) -> sorted le (x::y::l).

Lemma sorted_app:
  forall {A} {le: A->A->Prop} (TRANS: transitive A le)
    pivot al bl,
    sorted le al -> sorted le bl ->
    Forall (fun x => le x pivot) al ->
    Forall (le pivot) bl ->
    sorted le (al++bl).
Proof.
intros.
induction H.
simpl; auto.
simpl.
inv H1. inv H5.
inv H0.
constructor.
inv H2.
constructor.
apply TRANS with pivot; auto.
constructor.
inv H2.
constructor.
apply TRANS with pivot; auto.
constructor; auto.
simpl.
constructor; auto.
apply IHsorted.
inv H1; auto.
Qed.

Lemma sorted_app_e3:
  forall {A} {le: A->A->Prop} (TRANS: transitive A le)
    pivot al bl,
    sorted le (al++[pivot]++bl) ->
    sorted le al /\ sorted le bl /\
    Forall (fun x => le x pivot) al /\
    Forall (le pivot) bl.
Proof.
 intros.
 induction al.
 simpl in *.
 split. constructor.
 induction bl; inv  H. repeat constructor.
 spec IHbl. destruct bl; inv H4; constructor; auto.
 eapply TRANS; eassumption.
 split3; auto. destruct IHbl as [? [? ?]]; constructor; auto.
 inv H. destruct al; inv H2. destruct al; inv H1.
 simpl in IHal. spec IHal; auto.
 destruct IHal as [_ [? [_ ?]]].
 split3. constructor. auto. split; auto.
 spec IHal; auto.
 destruct IHal as [? [? [? ?]]].
 split3; auto. constructor; auto.
 split; auto.
 constructor; auto.
 apply TRANS with a0; auto.
 inv H1; auto.
Qed.

Lemma Permutation_Zlength:
  forall {A} {al bl: list A}, Permutation al bl -> Zlength al = Zlength bl.
Proof.
intros. rewrite !Zlength_correct. f_equal. apply Permutation_length; auto.
Qed.