Require Export ProjectiveGeometry.Dev.basic_plane_facts.
Require Export ProjectiveGeometry.Dev.pp_equiv_rk_lemmas.

(*****************************************************************************)
(** Proof of projective plane rank axioms **)

Section s_ppEquivToRk.

Context `{PPR : ProjectivePlaneRank}.
Context `{EP : EqDecidability Point}.
Context `{OP : OrderedType Point}.

Lemma matroid1a : forall e, rkl e >= 0.
Proof.
my_rank.
Qed.

Lemma matroid1b : forall e, rkl e <= cardinal e.
Proof.
intros.
induction e.
simpl.
intuition.
unfold rkl.
case_eq e.
intros.
simpl.
intuition.
intros.
case_eq (contains_three_non_collinear_points (a :: p :: l)).
intros.
assert( HH0 := matroid3_aux9 (a :: p :: l) H0).
assert( HH1 := list_cardinal_aux3 (a :: p :: l) HH0).
intuition.
intros.
case_eq (contains_two_distinct_points (a :: p :: l)).
intros.
assert( HH0 := matroid3_aux2 (a :: p :: l) H1 H0).
assert( HH1 := list_cardinal_aux2 (a :: p :: l) HH0).
intuition.
intros.
assert( HH0 := matroid3_aux3 (a :: p :: l) H1).
destruct HH0.
rewrite <-H in H2.
assert( HH1 : (a :: e) <> nil).
intro.
inversion H3.
assert( HH2 := matroid3_aux3_bis (a :: e) HH1).
destruct HH2.
rewrite H3 in H2.
inversion H2.
destruct H3.
rewrite H3 in H2.
inversion H2.
rewrite H3 in H2.
inversion H2.
assert( HH1 := list_cardinal_aux1 (a :: p :: l) H2).
intuition.
Qed.

Lemma matroid2 : forall e e',  inclA eq e e' -> rkl(e)<=rkl(e').
Proof.
my_rank;unfold rkl;case_eq e;case_eq e';my_rank.
rewrite H1 in H;rewrite H0 in H;my_inA;assert( HH := H p);my_inA.
my_inA;assert( HH := H p);my_inA.
my_inA;assert( HH := H p);my_inA.
my_inA;assert( HH := H p);my_inA.
subst;assert( HH := contains_three_non_collinear_points_sublist (p0 :: p1 :: l1) (p :: nil) H H3);simpl in HH;my_rank.
subst;assert( HH := contains_three_non_collinear_points_sublist (p0 :: p1 :: l1) (p :: p2 :: l2) H H3);rewrite HH in H5;my_rank.
subst;assert( HH := contains_three_non_collinear_points_sublist (p0 :: p1 :: l1) (p :: p2 :: l2) H H3);rewrite HH in H5;my_rank.
subst;assert( HH := contains_two_distinct_points_sublist (p0 :: p1 :: l1) (p :: nil) H H4);simpl in HH;my_rank.
subst;assert( HH := contains_two_distinct_points_sublist (p0 :: p1 :: l1) (p :: p2 :: l2) H H4);rewrite H7 in HH;my_rank.
Qed.

Lemma matroid3:
forall e e',
 rkl(e ++ e') + rkl(list_inter e e') <= rkl(e) + rkl(e').
Proof.
my_rank.
assert(HH0 := all_rank e).
assert(HH1 := all_rank e').
progress intuition.
- assert(HH0 := rk_nil e H);assert(HH1 := rk_nil e' H0);
subst;my_rank.
- assert(HH0 := rk_nil e H);subst;simpl;my_rank.
- assert(HH0 := rk_nil e H);subst;simpl;my_rank.
- assert(HH0 := rk_nil e H);subst;simpl;my_rank.
- assert(HH0 := rk_nil e' H0);
  assert(HH1 := list_inter_reverse e nil);
  assert(HH2 := list_concat_reverse e nil);
  subst;rewrite HH1;rewrite HH2;simpl;my_rank.
- assert(HH0 := rk_nil e' H0);
  assert(HH1 := list_inter_reverse e nil);
  assert(HH2 := list_concat_reverse e nil);
  subst;rewrite HH1;rewrite HH2;simpl;my_rank.
- assert(HH0 := rk_nil e' H0);
  assert(HH1 := list_inter_reverse e nil);
  assert(HH2 := list_concat_reverse e nil);
  subst;rewrite HH1;rewrite HH2;simpl;my_rank.
- rewrite H;rewrite H1;apply matroid3_aux20;my_rank.
- rewrite H0;rewrite H1;apply matroid3_aux14;my_rank.
- rewrite H0;rewrite H1;apply matroid3_aux26;my_rank.
- rewrite H;rewrite H0;apply matroid3_aux20_bis;my_rank.
- rewrite H;rewrite H0;apply matroid3_aux20_bis_bis;my_rank.
- rewrite H0;rewrite H1;apply matroid3_aux14_bis;my_rank.
- rewrite H0;rewrite H1;apply matroid3_aux26_bis;my_rank.
- rewrite H0;rewrite H1;apply matroid3_aux14_bis_bis;my_rank.
- rewrite H0;rewrite H1;apply matroid3_aux26_bis_bis;my_rank.
Qed.

Lemma rk_singleton_ge : forall p:Point, rkl (p::nil) >=1.
Proof.
my_rank.
Qed.

Lemma rk_couple_ge : forall p q:Point,~(p[==]q)-> rkl(p::q::nil)>=2.
Proof.
my_rank;
case (eq_dec_u p q);
my_rank;simpl;my_rank.
Qed.

Lemma rk_inter : forall a b c d, {j : Point | rkl(a :: b :: j :: nil) = 2 /\ rkl(c :: d :: j :: nil) = 2}.
Proof.
intros.
assert(HH0 := a1_exist a b).
destruct HH0.
assert(HH1 := a1_exist c d).
destruct HH1.

case_eq (eq_dec_u a b);
case_eq (eq_dec_u c d);
case_eq (eq_dec_u a c).

intros.
rewrite <-e1.
rewrite e.
rewrite e0.
destruct a1.
assert(HH := second_point d x0 H3).
destruct HH.
destruct a1.
exists x1.
assert(HH : ~ d [==] x1);[intuition|].
assert(HH0 := rk_inter_aux0 d x1 HH).
intuition.

intros.
rewrite <-e.
rewrite <-e0.
assert(HH := a1_exist a c).
destruct HH.
assert(HH0 : ~ a [==] c /\ Incid a x1 /\ Incid c x1);[intuition|].
assert(HH1 := third_point a c x1 HH0).
destruct HH1.
destruct a3.
destruct H3.
destruct H4.
exists x2.
split.
assert(HH : ~ a [==] x2);[intuition|].
assert(HH1 := rk_inter_aux0 a x2 HH).
intuition.
assert(HH : ~ c [==] x2);[intuition|].
assert(HH1 := rk_inter_aux0 c x2 HH).
intuition.

intros.
rewrite <-e0.
rewrite e.
exists d.
split.
assert(HH1 := rk_inter_aux0 c d n).
intuition.
assert(HH : ~ d [==] c);[intuition|].
assert(HH1 := rk_inter_aux0 d c HH).
intuition.

intros.
rewrite <-e.
exists c.
split.
assert(HH1 := rk_inter_aux0 a c n).
intuition.
assert(HH1 := rk_inter_aux0 c d n0).
intuition.

intros.
rewrite <-e0.
rewrite <-e.
exists b.
split.
assert(HH : ~ b [==] a);[intuition|].
assert(HH1 := rk_inter_aux0 b a HH).
intuition.
assert(HH1 := rk_inter_aux0 a b n).
intuition.

intros.
rewrite <-e.
exists a.
split.
assert(HH1 := rk_inter_aux0 a b n0).
intuition.
assert(HH : ~ c [==] a);[intuition|].
assert(HH1 := rk_inter_aux0 c a HH).
intuition.

intros.
assert(HH2 := a2_exist x x0).
destruct HH2.
exists x1.
simpl.
case_eq(collinear a b x1).
case_eq(eq_dec_u a b).
intros.
contradiction.
intros.
case_eq(collinear c d x1).
case_eq(eq_dec_u c d).
case_eq(eq_dec_u d x1).
intros.
contradiction.
intros.
intuition.
intros.
intuition.
intros.
generalize H4.
unfold collinear.
case_eq(eq_dec_u c d).
intros.
contradiction.
case_eq(incid_dec x1 (proj1_sig (a1_exist c d))).
intros.
inversion H7.
destruct(a1_exist c d);simpl.
intros.
destruct a1.
destruct a3.
destruct a2.
assert(HH := a1_unique c d x0 x2 n3 H8 H9 H10 H11).
rewrite HH in *.
contradiction.
unfold collinear.
case_eq(eq_dec_u a b).
intros.
contradiction.
case_eq(incid_dec x1 (proj1_sig (a1_exist a b))).
intros.
inversion H4.
destruct(a1_exist a b);simpl.
intros.
destruct a0.
destruct a3.
destruct a2.
assert(HH := a1_unique a b x x2 n0 H5 H6 H7 H8).
rewrite HH in *.
contradiction.

intros.
assert(HH2 := a2_exist x x0).
destruct HH2.
exists x1.
simpl.
case_eq(collinear a b x1).
case_eq(eq_dec_u a b).
intros.
contradiction.
intros.
case_eq(collinear c d x1).
case_eq(eq_dec_u c d).
case_eq(eq_dec_u d x1).
intros.
contradiction.
intros.
intuition.
intros.
intuition.
intros.
generalize H4.
unfold collinear.
case_eq(eq_dec_u c d).
intros.
contradiction.
case_eq(incid_dec x1 (proj1_sig (a1_exist c d))).
intros.
inversion H7.
destruct(a1_exist c d);simpl.
intros.
destruct a1.
destruct a3.
destruct a2.
assert(HH := a1_unique c d x0 x2 n0 H8 H9 H10 H11).
rewrite HH in *.
contradiction.
unfold collinear.
case_eq(eq_dec_u a b).
intros.
contradiction.
case_eq(incid_dec x1 (proj1_sig (a1_exist a b))).
intros.
inversion H4.
destruct(a1_exist a b);simpl.
intros.
destruct a0.
destruct a3.
destruct a2.
assert(HH := a1_unique a b x x2 n1 H5 H6 H7 H8).
rewrite HH in *.
contradiction.
Qed.

Lemma rk_three_points : forall a b, {c : Point | rkl(a :: b :: c :: nil) = 2 /\ rkl(b :: c :: nil) = 2 /\ rkl(a :: c :: nil) = 2}.
Proof.
intros.
assert( HH0 := a1_exist a b).
destruct HH0.
destruct a0.
assert( HH0 := a3_1 x).
destruct HH0.
destruct s.
destruct s.
destruct a0.
destruct H2.
destruct H3.
destruct H4.
destruct H5.
case_eq (eq_dec_u a x0).
case_eq (eq_dec_u b x1).
exists x2.
intros.
rewrite e.
rewrite e0.
simpl.
case_eq (collinear x0 x1 x2).
intros.
case_eq (eq_dec_u x0 x1).
intros.
contradiction.
intros.
case_eq (eq_dec_u x1 x2).
intros.
contradiction.
intros.
case_eq (eq_dec_u x0 x2).
intros.
contradiction.
intros.
split.
reflexivity.
split.
reflexivity.
reflexivity.
unfold collinear.
case_eq (eq_dec_u x0 x1).
intros.
inversion H10.
destruct (a1_exist x0 x1).
simpl.
case_eq (incid_dec x2 x3).
intros.
inversion H11.
intros.
destruct a0.
assert( HH0 := uniqueness x0 x1 x x3 H4 H5 H12 H13).
destruct HH0.
contradiction.
clear H9.
rewrite <-H14 in *.
contradiction.
intros.
exists x1.
simpl.
split.
case_eq (collinear a b x1).
case_eq (eq_dec_u a b).
case_eq (eq_dec_u b x1).
intros.
clear H8 H9 H10.
rewrite e in e1.
rewrite e0 in e1.
contradiction.
intros.
reflexivity.
intros.
reflexivity.
unfold collinear.
case_eq (eq_dec_u a b).
intros.
inversion H10.
destruct (a1_exist a b).
simpl.
case_eq (incid_dec x1 x3).
intros.
inversion H11.
intros.
destruct a0.
assert( HH0 := uniqueness a b x x3 H H0 H12 H13).
destruct HH0.
contradiction.
clear H9.
rewrite H14 in *.
contradiction.
case_eq (eq_dec_u b x1).
intros.
contradiction.
intros.
split.
reflexivity.
case_eq (eq_dec_u a x1).
intros.
clear H10.
rewrite e in e0.
contradiction.
intros.
reflexivity.
intros.
case_eq (eq_dec_u b x1).
intros.
exists x0.
simpl.
split.
case_eq (collinear a b x0).
intros.
case_eq (eq_dec_u a b).
case_eq (eq_dec_u b x0).
intros.
clear H8.
rewrite e0 in e.
contradiction.
intros.
reflexivity.
intros.
reflexivity.
unfold collinear.
case_eq (eq_dec_u a b).
intros.
inversion H10.
destruct (a1_exist a b).
simpl.
case_eq (incid_dec x0 x3).
intros.
inversion H11.
intros.
destruct a0.
assert( HH0 := uniqueness a b x x3 H H0 H12 H13).
destruct HH0.
contradiction.
clear H9.
rewrite <-H14 in n0.
contradiction.
case_eq (eq_dec_u b x0).
intros.
clear H8.
rewrite e0 in e.
contradiction.
intros.
split.
reflexivity.
case_eq (eq_dec_u a x0).
intros.
contradiction.
reflexivity.
intros.
case_eq (eq_dec_u b x0).
case_eq (eq_dec_u a x1).
intros.
exists x2.
simpl.
split.
case_eq (collinear a b x2).
case_eq (eq_dec_u a b).
case_eq (eq_dec_u b x2).
intros.
clear H11.
rewrite e0 in e1.
contradiction.
intros.
reflexivity.
intros.
reflexivity.
unfold collinear.
case_eq (eq_dec_u a b).
intros.
inversion H12.
destruct (a1_exist a b).
simpl.
case_eq (incid_dec x2 x3).
intros.
inversion H13.
intros.
destruct a0.
assert( HH0 := uniqueness a b x x3 H H0 H14 H15).
destruct HH0.
contradiction.
clear H11.
rewrite H16 in *.
contradiction.
case_eq (eq_dec_u b x2).
intros.
clear H11.
rewrite e0 in e1.
contradiction.
intros.
split.
reflexivity.
case_eq (eq_dec_u a x2).
intros.
clear H12.
rewrite e in e1.
contradiction.
intros.
reflexivity.
intros.
exists x1.
split.
simpl.
case_eq (collinear a b x1).
intros.
case_eq (eq_dec_u a b).
intros.
case_eq (eq_dec_u b x1).
intros.
contradiction.
intros.
reflexivity.
intros.
reflexivity.
intros.
generalize H11.
unfold collinear.
case_eq (eq_dec_u a b).
intros.
inversion H13.
destruct (a1_exist a b).
simpl.
case_eq( incid_dec x1 x3).
intros.
inversion H14.
intros.
destruct a0.
assert( HH0 := uniqueness a b x x3 H H0 H15 H16).
destruct HH0.
contradiction.
clear H12.
rewrite <-H17 in n2.
contradiction.
split.
simpl.
case_eq (eq_dec_u b x1).
intros.
contradiction.
intros.
reflexivity.
simpl.
case_eq (eq_dec_u a x1).
intros.
contradiction.
intros.
reflexivity.
intros.
exists x0.
split.
simpl.
case_eq (collinear a b x0).
intros.
case_eq (eq_dec_u a b).
intros.
case_eq (eq_dec_u b x0).
intros.
contradiction.
intros.
reflexivity.
intros.
reflexivity.
intros.
generalize H10.
unfold collinear.
case_eq (eq_dec_u a b).
intros.
inversion H12.
intro.
destruct (a1_exist a b).
simpl.
case_eq(incid_dec x0 x3).
intros.
inversion H13.
intros.
destruct a0.
assert( HH0 := uniqueness a b x x3 H H0 H14 H15).
destruct HH0.
contradiction.
clear H11.
rewrite <-H16 in n3.
contradiction.
split.
simpl.
case_eq (eq_dec_u b x0).
intros.
contradiction.
intros.
reflexivity.
simpl.
case_eq (eq_dec_u a x0).
intros.
contradiction.
intros.
reflexivity.
Qed.

Lemma lower_dim : exists a b c, rkl(a :: b :: c :: nil) >= 3.
Proof.
intros.
assert( HH0 := a3_2).
destruct HH0.
destruct s.
assert( HH0 := a2_exist x x0).
destruct HH0.
assert( HH1 := a3_1 x).
destruct HH1.
destruct s.
destruct s.
destruct a0.
assert(H1 := H0).
destruct H1.
destruct H2.
destruct H3.
destruct H4.
assert( HH2 := a3_1 x0).
destruct HH2.
destruct s.
destruct s.
destruct a0.
destruct H7.
destruct H8.
destruct H9.
destruct H10.
case_eq (eq_dec_u x2 x1).
case_eq (eq_dec_u x5 x1).
intros.
exists x3.
exists x6.
exists x1.
simpl.
case_eq (collinear x3 x6 x1).
intro.
generalize H9.
unfold collinear.
case_eq (eq_dec_u x3 x6).
intros.
rewrite <-e1 in *.
destruct a.
assert( HH0 := uniqueness x1 x3 x x0 H17 H4 H18 H10).
destruct HH0.
rewrite <-e0 in H19.
contradiction.
contradiction.
intro.
destruct (a1_exist x3 x6).
simpl.
case_eq (incid_dec x1 x8).
intros.
destruct a.
destruct a0.
assert( HH0 := uniqueness x1 x3 x x8 H18 H4 i H20).
destruct HH0.
clear H13.
rewrite H22 in e0.
contradiction.
assert( HH0 := uniqueness x1 x6 x0 x8 H19 H10 i H21).
destruct HH0.
clear H12.
rewrite H23 in e.
contradiction.
rewrite <-H23 in H22.
contradiction.
intros.
simplgen H14. unfold collinear.
case_eq(eq_dec_u x3 x6).
intros.
contradiction.
destruct (a1_exist x3 x6).
simpl.
case_eq(incid_dec x1 x9).
intros.
destruct a0.
destruct a1.
assert(HH0 := uniqueness x3 x6 x8 x9 H21 H22 H23 H24).
destruct HH0.
contradiction.
clear H15.
rewrite H25 in *.
contradiction.
intros.
inversion H20.
intros.
intuition.
intros.
exists x3.
exists x5.
exists x1.
simpl.
case_eq (collinear x3 x5 x1).
unfold collinear.
case_eq (eq_dec_u x3 x5).
intros.
rewrite e0 in H4.
destruct a.
assert( HH0 := uniqueness x1 x5 x x0 H16 H4 H17 H9).
destruct HH0.
clear H12.
rewrite H18 in n0.
apply False_ind.
apply n0.
reflexivity.
contradiction.
destruct (a1_exist x3 x5).
simpl.
case_eq (incid_dec x1 x8).
intros.
destruct a.
destruct a0.
assert( HH0 := uniqueness x1 x3 x x8 H17 H4 i H19).
destruct HH0.
clear H13.
rewrite H21 in e.
contradiction.
assert( HH0 := uniqueness x1 x5 x0 x8 H18 H9 i H20).
destruct HH0.
clear H12.
rewrite H22 in n0.
apply False_ind.
apply n0.
reflexivity.
rewrite <-H22 in H21.
contradiction.
intros.
inversion H16.
intros.
intuition.
intros.
case_eq (eq_dec_u x5 x1).
intros.
exists x2.
exists x6.
exists x1.
simpl.
case_eq (collinear x2 x6 x1).
unfold collinear.
case_eq (eq_dec_u x2 x6).
intros.
rewrite <-e0 in H10.
destruct a.
assert( HH0 := uniqueness x1 x2 x x0 H16 H3 H17 H10).
destruct HH0.
clear H12.
rewrite H18 in n0.
apply False_ind.
apply n0.
reflexivity.
contradiction.
destruct (a1_exist x2 x6).
simpl.
case_eq (incid_dec x1 x8).
intros.
destruct a.
destruct a0.
assert( HH0 := uniqueness x1 x2 x x8 H17 H3 i H19).
destruct HH0.
clear H12.
rewrite H21 in n0.
apply False_ind.
apply n0.
reflexivity.
assert( HH0 := uniqueness x1 x6 x0 x8 H18 H10 i H20).
destruct HH0.
clear H13.
rewrite H22 in e.
contradiction.
rewrite <-H22 in H21.
contradiction.
intros.
inversion H16.
intros.
intuition.
intros.
exists x2.
exists x5.
exists x1.
simpl.
case_eq (collinear x2 x5 x1).
unfold collinear.
case_eq (eq_dec_u x2 x5).
intros.
rewrite e in H3.
destruct a.
assert( HH0 := uniqueness x1 x5 x x0 H16 H3 H17 H9).
destruct HH0.
clear H13.
rewrite H18 in n1.
apply False_ind.
apply n1.
reflexivity.
contradiction.
destruct (a1_exist x2 x5).
simpl.
case_eq (incid_dec x1 x8).
intros.
destruct a.
destruct a0.
assert( HH0 := uniqueness x1 x2 x x8 H17 H3 i H19).
destruct HH0.
clear H12.
rewrite H21 in n0.
apply False_ind.
apply n0.
reflexivity.
assert( HH0 := uniqueness x1 x5 x0 x8 H18 H9 i H20).
destruct HH0.
clear H13.
rewrite H22 in n1.
apply False_ind.
apply n1.
reflexivity.
rewrite <-H22 in H21.
contradiction.
intros.
inversion H16.
intros.
intuition.
Qed.

End s_ppEquivToRk.


Require Import Iron.SimplePCFa.Value.Exp.
Require Import Iron.SimplePCFa.Value.Lift.

(* Substitution of values in expressions and values *)
Definition substVVs' (ix: nat) (d: nat) (vs: list val) (vv: val)
 := match get (ix - d) vs with
    | Some u => u
    | None   => VVar (ix - length vs)
   end.

Fixpoint substVVs (d: nat) (vs: list val) (vv: val)
 := match vv with
    |  VVar ix
    => match nat_compare ix d with
       | Lt  => VVar ix  (* ix is locally bound *)
       | _   => substVVs' ix d vs vv
       end

    |  VConst c
    => vv

    |  VLam t x
    => VLam t (substVXs (S d) (map (fun v => liftXV 0 v) vs) x)

    |  VFix t v
    => VFix t (substVVs (S d) (map (fun v => liftXV 0 v) vs) v)
    end
with    substVXs (d: nat) (vs: list val) (xx: exp)
 := match xx with
    |  XVal v
    => XVal (substVVs d vs v)

    |  XLet t x1 x2
    => XLet t (substVXs d vs x1)
              (substVXs (S d) (map (liftXV 0) vs) x2)

    |  XApp v1 v2
    => XApp (substVVs d vs v1) (substVVs d vs v2)

    |  XOp1 op v1
    => XOp1 op (substVVs d vs v1)

    |  XIf v1 x2 x3
    => XIf (substVVs d vs v1) (substVXs d vs x2) (substVXs d vs x3)
    end.

(* Closed substitution of values in expressions and values *)
Definition csubstVXs (vs: list val) (xx: exp) (xx': exp)
 := xx' = substVXs 0 vs xx
 /\ closedX xx'.


Require Import FO_BiInt_Syntax.
Require Import List.
Export ListNotations.

Require Import genT gen.
Require Import PeanoNat.
Require Import Ensembles.
Local Set Implicit Arguments.
Local Unset Strict Implicit.

(* In this file we define two Hilbert calculi based on multisets for the first-order
   bi-intuitionistic logicsFO wBIL and FOsBIL. *)

Section Calculi.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  (* **** Definition *)

(* We define here the axioms. *)

Definition RA1 (A B C : form) : form := (A --> B) --> ((B --> C) --> (A --> C)).
Definition RA2 (A B : form) : form := A --> (A ∨ B).
Definition RA3 (A B : form) : form := B --> (A ∨ B).
Definition RA4 (A B C : form) : form := (A --> C) --> ((B --> C) --> ((A ∨ B) --> C)).
Definition RA5 (A B : form) : form := (A ∧ B) --> A.
Definition RA6 (A B : form) : form := (A ∧ B) --> B.
Definition RA7 (A B C : form) : form := (A --> B) --> ((A --> C) --> (A --> (B ∧ C))).
Definition RA8 (A B C : form) : form := (A --> (B --> C)) --> ((A ∧ B) --> C).
Definition RA9 (A B C : form) : form := ((A ∧ B) --> C) --> (A --> (B --> C)).
Definition RA10 (A B : form) : form := (A --> B) --> ((¬ B) --> ¬ A).
Definition RA11 (A B : form) : form := A --> (B ∨ (A --< B)).
Definition RA12 (A B : form) : form := (A --< B) --> ∞ (A --> B).
Definition RA13 (A B C : form) : form := ((A --< B) --< C) --> (A --< (B ∨ C)).
Definition RA14 (A B : form) : form := (¬ (A --< B)) --> (A --> B).
Definition RA15 (A : form) : form := A --> ⊤.
Definition RA16 (A : form) : form := ⊥ --> A.
Definition RA17 (A B : form) : form := (∀ (A[↑] --> B)) --> (A --> ∀ B).
Definition RA18 (A : form) (t : term) : form := (∀ A) --> A[t..].
Definition RA19 (A : form) (t : term) : form := A[t..] --> ∃ A.

Inductive BIAxioms (A : form) : Prop :=
 | RA1_I : (exists B C D, A = (RA1 B C D)) -> BIAxioms A
 | RA2_I : (exists B C, A = (RA2 B C)) -> BIAxioms A
 | RA3_I :  (exists B C, A = (RA3 B C)) -> BIAxioms A
 | RA4_I :  (exists B C D, A = (RA4 B C D)) -> BIAxioms A
 | RA5_I :  (exists B C, A = (RA5 B C)) -> BIAxioms A
 | RA6_I :  (exists B C, A = (RA6 B C)) -> BIAxioms A
 | RA7_I :  (exists B C D, A = (RA7 B C D)) -> BIAxioms A
 | RA8_I :  (exists B C D, A = (RA8 B C D)) -> BIAxioms A
 | RA9_I :  (exists B C D, A = (RA9 B C D)) -> BIAxioms A
 | RA10_I :  (exists B C, A = (RA10 B C)) -> BIAxioms A
 | RA11_I :  (exists B C, A = (RA11 B C)) -> BIAxioms A
 | RA12_I :  (exists B C, A = (RA12 B C)) -> BIAxioms A
 | RA13_I :  (exists B C D, A = (RA13 B C D)) -> BIAxioms A
 | RA14_I :  (exists B C, A = (RA14 B C)) -> BIAxioms A
 | RA15_I :  (exists B, A = (RA15 B)) -> BIAxioms A
 | RA16_I :  (exists B, A = (RA16 B)) -> BIAxioms A
 | RA17_I :  (exists B C, A = (RA17 B C)) -> BIAxioms A
 | RA18_I :  (exists B t, A = (RA18 B t)) -> BIAxioms A
 | RA19_I :  (exists B t, A = (RA19 B t)) -> BIAxioms A.

(* Finally, we can define the rules which constitute our calculi. We gather
   them in cacluli in a definition appearing later.

   We start by giving the rules common to both calculi. *)

Inductive IdRule : rls (@Ensemble (form) * (form)) :=
  | IdRule_I : forall A (Γ : @Ensemble _),
                  (In _ Γ A) -> (IdRule nil (Γ, A)).

Inductive AxRule : rls ((@Ensemble (form)) * (form)) :=
  | AxRule_I : forall Γ (A : form),
          (BIAxioms A) -> AxRule nil (Γ, A)
.

Inductive MPRule : rls ((@Ensemble (form)) * (form)) :=
  | MPRule_I : forall A B Γ,
          MPRule ((Γ, (A --> B)) :: (Γ, A) :: nil)
                    (Γ, B)
.

Inductive GenRule : rls ((@Ensemble (form)) * (form)) :=
  | GenRule_I : forall (A : form) Γ,
          GenRule (((fun x => exists B, ((x = (subst_form ↑) B) /\ In _ Γ B)), A) :: nil)
                     (Γ, ∀ A)
.

Inductive ECRule : rls ((@Ensemble (form)) * (form)) :=
  | ECRule_I : forall (A B : form) Γ,
          ECRule (((fun x => exists B, ((x = (subst_form ↑) B) /\ In _ Γ B)), A --> (B[↑])) :: nil)
                     (Γ, (∃ A) --> B)
.

(* Then we turn to the distinctive rules of each calculus. *)

Inductive DNwRule : rls ((@Ensemble (form)) * (form)) :=
  | DNwRule_I : forall (A : form) Γ,
          DNwRule ((Empty_set _, A) :: nil)
                    (Γ, ¬ ∞ A)
.

Inductive DNsRule : rls ((@Ensemble (form)) * (form)) :=
  | DNsRule_I : forall (A : form) Γ,
          DNsRule ((Γ, A) :: nil)
                     (Γ, ¬ ∞ A)
.

(* At last we can define our calculi FOwBIH and FOwBIH. *)

Inductive FOwBIH_rules (s : ((@Ensemble (form)) * (form))) : Prop :=
  | Id : IdRule nil s -> FOwBIH_rules s
  | Ax : AxRule nil s -> FOwBIH_rules s
  | MP : forall ps, (forall prem, List.In prem ps -> FOwBIH_rules prem) -> MPRule ps s -> FOwBIH_rules s
  | DNw : forall ps, (forall prem, List.In prem ps -> FOwBIH_rules prem) -> DNwRule ps s -> FOwBIH_rules s
  | Gen : forall ps, (forall prem, List.In prem ps -> FOwBIH_rules prem) -> GenRule ps s -> FOwBIH_rules s
  | EC : forall ps, (forall prem, List.In prem ps -> FOwBIH_rules prem) -> ECRule ps s -> FOwBIH_rules s
.

Inductive FOsBIH_rules (s : ((@Ensemble form) * (form))) : Prop :=
  | Ids : IdRule nil s -> FOsBIH_rules s
  | Axs : AxRule nil s -> FOsBIH_rules s
  | MPs : forall ps, (forall prem, List.In prem ps -> FOsBIH_rules prem) -> MPRule ps s -> FOsBIH_rules s
  | DNs : forall ps, (forall prem, List.In prem ps -> FOsBIH_rules prem) -> DNsRule ps s -> FOsBIH_rules s
  | Gens : forall ps, (forall prem, List.In prem ps -> FOsBIH_rules prem) -> GenRule ps s -> FOsBIH_rules s
  | ECs : forall ps, (forall prem, List.In prem ps -> FOsBIH_rules prem) -> ECRule ps s -> FOsBIH_rules s
.
(* Define the general notion of derivable pair. *)

Fixpoint list_disj (l : list form) : form :=
match l with
 | nil => ⊥
 | h :: t => h ∨ (list_disj t)
end.

Fixpoint list_conj (l : list form) : form :=
match l with
 | nil => ⊤
 | h :: t => h ∧ (list_conj t)
end.

(* Why do I pick a NoDup list? Makes things easier I guess, as I can control the length.
    Logically I should be able to get rid of it though. *)

Definition wpair_der (G : prod (@Ensemble form) (@Ensemble form)) : Prop :=
    exists (l : list form), NoDup l /\ (forall A, List.In A l -> (In _ (snd G) A)) /\
        (FOwBIH_rules (fst G, list_disj l)).

Definition spair_der (G : prod (@Ensemble form) (@Ensemble form)) : Prop :=
    exists (l : list form), NoDup l /\ (forall A, List.In A l -> (In _ (snd G) A)) /\
        (FOsBIH_rules (fst G, list_disj l)).

Definition complete (G : prod (Ensemble form) (Ensemble form)) : Prop :=
    forall (A : form), In _ (fst G) A \/ In _ (snd G) A.

End Calculi.


(** * Natural numbers and their properties. Vladimir Voevodsky. Apr. - Sep. 2011

This file contains the formulations and proofs of general properties of natural
numbers from the univalent perspecive. *)
(** ** Contents

- Inductive types [le] with values in [UU]
 - A generalization of [le] and its properties
 - Inductive types [le] with values in [UU] are in [hProp]
 - Comparison between [le] with values in [UU] and [natleh]
*)

(** ** Preamble *)

(** Settings *)

(** Imports. *)

Require Export UniMath.Foundations.NaturalNumbers.

(** ** Inductive types [le] with values in [UU].

This part is included for illustration purposes only. In practice it is easier
to work with [natleh] than with [le].

*)

(** *** A generalization of [le] and its properties. *)

Inductive leF {T : UU} (F : T -> T) (t : T) : T -> UU :=
| leF_O : leF F t t
| leF_S : ∏ t' : T, leF F t t' -> leF F t (F t').

Lemma leFiter {T : UU} (F : T -> T) (t : T) (n : nat) : leF F t (iteration F n t).
Proof.
  intros. induction n as [ | n IHn ].
  - apply leF_O.
  - simpl. apply leF_S. assumption.
Defined.

Lemma leFtototal2withnat {T : UU} (F : T -> T) (t t' : T) (a : leF F t t') :
  total2 (λ n : nat, (iteration F n t) = t').
Proof.
  intros. induction a as [ | b H0 IH0 ].
  - split with O. apply idpath.
  - split with (S (pr1 IH0)). simpl.
    apply (@maponpaths _ _ F (iteration F (pr1 IH0) t) b).
    apply (pr2 IH0).
Defined.

Lemma total2withnattoleF {T : UU} (F : T -> T) (t t' : T)
      (a : total2 (λ n : nat, (iteration F n t) = t')) : leF F t t'.
Proof.
  intros. destruct a as [ n e ]. destruct e. apply leFiter.
Defined.

Lemma leFtototal2withnat_l0 {T : UU} (F : T -> T) (t : T) (n : nat) :
  (leFtototal2withnat F t _ (leFiter F t n)) = (tpair _  n (idpath (iteration F n t))).
Proof.
  intros. induction n as [ | n IHn ].
  - apply idpath.
  - simpl.
    set (h := fun ne : total2 (λ n0 : nat, paths (iteration F n0 t) (iteration F n t)) =>
                tpair (λ n0 : nat, paths (iteration F n0 t) (iteration F (S n) t)) (S (pr1 ne))
                      (maponpaths F (pr2 ne))).
    apply (@maponpaths _ _ h  _ _ IHn).
Defined.

Lemma isweqleFtototal2withnat {T : UU} (F : T -> T) (t t' : T) : isweq (leFtototal2withnat F t t').
Proof.
  intros.
  set (f := leFtototal2withnat F t t').
  set (g := total2withnattoleF  F t t').
  assert (egf : ∏ x : _, paths (g (f x)) x).
  {
    intro x. induction x as [ | y H0 IHH0 ].
    - apply idpath.
    - simpl. simpl in IHH0.
      destruct (leFtototal2withnat F t y H0) as [ m e ].
      destruct e. simpl. simpl in IHH0.
      apply (@maponpaths _ _ (leF_S F t (iteration F m t)) _ _ IHH0).
  }
  assert (efg : ∏ x : _, paths (f (g x)) x).
  {
    intro x. destruct x as [ n e ]. destruct e. simpl.
    apply leFtototal2withnat_l0.
  }
  apply (isweq_iso _ _ egf efg).
Defined.

Definition weqleFtototalwithnat { T : UU } (F : T -> T) (t t' : T) :
  weq (leF F t t') (total2 (λ n : nat, (iteration F n t) = t')) :=
  make_weq _ (isweqleFtototal2withnat F t t').

(** *** Inductive types [le] with values in [UU] are in [hProp] *)

Definition le (n : nat) : nat -> UU := leF S n.

Definition le_n : ∏ t : nat, leF S t t := leF_O S.

Definition le_S : ∏ t t' : nat, leF S t t' → leF S t (S t') := leF_S S.

Theorem isaprople (n m : nat) : isaprop (le n m).
Proof.
  intros.
  apply (isofhlevelweqb 1 (weqleFtototalwithnat S n m)).
  apply invproofirrelevance. intros x x'.
  set (i := @pr1 _ (λ n0 : nat, (iteration S n0 n) = m)).
  assert (is : isincl i) by apply (isinclpr1 _ (λ n0 : nat, isasetnat (iteration S n0 n) m)).
  apply (invmaponpathsincl _  is).
  destruct x as [ n1 e1 ]. destruct x' as [ n2 e2 ]. simpl.
  set (int1 := pathsinv0 (pathsitertoplus n1 n)).
  set (int2 := pathsinv0 (pathsitertoplus n2 n)).
  set (ee1 := pathscomp0 int1 e1).
  set (ee2 := pathscomp0 int2 e2).
  set (e := pathscomp0 ee1 (pathsinv0 ee2)).
  apply (invmaponpathsincl _ (isinclnatplusr n) n1 n2 e).
Defined.

(** *** Comparison between [le] with values in [UU] and [natleh]. *)

Lemma letoleh (n m : nat) : le n m -> n ≤ m.
Proof.
  intros H. induction H as [ | m H0 IHH0 ].
  - apply isreflnatleh.
  - apply natlehtolehs. assumption.
Defined.

Lemma natlehtole (n m : nat) : n ≤ m ->  le n m.
Proof.
  intros H. induction m as [|m IHm].
  - assert (int := natleh0tois0 H). clear H. destruct int. apply le_n.
  - set (int2 := natlehchoice2 n (S m) H).
    destruct int2 as [ isnatleh | iseq ].
    apply (le_S n m (IHm isnatleh)). destruct iseq.
    apply le_n.
Defined.

Lemma isweqletoleh (n m : nat) : isweq (letoleh n m).
Proof.
  intros.
  set (is1 := isaprople n m). set (is2 := pr2 (n ≤ m)).
  apply (isweqimplimpl (letoleh n m) (natlehtole n m) is1 is2).
Defined.

Definition weqletoleh (n m : nat) : le n m ≃ n ≤ m := make_weq _ (isweqletoleh n m).


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Solange Coupet-Grimal and William Delobel, 2006-01-09

Model of LPO statisfying Hypotheses in RPO_Types
*)

From CoLoR Require Import VPrecedence ListLex VRPO_Type VTerm ListUtil AccUtil
  LogicUtil.
From Coq Require Import Relations.

Module LPO (PT : VPrecedenceType).

  Module Export P := VPrecedence PT.
  Module Export S := Status PT.

  Inductive lt_lpo : relation term :=
    | lpo1 : forall f g ss ts, g <F f ->
        (forall t, In t ts -> lt_lpo t (Fun f ss)) ->
        lt_lpo (Fun g ts) (Fun f ss)
    | lpo2 : forall f g, f =F= g -> forall ss ts,
        (forall t, In t ts -> lt_lpo t (Fun f ss)) ->
        lex lt_lpo ts ss -> lt_lpo (Fun g ts) (Fun f ss)
    | lpo3 : forall t f ss,
        ex (fun s => In s ss /\ (s = t \/ lt_lpo t s)) ->
        lt_lpo t (Fun f ss).

  Definition mytau (f : Sig) (r : relation term) := lex r.

End LPO.

(***********************************************************************)

From CoLoR Require Import VRPO_Type.

Module LPO_Model (PT : VPrecedenceType) <: RPO_Model with Module P := PT.

  Module P := PT.
  Module Export LPO := LPO PT.

  Definition tau := mytau.

  Lemma tau_dec : forall f R ts ss,
    (forall t s, In t ts -> In s ss -> {R t s} + {~R t s}) ->
    {tau f R ts ss} + {~tau f R ts ss}.

  Proof.
    unfold tau, mytau. intros. apply lex_status_dec. hyp.
  Defined.

  Lemma status_eq : forall f g, f =F= g -> tau f = tau g.

  Proof.
    auto.
  Qed.

  Definition lt := lt_lpo.

  (* Verification des axiomes lt : *)

  Lemma lt_roots : forall f g, g <F f -> forall ss ts,
    (forall t, In t ts -> lt t (Fun f ss)) -> lt (Fun g ts) (Fun f ss).

  Proof.
    intros f g ltgf ss ts Hsub. unfold lt; apply lpo1; trivial.
  Qed.

  Lemma lt_status : forall f g, f =F= g ->
    forall ss ts, (forall t, In t ts -> lt t (Fun f ss)) ->
      tau f lt ts ss -> lt (Fun g ts) (Fun f ss).

  Proof.
    unfold lt, tau, mytau. intros f g feqg ss ts Hsub. apply lpo2; trivial.
  Qed.

  Lemma lt_subterm : forall f ss t,
    ex (fun s => In s ss /\ (s = t \/ lt t s)) -> lt t (Fun f ss).

  Proof.
    intros f ss t Hex; unfold lt; apply lpo3; trivial.
  Qed.

  Lemma lt_decomp : forall s t, lt s t ->
    ((ex (fun f => ex (fun g => ex (fun ss => ex (fun ts =>
      ltF f g /\
      (forall s, In s ss -> lt s (Fun g ts)) /\
      s = Fun f ss /\
      t = Fun g ts
    )))))
    \/
    ex (fun f => ex (fun g => ex (fun ss => ex (fun ts =>
      f =F= g /\
      (forall s, In s ss -> lt s (Fun g ts)) /\
      tau f lt ss ts /\
      s = Fun f ss /\
      t = Fun g ts)))))
    \/
    ex (fun f => ex (fun ts => ex (fun t' =>
      In t' ts /\ (s = t' \/ lt s t')) /\ t = Fun f ts)).

  Proof.
    intros s t Hst.
    unfold lt in Hst; inversion Hst as [f'' g'' ss' ts'' ltFfg Hsi'
      | f'' g'' feq ss' ts'' Hsub Hss'ts' Hsi'
      | f'' s' ts'' Hex]; subst.
    left; left.
    exists g''; exists f''; exists ts''; exists ss'.
    split; trivial; repeat split; trivial.
    left; right.
    exists g''; exists f''; exists ts''; exists ss'.
    split; elim feq; trivial; repeat split; trivial.
    right.
    exists s'; exists ts''.
    split; trivial; elim Hex; clear Hex; intros t Ht.
    elim Ht; clear Ht; intros t_in_ts Ht.
    exists t; split; trivial.
    elim Ht; [left; subst | right]; trivial.
  Qed.

(***********************************************************************)

  Lemma SPO_to_status_SPO : forall f (r : relation term),
    forall ss,
      (forall s, In s ss ->
	(forall t u, r s t -> r t u -> r s u) /\ (r s s -> False)) ->
      (forall ts us, tau f r ss ts -> tau f r ts us -> tau f r ss us)
      /\ (tau f r ss ss -> False).

  Proof.
    intros f r. unfold tau, mytau. apply SPO_to_lex_SPO.
  Qed.

  Lemma mono_axiom : forall f (r : relation term),
    forall ss ts, one_less r ss ts -> tau f r ss ts.

  Proof.
    intros f r ss ts. unfold tau, mytau. apply one_less2lex.
  Qed.

(***********************************************************************)

  Definition wf_ltF := ltF_wf.
  Definition leF_dec := leF_dec.

  Definition lifting R := forall l, Accs lt l ->  Restricted_acc (Accs lt) R l.

  Lemma status_lifting : forall f, lifting (tau f lt).

  Proof.
    intro f; unfold tau, mytau, lt, lifting. apply (lex_lifting lt_lpo).
  Qed.

End LPO_Model.


From Hammer Require Import Hammer.

From compcert Require Import Core.
From compcert Require Import Digits.
From compcert Require Import Float_prop.
From compcert Require Import Bracket.

Section Fcalc_round.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Section Fcalc_round_fexp.

Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.
Notation format := (generic_format beta fexp).

Theorem cexp_inbetween_float :
forall x m e l,
(0 < x)%R ->
inbetween_float beta m e x l ->
(e <= cexp beta fexp x \/ e <= fexp (Zdigits beta m + e))%Z ->
cexp beta fexp x = fexp (Zdigits beta m + e).
Proof. hammer_hook "Round" "Round.cexp_inbetween_float".
intros x m e l Px Bx He.
unfold cexp.
apply inbetween_float_bounds in Bx.
assert (0 <= m)%Z as Hm.
{ apply Zlt_succ_le.
eapply gt_0_F2R.
apply Rlt_trans with (1 := Px).
apply Bx. }
destruct (Zle_lt_or_eq _ _ Hm) as [Hm'|<-].
now erewrite <- mag_F2R_bounds_Zdigits with (1 := Hm').
clear Hm.
assert (mag beta x <= e)%Z as Hx.
{ apply mag_le_bpow.
now apply Rgt_not_eq.
rewrite Rabs_pos_eq.
now rewrite <- F2R_bpow.
now apply Rlt_le. }
simpl in He |- *.
clear Bx.
destruct He as [He|He].
- apply eq_sym, valid_exp with (2 := He).
now apply Z.le_trans with e.
- apply valid_exp with (1 := He).
now apply Z.le_trans with e.
Qed.

Theorem cexp_inbetween_float_loc_Exact :
forall x m e l,
(0 <= x)%R ->
inbetween_float beta m e x l ->
(e <= cexp beta fexp x \/ l = loc_Exact <->
e <= fexp (Zdigits beta m + e) \/ l = loc_Exact)%Z.
Proof. hammer_hook "Round" "Round.cexp_inbetween_float_loc_Exact".
intros x m e l Px Bx.
destruct Px as [Px|Px].
- split ; (intros [H|H] ; [left|now right]).
rewrite <- cexp_inbetween_float with (1 := Px) (2 := Bx).
exact H.
now left.
rewrite cexp_inbetween_float with (1 := Px) (2 := Bx).
exact H.
now right.
- assert (H := Bx).
destruct Bx as [|c Bx _].
now split ; right.
rewrite <- Px in Bx.
destruct Bx as [Bx1 Bx2].
apply lt_0_F2R in Bx1.
apply gt_0_F2R in Bx2.
omega.
Qed.

Theorem inbetween_float_round :
forall rnd choice,
( forall x m l, inbetween_int m x l -> rnd x = choice m l ) ->
forall x m l,
let e := cexp beta fexp x in
inbetween_float beta m e x l ->
round beta fexp rnd x = F2R (Float beta (choice m l) e).
Proof. hammer_hook "Round" "Round.inbetween_float_round".
intros rnd choice Hc x m l e Hl.
unfold round, F2R. simpl.
apply (f_equal (fun m => (IZR m * bpow e)%R)).
apply Hc.
apply inbetween_mult_reg with (bpow e).
apply bpow_gt_0.
now rewrite scaled_mantissa_mult_bpow.
Qed.

Definition cond_incr (b : bool) m := if b then (m + 1)%Z else m.

Theorem inbetween_float_round_sign :
forall rnd choice,
( forall x m l, inbetween_int m (Rabs x) l ->
rnd x = cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m l) ) ->
forall x m l,
let e := cexp beta fexp x in
inbetween_float beta m e (Rabs x) l ->
round beta fexp rnd x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m l)) e).
Proof. hammer_hook "Round" "Round.inbetween_float_round_sign".
intros rnd choice Hc x m l e Hx.
apply (f_equal (fun m => (IZR m * bpow e)%R)).
simpl.
replace (Rlt_bool x 0) with (Rlt_bool (scaled_mantissa beta fexp x) 0).

apply Hc.
apply inbetween_mult_reg with (bpow e).
apply bpow_gt_0.
rewrite <- (Rabs_right (bpow e)) at 3.
rewrite <- Rabs_mult.
now rewrite scaled_mantissa_mult_bpow.
apply Rle_ge.
apply bpow_ge_0.

destruct (Rlt_bool_spec x 0) as [Zx|Zx] ; simpl.
apply Rlt_bool_true.
rewrite <- (Rmult_0_l (bpow (-e))).
apply Rmult_lt_compat_r with (2 := Zx).
apply bpow_gt_0.
apply Rlt_bool_false.
apply Rmult_le_pos with (1 := Zx).
apply bpow_ge_0.
Qed.

Theorem inbetween_int_DN :
forall x m l,
inbetween_int m x l ->
Zfloor x = m.
Proof. hammer_hook "Round" "Round.inbetween_int_DN".
intros x m l Hl.
refine (Zfloor_imp m _ _).
apply inbetween_bounds with (2 := Hl).
apply IZR_lt.
apply Zlt_succ.
Qed.

Theorem inbetween_float_DN :
forall x m l,
let e := cexp beta fexp x in
inbetween_float beta m e x l ->
round beta fexp Zfloor x = F2R (Float beta m e).
Proof. hammer_hook "Round" "Round.inbetween_float_DN".
apply inbetween_float_round with (choice := fun m l => m).
exact inbetween_int_DN.
Qed.

Definition round_sign_DN s l :=
match l with
| loc_Exact => false
| _ => s
end.

Theorem inbetween_int_DN_sign :
forall x m l,
inbetween_int m (Rabs x) l ->
Zfloor x = cond_Zopp (Rlt_bool x 0) (cond_incr (round_sign_DN (Rlt_bool x 0) l) m).
Proof. hammer_hook "Round" "Round.inbetween_int_DN_sign".
intros x m l Hl.
unfold Rabs in Hl.
destruct (Rcase_abs x) as [Zx|Zx] .

rewrite Rlt_bool_true with (1 := Zx).
inversion_clear Hl ; simpl.
rewrite <- (Ropp_involutive x).
rewrite H, <- opp_IZR.
apply Zfloor_IZR.
apply Zfloor_imp.
split.
apply Rlt_le.
rewrite opp_IZR.
apply Ropp_lt_cancel.
now rewrite Ropp_involutive.
ring_simplify (- (m + 1) + 1)%Z.
rewrite opp_IZR.
apply Ropp_lt_cancel.
now rewrite Ropp_involutive.

rewrite Rlt_bool_false.
inversion_clear Hl ; simpl.
rewrite H.
apply Zfloor_IZR.
apply Zfloor_imp.
split.
now apply Rlt_le.
apply H.
now apply Rge_le.
Qed.

Theorem inbetween_float_DN_sign :
forall x m l,
let e := cexp beta fexp x in
inbetween_float beta m e (Rabs x) l ->
round beta fexp Zfloor x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (cond_incr (round_sign_DN (Rlt_bool x 0) l) m)) e).
Proof. hammer_hook "Round" "Round.inbetween_float_DN_sign".
apply inbetween_float_round_sign with (choice := fun s m l => cond_incr (round_sign_DN s l) m).
exact inbetween_int_DN_sign.
Qed.

Definition round_UP l :=
match l with
| loc_Exact => false
| _ => true
end.

Theorem inbetween_int_UP :
forall x m l,
inbetween_int m x l ->
Zceil x = cond_incr (round_UP l) m.
Proof. hammer_hook "Round" "Round.inbetween_int_UP".
intros x m l Hl.
assert (Hl': l = loc_Exact \/ (l <> loc_Exact /\ round_UP l = true)).
case l ; try (now left) ; now right ; split.
destruct Hl' as [Hl'|(Hl1, Hl2)].

rewrite Hl'.
destruct Hl ; try easy.
rewrite H.
exact (Zceil_IZR _).

rewrite Hl2.
simpl.
apply Zceil_imp.
ring_simplify (m + 1 - 1)%Z.
refine (let H := _ in conj (proj1 H) (Rlt_le _ _ (proj2 H))).
apply inbetween_bounds_not_Eq with (2 := Hl1) (1 := Hl).
Qed.

Theorem inbetween_float_UP :
forall x m l,
let e := cexp beta fexp x in
inbetween_float beta m e x l ->
round beta fexp Zceil x = F2R (Float beta (cond_incr (round_UP l) m) e).
Proof. hammer_hook "Round" "Round.inbetween_float_UP".
apply inbetween_float_round with (choice := fun m l => cond_incr (round_UP l) m).
exact inbetween_int_UP.
Qed.

Definition round_sign_UP s l :=
match l with
| loc_Exact => false
| _ => negb s
end.

Theorem inbetween_int_UP_sign :
forall x m l,
inbetween_int m (Rabs x) l ->
Zceil x = cond_Zopp (Rlt_bool x 0) (cond_incr (round_sign_UP (Rlt_bool x 0) l) m).
Proof. hammer_hook "Round" "Round.inbetween_int_UP_sign".
intros x m l Hl.
unfold Rabs in Hl.
destruct (Rcase_abs x) as [Zx|Zx] .

rewrite Rlt_bool_true with (1 := Zx).
simpl.
unfold Zceil.
apply f_equal.
inversion_clear Hl ; simpl.
rewrite H.
apply Zfloor_IZR.
apply Zfloor_imp.
split.
now apply Rlt_le.
apply H.

rewrite Rlt_bool_false.
simpl.
inversion_clear Hl ; simpl.
rewrite H.
apply Zceil_IZR.
apply Zceil_imp.
split.
change (m + 1 - 1)%Z with (Z.pred (Z.succ m)).
now rewrite <- Zpred_succ.
now apply Rlt_le.
now apply Rge_le.
Qed.

Theorem inbetween_float_UP_sign :
forall x m l,
let e := cexp beta fexp x in
inbetween_float beta m e (Rabs x) l ->
round beta fexp Zceil x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (cond_incr (round_sign_UP (Rlt_bool x 0) l) m)) e).
Proof. hammer_hook "Round" "Round.inbetween_float_UP_sign".
apply inbetween_float_round_sign with (choice := fun s m l => cond_incr (round_sign_UP s l) m).
exact inbetween_int_UP_sign.
Qed.

Definition round_ZR (s : bool) l :=
match l with
| loc_Exact => false
| _ => s
end.

Theorem inbetween_int_ZR :
forall x m l,
inbetween_int m x l ->
Ztrunc x = cond_incr (round_ZR (Zlt_bool m 0) l) m.
Proof with auto with typeclass_instances. hammer_hook "Round" "Round.inbetween_int_ZR".
intros x m l Hl.
inversion_clear Hl as [Hx|l' Hx Hl'].

rewrite Hx.
rewrite Zrnd_IZR...

unfold Ztrunc.
assert (Hm: Zfloor x = m).
apply Zfloor_imp.
exact (conj (Rlt_le _ _ (proj1 Hx)) (proj2 Hx)).
rewrite Zceil_floor_neq.
rewrite Hm.
unfold cond_incr.
simpl.
case Rlt_bool_spec ; intros Hx' ;
case Zlt_bool_spec ; intros Hm' ; try apply refl_equal.
elim Rlt_not_le with (1 := Hx').
apply Rlt_le.
apply Rle_lt_trans with (2 := proj1 Hx).
now apply IZR_le.
elim Rle_not_lt with (1 := Hx').
apply Rlt_le_trans with (1 := proj2 Hx).
apply IZR_le.
now apply Zlt_le_succ.
rewrite Hm.
now apply Rlt_not_eq.
Qed.

Theorem inbetween_float_ZR :
forall x m l,
let e := cexp beta fexp x in
inbetween_float beta m e x l ->
round beta fexp Ztrunc x = F2R (Float beta (cond_incr (round_ZR (Zlt_bool m 0) l) m) e).
Proof. hammer_hook "Round" "Round.inbetween_float_ZR".
apply inbetween_float_round with (choice := fun m l => cond_incr (round_ZR (Zlt_bool m 0) l) m).
exact inbetween_int_ZR.
Qed.

Theorem inbetween_int_ZR_sign :
forall x m l,
inbetween_int m (Rabs x) l ->
Ztrunc x = cond_Zopp (Rlt_bool x 0) m.
Proof. hammer_hook "Round" "Round.inbetween_int_ZR_sign".
intros x m l Hl.
simpl.
unfold Ztrunc.
destruct (Rlt_le_dec x 0) as [Zx|Zx].

rewrite Rlt_bool_true with (1 := Zx).
simpl.
unfold Zceil.
apply f_equal.
apply Zfloor_imp.
rewrite <- Rabs_left with (1 := Zx).
apply inbetween_bounds with (2 := Hl).
apply IZR_lt.
apply Zlt_succ.

rewrite Rlt_bool_false with (1 := Zx).
simpl.
apply Zfloor_imp.
rewrite <- Rabs_pos_eq with (1 := Zx).
apply inbetween_bounds with (2 := Hl).
apply IZR_lt.
apply Zlt_succ.
Qed.

Theorem inbetween_float_ZR_sign :
forall x m l,
let e := cexp beta fexp x in
inbetween_float beta m e (Rabs x) l ->
round beta fexp Ztrunc x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) m) e).
Proof. hammer_hook "Round" "Round.inbetween_float_ZR_sign".
apply inbetween_float_round_sign with (choice := fun s m l => m).
exact inbetween_int_ZR_sign.
Qed.

Definition round_N (p : bool) l :=
match l with
| loc_Exact => false
| loc_Inexact Lt => false
| loc_Inexact Eq => p
| loc_Inexact Gt => true
end.

Theorem inbetween_int_N :
forall choice x m l,
inbetween_int m x l ->
Znearest choice x = cond_incr (round_N (choice m) l) m.
Proof with auto with typeclass_instances. hammer_hook "Round" "Round.inbetween_int_N".
intros choice x m l Hl.
inversion_clear Hl as [Hx|l' Hx Hl'].

rewrite Hx.
rewrite Zrnd_IZR...

unfold Znearest.
assert (Hm: Zfloor x = m).
apply Zfloor_imp.
exact (conj (Rlt_le _ _ (proj1 Hx)) (proj2 Hx)).
rewrite Zceil_floor_neq.
rewrite Hm.
replace (Rcompare (x - IZR m) (/2)) with l'.
now case l'.
rewrite <- Hl'.
rewrite plus_IZR.
rewrite <- (Rcompare_plus_r (- IZR m) x).
apply f_equal.
field.
rewrite Hm.
now apply Rlt_not_eq.
Qed.

Theorem inbetween_int_N_sign :
forall choice x m l,
inbetween_int m (Rabs x) l ->
Znearest choice x = cond_Zopp (Rlt_bool x 0) (cond_incr (round_N (if Rlt_bool x 0 then negb (choice (-(m + 1))%Z) else choice m) l) m).
Proof with auto with typeclass_instances. hammer_hook "Round" "Round.inbetween_int_N_sign".
intros choice x m l Hl.
simpl.
unfold Rabs in Hl.
destruct (Rcase_abs x) as [Zx|Zx].

rewrite Rlt_bool_true with (1 := Zx).
simpl.
rewrite <- (Ropp_involutive x).
rewrite Znearest_opp.
apply f_equal.
inversion_clear Hl as [Hx|l' Hx Hl'].
rewrite Hx.
apply Zrnd_IZR...
assert (Hm: Zfloor (-x) = m).
apply Zfloor_imp.
exact (conj (Rlt_le _ _ (proj1 Hx)) (proj2 Hx)).
unfold Znearest.
rewrite Zceil_floor_neq.
rewrite Hm.
replace (Rcompare (- x - IZR m) (/2)) with l'.
now case l'.
rewrite <- Hl'.
rewrite plus_IZR.
rewrite <- (Rcompare_plus_r (- IZR m) (-x)).
apply f_equal.
field.
rewrite Hm.
now apply Rlt_not_eq.

generalize (Rge_le _ _ Zx).
clear Zx. intros Zx.
rewrite Rlt_bool_false with (1 := Zx).
simpl.
inversion_clear Hl as [Hx|l' Hx Hl'].
rewrite Hx.
apply Zrnd_IZR...
assert (Hm: Zfloor x = m).
apply Zfloor_imp.
exact (conj (Rlt_le _ _ (proj1 Hx)) (proj2 Hx)).
unfold Znearest.
rewrite Zceil_floor_neq.
rewrite Hm.
replace (Rcompare (x - IZR m) (/2)) with l'.
now case l'.
rewrite <- Hl'.
rewrite plus_IZR.
rewrite <- (Rcompare_plus_r (- IZR m) x).
apply f_equal.
field.
rewrite Hm.
now apply Rlt_not_eq.
Qed.

Theorem inbetween_int_NE :
forall x m l,
inbetween_int m x l ->
ZnearestE x = cond_incr (round_N (negb (Z.even m)) l) m.
Proof. hammer_hook "Round" "Round.inbetween_int_NE".
intros x m l Hl.
now apply inbetween_int_N with (choice := fun x => negb (Z.even x)).
Qed.

Theorem inbetween_float_NE :
forall x m l,
let e := cexp beta fexp x in
inbetween_float beta m e x l ->
round beta fexp ZnearestE x = F2R (Float beta (cond_incr (round_N (negb (Z.even m)) l) m) e).
Proof. hammer_hook "Round" "Round.inbetween_float_NE".
apply inbetween_float_round with (choice := fun m l => cond_incr (round_N (negb (Z.even m)) l) m).
exact inbetween_int_NE.
Qed.

Theorem inbetween_int_NE_sign :
forall x m l,
inbetween_int m (Rabs x) l ->
ZnearestE x = cond_Zopp (Rlt_bool x 0) (cond_incr (round_N (negb (Z.even m)) l) m).
Proof. hammer_hook "Round" "Round.inbetween_int_NE_sign".
intros x m l Hl.
erewrite inbetween_int_N_sign with (choice := fun x => negb (Z.even x)).
2: eexact Hl.
apply f_equal.
case Rlt_bool.
rewrite Z.even_opp, Z.even_add.
now case (Z.even m).
apply refl_equal.
Qed.

Theorem inbetween_float_NE_sign :
forall x m l,
let e := cexp beta fexp x in
inbetween_float beta m e (Rabs x) l ->
round beta fexp ZnearestE x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (cond_incr (round_N (negb (Z.even m)) l) m)) e).
Proof. hammer_hook "Round" "Round.inbetween_float_NE_sign".
apply inbetween_float_round_sign with (choice := fun s m l => cond_incr (round_N (negb (Z.even m)) l) m).
exact inbetween_int_NE_sign.
Qed.

Theorem inbetween_int_NA :
forall x m l,
inbetween_int m x l ->
ZnearestA x = cond_incr (round_N (Zle_bool 0 m) l) m.
Proof. hammer_hook "Round" "Round.inbetween_int_NA".
intros x m l Hl.
now apply inbetween_int_N with (choice := fun x => Zle_bool 0 x).
Qed.

Theorem inbetween_float_NA :
forall x m l,
let e := cexp beta fexp x in
inbetween_float beta m e x l ->
round beta fexp ZnearestA x = F2R (Float beta (cond_incr (round_N (Zle_bool 0 m) l) m) e).
Proof. hammer_hook "Round" "Round.inbetween_float_NA".
apply inbetween_float_round with (choice := fun m l => cond_incr (round_N (Zle_bool 0 m) l) m).
exact inbetween_int_NA.
Qed.

Theorem inbetween_int_NA_sign :
forall x m l,
inbetween_int m (Rabs x) l ->
ZnearestA x = cond_Zopp (Rlt_bool x 0) (cond_incr (round_N true l) m).
Proof. hammer_hook "Round" "Round.inbetween_int_NA_sign".
intros x m l Hl.
erewrite inbetween_int_N_sign with (choice := Zle_bool 0).
2: eexact Hl.
apply f_equal.
assert (Hm: (0 <= m)%Z).
apply Zlt_succ_le.
apply lt_IZR.
apply Rle_lt_trans with (Rabs x).
apply Rabs_pos.
refine (proj2 (inbetween_bounds _ _ _ _ _ Hl)).
apply IZR_lt.
apply Zlt_succ.
rewrite Zle_bool_true with (1 := Hm).
rewrite Zle_bool_false.
now case Rlt_bool.
omega.
Qed.

Definition truncate_aux t k :=
let '(m, e, l) := t in
let p := Zpower beta k in
(Z.div m p, (e + k)%Z, new_location p (Zmod m p) l).

Theorem truncate_aux_comp :
forall t k1 k2,
(0 < k1)%Z ->
(0 < k2)%Z ->
truncate_aux t (k1 + k2) = truncate_aux (truncate_aux t k1) k2.
Proof. hammer_hook "Round" "Round.truncate_aux_comp".
intros ((m,e),l) k1 k2 Hk1 Hk2.
unfold truncate_aux.
destruct (inbetween_float_ex beta m e l) as (x,Hx).
assert (B1 := inbetween_float_new_location _ _ _ _ _ _ Hk1 Hx).
assert (Hk3: (0 < k1 + k2)%Z).
change Z0 with (0 + 0)%Z.
now apply Zplus_lt_compat.
assert (B3 := inbetween_float_new_location _ _ _ _ _ _ Hk3 Hx).
assert (B2 := inbetween_float_new_location _ _ _ _ _ _ Hk2 B1).
rewrite Zplus_assoc in B3.
destruct (inbetween_float_unique _ _ _ _ _ _ _ B2 B3).
now rewrite H, H0, Zplus_assoc.
Qed.

Definition truncate t :=
let '(m, e, l) := t in
let k := (fexp (Zdigits beta m + e) - e)%Z in
if Zlt_bool 0 k then truncate_aux t k
else t.

Theorem truncate_0 :
forall e l,
let '(m', e', l') := truncate (0, e, l)%Z in
m' = Z0.
Proof. hammer_hook "Round" "Round.truncate_0".
intros e l.
unfold truncate.
case Zlt_bool.
simpl.
apply Zdiv_0_l.
apply refl_equal.
Qed.

Theorem generic_format_truncate :
forall m e l,
(0 <= m)%Z ->
let '(m', e', l') := truncate (m, e, l) in
format (F2R (Float beta m' e')).
Proof. hammer_hook "Round" "Round.generic_format_truncate".
intros m e l Hm.
unfold truncate.
set (k := (fexp (Zdigits beta m + e) - e)%Z).
case Zlt_bool_spec ; intros Hk.

unfold truncate_aux.
apply generic_format_F2R.
intros Hd.
unfold cexp.
rewrite mag_F2R_Zdigits with (1 := Hd).
rewrite Zdigits_div_Zpower with (1 := Hm).
replace (Zdigits beta m - k + (e + k))%Z with (Zdigits beta m + e)%Z by ring.
unfold k.
ring_simplify.
apply Z.le_refl.
split.
now apply Zlt_le_weak.
apply Znot_gt_le.
contradict Hd.
apply Zdiv_small.
apply conj with (1 := Hm).
rewrite <- Z.abs_eq with (1 := Hm).
apply Zpower_gt_Zdigits.
apply Zlt_le_weak.
now apply Z.gt_lt.

destruct (Zle_lt_or_eq _ _ Hm) as [Hm'|Hm'].
apply generic_format_F2R.
unfold cexp.
rewrite mag_F2R_Zdigits.
2: now apply Zgt_not_eq.
unfold k in Hk. clear -Hk.
omega.
rewrite <- Hm', F2R_0.
apply generic_format_0.
Qed.

Theorem truncate_correct_format :
forall m e,
m <> Z0 ->
let x := F2R (Float beta m e) in
generic_format beta fexp x ->
(e <= fexp (Zdigits beta m + e))%Z ->
let '(m', e', l') := truncate (m, e, loc_Exact) in
x = F2R (Float beta m' e') /\ e' = cexp beta fexp x.
Proof. hammer_hook "Round" "Round.truncate_correct_format".
intros m e Hm x Fx He.
assert (Hc: cexp beta fexp x = fexp (Zdigits beta m + e)).
unfold cexp, x.
now rewrite mag_F2R_Zdigits.
unfold truncate.
rewrite <- Hc.
set (k := (cexp beta fexp x - e)%Z).
case Zlt_bool_spec ; intros Hk.

unfold truncate_aux.
rewrite Fx at 1.
assert (H: (e + k)%Z = cexp beta fexp x).
unfold k. ring.
refine (conj _ H).
rewrite <- H.
apply F2R_eq.
replace (scaled_mantissa beta fexp x) with (IZR (Zfloor (scaled_mantissa beta fexp x))).
rewrite Ztrunc_IZR.
unfold scaled_mantissa.
rewrite <- H.
unfold x, F2R. simpl.
rewrite Rmult_assoc, <- bpow_plus.
ring_simplify (e + - (e + k))%Z.
clear -Hm Hk.
destruct k as [|k|k] ; try easy.
simpl.
apply Zfloor_div.
intros H.
generalize (Zpower_pos_gt_0 beta k) (Zle_bool_imp_le _ _ (radix_prop beta)).
omega.
rewrite scaled_mantissa_generic with (1 := Fx).
now rewrite Zfloor_IZR.

split.
apply refl_equal.
unfold k in Hk.
omega.
Qed.

Theorem truncate_correct_partial' :
forall x m e l,
(0 < x)%R ->
inbetween_float beta m e x l ->
(e <= cexp beta fexp x)%Z ->
let '(m', e', l') := truncate (m, e, l) in
inbetween_float beta m' e' x l' /\ e' = cexp beta fexp x.
Proof. hammer_hook "Round" "Round.truncate_correct_partial'".
intros x m e l Hx H1 H2.
unfold truncate.
rewrite <- cexp_inbetween_float with (1 := Hx) (2 := H1) by now left.
generalize (Zlt_cases 0 (cexp beta fexp x - e)).
destruct Zlt_bool ; intros Hk.
- split.
now apply inbetween_float_new_location.
ring.
- apply (conj H1).
omega.
Qed.

Theorem truncate_correct_partial :
forall x m e l,
(0 < x)%R ->
inbetween_float beta m e x l ->
(e <= fexp (Zdigits beta m + e))%Z ->
let '(m', e', l') := truncate (m, e, l) in
inbetween_float beta m' e' x l' /\ e' = cexp beta fexp x.
Proof. hammer_hook "Round" "Round.truncate_correct_partial".
intros x m e l Hx H1 H2.
apply truncate_correct_partial' with (1 := Hx) (2 := H1).
rewrite cexp_inbetween_float with (1 := Hx) (2 := H1).
exact H2.
now right.
Qed.

Theorem truncate_correct' :
forall x m e l,
(0 <= x)%R ->
inbetween_float beta m e x l ->
(e <= cexp beta fexp x)%Z \/ l = loc_Exact ->
let '(m', e', l') := truncate (m, e, l) in
inbetween_float beta m' e' x l' /\
(e' = cexp beta fexp x \/ (l' = loc_Exact /\ format x)).
Proof. hammer_hook "Round" "Round.truncate_correct'".
intros x m e l [Hx|Hx] H1 H2.
- destruct (Zle_or_lt e (fexp (Zdigits beta m + e))) as [H3|H3].
+ generalize (truncate_correct_partial x m e l Hx H1 H3).
destruct (truncate (m, e, l)) as [[m' e'] l'].
intros [H4 H5].
apply (conj H4).
now left.
+ destruct H2 as [H2|H2].
generalize (truncate_correct_partial' x m e l Hx H1 H2).
destruct (truncate (m, e, l)) as [[m' e'] l'].
intros [H4 H5].
apply (conj H4).
now left.
rewrite H2 in H1 |- *.
simpl.
generalize (Zlt_cases 0 (fexp (Zdigits beta m + e) - e)).
destruct Zlt_bool.
intros H.
apply False_ind.
omega.
intros _.
apply (conj H1).
right.
repeat split.
inversion_clear H1.
rewrite H.
apply generic_format_F2R.
intros Zm.
unfold cexp.
rewrite mag_F2R_Zdigits with (1 := Zm).
now apply Zlt_le_weak.
- assert (Hm: m = 0%Z).
cut (m <= 0 < m + 1)%Z. omega.
assert (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R as Hx'.
apply inbetween_float_bounds with (1 := H1).
rewrite <- Hx in Hx'.
split.
apply le_0_F2R with (1 := proj1 Hx').
apply gt_0_F2R with (1 := proj2 Hx').
rewrite Hm, <- Hx in H1 |- *.
clear -H1.
destruct H1 as [_ | l' [H _] _].
+ assert (exists e', truncate (Z0, e, loc_Exact) = (Z0, e', loc_Exact)).
unfold truncate, truncate_aux.
case Zlt_bool.
rewrite Zdiv_0_l, Zmod_0_l.
eexists.
apply f_equal.
unfold new_location.
now case Z.even.
now eexists.
destruct H as [e' H].
rewrite H.
split.
constructor.
apply eq_sym, F2R_0.
right.
repeat split.
apply generic_format_0.
+ rewrite F2R_0 in H.
elim Rlt_irrefl with (1 := H).
Qed.

Theorem truncate_correct :
forall x m e l,
(0 <= x)%R ->
inbetween_float beta m e x l ->
(e <= fexp (Zdigits beta m + e))%Z \/ l = loc_Exact ->
let '(m', e', l') := truncate (m, e, l) in
inbetween_float beta m' e' x l' /\
(e' = cexp beta fexp x \/ (l' = loc_Exact /\ format x)).
Proof. hammer_hook "Round" "Round.truncate_correct".
intros x m e l Hx H1 H2.
apply truncate_correct' with (1 := Hx) (2 := H1).
now apply cexp_inbetween_float_loc_Exact with (2 := H1).
Qed.

Section round_dir.

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

Variable choice : Z -> location -> Z.
Hypothesis inbetween_int_valid :
forall x m l,
inbetween_int m x l ->
rnd x = choice m l.

Theorem round_any_correct :
forall x m e l,
inbetween_float beta m e x l ->
(e = cexp beta fexp x \/ (l = loc_Exact /\ format x)) ->
round beta fexp rnd x = F2R (Float beta (choice m l) e).
Proof with auto with typeclass_instances. hammer_hook "Round" "Round.round_any_correct".
intros x m e l Hin [He|(Hl,Hf)].
rewrite He in Hin |- *.
apply inbetween_float_round with (2 := Hin).
exact inbetween_int_valid.
rewrite Hl in Hin.
inversion_clear Hin.
rewrite Hl.
replace (choice m loc_Exact) with m.
rewrite <- H.
apply round_generic...
rewrite <- (Zrnd_IZR rnd m) at 1.
apply inbetween_int_valid.
now constructor.
Qed.

Theorem round_trunc_any_correct :
forall x m e l,
(0 <= x)%R ->
inbetween_float beta m e x l ->
(e <= fexp (Zdigits beta m + e))%Z \/ l = loc_Exact ->
round beta fexp rnd x = let '(m', e', l') := truncate (m, e, l) in F2R (Float beta (choice m' l') e').
Proof. hammer_hook "Round" "Round.round_trunc_any_correct".
intros x m e l Hx Hl He.
generalize (truncate_correct x m e l Hx Hl He).
destruct (truncate (m, e, l)) as ((m', e'), l').
intros (H1, H2).
now apply round_any_correct.
Qed.

Theorem round_trunc_any_correct' :
forall x m e l,
(0 <= x)%R ->
inbetween_float beta m e x l ->
(e <= cexp beta fexp x)%Z \/ l = loc_Exact ->
round beta fexp rnd x = let '(m', e', l') := truncate (m, e, l) in F2R (Float beta (choice m' l') e').
Proof. hammer_hook "Round" "Round.round_trunc_any_correct'".
intros x m e l Hx Hl He.
generalize (truncate_correct' x m e l Hx Hl He).
destruct (truncate (m, e, l)) as [[m' e'] l'].
intros [H1 H2].
now apply round_any_correct.
Qed.

End round_dir.

Section round_dir_sign.

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

Variable choice : bool -> Z -> location -> Z.
Hypothesis inbetween_int_valid :
forall x m l,
inbetween_int m (Rabs x) l ->
rnd x = cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m l).

Theorem round_sign_any_correct :
forall x m e l,
inbetween_float beta m e (Rabs x) l ->
(e = cexp beta fexp x \/ (l = loc_Exact /\ format x)) ->
round beta fexp rnd x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m l)) e).
Proof with auto with typeclass_instances. hammer_hook "Round" "Round.round_sign_any_correct".
intros x m e l Hin [He|(Hl,Hf)].
rewrite He in Hin |- *.
apply inbetween_float_round_sign with (2 := Hin).
exact inbetween_int_valid.
rewrite Hl in Hin.
inversion_clear Hin.
rewrite Hl.
replace (choice (Rlt_bool x 0) m loc_Exact) with m.

unfold Rabs in H.
destruct (Rcase_abs x) as [Zx|Zx].
rewrite Rlt_bool_true with (1 := Zx).
simpl.
rewrite F2R_Zopp.
rewrite <- H, Ropp_involutive.
apply round_generic...
rewrite Rlt_bool_false.
simpl.
rewrite <- H.
now apply round_generic.
now apply Rge_le.

destruct (Rlt_bool_spec x 0) as [Zx|Zx].

apply Z.opp_inj.
change (- m = cond_Zopp true (choice true m loc_Exact))%Z.
rewrite <- (Zrnd_IZR rnd (-m)) at 1.
assert (IZR (-m) < 0)%R.
rewrite opp_IZR.
apply Ropp_lt_gt_0_contravar.
apply IZR_lt.
apply gt_0_F2R with beta e.
rewrite <- H.
apply Rabs_pos_lt.
now apply Rlt_not_eq.
rewrite <- Rlt_bool_true with (1 := H0).
apply inbetween_int_valid.
constructor.
rewrite Rabs_left with (1 := H0).
rewrite opp_IZR.
apply Ropp_involutive.

change (m = cond_Zopp false (choice false m loc_Exact))%Z.
rewrite <- (Zrnd_IZR rnd m) at 1.
assert (0 <= IZR m)%R.
apply IZR_le.
apply ge_0_F2R with beta e.
rewrite <- H.
apply Rabs_pos.
rewrite <- Rlt_bool_false with (1 := H0).
apply inbetween_int_valid.
constructor.
now apply Rabs_pos_eq.
Qed.

Theorem round_trunc_sign_any_correct' :
forall x m e l,
inbetween_float beta m e (Rabs x) l ->
(e <= cexp beta fexp x)%Z \/ l = loc_Exact ->
round beta fexp rnd x = let '(m', e', l') := truncate (m, e, l) in F2R (Float beta (cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m' l')) e').
Proof. hammer_hook "Round" "Round.round_trunc_sign_any_correct'".
intros x m e l Hl He.
rewrite <- cexp_abs in He.
generalize (truncate_correct' (Rabs x) m e l (Rabs_pos _) Hl He).
destruct (truncate (m, e, l)) as [[m' e'] l'].
intros [H1 H2].
apply round_sign_any_correct.
exact H1.
destruct H2 as [H2|[H2 H3]].
left.
now rewrite <- cexp_abs.
right.
apply (conj H2).
now apply generic_format_abs_inv.
Qed.

Theorem round_trunc_sign_any_correct :
forall x m e l,
inbetween_float beta m e (Rabs x) l ->
(e <= fexp (Zdigits beta m + e))%Z \/ l = loc_Exact ->
round beta fexp rnd x = let '(m', e', l') := truncate (m, e, l) in F2R (Float beta (cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m' l')) e').
Proof. hammer_hook "Round" "Round.round_trunc_sign_any_correct".
intros x m e l Hl He.
apply round_trunc_sign_any_correct' with (1 := Hl).
rewrite <- cexp_abs.
apply cexp_inbetween_float_loc_Exact with (2 := Hl) (3 := He).
apply Rabs_pos.
Qed.

End round_dir_sign.

Definition round_DN_correct :=
round_any_correct _ (fun m _ => m) inbetween_int_DN.

Definition round_trunc_DN_correct :=
round_trunc_any_correct _ (fun m _ => m) inbetween_int_DN.

Definition round_trunc_DN_correct' :=
round_trunc_any_correct' _ (fun m _ => m) inbetween_int_DN.

Definition round_sign_DN_correct :=
round_sign_any_correct _ (fun s m l => cond_incr (round_sign_DN s l) m) inbetween_int_DN_sign.

Definition round_trunc_sign_DN_correct :=
round_trunc_sign_any_correct _ (fun s m l => cond_incr (round_sign_DN s l) m) inbetween_int_DN_sign.

Definition round_trunc_sign_DN_correct' :=
round_trunc_sign_any_correct' _ (fun s m l => cond_incr (round_sign_DN s l) m) inbetween_int_DN_sign.

Definition round_UP_correct :=
round_any_correct _ (fun m l => cond_incr (round_UP l) m) inbetween_int_UP.

Definition round_trunc_UP_correct :=
round_trunc_any_correct _ (fun m l => cond_incr (round_UP l) m) inbetween_int_UP.

Definition round_trunc_UP_correct' :=
round_trunc_any_correct' _ (fun m l => cond_incr (round_UP l) m) inbetween_int_UP.

Definition round_sign_UP_correct :=
round_sign_any_correct _ (fun s m l => cond_incr (round_sign_UP s l) m) inbetween_int_UP_sign.

Definition round_trunc_sign_UP_correct :=
round_trunc_sign_any_correct _ (fun s m l => cond_incr (round_sign_UP s l) m) inbetween_int_UP_sign.

Definition round_trunc_sign_UP_correct' :=
round_trunc_sign_any_correct' _ (fun s m l => cond_incr (round_sign_UP s l) m) inbetween_int_UP_sign.

Definition round_ZR_correct :=
round_any_correct _ (fun m l => cond_incr (round_ZR (Zlt_bool m 0) l) m) inbetween_int_ZR.

Definition round_trunc_ZR_correct :=
round_trunc_any_correct _ (fun m l => cond_incr (round_ZR (Zlt_bool m 0) l) m) inbetween_int_ZR.

Definition round_trunc_ZR_correct' :=
round_trunc_any_correct' _ (fun m l => cond_incr (round_ZR (Zlt_bool m 0) l) m) inbetween_int_ZR.

Definition round_sign_ZR_correct :=
round_sign_any_correct _ (fun s m l => m) inbetween_int_ZR_sign.

Definition round_trunc_sign_ZR_correct :=
round_trunc_sign_any_correct _ (fun s m l => m) inbetween_int_ZR_sign.

Definition round_trunc_sign_ZR_correct' :=
round_trunc_sign_any_correct' _ (fun s m l => m) inbetween_int_ZR_sign.

Definition round_NE_correct :=
round_any_correct _ (fun m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE.

Definition round_trunc_NE_correct :=
round_trunc_any_correct _ (fun m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE.

Definition round_trunc_NE_correct' :=
round_trunc_any_correct' _ (fun m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE.

Definition round_sign_NE_correct :=
round_sign_any_correct _ (fun s m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE_sign.

Definition round_trunc_sign_NE_correct :=
round_trunc_sign_any_correct _ (fun s m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE_sign.

Definition round_trunc_sign_NE_correct' :=
round_trunc_sign_any_correct' _ (fun s m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE_sign.

Definition round_NA_correct :=
round_any_correct _ (fun m l => cond_incr (round_N (Zle_bool 0 m) l) m) inbetween_int_NA.

Definition round_trunc_NA_correct :=
round_trunc_any_correct _ (fun m l => cond_incr (round_N (Zle_bool 0 m) l) m) inbetween_int_NA.

Definition round_trunc_NA_correct' :=
round_trunc_any_correct' _ (fun m l => cond_incr (round_N (Zle_bool 0 m) l) m) inbetween_int_NA.

Definition round_sign_NA_correct :=
round_sign_any_correct _ (fun s m l => cond_incr (round_N true l) m) inbetween_int_NA_sign.

Definition round_trunc_sign_NA_correct :=
round_trunc_sign_any_correct _ (fun s m l => cond_incr (round_N true l) m) inbetween_int_NA_sign.

Definition round_trunc_sign_NA_correct' :=
round_trunc_sign_any_correct' _ (fun s m l => cond_incr (round_N true l) m) inbetween_int_NA_sign.

End Fcalc_round_fexp.

Variable emin : Z.

Definition truncate_FIX t :=
let '(m, e, l) := t in
let k := (emin - e)%Z in
if Zlt_bool 0 k then
let p := Zpower beta k in
(Z.div m p, (e + k)%Z, new_location p (Zmod m p) l)
else t.

Theorem truncate_FIX_correct :
forall x m e l,
inbetween_float beta m e x l ->
(e <= emin)%Z \/ l = loc_Exact ->
let '(m', e', l') := truncate_FIX (m, e, l) in
inbetween_float beta m' e' x l' /\
(e' = cexp beta (FIX_exp emin) x \/ (l' = loc_Exact /\ generic_format beta (FIX_exp emin) x)).
Proof. hammer_hook "Round" "Round.truncate_FIX_correct".
intros x m e l H1 H2.
unfold truncate_FIX.
set (k := (emin - e)%Z).
set (p := Zpower beta k).
unfold cexp, FIX_exp.
generalize (Zlt_cases 0 k).
case (Zlt_bool 0 k) ; intros Hk.

split.
now apply inbetween_float_new_location.
clear H2.
left.
unfold k.
ring.

split.
exact H1.
unfold k in Hk.
destruct H2 as [H2|H2].
left.
omega.
right.
split.
exact H2.
rewrite H2 in H1.
inversion_clear H1.
rewrite H.
apply generic_format_F2R.
unfold cexp.
omega.
Qed.

End Fcalc_round.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Lia.

From Undecidability.Shared.Libs.DLW
  Require Import utils pos vec subcode sss.

From Undecidability.MinskyMachines.MMenv
  Require Import env mme_defs.

Set Implicit Arguments.

Tactic Notation "rew" "length" := autorewrite with length_db.

Local Notation "P // s ->> t" := (sss_compute (mm_sss_env eq_nat_dec) P s t).
Local Notation "P // s -+> t" := (sss_progress (mm_sss_env eq_nat_dec) P s t).
Local Notation "P // s -[ k ]-> t" := (sss_steps (mm_sss_env eq_nat_dec) P k s t).
Local Notation "P // s ↓" := (sss_terminates (mm_sss_env eq_nat_dec ) P s).

Local Notation " e ⇢ x " := (@get_env _ _ e x).
Local Notation " e ⦃  x ⇠ v ⦄ " := (@set_env _ _ eq_nat_dec e x v).
Local Notation "x '⋈' y" := (forall i : nat, x⇢i = y⇢i :> nat) (at level 70, no associativity).

Section mm_env_utils.

  Ltac dest x y := destruct (eq_nat_dec x y) as [ | ]; [ subst x | ]; rew env.

  Section mm_transfert.

    Variables (src dst zero : nat).

    Hypothesis (Hsd : src <> dst) (Hsz : src <> zero) (Hdz : dst <> zero).

    Definition mm_transfert i := DEC src (3+i) :: INC dst :: DEC zero i :: nil.

    Fact mm_transfert_length i : length (mm_transfert i) = 3.
    Proof. reflexivity. Qed.

    Let mm_transfert_spec i e k x :
           e⇢src = k
        -> e⇢dst = x
        -> e⇢zero = 0
        -> exists e', e' ⋈  e⦃src⇠0⦄⦃dst⇠k+x⦄
                   /\ (i,mm_transfert i) // (i,e) -+> (3+i,e').
    Proof.
      unfold mm_transfert.
      revert e x.
      induction k as [ | k IHk ]; intros e x H1 H2 H3.
      + exists e; split.
        * intros j; dest j src; dest j dst.
        * mm env DEC zero with src (3+i).
          mm env stop; f_equal; auto.
      + destruct IHk with (e := e⦃src⇠k⦄⦃dst⇠1+x⦄) (x := 1+x)
          as (e' & H4 & H5); rew env.
        exists e'; split.
        * intros j; rewrite H4.
          dest j dst; try lia.
          dest j src.
        * mm env DEC S with src (3+i) k.
          mm env INC with dst.
          mm env DEC zero with zero i; rew env.
          rewrite H2.
          apply sss_progress_compute; auto.
    Qed.

    Fact mm_transfert_progress i e :
           e⇢dst = 0
        -> e⇢zero = 0
        -> exists e', e' ⋈  e⦃src⇠0⦄⦃dst⇠(e⇢src)⦄
                  /\ (i,mm_transfert i) // (i,e) -+> (3+i,e').
    Proof using Hsz Hsd Hdz.
      intros H1 H2.
      destruct mm_transfert_spec with (e := e) (x := 0) (i := i) (k := e⇢src)
        as (e' & H3 & H4); auto.
      exists e'; split; auto.
      intros j; rewrite H3, Nat.add_comm; auto.
    Qed.

  End mm_transfert.

  Hint Rewrite mm_transfert_length : length_db.

  Section mm_erase.

    Variables (dst zero : nat).

    Hypothesis (Hdz : dst <> zero).

    Definition mm_erase i := DEC dst (2+i) :: DEC zero i :: nil.

    Fact mm_erase_length i : length (mm_erase i) = 2.
    Proof. reflexivity. Qed.

    Let mm_erase_spec i e x :
           e⇢dst = x
        -> e⇢zero = 0
        -> exists e', e' ⋈  e⦃dst⇠0⦄
                   /\ (i,mm_erase i) // (i,e) -+> (2+i,e').
    Proof.
      unfold mm_erase.
      revert e.
      induction x as [ | x IHx ]; intros e H1 H2.
      + exists e; split.
        * intros j; dest j dst.
        * mm env DEC zero with dst (2+i).
          mm env stop; f_equal; auto.
      + destruct IHx with (e := e⦃dst⇠x⦄)
          as (e' & H4 & H5); rew env.
        exists e'; split.
        * intros j; rewrite H4; dest j dst.
        * mm env DEC S with dst (2+i) x.
          mm env DEC zero with zero i; rew env.
          apply sss_progress_compute; auto.
    Qed.

    Fact mm_erase_progress i e :
           e⇢zero = 0
        -> exists e', e' ⋈  e⦃dst⇠0⦄
                  /\ (i,mm_erase i) // (i,e) -+> (2+i,e').
    Proof using Hdz.
      intros H1.
      destruct mm_erase_spec with (e := e) (i := i) (x := e⇢dst)
        as (e' & H3 & H4); auto.
      exists e'; split; auto.
    Qed.

  End mm_erase.

  Hint Rewrite mm_erase_length : length_db.

  Opaque mm_erase.

  Section mm_list_erase.

    Variable (zero : nat).

    Fixpoint mm_list_erase ll i :=
      match ll with
        | nil     => nil
        | dst::ll => mm_erase dst zero i ++ mm_list_erase ll (2+i)
      end.

    Fact mm_list_erase_length ll i : length (mm_list_erase ll i) = 2*length ll.
    Proof.
      revert i; induction ll as [ | dst ll IH ]; simpl; intros i; rew length; auto.
      rewrite IH; ring.
    Qed.

    Fact mm_list_erase_compute ll i e :
            Forall (fun x => x <> zero) ll
         -> e⇢zero = 0
         -> exists e', (forall x,   In x ll -> e'⇢x = 0)
                    /\ (forall x, ~ In x ll -> e'⇢x = e⇢x)
                    /\ (i,mm_list_erase ll i) // (i,e) ->> (2*length ll+i,e').
    Proof.
      intros H; revert H i e.
      induction 1 as [ | dst ll H1 H2 IH2 ]; intros i e H3.
      + simpl; exists e; repeat split; try tauto; mm env stop.
      + destruct mm_erase_progress with (dst := dst) (zero := zero) (i := i) (e := e)
          as (e1 & H4 & H5); auto.
        destruct IH2 with (i := 2+i) (e := e1) as (e2 & H6 & H7 & H8).
        { rewrite H4; rew env. }
        exists e2; split; [ | split ].
        * intros x [ H | H ]; subst; auto.
          destruct in_dec with (1 := eq_nat_dec) (a := x) (l := ll) as [ H9 | H9 ]; auto.
          rewrite H7; auto; rewrite H4; rew env.
        * simpl; intros x Hx.
          rewrite H7, H4; try tauto.
          dest x dst; destruct Hx; auto.
        * apply sss_compute_trans with (2+i,e1).
          - apply sss_progress_compute.
            simpl; revert H5; apply subcode_sss_progress; auto.
          - replace (2*length (dst::ll)+i) with (2*length ll+(2+i)) by (rew length; lia).
            revert H8; simpl; apply subcode_sss_compute; auto.
    Qed.

  End mm_list_erase.

  Hint Rewrite mm_list_erase_length : length_db.

  Section mm_multi_erase.

    Variables (dst zero k : nat).

    Definition mm_multi_erase := mm_list_erase zero (list_an dst k).

    Fact mm_multi_erase_length i : length (mm_multi_erase i) = 2*k.
    Proof. unfold mm_multi_erase; rew length; auto. Qed.

    Hypothesis (Hdz : dst+k <= zero).

    Fact mm_multi_erase_compute i e :
                    e⇢zero = 0
      -> exists e', (forall j, dst <= j < k+dst -> e'⇢j = 0)
                 /\ (forall j, ~ dst <= j < k+dst -> e'⇢j = e⇢j)
                 /\ (i,mm_multi_erase i) // (i,e) ->> (2*k+i,e').
    Proof using Hdz.
      intros H; unfold mm_multi_erase.
      destruct mm_list_erase_compute
        with (zero := zero) (ll := list_an dst k) (i := i) (e := e)
        as (e' & H1 & H2 & H3); auto.
      * rewrite Forall_forall; intros j; rewrite list_an_spec; intros; lia.
      * rew length in H3; exists e'; msplit 2; auto.
        + intros; apply H1, list_an_spec; lia.
        + intros; apply H2; rewrite list_an_spec; lia.
    Qed.

  End mm_multi_erase.

  Hint Rewrite mm_multi_erase_length : length_db.

  Section mm_dup.

    Variables (src dst tmp zero : nat).

    Hypothesis (Hsd : src <> dst) (Hst : src <> tmp) (Hsz : src <> zero)
               (Hdt : dst <> tmp) (Hdz : dst <> zero)
               (Htz : tmp <> zero).

    Definition mm_dup i := DEC src (4+i) :: INC dst :: INC tmp :: DEC zero i :: nil.

    Fact mm_dup_length i : length (mm_dup i) = 4.
    Proof. reflexivity. Qed.

    Let mm_dup_spec i e k x y :
           e⇢src = k
        -> e⇢dst = x
        -> e⇢tmp = y
        -> e⇢zero = 0
        -> exists e', e' ⋈  e⦃src⇠0⦄⦃dst⇠k+x⦄⦃tmp⇠k+y⦄
                   /\ (i,mm_dup i) // (i,e) -+> (4+i,e').
    Proof.
      unfold mm_dup.
      revert e x y.
      induction k as [ | k IHk ]; intros e x y H1 H2 H3 H4.
      + exists e; split.
        * intros j; dest j src; dest j dst; dest j tmp.
        * mm env DEC zero with src (4+i).
          mm env stop; f_equal; auto.
      + destruct IHk with (e := e⦃src⇠k⦄⦃dst⇠1+x⦄⦃tmp⇠1+y⦄) (x := 1+x) (y := 1+y)
          as (e' & H5 & H6); rew env.
        exists e'; split.
        * intros j; rewrite H5.
          dest j tmp; try lia.
          dest j dst; try lia.
          dest j src.
        * mm env DEC S with src (4+i) k.
          mm env INC with dst.
          mm env INC with tmp.
          mm env DEC zero with zero i; rew env.
          rewrite H2, H3.
          apply sss_progress_compute; auto.
    Qed.

    Fact mm_dup_progress i e :
           e⇢dst = 0
        -> e⇢tmp = 0
        -> e⇢zero = 0
        -> exists e', e' ⋈  e⦃src⇠0⦄⦃dst⇠(e⇢src)⦄⦃tmp⇠(e⇢src)⦄
                  /\ (i,mm_dup i) // (i,e) -+> (4+i,e').
    Proof using Htz Hsz Hst Hsd Hdz Hdt.
      intros H1 H2 H3.
      destruct mm_dup_spec with (e := e) (x := 0) (y := 0) (i := i) (k := e⇢src)
        as (e' & H4 & H5); auto.
      exists e'; split; auto.
      intros j; rewrite H4, Nat.add_comm; auto.
    Qed.

  End mm_dup.

  Hint Rewrite mm_dup_length : length_db.

  Section mm_copy.

    Variables (src dst tmp zero : nat).

    Hypothesis (Hsd : src <> dst) (Hst : src <> tmp) (Hsz : src <> zero)
               (Hdt : dst <> tmp) (Hdz : dst <> zero)
               (Htz : tmp <> zero).

    Definition mm_copy i := mm_erase dst zero i
                         ++ mm_transfert src tmp zero (2+i)
                         ++ mm_dup tmp src dst zero (5+i).

    Fact mm_copy_length i : length (mm_copy i) = 9.
    Proof. reflexivity. Qed.

    Fact mm_copy_progress i e :
           e⇢tmp = 0
        -> e⇢zero = 0
        -> exists e', e' ⋈  e⦃dst⇠(e⇢src)⦄
                  /\ (i,mm_copy i) // (i,e) -+> (9+i,e').
    Proof using Htz Hsz Hst Hsd Hdz Hdt.
      intros H0 H1.
      unfold mm_copy.
      destruct mm_erase_progress with (1 := Hdz) (i := i) (e := e)
        as (e0 & H2 & H3); auto.
      destruct mm_transfert_progress
        with (src := src) (dst := tmp) (zero := zero) (i := 2+i) (e := e0)
        as (e1 & H4 & H5); auto.
      1,2: rewrite H2; rew env.
      destruct mm_dup_progress
        with (src := tmp) (dst := src) (tmp := dst) (zero := zero) (i := 5+i) (e := e1)
        as (e2 & H6 & H7); auto.
      1,2,3: rewrite H4; rew env; rewrite H2; rew env.
      exists e2; split.
      * intros j.
        rewrite H6; dest j dst.
        - rewrite H4; rew env.
          rewrite H2; rew env.
        - dest j src.
          + rewrite H4; rew env.
            rewrite H2; rew env.
          + dest j tmp.
            rewrite H4; rew env.
            rewrite H2; rew env.
      * apply sss_progress_trans with (2+i,e0).
        { revert H3; apply subcode_sss_progress; auto. }
        apply sss_progress_trans with (5+i,e1).
        { revert H5; apply subcode_sss_progress; auto. }
        { revert H7; apply subcode_sss_progress; auto. }
    Qed.

  End mm_copy.

  Hint Rewrite mm_copy_length : length_db.

  Section mm_multi_copy.

    Variables (tmp zero : nat).

    Fixpoint mm_multi_copy k src dst i :=
      match k with
        | 0   => nil
        | S k => mm_copy src dst tmp zero i ++ mm_multi_copy k (S src) (S dst) (9+i)
      end.

    Fact mm_multi_copy_length k src dst i : length (mm_multi_copy k src dst i) = 9*k.
    Proof.
      revert src dst i; induction k as [ | k IHk ]; intros src dst i; simpl; auto.
      rew length; rewrite IHk; lia.
    Qed.

    Fact mm_multi_copy_compute k src dst i e :
            k+src <= dst
         -> k+dst <= tmp
         -> k+dst <= zero
         -> tmp <> zero
         -> e⇢tmp = 0
         -> e⇢zero = 0
         -> exists e', (forall j, j < k -> e'⇢(j+dst) = e⇢(j+src))
                    /\ (forall j, ~ dst <= j < k+dst -> e'⇢j = e⇢j)
                    /\ (i,mm_multi_copy k src dst i) // (i,e) ->> (9*k+i,e').
    Proof.
      revert src dst i e; induction k as [ | k IHk ]; intros src dst i e; intros H1 H2 H3 H4 H5 H6.
      + exists e; split; [ | split ]; try (intros; lia).
        mm env stop.
      + destruct (@mm_copy_progress src dst tmp zero) with (i := i) (e := e)
          as (e1 & G1 & G2); try lia.
        destruct (IHk (S src) (S dst) (9+i)) with (e := e1)
          as (e2 & G3 & G4 & G5); try lia.
        { rewrite G1; assert (dst <> tmp); try lia; rew env. }
        { rewrite G1; assert (dst <> zero); try lia; rew env. }
        exists e2; split; [ | split ].
        * intros [ | j ] Hj.
          - rewrite G4; try lia; simpl; rewrite G1; rew env.
          - replace (S j + dst) with (j+S dst) by lia.
            replace (S j + src) with (j+S src) by lia.
            rewrite G3; try lia.
            rewrite G1.
            assert (dst <> j+S src) by lia; rew env.
        * intros j Hj.
          rewrite G4; try lia.
          rewrite G1.
          assert (j <> dst) by lia; rew env.
        * unfold mm_multi_copy; fold mm_multi_copy.
          apply sss_compute_trans with (9+i,e1).
          - apply sss_progress_compute.
            revert G2; apply subcode_sss_progress; auto.
          - replace (9*S k+i) with (9*k+(9+i)) by lia.
            revert G5; apply subcode_sss_compute.
            subcode_tac; rewrite <- app_nil_end; auto.
    Qed.

  End mm_multi_copy.

  Hint Rewrite mm_multi_copy_length : length_db.

  Section mm_set.

    Variables (dst zero : nat) (Hdz : dst <> zero).

    Let mm_incs : nat -> list (mm_instr nat) :=
      fix loop n := match n with
        | 0   => nil
        | S n => INC dst :: loop n
      end.

    Let mm_incs_length n : length (mm_incs n) = n.
    Proof. induction n; simpl; f_equal; auto. Qed.

    Let mm_incs_spec i e n :
      exists e', e' ⋈  e⦃dst⇠(n+(e⇢dst))⦄
              /\ (i,mm_incs n) // (i,e) ->> (n+i,e').
    Proof.
      revert i e; induction n as [ | n IHn ]; intros i e; simpl.
      + exists e; split.
        * intros j; dest j dst.
        * mm env stop.
      + destruct (IHn (1+i) (e⦃dst⇠1+(e⇢dst)⦄)) as (e' & H1 & H2).
        exists e'; split.
        * intros j; rewrite H1; dest j dst.
        * mm env INC with dst.
          replace (S (n+i)) with (n+(1+i)) by lia.
          revert H2; apply subcode_sss_compute.
          subcode_tac; simpl; rewrite <- app_nil_end; auto.
    Qed.

    Definition mm_set n i := mm_erase dst zero i ++ mm_incs n.

    Fact mm_set_length n i : length (mm_set n i) = 2+n.
    Proof.
      unfold mm_set; rew length; rewrite mm_incs_length; auto.
    Qed.

    Fact mm_set_progress n i e :
            e⇢zero = 0
         -> exists e', e' ⋈  e⦃dst⇠n⦄
                   /\ (i,mm_set n i) // (i,e) -+> (2+n+i,e').
    Proof using Hdz.
      intros H; unfold mm_set.
      destruct (@mm_erase_progress _ _ Hdz i _ H) as (e1 & H1 & H2).
      destruct (mm_incs_spec (2+i) e1 n) as (e2 & H3 & H4).
      exists e2; split.
      + intros j; rewrite H3, H1.
        dest j dst; rewrite H1; rew env.
      + apply sss_progress_compute_trans with (2+i,e1).
        * revert H2; apply subcode_sss_progress; auto.
        * replace (2+n+i) with (n+(2+i)) by lia.
          revert H4; apply subcode_sss_compute; auto.
    Qed.

  End mm_set.

End mm_env_utils.

#[export] Hint Rewrite mm_set_length mm_transfert_length mm_erase_length
             mm_list_erase_length mm_multi_erase_length
             mm_dup_length mm_copy_length mm_multi_copy_length
             mm_set_length : length_db.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Logic.Decidable.
Require Import Coq.Lists.List.
Require Import Optimizer.Util.Tactics.

Section Sumbool.
  Lemma dec_and A B : {A} + {~ A} -> {B} + {~ B} ->
                      {A /\ B} + {~ (A /\ B)}.
  Proof. tauto. Qed.
  Lemma dec_imp (A B : Prop) :
    {A} + {~ A} ->
    {B} + {~ B} ->
    {(A -> B)} + {~ (A -> B)}.
  Proof. tauto. Qed.

  Definition func_eq_dec A B (f:A -> B) (x y : A) :
    (forall a1 a2 : A, {a1 = a2} + {a1 <> a2}) ->
    (forall a1 a2, a1 <> a2 -> f a1 <> f a2) ->
    {f x = f y} + {f x <> f y}.
  Proof.
    intro A_eq_dec; destruct (A_eq_dec x y); [left|right];
      auto; congruence.
  Defined.

  Lemma dec_decidable A : {A} + {~ A} -> Decidable.decidable A.
  Proof. destruct 1; [left|right]; tauto. Qed.

  Section Finite.
    Context A (eq_dec : forall a1 a2 : A, {a1 = a2} + {a1 <> a2})
            (P : A -> Prop) (P_dec : forall a, {P a} + {~ P a}).

    (* enum has all possible elements that would fail (e.g. all
    elements that satisfy a precondition in P) *)
    Section with_enum.
      Context enum (Henum : forall a, ~ In a enum -> P a).
      Lemma dec_forall_exists : {forall a, P a} + {exists a, ~ P a}.
      Proof.
        intros.
        destruct (Forall_Exists_dec P P_dec enum); [ left | right ];
          rewrite ?Forall_forall, ?Exists_exists in *.
        { intro a. destruct (in_dec eq_dec a enum); auto. }
        { destruction. eauto. }
      Qed.
      Lemma dec_forall : {forall a, P a} + {~ (forall a, P a)}.
      Proof.
        edestruct dec_forall_exists; try eassumption; [tauto|].
        right; intro.
        match goal with
        | H : exists a, ~ P a, H': forall a, P a |- _ =>
        let x := fresh in
        destruct H as [x ?]; specialize (H' x); tauto
        end.
      Qed.
      Lemma not_forall_exists : (~ (forall a, P a)) -> exists a, ~ P a.
      Proof. edestruct dec_forall_exists; try eassumption; tauto. Qed.
    End with_enum.

    Lemma dec_forall_dependent B (projA : B -> A) enumB :
      (forall b, ~ In b enumB -> P (projA b)) ->
      (forall a, ~ Exists (fun b => projA b = a) enumB -> P a) ->
      {forall a, P a} + {~ (forall a, P a)}.
    Proof.
      intros.
      destruct (Forall_Exists_dec (fun b => P (projA b)) (fun b=> P_dec (projA b)) enumB); [ left | right ];
        repeat match goal with
               | _ => destruction; subst; solve [eauto]
               | H : forall x, ~ Exists ?P ?ls -> _ |- forall _, _ =>
                 let a := fresh in
                 intro a;
                   destruct (Exists_dec ((fun x => P) a) ls); [ solve [eauto] | | solve [eauto] ]
               | _ => progress rewrite ?Forall_forall, ?Exists_exists in *
               end.
    Qed.
  End Finite.
End Sumbool.
Hint Resolve dec_and dec_imp
     Nat.eq_dec ge_dec gt_dec lt_dec le_dec
     Z.eq_dec Z_ge_dec Z_gt_dec Z_lt_dec Z_le_dec
     Bool.bool_dec
     list_eq_dec in_dec Forall_dec
     dec_decidable
  : deciders.
Ltac f_equal_dec' A B :=
  match A with
  | ?f ?a =>
    match B with
    | f a => left; reflexivity
    | ?g a => f_equal_dec' f g
    | f ?b =>
      let H := fresh in
      assert ({a = b} + {a <> b}) as H by auto with deciders;
      destruct H; [subst a|right; congruence]
    | ?g ?b => f_equal_dec' f g
    end
  end.
Ltac f_equal_dec :=
  repeat match goal with
         | |- {?A = ?B} + {?A <> ?B} =>
           f_equal_dec' A B
         end;
  try (left; reflexivity).


Require Import Qcanon.
Require Export Replace2.
Require Import NAux ZAux RAux.
Require P.

(* Definition of the opposite for nat *)
Definition Natopp := (fun x:nat => 0%nat).

(* Definition of the opposite for N *)
Definition Nopp := (fun x:N => 0%N).

(* Auxillary functions for Z *)

Definition is_Z0 := Zeq_bool 0.
Definition is_Z1 := Zeq_bool 1.
Definition is_Zpos := Zle_bool 0.
Definition is_Zdiv x y :=
  if Zeq_bool x Z0 then false else Zeq_bool Z0 (Zmod y x).
Definition Zgcd x y :=
  if is_Zdiv x y then x else if is_Zdiv y x then y else 1%Z.

(* Check if a nat is a number *)
Ltac is_NatCst p :=
  match p with
  | O => constr:(true)
  | S ?p' => is_NatCst p'
  | _ => constr:(false)
  end.

(* Convert a Z into a nat if it is a number *)
Ltac NatCst t :=
  match is_NatCst t with
  | false => constr:(false)
  | _ => let res := eval compute in (Z_of_nat t) in constr:(res)
  end.

(* Check if a number is a positive *)
Ltac is_PCst p :=
  match p with
  | xH => constr:(true)
  | xO ?p' => is_PCst p'
  | xI ?p' => is_PCst p'
  | _ => constr:(false)
  end.

(* Check if a N is a number *)
Ltac is_NCst p :=
  match p with
  | N0 => constr:(true)
  | Npos ?p' => is_PCst p'
  | _ => constr:(false)
  end.

(* Convert a Z into a nat if it is a number *)
Ltac NCst t :=
  match is_NCst t with
  | false => constr:(false)
  | _ => let res := eval compute in (Z_of_N t) in constr:(res)
  end.

(* If a number is an integer return itself otherwise false *)
Ltac ZCst t :=
  match t with
  | Z0 => constr:(t)
  | Zpos ?p =>
    match is_PCst p with
    | false => constr:(false)
    | _ => constr:(t)
    end
  | Zneg ?p =>
    match is_PCst p with
    | false => constr:(false)
    | _ => constr:(t)
    end
  | _ => constr:(false)
  end.

(* Check if a number is an integer *)
Ltac is_ZCst t :=
  match t with
  | Z0 => constr:(true)
  | Zpos ?p => is_PCst p
  | Zneg ?p => is_PCst p
  | _ => constr:(false)
  end.

(* Turn a positive into a real *)
Fixpoint P2R (z: positive) {struct z}: R :=
  match z with
  | xH => 1%R
  | xO xH => 2%R
  | xI xH => 3%R
  | xO z1 => (2 * P2R z1)%R
  | xI z1 => (1 + 2 * P2R z1)%R
  end.

(* Turn an integer into a real *)
Definition Z2R (z: Z): R :=
  match z with
  | Z0 => 0%R
  | Zpos z1 => (P2R z1)%R
  | Zneg z1 => (-(P2R z1))%R
  end.

(* Turn a R when possible into a Q *)
Ltac RCst t :=
  match t with
  | R0 => constr:(0%Qc)
  | R1 => constr:(1%Qc)
  | Rplus ?e1 ?e2 =>
    match (RCst e1) with
    | false => constr:(false)
    | ?e3 => match (RCst e2) with
            | false => constr:(false)
            | ?e4 =>  eval vm_compute in (Qcplus e3  e4)
            end
    end
  | Rminus ?e1 ?e2 =>
    match (RCst e1) with
    | false => constr:(false)
    | ?e3 => match (RCst e2) with
            | false => constr:(false)
            |  ?e4 => eval vm_compute in (Qcminus e3  e4)
            end
    end
  | Rmult ?e1 ?e2 =>
    match (RCst e1) with
    | false => constr:(false)
    | ?e3 => match (RCst e2) with
            | false => constr:(false)
            | ?e4 => eval vm_compute in (Qcmult e3  e4)
            end
    end
  | Ropp ?e1 =>
    match (RCst e1) with
    | false => constr:(false)
    | ?e3 => eval vm_compute in (Qcopp e3)
    end
  | IZR ?e1 =>
    match (ZCst e1) with
    | false => constr:(false)
    | ?e3 => constr: (Q2Qc (QArith_base.Qmake e3 1))
    end
  | Rinv ?e1 =>
    match (RCst e1) with
    | false => constr:(false)
    | ?e3 => eval vm_compute in (Qcinv e3)
    end
  | Rdiv ?e1 ?e2 =>
    match (RCst e1) with
    | false => constr:(false)
    | ?e3 => match (RCst e2) with
            | false => constr:(false)
            | ?e4 => eval vm_compute in (Qcdiv e3  e4)
            end
    end
  | _ => constr:(false)
  end.

(* Remove the Z.abs_nat of a number, unfortunately stops at
   the first Z.abs_nat x where x is not a number *)

Ltac clean_zabs term :=
  match term with
  | context id [(Z.abs_nat ?X)] =>
    match is_ZCst X with
    | true =>
      let x := (eval vm_compute in (Z.abs_nat X)) in
      let y := context id [x] in
      clean_zabs y
    | false => term
    end
  | _ => term
  end.

(* Remove the Z.abs_N of a number, unfortunately stops at
   the first Z.abs_nat x where x is not a number *)

Ltac clean_zabs_N term :=
  match term with
  | context id [(Z.abs_N ?X)] =>
    match is_ZCst X with
    | true =>
      let x := (eval vm_compute in (Z.abs_N X)) in
      let y := context id [x] in
      clean_zabs_N y
    | false => term
    end
  | _ => term
  end.

(* Equality test for Ltac *)

Ltac eqterm t1 t2 :=
  match constr:((t1,t2)) with (?X, ?X) => true | _ => false end.

(* For replace *)

Theorem trans_equal_r (A : Set) (x y z : A) : y = z -> x = y -> x = z.
Proof. intros; apply trans_equal with y; auto. Qed.

(* Theorems for nat *)

Open Scope nat_scope.

Theorem plus_eq_compat_l a b c : b = c -> a + b = a + c.
Proof. intros; apply f_equal2 with (f := plus); auto. Qed.

Theorem plus_neg_compat_l a b c : b <> c -> a + b <> a + c.
Proof. intros H H1; case H; apply Nat.add_cancel_l with a; auto. Qed.

Theorem plus_ge_compat_l n m p : n >= m -> p + n >= p + m.
Proof. intros H; unfold ge; apply Nat.add_le_mono_l; auto. Qed.

Theorem plus_neg_reg_l a b c : a + b <> a + c -> b <> c.
Proof. intros H H1; case H; subst; auto. Qed.

Theorem plus_ge_reg_l n m p : p + n >= p + m -> n >= m.
Proof. intros H; unfold ge; apply Nat.add_le_mono_l with p; auto. Qed.

(* For replace *)

Theorem eq_lt_trans_l x y z : x = z -> x < y -> z < y.
Proof. intros H; rewrite H; auto. Qed.

Theorem eq_lt_trans_r x y z : y = z -> x < y -> x < z.
Proof. intros H; rewrite H; auto. Qed.

Theorem eq_gt_trans_l x y z : x = z -> x > y -> z > y.
Proof. intros H; rewrite H; auto. Qed.

Theorem eq_gt_trans_r x y z : y = z -> x > y -> x > z.
Proof. intros H; rewrite H; auto. Qed.

Theorem eq_le_trans_l x y z : x = z -> x <= y -> z <= y.
Proof. intros H; rewrite H; auto. Qed.

Theorem eq_le_trans_r x y z : y = z -> x <= y -> x <= z.
Proof. intros H; rewrite H; auto. Qed.

Theorem eq_ge_trans_l x y z : x = z -> x >= y -> z >= y.
Proof. intros H; rewrite H; auto. Qed.

Theorem eq_ge_trans_r x y z : y = z -> x >= y -> x >= z.
Proof. intros H; rewrite H; auto. Qed.

Theorem ge_trans x y z : x >= z -> z >= y -> x >= y.
Proof. intros H1 H2; red; apply Nat.le_trans with z; auto. Qed.

Close Scope nat_scope.

(* Theorems for N *)

Open Scope N_scope.

Theorem Nplus_eq_compat_l a b c : b = c -> a + b = a + c.
Proof. intros; apply f_equal2 with (f:= Nplus); auto. Qed.

Theorem Nplus_neg_compat_l a b c : b <> c -> a + b <> a + c.
Proof. intros H1 H2; case H1; apply Nplus_reg_l with a; auto. Qed.

Theorem Nplus_lt_compat_l n m p : n < m -> p + n < p + m.
Proof. intros; to_nat; auto with arith. Qed.

Theorem Nplus_gt_compat_l n m p : n > m -> p + n > p + m.
Proof. intros; to_nat; auto with arith. Qed.

Theorem Nplus_le_compat_l n m p : n <= m -> p + n <= p + m.
Proof. intros; to_nat; auto with arith. Qed.

Theorem Nplus_ge_compat_l n m p : n >= m -> p + n >= p + m.
Proof. intros; to_nat; auto with arith. Qed.

Theorem Nplus_neg_reg_l a b c :  a + b <> a + c -> b <> c.
Proof. intros H H1; case H; apply f_equal2 with (f:= Nplus); auto. Qed.

Theorem Nplus_lt_reg_l n m p : p + n < p + m -> n < m.
Proof. intros; to_nat; apply Nat.add_lt_mono_l with nn1; auto with arith. Qed.

Theorem Nplus_gt_reg_l: forall n m p, p + n > p + m -> n > m.
Proof. intros; to_nat; apply Nat.add_lt_mono_l with nn1; auto with arith. Qed.

Theorem Nplus_le_reg_l n m p : p + n <= p + m -> n <= m.
Proof. intros; to_nat; apply Nat.add_le_mono_l with nn1; auto with arith. Qed.

Theorem Nplus_ge_reg_l n m p : p + n >= p + m -> n >= m.
Proof. intros; to_nat; apply plus_ge_reg_l with nn1; auto with arith. Qed.

(* For replace *)
Theorem Neq_lt_trans_l x y z : x = z -> x < y -> z < y.
Proof. intros; subst; auto. Qed.

Theorem Neq_lt_trans_r x y z : y = z -> x < y -> x < z.
Proof. intros; subst; auto. Qed.

Theorem Neq_gt_trans_l x y z : x = z -> x > y -> z > y.
Proof. intros H; rewrite H; auto. Qed.

Theorem Neq_gt_trans_r x y z : y = z -> x > y -> x > z.
Proof. intros H; rewrite H; auto. Qed.

Theorem Neq_le_trans_l x y z : x = z -> x <= y -> z <= y.
Proof. intros H; rewrite H; auto. Qed.

Theorem Neq_le_trans_r x y z : y = z -> x <= y -> x <= z.
Proof. intros H; rewrite H; auto. Qed.

Theorem Neq_ge_trans_l x y z : x = z -> x >= y -> z >= y.
Proof. intros H; rewrite H; auto. Qed.

Theorem Neq_ge_trans_r x y z : y = z -> x >= y -> x >= z.
Proof. intros H; rewrite H; auto. Qed.

Theorem Nge_trans x y z : (x >= z) -> (z >= y) -> (x >= y).
Proof. intros; to_nat; red; apply Nat.le_trans with nn1; auto with arith. Qed.

Close Scope N_scope.

(* Theorems for Z *)

Open Scope Z_scope.

(* For replace *)

Theorem eq_Zlt_trans_l x y z : x = z -> x < y -> z < y.
Proof. intros H; rewrite H; auto. Qed.

Theorem eq_Zlt_trans_r x y z : y = z -> x < y -> x < z.
Proof. intros H; rewrite H; auto. Qed.

Theorem eq_Zgt_trans_l x y z : x = z -> x > y -> z > y.
Proof. intros H; rewrite H; auto. Qed.

Theorem eq_Zgt_trans_r x y z : y = z -> x > y -> x > z.
Proof. intros H; rewrite H; auto. Qed.

Theorem eq_Zle_trans_l x y z : x = z -> x <= y -> z <= y.
Proof. intros H; rewrite H; auto. Qed.

Theorem eq_Zle_trans_r x y z : y = z -> x <= y -> x <= z.
Proof. intros H; rewrite H; auto. Qed.

Theorem eq_Zge_trans_l x y z : x = z -> x >= y -> z >= y.
Proof. intros H; rewrite H; auto. Qed.

Theorem eq_Zge_trans_r x y z : y = z -> x >= y -> x >= z.
Proof. intros H; rewrite H; auto. Qed.

Theorem Zge_trans x y z : x >= z -> z >= y -> x >= y.
Proof. intros H1 H2; red; apply Zge_trans with z; auto. Qed.

Close Scope Z_scope.

(* Theorems for R *)

Open Scope R_scope.

(* For replace *)

Theorem eq_Rlt_trans_l x y z : x = z -> x < y -> z < y.
Proof. intros H; rewrite H; auto. Qed.

Theorem eq_Rlt_trans_r x y z : y = z -> x < y -> x < z.
Proof. intros H; rewrite H; auto. Qed.

Theorem eq_Rgt_trans_l x y z : x = z -> x > y -> z > y.
Proof. intros H; rewrite H; auto. Qed.

Theorem eq_Rgt_trans_r x y z : y = z -> x > y -> x > z.
Proof. intros H; rewrite H; auto. Qed.

Theorem eq_Rle_trans_l x y z : x = z -> x <= y -> z <= y.
Proof. intros H; rewrite H; auto. Qed.

Theorem eq_Rle_trans_r x y z : y = z -> x <= y -> x <= z.
Proof. intros H; rewrite H; auto. Qed.

Theorem eq_Rge_trans_l x y z : x = z -> x >= y -> z >= y.
Proof. intros H; rewrite H; auto. Qed.

Theorem eq_Rge_trans_r x y z : y = z -> x >= y -> x >= z.
Proof. intros H; rewrite H; auto. Qed.

Theorem Rge_trans x y z : (x >= z) -> (z >= y) -> (x >= y).
Proof. intros H1 H2; red; apply Rge_trans with z; auto. Qed.

(* For RGroundTac *)

Theorem Z2R_correct p : Z2R p = IZR p.
Proof.
case p; auto.
intros p1; elim p1; auto.
intros p2 Rec; pattern (Zpos (xI p2)) at 2;
  replace (Zpos (xI p2)) with (2 * (Zpos p2) +1)%Z by auto.
rewrite plus_IZR; rewrite mult_IZR; rewrite <- Rec.
simpl Z2R; simpl IZR; case p2; intros; simpl (P2R 1); ring.
intros p2 Rec; pattern (Zpos (xO p2)) at 2;
  replace (Zpos (xO p2)) with (2 * (Zpos p2))%Z by auto.
rewrite mult_IZR; rewrite <- Rec.
simpl Z2R; simpl IZR; case p2; intros; simpl (P2R 1); ring.
intros p1; elim p1; auto.
intros p2 Rec; pattern (Zneg (xI p2)) at 2;
  replace (Zneg (xI p2)) with ((2 * (Zneg p2) +  -1))%Z by auto.
rewrite plus_IZR; rewrite mult_IZR; rewrite <- Rec.
simpl Z2R; simpl IZR; case p2; intros; simpl (P2R 1); ring.
intros p2 Rec; pattern (Zneg (xO p2)) at 2;
  replace (Zneg (xO p2)) with (2 * (Zneg p2))%Z by auto.
rewrite mult_IZR; rewrite <- Rec.
simpl Z2R; simpl IZR; case p2; intros; simpl (P2R 1); ring.
Qed.

Theorem Z2R_le p q : (p <= q)%Z -> (Z2R p <= Z2R q)%R.
Proof. repeat rewrite Z2R_correct; intros; apply IZR_le; auto. Qed.

Theorem Z2R_lt p q : (p < q)%Z -> (Z2R p < Z2R q)%R.
Proof. repeat rewrite Z2R_correct; intros; apply IZR_lt; auto. Qed.

Theorem Z2R_ge p q : (p >= q)%Z -> (Z2R p >= Z2R q)%R.
Proof. repeat rewrite Z2R_correct; intros; apply IZR_ge; auto. Qed.

Theorem Z2R_gt p q : (p > q)%Z -> (Z2R p > Z2R q)%R.
Proof.
repeat rewrite Z2R_correct; intros; red; apply IZR_lt;
  apply Z.gt_lt; auto.
Qed.

Close Scope R_scope.