From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Topos.SubObject_Classifier.
From Categories Require Import Basic_Cons.Terminal Basic_Cons.PullBack.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat Coq_Cats.Type_Cat.CCC.
Require Import Coq.Logic.ChoiceFacts.
Require Coq.Logic.ClassicalFacts.

Local Axiom PropExt : ClassicalFacts.prop_extensionality.
Local Axiom ConstructiveIndefiniteDescription_Type :
  forall T : Type, ConstructiveIndefiniteDescription_on T.

(** The type Prop is the sub-object classifier for Type_Cat. With ⊤ mapping the
single element of the singleton set to (True : Prop) *)
Section Type_Cat_characteristic_function_unique.
  Context {A B : Type} (F : @Monic Type_Cat A B) (h : B → Prop)
          (hpb : is_PullBack (mono_morphism F) (fun _ => tt) h (fun _ => True)).

  Theorem Type_Cat_characteristic_function_unique :
    h = fun x => (exists y : A, (mono_morphism F) y = x).
  Proof.
    extensionality x.
    apply PropExt; split.
    {
      intros Hx.
      cut ((fun _ : unit => h x) = (fun _ => True)).
      {
        intros H.
        set (W := equal_f (is_pullback_morph_ex_com_1
                             hpb unit (fun _ => x) (fun _ => tt) H) tt).
        cbn in W.
        eexists; exact W.
      }
      {
        extensionality y; apply PropExt; split; trivial.
      }
    }
    {
      intros [y []].
      set (W := (equal_f (is_pullback_morph_com hpb))).
      cbn in W.
      rewrite W; trivial.
    }
  Qed.

End Type_Cat_characteristic_function_unique.

Local Hint Extern 1 =>
match goal with
  [|- ?A = ?B :> unit] =>
  try destruct A; try destruct B; trivial; fail
end.

Program Definition Type_Cat_SubObject_Classifier : SubObject_Classifier Type_Cat :=
  {|
    SOC := Prop;
    SOC_morph := fun _ : unit => True;
    SOC_char := fun A B f x => exists y : A, (mono_morphism f) y = x;
    SO_pulback :=
      fun A B f =>
        {|
          is_pullback_morph_ex :=
            fun p' pm1 pm2 pmc x =>
              proj1_sig (ConstructiveIndefiniteDescription_Type
                           A _
                           match eq_sym (equal_f pmc x) in _ = y return y with
                             eq_refl => I
                           end)
        |}
  |}.

Next Obligation.
Proof.
  extensionality x.
  apply PropExt; split; intros H; auto.
  exists x; trivial.
Qed.

Next Obligation.
Proof.
  extensionality x.
  match goal with
    [|- mono_morphism ?f (proj1_sig ?A) = _ ] => destruct A as [y Hy]
  end.
  trivial.
Qed.

Next Obligation.
Proof.
  match goal with
    [g : (_ ≫–> _)%morphism |- _] =>
    match goal with
      [H : (fun w => (mono_morphism g) (_ w)) = (fun x => (mono_morphism g) (_ x)) |- _] =>
      apply (mono_morphism_monomorphic g) in H
    end
  end.
  auto.
Qed.

Next Obligation.
Proof.
  etransitivity; [|symmetry];
  eapply Type_Cat_characteristic_function_unique; eassumption.
Qed.


Require Import AutoDB.

Definition VALUE := "VALUE".
Definition MEASUREMENT_TYPE := "MEASUREMENT_TYPE".
Definition TIME := "TIME".
Definition CELL_ID := "CELL_ID".

Definition STATE := "STATE".
Definition AREA_CODE := "AREA_CODE".
Definition DETAILS := "DETAILS".
Definition DAY := "DAY".

Definition WIND := 0.
Definition HUMIDITY := 1.
Definition TEMPERATURE := 2.
Definition PRESSURE := 3.

Definition MEASUREMENTS := "MEASUREMENTS".
Definition CELLS := "CELLS".

Definition MeasurementType := nat.
Definition AreaCode        := nat.
Definition State           := string.

Definition WeatherSchema :=
  Query Structure Schema
    [ relation CELLS has
              schema <CELL_ID :: nat,
                      STATE :: State,
                      AREA_CODE :: nat,
                      DETAILS :: string>
              where attributes [STATE] depend on [AREA_CODE]; (* second clause? *)
      relation MEASUREMENTS has
              schema <CELL_ID :: nat,
                      VALUE :: Z,
                      MEASUREMENT_TYPE :: MeasurementType,
                      DAY :: nat,
                      TIME :: nat> ]
    enforcing [attribute CELL_ID for MEASUREMENTS references CELLS].
(* Try with three tables (distribution of areas per state) *)

