(** * ARNDefiniciones.v
Este archivo contiene lemas y definiciones que definen Arboles Rojinegros.
Tambien contiene definiciones y lemas que se comparten entre las funciones de
agregar y eliminar elementos.
*)

Generalizable All Variables.

Require Export Utf8_core.
Require Import Coq.Classes.RelationClasses.
Unset Implicit Arguments.
Set Maximal Implicit Insertion.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Require Import Coq.Program.Equality.

Require Coq.Program.Tactics.
Require Coq.Program.Wf.

(* Converted imports: *)

Require GHC.Base.
Require GHC.Err.
Import GHC.Base.Notations.

(* Converted type declarations: *)

(** ** Definicion Arboles Rojinegros
Las siguientes definiciones son los tipos basicos de un Arbol Rojinegro.
*)
Inductive Color : Type := R : Color |  B : Color.

Inductive RB a : Type := E : RB a |  T : Color -> (RB a) -> a -> (RB a) -> RB a.

(* Tree for insert*)
Arguments E {_}.
Arguments T {_} _ _ _ _.

Instance Default__Color : GHC.Err.Default Color := GHC.Err.Build_Default _ R.

(** ** Estas definiciones son auxiliares para eliminar y agregar

*** makeBlack
Esta funcion pinta la raiz de un arbol de color negro.
*)
Definition makeBlack {a} `{GHC.Base.Ord a} (t:RB a) :=
 match t with
 | E => E
 | T _ a x b => T B a x b
 end.

Hint Unfold makeBlack.

(** *** makeRed
Esta funcion pinta la raiz de un arbol de color rojo.
 *)
Definition makeRed {a} `{GHC.Base.Ord a} (t:RB a) :=
 match t with
 | E => E
 | T _ a x b => T R a x b
 end.

Hint Unfold makeRed.

(** *** lbal
Funcion de balanceo para los subarboles izquierdos.
 *)
Definition lbal {a} `{GHC.Base.Ord a} (l:RB a) (k:a) (r:RB a) :=
 match l with
 | T R (T R a x b) y c => T R (T B a x b) y (T B c k r)
 | T R a x (T R b y c) => T R (T B a x b) y (T B c k r)
 | _ => T B l k r
 end.

Hint Resolve lbal.

(** *** rbal
Funcion de balanceo para los subarboles derechos.
 *)
Definition rbal {a} `{GHC.Base.Ord a} (l:RB a) (k:a) (r:RB a) :=
 match r with
 | T R (T R b y c) z d => T R (T B l k b) y (T B c z d)
 | T R b y (T R c z d) => T R (T B l k b) y (T B c z d)
 | _ => T B l k r
 end.

Hint Resolve rbal.

(** *** isblack, notblack, notred
Definiciones booleanas para saber el color de un arbol.
 *)
Definition isblack {a} `{GHC.Base.Ord a} (t : RB a) :=
 match t with T B _ _ _ => True | _ => False end.

Definition notblack {a} `{GHC.Base.Ord a} (t : RB a) :=
 match t with T B _ _ _ => False | _ => True end.

Definition notred {a} `{GHC.Base.Ord a} (t : RB a) :=
 match t with T R _ _ _ => False | _ => True end.

(** ** Invariantes
*** is_redblack
Esta funcion inductiva cuenta la cantidad de nodos negros de la raiz a las hojas,
de manera que se cumplan las invariantes de un arbol rojinegro, como son que la raiz
es negra y que no puede haber dos nodos rojos juntos.
 *)

(* definicion inductiva que ayuda a verificar que un arbol es rojinegro al llevar un contador de la altura
negra del arbol
 *)
(* dos nodos sucesivos NO pueden ser rojos *)
Inductive is_redblack {a} `{GHC.Base.Ord a} : nat -> RB a -> Prop :=
 | RB_Leaf : is_redblack 0 E
 | RB_R n l k r :
   notred l -> notred r -> is_redblack n l -> is_redblack n r -> is_redblack n (T R l k r)
 | RB_B n l k r : is_redblack n l -> is_redblack n r -> is_redblack (S n) (T B l k r).

Hint Constructors is_redblack.

(** *** redred_tree
Como lo dice el nombre de esta definicion, esta permite que haya dos nodos rojos consecutivos,
exactamente en la raiz del arbol que se le pasa.
 *)
Inductive redred_tree {a} `{GHC.Base.Ord a} (n:nat) : RB a -> Prop :=
 | RR_Rd l k r : is_redblack n l -> is_redblack n r -> redred_tree n (T R l k r).

(** *** nearly_redblack
Definicion inductiva que sirve como auxiliar al momento de las demostraciones, es un poco mas laxa con una invariante
de los arboles rojinegros, ya que permite que la raiz sea roja y que haya dos rojos a lo mas en la raiz del arbol.
 *)
Inductive nearly_redblack {a} `{GHC.Base.Ord a} (n:nat)(t:RB a) : Prop :=
 | ARB_RB : is_redblack n t -> nearly_redblack n t
 | ARB_RR : redred_tree n t -> nearly_redblack n t.

Class redblack {a} `{GHC.Base.Ord a} (t:RB a) := RedBlack : exists d, is_redblack d t.

(** ** Lemas...
*** lbal_rb
Este lema enuncia que si se tiene un arbol izquierdo que es _casi- rojinegro
y un arbol derecho que es rojinegro, al balancearlos con un elemento k con la funcion
lbal, resulta un arbol roinegro.
 *)
Lemma lbal_rb {a} `{GHC.Base.Ord a} (n:nat) (l:RB a) (k:a) (r:RB a) :
 nearly_redblack n l -> is_redblack n r -> is_redblack (S n) (lbal l k r).
Proof.
intros.
destruct l.
simpl.
constructor.
inversion H1.
trivial.
inversion H3.
trivial.
simpl.
destruct c.
destruct l1.
destruct l2.
constructor;trivial.
inversion H1.
trivial.
inversion H3.
constructor;simpl;trivial.
destruct c.
constructor;simpl;trivial.
inversion H1.
inversion H3.
subst.
constructor;trivial.
inversion H11.
trivial.
inversion H3.
constructor;trivial.
inversion H8.
trivial.
inversion H1.
inversion H3.
inversion H9.
inversion H3.
inversion H8.
constructor;trivial.
inversion H1.
inversion H3.
constructor;trivial.
constructor;trivial.
inversion H3.
constructor;simpl;trivial.
destruct c.
inversion H1.
inversion H3.
subst.
constructor;simpl;trivial.
inversion H10.
constructor;trivial.
constructor;trivial.
inversion H3.
constructor;simpl;trivial.
inversion H6.
constructor;trivial.
constructor;trivial.
destruct l2.
inversion H1.
inversion H3.
constructor;trivial.
constructor;trivial.
inversion H3.
inversion H6.
constructor;simpl;trivial.
constructor;trivial.
subst;trivial.
destruct c.
inversion H1.
inversion H3.
constructor;simpl;trivial.
constructor;trivial.
inversion H11;trivial.
constructor.
inversion H11;trivial.
trivial.
inversion H3.
constructor;simpl;trivial.
constructor;trivial.
inversion H8;trivial.
constructor.
inversion H8;trivial.
trivial.
inversion H1.
inversion H3.
constructor;simpl;trivial.
constructor;trivial.
inversion H3.
constructor;simpl;trivial.
constructor;trivial.
inversion H1.
trivial.
inversion H3.
Qed.

(** *** rbal_rb
Este lema enuncia basicamente lo mismo que lbal_rb pero ahora con los arboles del
lado derecho.
 *)
Lemma rbal_rb {a} `{GHC.Base.Ord a} (n:nat) (l:RB a) (k:a) (r:RB a) :
 is_redblack n l -> nearly_redblack n r -> is_redblack (S n) (rbal l k r).
Proof.
intros.
destruct r.
simpl.
constructor.
trivial.
inversion H2.
trivial.
inversion H3.
simpl.
destruct c.
destruct r1.
destruct r2.
constructor.
exact H1.
inversion H2.
exact H3.
inversion H3.
constructor;simpl;trivial.
destruct c.
constructor;simpl;trivial.
inversion H2.
constructor.
exact H1.
inversion H3.
exact H10.
constructor.
exact H1.
inversion H3.
exact H6.
inversion H2.
inversion H3.
constructor.
inversion H11.
exact H18.
inversion H11.
exact H19.
inversion H3.
constructor.
inversion H8.
exact H15.
inversion H8.
exact H16.
inversion H2.
constructor.
exact H1.
exact H3.
constructor.
exact H1.
inversion H3.
constructor.
simpl;trivial.
simpl;trivial.
exact H6.
exact H8.
destruct c.
inversion H2.
constructor.
simpl;trivial.
simpl;trivial.
inversion H3.
constructor.
exact H1.
inversion H10.
exact H18.
constructor.
inversion H3.
inversion H10.
exact H19.
inversion H3.
exact H11.
inversion H3.
constructor.
simpl;trivial.
simpl;trivial.
constructor.
exact H1.
inversion H6.
exact H15.
constructor.
inversion H6.
exact H16.
exact H8.
destruct r2.
inversion H2.
constructor.
exact H1.
exact H3.
inversion H3.
constructor;simpl;trivial.
constructor;simpl;trivial.
destruct c.
inversion H2.
inversion H3.
constructor;simpl;trivial.
constructor.
exact H1.
exact H10.
constructor.
inversion H11.
exact H18.
inversion H11.
exact H19.
inversion H3.
constructor.
constructor;simpl;trivial.
constructor;simpl;trivial.
constructor.
exact H1.
exact H6.
inversion H8.
constructor.
exact H15.
exact H16.
inversion H2.
inversion H3.
constructor;simpl;trivial.
inversion H3.
constructor.
exact H1.
constructor.
constructor;simpl;trivial.
constructor;simpl;trivial.
exact H6.
exact H8.
inversion H2.
constructor.
exact H1.
exact H3.
inversion H3.
Qed.

(** *** Lema makeBlack_rb
Este lema enuncia que si se tiene un arbol casi rojinegro y se pinta su raiz de negro, este se vuelve un arbol rojinegro.
*)
Lemma makeBlack_rb {a} `{GHC.Base.Ord a} n t :
nearly_redblack n t -> redblack (makeBlack t).
Proof.
destruct t.
exists 0.
simpl;trivial.
destruct 1.
inversion H1.
exists (S n).
simpl.
constructor.
exact H9.
exact H10.
exists (S n0).
simpl.
constructor.
exact H5.
exact H8.
exists (S n).
simpl.
inversion H1.
constructor.
exact H4.
exact H7.
Qed.

