From Coq Require Import ZArith Reals Psatz.
From Coq Require Import Arith.Arith.
Require Import real_lemmas real_model.
From Coquelicot Require Import Coquelicot.
Set Bullet Behavior "Strict Subproofs".

Require Import Interval.Tactic.

Import Coq.Logic.FunctionalExtensionality.

Open Scope R_scope.

(* the function f is k times differentiable in the interval [a,b] *)
Definition k_differentiable f k a b:=
  forall x, a <= x <= b -> forall n:nat, (n<=k)%nat ->  ex_derive_n f n x
.

Definition smooth_fun (f: R -> R): Prop :=
  forall (x: R) (n: nat),
  ex_derive_n f n x
.

Definition dUdq x ω := ω ^ 2 * x.

(* the continuous system of equations for the simple harmonic oscillator *)
Definition Harmonic_oscillator_system (ω : R) (p q : R -> R) :=
  smooth_fun p /\ smooth_fun q /\
  forall t: R,
  Derive_n q 1 t  = p t /\
  Derive_n p 1 t  = - dUdq (q t) ω.

Lemma HOS_implies_k_diff:
  forall p q ω t h,
  Harmonic_oscillator_system ω p q ->
  k_differentiable p 4 t (t + h) /\
  k_differentiable q 3 t (t + h) .
Proof.
intros.
unfold Harmonic_oscillator_system in H.
destruct H as (C & D).
split; unfold smooth_fun in *;
unfold k_differentiable in *; intros.
-apply C.
-apply D.
Qed.

Lemma system_implies_cons_e_aux p q ω:
  0 < ω ->
  Harmonic_oscillator_system ω p q  ->
  forall t, Derive (fun t => p t ^ 2 + ω ^ 2 * q t ^ 2) t = 0.
Proof.
intros.
destruct H0 as (A & B & C).
rewrite Derive_plus.
-
rewrite Derive_pow.
rewrite Derive_scal.
rewrite Derive_pow.
simpl.
pose proof (C t) as Hp.
destruct Hp as (Hp1 & Hp2).
rewrite <- Hp1.
assert (- Derive_n p 1 t * 1/ ω ^ 2 =  q t).
rewrite Hp2. unfold dUdq. field_simplify; try field; try nra.
rewrite <- H0.
replace (Derive_n q 1 t) with (Derive q t); auto.
replace (Derive_n p 1 t) with (Derive p t); auto.
field_simplify; try field; try nra.
all: (
specialize (A t 1%nat);
specialize (B t 1%nat);
try apply A; try apply B).
-
apply ex_derive_pow.
specialize (A t 1%nat);
specialize (B t 1%nat);
try apply A; try apply B.
-
apply ex_derive_scal.
apply ex_derive_pow.
specialize (A t 1%nat);
specialize (B t 1%nat);
try apply A; try apply B.
Qed.

Lemma system_implies_cons_e p q ω t0:
  0 < ω ->
  Harmonic_oscillator_system ω p q  ->
  forall t, (p t ^ 2 + ω ^ 2 * q t ^ 2) = (p t0 ^ 2 + ω ^ 2 * q t0 ^ 2).
Proof.
intros.
pose proof (Req_dec t t0) as Heq; destruct Heq.
-
destruct H0 as (A & B & C).
subst; auto.
-
pose proof system_implies_cons_e_aux p q ω  H H0.
pose proof MVT_gen (fun t : R => p t ^ 2 + ω ^ 2 * q t ^ 2) t0 t
  (Derive (fun t : R => p t ^ 2 + ω ^ 2 * q t ^ 2)) as MVT.
simpl in MVT.
simpl.
apply Rminus_diag_uniq.
replace (fun t : R => p t * (p t * 1) + ω * (ω * 1) * (q t * (q t * 1))) with
(fun t : R => (p t ^ 2 +  (ω * q t) ^ 2 )) in MVT by (apply functional_extensionality => z; field; nra).
replace (        p t * (p t * 1) + ω * (ω * 1) * (q t * (q t * 1)) -
        (p t0 * (p t0 * 1) + ω * (ω * 1) * (q t0 * (q t0 * 1))))
with
( p t ^ 2 + ω ^ 2 * q t ^ 2 - (p t0 ^ 2 + ω ^ 2 * q t0 ^ 2)) in MVT by field.
destruct H0 as (A & B & C).
assert (exists c : R,
        Rmin t0 t <= c <= Rmax t0 t /\
        p t ^ 2 + ω ^ 2 * q t ^ 2 - (p t0 ^ 2 + ω ^ 2 * q t0 ^ 2) =
        Derive (fun t1 : R => p t1 ^ 2 + (ω * q t1) ^ 2) c * (t - t0)).
apply MVT.
intros.
apply Derive_correct.
apply (@ex_derive_plus R_AbsRing R_NormedModule);
apply ex_derive_pow.
specialize (A x 1%nat);
apply A.
apply ex_derive_scal.
specialize (B x 1%nat);
apply B.
intros.
apply derivable_continuous_pt.
apply ex_derive_Reals_0.
apply (@ex_derive_plus R_AbsRing R_NormedModule);
apply ex_derive_pow.
specialize (A x 1%nat); apply A.
apply ex_derive_scal.
specialize (B x 1%nat);
apply B.
destruct H0 as ( c & H3 & H4).
simpl in H4.
subst.
rewrite H4.
specialize (H2 c).
simpl in H2.
apply Rmult_eq_0_compat_r.
rewrite <- H2.
apply Derive_ext => ts; field.
Qed.

Lemma system_implies_cons_e' p q ω t0 t:
  0 < ω ->
  Harmonic_oscillator_system ω p q  ->
  ∥ (p t, ω * q t) ∥ = ∥ (p t0, ω * q t0) ∥.
Proof.
intros.
pose proof (system_implies_cons_e _ _ _ t0 H H0 t).
unfold Rprod_norm. f_equal. simpl. lra.
Qed.

(* relating derivatives of the continuous system for future rewrites *)
Lemma Harm_sys_derive_eq p q ω:
  0 < ω ->
  Harmonic_oscillator_system ω p q ->
  forall t,
  Derive_n q 2 t  = Derive_n p 1 t /\
  Derive_n q 3 t  = - ω^2 * p t /\
  Derive_n p 2 t  = Derive_n q 3 t /\
  Derive_n p 3 t  = ω^4 * q t /\
  Derive_n p 4 t  = ω^4 * p t.
Proof.
intros * Hω H t.
pose (t0 := t). clearbody t0.
generalize H; intros [_ [_ AB]].
destruct (AB t) as [A B].
assert (C :=system_implies_cons_e' _ _ _ t0 t Hω H).
clear AB.
do 2 apply proj2 in H.
assert (forall t, Derive_n q 2 t  = Derive_n p 1 t).
- intros; replace (Derive_n q 2 t1) with
(Derive_n (Derive_n q 1) 1 t1) by auto.
apply Derive_n_ext; intros.
apply H; auto.
-

assert ((Derive_n (fun y : R => - dUdq (q y) ω) 1 t) =
(Derive_n (Derive_n q 1) 2 t )).
+
replace (Derive_n (Derive_n q 1) 2 t) with
(Derive_n (Derive_n q 2) 1 t) by auto.
symmetry.
apply Derive_n_ext. intros.
rewrite H0.
apply H.
+ split; auto; split.
* replace (Derive_n q 3 t) with
(Derive_n (fun y : R => - dUdq (q y) ω) 1 t).
rewrite <- A.
rewrite <- Ropp_mult_distr_l.
rewrite <- Derive_n_scal_l.
rewrite Derive_n_opp.
unfold dUdq; auto.
* split.
--
unfold dUdq in *.
 replace (Derive_n q 3 t) with
(Derive_n (fun y : R => - dUdq (q y) ω) 1 t).

         rewrite  Coquelicot.Derive_nS.
    replace (Derive q) with (Derive_n q 1); auto.
unfold dUdq.
         apply Derive_n_ext. apply H.
-- split.
++

unfold dUdq in *.
replace ( ω ^ 4 * q t) with
        ( -ω ^ 2 *(-ω ^ 2 * q t)) by nra.
rewrite <- Ropp_mult_distr_l.
rewrite <- Ropp_mult_distr_l.
rewrite <- B.

         replace (Derive_n p 3 t) with (Derive_n (Derive_n p 2) 1 t) by auto.
rewrite  Ropp_mult_distr_l.
          rewrite <- Derive_n_scal_l.
         apply Derive_n_ext.
intros.
destruct (H t1) as ( J & K).
rewrite <- J.
         replace (Derive_n p 2 t1) with (Derive_n (Derive_n p 1) 1 t1) by auto.
          rewrite <- Derive_n_scal_l.
         apply Derive_n_ext.
intros. specialize (H t2).
rewrite <-  Ropp_mult_distr_l.
apply H.
    ++  rewrite <- A.
        replace (Derive_n p 4 t) with
        (Derive_n (Derive_n p 3) 1 t) by auto.
        rewrite <- Derive_n_scal_l.
        apply Derive_n_ext.
        intros.
        replace (ω ^ 4 * q t1) with
        (- ω ^ 2 * Derive_n q 2 t1).
        rewrite <- Derive_n_scal_l.
        rewrite  Coquelicot.Derive_nS.
        apply Derive_n_ext.
        intros.
        replace (- ω ^ 2 * q t2) with
        ( Derive_n q 2 t2).
        rewrite  Coquelicot.Derive_nS.
         replace (Derive p) with (Derive_n p 1); auto.
        apply Derive_n_ext.
        intros.
        specialize (H t3).
        symmetry; replace (Derive q t3) with (Derive_n q 1 t3) by auto.
        apply H.
        specialize (H0 t2).
        rewrite H0.
        specialize (H t2).
rewrite <-  Ropp_mult_distr_l.
unfold dUdq in H; apply H.
        specialize (H t1).
unfold dUdq in H.
replace (ω ^ 4 * q t1) with
        ( -ω ^ 2 *(-ω ^ 2 * q t1)) by nra.
destruct H as ( _ & K).
repeat rewrite <-  Ropp_mult_distr_l.
rewrite <- K.
f_equal. f_equal.
apply H0.
Qed.

Close Scope R_scope.


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* ********************* *)
Section LCS.
  Variable (T:eqType).

  Fixpoint behind a (s:seq T) :=
    if s is x :: s' then if a == x then s' else behind a s' else [::].

  Definition argmax I (F:I -> nat) x y := if (F x) > (F y) then x else y.

  Fixpoint LCS (s t:seq T) : seq T :=
    if s is x :: s'
    then if x \in t
         then argmax size (x :: LCS s' (behind x t)) (LCS s' t)
         else LCS s' t
    else [::].

  Lemma LCS_subseql s t : subseq (LCS s t) s.
  Proof.
    elim : s =>[|x s IHs]//= in t *.
    case : ifP =>[|_]; last exact : subseq_trans (subseq_cons _ _).
    rewrite /argmax. case : ifP =>[|_ _]; first by rewrite eq_refl.
    exact : subseq_trans (subseq_cons _ _).
  Qed.

  Lemma LCS_subseqr s t : subseq (LCS s t) t.
  Proof.
    elim : s =>[|x s IHs]/= in t *; first exact : sub0seq.
    case : ifP =>//. rewrite /argmax. case : ifP =>//_.
    elim : t =>[|y t IHt]//=. rewrite in_cons. by case : ifP =>->.
  Qed.

  Lemma LCS_sizesup s t u :
    subseq u s -> subseq u t -> size u <= size (LCS s t).
  Proof.
    elim : s =>[|xs s IHs]/= in u t *=>[/eqP->|]//. case : u =>[|xu u]//.
    case : ifP =>[/eqP-> Hus Hut|_]; last (case : ifP =>_; last exact : IHs).
    - rewrite (mem_subseq Hut (mem_head _ _)) /argmax /= ltnS.
      case : ifP =>[|/negP /negP]/=; first rewrite ltnS.
      + exact : leq_trans (IHs _ _ Hus (subseq_trans (subseq_cons _ _) Hut)).
      + rewrite -ltnNge. apply : leq_ltn_trans (IHs _ _ Hus _).
        elim : t Hut =>[|xt t IHt]//=. by case : ifP.
    - rewrite /argmax => Hus /(IHs _ _ Hus) Hsize. case : ifP =>// /ltnW.
      exact : leq_trans Hsize.
  Qed.
End LCS.


Require Import ZArith.
From QuickChick Require Import QuickChick.
From ExtLib Require Import Monad.
From ExtLib.Data.Monads Require Import OptionMonad.
Import QcNotation.
Import MonadNotation.
From Coq Require Import List.
Import ListNotations.

From RBT Require Import Impl Spec.

Local Open Scope Z_scope.

Inductive between : Z -> Z -> Z -> Prop :=
| between_n : forall n m, Z.le n m -> between n (n + 1) (m + 2)
| between_S : forall n m o, between n m o -> between n (m + 1) (o + 1).

Inductive red_black_bst : Color -> nat -> Z -> Z -> Tree -> Prop :=
    rbt_leafbh_leafbst_leaf : forall (lo hi : Z) (c : Color),
                              red_black_bst c 1 lo hi E
  | rbt_black_nodebh_black_nodebst_node : forall (lo hi x y: Z)
                                            (l r : Tree) (h : nat)
                                            (c1 c2 : Color),
                                          between lo x hi ->
                                          red_black_bst c1 h lo x l ->
                                          red_black_bst c2 h x hi r ->
                                          red_black_bst B (S h) lo hi (T B l x y r)
  | rbt_red_nodebh_red_nodebst_node : forall (lo hi x y: Z) (l r : Tree) (h : nat),
                                      between lo x hi ->
                                      red_black_bst B h lo x l ->
                                      red_black_bst B h x hi r ->
                                      red_black_bst R h lo hi (T R l x y r).

#[local] Instance gen_between (lo hi : Z) :
GenSizedSuchThat _ (fun x => between lo x hi) :=
{| arbitrarySizeST := fun n =>
                        if Z.leb 2 (hi - lo) then
                          bindGen (choose (lo+1,hi-1)%Z) (fun x => ret (Some x))
                        else ret None
|}%nat.

Derive ArbitrarySizedSuchThat for (fun t => red_black_bst c h lo hi t).

Definition gRbt :=
    (@arbitrarySizeST _ (fun t => red_black_bst B 3 0 100 t) _ 10).

(* --------------------- Tests --------------------- *)

Definition test_prop_InsertValid :=
    forAllMaybe gRbt (fun t =>
    forAll arbitrary (fun k =>
    forAll arbitrary (fun v =>
        (prop_InsertValid t k v)))).

(*! QuickChick test_prop_InsertValid. *)

Definition test_prop_DeleteValid :=
    forAllMaybe gRbt (fun t =>
    forAll arbitrary (fun k =>
        prop_DeleteValid t k)).

(*! QuickChick test_prop_DeleteValid. *)