Definition WeatherSig : ADTSig :=
  ADTsignature {
      "Init"           : unit                               → rep,
      "AddCell"        : rep × (WeatherSchema#CELLS)        → rep × bool,
      "AddMeasurement" : rep × (WeatherSchema#MEASUREMENTS) → rep × bool,
      "CountCells"     : rep × AreaCode                        → rep × nat,
      "LocalMax"       : rep × (AreaCode * MeasurementType)    → rep × option Z
    }.

Definition WeatherSpec : ADT WeatherSig :=
  QueryADTRep WeatherSchema {
    const "Init" (_ : unit) : rep := empty,

    update "AddCell" (cell : WeatherSchema#CELLS) : bool :=
        Insert cell into CELLS,

    update "AddMeasurement" (measurement : WeatherSchema#MEASUREMENTS) : bool :=
        Insert measurement into MEASUREMENTS,

    query "CountCells" (area : AreaCode) : nat :=
      Count (For (cell in CELLS)
             Where (area = cell!AREA_CODE)
             Return 1),

     query "LocalMax" (params: AreaCode * MeasurementType) : option Z :=
        MaxZ (For (cell in CELLS) (measurement in MEASUREMENTS)
              Where (cell!AREA_CODE = fst params)
              Where (measurement!MEASUREMENT_TYPE = snd params)
              Where (cell!CELL_ID = measurement!CELL_ID)
              Return measurement!VALUE)
}.

Definition CellHeading := GetHeading WeatherSchema CELLS.
Definition MeasurementsHeading := GetHeading WeatherSchema MEASUREMENTS.

Definition CellsStorage : @BagPlusProof (WeatherSchema#CELLS).
  mkIndex CellHeading [ CellHeading/AREA_CODE ].
Defined.

Definition MeasurementsStorage : @BagPlusProof (WeatherSchema#MEASUREMENTS).
  mkIndex MeasurementsHeading [ MeasurementsHeading/MEASUREMENT_TYPE; MeasurementsHeading/CELL_ID ].
Defined.

Definition TCellsBag := BagTypePlus CellsStorage.
Definition TMeasurementsBag := BagTypePlus MeasurementsStorage.

Definition Weather_AbsR
           (or : UnConstrQueryStructure WeatherSchema)
           (nr : TCellsBag * TMeasurementsBag) : Prop :=
  or!CELLS ≃ fst nr /\ or!MEASUREMENTS ≃ snd nr.

Definition WeatherStation :
  Sharpened WeatherSpec.
Proof.
  plan Weather_AbsR.

  Show.

  finish sharpening.
Defined.


Require Import Common.Common.
Require Import LogRelFE.PseudoType.
Require Import LogRelFE.LemmasPseudoType.
Require Import LogRelFE.LR.
Require Import LogRelFE.LemmasLR.
Require Import LogRelFE.LemmasIntro.
Require Import StlcFix.SpecSyntax.
Require Import StlcFix.CanForm.
Require Import StlcFix.SpecEvaluation.
Require Import StlcFix.LemmasEvaluation.
Require Import StlcFix.LemmasTyping.
Require Import StlcFix.SpecTyping.
Require Import StlcFix.Size.
Require Import StlcEqui.SpecSyntax.
Require Import StlcEqui.SpecEvaluation.
Require Import StlcEqui.LemmasEvaluation.
Require Import StlcEqui.SpecTyping.
Require Import StlcEqui.Inst.
Require Import UValFE.UVal.

Require Import Lia.
Require Import Min.

Section ValrelInversion.

  Local Ltac crush :=
    repeat
      (cbn in * |-; cbn;
       try assumption;
       crushOfType;
       repeat E.crushTyping;
       repeat F.crushTyping;
       repeat E.crushStlcSyntaxMatchH;
       repeat F.crushStlcSyntaxMatchH;
       (* repeat crushUtlcScopingMatchH; *)
       repeat crushDbSyntaxMatchH;
       try subst;
       destruct_conjs;
       repeat match goal with
                  [ |- _ ∧ _ ] => split
              end;
       eauto
      );
    try discriminate;
    eauto with eval;
    try lia.

  Lemma valrel_ptunit_inversion {d w vs vu} :
    valrel d w ptunit vs vu →
    vs = F.unit ∧ vu = E.unit.
  Proof.
    rewrite valrel_fixp; unfold valrel'.
    tauto.
  Qed.

  (* Lemma valrel_ptbool_inversion {d w vs vu} : *)
  (*   valrel d w ptbool vs vu → *)
  (*   (vs = S.true ∧ vu = U.true) ∨ (vs = S.false ∧ vu = U.false). *)
  (* Proof. *)
  (*   rewrite valrel_fixp; unfold valrel'. *)
  (*   crush. *)
  (* Qed. *)

  Lemma valrel_ptprod_inversion {d w τ₁ τ₂ vs vu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    valrel d w (ptprod τ₁ τ₂) vs vu →
    exists vs₁ vs₂ vu₁ vu₂,
      (vs = F.pair vs₁ vs₂ ∧ vu = E.pair vu₁ vu₂ ∧
       OfType τ₁ vs₁ vu₁ ∧
       OfType τ₂ vs₂ vu₂ ∧
       ∀ w', w' < w → valrel d w' τ₁ vs₁ vu₁ ∧ valrel d w' τ₂ vs₂ vu₂).
  Proof.
    intros vτ₁ vτ₂ vr.
    destruct (OfType_inversion_ptprod vτ₁ vτ₂ (valrel_implies_OfType vr))
      as (ts1' & tu1' & ts2' & tu2' & Hvs & Hvu & oft1 & oft2).
    exists ts1', ts2', tu1', tu2';
    rewrite -> valrel_fixp in vr;
    unfold valrel' in vr; crush.
  Qed.

  Lemma valrel_ptsum_inversion {d w τ₁ τ₂ vs vu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    valrel d w (ptsum τ₁ τ₂) vs vu →
    exists vs' vu',
      (vs = F.inl vs' ∧ vu = E.inl vu' ∧
       OfType τ₁ vs' vu' ∧
       ∀ w', w' < w → valrel d w' τ₁ vs' vu') ∨
      (vs = F.inr vs' ∧ vu = E.inr vu' ∧
       OfType τ₂ vs' vu' ∧
       ∀ w', w' < w → valrel d w' τ₂ vs' vu').
  Proof.
    intros vτ₁ vτ₂ vr.
    rewrite -> valrel_fixp in vr; destruct vr as [oft sumrel];
    apply OfType_inversion_ptsum in oft;
    destruct oft as (tsb & tub & Hvs); intuition; crush;
    exists tsb, tub; crush.
  Qed.

  Lemma valrel_ptarr_inversion {d w τ₁ τ₂ vs vu} :
    ValidPTy τ₁ -> ValidPTy τ₂ ->
    valrel d w (ptarr τ₁ τ₂) vs vu →
    ∃ tsb tub τ,
      vs = F.abs (repEmul τ₁) tsb ∧ vu = E.abs τ tub ∧
      ValidTy τ /\
      ⟪ τ ≗ fxToIs τ₁ ⟫ /\
      ⟪ F.empty ▻ repEmul τ₁ ⊢ tsb : repEmul τ₂ ⟫ ∧
      ⟪ E.empty r▻ fxToIs τ₁ e⊢ tub : fxToIs τ₂ ⟫ ∧
      ∀ w' vs' vu',
        w' < w →
        (d = dir_gt -> E.size vu' <= w') ->
        valrel d w' τ₁ vs' vu' →
        termrel d w' τ₂ (tsb[beta1 vs']) (tub[beta1 vu']).
  Proof.
    intros vτ₁ vτ₂ vr.
    destruct (valrel_implies_Value vr) as [? ?].
    destruct (OfType_inversion_ptarr vτ₁ vτ₂ (valrel_implies_OfType vr))
      as (tsb & tub & τ & ? & ? & ?).
    exists tsb, tub, τ; crush.
    rewrite -> valrel_fixp in vr.
    unfold valrel' in vr; unfold termrel; crush.
  Qed.

  Lemma invert_valrel_pEmulDV_zero {dir w p vs vu τ} :
    valrel dir w (pEmulDV 0 p τ) vs vu →
    OfType (pEmulDV 0 p τ) vs vu ∧ vs = F.unit ∧ p = imprecise.
  Proof.
    intros vr.
    rewrite valrel_fixp in vr; unfold valrel' in vr.
    tauto.
  Qed.

  Lemma invert_valrel_pEmulDV_unk {dir w n p vu τ} :
    valrel dir w (pEmulDV (S n) p τ) (F.inr F.unit) vu →
    p = imprecise.
  Proof.
    intros vr.
    rewrite valrel_fixp in vr; unfold valrel' in vr.
    destruct vr as (ot & [(? & ?) | ?]).
    - assumption.
    - destruct (unfoldn (LMC τ) τ); destruct_conjs; unfold is_inl in H0; crush.
  Qed.

  Lemma invert_valrel_pEmulDV_inUnit' {dir w n p vs vu} :
    valrel dir w (pEmulDV (S n) p E.tunit) (F.inl vs) vu →
    vs = F.unit ∧ vu = E.unit.
  Proof.
    intros vr.
    rewrite valrel_fixp in vr.
    unfold valrel' in vr.
    destruct vr as (ot & [(? & ?) | ?]);
      try (destruct H as [? H']; unfold is_inl in H');
      crush.
  Qed.

  Lemma invert_valrel_pEmulDV_inUnit {dir w n p vs vu} :
    valrel dir w (pEmulDV (S n) p E.tunit) (F.inl vs) vu →
    valrel dir w ptunit vs vu.
  Proof.
    intros vr.
    destruct (invert_valrel_pEmulDV_inUnit' vr); subst.
    apply valrel_unit.
  Qed.

  Lemma invert_valrel_pEmulDV_unit {dir w n p vs vu} :
   valrel dir w (pEmulDV (S n) p E.tunit) vs vu →
    (vs = unkUVal (S n) ∧ p = imprecise) ∨
    ∃ vs', (vs = F.inl vs' ∧ valrel dir w ptunit vs' vu).
  Proof.
    intro vr.
    destruct (valrel_implies_OfType vr) as [[? ?] [? ?]].
    cbn in *; unfold UValFE in H0; cbn in *.
    E.stlcCanForm.
    F.stlcCanForm.
    - right. eexists; eauto using invert_valrel_pEmulDV_inUnit.
    - eauto using invert_valrel_pEmulDV_unk.
  Qed.

  (* TODO: ^^ one of these per type **)

  Lemma invert_valrel_pEmulDV_inVar {dir w n p vs vu i} :
    not (valrel dir w (pEmulDV (S n) p (E.tvar i)) (F.inl vs) vu).
  Proof.
    intros vr.
    rewrite valrel_fixp in vr; unfold valrel' in vr.
    destruct vr as [? [[? ?] | ?]];
    crush.
  Qed.

  Lemma invert_valrel_pEmulDV_var {dir w n p vs vu i} :
    valrel dir w (pEmulDV (S n) p (E.tvar i)) vs vu →
    vs = unkUVal (S n) ∧ p = imprecise.
  Proof.
    intro vr.
    destruct (valrel_implies_OfType vr) as [[? ?] [? ?]].
    cbv in H0, H2.
    E.stlcCanForm.
    F.stlcCanForm.
    - exfalso. exact (invert_valrel_pEmulDV_inVar vr).
    - eauto using invert_valrel_pEmulDV_unk.
  Qed.

  Lemma invert_valrel_pEmulDV_inBool' {dir w n p vs vu} :
    valrel dir w (pEmulDV (S n) p tbool) (inBool n vs) vu →
    (vs = F.true ∧ vu = E.true) ∨ (vs = F.false ∧ vu = E.false).
  Proof.
    intros vr.
    rewrite valrel_fixp in vr; unfold valrel' in vr.
    destruct vr as [_ [(? & ?)|(? & ? & [(? & ?)|(? & ?)])]];
      unfold is_inl in *;
      crush.
  Qed.

  Lemma invert_valrel_pEmulDV_inBool {dir w n p vs vu} :
    valrel dir w (pEmulDV (S n) p tbool) (inBool n vs) vu →
    valrel dir w ptbool vs vu.
  Proof.
    intros vr.
    destruct (invert_valrel_pEmulDV_inBool' vr) as [[? ?]|[? ?]]; subst;
    auto using valrel_true, valrel_false.
  Qed.

  Lemma invert_valrel_pEmulDV_bool {dir w n p vs vu} :
   valrel dir w (pEmulDV (S n) p E.tbool) vs vu →
    (vs = unkUVal (S n) ∧ p = imprecise) ∨
    ∃ vs', (vs = F.inl vs' ∧ valrel dir w ptbool vs' vu).
  Proof.
    intro vr.
    destruct (valrel_implies_OfType vr) as [[? ?] [? ?]].
    cbn in *; unfold UValFE in H0; cbn in *.
    rewrite valrel_fixp in vr; unfold valrel' in vr; cbn in vr.
    destruct vr as (ot & [(-> & ->)|(ts' & eq & vr)]).
    - left. eauto using invert_valrel_pEmulDV_unk.
    - right.
      exists ts'.
      split; [exact eq|].
      destruct vr as [[? ?]|[? ?]]; subst; eauto using valrel_true, valrel_false.
  Qed.

  Lemma invert_valrel_pEmulDV_inProd' {dir w n p τ₁ τ₂ vs vu} :
    ValidTy τ₁ -> ValidTy τ₂ ->
    valrel dir w (pEmulDV (S n) p (E.tprod τ₁ τ₂)) (inProd n vs) vu →
    ∃ vs₁ vs₂ vu₁ vu₂, vs = F.pair vs₁ vs₂ ∧ vu = E.pair vu₁ vu₂ ∧
                       (∀ w', w' < w → valrel dir w' (pEmulDV n p τ₁) vs₁ vu₁) ∧
                       (∀ w', w' < w → valrel dir w' (pEmulDV n p τ₂) vs₂ vu₂).
  Proof.
    intros vτ₁ vτ₂ vr.
    rewrite valrel_fixp in vr; unfold valrel' in vr.
    destruct vr as [[[vvs tvs] [vvu tvu]] [(? & ?) |(x & ? & vr)]];
      unfold is_inl in *; simpl in *; crush.
    F.stlcCanForm.
    E.stlcCanForm.
    exists x0, x1, x, x2; crush.
  Qed.

  Lemma invert_valrel_pEmulDV_inProd {dir w n p τ₁ τ₂ vs vu} :
    ValidTy τ₁ -> ValidTy τ₂ ->
    valrel dir w (pEmulDV (S n) p (E.tprod τ₁ τ₂)) (inProd n vs) vu →
    valrel dir w (ptprod (pEmulDV n p τ₁) (pEmulDV n p τ₂)) vs vu.
  Proof.
    intros vτ₁ vτ₂ vr.
    assert (ValidEnv E.empty) by eauto with tyvalid.
    destruct (valrel_implies_OfType vr) as [[? ?] [? ?]].
    destruct (invert_valrel_pEmulDV_inProd' vτ₁ vτ₂ vr) as (? & ? & ? & ? & ? & ? & ? & ?); subst.
    apply valrel_pair''; crush.
    - unshelve eapply (E.typed_terms_are_valid _ _ _ H9);
        eauto with tyvalid.
    - unshelve eapply (E.typed_terms_are_valid _ _ _ H3);
        eauto with tyvalid.
  Qed.

  Lemma invert_valrel_pEmulDV_prod {dir w n p vs vu τ₁ τ₂} :
    ValidTy τ₁ -> ValidTy τ₂ ->
    valrel dir w (pEmulDV (S n) p (E.tprod τ₁ τ₂)) vs vu →
    (vs = unkUVal (S n) ∧ p = imprecise)
    ∨ exists vs', vs = F.inl vs' ∧ valrel dir w (ptprod (pEmulDV n p τ₁) (pEmulDV n p τ₂)) vs' vu.
  Proof.
    intros vτ₁ vτ₂ vr.
    destruct (valrel_implies_OfType vr) as [[? ?] [? ?]].
    cbv [UValFE UValFE' fxToIs repEmul] in *.
    F.stlcCanForm; [right | eauto using invert_valrel_pEmulDV_unk].
    exists (F.pair x0 x1).
    crush; exact (invert_valrel_pEmulDV_inProd vτ₁ vτ₂ vr).
  Qed.

  Lemma invert_valrel_pEmulDV_inSum' {dir w n p vs vu τ₁ τ₂} :
    valrel dir w (pEmulDV (S n) p (E.tsum τ₁ τ₂)) (F.inl vs) vu →
    ∃ vs' vu', ((vs = F.inl vs' ∧ vu = E.inl vu') ∨ (vs = F.inr vs' ∧ vu = E.inr vu')) ∧
               ((∀ w', w' < w → valrel dir w' (pEmulDV n p τ₁) vs' vu')
                ∨ (∀ w', w' < w → valrel dir w' (pEmulDV n p τ₂) vs' vu')).
  Proof.
    intros vr.
    rewrite valrel_fixp in vr; unfold valrel' in vr.
    destruct vr as [? [? | [? ?]]]; crush.
    unfold OfType, OfTypeStlcFix, OfTypeStlcEqui in H; destruct_conjs.
    unfold is_inl in H0.
    assert (F.Value (F.inl x)) by crush.
    unfold sum_rel in H1; simpl in H1.
    destruct x; destruct vu;
    try exists x, vu; crush.
  Qed.

  Lemma invert_valrel_pEmulDV_inSum'' {dir w n p vs vu τ₁ τ₂} :
    valrel dir w (pEmulDV (S n) p (E.tsum τ₁ τ₂)) (F.inl vs) vu →
    ∃ vs' vu',
        ((vs = F.inl vs' ∧ vu = E.inl vu' ∧ (∀ w', w' < w → valrel dir w' (pEmulDV n p τ₁) vs' vu'))
        ∨ (vs = F.inr vs' ∧ vu = E.inr vu' ∧
               (∀ w', w' < w → valrel dir w' (pEmulDV n p τ₂) vs' vu'))).
  Proof.
    intros vr.
    rewrite valrel_fixp in vr; unfold valrel' in vr.
    destruct vr as [? [? | [? ?]]]; crush.
    unfold OfType, OfTypeStlcFix, OfTypeStlcEqui in H; destruct_conjs.
    unfold is_inl in H0.
    assert (F.Value (F.inl x)) by crush.
    unfold sum_rel in H1; simpl in H1.
    destruct x; destruct vu;
    try exists x, vu; crush.
  Qed.

  Lemma invert_valrel_pEmulDV_inSum {dir w n p vs vu τ₁ τ₂} :
    ValidTy τ₁ -> ValidTy τ₂ ->
    valrel dir w (pEmulDV (S n) p (E.tsum τ₁ τ₂)) (F.inl vs) vu →
    valrel dir w (ptsum (pEmulDV n p τ₁) (pEmulDV n p τ₂)) vs vu.
  Proof.
    assert (ValidEnv E.empty) by eauto with tyvalid.
    intros vτ₁ vτ₂ vr.
    destruct (valrel_implies_OfType vr) as [[? ?] [? ?]].
    destruct (invert_valrel_pEmulDV_inSum'' vr) as (? & ? & [(? & ? & ?) | (? & ? & ?)]);
      subst;
      [apply valrel_inl''| apply valrel_inr''];
      crush.
    - unshelve eapply (E.typed_terms_are_valid _ _ _ H7);
        eauto with tyvalid.
    - unshelve eapply (E.typed_terms_are_valid _ _ _ H7);
        eauto with tyvalid.
  Qed.

  Lemma invert_valrel_pEmulDV_sum {dir w n p vs vu τ₁ τ₂} :
    ValidTy τ₁ -> ValidTy τ₂ ->
    valrel dir w (pEmulDV (S n) p (E.tsum τ₁ τ₂)) vs vu →
    (vs = unkUVal (S n) ∧ p = imprecise)
    ∨ exists vs', vs = F.inl vs' ∧ valrel dir w (ptsum (pEmulDV n p τ₁) (pEmulDV n p τ₂)) vs' vu.
  Proof.
    intros vτ₁ vτ₂ vr.
    destruct (valrel_implies_OfType vr) as [[? ?] [? ?]].
    cbv [UValFE UValFE' fxToIs repEmul] in *.
    F.stlcCanForm; [right | right | eauto using invert_valrel_pEmulDV_unk];
    [exists (F.inl x0) | exists (F.inr x0)];
    crush; exact (invert_valrel_pEmulDV_inSum vτ₁ vτ₂ vr).
  Qed.

  Lemma invert_valrel_pEmulDV_inArr {dir w n p vs vu τ₁ τ₂} :
    valrel dir w (pEmulDV (S n) p (E.tarr τ₁ τ₂)) (F.inl vs) vu →
    valrel dir w (ptarr (pEmulDV n p τ₁) (pEmulDV n p τ₂)) vs vu.
  Proof.
    rewrite valrel_fixp; unfold valrel'.
    intro vr.
    split.
    destruct vr as [? [? | [? ?]]];
    unfold OfType, OfTypeStlcFix, OfTypeStlcEqui in *; destruct_conjs;
    crush.
    destruct vr as [? [? | [? ?]]].
      - crush.
      - destruct H0. inversion H0. assumption.
  Qed.

  Lemma invert_valrel_pEmulDV_arr {dir w n p vs vu τ₁ τ₂} :
    valrel dir w (pEmulDV (S n) p (E.tarr τ₁ τ₂)) vs vu →
    (vs = unkUVal (S n) ∧ p = imprecise) ∨
    exists vs', vs = F.inl vs' ∧ valrel dir w (ptarr (pEmulDV n p τ₁) (pEmulDV n p τ₂)) vs' vu.
  Proof.
    intro vr.
    destruct (valrel_implies_OfType vr) as [[? ?] [? ?]].
    cbv [UValFE UValFE' fxToIs repEmul] in *.
    F.stlcCanForm.
    - right. exists x. crush. exact (invert_valrel_pEmulDV_inArr vr).
    - eauto using invert_valrel_pEmulDV_unk.
  Qed.

  (* Lemma invert_valrel_pEmulDV_inRec {dir w n p vs vu τ} : *)
  (*   valrel dir (S w) (pEmulDV (S n) p (E.trec τ)) (F.inl vs) vu → *)
  (*   valrel dir w (pEmulDV n p τ[beta1 (E.trec τ)]) vs vu. *)
  (* Proof. *)
  (*   intros vr. *)
  (*   rewrite valrel_fixp in vr; unfold valrel' in vr. *)
  (*   destruct vr as [? [? | [? ?]]]; crush. *)
  (*   unfold OfType, OfTypeStlcFix, OfTypeStlcEqui in H; destruct_conjs. *)
  (*   unfold is_inl in H0. *)
  (*   inversion H0. *)
  (*   subst. *)
  (*   assert (F.Value (F.inl x)) by crush. *)
  (*   apply H1. *)
  (*   lia. *)
  (* Qed. *)

  Lemma invert_valrel_pEmulDV_inRec {d w n p vs vu τ} :
    ValidTy (trec τ) ->
    valrel d w (pEmulDV n p (E.trec τ)) vs vu ->
    valrel d w (pEmulDV n p τ[beta1 (E.trec τ)]) vs vu.
  Proof.
    intros [clτ crτ] vr.
    rewrite valrel_fixp; unfold valrel'; cbn.
    change (τ[beta1 (E.trec τ)]) with (unfoldOnce (trec τ)).
    rewrite (LMC_unfoldOnce (trec τ)); try assumption; [|cbn;eauto with arith].
    cbn.
    rewrite valrel_fixp in vr; unfold valrel' in vr; cbn in vr.
    destruct vr as [ot vr].
    split; [|assumption].
    destruct ot as ((vvs & tys) & (vvu & tyu));
    crush;
    cbn in tys, tyu.
    rewrite <-UValFE_trec; try assumption.
    now inversion crτ.
    refine (WtEq _ _ _ _ tyu); try assumption.
    eapply EqMuL, tyeq_refl.
    now split.
    now eapply E.ValidTy_unfold_trec.
  Qed.

  (* Lemma invert_valrel_pEmulDV_rec {dir w n p vs vu τ} : *)
  (*   valrel dir (S w) (pEmulDV (S n) p (E.trec τ)) vs vu → *)
  (*   (vs = unkUVal (S n) ∧ p = imprecise) ∨ *)
  (*   exists vs', vs = F.inl vs' ∧ valrel dir w (pEmulDV n p τ[beta1 (E.trec τ)]) vs' vu. *)
  (* Proof. *)
  (*   intro vr. *)
  (*   destruct (valrel_implies_OfType vr) as [[? ?] [? ?]]. *)
  (*   cbn in H0, H2. *)
  (*   cbv [UValFE UValFE'] in H0. *)
  (*   F.stlcCanForm. *)
  (*   - right. exists x. crush. exact (invert_valrel_pEmulDV_inRec vr). *)
  (*   - eauto using invert_valrel_pEmulDV_unk. *)
  (* Qed. *)
  (*   rewrite valrel_fixp; unfold valrel'. *)
  (*   intro vr. *)
  (*   split. *)
  (*   destruct vr as [? [? | [? ?]]]; *)
  (*   destruct H as [[? ?] [? ?]]; *)
  (*   crush. *)

  (*   destruct vr as [? [? | [? ?]]]. *)
  (*   exfalso. *)
  (*   crush. *)
  (*   destruct_conjs. *)
  (*   inversion H2. *)
  (*   subst. *)
  (*   dependent induction n. *)
  (*   unfold is_inl in H0. *)
  (*   inversion H0. *)
  (*   subst. *)
  (*   destruct H as [[? ?] [? ?]]. *)
  (*   simpl in H4, H6. *)
  (*   unfold UValFE in H4. *)
  (*   inversion H4. *)
  (*   subst. *)
  (*   split. *)
  (*   eapply F.can_form_tunit; *)
  (*     crush. *)
  (*   crush. *)
  (*   assert (vu = H1). *)
  (*   - destruct H as [[? ?] [? ?]]. *)
  (*     crush. *)
  (*   - dependent induction n. *)
  (*     destruct H as [[? ?] [? ?]]. *)
  (*     simpl in H1. *)
  (*     dependent induction n. *)
  (*     constructor *)
  (*   intro vr. *)
  (*   split. *)
  (*   destruct vr as [? [? | [? ?]]]; crush; *)
  (*   assert (vs = x) by (unfold is_inl in H0; crush); *)
  (*     subst; *)
  (*   destruct (OfType_implies_Value H); *)
  (*   crush. *)
  (*   destruct H as [[_ ?] _]. *)
  (*   simpl in H. *)
  (*   unfold UValFE in H. *)
  (*   destruct n. *)
  (*   unfold UValFE. *)
  (*   inversion H. *)
  (*   assumption. *)
  (*   destruct τ. *)
  (*   crush. *)
  (* Admitted. *)

  (* Lemma invert_valrel_pEmulDV {dir w n p vs vu} : *)
  (*   valrel dir w (pEmulDV (S n) p) vs vu → *)
  (*   (vs = unkUVal (S n) ∧ p = imprecise) ∨ *)
  (*   ∃ vs', vs = F.inl vs' *)
  (*     (vs = inUnit n vs' ∧ valrel dir w ptunit vs' vu) ∨ *)
  (*     (vs = inBool n vs' ∧ valrel dir w ptbool vs' vu) ∨ *)
  (*     (vs = inProd n vs' ∧ valrel dir w (ptprod (pEmulDV n p) (pEmulDV n p)) vs' vu) ∨ *)
  (*     (vs = inSum n vs' ∧ valrel dir w (ptsum (pEmulDV n p) (pEmulDV n p)) vs' vu) ∨ *)
  (*     (vs = inArr n vs' ∧ valrel dir w (ptarr (pEmulDV n p) (pEmulDV n p)) vs' vu). *)
  (* Proof. *)
  (*   intros vr. *)
  (*   destruct (valrel_implies_OfType vr) as [[? ?] _]. *)
  (*   simpl in H0. *)
  (*   canonUVal. *)
  (*   - left; crush. *)
  (*     exact (invert_valrel_pEmulDV_unk vr). *)
  (*   - right. exists x. left. crush. *)
  (*     exact (invert_valrel_pEmulDV_inUnit vr). *)
  (*   - right. exists x. right. left. crush. *)
  (*     exact (invert_valrel_pEmulDV_inBool vr). *)
  (*   - right. exists x. right. right. left. crush. *)
  (*     exact (invert_valrel_pEmulDV_inProd vr). *)
  (*   - right. exists x. right. right. right. left. crush. *)
  (*     exact (invert_valrel_pEmulDV_inSum vr). *)
  (*   - right. exists x. right. right. right. right. crush. *)
  (*     exact (invert_valrel_pEmulDV_inArr vr). *)
  (* Qed. *)
End ValrelInversion.

Ltac invert_valrel_pEmulDV :=
  match goal with
      | [ H : valrel _ _ (pEmulDV (S _) _ E.tunit) _ _ |- _ ] =>
      destruct (invert_valrel_pEmulDV_inUnit H)
      | [ H : valrel _ _ (pEmulDV (S _) _ (E.tsum _ _)) _ _ |- _ ] =>
      destruct (invert_valrel_pEmulDV_inSum H)
      | [ H : valrel _ _ (pEmulDV (S _) _ (E.tarr _ _)) _ _ |- _ ] =>
      destruct (invert_valrel_pEmulDV_inArr H)
      | [ H : valrel _ _ (pEmulDV (S _) _ (E.trec _)) _ _ |- _ ] =>
      destruct (invert_valrel_pEmulDV_inRec H)
      | [ H : valrel _ _ (pEmulDV 0 _ _) _ _ |- _ ] =>
      destruct (invert_valrel_pEmulDV_zero H) as (? & ? & ?)
  end.

(* Lemma valrel_precise_size {w τ vs vu n} : *)
(*   valrel dir_gt w (pEmulDV n precise τ) vs vu -> *)
(*   size vs <= S (S w). *)
(* Proof. *)
(*   revert vs vu n. *)
(*   induction τ; *)
(*     intros vs vu n; *)
(*     rewrite valrel_fixp; *)
(*     unfold valrel'; *)
(*            intros [ot vr]; *)
(*     destruct n. *)
(*   - destruct vr as [-> [=]]. *)
(*   - destruct vr as [[_ eq] _|(ts' & -> & vr)]; try inversion eq. *)
(*     cbn. *)
(*     destruct vr as (tsb & tub & τ₁' & τ₂' & -> & -> & vr). *)
(*     cbn. *)
(*     lia. *)
(*   - destruct vr as (-> & [= ]). *)
(*   - destruct vr as [(_ & [= ])| (? & -> & -> & ->)]. *)
(*     cbn. lia. *)
(*   - destruct vr as (-> & [=]). *)
(*   - destruct vr as [(_ & [= ])| (ts & -> & hyp)]. *)
(*     destruct ts, vu; try contradiction. *)
(*     destruct w. *)
(*     unfold sum_rel in hyp. *)
(*     cbn. *)
(*     eapply IHτ1. *)
(*     rewrite valrel_fixp; unfold valrel'; cbn. *)
(*     split; eauto. *)
(*     cbn; lia. *)
(*   -  *)

Lemma OfType_pEmulDV_unfoldn {n p τ ts tu} :
  ValidTy τ ->
  OfType (pEmulDV n p τ) ts tu <->
  OfType (pEmulDV n p (unfoldn (LMC τ) τ)) ts tu.
Proof.
  intros vτ; split;
    intros ((vvs & tvs) & (vvu & tvu));
  cbn in *;
  repeat split; cbn; try assumption;
    rewrite <-?UValFE_unfoldn in tvs;
    rewrite <-?UValFE_unfoldn;
    E.crushValidTy.
  - refine (WtEq _ _ _ _ tvu);
      eauto using E.ValidTy_unfoldn with tyvalid.
    eapply ty_eq_peel_recs; E.crushValidTy.
    eapply tyeq_refl.
  - refine (WtEq _ _ _ _ tvu);
      eauto using E.ValidTy_unfoldn with tyvalid.
    eapply ty_eq_unf_ty; E.crushValidTy.
    eapply tyeq_refl.
Qed.

Lemma valrel_pEmulDV_unfoldn {d n p w τ ts tu} :
  ValidTy τ ->
  valrel d w (pEmulDV n p τ) ts tu <->
  valrel d w (pEmulDV n p (unfoldn (LMC τ) τ)) ts tu.
Proof.
  intros vτ.
  rewrite valrel_fixp.
  unfold valrel'.
  rewrite unfoldn_LMC; E.crushValidTy.
  now rewrite <-OfType_pEmulDV_unfoldn.
Qed.

Lemma OfType_tyeq {T U n p ts tu} :
  ValidTy T ->
  ValidTy U ->
  ⟪ T ≗ U ⟫ ->
  OfType (pEmulDV n p T) ts tu <->
  OfType (pEmulDV n p U) ts tu.
Proof.
  intros vT vU tyeq; split;
  intros [[vts tts] [vtu ttu]];
  repeat split;
  cbn in *; try assumption.
  - now rewrite <-?(UVal_eq vT vU tyeq).
  - refine (WtEq _ tyeq vT vU ttu).
  - now rewrite ?(UVal_eq vT vU tyeq).
  - refine (WtEq _ (tyeq_symm tyeq) vU vT ttu).
Qed.

Lemma valrel_tyeq {T U d w n p ts tu} :
  ValidTy T ->
  ValidTy U ->
  ⟪ T ≗ U ⟫ ->
  valrel d w (pEmulDV n p T) ts tu ->
  valrel d w (pEmulDV n p U) ts tu.
Proof.
  revert T U d w p ts tu.
  induction n;
  intros T U d w p ts tu vT vU tyeq;
  rewrite valrel_fixp;
    unfold valrel';
    rewrite (OfType_tyeq vT vU tyeq);
    destruct 1 as [ot vr];
    cbn in *; [eauto|].
  split; [assumption|].
  destruct vr as [[-> ->]|[ts' vr']]; [now left|right].
  exists ts'.
  assert (⟪ unfoldn (LMC T) T ≗ unfoldn (LMC U) U ⟫).
  refine (eq_trans_contr _ _ (eq_trans_contr _ tyeq _));
    E.crushValidTy.
  eapply ty_eq_peel_recs_left; E.crushValidTy; eapply tyeq_refl.
  eapply ty_eq_peel_recs; E.crushValidTy; eapply tyeq_refl.

  assert (ValidTy (unfoldn (LMC T) T)) by eauto using E.ValidTy_unfoldn.
  assert (ValidTy (unfoldn (LMC U) U)) by eauto using E.ValidTy_unfoldn.
  assert (luz : LMC (unfoldn (LMC U) U) = 0) by (eapply unfoldn_LMC; E.crushValidTy).
  destruct H; eauto.
  - split;[now trivial|].
    eapply E.ValidTy_invert_arr in H0, H1.
    destruct vr' as (-> & ts'' & tu' & τ₁' & τ₂' & -> & -> & trb).
    exists ts'', tu', τ₁', τ₂'.
    intuition.
    specialize (trb w' fw vs vu H1 (IHn _ _ _ _ _ _ _ H0 H3 (tyeq_symm H) H6)).
    unfold termrel', contrel' in *.
    intros Cs Cu eCs eCu contrel.
    eapply (trb Cs Cu eCs eCu).
    intros w'' fw' ts' tu'' vr'.
    eapply (contrel w'' fw' ts' tu'').
    eapply (IHn _ _ _ _ _ _ _ H4 H5 H2 vr').
  - intuition.
    eapply E.ValidTy_invert_sum in H0, H1.
    unfold sum_rel in *.
    destruct ts', tu; intuition;
    specialize (H4 w' fw); refine (IHn _ _ _ _ _ _ _  _ _ _ H4);
      assumption.
  - intuition.
    eapply E.ValidTy_invert_prod in H0, H1.
    unfold prod_rel in *.
    destruct ts', tu; intuition;
    specialize (H1 w' fw);
      specialize (H8 w' fw).
    refine (IHn _ _ _ _ _ _ _  _ _ _ H1); assumption.
    refine (IHn _ _ _ _ _ _ _  _ _ _ H8); assumption.
  - contradiction vr'.
  - cbn in luz. exfalso. lia.
Qed.

Lemma valrel_tyeq' {T U d w n p ts tu} :
  ValidTy T ->
  ValidTy U ->
  ⟪ T ≗ U ⟫ ->
  valrel d w (pEmulDV n p T) ts tu <->
  valrel d w (pEmulDV n p U) ts tu.
Proof.
  intros vT vU tyeq.
  assert (tyeq' := tyeq_symm tyeq).
  split; intros vr;
  now refine (valrel_tyeq _ _ _ vr).
Qed.

Lemma compat_type_eq {T U Γ n p d m ts tu} :
  ValidTy T ->
  ValidTy U ->
  ⟪ T ≗ U ⟫ ->
  ⟪ Γ ⊩ ts ⟦d,m⟧ tu : pEmulDV n p T ⟫ ->
  ⟪ Γ ⊩ ts ⟦d,m⟧ tu : pEmulDV n p U ⟫.
Proof.
  intros vT vU tyeq [tts [ttu trel]].
  split; [|split]; cbn in *.
  - now rewrite <-(UVal_eq vT vU tyeq).
  - now refine (WtEq _ _ _ _ ttu).
  - revert trel.
    unfold termrel, termrel', contrel, contrel'.
    now setoid_rewrite <-(valrel_tyeq' vT vU tyeq).
Qed.


(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

Require Export CRelationClasses.
Require Import Bool CMorphisms.
(* Setoid.*)

Set Implicit Arguments.
Unset Strict Implicit.

(** Structure with nothing inside.
    Used to force a module type T into a module via Nop <+ T. (HACK!) *)

Module Type Nop.
End Nop.

(** * Structure with just a base type [t] *)

Module Type Typ.
  Parameter Inline(10) t : Type.
End Typ.

(** * Structure with an equality relation [eq] *)

Module Type HasEq (Import T:Typ).
  Parameter Inline(30) eq : t -> t -> Type.
End HasEq.

Module Type Eq := Typ <+ HasEq.

Module Type EqNotation (Import E:Eq).
  Infix "==" := eq (at level 70, no associativity).
  Notation "x ~= y" := (eq x y -> False) (at level 70, no associativity).
End EqNotation.

Module Type Eq' := Eq <+ EqNotation.

(** * Specification of the equality via the [Equivalence] type class *)

Module Type IsEq (Import E:Eq).
  Declare Instance eq_equiv : Equivalence eq.
End IsEq.

(** * Earlier specification of equality by three separate lemmas. *)

Module Type IsEqOrig (Import E:Eq').
  Axiom eq_refl : forall x : t, x==x.
  Axiom eq_sym : forall x y : t, x==y -> y==x.
  Axiom eq_trans : forall x y z : t, x==y -> y==z -> x==z.
  Hint Immediate eq_sym.
  Hint Resolve eq_refl eq_trans.
End IsEqOrig.

(** * Types with decidable equality *)

Module Type HasEqDec (Import E:Eq').
  Parameter eq_dec : forall x y : t, sum (x==y) (x==y -> False).
End HasEqDec.

(** * Boolean Equality *)

(** Having [eq_dec] is the same as having a boolean equality plus
    a correctness proof. *)

Module Type HasEqb (Import T:Typ).
  Parameter Inline eqb : t -> t -> bool.
End HasEqb.

Module Type EqbSpec (T:Typ)(X:HasEq T)(Y:HasEqb T).
  Parameter eqb_eq : forall x y, Y.eqb x y = true -> X.eq x y.
  Parameter eq_eqb : forall x y, X.eq x y -> Y.eqb x y = true.
End EqbSpec.

Module Type EqbNotation (T:Typ)(E:HasEqb T).
  Infix "=?" := E.eqb (at level 70, no associativity).
End EqbNotation.

Module Type HasEqBool (E:Eq) := HasEqb E <+ EqbSpec E E.

(** From these basic blocks, we can build many combinations
    of static standalone module types. *)

Module Type EqualityType := Eq <+ IsEq.

Module Type EqualityTypeOrig := Eq <+ IsEqOrig.

Module Type EqualityTypeBoth <: EqualityType <: EqualityTypeOrig
 := Eq <+ IsEq <+ IsEqOrig.

Module Type DecidableType <: EqualityType
 := Eq <+ IsEq <+ HasEqDec.

Module Type DecidableTypeOrig <: EqualityTypeOrig
 := Eq <+ IsEqOrig <+ HasEqDec.

Module Type DecidableTypeBoth <: DecidableType <: DecidableTypeOrig
 := EqualityTypeBoth <+ HasEqDec.

Module Type BooleanEqualityType <: EqualityType
 := Eq <+ IsEq <+ HasEqBool.

Module Type BooleanDecidableType <: DecidableType <: BooleanEqualityType
 := Eq <+ IsEq <+ HasEqDec <+ HasEqBool.

Module Type DecidableTypeFull <: DecidableTypeBoth <: BooleanDecidableType
 := Eq <+ IsEq <+ IsEqOrig <+ HasEqDec <+ HasEqBool.

(** Same, with notation for [eq] *)

Module Type EqualityType' := EqualityType <+ EqNotation.
Module Type EqualityTypeOrig' := EqualityTypeOrig <+ EqNotation.
Module Type EqualityTypeBoth' := EqualityTypeBoth <+ EqNotation.
Module Type DecidableType' := DecidableType <+ EqNotation.
Module Type DecidableTypeOrig' := DecidableTypeOrig <+ EqNotation.
Module Type DecidableTypeBoth' := DecidableTypeBoth <+ EqNotation.
Module Type BooleanEqualityType' :=
 BooleanEqualityType <+ EqNotation <+ EqbNotation.
Module Type BooleanDecidableType' :=
 BooleanDecidableType <+ EqNotation <+ EqbNotation.
Module Type DecidableTypeFull' := DecidableTypeFull <+ EqNotation.

(** * Compatibility wrapper from/to the old version of
      [EqualityType] and [DecidableType] *)

Module BackportEq (E:Eq)(F:IsEq E) <: IsEqOrig E.
 Definition eq_refl := F.eq_equiv.(@Equivalence_Reflexive _ _).
 Definition eq_sym := F.eq_equiv.(@Equivalence_Symmetric _ _).
 Definition eq_trans := F.eq_equiv.(@Equivalence_Transitive _ _).
End BackportEq.

Module UpdateEq (E:Eq)(F:IsEqOrig E) <: IsEq E.
 Instance eq_equiv : Equivalence E.eq.
 Proof. exact (Build_Equivalence _ F.eq_refl F.eq_sym F.eq_trans). Qed.
End UpdateEq.

Module Backport_ET (E:EqualityType) <: EqualityTypeBoth
 := E <+ BackportEq.

Module Update_ET (E:EqualityTypeOrig) <: EqualityTypeBoth
 := E <+ UpdateEq.

Module Backport_DT (E:DecidableType) <: DecidableTypeBoth
 := E <+ BackportEq.

Module Update_DT (E:DecidableTypeOrig) <: DecidableTypeBoth
 := E <+ UpdateEq.

(** * Having [eq_dec] is equivalent to having [eqb] and its spec. *)

Module HasEqDec2Bool (E:Eq)(F:HasEqDec E) <: HasEqBool E.
 Definition eqb x y := if F.eq_dec x y then true else false.
 Lemma eqb_eq : forall x y, eqb x y = true -> E.eq x y.
 Proof.
  intros x y. unfold eqb. destruct F.eq_dec as [EQ|NEQ].
  auto with *.
  discriminate.
 Qed.
 Lemma eq_eqb : forall x y, E.eq x y -> eqb x y = true.
 Proof.
  intros x y. unfold eqb. destruct F.eq_dec as [EQ|NEQ].
  auto with *.
  intro EQ; elim NEQ; auto.
 Qed.
End HasEqDec2Bool.

Module HasEqBool2Dec (E:Eq)(F:HasEqBool E) <: HasEqDec E.
 Lemma eq_dec : forall x y, sum (E.eq x y) (E.eq x y -> False).
 Proof.
  intros x y.
  assert (Hl := F.eqb_eq). specialize Hl with x y.
  assert (Hr := F.eq_eqb). specialize Hr with x y.
  destruct (F.eqb x y); [left|right].
  apply Hl; auto.
  intro EQ. apply Hr in EQ. discriminate.
 Defined.
End HasEqBool2Dec.

Module Dec2Bool (E:DecidableType) <: BooleanDecidableType
 := E <+ HasEqDec2Bool.

Module Bool2Dec (E:BooleanEqualityType) <: BooleanDecidableType
 := E <+ HasEqBool2Dec.

(** Some properties of boolean equality *)

Module BoolEqualityFacts (Import E : BooleanEqualityType').

(** [eqb] is compatible with [eq] *)

Instance eqb_compat : Proper (E.eq ==> E.eq ==> Logic.eq) eqb.
Proof.
intros x x' Exx' y y' Eyy'.
destruct eq_equiv.
apply eq_true_iff_eq.
split ; intros H.
apply eqb_eq in H.
apply eq_eqb.
eapply Equivalence_Transitive ; try eassumption.
apply Equivalence_Symmetric in Exx'.
eapply Equivalence_Transitive ; eassumption.
apply eqb_eq in H.
apply eq_eqb.
eapply Equivalence_Transitive ; try eassumption.
apply Equivalence_Symmetric in Eyy'.
eapply Equivalence_Transitive ; eassumption.
Qed.

(* TODO
(** Alternative specification of [eqb] based on [reflect]. *)

Lemma eqb_spec x y : reflect (x==y) (x =? y).
Proof.
apply iff_reflect. symmetry. apply eqb_eq.
Defined.
*)

(** Negated form of [eqb_eq] *)

Lemma eqb_neq x y : (x =? y) = false <-> x ~= y.
Proof.
split.
intros H He.
apply eq_eqb in He.
destruct (x =? y) ; discriminate.
intros He.
assert ((x =? y) = true -> False).
intros H. apply He.
apply eqb_eq ; assumption.
destruct (x =? y).
contradiction H.
reflexivity.
reflexivity.
Qed.

(** Basic equality laws for [eqb] *)

Lemma eqb_refl x : (x =? x) = true.
Proof.
apply eq_eqb.
apply eq_equiv.
Qed.

Lemma eqb_sym x y : (x =? y) = (y =? x).
Proof.
apply eq_true_iff_eq.
split ; intros H ; apply eqb_eq in H ; apply eq_eqb ;
  apply eq_equiv ; assumption.
Qed.

(** Transitivity is a particular case of [eqb_compat] *)

End BoolEqualityFacts.

(** * UsualDecidableType

   A particular case of [DecidableType] where the equality is
   the usual one of Coq. *)

Module Type HasUsualEq (Import T:Typ) <: HasEq T.
 Definition eq := @Logic.eq t.
End HasUsualEq.

Module Type UsualEq <: Eq := Typ <+ HasUsualEq.

Module Type UsualIsEq (E:UsualEq) <: IsEq E.
 (* No Instance syntax to avoid saturating the Equivalence tables *)
 Definition eq_equiv : Equivalence E.eq := eq_equivalence.
End UsualIsEq.

Module Type UsualIsEqOrig (E:UsualEq) <: IsEqOrig E.
 Definition eq_refl := @Logic.eq_refl E.t.
 Definition eq_sym := @Logic.eq_sym E.t.
 Definition eq_trans := @Logic.eq_trans E.t.
End UsualIsEqOrig.

Module Type UsualEqualityType <: EqualityType
 := UsualEq <+ UsualIsEq.

Module Type UsualDecidableType <: DecidableType
 := UsualEq <+ UsualIsEq <+ HasEqDec.

Module Type UsualDecidableTypeOrig <: DecidableTypeOrig
 := UsualEq <+ UsualIsEqOrig <+ HasEqDec.

Module Type UsualDecidableTypeBoth <: DecidableTypeBoth
 := UsualEq <+ UsualIsEq <+ UsualIsEqOrig <+ HasEqDec.

Module Type UsualBoolEq := UsualEq <+ HasEqBool.

Module Type UsualDecidableTypeFull <: DecidableTypeFull
 := UsualEq <+ UsualIsEq <+ UsualIsEqOrig <+ HasEqDec <+ HasEqBool.

(** Some shortcuts for easily building a [UsualDecidableType] *)

Module Type MiniDecidableType.
 Include Typ.
 Parameter eq_dec : forall x y : t, sum (x=y) (x=y -> False).
End MiniDecidableType.

Module Make_UDT (M:MiniDecidableType) <: UsualDecidableTypeBoth
 := M <+ HasUsualEq <+ UsualIsEq <+ UsualIsEqOrig.

Module Make_UDTF (M:UsualBoolEq) <: UsualDecidableTypeFull
 := M <+ UsualIsEq <+ UsualIsEqOrig <+ HasEqBool2Dec.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

Require Export cvterm.
Require Export substitution3.

Require Export continuity_axiom2_v2.
Require Export continuity_type_aux_v2.

Require Export cequiv_tacs.
Require Export subst_tacs.

Require Export continuity_per.

Require Export lift_lsubst_tacs.

Require Export list. (* why? *)

(*
Definition of_type_int {o} lib (t : @NTerm o) :=
  {z : Z & reduces_to lib t (mk_integer z)}.

Definition of_type_int_to_val {o} lib (f : @NTerm o) :=
  forall a,
    of_type_int lib a
    -> {v : NTerm
        & reduces_to lib (mk_apply f a) v
        # isvalue_like v}.

Definition of_type_int_to_val_TO_int {o} lib (F : @NTerm o) :=
  forall f,
    of_type_int_to_val lib f
    -> {z : Z & reduces_to lib (mk_apply F f) (mk_integer z)}.
*)

Definition value_like_type {o} lib (T : @CTerm o) :=
  forall t, member lib t T -> isvaluec_like t.

Definition agree_upto_b_c {o} lib (b f g : @CTerm o) :=
  forall (t : CTerm),
    member lib (absolute_value_c t) (mkc_natk b) (* take t's absolute value *)
    -> equality lib (mkc_apply f t) (mkc_apply g t) mkc_int.

Definition continuous2 {o} lib (F : @CTerm o) :=
  forall f,
    member lib f (mkc_fun mkc_int mkc_int)
    -> {b : CTerm
        & member lib b mkc_tnat
        # forall g : CTerm,
            member lib g (mkc_fun mkc_int mkc_int)
            -> agree_upto_b_c lib b f g
            -> equality lib (mkc_apply F f) (mkc_apply F g) mkc_int}.

Definition agree_upto_b_type_c {o} (b f g : @CTerm o) : CTerm :=
  mkc_isect
    (mkc_set
       mkc_int
       nvarx
       (mkcv_member
          [nvarx]
          (absolute_value_cv [nvarx] (mkc_var nvarx))
          (mkcv_natk [nvarx] (mk_cv [nvarx] b))))
    nvarx
    (mkcv_equality
       [nvarx]
       (mkcv_apply [nvarx] (mk_cv [nvarx] f) (mkc_var nvarx))
       (mkcv_apply [nvarx] (mk_cv [nvarx] f) (mkc_var nvarx))
       (mkcv_int [nvarx])).

Definition agree_upto_b_type_cv_v2 {o} vs (b f g T : @CVTerm o vs) : CVTerm vs :=
  mkcv_isect
    vs
    (mkcv_set
       vs
       (mkcv_int vs)
       nvarx
       (mkcv_member
          (nvarx :: vs)
          (absolute_value_cv (nvarx :: vs) (mk_cv_app_r vs [nvarx] (mkc_var nvarx)))
          (mkcv_natk (nvarx :: vs) (mk_cv_app_l [nvarx] vs b))))
    nvarx
    (mkcv_equality
       (nvarx :: vs)
       (mkcv_apply (nvarx :: vs) (mk_cv_app_l [nvarx] vs f) (mk_cv_app_r vs [nvarx] (mkc_var nvarx)))
       (mkcv_apply (nvarx :: vs) (mk_cv_app_l [nvarx] vs g) (mk_cv_app_r vs [nvarx] (mkc_var nvarx)))
       (mk_cv_app_l [nvarx] vs T)).

Definition continuous_type_c_v2 {o} (F f T : @CTerm o) :=
  mkc_product
    mkc_tnat
    nvarb
    (mkcv_isect
       [nvarb]
       (mkcv_fun [nvarb] (mkcv_int [nvarb]) (mk_cv [nvarb] T))
       nvarg
       (mkcv_ufun
          [nvarg, nvarb]
          (agree_upto_b_type_cv_v2
             [nvarg,nvarb]
             (mk_cv_app_l [nvarg] [nvarb] (mkc_var nvarb))
             (mk_cv [nvarg,nvarb] f)
             (mk_cv_app_r [nvarb] [nvarg] (mkc_var nvarg))
             (mk_cv [nvarg,nvarb] T))
          (mkcv_equality
             [nvarg,nvarb]
             (mkcv_apply [nvarg,nvarb] (mk_cv [nvarg,nvarb] F) (mk_cv [nvarg,nvarb] f))
             (mkcv_apply [nvarg,nvarb] (mk_cv [nvarg,nvarb] F) (mk_cv_app_r [nvarb] [nvarg] (mkc_var nvarg)))
             (mkcv_int [nvarg,nvarb])))).

Definition continuous_type_aux_v2 {o} vb vg vi (F f T : @NTerm o) :=
  mk_product
    mk_tnat
    vb
    (mk_isect
       (mk_fun mk_int T)
       vg
       (mk_ufun
          (agree_upto_b_type_v2
             vi
             (mk_var vb)
             f
             (mk_var vg)
             T)
          (mk_equality
             (mk_apply F f)
             (mk_apply F (mk_var vg))
             mk_int))).

Definition continuous_type_v2 {o} (F f T : @NTerm o) :=
  match newvars3 [F,f,T] with
    | (vb,vg,vi) => continuous_type_aux_v2 vb vg vi F f T
  end.

Lemma lsubstc_continuous_type_v2 {o} :
  forall (F f T : @NTerm o)
         (w : wf_term (continuous_type_v2 F f T))
         (s : CSub)
         (c : cover_vars (continuous_type_v2 F f T) s),
    {wF : wf_term F
     & {wf : wf_term f
     & {wT : wf_term T
     & {cF : cover_vars F s
     & {cf : cover_vars f s
     & {cT : cover_vars T s
     & alphaeqc
         (lsubstc (continuous_type_v2 F f T) w s c)
         (continuous_type_c_v2
            (lsubstc F wF s cF)
            (lsubstc f wf s cf)
            (lsubstc T wT s cT)) }}}}}}.
Proof.
  introv.

  assert (wf_term F # wf_term f # wf_term T) as wf.
  { unfold continuous_type_v2 in w.
    remember (newvars3 [F,f]) as p.
    destruct p as [p vi].
    destruct p as [vb vg].
    apply newvars3_prop in Heqp.
    allsimpl; allrw app_nil_r; allrw in_app_iff; allrw not_over_or; repnd.
    apply wf_product_iff in w; repnd.
    apply wf_isect_iff in w; repnd.
    apply wf_ufun in w; repnd.
    apply wf_fun in w1; repnd.
    apply wf_equality_iff in w; repnd.
    apply wf_apply_iff in w4; repnd; auto. }

  destruct wf as [wF wf].
  destruct wf as [wf wT].
  exists wF wf wT.

  assert (cover_vars F s # cover_vars f s # cover_vars T s) as cov.
  { unfold continuous_type_v2 in c.
    remember (newvars3 [F,f, T]) as p.
    destruct p as [p vi].
    destruct p as [vb vg].
    apply newvars3_prop in Heqp.
    allsimpl; allrw app_nil_r; allrw in_app_iff; allrw not_over_or; repnd.
    apply cover_vars_product in c; repnd.
    apply cover_vars_upto_isect in c; repnd.
    apply cover_vars_upto_ufun in c; repnd.
    apply cover_vars_upto_equality in c; repnd.
    apply cover_vars_upto_apply in c3; repnd.
    allrw <- @csub_filter_app_r; allsimpl.
    apply cover_vars_upto_csub_filter_disjoint in c5;
      [|rw eqvars_prop; simpl; sp; split; complete sp
       |allrw disjoint_cons_r; sp].
    apply cover_vars_upto_csub_filter_disjoint in c3;
      [|rw eqvars_prop; simpl; sp; split; sp
       |allrw disjoint_cons_r; sp].
    apply cover_vars_upto_csub_filter_disjoint in c1;
      [|rw eqvars_prop; simpl; sp; split; sp
       |allsimpl; rw disjoint_singleton_r; rw app_nil_r;
        rw in_remove_nvars; simpl; sp].
    allrw @cover_vars_fun; repnd.
    sp. }

  destruct cov as [cF cf].
  destruct cf as [cf cT].
  exists cF cf cT.

  unfold alphaeqc; simpl.
  unfold csubst, lsubst.
  allrw <- @sub_free_vars_is_flat_map_free_vars_range.
  allrw @sub_free_vars_csub2sub; boolvar; tcsp;
  try (complete (destruct n; tcsp)).

  simpl.
  allrw @sub_filter_nil_r.
  allrw <- @sub_filter_app_r; simpl.
  allrw @sub_find_sub_filter; simpl; tcsp.
  repeat gen_newvar.
  fold_terms.

  allrw @lsubst_aux_sub_filter;
    try (complete (repeat get_newvar_prop; allsimpl;
                   allrw remove_nvars_nil_l; allrw app_nil_r;
                   allrw in_app_iff; allrw not_over_or; repnd;
                   allrw disjoint_cons_r; sp)).

  fold_terms.
  unfold mk_natk.
  fold (@mk_natk_aux o n1 (mk_var n)).
  allfold (@mk_tnat o).
  allfold (@int2int o).
  pose proof (newvar_not_in_free_vars (@mk_var o nvarb)) as nve; simpl in nve.
  autodimp nve hyp;[intro k; repndors; tcsp; ginv|rw nve; clear nve].
  fold (agree_upto_b_type_v2 n1 (mk_var n) (lsubst_aux f (csub2sub s)) (mk_var n0) (lsubst_aux T (csub2sub s))).
  fold (agree_upto_b_type_v2 nvarx (mk_var nvarb) (lsubst_aux f (csub2sub s)) (mk_var nvarg) (lsubst_aux T (csub2sub s))).

  fold (int2Tv n3 (lsubst_aux T (csub2sub s))).
  fold (continuous_type_aux_aux_v2v n n3 n0 n1 n5 (lsubst_aux F (csub2sub s)) (lsubst_aux f (csub2sub s)) (lsubst_aux T (csub2sub s))).

  unfold mk_fun, mk_ufun.
  repeat gen_newvar.
  fold (int2Tv n6 (lsubst_aux T (csub2sub s))).
  fold (continuous_type_aux_aux_v2v nvarb n6 nvarg nvarx n7 (lsubst_aux F (csub2sub s)) (lsubst_aux f (csub2sub s)) (lsubst_aux T (csub2sub s))).
  clear dependent n2.
  clear dependent n4.

  apply alphaeq_eq.
  repeat get_newvar_prop.
  allsimpl; allrw remove_nvars_nil_l; allrw app_nil_r.
  allrw in_app_iff; allsimpl; allrw not_over_or; repnd; GC.
  apply alphaeq_continuous_type_aux_aux_v2v; tcsp;
  try (complete (apply cover_vars_iff_closed_lsubst_aux; auto));
  try (complete (intro k; inversion k)).
Qed.

Tactic Notation "one_lift_lsubst_cont" constr(T) ident(name) tactic(tac) :=
  match T with
    | context [lsubstc (continuous_type_v2 ?F ?f ?T) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let w3 := fresh "w3" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      let c3 := fresh "c3" in
      pose proof (lsubstc_continuous_type_v2 F f T w s c) as name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [w3 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        destruct name as [c3 name];
        clear_irr; tac
  end.

Ltac one_lift_lsubst_cont_concl :=
  match goal with
    | [ |- ?T ] =>
      let name := fresh "eq" in
      one_lift_lsubst_cont
        T
        name
        (first [ rewrite name
               | progress (apply alphaeqc_sym in name; rwal_c name)
               ]);
        clear name
  end.

Ltac one_lift_lsubst_cont_hyp H :=
  let T := type of H in
  let name := fresh "eq" in
  one_lift_lsubst_cont
    T name
    (first [ rewrite name in H
           | progress (rwal_h name H)
           ]); clear name.

Ltac lift_lsubsts_cont :=
  repeat (match goal with
            | [ H : context [lsubstc _ _ _ _ ] |- _ ] => one_lift_lsubst_cont_hyp H
            | [ |- context [lsubstc _ _ _ _ ] ] => one_lift_lsubst_cont_concl
          end).


(*
   Quark is Copyright (C) 2012-2015, Quark Team.

   You can redistribute and modify it under the terms of the GNU GPL,
   version 2 or later, but it is made available WITHOUT ANY WARRANTY.

   For more information about Quark, see our web site at:
   http://goto.ucsd.edu/quark/
*)

Require Import Ynot.

Require Import Basis.
Require Import Ascii.
Require Import String.
Require Import List.
Require Import RSep.
Require Import NArith.
Require Import Arith.

Open Local Scope stsepi_scope.
Open Local Scope hprop_scope.

Fixpoint length_in_size_helper (l : list ascii) (res:positive) :=
  match l with
  | nil => res
  | a :: ls => (length_in_size_helper ls (Psucc res))
  end.

Fixpoint length_in_size (l : list ascii) :=
  length_in_size_helper l 1%positive.

Lemma psucc_ge:
  forall p, (Psucc p >= p)%positive.
Proof.
  intros p.
  unfold Pge.
  rewrite ZC2; [discriminate | apply Pcompare_p_Sp].
Qed.

Lemma not_lt:
  forall a, a <> Lt <-> a = Gt \/ a = Eq.
Proof.
  unfold iff; split.
  intros a_not_Lt.
  destruct a.
  right; auto. destruct a_not_Lt; auto.
  left; auto.

  intros a_Gt.
  destruct a_Gt; rewrite H; discriminate.
Qed.

Lemma pos_ge_trans:
  forall p0 p1 p2, (p0 >= p1)%positive -> (p1 >= p2)%positive -> (p0 >= p2)%positive.
Proof.
  intros p0 p1 p2 H H0.

  unfold Pge in H,H0. unfold Pge.
  rewrite not_lt in H,H0. rewrite not_lt.
  destruct H. destruct H0.

  left; apply ZC2; eapply Plt_trans;
  unfold Plt; apply ZC1; eauto.

  left; apply Pcompare_Eq_eq in H0.
  rewrite<- H0. auto.

  destruct H0.
  left; apply Pcompare_Eq_eq in H.
  rewrite H. auto.

  right; apply Pcompare_Eq_eq in H.
  rewrite H. auto.
Qed.

Lemma lsi :
  forall l0 p0, ((length_in_size_helper l0 p0) >= p0)%positive.
Proof.
  induction l0.

  intros. simpl.
  unfold Pge.
  rewrite Pcompare_refl.
  discriminate.

  intros.
  simpl.

  destruct l0.
  simpl. apply psucc_ge.

  simpl in IHl0.
  simpl.

  assert (length_in_size_helper l0 (Psucc (Psucc p0)) >= (Psucc p0))%positive.
  apply IHl0.
  assert ((Psucc p0) >= p0)%positive.
  apply psucc_ge.

  eapply pos_ge_trans.
  eauto. eauto.
Qed.

Definition size (s:positive ) := (1 + s)%positive.

Lemma psucc_plus_1 :
  forall a, Psucc a = (a + 1)%positive.
Proof.
  induction a; simpl; auto.
Qed.

Ltac inv H := inversion H; subst; clear H.

(* core structures and traces *)
Axiom file_desc : Set.
Axiom ichan     : Set.
Axiom ochan     : Set.

Variable stdin  : file_desc.
Variable stdout : file_desc.

(*
   the checking function called before a socket is created.

   arg0 : the host destination of THE SOCKET
   arg1 : the tab's domain

   returns true only if

   the tab is allowed to create a socket to the host.
*)
Parameter is_safe_sock_dest_on : list ascii -> list ascii -> bool.

(* converts a file descriptor into an ascii representation. it returns an ascii list of length 4 *)
Parameter tab_id_to_la :  ichan -> list ascii.

(* Converts the file descriptor's ascii representation to the real fd representaion   the first 4 elements of the ascii list are converted. *)
Parameter get_tab_id : list ascii -> ichan.

(* extract the domain attr from the cookie and returns the domain's top domain.*)
Parameter get_topdomain_cookie : list ascii -> list ascii.

(* from a domain expression ...*.c.b.a  returns b.a (if it's just a, returns a *)
Parameter get_topdomain_tab : list ascii -> list ascii.

Fixpoint get_cookie_content_helper (la:list ascii) (cnt:nat) : list ascii :=
if beq_nat cnt 4 then la
else
  match la with
    | a :: la' => get_cookie_content_helper la' (S cnt)
    | nil => nil
  end.

(* cut the first 4 elements from the list and returns the rest part of the string *)
Definition get_cookie_content (la:list ascii) : list ascii :=
  get_cookie_content_helper la 0%nat.
Opaque get_cookie_content.

Axiom iceq:
  forall (ic1 ic2: ichan), {ic1 = ic2} + {ic1 <> ic2}.

Axiom file_desc_eq:
  forall (f1 f2: file_desc), {f1 = f2} + {f1 <> f2}.

Axiom oceq:
  forall (oc1 oc2: ochan), {oc1 = oc2} + {oc1 <> oc2}.

(* tabs *)

Definition tab := (prod (prod (prod (prod ichan ochan) (list ascii)) (list ascii)) (option ichan)).

(* kernel reads to recv from tab *)
Definition t2k (t: tab) : ichan :=
  fst (fst (fst (fst t))).

(*  tab_ichan t. *)

(* kernel writes to send to tab *)
Definition k2t (t: tab) : ochan :=
  snd (fst (fst (fst t))).

(* returns tab's init url *)
Definition tab_init_url (t: tab) : list ascii :=
  snd (fst (fst t)).

(* returns tab's origin *)
Definition tab_origin_url (t: tab) : list ascii :=
  snd (fst t).

Definition create_tab (ic:ichan) (oc:ochan) (initurl:list ascii) (torigin:list ascii) (parent:option ichan): tab :=
  (pair (pair (pair (pair ic oc) (initurl)) torigin) (parent)).

(* cookie process *)
Definition cproc := (prod (prod ichan ochan) (list ascii)).

(* kernel reads to recv from a cproc *)
Definition c2k (c: cproc) : ichan :=
  fst (fst c).

(* kernel writes to send to cproc *)
Definition k2c (c: cproc) : ochan :=
  snd (fst c).

(* returns tab's init url *)
Definition cproc_domain (c: cproc) : list ascii :=
  snd c.

Definition create_cproc (ic:ichan) (oc:ochan)  (origin:list ascii): cproc :=
  (pair (pair ic oc) (origin)).

Inductive Action : Set :=
  | MousePos : list ascii -> Action
  | ReadN : ichan -> positive -> list ascii -> Action
  | ReadFile : file_desc -> ascii -> Action
  | WriteStrFile : file_desc -> list ascii -> Action
  | WriteN : ochan -> positive -> list ascii -> Action
  | MkTab : tab -> Action
  | MkCProc : cproc -> Action
  | Endorse : bool -> Action
  | KillTab : tab -> Action
  | SendSocket : tab -> list ascii -> list ascii -> Action
  | Wget  : list ascii -> list ascii -> Action
  | FakeAction : nat -> Action.

Definition laeq (l1 l2 : list ascii) :=
  list_eq_dec ascii_dec l1 l2.

Check laeq.
Definition positive_eq_dec : forall x y:positive, {x=y}+{x<>y}.
Proof.
  decide equality.
Qed.

Definition tabeq:
  forall (t1 t2: tab), {t1 = t2} + {t1 <> t2}.
Proof.
  decide equality.
  decide equality.
  apply iceq.
  repeat decide equality.
  apply oceq.
  apply iceq.
Qed.

Definition cproceq:
  forall (t1 t2: cproc), {t1 = t2} + {t1 <> t2}.
Proof.
  decide equality.
  decide equality.
  repeat decide equality.
  decide equality.
  repeat decide equality.
  apply oceq.
  apply iceq.
Qed.

Definition Trace : Set :=
  list Action.

Definition coqtab (initurl: list ascii) (rv: ichan * ochan * list ascii) (ptab: option tab) : tab :=
  let i := (fst (fst rv)) in
  let o := (snd (fst rv)) in
  let url := (snd rv) in
    create_tab i o initurl url
      (
        match ptab with
          | Some pt => Some (t2k pt)
          | None => None
       end
      ).

Definition coqcproc (origin: list ascii) (rv: ichan * ochan) : cproc :=
  let i := (fst rv) in
  let o := (snd rv) in
    create_cproc i o origin.

Axiom gout    : ochan.
Axiom ihandle : ichan -> hprop.
Axiom ohandle : ochan -> hprop.
Axiom traced  : Trace -> hprop.
Axiom fhandle : file_desc -> hprop.

Definition thandle (t: tab) : hprop :=
  ihandle (t2k t) * ohandle (k2t t).

Definition chandle (c: cproc) : hprop :=
  ihandle (c2k c) * ohandle (k2c c).

(* actions *)
Axiom readn:
  forall (f: ichan) (s: positive) (tr: [Trace]),
  STsep (tr ~~ traced tr * ihandle f)
        (fun la => tr ~~ traced (ReadN f s la :: tr) * [ length_in_size la  = s] * ihandle f).

Axiom readfile:
  forall (f: file_desc) (tr: [Trace]),
  STsep (tr ~~ traced tr * fhandle f)
        (fun c:ascii => tr ~~ traced (ReadFile f c :: tr) * fhandle f).

Axiom writestrfile:
  forall (f: file_desc) (str: list ascii) (tr: [Trace]),
  STsep (tr ~~ traced tr * fhandle f)
        (fun _:unit => tr ~~ traced (WriteStrFile f str :: tr) * fhandle f).

Axiom mousepos: forall (tr: [Trace]), STsep (tr ~~ traced tr) (fun
  posstr => tr ~~ traced ((MousePos posstr) :: tr)).

Axiom writen:
  forall (f: ochan) (p: positive ) (s: list ascii) (tr: [Trace]),
  STsep (tr ~~ traced tr * ohandle f)
        (fun _:unit => tr ~~ traced (WriteN f p s :: tr) * ohandle f).

Axiom mktab:
  forall (url:list ascii) (avoid: list ichan) (oavoid: list ochan) (ptab: option tab) (tr: [Trace]),
  STsep (tr ~~ traced tr)
        (fun (rv: ichan * ochan * list ascii) =>
          let t := (coqtab url rv ptab) in
          tr ~~ traced (MkTab t :: tr) * ihandle (t2k t) * ohandle (k2t t) * [~ In (t2k t) avoid]  * [~ In (k2t t) oavoid]).

Axiom mkcproc:
  forall (domain:list ascii) (avoid: list ichan) (oavoid: list ochan) (tr: [Trace]),
  STsep (tr ~~ traced tr)
        (fun (rv: ichan * ochan) =>
          let c := (coqcproc domain rv) in
          tr ~~ traced (MkCProc c :: tr) * ihandle (c2k c) * ohandle (k2c c) * [~ In (c2k c) avoid] *  [~ In (k2c c) oavoid]).

Axiom killtab:
  forall (t: tab) (tr: [Trace]),
  STsep (tr ~~ traced tr)
        (fun _:unit => tr ~~ traced (KillTab t:: tr)).

(* later, desc should be disappered because a tab can connect only to it's origin *)
Axiom sendsocket:
  forall (t: tab) (host:list ascii) (sock_desc : list ascii) (tr: [Trace]),
  STsep (tr ~~ traced tr * thandle t)
        (fun _:unit => tr ~~ traced (SendSocket t host sock_desc :: tr) * thandle t).

Axiom wget:
  forall (url: list ascii) (tr: [Trace]),
  STsep (tr ~~ traced tr)
        (fun (html: list ascii) =>
          tr ~~ traced (Wget url html :: tr)).

Axiom endorse:
  forall (tr: [Trace]),
  STsep (tr ~~ traced tr)
        (fun (dec: bool) =>
          tr ~~ traced (Endorse dec :: tr)).

Axiom select:
  forall (stdin: file_desc) (ics: list ichan) (tr: [Trace]),
  STsep (tr ~~ traced tr)
        (fun ready:(option file_desc*(list ichan)) =>
          tr ~~ traced tr * [fst ready = (Some stdin) \/ snd ready <> nil] *
          [forall ic, In ic (snd ready) -> In ic ics]).

(* aux defns *)

Definition WroteStr (f: ochan) (s: list ascii) : Action :=
  WriteN f (length_in_size s) s.

Lemma iceq_true:
  forall T (A B: T) f,
  (if iceq f f then A else B) = A.
Proof.
  intros. case (iceq f f); intros.
  auto. destruct n; auto.
Qed.

Lemma iceq_false:
  forall T (A B: T) f1 f2,
  f1 <> f2 ->
  (if iceq f1 f2 then A else B) = B.
Proof.
  intros. case (iceq f1 f2); intros.
  subst. destruct H; auto. auto.
Qed.

Lemma file_desc_eq_true:
  forall T (A B: T) f,
  (if file_desc_eq f f then A else B) = A.
Proof.
  intros.
  destruct (file_desc_eq f f); auto.
  destruct n; auto.
Qed.

Lemma file_desc_eq_false:
  forall T (A B: T) f1 f2,
  f1 <> f2 ->
  (if file_desc_eq f1 f2 then A else B) = B.
Proof.
  intros.
  destruct (file_desc_eq f1 f2); intros.
  subst. destruct H; auto. auto.
Qed.

Lemma oceq_true:
  forall T (A B: T) f,
  (if oceq f f then A else B) = A.
Proof.
  intros. case (oceq f f); intros.
  auto. destruct n; auto.
Qed.

Lemma oceq_false:
  forall T (A B: T) f1 f2,
  f1 <> f2 ->
  (if oceq  f1 f2 then A else B) = B.
Proof.
  intros. case (oceq f1 f2); intros.
  subst. destruct H; auto. auto.
Qed.

Lemma ascii_dec_true:
  forall T (A B: T) c,
  (if ascii_dec c c then A else B) = A.
Proof.
  intros. case (ascii_dec c c); auto.
  intros. destruct n; auto.
Qed.

Lemma ascii_dec_false:
  forall T (A B: T) c1 c2,
  c1 <> c2 ->
  (if ascii_dec c1 c2 then A else B) = B.
Proof.
  intros. case (ascii_dec c1 c2); auto.
  intros; subst; destruct H; auto.
Qed.

Lemma rev_nil_eq_nil:
  forall A (l: list A),
  rev l = nil ->
  l = nil.
Proof.
  intros. apply f_equal with (f := @rev A) in H.
  rewrite rev_involutive in H. auto.
Qed.

Lemma rev_inj:
  forall A (l1 l2: list A),
  rev l1 = rev l2 ->
  l1 = l2.
Proof.
  intros. apply f_equal with (f := @rev A) in H.
  repeat rewrite rev_involutive in H. auto.
Qed.

Definition in_tail {A} (a: A) (l: list A) : Prop :=
  match l with
  | h::t => In a t
  | nil  => False
  end.

Lemma in_tail_app_tail:
  forall A (l1 l2: list A) x,
  In x l2 ->
  l1 <> nil ->
  in_tail x (l1 ++ l2).
Proof.
  intros. destruct l1. destruct H0; auto.
  simpl. apply in_or_app. right; auto.
Qed.

Definition in_mod_last {A} (a: A) (l: list A) : Prop :=
  match rev l with
  | h::t => In a t
  | nil  => False
  end.

Lemma in_mod_last_or:
  forall A (t: list A) (x h: A),
  in_mod_last x (h::t) ->
  x = h \/ in_mod_last x t.
Proof.
  unfold in_mod_last.
  destruct t using rev_ind; simpl. auto.
  rewrite rev_app; simpl; intros.
  apply in_app_or in H.
  destruct H; simpl in H; auto.
  destruct H; auto. contradiction.
Qed.

Inductive uniq {A} : list A -> Prop :=
  | uniq_nil:
      uniq nil
  | uniq_cons:
      forall l a,
      uniq l ->
      ~ In a l ->
      uniq (a :: l).

Lemma uniq_app:
  forall A (l1 l2: list A),
  uniq (l1 ++ l2) -> uniq l1 /\ uniq l2.
Proof.
  induction l1; simpl; intros.
  split. constructor. auto.

  split.
  apply uniq_cons.
  inversion H. apply IHl1 in H2. destruct H2. auto.
  inversion H. unfold not. intros. destruct H3.
  apply in_or_app. left. auto.

  inversion H.
  apply IHl1 in H2. destruct H2. auto.
Qed.

Lemma uniq_end:
  forall A (l: list A) a,
  uniq l ->
  ~ In a l ->
  uniq (l ++ a :: nil).
Proof.
  induction l; simpl; intros.
  constructor; auto.
  constructor; auto.
  apply IHl; auto. inv H; auto.
  unfold not; intros. destruct H0.
  apply in_app_or in H1. simpl in H1.
  destruct H1. inv H. contradiction.
  destruct H0; auto. contradiction.
Qed.

Lemma uniq_app_comm_helper:
  forall A (a : A) (l1 l2: list A),
  ~ In a (l1 ++ l2) -> uniq (l1 ++ l2) -> uniq (l1 ++ a:: l2).
Proof.
  intros A a l1.
  induction l1.

  intros. simpl. apply uniq_cons; auto.

  intros. simpl.
  apply uniq_cons.
   (* use IH *)
  simpl in H0. inv H0.
  assert ( ~ In a (l1 ++ l2)).
  unfold not; intros. destruct H.
  replace ((a0 :: l1) ++ l2) with (a0 :: (l1 ++ l2)).
  apply in_cons; auto. reflexivity.
  apply IHl1; auto.

   (* use the given hypothesis *)
  unfold not; intros. destruct H.
  assert (a = a0).

  apply in_app_or in H1.
  destruct H1. simpl in H0. inv H0. destruct H4.
  apply in_app_iff. left; auto.

  simpl in H. destruct H. auto.
  simpl in H0. inv H0. destruct H4.
  apply in_app_iff. right.  auto.

  rewrite H. simpl. left; auto.
Qed.

Lemma uniq_app_comm:
  forall A (l1 l2: list A),
  uniq (l1 ++ l2) -> uniq (l2 ++ l1).
Proof.
  induction l1.
  intros. rewrite app_nil_r. auto.

  intros.
  simpl in H.
  inversion H.

  eapply uniq_app_comm_helper; eauto.
  unfold not; intros. destruct H3.
  apply in_app_or in H4.
  apply in_app_iff.
  apply or_comm. auto.
Qed.

Lemma map_in_uniq_inv:
  forall A B (f: A -> B) (l: list A) x y,
  f x = f y ->
  uniq (map f l) ->
  In x l ->
  In y l ->
  x = y.
Proof.
  induction l; simpl; intros. contradiction.
  destruct H1; destruct H2; subst. auto.
  inv H0. destruct H5. rewrite H. apply in_map; auto.
  inv H0. destruct H5. rewrite <- H. apply in_map; auto.
  apply IHl; auto. inv H0; auto.
Qed.


Set Warnings "-notation-overridden".

Require Export
  Coq.Init.Datatypes
  Coq.Program.Program
  Coq.Classes.CEquivalence
  Coq.Classes.CRelationClasses
  Coq.Classes.CMorphisms.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.

Close Scope nat_scope.
Delimit Scope category_theory_scope with category_theory.
Open Scope category_theory_scope.

Notation "∀  x .. y , P" := (forall x, .. (forall y, P) ..)
  (at level 200, x binder, y binder, right associativity) :
  category_theory_scope.

Notation "'exists' x .. y , p" := (sigT (fun x => .. (sigT (fun y => p)) ..))
  (at level 200, x binder, right associativity,
   format "'[' 'exists'  '/  ' x  ..  y ,  '/  ' p ']'") :
  category_theory_scope.

Notation "∃  x .. y , P" := (exists x, .. (exists y, P) ..)
  (at level 200, x binder, y binder, right associativity) :
  category_theory_scope.

Notation "x → y" := (x -> y)
  (at level 99, y at level 200, right associativity): category_theory_scope.
Notation "x ↔ y" := (iffT x y)
  (at level 95, no associativity) : category_theory_scope.
Notation "¬ x" := (~(x%category_theory))
  (at level 75, right associativity) : category_theory_scope.
Notation "x ≠ y" := (x%category_theory <> y%category_theory) (at level 70) : category_theory_scope.

Infix "∧" := prod (at level 80, right associativity) : category_theory_scope.

Infix "∨" := sum
  (at level 85, right associativity) : category_theory_scope.

Notation "'λ'  x .. y , t" := (fun x => .. (fun y => t) ..)
  (at level 200, x binder, y binder, right associativity) :
  category_theory_scope.

Class Setoid A := {
  equiv : crelation A;
  setoid_equiv :> Equivalence equiv
}.

Notation "f ≈ g" := (equiv f g) (at level 79) : category_theory_scope.

Program Instance setoid_refl `(sa : Setoid A) :
  Reflexive equiv.
Obligation 1. apply setoid_equiv. Qed.

Program Instance setoid_sym `(sa : Setoid A) :
  Symmetric equiv.
Obligation 1. apply setoid_equiv; auto. Qed.

Program Instance setoid_trans `(sa : Setoid A) :
  Transitive equiv.
Obligation 1.
  apply setoid_equiv.
  destruct sa; simpl in *.
  destruct setoid_equiv0.
  eapply Equivalence_Transitive; eauto.
Qed.

Delimit Scope signature_scope with signature.

Notation "f ++> g" := (respectful f g)%signature
  (right associativity, at level 55) : signature_scope.
Notation "f ==> g" := (respectful f g)%signature
  (right associativity, at level 55) : signature_scope.
Notation "f --> g" := (respectful (Basics.flip f) g)%signature
  (right associativity, at level 55) : signature_scope.

Arguments Proper {A}%type R%signature m.
Arguments respectful {A B}%type (R R')%signature _ _.

Program Instance unit_setoid : Setoid unit := {
  equiv := fun x y => unit
}.
Next Obligation.
  apply Build_Equivalence.
  - unfold Reflexive. trivial.
  - unfold Symmetric. trivial.
  - unfold Transitive. trivial.
Defined.

Program Instance prod_setoid `{Setoid A} `{Setoid B} : Setoid (A * B) := {
  equiv := fun x y => equiv (fst x) (fst y) * equiv (snd x) (snd y)
}.
Next Obligation.
  apply Build_Equivalence.
  - unfold Reflexive; intros; simpl; split; reflexivity.
  - unfold Symmetric. intros x y [eq1 eq2].
    split; [rewrite eq1|rewrite eq2]; reflexivity.
  - unfold Transitive. intros [x1 x2] [y1 y2] [z1 z2] [eq1 eq2] [eq3 eq4].
    split; [rewrite eq1; rewrite eq3 | rewrite eq2; rewrite eq4]; reflexivity.
Defined.

Program Instance pair_respects `{Setoid A} `{Setoid B} :
  Proper (equiv ==> equiv ==> equiv) (@pair A B).
Next Obligation.
  unfold Proper; unfold respectful.
  intros x1 x2 eq1 y1 y2 eq2.
  simpl.
  split; [rewrite eq1 | rewrite eq2]; reflexivity.
Defined.

Program Instance fst_respects {A B} `{Setoid A} `{Setoid B} :
  Proper (equiv ==> equiv) (@fst A B).
Next Obligation.
  unfold Proper; unfold respectful.
  intros x y [eq1 eq2]. rewrite eq1; reflexivity.
Defined.

Program Instance snd_respects {A B} `{Setoid A} `{Setoid B} :
  Proper (equiv ==> equiv) (@snd A B).
Next Obligation.
  unfold Proper; unfold respectful.
  intros x y [eq1 eq2]. rewrite eq2; reflexivity.
Defined.


From Template Require Import All.
Require Import List.
Require Import Template.Ast.
Require Import String.

Open Scope string_scope.

(* Taken from the template-coq parametricity translation *)

Definition tsl_table := list (global_reference * term).

Locate gref_eq_dec.

Fixpoint lookup_tsl_table (E : tsl_table) (gr : global_reference)
  : option term :=
  match E with
  | nil => None
  | hd :: tl =>
    if gref_eq_dec gr (fst hd) then Some (snd hd)
    else lookup_tsl_table tl gr
  end.

Definition default_term := tVar "constant_not_found".

Definition lookup_default (E : tsl_table) (gr : global_reference)
  : term :=
  match (lookup_tsl_table E gr) with
  | None => match gr with
            | ConstRef n => tVar ("Not_found_" ++ n)
            | _ => default_term
            end
  | Some t => t
  end.

Import ListNotations.

(* Partly taken from Template.Typing *) Print context_decl.
Definition it_mkLambda_or_LetIn (t : term) (l : context) :=
  List.fold_left
    (fun acc d =>
       match d.(decl_body) with
       | None => tLambda d.(decl_name) d.(decl_type) acc
       | Some b => tLetIn d.(decl_name) b d.(decl_type) acc
       end) l t.

Definition it_mkProd_or_LetIn (t : term) (l : context) :=
  List.fold_left
    (fun acc d =>
       match d.(decl_body) with
       | None => tProd d.(decl_name)  d.(decl_type) acc
       | Some b => tLetIn d.(decl_name)  b d.(decl_type) acc
       end) l t.

Fixpoint fold_map_internal {A B C : Type} (f : A -> B -> A * C) (a : A)
         (cs : list C) (bs : list B) : A * (list C)
  := match bs with
     | [] => (a, rev cs)
     | hd :: tl => let (a_, c_) := f a hd in fold_map_internal f a_ (c_ :: cs) tl
     end.

Definition fold_map {A B C : Type} (f : A -> B -> A * C) (a : A)
           (bs : list B) : A * (list C) := fold_map_internal f a [] bs.

Fixpoint fold_map' {A B C : Type} (f : A -> B -> A * C) (a : A)
         (bs : list B) : A * (list C)
  := match bs with
     | [] => (a, [])
     | hd :: tl => let (a_, c_) := f a hd in
                   let (a__, cs) := fold_map' f a_ tl in
                   (a__, c_ :: cs)
     end.

Example ex_fold_map : fold_map (fun x y => (x+y, y+1)) 0 [1;2;3] = (6,[2;3;4]).
reflexivity.
Qed.

Example ex_fold_map_fold_map' :
  fold_map (fun x y => (x+y, y+1)) 0 [1;2;3] = fold_map' (fun x y => (x+y, y+1)) 0 [1;2;3].
reflexivity.
Qed.

Definition sect {A B} (s : A -> B) (r : B -> A) := forall (x : A), r (s x) = x.

Definition retract {A B} (s : A -> B) (r : B -> A) := sect r s.

(* Auxiliary definitions related to equality *)
Definition transport {A : Type} {F : A -> Type} {a b : A} (p : a = b) : F a -> F b.
Proof.
  destruct p. apply id.
Defined.

(** Concatenation of paths *)
Definition path_concat {A : Type} {x y z : A} : x = y -> y = z -> x = z.
  intros p q. destruct p. apply q. Defined.

(** Lemma 2.3.9 in the HoTT book *)
Definition transp_concat {A : Type} {B : A -> Type} {x y z : A} {u : B x}
           (p : x = y) (q : y = z) :
  transport q (transport p u) = transport (path_concat p q) u.
  destruct p. reflexivity. Defined.

Definition ap {A B} (f : A -> B) {x y} : x = y -> f x = f y.
    destruct 1. reflexivity.
Defined.

(* Lemma 2.3.10 in the HoTT book *)
Definition transp_naturality {A B : Type} {C : B -> Type} {x y : A} {f : A -> B}
           {u : C (f x)} (p : x = y) :
  transport (ap f p) u =  @transport _ (fun x => C (f x)) _ _ p u.
  destruct p. reflexivity. Defined.

(* Lemma 2.3.11 in the HoTT book *)
Definition move_transport {A : Type}{F G : A -> Type}(f : forall {a : A}, F a -> G a)
           {a a' : A} (u : F a) (p : a = a') : f (transport p u) = transport p (f u).
  destruct p. reflexivity. Defined.

Definition concat_inv_r {A : Type} {x y : A} (p : x = y) :
  path_concat p (eq_sym p) = eq_refl.
  destruct p. reflexivity. Defined.

Definition concat_inv_l {A : Type} {x y : A} (p : x = y) :
  path_concat (eq_sym p) p = eq_refl.
  destruct p. reflexivity. Defined.


(** * Univalence axiom and functional extensionality.  Vladimir Voevodsky. Feb. 2010 - Sep. 2011

This file contains the formulation of the univalence axiom and the proof that it implies functional extensionality for functions - Theorem funextfun.

*)

(** *** Preamble. *)

(** *** Imports. *)

Unset Automatic Introduction. (** This line has to be removed for the file to compile with Coq8.2 *)

Add LoadPath "../..".

Require Export Foundations.Generalities.uu0.

(** ** Univalence axiom. *)

Definition eqweqmap { T1 T2 : UU } ( e: paths T1 T2 ) : weq T1 T2 .
Proof. intros. destruct e . apply idweq. Defined.

Axiom univalenceaxiom :  forall T1 T2 : UU ,  isweq ( @eqweqmap T1 T2 ).

Definition weqtopaths { T1 T2 : UU } ( w : weq T1 T2 ) : paths T1 T2  :=  invmap ( weqpair _ ( univalenceaxiom T1 T2 ) ) w.

Definition weqpathsweq { T1 T2 : UU } ( w : weq T1 T2 ) : paths ( eqweqmap ( weqtopaths w ) ) w  :=  homotweqinvweq ( weqpair _ ( univalenceaxiom T1 T2 ) ) w.

(** We show that [ univalenceaxiom ] is equivalent to the axioms [ weqtopaths0 ] and [ weqpathsweq0 ] stated below . *)

Axiom weqtopaths0 : forall ( T1 T2 : UU ) ( w : weq T1 T2 ) , paths T1 T2.

Axiom weqpathsweq0 : forall ( T1 T2 : UU ) ( w : weq T1 T2 ) ,  paths ( eqweqmap ( weqtopaths0 _ _ w ) ) w.

Theorem univfromtwoaxioms ( T1 T2 : UU ) : isweq ( @eqweqmap T1 T2 ).
Proof. intros. set ( P1 := fun XY : dirprod UU UU => ( match XY with  tpair _ X Y =>  paths X Y end ) ) . set ( P2 := fun XY :  dirprod UU UU => match XY with  tpair _ X Y => weq X Y end ) . set ( Z1 := total2 P1 ). set ( Z2 := total2 P2 ). set ( f := totalfun _ _ ( fun XY :  dirprod UU UU => match XY with  tpair _ X Y => @eqweqmap X Y end ) : Z1 -> Z2 ) . set ( g := totalfun _ _ ( fun XY : dirprod UU UU => match XY with  tpair _ X Y => weqtopaths0 X Y end ) : Z2 -> Z1 ) . set ( s1 := fun X Y  : UU => fun w : weq X Y =>  tpair P2 (  dirprodpair X Y ) w ) . set ( efg := fun a => match a as a' return (  paths ( f ( g a' ) ) a' ) with  tpair _ ( tpair _ X Y ) w => ( maponpaths ( s1 X Y ) ( weqpathsweq0 X Y w ) ) end ) .

set ( h := fun a1 : Z1 =>  pr1 ( pr1 a1 ) ) .
assert ( egf0 : forall a1 : Z1 ,  paths ( pr1 ( g ( f a1 ) ) ) (  pr1 a1 ) ). intro. apply  idpath.
assert ( egf1 : forall a1 a1' : Z1 ,  paths ( pr1 a1' ) (  pr1 a1 ) ->  paths a1' a1 ). intros.  set ( X' :=  maponpaths ( @pr1 _ _ ) X ).
assert ( is : isweq h ).  apply isweqpr1pr1 . apply ( invmaponpathsweq ( weqpair h is ) _ _ X' ).
set ( egf := fun a1  => ( egf1 _ _ ( egf0 a1 ) ) ).
set ( is2 := gradth _ _ egf efg ).
apply ( isweqtotaltofib P1 P2  ( fun XY : dirprod UU UU => match XY with  tpair _ X Y => @eqweqmap X Y end ) is2 ( dirprodpair T1 T2 ) ). Defined.

(** Conjecture :  the pair [weqtopaths0] and [weatopathsweq0] is well defined up to a canonical equality. **)

(** ** Transport theorem.

Theorem saying that any general scheme to "transport" a structure along a weak equivalence which does not change the structure in the case of the identity equivalence is equivalent to the transport along the path which corresponds to a weak equivalence by the univalenceaxiom. As a corollary we conclude that for any such transport scheme the corresponding maps on spaes of structures are weak equivalences. *)

Lemma isweqtransportf10 { X : UU } ( P : X -> UU ) { x x' : X } ( e :  paths x x' ) : isweq ( transportf P e ).
Proof. intros. destruct e.  apply idisweq. Defined.

Lemma isweqtransportb10 { X : UU } ( P : X -> UU ) { x x' : X } ( e :  paths x x' ) : isweq ( transportb P e ).
Proof. intros. apply ( isweqtransportf10 _ ( pathsinv0 e ) ). Defined.

Lemma l1  { X0 X0' : UU } ( ee : paths X0 X0' ) ( P : UU -> UU ) ( pp' : P X0' ) ( R : forall X X' : UU , forall w : weq X X' , P X' -> P X ) ( r : forall X : UU , forall p : P X , paths ( R X X ( idweq X ) p ) p ) : paths ( R X0 X0' ( eqweqmap ee ) pp' ) (  transportb P ee pp' ).
Proof. intro. intro. intro. intro. intro. destruct ee. simpl. intro. intro. apply r. Defined.

Theorem weqtransportb ( P : UU -> UU ) ( R : forall ( X X' : UU ) ( w :  weq X X' ) , P X' -> P X ) ( r : forall X : UU , forall p : P X , paths ( R X X ( idweq X ) p ) p ) :  forall ( X X' : UU ) ( w :  weq X X' ) ( p' : P X' ) , paths ( R X X' w p' ) (  transportb P ( weqtopaths w ) p' ).
Proof. intros. set ( uv := weqtopaths w ).   set ( v := eqweqmap uv ).

assert ( e : paths v w ) . unfold weqtopaths in uv.  apply ( homotweqinvweq ( weqpair _ ( univalenceaxiom X X' ) ) w ).

assert ( ee : paths ( R X X' v p' ) ( R X X' w p' ) ) . set ( R' := fun vis : weq X X' => R X X' vis p' ). assert ( ee' : paths ( R' v ) ( R' w ) ). apply (  maponpaths R' e ). assumption.

destruct ee. apply l1. assumption. Defined.

Corollary isweqweqtransportb ( P : UU -> UU ) ( R :  forall ( X X' : UU ) ( w :  weq X X' ) , P X' -> P X ) ( r :  forall X : UU , forall p : P X , paths ( R X X ( idweq X ) p ) p ) :  forall ( X X' : UU ) ( w :  weq X X' ) , isweq ( fun p' :  P X' => R X X' w p' ).
Proof. intros. assert ( e : forall p' : P X' , paths ( R X X' w p' ) (  transportb P ( weqtopaths w ) p' ) ). apply weqtransportb. assumption. assert ( ee : forall p' : P X' , paths  ( transportb P ( weqtopaths w ) p' ) ( R X X' w p' ) ). intro.  apply ( pathsinv0 ( e p' ) ). clear e.

assert ( is1 : isweq ( transportb P ( weqtopaths w ) ) ). apply isweqtransportb10.
apply ( isweqhomot ( transportb P ( weqtopaths w ) ) ( fun p'  :  P X' => R X X' w p' ) ee is1 ).  Defined.

(** Theorem saying that composition with a weak equivalence is a weak equivalence on function spaces. *)

Theorem isweqcompwithweq { X X' : UU } ( w : weq X X' ) ( Y : UU ) :  isweq ( fun f : X' -> Y => ( fun x : X => f ( w x ) ) ).
Proof. intros.
set ( P := fun X0 : UU => ( X0 -> Y ) ).
set ( R := fun X0 : UU => ( fun X0' : UU => ( fun w1 : X0 -> X0' =>  ( fun  f : P X0'  => ( fun x : X0 => f ( w1 x ) ) ) ) ) ).
set ( r := fun X0 : UU => ( fun f : X0 -> Y => pathsinv0 ( etacor f ) ) ).
apply ( isweqweqtransportb P R r X X' w ). Defined.

(** ** Proof of the functional extensionality for functions *)

Lemma eqcor0 { X X' : UU } ( w :  weq X X' ) ( Y : UU ) ( f1 f2 : X' -> Y ) : paths ( fun x : X => f1 ( w x ) )  ( fun x : X => f2 ( w x ) ) -> paths f1 f2.
Proof. intros. apply ( invmaponpathsweq ( weqpair _ ( isweqcompwithweq w Y ) ) f1 f2 ). assumption.  Defined.

Lemma apathpr1topr ( T : UU ) : paths ( fun z :  pathsspace T => pr1 z ) ( fun z : pathsspace T => pr1 ( pr2 z ) ).
Proof. intro. apply ( eqcor0  ( weqpair _ ( isweqdeltap T ) ) _ ( fun z :  pathsspace T => pr1 z ) ( fun z :  pathsspace T => pr1 ( pr2 z ) ) ( idpath ( idfun T ) ) ) . Defined.

Theorem funextfun { X Y : UU } ( f1 f2 : X -> Y ) ( e :  forall x : X , paths ( f1 x ) ( f2 x ) ) : paths f1 f2.
Proof. intros. set ( f := fun x : X => pathsspacetriple Y ( e x ) ) .  set ( g1 := fun z : pathsspace Y => pr1 z ) . set ( g2 := fun z :  pathsspace Y => pr1 ( pr2 z ) ). assert ( e' : paths g1 g2 ). apply ( apathpr1topr Y ). assert ( ee : paths  ( fun x : X => f1 x ) ( fun x : X => f2 x ) ). change ( paths (fun x : X => g1 ( f x ) ) (fun x : X => g2 ( f x ) ) ) . destruct e' .  apply idpath .   apply etacoronpaths. apply ee . Defined.

(* End of the file funextfun.v *)


(***************************************************************************
* Safety for STLC with Patterns - Proofs                                  *
* Arthur Chargueraud, July 2007                                            *
***************************************************************************)

Set Implicit Arguments.
Require Import List LibLN
  STLC_Pat_Definitions
  STLC_Pat_Infrastructure.

(* ********************************************************************** *)
(** * Proofs *)

(** Typing is preserved by weakening. *)

Lemma typing_weaken : forall G E F t T,
   (E & G) |= t ~: T ->
   ok (E & F & G) ->
   (E & F & G) |= t ~: T.
Proof.
  introv Typ. inductions Typ with gen_eq H:(E & G)
   and gen G, introv end; introv Ok.
  apply* typing_var. apply* binds_weaken.
  apply_fresh* typing_abs.
   do_rew* concat_assoc (apply* H0).
  apply_fresh* typing_let as xs.
    do_rew* concat_assoc (apply* H1).
  autos*.
  autos*.
Qed.

(** Typing is preserved by substitution. *)

Lemma typing_subst : forall F U E t T z u,
  (E & z ~ U & F) |= t ~: T ->
  E |= u ~: U ->
  (E & F) |= [z ~> u]t ~: T.
Proof.
  introv Typt Typu. inductions Typt with gen_eq G:(E & z ~ U & F)
   and gen F, introv end; simpl subst.
  case_var.
    binds_get H0. apply_empty* typing_weaken.
    binds_cases H0; apply* typing_var.
  apply_fresh typing_abs.
   rewrite* subst_open_vars.
   do_rew concat_assoc (apply* H0).
  apply_fresh* typing_let as xs.
   rewrite* subst_open_vars.
   do_rew* concat_assoc (apply* H1).
  autos*.
  autos*.
Qed.

(** Typing is preserved by iterated substitution. *)

Lemma typing_substs : forall Us E xs ts t T,
   length xs = length ts ->
   typings E ts Us ->
   E & (iter_push xs Us) |= t ~: T ->
   E |= substs xs ts t ~: T.
Proof.
  intros Us E xs. inductions xs with gen Us E end;
   simpl; introv Le Typts Typt. auto.
  destruct ts; simpls; inversions Le. inversions Typts.
  rewrite iter_push_cons in Typt.
  rewrite <- concat_assoc in Typt.
  apply* (@IHxs Us0).
  apply* typing_subst.
Qed.

(** Typing the result of pattern matching. *)

Lemma typing_pattern_match : forall p t T E ts Us,
  Pat_match ts p t ->
  E |= t ~: T ->
  Pat_typing Us p T ->
  typings E ts Us.
Proof.
  introv Pat. induction Pat; introv Typt Typp.
Admitted.

(** Preservation (typing is preserved by reduction). *)

Lemma preservation_result : preservation.
Proof.
  introv Typ. gen t'.
  induction Typ; introv Red; inversions Red.
  pick_freshes (pat_arity p1) xs.
   asserts_skip: (terms (length xs) ts).
   rewrite* (@substs_intro xs).
   apply~ (@typing_substs Us). unfolds~ terms.
   apply~ (@typing_pattern_match p1 t1 T).
  autos*.
  inversions Typ1. pick_fresh x.
    rewrite* (@substs_intro (x::nil)). unfolds substs.
    apply_empty* typing_subst.
  autos*.
  autos*.
  autos*.
  autos*.
Qed.

(** Lemma : well-typed pattern matching never fails. *)

Lemma matching_successful : forall p Us v T,
  empty |= v ~: T ->
  value v ->
  Pat_typing Us p T ->
  exists vs, Pat_match vs p v.
Proof.

  (* todo : prouver que :
  pat_typing Us p T ->   (* induction l dessus *)
  binds p ns ->
  empty |= v ~: T ->
  value v ->
  exists ms, .

   *)

Admitted.

(** Progress (a well-typed term is either a value or it can
  take a step of reduction). *)

Lemma progress_result : progress.
Proof.
  introv Typ. lets Typ': Typ.
  inductions Typ with gen_eq E:(empty:env).
  false.
  left*.
  right. destruct~ IHTyp as [Val1 | [t1' Red1]].
    destruct~ (@matching_successful p1 Us t1 T) as [vs Eq].
     exists~ (t2 ^^ vs).
    exists* (trm_let p1 t1' t2).
  right. destruct~ IHTyp1 as [Val1 | [t1' Red1]].
    destruct~ IHTyp2 as [Val2 | [t2' Red2]].
      inversions Typ1; inversions Val1.
       exists* (t0 ^^ (t2::nil)).
      exists* (trm_app t1 t2').
    exists* (trm_app t1' t2).
  destruct~ IHTyp1 as [Val1 | [t1' Red1]].
    destruct~ IHTyp2 as [Val2 | [t2' Red2]].
     right. exists* (trm_pair t1 t2').
     right. exists* (trm_pair t1' t2).
Qed.


Require Import BaseTree Tree.

Set Implicit Arguments.

Definition Time := nat.
Definition Index := nat.

Parameter Addr: Set.
Parameter zero: Addr.
Axiom decAddr: forall a1 a2:Addr, {a1 = a2} + {a1 <> a2}.

Inductive Desc := Ld | St.

Parameter Data: Set.
Axiom decData: forall (d1 d2: Data), {d1 = d2} + {d1 <> d2}.

Parameter bHier : BaseTree.

Definition hier := getC nil bHier.
Opaque hier.

Record Cache := { node: Tree;
                  def: descendent node hier }.

Record Proc := { proc: Cache;
                 isLeaf: leaf (node proc) }.

Definition p_node x := node (proc x).

Record Req := { desc: Desc;
                dataQ: Data
              }.

Record Resp := { procR: Proc;
                 idx: Index;
                 datum: Data
               }.

Parameter reqFn: Addr -> Proc -> Index -> Req.
Parameter initData: Addr -> Data.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************)
(*              Intensional Lambda Calculus                           *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus from Project Coq                                   *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                LamSF_Substitution_term.v                           *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(* adapted from Substitution.v of Project Coq  to act on boa-terms    *)
(**********************************************************************)

Require Import Arith.
Require Import Test.
Require Import General.
Require Import LamSF_Terms.
Require Import LamSF_Tactics.
Require Import Omega.

(* Lifting lemmas *)

Lemma lift_rec_null_term :
forall (U : lamSF)(n: nat), lift_rec U n 0 = U.
Proof.
simple induction U; split_all.
relocate_lt; auto.
Qed.

Lemma lift1 :
 forall (U : lamSF) (j i k : nat),
 lift_rec (lift_rec U i j) (j + i) k = lift_rec U i (j + k).
Proof.
simple induction U; simpl in |- *;  split_all.
unfold relocate.
elim (test i n); elim (test (j+i) (j+ n)); split_all; try noway.
assert(k + (j + n) = j + k + n) by omega. congruence.
elim (test (j + i) n); split_all; try noway.

unfold relocate.
replace (S(j+i)) with (j+ S i) by omega.
rewrite H. auto.
Qed.

Lemma lift_lift_rec :
 forall (U : lamSF) (k p n i : nat),
 i <= n ->
 lift_rec (lift_rec U i p) (p + n) k = lift_rec (lift_rec U n k) i p.
Proof.
simple induction U; simpl in |- *;  split_all.
(* Ref *)
unfold relocate.
elim(test i n); split_all; try noway.
elim(test n0 n); split_all; try noway.
elim(test (p+n0) (p+n)); split_all; try noway.
elim(test i (k+n)); split_all; try noway.
assert(k+(p+n) = p+ (k+n)) by omega.
rewrite H0; auto.
elim(test (p+n0) (p+n)); split_all; try noway.
elim(test i n); split_all; try noway.
elim(test n0 n); split_all; try noway.
elim(test (p+n0) n); split_all; try noway.
elim(test i n); split_all; try noway.
(* Abs *)
replace(S(p + n)) with (p + S n) by omega.
rewrite H; split_all. omega.
(* Ap *)
rewrite H; split_all.  rewrite H0; split_all.
Qed.

Lemma lift_lift_term :
 forall (U : lamSF) (k p n : nat),
 lift_rec (lift p U) (p+ n) k = lift p (lift_rec U n k).
Proof.
unfold lift in |- *; intros; apply lift_lift_rec; trivial with arith.
Qed.

Lemma liftrecO : forall (U : lamSF) (n : nat), lift_rec U n 0 = U.
Proof.
simple induction U; simpl in |- *; intros; split_all; relocate_lt; congruence.
Qed.

Lemma liftO : forall (U : lamSF) , lift 0 U = U.
Proof.
unfold lift in |- *; split_all; apply liftrecO.
Qed.

Lemma lift_rec_lift_rec :
 forall (U : lamSF) (n p k i : nat),
 k <= i + n ->
 i <= k -> lift_rec (lift_rec U i n) k p = lift_rec U i (p + n).

Proof.
simple induction U; split_all.
(* Ref *)
unfold relocate.
elim(test i n); split_all; try noway.
elim(test k (n0 + n)); split_all; try noway.
replace (p+(n0+n)) with (p + n0 + n) by omega. auto.
elim(test k n); split_all; try noway.
(* Abs *)
rewrite H; split_all; try omega.
(* Ap *)
rewrite H; split_all; rewrite H0; split_all; split_all.
Qed.

Lemma lift_rec_lift :
 forall (U : lamSF)  (n p k i : nat),
 k <= n -> lift_rec (lift  n U)  k p = lift (p + n) U.
Proof.
unfold lift in |- *; intros; rewrite lift_rec_lift_rec; trivial with arith.
Qed.

Lemma gt_plus : forall i m n : nat, i>m+n -> i> n.
Proof.
induction m.
simpl; tauto.
intros; apply (IHm); auto with arith.
Qed.

Lemma le_plus : forall i m n : nat, i +m <= n -> i<= n.
Proof.
induction m; intros.
elim H;  auto with arith.
apply (IHm).
apply le_trans with (i+S m).
auto with arith. trivial.

Qed.

Ltac lrlr_absurd p k n :=
absurd (p+S k> S n); [
apply le_not_gt;
replace (p+ S k) with (S (p+k)); auto with arith | trivial].

(* The three cases of substitution of U for (Ref n) *)

Lemma subst_eq :
 forall (M U : lamSF) (n : nat), subst_rec (Ref n) U n = lift n U.
Proof.
simpl in |- *; unfold insert_Ref in |- *; split_all.
elim (compare n n); intro P; try noway.
elim P; intro Q; simpl in |- *; trivial with arith; try noway.
Qed.

Lemma subst_gt :
 forall (M U : lamSF) (n p : nat),
 n > p -> subst_rec (Ref n) U p = Ref (pred n).
Proof.
simpl in |- *; unfold insert_Ref in |- *.
intros; elim (compare p n); intro P.
elim P; intro Q; trivial with arith.
absurd (n > p); trivial with arith; rewrite Q; trivial with arith.
absurd (n > p); auto with arith.
Qed.

Lemma subst_lt :
 forall (M U : lamSF) (n p : nat), p > n -> subst_rec (Ref n) U p = Ref n.
Proof.
simpl in |- *; unfold insert_Ref in |- *.
intros; elim (compare p n); intro P; trivial with arith.
absurd (p > n); trivial with arith; elim P; intro Q; auto with arith.
rewrite Q; trivial with arith.
Qed.

(* Substitution lemma *)

Lemma lift_rec_subst_rec :
 forall (V U : lamSF) (k p n : nat),
 lift_rec (subst_rec V U p) (p + n) k =
 subst_rec (lift_rec V (S (p + n)) k) (lift_rec U n k) p.
Proof.
simple induction V; split_all.
(* 1 Ref *)
unfold insert_Ref, relocate in |- *.
elim (test (S(p + n0)) n); elim (compare p n); split_all.
elim a; elim(compare p (k+n)); split_all.
unfold relocate.
elim(test (p+n0) (pred n)); elim a1; split_all; try noway.
replace (k + pred n) with (pred (k + n)) by omega; auto.
noway.
noway.
noway.
noway.
elim a; split_all.
unfold relocate. elim(test(p+n0) (pred n)); split_all.
noway.
unfold lift.
rewrite lift_lift_rec; auto; omega.
unfold relocate.
elim(test (p+n0) n); split_all.
noway.
replace(S(p+n)) with (S p + n) by omega.
congruence.
Qed.

Lemma lift_subst :
 forall (U V : lamSF) (k n : nat),
 lift_rec (subst U V) n k =
 subst (lift_rec U n k) (lift_rec V (S n) k).
Proof.
unfold subst in |- *; intros.
replace (S n) with (S (0 + n)).
elim lift_rec_subst_rec; trivial with arith.
simpl in |- *; trivial with arith.
Qed.

Lemma subst_rec_lift_rec1 :
 forall (U V : lamSF) (n p k : nat),
 k <= n ->
 subst_rec (lift_rec U k p) V (p + n) =
 lift_rec (subst_rec U V n) k p.
Proof.
simple induction U; intros; simpl in |- *; split_all.
(* Ref *)
unfold insert_Ref, relocate.
elim(test k n); split_all.
elim(compare n0 n); split_all; try noway.
elim a0; split_all; try noway.
elim(compare (p+n0) (p+n)); split_all.
elim a2; split_all; try noway.
unfold relocate.
elim(test k (pred n)); split_all; try noway.
assert(pred (p+n) = p + pred n) by omega. auto.
noway.
elim(compare (p+n0) (p+n)); split_all.
elim a1; split_all; try noway.
unfold lift. rewrite lift_rec_lift_rec; split_all; try omega.
unfold lift. rewrite lift_rec_lift_rec; split_all; try omega.
elim(compare (p+n0) (p+n)); split_all.
elim a0; split_all; try noway.
unfold relocate.
elim(test k n); split_all; try noway.
elim(compare (p+n0) n); split_all; try noway.
elim a; split_all; try noway.
elim(compare n0 n); split_all; try noway.
elim a; split_all; try noway.
unfold relocate.
elim(test k n); split_all; try noway.

(* 2 subgoals *)
replace (S(p + n)) with (p + S n) by omega.
rewrite H; split_all; omega.
(* 1 *)
rewrite H; split_all.  rewrite H0; split_all.
Qed.

Lemma subst_rec_lift1 :
 forall (U V : lamSF) (n p : nat),
 subst_rec (lift p U) V (p + n) = lift p (subst_rec U V n).
Proof.
unfold lift in |- *; intros; rewrite subst_rec_lift_rec1;
 trivial with arith.
Qed.

Lemma subst_rec_lift_rec :
 forall (U V : lamSF) (p q n : nat),
 q <= p + n ->
 n <= q -> subst_rec (lift_rec U n (S p)) V q = lift_rec U n p.
Proof.
simple induction U; intros; simpl in |- *; split_all.
unfold relocate. elim(test n0 n); split_all.
unfold insert_Ref.
elim(compare q (S(p+n))); split_all; try noway.
elim a0; split_all; try noway.
unfold insert_Ref.
elim(compare q n); split_all; try noway.
elim a; split_all; try noway.

(* 2 *)
rewrite H; auto; omega.
(* 1 *)
rewrite H; split_all.
rewrite H0; auto.
Qed.

(* subst_rec_subst_rec *)

Lemma subst_rec_subst_rec :
 forall (V U W : lamSF) (n p : nat),
 subst_rec (subst_rec V U p) W (p + n) =
 subst_rec (subst_rec V W (S (p + n))) (subst_rec U W n) p.
Proof.
simple induction V;  split_all.

unfold insert_Ref in |- *.
elim (compare p n); split_all.
elim a; split_all.
elim (compare (S (p + n0)) n); split_all.
elim a1; split_all; try noway.
unfold insert_Ref.
elim (compare (p+n0) (pred n)); split_all; try noway.
elim a3; split_all; try noway.
elim (compare p (pred n)); split_all; try noway.
elim a5; split_all; try noway.
unfold lift; split_all.
unfold insert_Ref.
elim (compare (p+n0) (pred n)); split_all; try noway.
elim a2; split_all; try noway.
subst. unfold lift.
rewrite subst_rec_lift_rec; split_all; try omega.
unfold insert_Ref.
elim(compare (p+n0) (pred n)); split_all; try noway.
elim a1; split_all; try noway.
elim(compare p n); split_all; try noway.
elim a1; split_all; try noway.
elim (compare (S (p + n0)) n); split_all; try noway.
elim a0; split_all; try noway.
unfold insert_Ref.
elim(compare p n); split_all; try noway.
elim a0; split_all; try noway.
unfold lift.
subst.
rewrite subst_rec_lift_rec1; split_all.  omega.

unfold insert_Ref.
elim(compare (p+n0) n); split_all; try noway.
elim a; split_all; try noway.
elim(compare (S(p+n0)) n); split_all; try noway.
elim a; split_all; try noway.
unfold insert_Ref.
elim(compare p n); split_all; try noway.
elim a; split_all; try noway.

replace(S(p + n)) with (S p + n) by omega.
rewrite H; split_all; omega.
Qed.

Lemma subst_rec_subst_0 :
 forall (U V W : lamSF) (n : nat),
 subst_rec (subst_rec V U 0) W n =
 subst_rec (subst_rec V W (S n)) (subst_rec U W n) 0.
Proof.
intros; pattern n at 1 3 in |- *.
replace n with (0 + n) by trivial with arith.
rewrite (subst_rec_subst_rec V U W n 0); trivial with arith.
Qed.

(**************************)
(* The Substitution Lemma *)
(**************************)

Lemma substitution :
 forall (U V W : lamSF) (n : nat),
 subst_rec (subst U V) W n =
 subst (subst_rec U W n) (subst_rec V W (S n)).
Proof.
unfold subst in |- *; intros; apply subst_rec_subst_0; trivial with arith.
Qed.

(* to show (\ t)0 -> t  *)

Lemma lift_rec_null :
forall (U : lamSF) (n: nat), lift_rec U n 0 = U.
Proof. simple induction U; split_all.
 rewrite relocate_null; congruence.
Qed.

Lemma subst_lift_null :
forall (W V : lamSF)(n : nat), subst_rec (lift_rec W n 1) V n = W.
Proof.
simple induction W; split_all.
unfold insert_Ref.
unfold relocate.
elim(test n0 n); split_all.
elim(compare n0 (S n)); split_all.
elim a0; split_all; noway.
noway.
elim(compare n0 n); split_all.
elim a; split_all. noway.
noway.
Qed.

(* more  Properties *)

Lemma lift_rec_lift2 :
forall M n k, lift_rec (lift 1 M) (S n) k = lift 1 (lift_rec M n k).
Proof.
split_all.
unfold lift.
replace (S n) with (1+n) by omega.
rewrite lift_lift_rec; auto.
omega.
Qed.

Lemma relocate_null2 :
forall n k, relocate 0 (S n) k = 0.
Proof. split_all. Qed.

Lemma subst_rec_lift2 :
forall M N n , subst_rec (lift 1 M) N (S n)  = lift 1 (subst_rec M N n).
Proof.
split_all.
unfold lift.
replace (S n) with (1+n) by omega.
rewrite subst_rec_lift_rec1; auto.
omega.
Qed.

Lemma subst_rec_lift_rec2 : forall M n,
subst_rec (lift_rec M (S n) 1) (Ref 0) n = M.
Proof. induction M; split_all.
unfold relocate.
elim(test (S n0) n); split_all.
insert_Ref_out. auto.
unfold insert_Ref.
elim(compare n0 n); split_all.
elim a; split_all.
noway.
unfold lift; split_all.
relocate_lt.
subst; auto.
Qed.