(** *** Lema makeRed_rr
Este lema enuncia que si se tiene un arbol rojinegro y se pinta su raiz de rojo, este se vuelve un arbol casi rojinegro.
*)
Lemma makeRed_rr {a} `{GHC.Base.Ord a} t n :
 is_redblack (S n) t -> notred t -> redred_tree n (makeRed t).
Proof.
destruct t.
inversion 1.
inversion 1.
simpl;contradiction.
intro.
constructor.
exact H5.
exact H8.
Qed.


Require Import ZArith Psatz List.
Require Import MathClasses.interfaces.canonical_names.
Require Import ExtLib.Structures.Monad.

Require Import Helix.Tactics.StructTactics.
Require Import Helix.Util.OptionSetoid.

Require Import Helix.DSigmaHCOL.DSigmaHCOL.
Require Import Helix.DSigmaHCOL.DSigmaHCOLEval.
Require Import Helix.DSigmaHCOL.DHCOLTypeTranslator.

Require Import Helix.FSigmaHCOL.Float64asCT.
Require Import Helix.FSigmaHCOL.Int64asNT.
Require Import Helix.FSigmaHCOL.FSigmaHCOL.

Require Import Helix.SymbolicDHCOL.SymbolicCT.

Import ListNotations.

Module Export SFHCOL <: MDSigmaHCOL(MSymbolicCT)(MInt64asNT).
  Include MDSigmaHCOL MSymbolicCT MInt64asNT.
End SFHCOL.

Module Export SFHCOLEval <: MDSigmaHCOLEval(MSymbolicCT)(MInt64asNT)(SFHCOL).
  Include MDSigmaHCOLEval MSymbolicCT MInt64asNT SFHCOL.
End SFHCOLEval.

Module Export FHCOLtoSFHCOL := MDHCOLTypeTranslator
                                 (MFloat64asCT)
                                 (MSymbolicCT)
                                 (MInt64asNT)
                                 (MInt64asNT)
                                 (FHCOL)
                                 (SFHCOL)
                                 (FHCOLEval)
                                 (SFHCOLEval).

Definition FloatEnv := list MFloat64asCT.t.

(* No use for fancier monads *)
Fixpoint evalFloatSExpr (e : FloatEnv) (f : SExpr) : option MFloat64asCT.t :=
  match f with
  | SVar i       => (nth_error e i)
  | SConstZero   => Some MFloat64asCT.CTypeZero
  | SConstOne    => Some MFloat64asCT.CTypeOne
  | SNeg   f     =>
      liftM  MFloat64asCT.CTypeNeg   (evalFloatSExpr e f)
  | SAbs   f     =>
      liftM  MFloat64asCT.CTypeAbs   (evalFloatSExpr e f)
  | SPlus  f1 f2 =>
      liftM2 MFloat64asCT.CTypePlus  (evalFloatSExpr e f1) (evalFloatSExpr e f2)
  | SMult  f1 f2 =>
      liftM2 MFloat64asCT.CTypeMult  (evalFloatSExpr e f1) (evalFloatSExpr e f2)
  | SZLess f1 f2 =>
      liftM2 MFloat64asCT.CTypeZLess (evalFloatSExpr e f1) (evalFloatSExpr e f2)
  | SMin   f1 f2 =>
      liftM2 MFloat64asCT.CTypeMin   (evalFloatSExpr e f1) (evalFloatSExpr e f2)
  | SMax   f1 f2 =>
      liftM2 MFloat64asCT.CTypeMax   (evalFloatSExpr e f1) (evalFloatSExpr e f2)
  | SSub   f1 f2 =>
      liftM2 MFloat64asCT.CTypeSub   (evalFloatSExpr e f1) (evalFloatSExpr e f2)
  end.

Definition heq_Float_SExpr
  (env : FloatEnv)
  (f : MFloat64asCT.t)
  (sf : MSymbolicCT.t)
  : Prop :=
  evalFloatSExpr env sf ≡ Some f.

Global Instance FSF_CHE : FHCOLtoSFHCOL.CTranslation_heq FloatEnv.
Proof.
  econstructor.
  -
    instantiate (1:=heq_Float_SExpr).
    intros f1 f2 F lf1 lf2 LF.
    invc F; invc LF.
    easy.
  -
    intros * T *.
    unfold translateCTypeConst in *.
    repeat break_if; invc T.
    all: now rewrite e, <-H1.
Defined.

Global Instance FSF_COP : @FHCOLtoSFHCOL.COpTranslationProps FloatEnv FSF_CHE.
Proof.
  do 2 constructor.
  all: intros * XE; try intro YE.
  all: unfold heq_CType', FSF_CHE, heq_Float_SExpr in *.
  all: cbn.
  all: now rewrite ?XE, ?YE.
Qed.

(* Trivial instances for "translating" Int64 -> Int64 *)
Instance FSF_NHE : FHCOLtoSFHCOL.NTranslation_heq.
Proof.
  econstructor.
  -
    instantiate (1:=eq).
    intros i1 i2 I i1' i2' I'.
    invc I. invc I'.

    pose proof Int64.eq_spec i1 i2 as I.
    rewrite H0 in I.
    subst.

    pose proof Int64.eq_spec i1' i2' as I'.
    rewrite H1 in I'.
    subst.

    easy.
  -
    intros * T.
    unfold translateNTypeConst, MInt64asNT.from_nat, MInt64asNT.to_nat in *.
    rewrite Znat.Z2Nat.id in *
      by (pose proof Integers.Int64.intrange x; lia).

    unfold MInt64asNT.from_Z in *.
    repeat break_match; invc T.
    pose proof Int64.eq_spec
               {| Int64.intval := Int64.intval x; Int64.intrange := conj l l0 |}
               x'.
    rewrite H1 in H.
    clear H1.
    rewrite <-H.
    destruct x.
    f_equal.
    apply proof_irrelevance.
Defined.

Instance FSF_NTP : FHCOLtoSFHCOL.NTranslationProps.
Proof.
  constructor.
  -
    intros.
    unfold heq_NType, FSF_NHE in *.
    congruence.
  -
    intros.
    unfold heq_NType, FSF_NHE in *.
    destruct (MInt64asNT.from_nat n);
      repeat constructor.
Qed.

Instance FSF_NOP : FHCOLtoSFHCOL.NOpTranslationProps.
Proof.
  do 2 constructor; intros.
  all: unfold heq_NType, FSF_NHE in *.
  all: congruence.
Qed.

Lemma FHCOLtoSFHCOL_semantic_preservation
  (op : FHCOL.DSHOperator) (op' : SFHCOL.DSHOperator)
  (σ : FHCOLEval.evalContext) (σ' : evalContext)
  (imem : FHCOL.memory) (imem' : SFHCOL.memory)
  :
  forall env,
    FHCOLtoSFHCOL.heq_DSHOperator env FSF_NHE FSF_CHE op op' →
    FHCOLtoSFHCOL.heq_evalContext env FSF_NHE FSF_CHE σ σ' →
    FHCOLtoSFHCOL.heq_memory env FSF_CHE imem imem' →
    hopt_r (ErrorSetoid.herr_c (FHCOLtoSFHCOL.heq_memory env FSF_CHE))
      (FHCOLEval.evalDSHOperator σ op imem (FHCOLEval.estimateFuel op))
      (SFHCOLEval.evalDSHOperator σ' op' imem' (SFHCOLEval.estimateFuel op')).
Proof.
  intros * OPE ΣE ME.
  eapply FHCOLtoSFHCOL.translation_semantics_correct_strict.
  all: auto using FSF_NTP, FSF_NOP, FSF_COP.
Qed.


Require Import ExtLib.Tactics.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.Lambda.Rewrite.Core.

Set Implicit Arguments.
Set Strict Implicit.

Set Suggest Proof Using.

Section setoid.
  Context {typ : Set}.
  Context {func : Set}.
  Context {RType_typD : RType typ}.
  Context {Typ2_Fun : Typ2 RType_typD RFun}.
  Context {RSym_func : RSym func}.

  (** Reasoning principles **)
  Context {RTypeOk_typD : RTypeOk}.
  Context {Typ2Ok_Fun : Typ2Ok Typ2_Fun}.
  Context {RSymOk_func : RSymOk RSym_func}.
  Context {Typ0_Prop : Typ0 _ Prop}.

  Local Existing Instance Subst_ctx_subst.
  Local Existing Instance SubstOk_ctx_subst.
  Local Existing Instance SubstUpdate_ctx_subst.
  Local Existing Instance SubstUpdateOk_ctx_subst.
  Local Existing Instance Expr_expr.
  Local Existing Instance ExprOk_expr.

  (* TODO(gmalecha): Wrap all of this up in a type class?
   * Why should it be different than Expr?
   *)
  Variable Rbase : Set.
  Variable Rbase_eq : Rbase -> Rbase -> bool.
  Hypothesis Rbase_eq_ok : forall a b, Rbase_eq a b = true -> a = b.

  Local Notation "'R'" := (R typ Rbase).

  Variable RbaseD : Rbase -> forall t : typ, option (typD t -> typD t -> Prop).

  (** Apply the same rewrite until it stops making progress
   **)

  Variable rw : RwAction typ func Rbase.
  Variable is_refl : refl_dec R.
  Variable is_trans : trans_dec R.

  Local Fixpoint repeat_rewrite' (n : nat)
           (prog : expr typ func -> Progressing (expr typ func))
           (e : expr typ func) (r : R)
  : mrw typ func (Progressing (expr typ func)) :=
    match n with
    | 0 => if is_refl r
           then rw_ret (prog e)
           else rw_fail
    | S n => rw_bind_catch
               (rw e r)
               (fun e' =>
                  match e' with
                  | NoProgress =>
                    if is_refl r then rw_ret (prog e) else rw_fail
                  | Progress e' as X =>
                    if is_trans r then repeat_rewrite' n (@Progress _) e' r
                    else rw_ret X
                  end)
               (if is_refl r
                then rw_ret (prog e)
                else rw_fail)
    end.

  Hypothesis rw_sound : setoid_rewrite_spec RbaseD rw.
  Hypothesis is_reflOk : refl_dec_ok (RD RbaseD) is_refl.
  Hypothesis is_transOk : trans_dec_ok (RD RbaseD) is_trans.

  Local Lemma repeat_rewrite'_mono : forall n e r c E F X Y,
      repeat_rewrite' (c:=c) n (@Progress _) e r E F = Some (X,Y) ->
      X <> NoProgress.
  Proof using.
    induction n; simpl.
    { intros. destruct (is_refl r). inversion H. congruence. inversion H. }
    { intros.
      eapply rw_bind_catch_case in H. destruct H; forward_reason.
      { destruct x.
        { destruct (is_trans r); eauto.
          inversion H0. congruence. }
        { destruct (is_refl r).
          { inversion H0; congruence. }
          { inversion H0. } } }
      { destruct (is_refl r).
        { inversion H; congruence. }
        { inversion H. } } }
  Qed.

  Local Theorem repeat_rewrite'_sound
  : forall n (prog : bool),
      setoid_rewrite_spec
        RbaseD
        (repeat_rewrite' n
                         (if prog then @Progress _ else (fun _ => NoProgress))).
  Proof using is_reflOk is_transOk rw_sound.
    induction n.
    { intros. simpl. destruct prog.
      { do 2 red. intros.
        specialize (@is_reflOk r).
        destruct (is_refl r).
        { inversion H; clear H; subst.
          split; auto.
          intros.
          eapply is_reflOk in H; trivial.
          simpl.
          forward.
          split; [ reflexivity | ].
          intros. eapply Pure_pctxD; eauto. }
        { inversion H. } }
      { do 2 red; intros.
        specialize (@is_reflOk r).
        destruct (is_refl r).
        { inversion H; clear H; subst.
          split; auto.
          intros.
          eapply is_reflOk in H; eauto.
          simpl. forward.
          split; [ reflexivity | ].
          intros; eapply Pure_pctxD; eauto. }
        { inversion H. } } }
    { simpl. do 2 red; intros.
      eapply rw_bind_catch_case in H; destruct H; forward_reason.
      { eapply rw_sound in H.
        forward_reason. destruct x.
        { specialize (@is_transOk r).
          destruct (is_trans r).
          { generalize (repeat_rewrite'_mono _ _ _ _ _ H1).
            eapply (IHn true) in H1.
            forward_reason. split; auto.
            intros.
            specialize (H3 _ _ H5).
            specialize (H2 _ _ H5).
            simpl in *.
            forward.
            forward_reason.
            destruct e'; simpl in *.
            { Cases.rewrite_all_goal.
              split; [ reflexivity | ].
              intros. gather_facts.
              eapply pctxD_SubstMorphism; [ | | eassumption | ]; eauto.
              gather_facts.
              eapply is_transOk in H5; eauto.
              eapply Pure_pctxD; eauto. }
            { congruence. } }
          { inversion H1; clear H1; subst.
            simpl in *. split; auto. } }
        { specialize (@is_reflOk r).
          destruct (is_refl r); [ | inversion H1 ].
          inversion H1; clear H1; subst.
          split; auto.
          intros. specialize (H2 _ _ H1).
          forward. destruct prog; simpl in *.
          { rewrite H5. forward_reason.
            split; auto. }
          { rewrite H5; forward_reason; auto. } } }
      { specialize (@is_reflOk r).
        destruct (is_refl r); [ | inversion H ].
        inversion H; clear H; subst.
        split; auto.
        intros.
        forward.
        cutrewrite (ProgressD e
                              ((if prog then (@Progress _)
                                else fun _ : expr typ func => NoProgress) e) = e);
          [ | destruct prog; reflexivity ].
        rewrite H3; forward_reason.
        split; [ reflexivity | ].
        eapply is_reflOk in H; eauto.
        eapply Pure_pctxD; eauto. } }
  Qed.

  Definition repeat_rewrite (progress : bool)
  : nat -> RwAction typ func Rbase :=
    let prog := if progress then @Progress _ else (fun _ => NoProgress) in
    fun n =>
      repeat_rewrite' n prog.

  Theorem repeat_rewrite_sound
  : forall b n, setoid_rewrite_spec RbaseD (repeat_rewrite b n).
  Proof using is_reflOk is_transOk rw_sound.
    unfold repeat_rewrite. simpl. intros.
    eapply repeat_rewrite'_sound.
  Qed.

End setoid.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq.
From fourcolor Require Import cfmap cfreducible configurations.

(******************************************************************************)
(* Reducibility of configurations number 531 to 534, whose indices in         *)
(* the_configs range over segment [530, 534).                                 *)
(******************************************************************************)

Lemma red530to534 : reducible_in_range 530 534 the_configs.
Proof. CheckReducible. Qed.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq.
From fourcolor Require Import cfmap cfreducible configurations.

(******************************************************************************)
(* Reducibility of configurations number 303 to 306, whose indices in         *)
(* the_configs range over segment [302, 306).                                 *)
(******************************************************************************)

Lemma red302to306 : reducible_in_range 302 306 the_configs.
Proof. CheckReducible. Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall Qprime Cprime P Q Aprime C A X Y Z : Universe, ((wd_ Qprime Cprime /\ (wd_ Cprime P /\ (wd_ P Q /\ (wd_ Qprime Q /\ (wd_ Qprime P /\ (wd_ Cprime Q /\ (wd_ Aprime P /\ (wd_ Q Aprime /\ (wd_ Aprime A /\ (wd_ Cprime C /\ (wd_ P A /\ (wd_ P C /\ (wd_ Q C /\ (wd_ C A /\ (wd_ Cprime Aprime /\ (wd_ X Y /\ (wd_ A Q /\ (wd_ P Y /\ (wd_ Y Z /\ (wd_ Z Q /\ (wd_ X P /\ (col_ P Q Z /\ (col_ P A Y /\ (col_ Aprime P A /\ (col_ Cprime P C /\ (col_ P C Y /\ col_ P A X)))))))))))))))))))))))))) -> col_ P C A)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

Require Export eLift.
Require Export SD.
Require Export SD_Others.

Set Implicit Arguments.

(*********************** SOME AUXILIARY STUFF ***********************)
(********************************************************************)

 Definition uncurry (A B C:Type) (f : A -> B -> C) : A * B -> C :=
  fun ab => f (fst ab) (snd ab).

 Lemma discr_srange: forall (A:Type) (d:Distr A)
  (Hdiscr: is_Discrete d) (carA: A -> MF A),
  (forall a, cover (fun x => a = x) (carA a)) ->
  srange (fun a => exc (fun k => a = D_points Hdiscr k) /\ ~ mu d (carA a) == 0) d.
 Proof.
  intros.
  split.
    (* range *)
    intros f Hf.
    rewrite (mu_is_Discrete _ H Hdiscr); destruct Hdiscr; simpl in *.
    symmetry; apply serie_zero.
    intro k.
    apply (Ueq_orc (mu d (carA (D_points k))) 0); [ auto | | ]; intro Hk.
      unfold coeff; rewrite Hk; repeat Usimpl; trivial.
      rewrite <-Hf; [ auto | ];
        split; [ apply exc_intro with k | ]; trivial.
    (* drange *)
    intro f.
    rewrite (mu_is_Discrete _ H Hdiscr).
    intros Hf a [H1 H2]; simpl in *.
    generalize (serie_zero_elim _ (Oeq_sym Hf)); clear Hf; intro Hf.
    assert (H': exc (In_class eq (D_points Hdiscr) a)).
      apply H1;[auto | ].
      induction x using Wf_nat.lt_wf_ind; intros.
      apply (cover_elim (cover_not_first_repr _ _ H (D_points Hdiscr)) x);
        [ auto | | ]; intros [H5 H6].
        apply exc_intro with x.
        split; [ | red;intros;elim H5;apply exc_intro with k0];auto.
        apply H5;[auto | ].
        intros m (H7, H8);apply (H0 m); [ | rewrite <-H8 ]; auto.
    clear H1; apply H'; [ auto | intros k [Hk Hk']; subst; clear H' ].
    apply (Umult_zero_simpl_right (Oeq_sym (Hf k))).
    apply (cover_elim  (cover_not_first_repr _ _ H (D_points Hdiscr)) k);
      [ auto | | ]; intros [H4 H5].
      unfold coeff; rewrite H5; repeat Usimpl; auto.
      apply H4; [auto | intros k2 [Hk2 Hk2'] ]; generalize (Hk' _ Hk2); tauto.
 Qed.

 Lemma discr_ext: forall (A:Type) (d1 d2: Distr A),
   (forall f, mu d1 f == 0 -> mu d2 f == 0) ->
   is_Discrete d1 ->
   is_Discrete d2.
 Proof.
  intros A d1 d2 Hd [p Hdis1].
  apply mkDiscr with p.
  unfold Discrete in *.
  intros f Hf.
  symmetry; apply Hd.
  symmetry; apply (Hdis1 _ Hf).
 Qed.

(* Given a distribution on a product, if both projections  *
 * are discrete, then the distribution is discrete.        *)
Section DISCRETE.

 Variables A B: Type.

 Variable carB : B -> MF B.
 Variable carA : A -> MF A.

 Hypothesis carB_prop : forall b, cover (fun x => b = x) (carB b).
 Hypothesis carA_prop : forall a, cover (fun x => a = x) (carA a).

 Variable d  : Distr (A * B).

 Hypothesis discr_d1: is_Discrete (Mlet d (fun ab => Munit (fst ab))).
 Hypothesis discr_d2: is_Discrete (Mlet d (fun ab => Munit (snd ab))).

 Lemma discr_projs: is_Discrete d.
 Proof.
  destruct discr_d1 as [p1 H1].
  destruct discr_d2 as [p2 H2].
  apply mkDiscr with (fun k => (p1 (fst (bij_n_nxn k)), p2 (snd (bij_n_nxn k)))).
  unfold Discrete, range in *; simpl in *.
  intros f Hf.
  rewrite (d_ito_p2_d _ carB_prop discr_d2); simpl.
  apply H2 with (f:= fun b =>
      (mu d) (fun ab : A * B => carB b (snd ab) * f ab) /
      (mu d) (fun ab : A * B => carB b (snd ab))).
  intros b Hb; apply Hb; [ auto | intros kb Hkb ].
  symmetry; apply Udiv_zero_eq.

  transitivity (mu (d_inv d) (fun ba => carB b (fst ba) * f (snd ba, fst ba)));
    [ | simpl; apply (mu_stable_eq d); refine (ford_eq_intro _); intros (a',b'); auto ].
  rewrite (d_ito_p2_d _ carA_prop); [ simpl |
    refine (is_Discrete_eq_compat _  discr_d1); auto ].
  apply H1 with (f:= fun a  => mu d
    (fun ab => carA a (fst ab) * (carB b (snd ab) * f (fst ab, snd ab))) /
    mu d (fun ab => carA a (fst ab))).
  intros a Ha; apply Ha; [ auto | intros ka Hka ].
  symmetry; apply Udiv_zero_eq.

  rewrite <-(mu_zero d); unfold fzero;
  apply mu_stable_eq; refine (ford_eq_intro _).
  intros (a',b'); simpl.
  apply (cover_elim (carB_prop b) b'); [ auto | | ]; intros [H4 H5].
    rewrite H5; repeat Usimpl; trivial.
    rewrite H5, <-H4; Usimpl; clear H4 H5.
    apply (cover_elim (carA_prop a) a'); [ auto | | ]; intros [H4 H5].
      rewrite H5; repeat Usimpl; trivial.
      rewrite H5, <-H4; Usimpl; clear H4 H5.
      apply Hf.
      destruct (bij_surj ka kb) as [k Hk].
      apply exc_intro with k.
      rewrite Hk; simpl; rewrite Hkb, Hka; trivial.
 Qed.

End DISCRETE.

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

Module Make (SemO:SEM_OPT).

 Module OPT2 := SD_Others.Make SemO.
 Export OPT2.

 Set Implicit Arguments.

 Definition eequiv (P:mem_rel) E1 c1 E2 c2 (Q:mem_rel) (ep:nat-o>U) :=
  forall k, exists d,
   forall (m1 m2 : Mem.t k),
   P _ m1 m2 ->
   elift (@Q k) (d m1 m2) ([[c1]] E1 m1)  ([[c2]] E2 m2) (ep k).

 Lemma eequiv_deno: forall (P:mem_rel) E1 c1 E2 c2 (Q:mem_rel) ep,
  eequiv P E1 c1 E2 c2 Q ep -> prg_SD P E1 c1 E2 c2 Q ep.
 Proof.
  unfold eequiv, prg_SD; intros.
  destruct (H k) as [d Hd]; clear H.
  apply elift_dist with (Q k) (d m1 m2); auto.
 Qed.

 Lemma eequiv_sdeno: forall c1 E1 c2 E2 (P Q: mem_rel) ep,
   decMR P ->
   eequiv P E1 c1 E2 c2 Q ep ->
   forall k (d1 d2 : Distr(Mem.t k)) (del:nat -o> U),
   (exists d, elift (@P k) d d1 d2 (del k) /\ exists R, srange R d) ->
   forall f g,
   (forall m1 m2 : Mem.t k, Q k m1 m2 -> f m1 == g m2) ->
   Uabs_diff (mu (Mlet d1 ([[c1]] E1)) f) (mu (Mlet d2 ([[c2]] E2)) g) <= (ep k + del k).
 Proof.
  intros.
  destruct H0 as [d [Hd HdR] ].
  destruct (H k) as [d' Hd']; clear H.
  apply elift_dist with (R:=Q k) (d:=Mlet d (fun mm => d' (fst mm) (snd mm))).
    assumption.
    apply elift_Mlet with (P k); try assumption.
      exists (carac (fun mm => X k (fst mm) (snd mm)));
        apply (cover_dec (fun mm => X k (fst mm) (snd mm))).
 Qed.

 Lemma eequiv_sdeno_case: forall  (P P':mem_rel) E1 c1 E2 c2 Q ep1 ep2
   (P_dec: decMR P) (P'_dec: decMR P') k (d1 d2: Distr(Mem.t k)) (del:nat -o> U) d,
   eequiv (P /-\ P') E1 c1 E2 c2 Q ep1 ->
   eequiv (P /-\ ~-P') E1 c1 E2 c2 Q ep2 ->
   (elift (@P k) d d1 d2 (del k) /\ exists R, srange R d) ->
   ep1 k < 1 ->
   ep2 k < 1 ->
   let pt := mu d (charfun (fun mm => if (P'_dec k (fst mm) (snd mm)) then true else false)) in
   let pf := mu d (charfun (negP (fun mm => if (P'_dec k (fst mm) (snd mm)) then true else false))) in
   exists d',
     elift (Q k) d' (Mlet d1 (([[ c1 ]]) E1)) (Mlet d2 (([[ c2 ]]) E2))
     (ep1 k * pt + ep2 k * pf + del k).
 Proof.
  intros.
  destruct H1 as [Hd HdR].
  destruct (H k) as [dt Hdt]; clear H.
  destruct (H0 k) as [df Hdf]; clear H0.
  set (Cond := fun mm => if (P'_dec k (fst mm) (snd mm)) then true else false).
  exists (Mlet d (fun mm => if Cond mm then uncurry dt mm else uncurry df mm)).
  apply elift_MletCase with (R1:=P k); trivial.
    exists (carac (fun mm => P_dec k (fst mm) (snd mm)));
      apply (cover_dec (fun mm => P_dec k (fst mm) (snd mm))).
    intros; apply Hdt; split.
      trivial.
      generalize H0; unfold Cond; simpl; case (P'_dec k x y); [ trivial | discriminate ].
    intros; apply Hdf; split.
      trivial.
      generalize H0; unfold Cond; simpl; case (P'_dec k x y); [ discriminate | trivial ].
 Qed.

 Lemma eequiv_weaken: forall P E1 c1 E2 c2 Q ep P' Q' (ep':nat -o> U),
  implMR P P' ->
  implMR Q' Q ->
  ep' <= ep ->
  eequiv P' E1 c1 E2 c2 Q' ep' ->
  eequiv P  E1 c1 E2 c2 Q  ep.
 Proof.
  unfold eequiv; intros.
  destruct (H2 k) as [d Hd]; clear H2.
  exists d.
  intros m1 m2 Hm.
  apply elift_weaken with (Q' k) (ep' k); auto.
 Qed.

 Add Morphism eequiv with signature
   implMR --> (@eq env) ==> (@eq cmd) ==> (@eq env) ==>
   (@eq cmd) ==> implMR ++> (@Ole (ford nat (tcpo U))) ++>
    impl as eequiv_imp_Morph.
 Proof.
  unfold impl; intros.
  apply eequiv_weaken with (4:=H2); assumption.
 Qed.

 Add Morphism eequiv with signature
   iffMR ==> (@eq env) ==> (@eq cmd) ==> (@eq env) ==>
   (@eq cmd) ==> iffMR ==> (@Oeq (ford nat (tcpo U))) ==>
   iff as eequiv_iff_Morph.
 Proof.
  unfold iffMR; intros.
  destruct H; destruct H0.
  split; intros.
    apply eequiv_weaken with (4:=H4); auto.
    apply eequiv_weaken with (4:=H4); auto.
 Qed.

 Lemma eequiv_trueR: forall (P:mem_rel) E1 c1 E2 c2 ep1 ep2,
  (forall k (m1 m2:Mem.t k), P _ m1 m2 ->
    ep1 k <=  mu ([[c1]] E1 m1) (fone _) /\
    ep2 k <=  mu ([[c2]] E2 m2) (fone _)) ->
  (forall k (m1 m2:Mem.t k), P _ m1 m2 ->
  ~ mu ([[c1]] E1 m1) (fone _) == 0 /\
  ~ mu ([[c2]] E2 m2) (fone _) == 0) ->
  eequiv P E1 c1 E2 c2 trueR (fun k => [1-] (ep1 k) + [1-] (ep2 k)).
 Proof.
  unfold eequiv; intros.
  exists (fun m1 m2 => prod_distr ([[c1]] E1 m1) ([[c2]] E2 m2)).
  intros m1 m2 Hm.
  eapply elift_weaken; [ | | apply (@elift_true _ _ ([[c1]] E1 m1) ([[c2]] E2 m2)) ].
    auto.
    apply Uplus_le_compat; Usimpl.
      exact (proj1 (H _ _ _ Hm)).
      exact (proj2 (H _ _ _ Hm)).
    exact (proj1 (H0 _ _ _ Hm)).
    exact (proj2 (H0 _ _ _ Hm)).
 Qed.

 Lemma eequiv_trueR_lossless: forall (P:mem_rel) E1 c1 E2 c2,
   lossless E1 c1 ->
   lossless E2 c2 ->
   eequiv P E1 c1 E2 c2 trueR (fzero _).
 Proof.
  intros.
  apply eequiv_weaken with P trueR (fun k => [1-] fone _ k + [1-] fone _ k).
    trivial.
    trivial.
    unfold fzero, fone; refine (ford_le_intro _); intro k; rewrite Uinv_one; auto.
    apply eequiv_trueR.
      intros k m1 m2 Hm; split; [ rewrite (H _ m1) | rewrite (H0 _ m2) ]; trivial.
      intros k m1 m2 Hm; split; [ rewrite (H _ m1) | rewrite (H0 _ m2) ]; auto.
 Qed.

 Lemma eequiv_falseR: forall E1 c1 E2 c2 Q,
  eequiv falseR E1 c1 E2 c2 Q (fzero _).
 Proof.
  unfold eequiv; intros.
  exists (fun _ _ => distr0 _).
  unfold falseR; intros m1 m2 H; tauto.
 Qed.

 Hint Resolve eequiv_falseR.

 Lemma eequiv_transp: forall P E1 c1 E2 c2 Q ep,
   eequiv (transpR P) E2 c2 E1 c1 (transpR Q) ep ->
   eequiv P E1 c1 E2 c2 Q ep.
 Proof.
  unfold eequiv, transpR; intros.
  destruct (H k) as [d Hd]; clear H.
  exists (fun m1 m2 => Mlet (d m2 m1) (fun mm => Munit (snd mm, fst mm))).
  intros.
  apply elift_transp.
  apply elift_stable_eq with (5:=Hd _ _ H); auto.
    rewrite Mcomp, <-(Mext (d m2 m1)) at 1.
    apply Mlet_eq_compat; trivial.
    refine (ford_eq_intro _); intros (m1',m2'); auto.
 Qed.

 Lemma eequiv_sym :  forall P E1 c1 E2 c2 Q ep,
  symMR P ->
  symMR Q ->
  eequiv P E2 c2 E1 c1 Q ep ->
  eequiv P E1 c1 E2 c2 Q ep.
 Proof.
  intros.
  apply eequiv_transp.
  unfold symMR in *; rewrite H, H0; trivial.
 Qed.

 Lemma eequiv_case: forall  (P P':mem_rel) E1 c1 E2 c2 Q ep,
   decMR P' ->
   eequiv (P /-\ P') E1 c1 E2 c2 Q ep ->
   eequiv (P /-\ ~-P') E1 c1 E2 c2 Q ep ->
   eequiv P E1 c1 E2 c2 Q ep.
 Proof.
  unfold andR, notR, eequiv; intros.
  destruct (H k) as (dt,Hdt); destruct (H0 k) as (df,Hdf); clear H H0.
  exists (fun m1 m2 => if X k m1 m2 then dt m1 m2 else df m1 m2); intros.
  destruct (X k m1 m2); auto.
 Qed.

 Lemma eequiv_nil: forall P E1 E2,
   eequiv P E1 nil E2 nil P (fzero _).
 Proof.
  unfold eequiv; intros.
  exists (fun m1 m2 => Munit (m1, m2)); intros.
  repeat rewrite deno_nil.
  apply (elift_Munit _ _ _ H).
 Qed.

 Lemma elift_deno_witness_discr_Mlet: forall (c1 c2:cmd) e1 e2 k (d1 d2: Distr (Mem.t k))
  d R ep,
  is_Discrete d1 ->
  is_Discrete d2 ->
  elift R d (Mlet d1 ([[c1]] e1)) (Mlet d2 ([[c2]] e2)) ep ->
  is_Discrete d.
 Proof.
  intros.
  destruct H as (_, _, Hl, Hr).
  apply discr_projs with (carA:=@mem_eqU k) (carB:=@mem_eqU k).
    apply mem_eqU_spec.
    apply mem_eqU_spec.
    apply discr_ext with (Mlet d1 ([[c1]] e1)).
      intros f Hf; apply (proj2 (Hl f) Hf).
      apply is_Discrete_Mlet; trivial.
        apply sem_discr.
    apply discr_ext with (Mlet d2 ([[c2]] e2)).
      intros f Hf; apply (proj2 (Hr f) Hf).
      apply is_Discrete_Mlet; trivial.
        apply sem_discr.
 Qed.

 Lemma elift_deno_witness_discr: forall (c1 c2:cmd) e1 e2 k (m1 m2:Mem.t k) d R ep,
  elift R d ([[c1]] e1 m1) ([[c2]] e2 m2) ep ->
  is_Discrete d.
 Proof.
  intros.
  apply elift_deno_witness_discr_Mlet with
    c1 c2 e1 e2 (Munit m1) (Munit m2) R ep.
    apply is_Discrete_Munit.
    apply is_Discrete_Munit.
    apply elift_stable_eq with d (([[ c1 ]]) e1 m1) (([[ c2 ]]) e2 m2) ep; trivial.
      rewrite Mlet_unit; trivial.
      rewrite Mlet_unit; trivial.
 Qed.

 Lemma eequiv_seq: forall P E1 c1 E2 c2 Q' ep Q c1' c2' ep',
   decMR Q' ->
   eequiv P E1 c1  E2 c2 Q' ep ->
   eequiv Q' E1 c1' E2 c2' Q ep' ->
   eequiv P E1 (c1 ++ c1') E2 (c2 ++ c2') Q (fplus ep' ep).
 Proof.
   unfold eequiv; intros.
   destruct (H k) as (d, Hd); destruct (H0 k) as (d', Hd'); clear H H0.
   exists (fun m1 m2 => Mlet (d m1 m2) (fun p => d' (fst p) (snd p))).
     intros.
     repeat rewrite deno_app.
     apply elift_Mlet with (Q' k); auto.
       exists (carac (fun mm => X k (fst mm) (snd mm))).
         apply (cover_dec (fun mm => X k (fst mm) (snd mm))).
         eexists; apply (discr_srange (elift_deno_witness_discr (Hd _ _ H)) _
           (cover_eq_prod _ _ (@mem_eqU_spec k) (@mem_eqU_spec k))).
 Qed.

 Lemma eequiv_trans_l : forall (P1 P2 Q1 Q2 Q3:mem_rel) E1 c1 E2 c2 E3 c3 ep ep',
  decMR P2 ->
  refl_supMR2 P2 P1 ->
  (forall k x y z, Q1 k x y -> Q2 k y z -> Q3 k x z) ->
  eequiv P1 E1 c1 E2 c2 Q1 ep->
  eequiv P2 E2 c2 E3 c3 Q2 ep'->
  eequiv P2 E1 c1 E3 c3 Q3 (fplus ep ep').
 Proof.
  intros.
  intros k; destruct (H1 k) as (d, Hd); destruct (H2 k) as (d',Hd').
  exists (
   fun m1 m3 =>
    match X k m1 m3 with
    | left _ =>
        dd' (@mem_eqU k) (d m1 m1) (d' m1 m3) ([[c2]] E2 m1)
    | _ => distr0 _
    end).
  intros m1 m3 HP2.
  destruct (X k m1 m3); simpl.
    (* P m1 m3 *)
    apply elift_trans_discr with (P:=Q1 k) (Q:=Q2 k).
      apply mem_eqU_spec.
      apply H0.
      apply (Hd _ _ (H _ _ _ p)).
      apply (Hd' _ _ p).
      apply discr_ext with (d1:=[[c2]] E2 m1).
        intros f Hf; apply (proj2 (el_supp_r (Hd _ _ (H _ _ _ p)) f) Hf).
        apply sem_discr.
      apply discr_ext with (d1:=[[c2]] E2 m1).
        intros f Hf; apply (proj2 (el_supp_l (Hd' _ _ p) f) Hf).
        apply sem_discr.
    (* ~P m1 m3 *)
    tauto.
 Qed.

 Lemma eequiv_trans_r : forall (P1 P2 Q1 Q2 Q3:mem_rel) E1 c1 E2 c2 E3 c3 ep ep',
  decMR P1 ->
  refl_supMR2 (transpR P1) (transpR P2) ->
  (forall k x y z, Q1 k x y -> Q2 k y z -> Q3 k x z) ->
  eequiv P1 E1 c1 E2 c2 Q1 ep ->
  eequiv P2 E2 c2 E3 c3 Q2 ep' ->
  eequiv P1 E1 c1 E3 c3 Q3 (fplus ep' ep).
 Proof.
  intros; apply eequiv_transp.
  apply eequiv_trans_l with (P1 := transpR P2) (P2:=transpR P1)
   (Q1 := transpR Q2) (Q2 := transpR Q1) (E2 := E2) (c2:= c2).
  auto.
  trivial.
  unfold transpR; intros; eapply H0; eauto.
  apply eequiv_transp; repeat rewrite transpR_transpR; trivial.
  apply eequiv_transp; repeat rewrite transpR_transpR; trivial.
 Qed.

 Lemma eequiv_trans_trans : forall P Q E1 c1 E2 c2 E3 c3 ep ep',
   decMR P ->
   refl_supMR P ->
   transMR Q ->
   eequiv P E1 c1 E2 c2 Q ep->
   eequiv P E2 c2 E3 c3 Q ep'->
   eequiv P E1 c1 E3 c3 Q (fplus ep ep').
 Proof.
  intros; eapply eequiv_trans_l; eauto; trivial.
 Qed.

 Lemma eequiv_cond_l : forall P E1 e c c' E2 c2 Q ep,
  eequiv (P /-\ EP1 e) E1 c E2 c2 Q ep ->
  eequiv (P /-\ ~- EP1 e) E1 c' E2 c2 Q ep ->
  eequiv P E1 [If e then c else c'] E2 c2 Q ep.
 Proof.
  unfold eequiv, andR, notR, EP1, is_true.
  intros P E3 e1 c c' E4 c2 Q ep Ht Hf k.
  destruct (Ht k) as (dt,Hdt); destruct (Hf k) as (df,Hdf); clear Ht Hf.
  exists (fun m1 m2 => if E.eval_expr e1 m1 then dt m1 m2  else df m1 m2).
  intros.
  repeat rewrite deno_cond.
  case_eq (E.eval_expr e1 m1); intros Heq;
   [ apply Hdt | apply Hdf ]; (split; [ | rewrite Heq]; auto).
 Qed.

 Lemma eequiv_cond_r :  forall P E1 c1 E2 e c c' Q ep,
  eequiv (P /-\ EP2 e) E1 c1 E2 c Q ep ->
  eequiv (P /-\ ~- EP2 e) E1 c1 E2 c' Q ep ->
  eequiv P E1 c1 E2 [If e then c else c'] Q ep.
 Proof.
  unfold eequiv, andR, notR, EP2, is_true.
  intros P E3 c c' e E4 c2 Q ep Ht Hf k.
  destruct (Ht k) as (dt,Hdt); destruct (Hf k) as (df,Hdf); clear Ht Hf.
  exists (fun m1 m2 => if E.eval_expr e m2 then dt m1 m2  else df m1 m2).
  intros.
  repeat rewrite deno_cond.
  case_eq (E.eval_expr e m2); intros Heq;
   [ apply Hdt | apply Hdf ]; (split; [ | rewrite Heq]; auto).
 Qed.

 Lemma eequiv_cond : forall P Q E1 (e1:E.expr T.Bool) c1 c2 E2 (e2:E.expr T.Bool) c3 c4 ep,
  eequiv (P /-\ (EP1 e1 /-\ EP2 e2)) E1 c1 E2 c3 Q ep ->
  eequiv (P /-\ (~- EP1 e1 /-\ ~- EP2 e2)) E1 c2 E2 c4 Q ep ->
  (forall k m1 m2, P k m1 m2 -> E.eval_expr e1 m1 = E.eval_expr e2 m2) ->
  eequiv P E1 [If e1 then c1 else c2] E2 [If e2 then c3 else c4] Q ep.
 Proof.
  intros; apply eequiv_cond_l; apply eequiv_cond_r.
  simplMR; trivial.
  apply eequiv_weaken with falseR Q (fzero _); auto; unfold EP1, EP2.
    intros k m1 m2 ((H2, H3), H4); apply H4; erewrite <-H1; eauto.
  apply eequiv_weaken with falseR Q (fzero _); auto; unfold EP1, EP2.
    intros k m1 m2 ((H2, H3), H4); apply H3; erewrite H1; eauto.
  simplMR; trivial.
 Qed.

Section WHILE.

  Variables c1 c2 : cmd.
  Variables e1 e2 : env.

  Variables I P1 P2: mem_rel.
  Variables b1 b2: E.expr T.Bool.

  Hypothesis I_b: forall k (m1 m2:Mem.t k),
   I m1 m2 -> E.eval_expr b1 m1 = E.eval_expr b2 m2.

  Hypothesis I_dec: decMR I.

  Hypothesis I_P: forall k (m1 m2:Mem.t k),
    I m1 m2 -> P1 m1 m1 /\ P2 m2 m2.

  Variable ep: nat -o> U.
  Hypothesis Hc:
    eequiv (I /-\ EP1 b1) e1 c1 e2 c2 I ep.

  Variable q: nat.

  Hypothesis H_while1:
    eequiv
    (Meq /-\ P1)
    e1 [while b1 do c1]
    e1 (unroll_while b1 c1 q)
    (Meq /-\ ~-EP2 b1)
    (fzero _).

  Hypothesis H_while2:
    eequiv
    (Meq /-\ P2)
    e2 [while b2 do c2]
    e2 (unroll_while b2 c2 q)
    (Meq /-\ ~-EP2 b2)
    (fzero _).

  Ltac My_Usimpl :=  (try Usimpl); match goal with
    |- context [(Uabs_diff ?x ?x)] => setoid_rewrite (Uabs_diff_compat_eq x)
  end.

  Lemma deno_unroll_while_0: forall c e b k (m:Mem.t k),
   [[ unroll_while b c 0 ]] e m == Munit m.
  Proof.
   unfold unroll_while; intros.
   rewrite deno_cond.
   case (E.eval_expr b m); apply deno_nil.
  Qed.

  Lemma while_rule:
    eequiv I e1 [while b1 do c1] e2  [while b2 do c2] (I /-\ ~-EP1 b1)
    (fun k => q */ ep k).
  Proof.
   apply eequiv_weaken with I (I /-\ ~-EP1 b1) (fplus (fzero _) (fplus (fzero _)
      (fun k => q */ ep k))); trivial.
     unfold fplus, fzero; refine (ford_le_intro _); intro m; auto.
   apply eequiv_trans_l  with (1:=I_dec) (4:=H_while1) (Q2:=I).
     intros k m1 m2 Hm; split; [ trivial | apply (proj1 (I_P Hm)) ].
     intros k m1 m2 m3 [H1 H2] H3; split; rewrite H1; trivial.
   eapply eequiv_trans_r  with (1:=I_dec) (5:=eequiv_transp H_while2) (Q1:=I).
     intros k m1 m2 Hm; split; [ trivial | apply (proj2 (I_P Hm)) ].
     intros k m1 m2 m3 H1 [H2 _]; rewrite H2; trivial.

   clear H_while1 H_while2.
   induction q.
     (* base case *)
     intro k.
     exists (fun m1 m2 => Munit (m1,m2)).
     intros m1 m2 Hm; repeat rewrite deno_unroll_while_0.
     apply (elift_Munit _ _ _ Hm).

     (* inductive case *)
     unfold unroll_while; fold (unroll_while b1 c1 n) (unroll_while b2 c2 n).
     apply eequiv_cond with (3:=I_b).
       apply eequiv_weaken with (I /-\ EP1 b1) I (fplus (fun k => n */ ep k) ep).
         rewrite <-andR_assoc; apply proj1_MR.
         trivial.
         unfold fplus; refine (ford_le_intro _); intro m; rewrite Uplus_sym; auto.
       apply eequiv_seq with I; trivial.
       apply eequiv_weaken with I I (fzero _).
         apply proj1_MR.
         trivial.
         unfold fzero; refine (ford_le_intro _); intro m; trivial.
       apply eequiv_nil.
 Qed.

 End WHILE.

 Lemma equiv_eequiv: forall (P:mem_rel) E1 c1 E2 c2 (Q:mem_rel),
   eequiv P E1 c1 E2 c2 Q (fzero _) <-> equiv P E1 c1 E2 c2 Q.
 Proof.
  unfold equiv, eequiv; split; intros.
    (* eequiv ==> equiv *)
    destruct (H k) as [d Hd]; clear H.
    exists d.
      intros m1 m2 H; rewrite <-lift_elift; exact (Hd _ _ H).
    (* equiv ==> eequiv *)
    destruct (H k) as [d Hd]; clear H.
    exists d.
      intros m1 m2 H; rewrite lift_elift; exact (Hd _ _ H).
 Qed.

 (* ONE VARIANT OF EEQUIV *)

 Definition eEqObs I e1 c1 e2 c2 O (ep:nat-o>U) :=
   eequiv (kreq_mem I) e1 c1 e2 c2 (kreq_mem O) ep.

Lemma eEqObs_sym : forall I E1 c1 E2 c2 O ep,
  eEqObs I E1 c1 E2 c2 O ep -> eEqObs I E2 c2 E1 c1 O ep.
 Proof.
  unfold eEqObs; intros; apply eequiv_sym; auto.
 Qed.

 Lemma eEqObs_trans: forall I E1 c1 E2 c2 E3 c3 O ep ep',
   eEqObs I E1 c1 E2 c2 O ep ->
   eEqObs I E2 c2 E3 c3 O ep'->
   eEqObs I E1 c1 E3 c3 O (fplus ep ep').
 Proof.
  unfold eEqObs; intros.
  apply eequiv_trans_trans with E2 c2; auto.
 Qed.

(*
 Add Morphism eEqObs
  with signature Vset.subset ++> (@eq env) ==> (@eq cmd) ==>
   (@eq env) ==> (@eq cmd) ==> Vset.subset ++> (@Ole (ford nat (tcpo U))) ++> impl
  as eEqObs_imp_Morph.
 Proof.
  unfold eEqObs, flip, impl; intros.
  eapply eequiv_imp_Morph with (8:=H2); auto.  y0 y1 y2 y3 (kreq_mem y4)
  rewrite H0, <- H; trivial.
 Qed.
*)

 Lemma eEqObs_Pr2 : forall I E1 c1 E2 c2 O ep,
  eEqObs I E1 c1 E2 c2 O ep ->
  forall e, fv_expr e [<=] O ->
   forall k (m1 m2:Mem.t k), m1 =={I} m2 ->
   Uabs_diff (Pr E1 c1 m1 (EP k e)) (Pr E2 c2 m2 (EP k e)) <= ep k.
 Proof.
  unfold Pr; intros.
  eapply eequiv_deno with (1:=H); trivial.
    unfold charfun,restr, EP; intros.
    rewrite (@depend_only_fv_expr_subset _ e _ H0 _ _ _ H2); trivial.
 Qed.

 Lemma eEqObs_Pr : forall I E1 c1 E2 c2 e ep,
  eEqObs I E1 c1 E2 c2 (fv_expr e) ep ->
  forall k m,
   Uabs_diff (Pr E1 c1 m (EP k e)) (Pr E2 c2 m (EP k e)) <= ep k.
 Proof.
  intros; eapply eEqObs_Pr2; eauto with set.
 Qed.

End Make.

(*
 Require Import WhileStuff.

 Section For_loop_rule.

  Variables i : E.expr T.Nat.

 (* [q] is a constant expression *)
  Variable q: E.expr T.Nat.
  Variable q_interp : nat -> nat.
  Hypothesis Hq_cte : forall k (m:Mem.t k), E.eval_expr q m = q_interp k.

  Variables c1 c2 : cmd.
  Variables e1 e2 : env.

  Variables I: mem_rel.

  (* First argument is the security parameter *)
  Variable h : nat -> nat -o> U.

  Hypothesis Hc: forall n:nat,
    eequiv
    (I /-\ EP1 (i=?=n) /-\ EP2 (i=?=n))
    e1 c1 e2 c2
    (I /-\ EP1 (i=?=S n) /-\ EP2 (i=?=S n))
    (fun k => h k n).

  Variable P1 P2: forall k, Mem.t k -> Prop.

  Hypothesis H_P : forall k (m1 m2:Mem.t k), I m1 m2 -> P1 m1 /\ P2 m2.

  Hypothesis Hran1: forall k (m:Mem.t k),
    P1 m ->
    range (fun m' => E.eval_expr i m' = S (E.eval_expr i m) /\ P1 m') (([[c1]]) e1 m).
  Hypothesis Hran2: forall k (m:Mem.t k),
    P2 m ->
    range (fun m' => E.eval_expr i m' = S (E.eval_expr i m) /\ P2 m')  (([[c2]]) e2 m).

  Hypothesis I_dec: decMR I.

  Lemma cover_prec: forall (n k:nat),
    cover (prodP ((I /-\ EP1 (i =?= n) /-\ EP2 (i =?= n)) k ))
     (fun mm => (fun z => if I_dec (fst z) (snd z) then 1 else 0) mm * (
     ((fun z => if nat_eqb (E.eval_expr i (fst z)) n then 1 else 0) mm) *
     ((fun z => if nat_eqb (E.eval_expr i (snd z)) n then 1 else 0) mm))).
  Proof.
   intros; unfold prodP, andR.
   repeat apply cover_inter_mult.
     apply  (cover_dec (fun mm => @I_dec k (fst mm) (snd mm))).
     unfold cover; unfold EP1; simpl; unfold O.eval_op; simpl.
     intro mm; generalize (nat_eqb_spec (E.eval_expr i (fst mm)) n);
     case (nat_eqb (E.eval_expr i (fst mm)) n); split; intros; trivial.
       generalize is_true_true; tauto.
       discriminate.
     unfold cover; unfold EP2; simpl; unfold O.eval_op; simpl.
     intro mm; generalize (nat_eqb_spec (E.eval_expr i (fst mm)) n);
     case (nat_eqb (E.eval_expr i (snd mm)) n); split; intros; trivial.
       generalize is_true_true; tauto.
       discriminate.
 Qed.

 (* REMARK: wasn't able to weaken the poscondition in [Hc]
    using [Hran1], [Hran2] and [H_P] *)

  Lemma eequiv_for_loop :  eequiv
   (I /-\ EP1 (i=?=0%nat) /-\ EP2 (i=?=0%nat))
   e1 [ while (i <! q) do c1 ] e2 [ while (i <! q) do c2 ]
   (I /-\ EP1 (i=?=q) /-\ EP2 (i=?=q))
   (fun k => sigma (h k) (q_interp k)).
  Proof.
   unfold eequiv; intros.
   cut (exists d: Mem.t k -> Mem.t k -> Distr (Mem.t k * Mem.t k),
     forall m1 m2 : Mem.t k,
     (I /-\ EP1 (i =?= 0%nat) /-\ EP2 (i =?= 0%nat)) k m1 m2 ->
     elift ((I /-\ EP1 (i =?= q_interp k) /-\ EP2 (i =?= q_interp k)) k)
       (d m1 m2) (([[ [while i <! q_interp k do c1] ]]) e1 m1)
       (([[ [while i <! q_interp k do c2] ]]) e2 m2) ((sigma (h k)) (q_interp k))).
     intros [d Hd].
     exists d; intros m1 m2 Hm.
     eapply elift_weaken with (P:=(I /-\ EP1 (i =?= q_interp k) /-\ EP2 (i =?= q_interp k)) k).
       intros m1' m2' [HI [H1 H2] ]; repeat split; unfold EP1, EP2 in *.
         trivial.
         rewrite <-(Hq_cte m1') in H1; apply H1.
         rewrite <-(Hq_cte m2') in H2; apply H2.
       apply Ole_refl.
     eapply elift_stable_eq with (5:=Hd _ _ Hm); trivial.
     apply eq_distr_intro; intro f.
     apply while_eq_guard_compat_elim.
     intro m'; change (leb (E.eval_expr i m' + 1) (q_interp k) =
       leb (E.eval_expr i m' + 1) (E.eval_expr q m')); rewrite Hq_cte; trivial.
     apply eq_distr_intro; intro f.
     apply while_eq_guard_compat_elim.
     intro m'; change (leb (E.eval_expr i m' + 1) (q_interp k) =
       leb (E.eval_expr i m' + 1) (E.eval_expr q m')); rewrite Hq_cte; trivial.

   induction (q_interp k).
     (* base case *)
     exists (fun m1 m2 => Munit (m1,m2)).
     intros m1 m2 Hm; constructor.
       (* dist *)
       intros f g.
       repeat rewrite deno_while_elim, deno_cond_elim.
       replace (@E.eval_expr _ T.Bool (i <! 0) m1) with false by
         (symmetry; apply (leb_correct_conv 0%nat (E.eval_expr i m1 + 1)); omega).
       replace (@E.eval_expr _ T.Bool (i <! 0) m2) with false by
         (symmetry; apply (leb_correct_conv 0%nat (E.eval_expr i m2 + 1)); omega).
       repeat rewrite deno_nil_elim, Munit_eq, Uabs_diff_compat_eq; auto.
       (* range *)
       apply range_Munit; assumption.
       (* supp *)
       intro f.
       rewrite deno_while_elim, deno_cond_elim.
       replace (@E.eval_expr _ T.Bool (i <! 0) m1) with false by
         (symmetry; apply (leb_correct_conv 0%nat (E.eval_expr i m1 + 1)); omega).
       rewrite deno_nil_elim, Munit_eq; auto.
       intro g.
       rewrite deno_while_elim, deno_cond_elim.
       replace (@E.eval_expr _ T.Bool (i <! 0) m2) with false by
         (symmetry; apply (leb_correct_conv 0%nat (E.eval_expr i m2 + 1)); omega).
       rewrite deno_nil_elim, Munit_eq; auto.
     (* inductive case *)
      assert (H1: forall (m:Mem.t k) f, P1 m -> E.eval_expr i m = 0%nat ->
        mu ([[ [while i <! S n do c1] ]] e1 m) f ==
        mu ([[ [while i <! n do c1] ]] e1 m) (fun m' => mu ([[c1]] e1 m') f)).
        intros.
         rewrite <-(deno_cons_elim e1 (while i <! n do c1) c1 m f).
         apply (init_for_loop_tail_unroll _ _ P1 m _ Hran1 H H0).
      assert (H2: forall (m:Mem.t k) f, P2 m -> E.eval_expr i m = 0%nat ->
        mu ([[ [while i <! S n do c2] ]] e2 m) f ==
        mu ([[ [while i <! n do c2] ]] e2 m) (fun m' => mu ([[c2]] e2 m') f)).
        intros.
         rewrite <-(deno_cons_elim e2 (while i <! n do c2) c2 m f).
         apply (init_for_loop_tail_unroll _ _ P2 m _ Hran2 H H0).

     destruct IHn as [d Hd].
     destruct (Hc n k) as [d' Hd']; clear Hc.
     exists (fun m1 m2 => Mlet (d m1 m2) (fun mm => d' (fst mm) (snd mm))).
     intros m1 m2 Hm; constructor.

       (* dist *)
       intros f g.
       set (Hm':=Hm).
       destruct Hm' as [HI [Hil Hir] ]; unfold EP1 in Hil; unfold EP2 in Hir.
       setoid_rewrite (eval_eq m1 i 0%nat) in Hil; apply nat_eqb_true in Hil.
       setoid_rewrite (eval_eq m2 i 0%nat) in Hir; apply nat_eqb_true in Hir.
       rewrite (H1 _ _ (proj1 (H_P HI)) Hil), (H2 _ _ (proj2 (H_P HI)) Hir).
       rewrite (Uabs_diff_triangle_ineq _
         (mu ([[ [while i <! n do c1] ]] e1 m1) (fun m => mu ([[c1]] e1 m) f))
         (mu (d m1 m2) (fun x => mu ([[c1]] e1 (fst x)) f))).
       rewrite (Uabs_diff_triangle_ineq _
         (mu ([[ [while i <! n do c2] ]] e2 m2) (fun m => mu ([[c2]] e2 m) g))
         (mu (d m1 m2) (fun x => mu ([[c2]] e2 (snd x)) g))).
       match goal with |- (?A + ?B) + (?C + ?D) <= _ =>
         rewrite <-(Uplus_assoc A), (Uplus_sym B), Uplus_assoc, (Uplus_assoc A), <-(Uplus_assoc), (Uplus_sym D)
       end.
       rewrite sigma_S; apply Uplus_le_compat.
         (* left inequality *)
         apply (Ueq_orc (h k n) 1); [apply Ule_class | | ]; intro Hhn.
           (* case [h n = 1] *)
           rewrite Hhn; auto.
           (* case [h n < 1] *)
           repeat rewrite Mlet_simpl.
           rewrite Uabs_diff_mu_compat, Uabs_diff_mu_compat,
             <-(mu_stable_plus_range (el_range (Hd _ _ Hm))).
           rewrite <-(mu_cte_le (d m1 m2) (h k n)); apply (range_le (el_range (Hd _ _ Hm))).
             intros (m1',m2') Hm'; unfold fplus, fcte, fabs_diff.
             apply (el_dist (Hd' _ _ Hm')).
             intros (m1',m2') Hm'; unfold fabs_diff.
             apply Uplus_lt_Uinv; apply Ule_lt_trans with (h k n); [ | auto ].
             rewrite Uplus_sym; apply (el_dist (Hd' _ _ Hm')).
         (* right inequality *)
         apply (el_dist (Hd _ _ Hm) (fun m => mu ([[c1]] e1 m) f) (fun m => mu ([[c2]] e2 m) g)).

    (* range *)
    apply range_Mlet with (1:=el_range (Hd _ _ Hm)).
    intros (m1',m2') Hm'; apply (el_range (Hd' _ _ Hm')).

    (* supp_l *)
    assert (Hd_srange: exists R, srange R (d m1 m2)) by
       (eexists; apply (discr_srange  (elift_deno_witness_discr (Hd _ _ Hm)) _
         (cover_eq_prod _ _ (@mem_eqU_spec k) (@mem_eqU_spec k)))).
    destruct Hd_srange as (R,(Hd_ran,Hd_dran)).
    intro f.
    set (Hm':=Hm); destruct Hm' as [HI [Hil _] ]; unfold EP1 in Hil.
    setoid_rewrite (eval_eq m1 i 0%nat) in Hil; apply nat_eqb_true in Hil.
    rewrite Mlet_simpl, (H1 _ _ (proj1 (H_P HI)) Hil).
    generalize (el_supp_l (Hd _ _ Hm)); intro Hl.
    split; intro H.
      (*  *)
      rewrite <-Hl.
      symmetry; apply Hd_ran.
      intros (m1',m2') Hm'; simpl.
      assert (Hm'_2: (I /-\ EP1 (i =?= n) /-\ EP2 (i =?= n)) _ m1' m2') by
        refine (drange_range (@cover_prec n k) (el_range (Hd _ _ Hm)) Hd_dran _ Hm').
      destruct (Hd' _ _ Hm'_2) as (_, Hran', Hsupp', _); simpl in *.
      symmetry; rewrite <-Hsupp'.
      symmetry; apply (Hd_dran _ (Oeq_sym H) _ Hm').
      (*  *)
      rewrite <-Hl in H.
      symmetry; apply Hd_ran.
      intros (m1',m2') Hm'; simpl.
      assert (Hm'_2: (I /-\ EP1 (i =?= n) /-\ EP2 (i =?= n)) _ m1' m2') by
        refine (drange_range (@cover_prec n k) (el_range (Hd _ _ Hm)) Hd_dran _ Hm').
      destruct (Hd' _ _ Hm'_2) as (_, Hran', Hsupp', _); simpl in *.
      symmetry; rewrite Hsupp'.
      symmetry; apply (Hd_dran _ (Oeq_sym H) _ Hm').

    (* supp_r *)
    assert (Hd_srange: exists R, srange R (d m1 m2)) by
       (eexists; apply (discr_srange  (elift_deno_witness_discr (Hd _ _ Hm)) _
         (cover_eq_prod _ _ (@mem_eqU_spec k) (@mem_eqU_spec k)))).
    destruct Hd_srange as (R,(Hd_ran,Hd_dran)).
    intro g.
    set (Hm':=Hm); destruct Hm' as [HI [_ Hir] ]; unfold EP2 in Hir.
    setoid_rewrite (eval_eq m2 i 0%nat) in Hir; apply nat_eqb_true in Hir.
    rewrite Mlet_simpl, (H2 _ _ (proj2 (H_P HI)) Hir).
    generalize (el_supp_r (Hd _ _ Hm)); intro Hr.
    split; intro H.
      (*  *)
      rewrite <-Hr.
      symmetry; apply Hd_ran.
      intros (m1',m2') Hm'; simpl.
      assert (Hm'_2: (I /-\ EP1 (i =?= n) /-\ EP2 (i =?= n)) _ m1' m2') by
        refine (drange_range (@cover_prec n k) (el_range (Hd _ _ Hm)) Hd_dran _ Hm').
      destruct (Hd' _ _ Hm'_2) as (_, Hran', _, Hsupp'); simpl in *.
      symmetry; rewrite <-Hsupp'.
      symmetry; apply (Hd_dran _ (Oeq_sym H) _ Hm').
      (*  *)
      rewrite <-Hr in H.
      symmetry; apply Hd_ran.
      intros (m1',m2') Hm'; simpl.
      assert (Hm'_2: (I /-\ EP1 (i =?= n) /-\ EP2 (i =?= n)) _ m1' m2') by
        refine (drange_range (@cover_prec n k) (el_range (Hd _ _ Hm)) Hd_dran _ Hm').
      destruct (Hd' _ _ Hm'_2) as (_, Hran', _, Hsupp'); simpl in *.
      symmetry; rewrite Hsupp'.
      symmetry; apply (Hd_dran _ (Oeq_sym H) _ Hm').
 Qed.

End For_loop_rule.
*)

(*
 Lemma eequiv_random_permut: forall (P:mem_rel) E1 t (x:Var.var t) (D1:E.support t)
   E2 (D2:E.support t),
  eequiv P E1 [x <$- D1] E2 [x <$- D2] P (fone _).
 Proof.
  unfold eequiv; intros.
  exists (fun m1 m2 => Munit (m1,m2)).
  intros m1 m2 Hm; constructor.
    (* dist *)
    intros f g.
    rewrite deno_random_elim, Munit_eq; unfold fst.
    admit.

    (* range *)
    apply range_Munit; trivial.

    (* l_supp *)
    intro f.
    rewrite deno_random_elim, Munit_eq; unfold fst.

  rewrite equiv_eequiv.
  apply equiv_random_permut.
 Qed.
*)

(*

 Lemma Uplus_le_minus: forall a b c,
  a - b <= c -> a <= c + b.
 Proof.
   intros.
   apply (Ule_total a b); [auto|intro H'|intro H'].
     rewrite (Uminus_plus_le a b), (Uminus_le_zero _ _ H'); auto.
     apply (Uminus_le_perm_left _ _ _ H' H).
 Qed.

 Lemma Uabs_diff_restr: forall (A:Type) (d:Distr A)  f R,
  Uabs_diff (mu d f) (mu d (restr R f)) <= mu d (restr (negP R) f).
 Proof.
  intros.
  rewrite <-(Uplus_zero_right (mu d (restr R f))),
    (mu_restr_split d R f), Uabs_diff_plus, Uabs_diff_compat_eq, Uplus_zero_left.
  unfold Uabs_diff; rewrite (Uminus_le_zero 0 _ (Upos _)); auto.
 Qed.

 Lemma eequiv_failure_events: forall (P:mem_rel) E1 c1 E2 c2 (Q:mem_rel) (ep ep1: nat -o> U)
  (bad1 bad2: Var.var T.Bool),
  (forall k (m1 m2:Mem.t k), P _ m1 m2 -> Pr E1 c1 m1 (EP k bad1) + Pr E2 c2 m2 (EP k bad2) <= ep k) ->
   eequiv P E1 c1 E2 c2 ((~-EP1 bad1 \-/ ~-EP2 bad2) |-> Q) ep1 ->
   eequiv P E1 c1 E2 c2 Q (fplus (fplus ep1 ep) ep1).
 Proof.
  unfold eequiv;  intros.
  destruct (H0 k) as [d Hd]; clear H0.
  exists (fun m1 m2 => drestr (d m1 m2) (fun mm => if andb (fst mm bad1) (snd mm bad2) then false else true)).
  intros m1 m2 Hm.
  constructor.
    (* dist *)
    intros.
    rewrite (Uabs_diff_triangle_ineq _ (mu ([[c1]] E1 m1) f) (mu (d m1 m2) (fun x => f (fst x)))).
    rewrite (Uabs_diff_triangle_ineq _ (mu ([[c2]] E2 m2) g) (mu (d m1 m2) (fun x => g (snd x)))).
    match goal with |- (?A + ?B) + (?C + ?D) <= _ =>
      rewrite <-(Uplus_assoc A), (Uplus_sym B), Uplus_assoc, (Uplus_assoc A), <-(Uplus_assoc), (Uplus_sym D)
    end.
    apply Uplus_le_compat.
      rewrite mu_drestr, (Uabs_diff_sym _ (mu _ (fun x => f (fst x)))), Uabs_diff_restr.
      rewrite mu_drestr, (Uabs_diff_sym _ (mu _ (fun x => g (snd x)))), Uabs_diff_restr.
      transitivity ( mu (d m1 m2) (fun x => charfun (EP k bad1) (fst x)) +
        mu (d m1 m2) (fun x => charfun (EP k bad2) (snd x))).
        apply Uplus_le_compat; unfold charfun, restr, EP, negP;
          (apply mu_le_compat; [ trivial | simpl ]; refine (ford_le_intro _);
            intro mm; case (fst mm bad1); case (snd mm bad2); simpl; auto).
      unfold fplus; rewrite <-(H _ _ _ Hm).
      apply Uplus_le_minus.
      rewrite <-(el_dist (Hd _ _  Hm) (charfun (EP k bad1)) (charfun (EP k bad2))).
      rewrite <-Uabs_diff_plus; apply Ule_plus_right.
      apply (el_dist (Hd _ _ Hm)).
    (* range *)
    unfold drestr; apply range_Mlet with (1:=el_range (Hd _ _ Hm)).
    unfold prodP, notR, impR, orR, EP1, EP2; intros (m1',m2') Hm';
     unfold fst, snd in *; generalize Hm'; simpl.
    case (m1' bad1); case (m2' bad2); intros Hbad; simpl.
      apply distr0_range; trivial.
      apply range_Munit; apply Hbad; right; discriminate.
      apply range_Munit; apply Hbad; left; discriminate.
      apply range_Munit; apply Hbad; left; discriminate.
 Qed.
*)

(*
 Lemma eequiv_assign: forall E1 (t1 : T.type) (x1 : Var.var t1)
   (e1 : E.expr t1) E2 (t2 : T.type) (x2 : Var.var t2) (e2 : E.expr t2)  Q,
    eequiv (upd_para Q x1 e1 x2 e2) E1 [x1 <- e1] E2 [x2 <- e2] Q (fzero _).
 Proof.
  unfold eequiv, upd_para; intros.
  exists (fun m1 m2 => Munit (m1{!x1<-- E.eval_expr e1 m1!}, m2{!x2<--E.eval_expr e2 m2!})).
  intros.
  repeat rewrite deno_assign; auto using elift_Munit.
 Qed.

 Lemma eequiv_random_permut: forall (Q:mem_rel) E1 t (x1:Var.var t) (D1:E.support t)
   E2 (x2: Var.var t) (D2:E.support t) (h:forall k, Mem.t k -> Mem.t k -> T.interp k t -> T.interp k t),
  eequiv
   ((permut_support h D1 D2) /-\ (fun k m1 m2 => forall v, In v (E.eval_support D2 m2) ->
     Q k (m1{!x1 <-- h k m1 m2 v!}) (m2{!x2 <-- v!})))
   E1 [x1 <$- D1] E2 [x2 <$- D2] Q (fzero _).
 Proof.
  intros.
  rewrite equiv_eequiv.
  apply equiv_random_permut.
 Qed.

 Lemma eequiv_while : forall (P:mem_rel) E1 (e1:E.expr T.Bool) c1 E2 (e2:E.expr T.Bool) c2,
  (forall k m1 m2, P k m1 m2 -> E.eval_expr e1 m1 = E.eval_expr e2 m2) ->
  eequiv (P /-\ EP1 e1 /-\ EP2 e2) E1 c1 E2 c2 P (fzero _) ->
  eequiv P E1 [while e1 do c1] E2 [while e2 do c2] (P /-\ ~-EP1 e1 /-\ ~-EP2 e2) (fzero _).
 Proof.
  intros.
  rewrite equiv_eequiv.
  apply (equiv_while H).
  rewrite <-equiv_eequiv.
  assumption.
 Qed.
*)


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition data_granule_measure_spec0 (rd: Pointer) (data: Pointer) (offset: Z64) (data_size: Z64) (adt: RData) : option RData :=
    match rd, data, offset, data_size with
    | (_rd_base, _rd_ofst), (_data_base, _data_ofst), VZ64 _offset, VZ64 _data_size =>
      rely is_int64 _offset;
      when adt == measurement_extend_data_header_spec (_rd_base, _rd_ofst) (VZ64 _offset) adt;
      when adt == measurement_extend_data_spec (_rd_base, _rd_ofst) (_data_base, _data_ofst) adt;
      Some adt
     end
    .

End SpecLow.


From HoTT Require Export HoTT.

Local Set Default Proof Mode "Classic".

Set Universe Polymorphism.

(* Record fiber {A B : U} (f : A -> B) (b : B) : U :=
{
  domp : A;
  domp_spec : f domp = b;
}.

Arguments domp {A B f b} _.
 *)

Definition fiber {A B : U} (f : A -> B) (b : B) : U :=
  {a : A & f a = b}.

(*
Class Codomain (B : U) (P : U -> U) : U :=
{
  E : U;
  pr : E -> B;
  spec : forall b : B, fiber (comp pr b);
}.

#[refine]
Instance wut {B : Type} (P : Type -> Type) (f : B -> {A : Type & P A}) : Codomain B P :=
{|
  E := {x : {A : Type  & P A} & fiber f x};
|}.
Proof.
  intro x. exact (pr1' (pr2' x)).
  intro. unfold fiber. Check (pr1' (pr2' (f b))). compute. cbn.
  pose (f b).
  cbn in s.

 compute in *. Check (pr2' (f b)).
  intro. assert ( exact (pr2' (f b)). cbn.
  intro b.
  destruct (f b).
  compute. apply p.

Definition tuw {B : U} (P : U -> U) (x : Codomain B P) : B -> {A : U & P A}.
Proof.
  destruct x.
  intro b.
  exists (fiber pr0 b). apply spec0.
Defined.

Record Iso (A B : U) : U :=
{
  coe   : A -> B;
  uncoe : B -> A;
  coe_uncoe : forall a : A, uncoe (coe a) = a;
  uncoe_coe : forall b : B, coe (uncoe b) = b;
}.

Axiom funext : forall {A B : U} (f g : A -> B), (forall x : A, f x = g x) -> f = g.

Lemma fg :
  forall {A : U} (P : A -> U),
    g (f P) = P.
Proof.
  intros.
  unfold f, g in *.
  apply funext.
  intro a.
  apply ua. esplit. apply qinv_isequiv. Unshelve. all: cycle 1.
    destruct 1. destruct aa0. exact (transport _ f_aa0 p).
    esplit. Unshelve. all: cycle 1.
      intro. esplit. Unshelve. all: cycle 2.
        split with a. assumption.
        cbn. reflexivity.
      split.
        compute. reflexivity.
        red. destruct x as [[] []]. compute. reflexivity.
Defined.

Lemma ua_Codomain :
  forall
    {B : U} (x y : Codomain B)
    (p : @CE _ x = @CE _ y) (q : transport (fun t => t -> B) p (@Cf _ x) = @Cf _ y), x = y.
Proof.
  destruct x, y. cbn.
  destruct p. cbn.
  destruct 1.
  reflexivity.
Defined.

Lemma gf :
  forall {B : U} (x : Codomain B),
    f (g x) = x.
Proof.
  intros.
  eapply ua_Codomain.
  Unshelve. all: cycle 1.
    cbn. destruct x. cbn. apply ua. esplit. apply qinv_isequiv. Unshelve. all: cycle 2.
      destruct 1 as [b []]. exact aa0.
      esplit. Unshelve. all: cycle 2.
        intro x. split with (Cf0 x). esplit. Unshelve. all: cycle 3.
          exact x.
          reflexivity.
        split.
          compute. reflexivity.
          red. destruct x as [b []]. compute. destruct f_aa0. reflexivity.
    destruct x. cbn. apply funext. intro.
    {
      rewrite transport_fun.
      rewrite transportconst.
      rewrite inv_ua.
      rewrite transport_ua.
      cbn. reflexivity.
    }
Defined.
*)


Require Import floyd.proofauto.
Require Import progs.nest2.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope logic.

Definition t_struct_b := Tstruct _b noattr.

Definition get_spec :=
 DECLARE _get
  WITH v : reptype' t_struct_b, p : val
  PRE  []
        PROP ()
        LOCAL(gvar _p p)
        SEP(data_at Ews t_struct_b (repinj _ v) p)
  POST [ tint ]
         PROP()
         LOCAL (temp 1%positive (Vint (snd (snd v))))
         SEP (data_at Ews t_struct_b (repinj _ v) p).

Definition get_spec' :=
 DECLARE _get
  WITH v : (int * (float * int))%type, p : val
  PRE  []
        PROP ()
        LOCAL(gvar _p p)
        SEP(data_at Ews t_struct_b (repinj t_struct_b v) p)
  POST [ tint ]
         PROP()
         LOCAL (temp 1%positive (Vint (snd (snd v))))
         SEP (data_at Ews t_struct_b (repinj t_struct_b v) p).

Definition update22 (i: int) (v: reptype' t_struct_b) : reptype' t_struct_b :=
   (fst v, (fst (snd v), i)).

Definition set_spec :=
 DECLARE _set
  WITH i : int, v : reptype' t_struct_b, p : val
  PRE  [ _i OF tint ]
         PROP  ()
         LOCAL (gvar _p p;
                temp _i (Vint i))
         SEP   (data_at Ews t_struct_b (repinj _ v) p)
  POST [ tvoid ]
         PROP() LOCAL()
        SEP(data_at Ews t_struct_b (repinj _ (update22 i v)) p).

Definition Gprog : funspecs :=   ltac:(with_library prog [get_spec; set_spec]).

Lemma body_get:  semax_body Vprog Gprog f_get get_spec.
Proof.
start_function.
simpl in v.
unfold_repinj.
Time forward. (* 5.989 sec  -> 2.6 -> 1.5 *)
Time forward. (* 11.1118 sec -> 7.5 *)
Time Qed.

Lemma body_get':  semax_body Vprog Gprog f_get get_spec'.
Proof.
start_function.
simpl in v.
unfold_repinj.
Time forward. (* 5.989 sec  -> 2.6*)
Time forward. (* 11.1118 sec -> 7.5 *)
Qed.

Lemma body_set:  semax_body Vprog Gprog f_set set_spec.
Proof.
 start_function.
simpl in v.
(*destruct v as [a [b c]]; simpl in *. *)
unfold_repinj.
Time forward. (* 1.23 sec *)
Time forward. (* 8.77  -> 5.25 sec *)
Time Qed.  (*  28 sec -> 3.45 sec *)


(*  DEC 2.0 language specification.
   Paolo Torrini
   Universite' de Lille - CRIStAL-CNRS
*)

Require Import List.
Require Import Equality.
Require Import Eqdep.
Require Import PeanoNat.
Require Import Omega.
Require Import Eqdep FunctionalExtensionality Tactics.
Require Import JMeq.
Require Import ProofIrrelevance.
Require Import GenericMinMax.
Require Import NMaxMin.

Require Import AuxLibI1.
Require Import TypSpecI1.
Require Import ModTypI1.
Require Import LangSpecI1.
Require Import StaticSemI1.
Require Import DynamicSemI1.
Require Import WeakenI1.
Require Import UniqueTypI1.
Require Import DerivDynI1.
Require Import TransPrelimI1.
Require Import TSoundnessI1.
Require Import SReducI1.
Require Import DetermI1.
Require Import PreReflI1.
Require Import ReflectI1.
Require Import PreInterI1.
Require Import InterprBaseI1.
Require Import InterpretI1.

Require Import BinNat.
Require Import Integers.

Require VectorDef.

(*
Add LoadPath "/home/ptorrx/lib/CompCert-3.0.1" as compcert.
Add LoadPath "/home/ptorrx/lib/CompCert-3.0.1/cfrontend" as compcert.cfrontend.
Add LoadPath "/home/ptorrx/lib/CompCert-3.0.1/common" as compcert.common.

Require Import compcert.common.AST.
Require Import compcert.cfrontend.Ctypes.
Require Import compcert.cfrontend.Csyntax.
*)

Import ListNotations.
Import Integers.

(* Import Values. *)

Module CHeadAux (IdT: ModTyp) <: ModTyp.

Module InterpretL := Interpret IdT.
Export InterpretL.

Definition Id := IdT.Id.
Definition IdEqDec := IdT.IdEqDec.
Definition IdEq := IdT.IdEq.
Definition W := IdT.W.
Definition BInit := IdT.BInit.
Definition WP := IdT.WP.

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

(* produces a numbered list, pairing list elems with natural numbers,
adding 3 to the length of the tail *)
Fixpoint enumBListX {A: Type} (n: nat) (ls: list A) : list (nat * A) :=
  match ls with
  | nil => nil
  | x :: xs => ((length xs + n + 3)%nat, x) :: enumBListX n xs
  end.

Definition enumBList {A: Type} (ls: list A) : list (nat * A) :=
  enumBListX 0 ls.

(* pairs numbered list with its length *)
Definition enumEListA {A: Type} (n: nat) (ls: list A) :
  list (nat * A) * nat :=
  (enumBList ls, length ls).

(* not used - pairs list with its lenght *)
Definition enumEList {A: Type} (ls: list A) : list A * nat :=
  (ls, length ls).

(* triple swap: swap first two components of a triple *)
Definition swapTriple {A B C: Type} (x : (A * (B * C))) : (B * (A * C)) :=
  let a := fst x in
  let b := fst (snd x) in
  let c := snd (snd x) in
               (b, (a, c)).

(* maps triple swap on a list, recursive def *)
Fixpoint swapTListA {A B C: Type} (ls : list (A * (B * C))) :
  list (B * (A * C)) :=
  match ls with
  | nil => nil
  | x :: xs => let a := fst x in
               let b := fst (snd x) in
               let c := snd (snd x) in
               (b, (a, c)) :: swapTListA xs
  end.

(* swapped numbered list: maps triple swap on the numbered list *)
Definition swapTList22X {K V: Type} (n: nat) (ls : list (K * V)) :
  list (K * (nat * V)) := map swapTriple (enumBListX n ls).

Definition swapTList22 {K V: Type} (ls : list (K * V)) :
  list (K * (nat * V)) := swapTList22X 0 ls.

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

(* converting naturals to a binary representation *)

(* not good *)
Fixpoint nat2blistB (n p : nat) (ls : list nat) : list nat :=
  match p with
  | 0 => ls
  | S q => let pp := 2 ^ p in
           let m1 := n / pp in
           let m2 := Nat.modulo n pp in
    (m1 :: (nat2blistB m2 q ls))
  end.

(* decomposes n by dividing for powers of 2 up to p *)
Fixpoint nat2blist (n p : nat) : list nat :=
  match p with
  | 0 => [n]
  | S q => let pp := 2 ^ p in
           let m1 := n / pp in
           let m2 := Nat.modulo n pp in
    (m1 :: (nat2blist m2 q))
  end.

(* binary naturals: gives the binary representation of n as a list of
naturals (actually only 1 and 0) *)
Definition nat2blistA (n: nat) : list nat :=
  nat2blist n (Nat.log2 n).

(* Eval compute in (Nat.log2 19). *)
(* Eval compute in (nat2blistA 15). *)

(* increases a positive, by adding either 0 or 1 as least significant
digit *)
Definition pos_add1 (p: positive) (n: nat) : positive :=
  match n with
  | 0 => xO p
  | S _ => xI p
  end.

(* converts a binary natural into a positive *)
Definition blist2positive (ls : list nat) : positive :=
  match ls with
  | nil => xH
  | (x::xs) => fold_left pos_add1 xs xH
  end.

(* converts a natural into a positive *)
Definition nat2positive (n: nat) : positive :=
  blist2positive (nat2blistA n).

(* Eval compute in (nat2positive 13). *)

(* converts a swap numbered list into an extended C environment *)
Definition swapTList33 {K V: Type} (ls : list (K * (nat * V))) :
  list (K * (positive * V)) :=
  map (fun pp => let p1 := fst pp in let p2 := fst (snd pp) in
                                     let p3 := snd (snd pp) in
                                     (p1, (nat2positive p2, p3))) ls.

Import BinPos.

Open Scope positive_scope.

Fixpoint Pmaximum (ls : list positive) : positive :=
  match ls with
  | nil => xH
  | x :: xs => Pmax x (Pmaximum xs)
  end.

End CHeadAux.