Definition test_prop_InsertPost :=
    forAllMaybe gRbt (fun t =>
    forAll arbitrary (fun k =>
    forAll arbitrary (fun k' =>
     forAll arbitrary (fun v =>
        prop_InsertPost t k k' v)))).

(*! QuickChick test_prop_InsertPost. *)

Definition test_prop_DeletePost :=
    forAllMaybe gRbt (fun t =>
    forAll arbitrary (fun k =>
    forAll arbitrary (fun k' =>
        prop_DeletePost t k k'))).

(*! QuickChick test_prop_DeletePost. *)

Definition test_prop_InsertModel :=
    forAllMaybe gRbt (fun t =>
    forAll arbitrary (fun k =>
    forAll arbitrary (fun v =>
        prop_InsertModel t k v))).

(*! QuickChick test_prop_InsertModel. *)

Definition test_prop_DeleteModel :=
    forAllMaybe gRbt (fun t =>
    forAll arbitrary (fun k =>
            prop_DeleteModel t k)).

(*! QuickChick test_prop_DeleteModel. *)

Definition test_prop_InsertInsert :=
    forAllMaybe gRbt (fun t =>
    forAll arbitrary (fun k =>
    forAll arbitrary (fun k' =>
    forAll arbitrary (fun v =>
    forAll arbitrary (fun v' =>
        prop_InsertInsert t k k' v v'))))).

(*! QuickChick test_prop_InsertInsert. *)

Definition test_prop_InsertDelete :=
    forAllMaybe gRbt (fun t =>
    forAll arbitrary (fun k =>
    forAll arbitrary (fun k' =>
    forAll arbitrary (fun v =>
        prop_InsertDelete t k k' v)))).

(*! QuickChick test_prop_InsertDelete. *)

Definition test_prop_DeleteInsert :=
    forAllMaybe gRbt (fun t =>
    forAll arbitrary (fun k =>
    forAll arbitrary (fun k' =>
    forAll arbitrary (fun v' =>
        prop_DeleteInsert t k k' v')))).

(*! QuickChick test_prop_DeleteInsert. *)

Definition test_prop_DeleteDelete :=
    forAllMaybe gRbt (fun t =>
    forAll arbitrary (fun k =>
    forAll arbitrary (fun k' =>
        prop_DeleteDelete t k k'))).

(*! QuickChick test_prop_DeleteDelete. *)


Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.ProofIrrelevance.
Require Import Program.

Require Import LensLaws.Isomorphism.
Require Import LensLaws.Crush.

Definition Prism (A B : Set) : Type := { X : Set & Iso A (X + B) }.

Lemma iso_is_prism_ex {A B} (i : Iso A B) : Iso A (sum Empty_set B).
Proof.
  destruct i as [f g H H0].
  apply (MkIso
    (fun (a : A) => inr(f(a)))
    (fun  (e : Empty_set + B) =>
      match e with
      | inr b => g b
      | inl void => Empty_set_rec _ void
      end)); crush. Defined.

Lemma iso_is_prism {A B} (i : Iso A B) : Prism A B.
Proof.
  intros.
  exists Empty_set.
  exact (iso_is_prism_ex i). Defined.

Lemma prism_compose {A B C} (ab : Prism A B) (bc : Prism B C) : Prism A C.
Proof.
  intros.
  destruct ab as [X ab]. destruct ab as [axb xba H H0].
  destruct bc as [Y bc]. destruct bc as [byc ycb H1 H2].
  exists (sum X Y).

  apply (MkIso
    (fun (a : A) =>
      match axb a with
      | inl x => inl (inl x)
      | inr b =>
        match byc b with
        | inl y => inl (inr y)
        | inr b => inr b
        end
      end)
    (fun (t : X + Y + C) =>
      match t with
      | inl xy =>
        match xy with
        | inl x => xba (inl x)
        | inr y => xba (inr (ycb (inl y)))
        end
      | inr c => xba (inr (ycb (inr c)))
      end)); crush. Qed.

Definition prism_review {A B} (prism : Prism A B) (b : B) : A.
Proof.
  destruct prism as [Y ab]. destruct ab as [ayb yba _ _].
  exact (yba (inr b)). Defined.

Definition prism_preview {A B} (prism : Prism A B) (a : A) : option B.
Proof.
  destruct prism as [Y ab]. destruct ab as [ayb yba _ _].
  destruct (ayb a) as [y | b].
  exact None. exact (Some b). Defined.

Theorem prism_law1 {A B} (prism : Prism A B) :
  forall (b : B), prism_preview prism (prism_review prism b) = Some b.
Proof.
  intros b. destruct prism as [Y ab]. destruct ab as [ayb yba H H0]. crush. Qed.

Theorem prism_law2 {A B} (prism : Prism A B) :
  forall a b, prism_preview prism a = Some b -> prism_review prism b = a.
Proof.
  intros a b Hsome. destruct prism as [Y ab]. destruct ab as [ayb yba H H0].
  crush. Qed.

Theorem prism_law3_variant {A B} (prism : Prism A B) :
  forall a, prism_preview prism a = None -> (forall b, prism_review prism b <> a).
Proof.
  intros a Hnone. destruct prism as [Y ab]. destruct ab as [ayb yba H H0]. unfold not.
  crush.
  - rewrite (H a) in H1.
    assert (Contra : ayb (yba (inr b)) = ayb (yba (inl y))).
    rewrite H1. rewrite Heqayba. reflexivity.
    repeat (rewrite <- H0 in Contra).
    inversion Contra.
  - inversion Hnone. Qed.

Theorem prism_complete {A B : Set} (review : B -> A) (preview : A -> option B):
  (forall b, preview (review b) = Some b) ->
  (forall a b, preview a = Some b -> review b = a) ->
  Prism A B.
Proof.
  intros law1 law2.

  set (E := { a : A | None = preview a }).

  exists E.

  assert (FWD: A -> E + B).
  refine (fun (a : A) =>
    let pa := preview a in
    let Heqpa := eq_refl : pa = preview a in
    (match pa as pa0 return (pa0 = preview a -> E + B) with
      | None   => fun proof => inl (exist _ a proof)
      | Some b => fun _  => inr b
      end) Heqpa).

  assert (BWD: E + B -> A).
  refine (fun (eb : E + B) => match eb with
    | inl (exist _ a _) => a
    | inr b => review b
    end).

  set (FWD2 := (fun (a : A) =>
    let pa := preview a in
    let Heqpa := eq_refl : pa = preview a in
    (match pa as pa0 return (pa0 = preview a -> E + B) with
      | None   => fun proof => inl (exist _ a proof)
      | Some b => fun _  => inr b
      end) Heqpa)).
  set (BWD2 := (fun (eb : E + B) => match eb with
    | inl (exist _ a _) => a
    | inr b => review b
    end)).

  apply (MkIso FWD2 BWD2); subst E; subst FWD2; subst BWD2.

  - intro a. simpl.
    rewrite (@dependentMatchOfMatch _
      (fun o => o = preview a) A (preview a) eq_refl
      _ _
      (fun b pf => inr b)
      (fun pf => inl (exist (fun a0 : A => None = preview a0) a pf))).
    remember (preview a) as pa.
    destruct pa.
    + symmetry. apply law2. symmetry. apply Heqpa.
    + trivial.
  - intro eb. simpl. destruct eb as [e | b]; simpl.
    + destruct e as [a Hnone].
      set (Lem2 := @lem2_None _ ({ a : A | None = preview a } + B) (preview a)            Hnone).             rewrite Lem2. reflexivity.
    + set (Lem2 := @lem2_Some _ ({ a : A | None = preview a } + B) (preview (review b)) b (eq_sym (law1 b))). rewrite Lem2. reflexivity. Defined.

Module CompletenessMatching.
  Parameter A : Set.
  Parameter B : Set.

  Parameter review : B -> A.
  Parameter matching : A -> A + B.

  Parameter law1 : forall b, matching (review b) = inr b.
  Parameter law2 : forall a b, matching a = inr b -> review b = a.
  Parameter law3 : forall a a', matching a = inl a' -> a' = a.

  Definition E : Set := { aa : prod A A | inl (snd aa) = matching (fst aa) }.

  Definition FWD (a : A) : E + B :=
    let pa := matching a in
    let Heqpa := eq_refl : pa = matching a in
    (match pa as pa0 return (pa0 = matching a -> E + B) with
      | inl a' => fun proof => inl (exist _ (pair a a') proof)
      | inr b  => fun _  => inr b
      end) Heqpa.

  Definition BWD (eb : E + B) : A :=
    match eb with
    | inl (exist _ aa _) => snd aa (* second, i.e. returned by maching *)
    | inr b              => review b
    end.

  Theorem prism_complete : Prism A B.
  Proof.
    exists E.
    apply (MkIso FWD BWD); unfold FWD; unfold BWD; unfold E.

    - intro a. simpl.
      rewrite (@dependentMatchOfMatchSumSum _ _
        (fun (uv : A + B) => uv = matching a) A (matching a) eq_refl
        _ _
        (fun b pf => inr b)
        (fun a' pf => inl (exist (fun aa : A * A => inl (snd aa) = matching (fst aa)) (a, a') pf))).
      remember (matching a) as ab. destruct ab.
      + symmetry in Heqab. apply law3 in Heqab. subst. trivial.
      + symmetry. apply law2. symmetry. apply Heqab.

    - intro eb. simpl. destruct eb as [e | b]; simpl.
      + destruct e as [aa proof]. destruct aa as [a a']. simpl in *.
        assert (H: a' = a). apply law3. symmetry. apply proof. subst a'.
        set (Lem2 := @lem2_inl _ _ ({ aa : A * A | inl (snd aa) = matching (fst aa) } + B) (matching a) a proof).
        rewrite Lem2. trivial.
      + set (Lem2 := @lem2_inr _ _ ({ aa : A * A | inl (snd aa) = matching (fst aa) } + B) (matching (review b)) b (eq_sym (law1 b))).
        rewrite Lem2. trivial. Defined.
End CompletenessMatching.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Correctness of instruction selection for integer division *)

Require Import Zquot Coqlib Zbits.
Require Import AST Integers Floats Values Memory Globalenvs Events.
Require Import Cminor Op CminorSel.
Require Import SelectOp SelectOpproof SplitLong SplitLongproof SelectLong SelectLongproof SelectDiv.

Local Open Scope cminorsel_scope.

(** * Main approximation theorems *)

Section Z_DIV_MUL.

Variable N: Z.      (**r number of relevant bits *)
Hypothesis N_pos: N >= 0.
Variable d: Z.      (**r divisor *)
Hypothesis d_pos: d > 0.

(** This is theorem 4.2 from Granlund and Montgomery, PLDI 1994. *)

Lemma Zdiv_mul_pos:
  forall m l,
  l >= 0 ->
  two_p (N+l) <= m * d <= two_p (N+l) + two_p l ->
  forall n,
  0 <= n < two_p N ->
  Z.div n d = Z.div (m * n) (two_p (N + l)).
Proof.
  intros m l l_pos [LO HI] n RANGE.
  exploit (Z_div_mod_eq n d). auto.
  set (q := n / d).
  set (r := n mod d).
  intro EUCL.
  assert (0 <= r <= d - 1).
    unfold r. generalize (Z_mod_lt n d d_pos). omega.
  assert (0 <= m).
    apply Zmult_le_0_reg_r with d. auto.
    exploit (two_p_gt_ZERO (N + l)). omega. omega.
  set (k := m * d - two_p (N + l)).
  assert (0 <= k <= two_p l).
    unfold k; omega.
  assert ((m * n - two_p (N + l) * q) * d = k * n + two_p (N + l) * r).
    unfold k. rewrite EUCL. ring.
  assert (0 <= k * n).
    apply Z.mul_nonneg_nonneg; omega.
  assert (k * n <= two_p (N + l) - two_p l).
    apply Z.le_trans with (two_p l * n).
    apply Z.mul_le_mono_nonneg_r; omega.
    replace (N + l) with (l + N) by omega.
    rewrite two_p_is_exp.
    replace (two_p l * two_p N - two_p l)
       with (two_p l * (two_p N - 1))
         by ring.
    apply Z.mul_le_mono_nonneg_l. omega. exploit (two_p_gt_ZERO l). omega. omega.
    omega. omega.
  assert (0 <= two_p (N + l) * r).
    apply Z.mul_nonneg_nonneg.
    exploit (two_p_gt_ZERO (N + l)). omega. omega.
    omega.
  assert (two_p (N + l) * r <= two_p (N + l) * d - two_p (N + l)).
    replace (two_p (N + l) * d - two_p (N + l))
       with (two_p (N + l) * (d - 1)) by ring.
    apply Z.mul_le_mono_nonneg_l.
    omega.
    exploit (two_p_gt_ZERO (N + l)). omega. omega.
  assert (0 <= m * n - two_p (N + l) * q).
    apply Zmult_le_reg_r with d. auto.
    replace (0 * d) with 0 by ring.  rewrite H2. omega.
  assert (m * n - two_p (N + l) * q < two_p (N + l)).
    apply Zmult_lt_reg_r with d. omega.
    rewrite H2.
    apply Z.le_lt_trans with (two_p (N + l) * d - two_p l).
    omega.
    exploit (two_p_gt_ZERO l). omega. omega.
  symmetry. apply Zdiv_unique with (m * n - two_p (N + l) * q).
  ring. omega.
Qed.

Lemma Zdiv_unique_2:
  forall x y q, y > 0 -> 0 < y * q - x <= y -> Z.div x y = q - 1.
Proof.
  intros. apply Zdiv_unique with (x - (q - 1) * y). ring.
  replace ((q - 1) * y) with (y * q - y) by ring. omega.
Qed.

Lemma Zdiv_mul_opp:
  forall m l,
  l >= 0 ->
  two_p (N+l) < m * d <= two_p (N+l) + two_p l ->
  forall n,
  0 < n <= two_p N ->
  Z.div n d = - Z.div (m * (-n)) (two_p (N + l)) - 1.
Proof.
  intros m l l_pos [LO HI] n RANGE.
  replace (m * (-n)) with (- (m * n)) by ring.
  exploit (Z_div_mod_eq n d). auto.
  set (q := n / d).
  set (r := n mod d).
  intro EUCL.
  assert (0 <= r <= d - 1).
    unfold r. generalize (Z_mod_lt n d d_pos). omega.
  assert (0 <= m).
    apply Zmult_le_0_reg_r with d. auto.
    exploit (two_p_gt_ZERO (N + l)). omega. omega.
  cut (Z.div (- (m * n)) (two_p (N + l)) = -q - 1).
    omega.
  apply Zdiv_unique_2.
  apply two_p_gt_ZERO. omega.
  replace (two_p (N + l) * - q - - (m * n))
     with (m * n - two_p (N + l) * q)
       by ring.
  set (k := m * d - two_p (N + l)).
  assert (0 < k <= two_p l).
    unfold k; omega.
  assert ((m * n - two_p (N + l) * q) * d = k * n + two_p (N + l) * r).
    unfold k. rewrite EUCL. ring.
  split.
  apply Zmult_lt_reg_r with d. omega.
  replace (0 * d) with 0 by omega.
  rewrite H2.
  assert (0 < k * n). apply Z.mul_pos_pos; omega.
  assert (0 <= two_p (N + l) * r).
    apply Z.mul_nonneg_nonneg. exploit (two_p_gt_ZERO (N + l)); omega. omega.
  omega.
  apply Zmult_le_reg_r with d. omega.
  rewrite H2.
  assert (k * n <= two_p (N + l)).
    rewrite Z.add_comm. rewrite two_p_is_exp; try omega.
    apply Z.le_trans with (two_p l * n). apply Z.mul_le_mono_nonneg_r; omega.
    apply Z.mul_le_mono_nonneg_l. omega. exploit (two_p_gt_ZERO l). omega. omega.
  assert (two_p (N + l) * r <= two_p (N + l) * d - two_p (N + l)).
    replace (two_p (N + l) * d - two_p (N + l))
       with (two_p (N + l) * (d - 1))
         by ring.
    apply Z.mul_le_mono_nonneg_l. exploit (two_p_gt_ZERO (N + l)). omega. omega. omega.
  omega.
Qed.

(** This is theorem 5.1 from Granlund and Montgomery, PLDI 1994. *)

Lemma Zquot_mul:
  forall m l,
  l >= 0 ->
  two_p (N+l) < m * d <= two_p (N+l) + two_p l ->
  forall n,
  - two_p N <= n < two_p N ->
  Z.quot n d = Z.div (m * n) (two_p (N + l)) + (if zlt n 0 then 1 else 0).
Proof.
  intros. destruct (zlt n 0).
  exploit (Zdiv_mul_opp m l H H0 (-n)). omega.
  replace (- - n) with n by ring.
  replace (Z.quot n d) with (- Z.quot (-n) d).
  rewrite Zquot_Zdiv_pos by omega. omega.
  rewrite Z.quot_opp_l by omega. ring.
  rewrite Z.add_0_r. rewrite Zquot_Zdiv_pos by omega.
  apply Zdiv_mul_pos; omega.
Qed.

End Z_DIV_MUL.

(** * Correctness of the division parameters *)

Lemma divs_mul_params_sound:
  forall d m p,
  divs_mul_params d = Some(p, m) ->
  0 <= m < Int.modulus /\ 0 <= p < 32 /\
  forall n,
  Int.min_signed <= n <= Int.max_signed ->
  Z.quot n d = Z.div (m * n) (two_p (32 + p)) + (if zlt n 0 then 1 else 0).
Proof with (try discriminate).
  unfold divs_mul_params; intros d m' p'.
  destruct (find_div_mul_params Int.wordsize
               (Int.half_modulus - Int.half_modulus mod d - 1) d 32)
  as [[p m] | ]...
  generalize (p - 32). intro p1.
  destruct (zlt 0 d)...
  destruct (zlt (two_p (32 + p1)) (m * d))...
  destruct (zle (m * d) (two_p (32 + p1) + two_p (p1 + 1)))...
  destruct (zle 0 m)...
  destruct (zlt m Int.modulus)...
  destruct (zle 0 p1)...
  destruct (zlt p1 32)...
  intros EQ; inv EQ.
  split. auto. split. auto. intros.
  replace (32 + p') with (31 + (p' + 1)) by omega.
  apply Zquot_mul; try omega.
  replace (31 + (p' + 1)) with (32 + p') by omega. omega.
  change (Int.min_signed <= n < Int.half_modulus).
  unfold Int.max_signed in H. omega.
Qed.

Lemma divu_mul_params_sound:
  forall d m p,
  divu_mul_params d = Some(p, m) ->
  0 <= m < Int.modulus /\ 0 <= p < 32 /\
  forall n,
  0 <= n < Int.modulus ->
  Z.div n d = Z.div (m * n) (two_p (32 + p)).
Proof with (try discriminate).
  unfold divu_mul_params; intros d m' p'.
  destruct (find_div_mul_params Int.wordsize
               (Int.modulus - Int.modulus mod d - 1) d 32)
  as [[p m] | ]...
  generalize (p - 32); intro p1.
  destruct (zlt 0 d)...
  destruct (zle (two_p (32 + p1)) (m * d))...
  destruct (zle (m * d) (two_p (32 + p1) + two_p p1))...
  destruct (zle 0 m)...
  destruct (zlt m Int.modulus)...
  destruct (zle 0 p1)...
  destruct (zlt p1 32)...
  intros EQ; inv EQ.
  split. auto. split. auto. intros.
  apply Zdiv_mul_pos; try omega. assumption.
Qed.

Lemma divs_mul_shift_gen:
  forall x y m p,
  divs_mul_params (Int.signed y) = Some(p, m) ->
  0 <= m < Int.modulus /\ 0 <= p < 32 /\
  Int.divs x y = Int.add (Int.shr (Int.repr ((Int.signed x * m) / Int.modulus)) (Int.repr p))
                         (Int.shru x (Int.repr 31)).
Proof.
  intros. set (n := Int.signed x). set (d := Int.signed y) in *.
  exploit divs_mul_params_sound; eauto. intros (A & B & C).
  split. auto. split. auto.
  unfold Int.divs. fold n; fold d. rewrite C by (apply Int.signed_range).
  rewrite two_p_is_exp by omega. rewrite <- Zdiv_Zdiv.
  rewrite Int.shru_lt_zero. unfold Int.add. apply Int.eqm_samerepr. apply Int.eqm_add.
  rewrite Int.shr_div_two_p. apply Int.eqm_unsigned_repr_r. apply Int.eqm_refl2.
  rewrite Int.unsigned_repr. f_equal.
  rewrite Int.signed_repr. rewrite Int.modulus_power. f_equal. ring.
  cut (Int.min_signed <= n * m / Int.modulus < Int.half_modulus).
  unfold Int.max_signed; omega.
  apply Zdiv_interval_1. generalize Int.min_signed_neg; omega. apply Int.half_modulus_pos.
  apply Int.modulus_pos.
  split. apply Z.le_trans with (Int.min_signed * m).
  apply Z.mul_le_mono_nonpos_l. generalize Int.min_signed_neg; omega. omega.
  apply Z.mul_le_mono_nonneg_r. omega. unfold n; generalize (Int.signed_range x); tauto.
  apply Z.le_lt_trans with (Int.half_modulus * m).
  apply Z.mul_le_mono_nonneg_r. tauto. generalize (Int.signed_range x); unfold n, Int.max_signed; omega.
  apply Zmult_lt_compat_l. generalize Int.half_modulus_pos; omega. tauto.
  assert (32 < Int.max_unsigned) by (compute; auto). omega.
  unfold Int.lt; fold n. rewrite Int.signed_zero. destruct (zlt n 0); apply Int.eqm_unsigned_repr.
  apply two_p_gt_ZERO. omega.
  apply two_p_gt_ZERO. omega.
Qed.

Theorem divs_mul_shift_1:
  forall x y m p,
  divs_mul_params (Int.signed y) = Some(p, m) ->
  m < Int.half_modulus ->
  0 <= p < 32 /\
  Int.divs x y = Int.add (Int.shr (Int.mulhs x (Int.repr m)) (Int.repr p))
                         (Int.shru x (Int.repr 31)).
Proof.
  intros. exploit divs_mul_shift_gen; eauto. instantiate (1 := x).
  intros (A & B & C). split. auto. rewrite C.
  unfold Int.mulhs. rewrite Int.signed_repr. auto.
  generalize Int.min_signed_neg; unfold Int.max_signed; omega.
Qed.

Theorem divs_mul_shift_2:
  forall x y m p,
  divs_mul_params (Int.signed y) = Some(p, m) ->
  m >= Int.half_modulus ->
  0 <= p < 32 /\
  Int.divs x y = Int.add (Int.shr (Int.add (Int.mulhs x (Int.repr m)) x) (Int.repr p))
                         (Int.shru x (Int.repr 31)).
Proof.
  intros. exploit divs_mul_shift_gen; eauto. instantiate (1 := x).
  intros (A & B & C). split. auto. rewrite C. f_equal. f_equal.
  rewrite Int.add_signed. unfold Int.mulhs. set (n := Int.signed x).
  transitivity (Int.repr (n * (m - Int.modulus) / Int.modulus + n)).
  apply f_equal.
  replace (n * (m - Int.modulus)) with (n * m +  (-n) * Int.modulus) by ring.
  rewrite Z_div_plus. ring. apply Int.modulus_pos.
  apply Int.eqm_samerepr. apply Int.eqm_add; auto with ints.
  apply Int.eqm_sym. eapply Int.eqm_trans. apply Int.eqm_signed_unsigned.
  apply Int.eqm_unsigned_repr_l. apply Int.eqm_refl2.
  apply (f_equal (fun x => n * x / Int.modulus)).
  rewrite Int.signed_repr_eq. rewrite Z.mod_small by assumption.
  apply zlt_false. assumption.
Qed.

Theorem divu_mul_shift:
  forall x y m p,
  divu_mul_params (Int.unsigned y) = Some(p, m) ->
  0 <= p < 32 /\
  Int.divu x y = Int.shru (Int.mulhu x (Int.repr m)) (Int.repr p).
Proof.
  intros. exploit divu_mul_params_sound; eauto. intros (A & B & C).
  split. auto.
  rewrite Int.shru_div_two_p. rewrite Int.unsigned_repr.
  unfold Int.divu, Int.mulhu. f_equal. rewrite C by apply Int.unsigned_range.
  rewrite two_p_is_exp by omega. rewrite <- Zdiv_Zdiv by (apply two_p_gt_ZERO; omega).
  f_equal. rewrite (Int.unsigned_repr m).
  rewrite Int.unsigned_repr. f_equal. ring.
  cut (0 <= Int.unsigned x * m / Int.modulus < Int.modulus).
  unfold Int.max_unsigned; omega.
  apply Zdiv_interval_1. omega. compute; auto. compute; auto.
  split. simpl. apply Z.mul_nonneg_nonneg. generalize (Int.unsigned_range x); omega. omega.
  apply Z.le_lt_trans with (Int.modulus * m).
  apply Zmult_le_compat_r. generalize (Int.unsigned_range x); omega. omega.
  apply Zmult_lt_compat_l. compute; auto. omega.
  unfold Int.max_unsigned; omega.
  assert (32 < Int.max_unsigned) by (compute; auto). omega.
Qed.

(** Same, for 64-bit integers *)

Lemma divls_mul_params_sound:
  forall d m p,
  divls_mul_params d = Some(p, m) ->
  0 <= m < Int64.modulus /\ 0 <= p < 64 /\
  forall n,
  Int64.min_signed <= n <= Int64.max_signed ->
  Z.quot n d = Z.div (m * n) (two_p (64 + p)) + (if zlt n 0 then 1 else 0).
Proof with (try discriminate).
  unfold divls_mul_params; intros d m' p'.
  destruct (find_div_mul_params Int64.wordsize
               (Int64.half_modulus - Int64.half_modulus mod d - 1) d 64)
  as [[p m] | ]...
  generalize (p - 64). intro p1.
  destruct (zlt 0 d)...
  destruct (zlt (two_p (64 + p1)) (m * d))...
  destruct (zle (m * d) (two_p (64 + p1) + two_p (p1 + 1)))...
  destruct (zle 0 m)...
  destruct (zlt m Int64.modulus)...
  destruct (zle 0 p1)...
  destruct (zlt p1 64)...
  intros EQ; inv EQ.
  split. auto. split. auto. intros.
  replace (64 + p') with (63 + (p' + 1)) by omega.
  apply Zquot_mul; try omega.
  replace (63 + (p' + 1)) with (64 + p') by omega. omega.
  change (Int64.min_signed <= n < Int64.half_modulus).
  unfold Int64.max_signed in H. omega.
Qed.

Lemma divlu_mul_params_sound:
  forall d m p,
  divlu_mul_params d = Some(p, m) ->
  0 <= m < Int64.modulus /\ 0 <= p < 64 /\
  forall n,
  0 <= n < Int64.modulus ->
  Z.div n d = Z.div (m * n) (two_p (64 + p)).
Proof with (try discriminate).
  unfold divlu_mul_params; intros d m' p'.
  destruct (find_div_mul_params Int64.wordsize
               (Int64.modulus - Int64.modulus mod d - 1) d 64)
  as [[p m] | ]...
  generalize (p - 64); intro p1.
  destruct (zlt 0 d)...
  destruct (zle (two_p (64 + p1)) (m * d))...
  destruct (zle (m * d) (two_p (64 + p1) + two_p p1))...
  destruct (zle 0 m)...
  destruct (zlt m Int64.modulus)...
  destruct (zle 0 p1)...
  destruct (zlt p1 64)...
  intros EQ; inv EQ.
  split. auto. split. auto. intros.
  apply Zdiv_mul_pos; try omega. assumption.
Qed.

Remark int64_shr'_div_two_p:
  forall x y, Int64.shr' x y = Int64.repr (Int64.signed x / two_p (Int.unsigned y)).
Proof.
  intros; unfold Int64.shr'. rewrite Zshiftr_div_two_p; auto. generalize (Int.unsigned_range y); omega.
Qed.

Lemma divls_mul_shift_gen:
  forall x y m p,
  divls_mul_params (Int64.signed y) = Some(p, m) ->
  0 <= m < Int64.modulus /\ 0 <= p < 64 /\
  Int64.divs x y = Int64.add (Int64.shr' (Int64.repr ((Int64.signed x * m) / Int64.modulus)) (Int.repr p))
                             (Int64.shru x (Int64.repr 63)).
Proof.
  intros. set (n := Int64.signed x). set (d := Int64.signed y) in *.
  exploit divls_mul_params_sound; eauto. intros (A & B & C).
  split. auto. split. auto.
  unfold Int64.divs. fold n; fold d. rewrite C by (apply Int64.signed_range).
  rewrite two_p_is_exp by omega. rewrite <- Zdiv_Zdiv.
  rewrite Int64.shru_lt_zero. unfold Int64.add. apply Int64.eqm_samerepr. apply Int64.eqm_add.
  rewrite int64_shr'_div_two_p. apply Int64.eqm_unsigned_repr_r. apply Int64.eqm_refl2.
  rewrite Int.unsigned_repr. f_equal.
  rewrite Int64.signed_repr. rewrite Int64.modulus_power. f_equal. ring.
  cut (Int64.min_signed <= n * m / Int64.modulus < Int64.half_modulus).
  unfold Int64.max_signed; omega.
  apply Zdiv_interval_1. generalize Int64.min_signed_neg; omega. apply Int64.half_modulus_pos.
  apply Int64.modulus_pos.
  split. apply Z.le_trans with (Int64.min_signed * m).
  apply Z.mul_le_mono_nonpos_l. generalize Int64.min_signed_neg; omega. omega.
  apply Z.mul_le_mono_nonneg_r. tauto. unfold n; generalize (Int64.signed_range x); tauto.
  apply Z.le_lt_trans with (Int64.half_modulus * m).
  apply Zmult_le_compat_r. generalize (Int64.signed_range x); unfold n, Int64.max_signed; omega. tauto.
  apply Zmult_lt_compat_l. generalize Int64.half_modulus_pos; omega. tauto.
  assert (64 < Int.max_unsigned) by (compute; auto). omega.
  unfold Int64.lt; fold n. rewrite Int64.signed_zero. destruct (zlt n 0); apply Int64.eqm_unsigned_repr.
  apply two_p_gt_ZERO. omega.
  apply two_p_gt_ZERO. omega.
Qed.

Theorem divls_mul_shift_1:
  forall x y m p,
  divls_mul_params (Int64.signed y) = Some(p, m) ->
  m < Int64.half_modulus ->
  0 <= p < 64 /\
  Int64.divs x y = Int64.add (Int64.shr' (Int64.mulhs x (Int64.repr m)) (Int.repr p))
                             (Int64.shru' x (Int.repr 63)).
Proof.
  intros. exploit divls_mul_shift_gen; eauto. instantiate (1 := x).
  intros (A & B & C). split. auto. rewrite C.
  unfold Int64.mulhs. rewrite Int64.signed_repr. auto.
  generalize Int64.min_signed_neg; unfold Int64.max_signed; omega.
Qed.

Theorem divls_mul_shift_2:
  forall x y m p,
  divls_mul_params (Int64.signed y) = Some(p, m) ->
  m >= Int64.half_modulus ->
  0 <= p < 64 /\
  Int64.divs x y = Int64.add (Int64.shr' (Int64.add (Int64.mulhs x (Int64.repr m)) x) (Int.repr p))
                             (Int64.shru' x (Int.repr 63)).
Proof.
  intros. exploit divls_mul_shift_gen; eauto. instantiate (1 := x).
  intros (A & B & C). split. auto. rewrite C. f_equal. f_equal.
  rewrite Int64.add_signed. unfold Int64.mulhs. set (n := Int64.signed x).
  transitivity (Int64.repr (n * (m - Int64.modulus) / Int64.modulus + n)).
  apply f_equal.
  replace (n * (m - Int64.modulus)) with (n * m +  (-n) * Int64.modulus) by ring.
  rewrite Z_div_plus. ring. apply Int64.modulus_pos.
  apply Int64.eqm_samerepr. apply Int64.eqm_add; auto with ints.
  apply Int64.eqm_sym. eapply Int64.eqm_trans. apply Int64.eqm_signed_unsigned.
  apply Int64.eqm_unsigned_repr_l. apply Int64.eqm_refl2.
  apply (f_equal (fun x => n * x / Int64.modulus)).
  rewrite Int64.signed_repr_eq. rewrite Z.mod_small by assumption.
  apply zlt_false. assumption.
Qed.

Remark int64_shru'_div_two_p:
  forall x y, Int64.shru' x y = Int64.repr (Int64.unsigned x / two_p (Int.unsigned y)).
Proof.
  intros; unfold Int64.shru'. rewrite Zshiftr_div_two_p; auto. generalize (Int.unsigned_range y); omega.
Qed.

Theorem divlu_mul_shift:
  forall x y m p,
  divlu_mul_params (Int64.unsigned y) = Some(p, m) ->
  0 <= p < 64 /\
  Int64.divu x y = Int64.shru' (Int64.mulhu x (Int64.repr m)) (Int.repr p).
Proof.
  intros. exploit divlu_mul_params_sound; eauto. intros (A & B & C).
  split. auto.
  rewrite int64_shru'_div_two_p. rewrite Int.unsigned_repr.
  unfold Int64.divu, Int64.mulhu. f_equal. rewrite C by apply Int64.unsigned_range.
  rewrite two_p_is_exp by omega. rewrite <- Zdiv_Zdiv by (apply two_p_gt_ZERO; omega).
  f_equal. rewrite (Int64.unsigned_repr m).
  rewrite Int64.unsigned_repr. f_equal. ring.
  cut (0 <= Int64.unsigned x * m / Int64.modulus < Int64.modulus).
  unfold Int64.max_unsigned; omega.
  apply Zdiv_interval_1. omega. compute; auto. compute; auto.
  split. simpl. apply Z.mul_nonneg_nonneg. generalize (Int64.unsigned_range x); omega. omega.
  apply Z.le_lt_trans with (Int64.modulus * m).
  apply Zmult_le_compat_r. generalize (Int64.unsigned_range x); omega. omega.
  apply Zmult_lt_compat_l. compute; auto. omega.
  unfold Int64.max_unsigned; omega.
  assert (64 < Int.max_unsigned) by (compute; auto). omega.
Qed.

(** * Correctness of the smart constructors for division and modulus *)

Section CMCONSTRS.

Variable prog: program.
Variable hf: helper_functions.
Hypothesis HELPERS: helper_functions_declared prog hf.
Let ge := Genv.globalenv prog.
Variable sp: val.
Variable e: env.
Variable m: mem.

Lemma is_intconst_sound:
  forall v a n le,
  is_intconst a = Some n -> eval_expr ge sp e m le a v -> v = Vint n.
Proof with (try discriminate).
  intros. unfold is_intconst in *.
  destruct a... destruct o... inv H. inv H0. destruct vl; inv H5. auto.
Qed.

Lemma eval_divu_mul:
  forall le x y p M,
  divu_mul_params (Int.unsigned y) = Some(p, M) ->
  nth_error le O = Some (Vint x) ->
  eval_expr ge sp e m le (divu_mul p M) (Vint (Int.divu x y)).
Proof.
  intros. unfold divu_mul. exploit (divu_mul_shift x); eauto. intros [A B].
  assert (C: eval_expr ge sp e m le (Eletvar 0) (Vint x)) by (apply eval_Eletvar; eauto).
  assert (D: eval_expr ge sp e m le (Eop (Ointconst (Int.repr M)) Enil) (Vint (Int.repr M))) by EvalOp.
  exploit eval_mulhu. eexact C. eexact D. intros (v & E & F). simpl in F. inv F.
  exploit eval_shruimm. eexact E. instantiate (1 := Int.repr p).
  intros [v [P Q]]. simpl in Q.
  replace (Int.ltu (Int.repr p) Int.iwordsize) with true in Q.
  inv Q. rewrite B. auto.
  unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true; auto. tauto.
  assert (32 < Int.max_unsigned) by (compute; auto). omega.
Qed.

Theorem eval_divuimm:
  forall le e1 x n2 z,
  eval_expr ge sp e m le e1 x ->
  Val.divu x (Vint n2) = Some z ->
  exists v, eval_expr ge sp e m le (divuimm e1 n2) v /\ Val.lessdef z v.
Proof.
  unfold divuimm; intros. generalize H0; intros DIV.
  destruct x; simpl in DIV; try discriminate.
  destruct (Int.eq n2 Int.zero) eqn:Z2; inv DIV.
  destruct (Int.is_power2 n2) as [l | ] eqn:P2.
- erewrite Int.divu_pow2 by eauto.
  replace (Vint (Int.shru i l)) with (Val.shru (Vint i) (Vint l)).
  apply eval_shruimm; auto.
  simpl. erewrite Int.is_power2_range; eauto.
- destruct (Compopts.optim_for_size tt).
  + eapply eval_divu_base; eauto. EvalOp.
  + destruct (divu_mul_params (Int.unsigned n2)) as [[p M] | ] eqn:PARAMS.
    * exists (Vint (Int.divu i n2)); split; auto.
      econstructor; eauto. eapply eval_divu_mul; eauto.
    * eapply eval_divu_base; eauto. EvalOp.
Qed.

Theorem eval_divu:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.divu x y = Some z ->
  exists v, eval_expr ge sp e m le (divu a b) v /\ Val.lessdef z v.
Proof.
  unfold divu; intros.
  destruct (is_intconst b) as [n2|] eqn:B.
- exploit is_intconst_sound; eauto. intros EB; clear B.
  destruct (is_intconst a) as [n1|] eqn:A.
+ exploit is_intconst_sound; eauto. intros EA; clear A.
  destruct (Int.eq n2 Int.zero) eqn:Z. eapply eval_divu_base; eauto.
  subst. simpl in H1. rewrite Z in H1; inv H1.
  TrivialExists.
+ subst. eapply eval_divuimm; eauto.
- eapply eval_divu_base; eauto.
Qed.

Lemma eval_mod_from_div:
  forall le a n x y,
  eval_expr ge sp e m le a (Vint y) ->
  nth_error le O = Some (Vint x) ->
  eval_expr ge sp e m le (mod_from_div a n) (Vint (Int.sub x (Int.mul y n))).
Proof.
  unfold mod_from_div; intros.
  exploit eval_mulimm; eauto. instantiate (1 := n). intros [v [A B]].
  simpl in B. inv B. EvalOp.
Qed.

Theorem eval_moduimm:
  forall le e1 x n2 z,
  eval_expr ge sp e m le e1 x ->
  Val.modu x (Vint n2) = Some z ->
  exists v, eval_expr ge sp e m le (moduimm e1 n2) v /\ Val.lessdef z v.
Proof.
  unfold moduimm; intros. generalize H0; intros MOD.
  destruct x; simpl in MOD; try discriminate.
  destruct (Int.eq n2 Int.zero) eqn:Z2; inv MOD.
  destruct (Int.is_power2 n2) as [l | ] eqn:P2.
- erewrite Int.modu_and by eauto.
  change (Vint (Int.and i (Int.sub n2 Int.one)))
    with (Val.and (Vint i) (Vint (Int.sub n2 Int.one))).
  apply eval_andimm. auto.
- destruct (Compopts.optim_for_size tt).
  + eapply eval_modu_base; eauto. EvalOp.
  + destruct (divu_mul_params (Int.unsigned n2)) as [[p M] | ] eqn:PARAMS.
    * econstructor; split.
      econstructor; eauto. eapply eval_mod_from_div.
      eapply eval_divu_mul; eauto. simpl; eauto. simpl; eauto.
      rewrite Int.modu_divu. auto.
      red; intros; subst n2; discriminate.
    * eapply eval_modu_base; eauto. EvalOp.
Qed.

Theorem eval_modu:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.modu x y = Some z ->
  exists v, eval_expr ge sp e m le (modu a b) v /\ Val.lessdef z v.
Proof.
  unfold modu; intros.
  destruct (is_intconst b) as [n2|] eqn:B.
- exploit is_intconst_sound; eauto. intros EB; clear B.
  destruct (is_intconst a) as [n1|] eqn:A.
+ exploit is_intconst_sound; eauto. intros EA; clear A.
  destruct (Int.eq n2 Int.zero) eqn:Z. eapply eval_modu_base; eauto.
  subst. simpl in H1. rewrite Z in H1; inv H1.
  TrivialExists.
+ subst. eapply eval_moduimm; eauto.
- eapply eval_modu_base; eauto.
Qed.

Lemma eval_divs_mul:
  forall le x y p M,
  divs_mul_params (Int.signed y) = Some(p, M) ->
  nth_error le O = Some (Vint x) ->
  eval_expr ge sp e m le (divs_mul p M) (Vint (Int.divs x y)).
Proof.
  intros. unfold divs_mul.
  assert (C: eval_expr ge sp e m le (Eletvar 0) (Vint x)) by (apply eval_Eletvar; eauto).
  assert (D: eval_expr ge sp e m le (Eop (Ointconst (Int.repr M)) Enil) (Vint (Int.repr M))) by EvalOp.
  exploit eval_mulhs. eexact C. eexact D. intros (v & X & F). simpl in F; inv F.
  exploit eval_shruimm. eexact C. instantiate (1 := Int.repr (Int.zwordsize - 1)).
  intros [v1 [Y LD]]. simpl in LD.
  change (Int.ltu (Int.repr 31) Int.iwordsize) with true in LD.
  simpl in LD. inv LD.
  assert (RANGE: 0 <= p < 32 -> Int.ltu (Int.repr p) Int.iwordsize = true).
  { intros. unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true by tauto. auto.
    assert (32 < Int.max_unsigned) by (compute; auto). omega. }
  destruct (zlt M Int.half_modulus).
- exploit (divs_mul_shift_1 x); eauto. intros [A B].
  exploit eval_shrimm. eexact X. instantiate (1 := Int.repr p). intros [v1 [Z LD]].
  simpl in LD. rewrite RANGE in LD by auto. inv LD.
  exploit eval_add. eexact Z. eexact Y. intros [v1 [W LD]].
  simpl in LD. inv LD.
  rewrite B. exact W.
- exploit (divs_mul_shift_2 x); eauto. intros [A B].
  exploit eval_add. eexact X. eexact C. intros [v1 [Z LD]].
  simpl in LD. inv LD.
  exploit eval_shrimm. eexact Z. instantiate (1 := Int.repr p). intros [v1 [U LD]].
  simpl in LD. rewrite RANGE in LD by auto. inv LD.
  exploit eval_add. eexact U. eexact Y. intros [v1 [W LD]].
  simpl in LD. inv LD.
  rewrite B. exact W.
Qed.

Theorem eval_divsimm:
  forall le e1 x n2 z,
  eval_expr ge sp e m le e1 x ->
  Val.divs x (Vint n2) = Some z ->
  exists v, eval_expr ge sp e m le (divsimm e1 n2) v /\ Val.lessdef z v.
Proof.
  unfold divsimm; intros. generalize H0; intros DIV.
  destruct x; simpl in DIV; try discriminate.
  destruct (Int.eq n2 Int.zero
            || Int.eq i (Int.repr Int.min_signed) && Int.eq n2 Int.mone) eqn:Z2; inv DIV.
  destruct (Int.is_power2 n2) as [l | ] eqn:P2.
- destruct (Int.ltu l (Int.repr 31)) eqn:LT31.
  + eapply eval_shrximm; eauto. eapply Val.divs_pow2; eauto.
  + eapply eval_divs_base; eauto. EvalOp.
- destruct (Compopts.optim_for_size tt).
  + eapply eval_divs_base; eauto. EvalOp.
  + destruct (divs_mul_params (Int.signed n2)) as [[p M] | ] eqn:PARAMS.
    * exists (Vint (Int.divs i n2)); split; auto.
      econstructor; eauto. eapply eval_divs_mul; eauto.
    * eapply eval_divs_base; eauto. EvalOp.
Qed.

Theorem eval_divs:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.divs x y = Some z ->
  exists v, eval_expr ge sp e m le (divs a b) v /\ Val.lessdef z v.
Proof.
  unfold divs; intros.
  destruct (is_intconst b) as [n2|] eqn:B.
- exploit is_intconst_sound; eauto. intros EB; clear B.
  destruct (is_intconst a) as [n1|] eqn:A.
+ exploit is_intconst_sound; eauto. intros EA; clear A.
  destruct (Int.eq n2 Int.zero) eqn:Z. eapply eval_divs_base; eauto.
  subst. simpl in H1.
  destruct (Int.eq n2 Int.zero || Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone); inv H1.
  TrivialExists.
+ subst. eapply eval_divsimm; eauto.
- eapply eval_divs_base; eauto.
Qed.

Theorem eval_modsimm:
  forall le e1 x n2 z,
  eval_expr ge sp e m le e1 x ->
  Val.mods x (Vint n2) = Some z ->
  exists v, eval_expr ge sp e m le (modsimm e1 n2) v /\ Val.lessdef z v.
Proof.
  unfold modsimm; intros.
  exploit Val.mods_divs; eauto. intros [y [A B]].
  generalize A; intros DIV.
  destruct x; simpl in DIV; try discriminate.
  destruct (Int.eq n2 Int.zero
            || Int.eq i (Int.repr Int.min_signed) && Int.eq n2 Int.mone) eqn:Z2; inv DIV.
  destruct (Int.is_power2 n2) as [l | ] eqn:P2.
- destruct (Int.ltu l (Int.repr 31)) eqn:LT31.
  + exploit (eval_shrximm ge sp e m (Vint i :: le) (Eletvar O)).
    constructor. simpl; eauto. eapply Val.divs_pow2; eauto.
    intros [v1 [X LD]]. inv LD.
    econstructor; split. econstructor. eauto.
    apply eval_mod_from_div. eexact X. simpl; eauto.
    simpl. auto.
  + eapply eval_mods_base; eauto. EvalOp.
- destruct (Compopts.optim_for_size tt).
  + eapply eval_mods_base; eauto. EvalOp.
  + destruct (divs_mul_params (Int.signed n2)) as [[p M] | ] eqn:PARAMS.
    * econstructor; split.
      econstructor. eauto. apply eval_mod_from_div with (x := i); auto.
      eapply eval_divs_mul with (x := i); eauto.
      simpl. auto.
    * eapply eval_mods_base; eauto. EvalOp.
Qed.

Theorem eval_mods:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.mods x y = Some z ->
  exists v, eval_expr ge sp e m le (mods a b) v /\ Val.lessdef z v.
Proof.
  unfold mods; intros.
  destruct (is_intconst b) as [n2|] eqn:B.
- exploit is_intconst_sound; eauto. intros EB; clear B.
  destruct (is_intconst a) as [n1|] eqn:A.
+ exploit is_intconst_sound; eauto. intros EA; clear A.
  destruct (Int.eq n2 Int.zero) eqn:Z. eapply eval_mods_base; eauto.
  subst. simpl in H1.
  destruct (Int.eq n2 Int.zero || Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone); inv H1.
  TrivialExists.
+ subst. eapply eval_modsimm; eauto.
- eapply eval_mods_base; eauto.
Qed.

Lemma eval_modl_from_divl:
  forall le a n x y,
  eval_expr ge sp e m le a (Vlong y) ->
  nth_error le O = Some (Vlong x) ->
  eval_expr ge sp e m le (modl_from_divl a n) (Vlong (Int64.sub x (Int64.mul y n))).
Proof.
  unfold modl_from_divl; intros.
  exploit eval_mullimm; eauto. instantiate (1 := n). intros (v1 & A1 & B1).
  assert (A0: eval_expr ge sp e m le (Eletvar O) (Vlong x)) by (constructor; auto).
  exploit eval_subl ; auto ; try apply HELPERS. exact A0. exact A1.
  intros (v2 & A2 & B2).
  simpl in B1; inv B1. simpl in B2; inv B2. exact A2.
Qed.

Lemma eval_divlu_mull:
  forall le x y p M,
  divlu_mul_params (Int64.unsigned y) = Some(p, M) ->
  nth_error le O = Some (Vlong x) ->
  eval_expr ge sp e m le (divlu_mull p M) (Vlong (Int64.divu x y)).
Proof.
  intros. unfold divlu_mull. exploit (divlu_mul_shift x); eauto. intros [A B].
  assert (A0: eval_expr ge sp e m le (Eletvar O) (Vlong x)) by (constructor; auto).
  exploit eval_mullhu. eauto. eexact A0. instantiate (1 := Int64.repr M). intros (v1 & A1 & B1).
  exploit eval_shrluimm. eauto. eexact A1. instantiate (1 := Int.repr p). intros (v2 & A2 & B2).
  simpl in B1; inv B1. simpl in B2. replace (Int.ltu (Int.repr p) Int64.iwordsize') with true in B2. inv B2.
  rewrite B. assumption.
  unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true; auto. tauto.
  assert (64 < Int.max_unsigned) by (compute; auto). omega.
Qed.

Theorem eval_divlu:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.divlu x y = Some z ->
  exists v, eval_expr ge sp e m le (divlu a b) v /\ Val.lessdef z v.
Proof.
  unfold divlu; intros.
  destruct (is_longconst b) as [n2|] eqn:N2.
- assert (y = Vlong n2) by (eapply is_longconst_sound; eauto). subst y.
  destruct (is_longconst a) as [n1|] eqn:N1.
+ assert (x = Vlong n1) by (eapply is_longconst_sound; eauto). subst x.
  simpl in H1. destruct (Int64.eq n2 Int64.zero); inv H1.
  econstructor; split. apply eval_longconst. constructor.
+ destruct (Int64.is_power2' n2) as [l|] eqn:POW.
* exploit Val.divlu_pow2; eauto. intros EQ; subst z. apply eval_shrluimm; auto.
* destruct (Compopts.optim_for_size tt). eapply eval_divlu_base; eauto.
  destruct (divlu_mul_params (Int64.unsigned n2)) as [[p M]|] eqn:PARAMS.
** destruct x; simpl in H1; try discriminate.
   destruct (Int64.eq n2 Int64.zero); inv H1.
   econstructor; split; eauto. econstructor. eauto. eapply eval_divlu_mull; eauto.
** eapply eval_divlu_base; eauto.
- eapply eval_divlu_base; eauto.
Qed.

Theorem eval_modlu:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.modlu x y = Some z ->
  exists v, eval_expr ge sp e m le (modlu a b) v /\ Val.lessdef z v.
Proof.
  unfold modlu; intros.
  destruct (is_longconst b) as [n2|] eqn:N2.
- assert (y = Vlong n2) by (eapply is_longconst_sound; eauto). subst y.
  destruct (is_longconst a) as [n1|] eqn:N1.
+ assert (x = Vlong n1) by (eapply is_longconst_sound; eauto). subst x.
  simpl in H1. destruct (Int64.eq n2 Int64.zero); inv H1.
  econstructor; split. apply eval_longconst. constructor.
+ destruct (Int64.is_power2 n2) as [l|] eqn:POW.
* exploit Val.modlu_pow2; eauto. intros EQ; subst z. eapply eval_andl; eauto. apply eval_longconst.
* destruct (Compopts.optim_for_size tt). eapply eval_modlu_base; eauto.
  destruct (divlu_mul_params (Int64.unsigned n2)) as [[p M]|] eqn:PARAMS.
** destruct x; simpl in H1; try discriminate.
   destruct (Int64.eq n2 Int64.zero) eqn:Z; inv H1.
   rewrite Int64.modu_divu.
    econstructor; split; eauto. econstructor. eauto.
    eapply eval_modl_from_divl; eauto.
    eapply eval_divlu_mull; eauto.
    red; intros; subst n2; discriminate Z.
** eapply eval_modlu_base; eauto.
- eapply eval_modlu_base; eauto.
Qed.

Lemma eval_divls_mull:
  forall le x y p M,
  divls_mul_params (Int64.signed y) = Some(p, M) ->
  nth_error le O = Some (Vlong x) ->
  eval_expr ge sp e m le (divls_mull p M) (Vlong (Int64.divs x y)).
Proof.
  intros. unfold divls_mull.
  assert (A0: eval_expr ge sp e m le (Eletvar O) (Vlong x)).
  { constructor; auto. }
  exploit eval_mullhs. eauto. eexact A0. instantiate (1 := Int64.repr M).  intros (v1 & A1 & B1).
  exploit eval_addl; auto; try apply HELPERS. eexact A1. eexact A0. intros (v2 & A2 & B2).
  exploit eval_shrluimm. eauto. eexact A0. instantiate (1 := Int.repr 63). intros (v3 & A3 & B3).
  set (a4 := if zlt M Int64.half_modulus
             then mullhs (Eletvar 0) (Int64.repr M)
             else addl (mullhs (Eletvar 0) (Int64.repr M)) (Eletvar 0)).
  set (v4 := if zlt M Int64.half_modulus then v1 else v2).
  assert (A4: eval_expr ge sp e m le a4 v4).
  { unfold a4, v4; destruct (zlt M Int64.half_modulus); auto. }
  exploit eval_shrlimm. eauto. eexact A4. instantiate (1 := Int.repr p). intros (v5 & A5 & B5).
  exploit eval_addl; auto; try apply HELPERS. eexact A5. eexact A3. intros (v6 & A6 & B6).
  assert (RANGE: forall x, 0 <= x < 64 -> Int.ltu (Int.repr x) Int64.iwordsize' = true).
  { intros. unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true by tauto. auto.
    assert (64 < Int.max_unsigned) by (compute; auto). omega. }
  simpl in B1; inv B1.
  simpl in B2; inv B2.
  simpl in B3; rewrite RANGE in B3 by omega; inv B3.
  destruct (zlt M Int64.half_modulus).
- exploit (divls_mul_shift_1 x); eauto. intros [A B].
  simpl in B5; rewrite RANGE in B5 by auto; inv B5.
  simpl in B6; inv B6.
  rewrite B; exact A6.
- exploit (divls_mul_shift_2 x); eauto. intros [A B].
  simpl in B5; rewrite RANGE in B5 by auto; inv B5.
  simpl in B6; inv B6.
  rewrite B; exact A6.
Qed.

Theorem eval_divls:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.divls x y = Some z ->
  exists v, eval_expr ge sp e m le (divls a b) v /\ Val.lessdef z v.
Proof.
  unfold divls; intros.
  destruct (is_longconst b) as [n2|] eqn:N2.
- assert (y = Vlong n2) by (eapply is_longconst_sound; eauto). subst y.
  destruct (is_longconst a) as [n1|] eqn:N1.
+ assert (x = Vlong n1) by (eapply is_longconst_sound; eauto). subst x.
  simpl in H1.
  destruct (Int64.eq n2 Int64.zero
         || Int64.eq n1 (Int64.repr Int64.min_signed) && Int64.eq n2 Int64.mone); inv H1.
  econstructor; split. apply eval_longconst. constructor.
+ destruct (Int64.is_power2' n2) as [l|] eqn:POW.
* destruct (Int.ltu l (Int.repr 63)) eqn:LT.
** exploit Val.divls_pow2; eauto. intros EQ. eapply eval_shrxlimm; eauto.
** eapply eval_divls_base; eauto.
* destruct (Compopts.optim_for_size tt). eapply eval_divls_base; eauto.
  destruct (divls_mul_params (Int64.signed n2)) as [[p M]|] eqn:PARAMS.
** destruct x; simpl in H1; try discriminate.
   destruct (Int64.eq n2 Int64.zero
             || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq n2 Int64.mone); inv H1.
   econstructor; split; eauto. econstructor. eauto.
   eapply eval_divls_mull; eauto.
** eapply eval_divls_base; eauto.
- eapply eval_divls_base; eauto.
Qed.

Theorem eval_modls:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.modls x y = Some z ->
  exists v, eval_expr ge sp e m le (modls a b) v /\ Val.lessdef z v.
Proof.
  unfold modls; intros.
  destruct (is_longconst b) as [n2|] eqn:N2.
- assert (y = Vlong n2) by (eapply is_longconst_sound; eauto). subst y.
  destruct (is_longconst a) as [n1|] eqn:N1.
+ assert (x = Vlong n1) by (eapply is_longconst_sound; eauto). subst x.
  simpl in H1.
  destruct (Int64.eq n2 Int64.zero
         || Int64.eq n1 (Int64.repr Int64.min_signed) && Int64.eq n2 Int64.mone); inv H1.
  econstructor; split. apply eval_longconst. constructor.
+ destruct (Int64.is_power2' n2) as [l|] eqn:POW.
* destruct (Int.ltu l (Int.repr 63)) eqn:LT.
**destruct x; simpl in H1; try discriminate.
  destruct (Int64.eq n2 Int64.zero
         || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq n2 Int64.mone) eqn:D; inv H1.
  assert (Val.divls (Vlong i) (Vlong n2) = Some (Vlong (Int64.divs i n2))).
  { simpl; rewrite D; auto. }
  exploit Val.divls_pow2; eauto. intros EQ.
  set (le' := Vlong i :: le).
  assert (A: eval_expr ge sp e m le' (Eletvar O) (Vlong i)) by (constructor; auto).
  exploit eval_shrxlimm; eauto. intros (v1 & A1 & B1). inv B1.
  econstructor; split.
  econstructor. eauto. eapply eval_modl_from_divl. eexact A1. reflexivity.
  rewrite Int64.mods_divs. auto.
**eapply eval_modls_base; eauto.
* destruct (Compopts.optim_for_size tt). eapply eval_modls_base; eauto.
  destruct (divls_mul_params (Int64.signed n2)) as [[p M]|] eqn:PARAMS.
** destruct x; simpl in H1; try discriminate.
   destruct (Int64.eq n2 Int64.zero
             || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq n2 Int64.mone); inv H1.
   econstructor; split; eauto. econstructor. eauto.
   rewrite Int64.mods_divs.
   eapply eval_modl_from_divl; auto.
   eapply eval_divls_mull; eauto.
** eapply eval_modls_base; eauto.
- eapply eval_modls_base; eauto.
Qed.

(** * Floating-point division *)

Theorem eval_divf:
  forall le a b x y,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  exists v, eval_expr ge sp e m le (divf a b) v /\ Val.lessdef (Val.divf x y) v.
Proof.
  intros until y. unfold divf. destruct (divf_match b); intros.
- unfold divfimm. destruct (Float.exact_inverse n2) as [n2' | ] eqn:EINV.
  + inv H0. inv H4. simpl in H6. inv H6. econstructor; split.
    EvalOp. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor.
    simpl; eauto.
    destruct x; simpl; auto. erewrite Float.div_mul_inverse; eauto.
  + TrivialExists.
- TrivialExists.
Qed.

Theorem eval_divfs:
  forall le a b x y,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  exists v, eval_expr ge sp e m le (divfs a b) v /\ Val.lessdef (Val.divfs x y) v.
Proof.
  intros until y. unfold divfs. destruct (divfs_match b); intros.
- unfold divfsimm. destruct (Float32.exact_inverse n2) as [n2' | ] eqn:EINV.
  + inv H0. inv H4. simpl in H6. inv H6. econstructor; split.
    EvalOp. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor.
    simpl; eauto.
    destruct x; simpl; auto. erewrite Float32.div_mul_inverse; eauto.
  + TrivialExists.
- TrivialExists.
Qed.

End CMCONSTRS.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Annexes.saccheri.

Section rah_posidonius.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma rah__posidonius_aux : postulate_of_right_saccheri_quadrilaterals ->
  forall A1 A2 A3 B1 B2 B3,
  Per A2 A1 B1 -> Per A1 A2 B2 -> Cong A1 B1 A2 B2 -> OS A1 A2 B1 B2 ->
  Col A1 A2 A3 -> Col B1 B2 B3 -> Perp A1 A2 A3 B3 ->
  Cong A3 B3 A1 B1.
Proof.
  intros rah A1 A2 A3 B1 B2 B3 HPer1 HPer2 HCong HOS HA HB HPerp.
  assert (HSac : Saccheri A1 B1 B2 A2) by (repeat split; Perp; Cong).
  assert(Hdiff := sac_distincts A1 B1 B2 A2 HSac).
  spliter.
  assert_diffs.
  elim(eq_dec_points A1 A3).
  { intro.
    subst A3.
    assert(B1 = B3); [|subst; Cong].
    apply (l6_21 B1 B2 A1 B1); Col.
      apply not_col_permutation_1, par_strict_not_col_1 with A2, sac__pars1234, HSac.
      unfold Saccheri in HSac; spliter; apply (cop_perp2__col _ _ _ A1 A2); Perp.
      apply col_cop__cop with B2; Cop.
  }
  intro.
  destruct(segment_construction_3 A3 B3 A1 B1) as [B'3 []]; auto.
  assert_diffs.
  assert(B3 = B'3); [|subst; assumption].
  assert(Par_strict B1 B2 A1 A3).
  { apply (par_strict_col_par_strict _ _ _ A2); auto.
    apply par_strict_symmetry.
    apply sac__pars1423; assumption.
  }
  apply (l6_21 B1 B2 A3 B3); Col.
    apply (par_strict_not_col_4 _ _ A1); auto.
  apply col_permutation_2.
  assert (Coplanar A1 B2 B'3 B1).
  { apply coplanar_perm_15, coplanar_trans_1 with A3.
      apply not_col_permutation_2, par_strict_not_col_4 with A1; assumption.
      apply coplanar_perm_18, pars__coplanar; assumption.
    exists B3; right; right; split; Col.
  }
  apply cop_per2__col with A1; auto; apply l8_2.
    apply (rah _ _ _ A2); auto.
  apply (rah _ _ _ A3).
  unfold Saccheri in *.
  spliter.
  assert(B1 <> B3).
  { intro.
    subst B3.
    assert(A1 = A3); auto.
    apply (l8_18_uniqueness A1 A2 B1); Col; Perp.
    apply not_col_permutation_1; apply per_not_col; auto.
  }
  assert(Per A1 A3 B'3).
  { apply perp_per_1, perp_comm, (perp_col _ A2); Col.
    apply (perp_col1 _ _ _ B3); Col.
  }
  repeat split; Cong.
    apply (per_col _ _ A2); auto.
  apply (one_side_transitivity _ _ _ B3).
    apply l12_6; auto; apply (par_strict_col_par_strict _ _ _ B2); Col; Par.
    apply invert_one_side; apply out_one_side; auto; right; apply not_col_permutation_4; apply per_not_col; auto.
Qed.

Lemma rah__posidonius :
  postulate_of_right_saccheri_quadrilaterals -> posidonius_postulate.
Proof.
intro HP.
destruct ex_saccheri as [A1 [B1 [B2 [A2 [HPer1 [HPer2 [HCong HOS]]]]]]].
exists A1; exists A2; exists B1; exists B2.
assert (HNE : A1 <> A2) by (destruct HOS as [X [[H ?] ?]]; intro; subst A2; Col).
split; [destruct HOS; unfold TS in *; spliter; Col|].
split; [intro; treat_equalities; apply l8_7 in HPer1; intuition|split; [Cop|]].
intros A3 A4 B3 B4 HC1 HC2 HPerp1 HC3 HC4 HPerp2.
assert (HCong1 := rah__posidonius_aux HP A1 A2 A3 B1 B2 B3).
assert (HCong2 := rah__posidonius_aux HP A1 A2 A4 B1 B2 B4).
apply cong_inner_transitivity with A1 B1; apply cong_symmetry;
[apply HCong1|apply HCong2]; Cong; apply l8_2; auto.
Qed.

End rah_posidonius.


Require Export XR_Rle.
Require Export XR_Rlt_not_eq.
Require Export XR_Rmult_lt_reg_l.
Require Export XR_Rmult_eq_reg_l.

Local Open Scope R_scope.

Lemma Rmult_le_reg_l : forall r r1 r2,
  R0 < r ->
  r * r1 <= r * r2 ->
  r1 <= r2.
Proof.
  intros x y z hx h.
  unfold "<=" in h.
  destruct h as [ h | heq ].
  {
    unfold "<=".
    left.
    apply Rmult_lt_reg_l with x.
    { exact hx. }
    { exact h. }
  }
  {
    unfold "<=".
    right.
    apply Rmult_eq_reg_l with x.
    { exact heq. }
    {
      apply not_eq_sym.
      apply Rlt_not_eq.
      exact hx.
    }
  }
Qed.


(** printing μ_e #μe# *)

Require Import Coq.Reals.Reals.
Require Import Coq.Relations.Relations.

Require Import utils.
Require Import syntax.
Require Import integration.

Require determinism.
Import determinism.eval_dec.

Local Open Scope ennr.

(** * The value measure [μ_e] *)

(** We make use of [eval_dec] to define evaluation as [ev], a partial function
    of values, and [ew] a total function for weights. *)
Definition ev {τ} (e : expr · τ) σ : option (val τ) :=
  match eval_dec e σ with
  | eval_dec_ex_unique v w _ _ => Some v
  | eval_dec_not_ex _ => None
  end.

Definition ew {τ} (e : expr · τ) σ : R+ :=
  match eval_dec e σ with
  | eval_dec_ex_unique v w _ _ => w
  | eval_dec_not_ex _ => 0
  end.

(** [eval_in] is the value measure of an expression at exactly one entropy. It
    concentrates all weight on at most one value. *)
Definition eval_in {τ} (e : expr · τ) σ : Meas (val τ) :=
  fun A =>
    option0 (indicator A <$> ev e σ) * ew e σ.

(** [μ] is the value measure of an expression across all entropies. It will be
    the basis for our notion of equivalence. *)
Definition μ {τ} (e : expr · τ) : Meas (val τ) :=
  μEntropy >>= eval_in e.

(** * The logical relation *)

(** We now begin defining our logical relation for contextual equivalence. Since
    the relations are mutually recursive, we have to be somewhat careful in how
    we tie the recursive knot to appease the termination/positivity checkers.
    This is done by defining [A_rel'] and [E_rel'] that take as a parameter the
    V relation at a specific type. Once [V_rel] is defined using [A_rel'] we can
    close [A_rel] with it. *)

(** ---- *)

(** Two events are A-related if they agree on all V-related values. *)
Definition A_rel' (τ : Ty) (V_rel_τ : relation (val τ)) : relation (Event (val τ)) :=
  fun A0 A1 =>
    forall v0 v1 (Hv : V_rel_τ v0 v1),
      (A0 v0 = (* iff *) A1 v1).

(** Two closed expressions are E-related if their value measures agree for all
    A-related events. *)
Definition E_rel' (τ : Ty) (V_rel_τ : relation (val τ)) : relation (expr · τ) :=
  fun e0 e1 =>
    forall A0 A1 (HA : A_rel' τ V_rel_τ A0 A1),
      μ e0 A0 = μ e1 A1.

(** Values at base type are V-related exactly when they are identical *)
Definition V_rel_real : relation (val ℝ) := eq.

(** Values at arrow type are V-related when they take V-related inputs to
    E-related outputs. *)
Inductive V_rel_arrow τa τr
          (V_rel_a : relation (val τa))
          (V_rel_r : relation (val τr))
  : relation (val (τa ~> τr)) :=
| mk_V_rel_arrow (body0 body1 : expr (τa :: ·) τr) :
    (forall (va0 va1 : val τa),
        V_rel_a va0 va1 ->
        E_rel' τr V_rel_r
               (proj1_sig (ty_subst1 body0 va0))
               (proj1_sig (ty_subst1 body1 va1))) ->
      V_rel_arrow τa τr V_rel_a V_rel_r
                  (v_lam body0)
                  (v_lam body1).
Arguments mk_V_rel_arrow {_ _ _ _ _ _} Hva.

(** [V_rel] can't be defined as an inductive without angering the positivity
    checker. Instead, it is defined in pieces by type, then assembled by
    fixpoint. *)
Fixpoint V_rel τ : relation (val τ) :=
  match τ with
  | ℝ => V_rel_real
  | τa ~> τr => V_rel_arrow τa τr (V_rel τa) (V_rel τr)
  end.

Definition A_rel τ := A_rel' τ (V_rel τ).
Definition E_rel τ := E_rel' τ (V_rel τ).

(** Two value environments are G-related when they agree on domain and all their
    values are V-related. *)
Inductive G_rel : forall Γ, relation (wt_env Γ) :=
| G_rel_nil : G_rel · dep_nil dep_nil
| G_rel_cons {τ Γ v0 v1 ρ0 ρ1} :
    V_rel τ v0 v1 -> G_rel Γ ρ0 ρ1 ->
    G_rel (τ :: Γ) (dep_cons v0 ρ0) (dep_cons v1 ρ1).

(** Two open expressions are related when they are E-related after being closed
    by G-related environments. *)
Definition related_exprs Γ τ : relation (expr Γ τ) :=
  fun e0 e1 =>
    forall ρ0 ρ1 (Hρ : G_rel Γ ρ0 ρ1),
      E_rel τ (proj1_sig (close ρ0 e0)) (proj1_sig (close ρ1 e1)).

Notation "'EXP' Γ ⊢ e0 ≈ e1 : τ" :=
  (related_exprs Γ τ e0 e1)
    (at level 69, e0 at level 99, e1 at level 99, no associativity).

(** Our goal will be to prove that related_exprs is reflexive, but we will need
    some lemmas first. *)

(** * Tactics *)

Ltac fold_μ :=
  match goal with
  | [ |- context [ μEntropy >>= eval_in ?e ] ] => fold (μ e)
  | [ H : context [ μEntropy >>= eval_in ?e ] |- _ ] => fold (μ e)
  end.

(** [decide_eval e, σ as [v, w, E, u]] is a tactic to perform case analysis on
    the partiality of evaluation, and to get rid of [ev e σ] and [ew e σ]. It
    also does other stuff that tries to automatically solve the no-evaluation
    case. It binds the value and weight of the result to [v] and [w], the
    evaluation tree to [E], and the proof that [(v, w)] is unique to u. *)
Ltac decide_eval' e σ v w ex u :=
  let not_ex := fresh "not_ex" in
  let focus_ev := fresh "focus_ev" in
  let focus_ew := fresh "focus_ew" in
  set (focus_ev := ev e σ);
  set (focus_ew := ew e σ);
  unfold ev in focus_ev;
  unfold ew in focus_ew;
  destruct (eval_dec e σ) as [v w ex u | not_ex];
  subst focus_ev focus_ew;
  [| try solve [ econtradict not_ex
               | Finite
               | ring]
  ].

Tactic Notation "decide_eval" "as"
       "[" ident(v) ident(w) ident(ex) ident(u) "]"
  := match goal with
     | [ |- context[ev ?e ?σ] ] => decide_eval' e σ v w ex u
     end.
Tactic Notation "decide_eval" constr(e) constr(σ) "as"
       "[" ident(v) ident(w) ident(ex) ident(u) "]"
  :=  decide_eval' e σ v w ex u.

(** * Lemmas *)

(** If we can rewrite a measure into a dirac, we can often remove an integral
    through the monad laws. The value measure of a value is such a hidden dirac.
    *)
Lemma val_is_dirac {τ} (v : val τ) :
  μ v = dirac v.
Proof.
  extensionality A.
  unfold μ, dirac.
  apply integration_const_entropy; intro σ.
  unfold eval_in.

  decide_eval as [v' w E u]; cbn.
  destruct (invert_eval_val E).
  subst.
  ring.
Qed.

(** A helper to look up a V-relation from a G-relation  *)
Lemma apply_G_rel {Γ ρ0 ρ1} :
  G_rel Γ ρ0 ρ1 ->
  forall {x τ} {v0 v1 : val τ},
    lookup Γ x = Some τ ->
    erase v0 = erase_wt_env ρ0 x ->
    erase v1 = erase_wt_env ρ1 x ->
    V_rel τ v0 v1.
Proof.
  intros.
  revert Γ ρ0 ρ1 H H0 H1 H2.
  induction x; intros. {
    dep_destruct (Γ, H0).
    dep_destruct (ρ0, ρ1, H1, H2).
    dep_destruct H.

    cbn in *.
    elim_erase_eqs.
    apply val_eq in x0.
    apply val_eq in x.
    subst.
    auto.
  } {
    dep_destruct (Γ, H0).
    dep_destruct (ρ0, ρ1, H1, H2).
    dep_destruct H.
    eapply IHx; eauto.
  }
Qed.

(** A helper lemma and tactic for applying the coarsening lemma *)
Lemma coarsen_helper {τ X} (e0 e1 : expr · τ) (f0 f1 : val τ -> Meas X) (A0 A1 : Event X) :
  E_rel τ e0 e1 ->
  (forall v0 v1, V_rel τ v0 v1 -> f0 v0 A0 = f1 v1 A1) ->
  (μ e0 >>= f0) A0 = (μ e1 >>= f1) A1.
Proof.
  intros.
  apply (coarsening (A_rel τ)); auto.

  intros B v0 v1 Hv.
  cbn.
  f_equal.
  apply H0.
  apply Hv.
Qed.

Ltac coarsen v :=
  let v0 := fresh v "0" in
  let v1 := fresh v "1" in
  let Hv := fresh "H" v in
  apply coarsen_helper; [tauto |]; intros v0 v1 Hv.

(** It is convenient to be able to talk about the evaluation of an expression as
    transformer of value measures. We will prove they correspond to the value
    measure of the whole expression later in [plus_as_transformer] and similar. *)
Definition plus_in (v v' : val ℝ) : Meas (val ℝ) :=
    match (v : expr · ℝ), (v' : expr · ℝ) with
    | e_real r, e_real r' => fun A => indicator A (v_real (r + r'))
    | _, _ => (* never happens *) empty_meas _
    end.
Arguments plus_in !_ !_.

Definition factor_in (v : val ℝ) : Meas (val ℝ) :=
  match (v : expr · ℝ) with
  | e_real r =>
    match Rle_dec 0 r with
    | left rpos => unif_score_meas (finite r rpos) (dirac (v_real r))
    | _ => empty_meas _
    end
  | _ => (* never happens *) empty_meas _
  end.

Definition apply_in {τa τr} (vf : val (τa ~> τr)) (va : val τa) :
  Entropy -> Meas (val τr) :=
  match (vf : expr _ _) in (expr _ τ)
        return (τ = τa ~> τr -> Entropy -> Meas (val τr))
  with
  | e_lam body => fun H => ltac:(inject H; refine (eval_in (proj1_sig (ty_subst1 body va))))
  | _ => (* never happens *) fun _ _ => empty_meas _
  end eq_refl.

(** (Theorem 7) [μe_eq_μEntropy] changes an integral over a program measure into
    an integral over entropy. This is useful since we know a lot more about
    integrating by entropies than by programs. We will use it in
    [plus_as_val_transformer] and the others like it. *)
Theorem μe_eq_μEntropy :
  forall {τ B} (e : expr · τ)
         (f : val τ -> Meas B),
    μ e >>= f =
    μEntropy >>=
             (fun σ A =>
                option0 ((fun v => f v A) <$> ev e σ) * ew e σ).
Proof.
  intros.

  setoid_rewrite meas_bind_assoc.
  integrand_extensionality σ.

  unfold eval_in.
  setoid_rewrite ennr_mul_comm.
  rewrite integration_linear_in_meas.
  f_equal.

  destruct ev; cbn. {
    fold (dirac v).
    rewrite meas_id_left.
    reflexivity.
  } {
    fold (empty_meas (val τ)).
    rewrite bind_empty.
    reflexivity.
  }
Qed.

(* [μe_eq_μEntropy2] is the two argument version of [μe_eq_μEntropy]. It's
   better than just using the original twice because it moves all the option
   machinery into the very inside. *)
Lemma μe_eq_μEntropy2 {τ0 τ1 B}
      (f : val τ0 -> val τ1 -> Meas B)
      (e0 : expr · τ0) (e1 : expr · τ1) :
  μ e0 >>= (fun v0 => μ e1 >>= (fun v1 => f v0 v1)) =
  μEntropy >>=
           (fun σ0 =>
              μEntropy >>=
                       (fun σ1 A =>
                          option0 ((fun v0 v1 => f v0 v1 A)
                                     <$> ev e0 σ0 <*> ev e1 σ1)
                                  * ew e1 σ1 * ew e0 σ0)).
Proof.
  extensionality A.
  setoid_rewrite μe_eq_μEntropy.
  rewrite μe_eq_μEntropy.
  integrand_extensionality σ0.

  unfold ">>=".
  rewrite <- integration_linear_mult_r.
  f_equal.

  decide_eval as [v w E u]; cbn; auto.
  rewrite <- integration_linear_mult_l.
  ring.
Qed.

Lemma plus_as_transformer (el er : expr · ℝ) :
  μ (e_plus el er) =
  μ el >>= (fun vl => μ er >>= (fun vr => plus_in vl vr)).
Proof.
  extensionality A.

  rewrite μe_eq_μEntropy2.
  set (f σ0 σ1 A :=
         option0 (((fun vl vr => plus_in vl vr A) <$> ev el σ0) <*> ev er σ1)
                 * ew er σ1 * ew el σ0).
  transitivity ((μEntropy >>= (fun σ => f (π 0 σ) (π 1 σ))) A). {
    subst f.
    simpl.

    integrand_extensionality σ.

    unfold eval_in.
    decide_eval (e_plus el er) σ as [v0 w0 ex0 u0]. {
      dependent destruction ex0; try absurd_val.
      decide_eval el (π 0 σ) as [vl wl exl ul].
      decide_eval er (π 1 σ) as [vr wr exr ur].
      destruct_val vr.
      destruct_val vl.
      simpl.

      destruct (ul _ _ ex0_1), (ur _ _ ex0_2); subst.
      dep_destruct (H, H1).

      cbn.
      ring.
    } {
      decide_eval el (π 0 σ) as [vl wl exl ul].
      decide_eval er (π 1 σ) as [vr wr exr ur].
      destruct_val vr.
      destruct_val vl.
      econtradict not_ex.
    }
  } {
    rewrite pick_2_entropies.
    auto.
  }
Qed.

Lemma apply_as_transformer {τa τr}
      (ef : expr · (τa ~> τr))
      (ea : expr · τa) :
  μ (e_app ef ea) =
  μ ef >>= (fun vf => μ ea >>= (fun va => μEntropy >>= apply_in vf va)).
Proof.
  extensionality A.

  set (x σf σa σbody A :=
         option0 ((fun vf va => apply_in vf va σbody A)
                    <$> ev ef σf
                    <*> ev ea σa)
                 * ew ea σa * ew ef σf).
  transitivity ((μEntropy >>= (fun σ => x (π 0 σ) (π 1 σ) (π 2 σ))) A). {
    subst x.
    cbn.

    integrand_extensionality σ.

    unfold eval_in.
    decide_eval (e_app ef ea) σ as [vr wr exr ur]; simpl. {
      dep_destruct exr; try absurd_val.
      rename va into va'.
      decide_eval ef (π 0 σ) as [vf wf exf uf].
      decide_eval ea (π 1 σ) as [va wa exa ua].
      simpl.

      destruct_val vf.
      cbn.

      destruct (uf _ _ exr1), (ua _ _ exr2); subst.
      dep_destruct H.

      unfold eval_in.

      decide_eval as [vr' wr' exr' ur'].
      destruct (ur' _ _ exr3); subst.
      simpl.
      ring.
    } {
      decide_eval ef (π 0 σ) as [vf wf exf uf].
      decide_eval ea (π 1 σ) as [va wa exa ua].
      simpl.

      destruct_val vf.
      cbn.

      unfold eval_in.

      decide_eval as [v5 w5 ex5 u5].
      econtradict not_ex.
    }
  } {
    rewrite pick_3_entropies.
    rewrite μe_eq_μEntropy2.
    integrand_extensionality σf.
    integrand_extensionality σa.
    subst x.
    cbn.
    repeat setoid_rewrite <- integration_linear_mult_r.
    do 2 f_equal.

    repeat destruct ev; try solve [apply integration_of_0].
    cbn.
    reflexivity.
  }
Qed.

Lemma factor_as_transformer (e : expr · ℝ) :
  μ (e_factor e) =
  μ e >>= factor_in.
Proof.
  extensionality A.

  rewrite μe_eq_μEntropy.

  integrand_extensionality σ.
  unfold eval_in.

  decide_eval (e_factor e) σ as [vr wr exr ur]; simpl. {
    destruct_val vr.
    dep_destruct exr; try absurd_val.

    decide_eval as [ve we exe ue].
    destruct (ue _ _ exr); subst.

    cbn.
    destruct Rle_dec; [| contradiction].
    replace (finite r r0) with (finite r rpos) by Finite.
    cbn.
    ring.
  } {
    decide_eval as [ve we exe ue].
    destruct_val ve.
    cbn.

    destruct Rle_dec; cbn; try ring.
    specialize (not_ex (v_real r) (finite r r0 * we)).
    econtradict not_ex.
  }
Qed.

(** ** Compatibility Lemmas *)

Lemma compat_real Γ r :
  (EXP Γ ⊢ e_real r ≈ e_real r : ℝ).
Proof.
  repeat intro.
  elim_sig_exprs.
  elim_erase_eqs.

  rewrite rewrite_v_real.
  rewrite val_is_dirac.
  unfold dirac, indicator.
  f_equal.
  apply HA.

  hnf.
  reflexivity.
Qed.

Lemma compat_var Γ x τ
      (Hx : lookup Γ x = Some τ) :
  EXP Γ ⊢ e_var x Hx ≈ e_var x Hx : τ.
Proof.
  repeat intro.

  destruct (env_search_subst ρ0 Hx) as [v0 ρ0x].
  destruct (env_search_subst ρ1 Hx) as [v1 ρ1x].
  pose proof (apply_G_rel Hρ Hx ρ0x ρ1x).

  elim_sig_exprs.
  elim_erase_eqs.

  rewrite 2 val_is_dirac.
  unfold dirac, indicator.
  f_equal.
  apply HA.
  exact H.
Qed.

Lemma compat_lam Γ τa τr body0 body1 :
  (EXP (τa :: Γ) ⊢ body0 ≈ body1 : τr) ->
  (EXP Γ ⊢ e_lam body0 ≈ e_lam body1 : (τa ~> τr)).
Proof.
  intros Hbody.
  repeat intro.

  elim_sig_exprs.
  elim_erase_eqs.

  rewrite 2 rewrite_v_lam.
  rewrite 2 val_is_dirac.

  unfold dirac, indicator.
  f_equal.
  apply HA.

  constructor.
  intros.

  specialize (Hbody (dep_cons va0 ρ0) (dep_cons va1 ρ1) (G_rel_cons H Hρ)).

  elim_sig_exprs.
  elim_erase_eqs.
  asimpl in He3.
  asimpl in He4.
  elim_erase_eqs.

  exact Hbody.
Qed.

Lemma compat_plus Γ el0 er0 el1 er1 :
  (EXP Γ ⊢ el0 ≈ el1 : ℝ) ->
  (EXP Γ ⊢ er0 ≈ er1 : ℝ) ->
  (EXP Γ ⊢ e_plus el0 er0 ≈ e_plus el1 er1 : ℝ).
Proof.
  intros Hl Hr.
  repeat intro.

  specialize (Hl _ _ Hρ).
  specialize (Hr _ _ Hρ).

  elim_sig_exprs.
  elim_erase_eqs.

  clear el0 el1 er0 er1 He He0 He1 He2.

  do 2 rewrite plus_as_transformer.

  coarsen vl.
  coarsen vr.

  destruct Hvl, Hvr.
  destruct_val vl0.
  destruct_val vr0.

  cbn.
  unfold indicator.
  erewrite HA; auto.
  reflexivity.
Qed.

Lemma compat_app Γ τa τr ef0 ef1 ea0 ea1 :
  (EXP Γ ⊢ ef0 ≈ ef1 : (τa ~> τr)) ->
  (EXP Γ ⊢ ea0 ≈ ea1 : τa) ->
  (EXP Γ ⊢ e_app ef0 ea0 ≈ e_app ef1 ea1 : τr).
Proof.
  intros Hf Ha.
  repeat intro.

  specialize (Hf _ _ Hρ).
  specialize (Ha _ _ Hρ).

  elim_sig_exprs.
  elim_erase_eqs.

  clear ef0 ef1 ea0 ea1 He He0 He1 He2.

  do 2 rewrite apply_as_transformer.

  coarsen vf.
  coarsen va.

  destruct Hvf as [? ? Hvf].
  cbn; repeat fold_μ.
  apply Hvf; assumption.
Qed.

Lemma compat_sample Γ :
  EXP Γ ⊢ e_sample ≈ e_sample : ℝ.
Proof.
  repeat intro.

  elim_sig_exprs.
  elim_erase_eqs.

  f_equal.
  extensionality v.

  apply HA.
  reflexivity.
Qed.

Lemma compat_factor Γ e0 e1:
  (EXP Γ ⊢ e0 ≈ e1 : ℝ) ->
  (EXP Γ ⊢ e_factor e0 ≈ e_factor e1 : ℝ).
Proof.
  intros He.
  repeat intro.

  specialize (He _ _ Hρ).

  elim_sig_exprs.
  elim_erase_eqs.

  clear e0 e1 He0 He2.

  rewrite 2 factor_as_transformer.

  coarsen v.

  destruct Hv.
  destruct_val v0.

  cbn.
  destruct Rle_dec; auto.

  cbn.
  unfold indicator.
  do 2 f_equal.
  apply HA.
  reflexivity.
Qed.

(** * The fundamental property *)
Lemma fundamental_property {Γ τ} (e : expr Γ τ) :
  (EXP Γ ⊢ e ≈ e : τ).
Proof.
  induction e.
  - apply compat_real.
  - apply compat_var.
  - apply compat_lam; auto.
  - apply compat_app; auto.
  - apply compat_factor; auto.
  - apply compat_sample.
  - apply compat_plus; auto.
Qed.


Require Import NPeano Arith Bool String List CpdtTactics.
Set Implicit Arguments.

(** A class definition defines an interface for some type.  In this
   case, we say that types A that implement the Show interface have
   a method named show that will convert them to a string.

   So we can use the generic method "show" on any type A that is
   an instance of the Show class.

   In general, you can have multiple things in the interface that
   depend upon the type A.
*)
Class Show(A:Type) := {
  show : A -> string
}.

(** Here we define booleans as an instance of the Show class and
   give a definition of the method.  *)
Instance boolShow : Show bool := {
  show := fun (b:bool) => (if b then "true" else "false") % string
}.

Compute show true.
Compute show false.
Eval compute in show 3.

(** This doesn't work because we haven't said how to show a nat.
 We get an even scarier message,
"[Error: vm_compute does not support existential variables.]"
if we do [Compute show 3], because of that variable [?Show]. *)

(** Now let's define nat as an instance of Show.  We first need
   some helper functions to convert nats to strings. *)

Definition digit2string(d:nat) : string :=
  match d with
    | 0 => "0" | 1 => "1" | 2 => "2" | 3 => "3"
    | 4 => "4" | 5 => "5" | 6 => "6" | 7 => "7"
    | 8 => "8" | _ => "9"
  end %string.

(** Alas, it can be difficult to convince Coq that
   this terminates.  So we give it fuel.  But, we
   know how much fuel we should use in this case... *)
Fixpoint digits'(fuel n:nat) (accum : string) : string :=
  match fuel with
    | 0 => accum
    | S fuel' =>
      match n with
        | 0 => accum
        | _ => let d := digit2string(n mod 10) in
               digits' fuel' (n / 10) (d ++ accum)
      end
  end.

(** It's sufficient to use n as the fuel here since
   we know we won't need to divide n by 10 more than
   n times.  We could of course use log_10 n, but there's
   no need to bother here. *)
Definition digits (n:nat) : string :=
  match digits' n n "" with
    | "" => "0"
    | ds => ds
  end %string.

Require Import Recdef Nat Lia.
Function digits''(n:nat) (accum:string)
            {measure (fun x:nat => x) n}: string :=
  match n with
  | 0 => accum
  | _ => let d := digit2string(n mod 10) in
         digits'' (n / 10) (d ++ accum)
  end.
Proof.
  intros. apply Nat.div_lt ; lia.
Defined.

(* Now we can define our nat instance for the Show class. *)
Instance natShow : Show nat := {
  show := digits
}.

Compute show 42.
Compute show (10+2).

(* Importantly, we still have the ability to show booleans. *)
Compute show true.

(** We can also parameterized instances, allowing us to show
    data structures.

    The following is a generic instance in that if we can have two types
    A and B that are instances of the Show class, then we can
    build a generic Show for the product type (A*B).
*)
Instance pairShow(A B:Type)(showA : Show A)(showB : Show B) : Show (A*B) := {
  show := (fun p => "(" ++ (show (fst p)) ++ "," ++ (show (snd p)) ++ ")")
            %string
}.

Compute show (3,4).
Compute show (true,42).

Print pairShow.

(** Similarly, we can define a generic show for lists, as long
   as the elements of the lists are show'able. *)
Definition show_list{A:Type}{showA:Show A}(xs:list A) : string :=
  ("[" ++ ((fix loop (xs:list A) : string :=
             match xs with
               | nil => "]"
               | h::nil => show h ++ "]"
               | h::t => show h ++ "," ++ loop t
             end) xs))%string.

Instance listShow(A:Type)(showA:Show A) : Show (list A) := {
  show := @show_list A showA
}.

Compute show (1::2::3::nil).
Compute show (true::false::nil).
Compute show ((1,true)::(42,false)::nil).
Compute show ((1::2::3::nil)::(4::5::nil)::(6::nil)::nil).

(** Here is another way to have an anonymous argument,
    other than using the name [_]. *)
Definition showOne {A:Type} `{Show A} (a:A) : string :=
  "The value is " ++ show a.

Compute showOne true.
Compute showOne 7.

Definition showTwo {A B:Type} {sa:Show A} `{Show B} (a:A) (b:B) : string :=
  "First is " ++ show a ++ " and second is " ++ show b.

Compute (showTwo true 7).

(** Type classes are a powerful abstraction tool that fit very well
    with some proof developments.

    One tip is to make type classes as small and simple
    as possible. For example, you probably want to separate out
    the operations you want to use from the properties that
    the implementation is expected to satisfy.
*)

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

(** Monads are very useful for modeling things that are not just
   pure functions, that have some kind of external effect on the
   world such as reading input or producing output. They're
   essential for modeling statefulness a in pure, stateless,
   functional language like Coq.

   Now we define a generic class for Monads.  Here, it's not a type
   that's a monad, but rather a type constructor (i.e., a function
   from types to types, aka a functor.  Monads have two operations:
   ret and bind.

   If we think of monads as a pattern for encoding effects, such
   as exceptions or state or non-determinism, then we can think
   of "M A" as describing side-effecting computations that produce
   a value of type A.

   The "ret" operation takes a pure (effect-free) value of type A
   and injects it into the space of side-effecting computations.

   The "bind" operation sequences two side-effecting computations,
   allowing the latter to depend upon the value of the first one.
*)

Record Point (T:Type) : Type := {xCord:T; yCord:T}.

Inductive Point' (T:Type) : Type :=
| Build_Point':  T -> T -> Point' T
.

Check {| xCord := 2; yCord :=3 |}.

Check (@Build_Point _ 2 3).

Class Monad(M:Type -> Type) :=
{
  ret : forall {A:Type}, A -> M A ;
  bind : forall {A B:Type}, M A -> (A -> M B) -> M B
}.

(* As usual, we will use the more convenient notation for bind. *)
Notation "x <- c1 ;; c2" := (bind c1 (fun x => c2))
                             (right associativity, at level 84, c1 at next level).

Notation "c1 ;; c2" := (bind c1 (fun _ => c2)) (at level 100, right associativity).

Inductive IO :Type -> Prop :=
| reti : forall A, A-> IO A
| bindi : forall A B, IO A -> (A -> IO B) -> IO B
| printString : string -> IO bool
| readLine : IO string.

(** One instance of the generic Monad class is the option monad
   defined as follows. It's a bit like exceptions where there
   is only one possible exception: None.
 *)
Instance OptionMonad : Monad option :=
{
  ret := fun {A:Type} (x:A) => Some x ;
  bind := fun {A B:Type} (x:option A) (f:A -> option B) =>
            match x with
              | None => None
              | Some y => f y
            end
}.

(** How might we use this monad? We can 'fix' subtraction,
    which ordinarily has odd semantics in Coq, so that any
    computation of a negative number fails and that failure
    propagates to the final result.
*)

Fixpoint subtract (x y:nat) : option nat :=
  match x, y with
    | x, 0 => ret x
    | 0, S _ => None
    | S x', S y' => subtract x' y'
  end.

Inductive exp :=
| Num : nat -> exp
| Plus : exp -> exp -> exp
| Minus : exp -> exp -> exp.

Instance expShow : Show exp := {
  show := fix show_exp (e:exp) : string :=
              match e with
                | Num n => show n
                | Plus e1 e2 =>
                  "(" ++ (show_exp e1) ++ "+" ++ (show_exp e2) ++ ")"
                | Minus e1 e2 =>
                  "(" ++ (show_exp e1) ++ "-" ++ (show_exp e2) ++ ")"
              end %string
}.

(** Now we can write an expression evaluator very conveniently: *)
Fixpoint eval (e:exp) : option nat :=
  match e with
    | Num n => ret n
    | Plus e1 e2 => n1 <- eval e1 ;;
                    n2 <- eval e2 ;;
                    ret (n1 + n2)
    | Minus e1 e2 => n1 <- eval e1 ;;
                     n2 <- eval e2 ;;
                     subtract n1 n2
  end.

Goal eval = fun x => None.
unfold eval.
simpl.
Abort.

Example e1 : exp := Plus(Num 2) (Minus(Num 0) (Num 1)).
Compute (eval e1).
(** That's better than normal evaluation: *)
Compute 2 + (0 - 1).

Print "+".

Require Import String.
Inductive Exn(A:Type) : Type :=
| Result : A -> Exn A
| Fail : string -> Exn A.
Arguments Result {A}.
Arguments Fail {A}.

Instance ExnMonad : Monad Exn :=
{
  ret := fun {A:Type} (x:A) => Result x ;
  bind := fun {A B:Type} (x:Exn A) (f:A -> Exn B) =>
            match x with
              | Result y => f y
              | Fail s => Fail s
            end
}.

Fixpoint eval' (e:exp) : Exn nat :=
  match e with
    | Num n => ret n
    | Plus e1 e2 => n1 <- eval' e1 ;;
                    n2 <- eval' e2 ;;
                    ret (n1 + n2)
    | Minus e1 e2 => n1 <- eval' e1 ;;
                     n2 <- eval' e2 ;;
                     match subtract n1 n2 with
                       | None => Fail "underflow"
                       | Some v => ret v
                     end
  end.

Definition tryCatch {A} (e:Exn A) (s:string) (handler:Exn A) : Exn A :=
  match e with
    | Fail s' => if string_dec s s' then handler else e
    | _ => e
  end.

Definition eval_to_zero (e:exp) :=
  tryCatch (eval' e) "underflow" (ret 0).

Check eval_to_zero.
Compute eval' (Minus (Num 2) (Num 5)).
Compute eval_to_zero (Minus (Num 2) (Num 5)).

(** We can also use monads to model state. *)

Require Import List.
Definition var := string.

(** We define expressions equipped with an imperative
    update: *)
Inductive exp_s : Type :=
| Var_s : var -> exp_s
| Plus_s : exp_s -> exp_s -> exp_s
| Times_s : exp_s -> exp_s -> exp_s
| Set_s : var -> exp_s -> exp_s
| Seq_s : exp_s -> exp_s -> exp_s
| If0_s : exp_s -> exp_s -> exp_s -> exp_s.

Definition state := var -> nat.
Definition upd(x:var)(n:nat)(s:state) : state :=
  fun v => if string_dec x v then n else s x.

(** An evaluator can be written that passes the state
    through everywhere, but it's tedious and error-prone: *)
Fixpoint eval_s (e:exp_s)(s:state) : (state * nat) :=
  match e with
    | Var_s x => (s, s x)
    | Plus_s e1 e2 =>
      let (s1, n1) := eval_s e1 s in
      let (s2, n2) := eval_s e2 s1 in
      (s2, n1+n2)
    | Times_s e1 e2 =>
      let (s1, n1) := eval_s e1 s in
      let (s2, n2) := eval_s e2 s1 in
      (s2, n1*n2)
    | Set_s x e =>
      let (s1, n1) := eval_s e s in
      (upd x n1 s1, n1)
    | Seq_s e1 e2 =>
      let (s1, n1) := eval_s e1 s in
      eval_s e2 s1
    | If0_s e1 e2 e3 =>
      let (s1, n1) := eval_s e1 s in
      match n1 with
        | 0 => eval_s e2 s1
        | _ => eval_s e3 s1
      end
  end.

Definition state_comp(A:Type) : Type := state -> (state*A).

Instance StateMonad : Monad state_comp := {
  ret := fun {A:Type} (x:A) => (fun (s:state) => (s,x)) ;
  bind := fun {A B:Type} (c : state_comp A) (f: A -> state_comp B) =>
            fun (s:state) =>
              let (s',v) := c s in
              f v s'
}.

Definition read (x:var) : state_comp nat :=
  fun s => (s, s x).

Definition write (x:var) (n:nat) : state_comp nat :=
  fun s => (upd x n s, n).

(** The evaluator looks much cleaner with the state monad,
    using the functions [read] and [write] to capture interaction
    with the state.
 *)
Fixpoint eval_sm (e:exp_s) : state_comp nat :=
  match e with
    | Var_s x => read x
    | Plus_s e1 e2 =>
      n1 <- eval_sm e1 ;;
      n2 <- eval_sm e2 ;;
      ret (n1 + n2)
    | Times_s e1 e2 =>
      n1 <- eval_sm e1 ;;
      n2 <- eval_sm e2 ;;
      ret (n1 * n2)
    | Set_s x e =>
      n <- eval_sm e ;;
      write x n
    | Seq_s e1 e2 =>
      _ <- eval_sm e1 ;;
      eval_sm e2
    | If0_s e1 e2 e3 =>
      n <- eval_sm e1 ;;
      match n with
        | 0 => eval_sm e2
        | _ => eval_sm e3
      end
  end.

(** We can also use monads to model nondeterministic
    evaluation. *)

Inductive exp_nd : Type :=
| Choose_nd : list nat -> exp_nd
| Plus_nd : exp_nd -> exp_nd -> exp_nd
| Times_nd : exp_nd -> exp_nd -> exp_nd.

Definition flatten {A:Type} (xs:list (list A)) :=
  fold_right (fun x a => x ++ a) nil xs.

Instance listMonad : Monad list := {
  ret := fun {A:Type} (x:A) => (x::nil) ;
  bind := fun {A B:Type} (c:list A) (f: A -> list B) =>
            flatten (map f c)
}.

Fixpoint eval_nd (e:exp_nd) : list nat :=
  match e with
    | Choose_nd ns => ns
    | Plus_nd e1 e2 =>
      n1 <- eval_nd e1 ;;
      n2 <- eval_nd e2 ;;
      ret (n1 + n2)
    | Times_nd e1 e2 =>
      n1 <- eval_nd e1 ;;
      n2 <- eval_nd e2 ;;
      ret (n1 * n2)
  end.
Import ListNotations.

Goal eval_nd = fun _ => nil.
unfold eval_nd. simpl.
Abort.

Compute eval_nd (Plus_nd (Choose_nd (1::2::nil)) (Choose_nd (3::4::nil))).

(** Monads ideally satisfy the following laws, and a good exercise
    is to try to show that any monad you define satisfies these laws. *)

Class Monad_with_Laws (M: Type -> Type){MonadM : Monad M} :=
{
  m_left_id : forall {A B:Type} (x:A) (f:A -> M B), bind (ret x) f = f x ;
  m_right_id : forall {A B:Type} (c:M A), bind c ret = c ;
  m_assoc : forall {A B C} (c:M A) (f:A->M B) (g:B -> M C),
    bind (bind c f) g = bind c (fun x => bind (f x) g)
}.

(** This demonstration is easy for the option monad: *)

Instance OptionMonadLaws : @Monad_with_Laws option _ := {}.
  auto.
  intros ; destruct c ; auto.
  intros ; destruct c ; auto.
Defined.

(** In fact, not all monads we want to define will satisfy
    these laws. In particular, the requirement of equality above
    causes trouble when the monad contains functions, as in the
    case of the state monad. We can get around that difficulty
    by parameterizing the monad laws with an equivalence relation
    that captures the notion of equality we want to use.
*)


Require Export Arith.EqNat.
Require Export Arith.Le.
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.

(* The bdestruct tactic is borrowed from https://softwarefoundations.cis.upenn.edu/vfa-current/Perm.html *)

Lemma beq_reflect : forall x y, reflect (x = y) (x =? y).
Proof.
  intros x y.
  apply iff_reflect. symmetry. apply beq_nat_true_iff.
Qed.

Lemma blt_reflect : forall x y, reflect (x < y) (x <? y).
Proof.
  intros x y.
  apply iff_reflect. symmetry. apply Nat.ltb_lt.
Qed.

Lemma ble_reflect : forall x y, reflect (x <= y) (x <=? y).
Proof.
  intros x y.
  apply iff_reflect. symmetry. apply Nat.leb_le.
Qed.
#[global] Hint Resolve blt_reflect ble_reflect beq_reflect : bdestruct.

Ltac bdestruct X :=
  let H := fresh in let e := fresh "e" in
                    evar (e: Prop);
                    assert (H: reflect e X); subst e;
                    [eauto with bdestruct
                    | destruct H as [H|H];
                      [ | try first [apply not_lt in H | apply not_le in H] ] ].


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Require Import Arith.
From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint eqb (n m: natural) : bool :=
  match n, m with
    | Zero, Zero => true
    | Zero, Succ _ => false
    | Succ _, Zero => false
    | Succ n', Succ m' => eqb n' m'
  end.

  Fixpoint mem  (mem_arg1 : lst) (mem_arg0 : natural)
  := match mem_arg0, mem_arg1 with
    | x, Nil => false
    | x, Cons y z => orb (eqb x y) (mem z x)
    end.

Fixpoint less (less_arg0 : natural) (less_arg1 : natural) : bool
           := match less_arg0, less_arg1 with
              | x, Zero => false
              | Zero, Succ x => true
              | Succ x, Succ y => less x y
              end.

Fixpoint insort  (insort_arg1 : lst) (insort_arg0 : natural) : lst
           := match insort_arg1, insort_arg0 with
              |  Nil, i => Cons i Nil
              | Cons x y, i => if less i x then Cons i (Cons x y) else Cons x (insort y i)
              end.

Fixpoint sort (sort_arg0 : lst) : lst
           := match sort_arg0 with
              | Nil => Nil
              | Cons x y => insort (sort y) x
              end.

Lemma Nat_beq_refl : forall (n : natural), eqb n n = true.
Proof.
   intros.
   induction n.
   - assumption.
   - reflexivity.
Qed.

Theorem theorem0 : forall (x : natural) (y : lst), eq (mem (insort  y x) x) true.
Proof.
   intros.
  induction y.
  - simpl. destruct (less x n).
    + simpl. rewrite Nat_beq_refl. reflexivity.
    + simpl. rewrite IHy. apply Bool.orb_true_r.
  - simpl. lfind.  reflexivity.
Admitted.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrbool.
Require Import funs.
Require Import dataset.
Require Import ssrnat.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* ``Dyck numbers'', i.e., the number of balanced bracket words of length n. *)
(* (In fact, we define generalized Dyck numbers, that allow for m-1 extra    *)
(* closing brackets.) Dyck numbers are the only link between the initial     *)
(* color and (chromo)gram trees.                                             *)

Fixpoint gen_dyck (m n : nat) {struct n} : nat :=
  match n, m with
  | O, S O => 1
  | S n', S m' => gen_dyck (S m) n' + gen_dyck m' n'
  | _, _ => 0
  end.

Definition dyck : nat -> nat := gen_dyck 1.

Lemma gen_dyck_max : forall m n, S n < m -> gen_dyck m n = 0.
Proof.
move=> m n; elim: n m => [|n Hrec] [|m] //; first by case m.
move=> Hm; rewrite /= !Hrec //; exact (leq_trans (leq_addl 2 n) Hm).
Qed.

Lemma gen_dyck_all_close : forall m, gen_dyck (S m) m = 1.
Proof.
elim=> [|m Hrec] //=; rewrite Hrec gen_dyck_max //; exact (leqnSn m).
Qed.

Lemma even_dyck_pos : forall n, 0 < dyck (double n).
Proof.
move=> n; rewrite /dyck -(addn0 (double n)).
elim: n {-1}0 => [|n Hrec] m; first by rewrite gen_dyck_all_close.
rewrite doubleS addSnnS addSn; exact (leq_trans (Hrec _) (leq_addr _ _)).
Qed.

Unset Implicit Arguments.


From mathcomp Require Import ssreflect.
Require Import NPeano ZArith.
From Coquelicot Require Import Coquelicot.
Require Import Reals Field Psatz Plouffe CPlouffe Million0.

(*
Time Eval native_compute in sumV cprecision cdigit 5.
*)

Definition comp3 := 39136890.

Lemma comp3_def : comp3 = sumV cprecision cdigit 5.
Proof.
native_cast_no_check (refl_equal comp3).
Time Qed.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

Require Import definition.
Require Import Tactiques.
Require Import Axiomes.
Require Import Lemmes_generaux.
Require Import Lemmes.
Require Import Rbase_doubles_inegalites.

Lemma lemme_oppose :
 forall (x : R) (xc : Reelc),
 encadrement xc x -> encadrement (oppose_reelc xc) (- x).

Proof.
intros x xc.
unfold encadrement in |- *.
unfold oppose_reelc in |- *.
intros.
generalize (H n); clear H; intro H.
rewrite Ropp_mult_distr_l_reverse.
rewrite <- Ropp_minus_distr'.
rewrite Ropp_Ropp_IZR.
RingReplace (1 - - IZR (xc n))%R (IZR (xc n) + 1)%R.
RingReplace (- IZR (xc n) + 1)%R (- (IZR (xc n) - 1))%R.
apply Rlt_2_Ropp_r.
assumption.
Qed.