Require Import Merges.Tactics.
Require Import Merges.Map.

Require Import Merges.List.List.
Require Import Coq.Lists.List.
Import ListNotations.
Set Implicit Arguments.

Module Type While.
 Variable Stream : Set.
 Variable Scalar : Set.
 Variable Value  : Set.

 Variable StreamEqDec : EqDec Stream.
 Variable ScalarEqDec : EqDec Scalar.
End While.

Module Program (W : While).
 Definition Heap := Map W.Scalar W.Value.
 Definition Exp  := Heap -> W.Value.
 Definition Pred := Heap -> bool.
 Definition StreamHeap := Map W.Stream (list W.Value).

 (* Pull from an input *)
 Definition streamPull (i : W.Stream) (is : StreamHeap) : (StreamHeap * option W.Value)
  := match is i with
     | []
        => (is, None)
     | (x::xs)
        => (update _ _ W.StreamEqDec i xs is, Some x)
     end.

 (* Push to an output *)
 Definition streamPush (o : W.Stream) (v : W.Value) (os : StreamHeap) : StreamHeap
  := update _ _ W.StreamEqDec o (v :: os o) os.

 (* Push to an output *)
 Definition scalarWrite (n : W.Scalar) (v : W.Value) (h : Heap) : Heap
  := update _ _ W.ScalarEqDec n v h.

 Inductive Program
  := Skip  : Program
   | Push  : W.Stream -> Exp -> Program
   | Pull  : W.Scalar -> W.Stream -> Program -> Program
   | Write : W.Scalar -> Exp -> Program
   | While : Pred -> Program -> Program
   | Semicolon : Program -> Program -> Program.

 Notation "a ';' b" := (Semicolon a b) (at level 20).

 Inductive Exec (h : Heap) (sh : StreamHeap) : Program -> Heap -> StreamHeap -> Prop
  := ESkip : Exec h sh Skip h sh
   | EPush : forall s v,
             Exec h sh
                 (Push s v)
                  h (streamPush s (v h) sh)

   | EPullNone : forall n s p sh',
             streamPull s sh = (sh', None) ->
             Exec h sh
                 (Pull n s p)
                  h sh'
   | EPullSome : forall n s p sh' v h'' sh'',
             streamPull s sh = (sh', Some v) ->
             Exec (scalarWrite n v h) sh' p h'' sh'' ->
             Exec h sh
                 (Pull n s p)
                  h'' sh''

   | EWrite : forall n x,
             Exec h sh
                 (Write n x)
                  (scalarWrite n (x h) h) sh

   | EWhileDone : forall pred prog,
             pred h = false ->
             Exec h sh
                 (While pred prog)
                  h sh
   | EWhileGo : forall pred prog h' sh' h'' sh'',
             pred h = true ->
             Exec h sh prog h' sh' ->
             Exec h' sh'
                 (While pred prog)
                  h'' sh'' ->
             Exec h sh
                 (While pred prog)
                  h'' sh''

   | ESemicolon : forall p1 p2 h' sh' h'' sh'',
             Exec h sh   p1 h' sh' ->
             Exec h' sh' p2 h'' sh'' ->
             Exec h sh
                 (Semicolon p1 p2)
                  h'' sh''
   .

 Theorem Exec_deterministic p:
  forall h sh h' sh' h'' sh'',
  Exec h sh p h'  sh'  ->
  Exec h sh p h'' sh'' ->
  h' = h'' /\
  sh' = sh''.
 Proof.
  intros.
  gen h'' sh''.
  induction H; intros;
   try solve [inverts H0; best_bet].

  inverts H0; rewrite H in *.

  injects H6; best_bet.
  inverts H6.

  inverts H1; rewrite H in *.
  inverts H7.
  injects H7; best_bet.

  inverts H2.
  rewrite H in *; inverts H7.

  assert (h' = h'0 /\ sh' = sh'0).
  apply IHExec1. assumption.
  inverts H2.
  apply IHExec2. assumption.

  inverts H1.
  assert (h' = h'0 /\ sh' = sh'0).
  apply IHExec1. assumption.
  inverts H1.
  apply IHExec2. assumption.
 Qed.

End Program.

Module Drain <: While.
 Inductive Stream' := StreamIn.
 Definition Stream := Stream'.
 Inductive Scalar' := ScalarDone.
 Definition Scalar := Scalar'.
 Definition Value  := nat.
 Definition StreamEqDec : EqDec Stream.
  unfold EqDec.
  intros.
  destruct n; destruct m; eauto.
 Qed.

 Definition ScalarEqDec : EqDec Scalar.
  unfold EqDec.
  intros.
  destruct n; destruct m; eauto.
 Qed.
End Drain.

Module Drain'.
 Module Program' := Program Drain.
 Import Program'.
 Import Drain.

 Notation "! p" := (fun _ => p) (at level 0).

 Definition P
  := Write ScalarDone !0;
     While (fun h => beq_nat (h ScalarDone) 0)
     ( Write ScalarDone !1;
       Pull ScalarDone StreamIn
       ( Write ScalarDone !0)).

 Lemma write_same i s:
  scalarWrite ScalarDone i s = (fun _ => i).
 Proof.
  apply MapExtensional.
  destruct k.
  unfold scalarWrite.
  apply update_eq_is.
 Qed.

 Lemma update_same i s:
  (update Stream (list Value) StreamEqDec StreamIn i s) = (fun _ => i).
 Proof.
  apply MapExtensional.
  destruct k. apply update_eq_is.
 Qed.

 Lemma runs (l : list nat):
  Exec (fun _ => 0) (fun _ => l) P
       (fun _ => 1) (fun _ => []).
 Proof.
  unfold P.
  econstructor. econstructor.

  induction l.
  eapply EWhileGo.

  unfold scalarWrite; rewrite update_eq_is; best_bet.

  econstructor; econstructor.
  unfold streamPull.
  eauto.
  rewrite write_same.
  eapply EWhileDone. simpl. eauto.

  eapply EWhileGo.
  rewrite write_same. eauto.
  econstructor.
  econstructor.
  eapply EPullSome.
  unfold streamPull; eauto.
  rewrite write_same.
  econstructor.
  simpl.
  rewrite write_same in *.
  rewrite update_same in *.
  apply IHl.
 Qed.

End Drain'.

Module Id <: While.
 Inductive Stream' := StreamIn | StreamOut.
 Definition Stream := Stream'.
 Inductive Scalar' := ScalarDone.
 Definition Scalar := Scalar'.
 Definition Value  := nat.
 Definition StreamEqDec : EqDec Stream.
  unfold EqDec.
  intros.
  destruct n; destruct m; eauto.
  right. intros ne. inverts ne.
  right. intros ne. inverts ne.
 Qed.

 Definition ScalarEqDec : EqDec Scalar.
  unfold EqDec.
  intros.
  destruct n; destruct m; eauto.
 Qed.
End Id.

Module Id'.
 Module Program' := Program Id.
 Import Program'.
 Import Id.

 Notation "! p" := (fun _ => p) (at level 0).

 Definition Loop
  := While (fun h => beq_nat (h ScalarDone) 0)
     ( Write ScalarDone !1;
       Pull ScalarDone StreamIn
       ( Push StreamOut (fun h => h ScalarDone);
         Write ScalarDone !0)).

 Definition P
  := Write ScalarDone !0; Loop.

 Definition initList k (l : list Value)
  := update _ _ StreamEqDec k l (fun _ => []).

 Lemma runLoop: forall h sh,
  h ScalarDone = 0 ->
  Exec h sh Loop
       (update _ _ ScalarEqDec ScalarDone 1 h)
       (update _ _ StreamEqDec StreamIn []
       (update _ _ StreamEqDec StreamOut (reverse (sh StreamIn) ++ sh StreamOut) sh)).
 Proof.
  unfold Loop.
  intros.
  remember (sh StreamIn) as l.
  gen h sh.
  induction l; intros.
  - eapply EWhileGo.
    + rewrite~ H.
    + econstructor. econstructor.
      simpl.
      eapply EPullNone.
      unfold streamPull. rewrite <- Heql. eauto.
    + assert ((scalarWrite ScalarDone 1 h) = (update Scalar nat ScalarEqDec ScalarDone 1 h)).
      eauto.
      rewrite <- H0.
      assert (sh = (update Stream (list Value) StreamEqDec StreamIn []
     (update Stream (list Value) StreamEqDec StreamOut
        (reverse [] ++ sh StreamOut) sh))).
      simpl.
      apply MapExtensional.
      unfold update. intros.
            destroy_eqdecs StreamEqDec; best_bet.
      rewrite <- H1.
      eapply EWhileDone.
       unfold scalarWrite.
       rewrite update_eq_is. eauto.
  - eapply EWhileGo; eauto.
    + rewrite~ H.
    +  clear IHl.
      econstructor. econstructor.
      eapply EPullSome.
      unfold streamPull.
      rewrite <- Heql.
      eauto.
      repeat econstructor.
    + simpl.
      assert ((scalarWrite ScalarDone 0 (scalarWrite ScalarDone a (scalarWrite ScalarDone 1 h))) = h) as hRw.
       unfold scalarWrite. unfold update.
       apply MapExtensional.
       intros. destroy_eqdecs ScalarEqDec; best_bet.
      rewrite hRw.
      remember ((streamPush StreamOut
                (scalarWrite ScalarDone a (scalarWrite ScalarDone 1 h) ScalarDone)
                (update Stream (list Value) StreamEqDec StreamIn l sh))) as sh1.
      assert ((update Stream (list Value) StreamEqDec StreamIn []
     (update Stream (list Value) StreamEqDec StreamOut
        ((reverse l ++ [a]) ++ sh StreamOut) sh)
         = (update Stream (list Value) StreamEqDec StreamIn []
           (update Stream (list Value) StreamEqDec StreamOut
              (reverse l ++ sh1 StreamOut) sh1)))).

      rewrite Heqsh1.
      apply MapExtensional.
      intros.
      unfold scalarWrite. unfold streamPush. unfold update.
      destroy_eqdecs StreamEqDec; best_bet.
      simpl. destroy_eqdecs ScalarEqDec.
      simpl. rewrite <- app_assoc. eauto.

     rewrite H0.
     eapply IHl; best_bet.

     rewrite Heqsh1.
     unfold streamPush.
     unfold update.
     destroy_eqdecs StreamEqDec; best_bet.
 Qed.

 Lemma runP (l : list nat):
  Exec (fun _ => 0) (initList StreamIn l) P
       (fun _ => 1) (initList StreamOut (reverse l)).
 Proof.
  unfold P.
  econstructor. econstructor.
  simpl.
  cutrewrite (scalarWrite ScalarDone 0 !(0) = !0).
  remember !0 as h.
  remember (initList StreamIn l) as sh.
  cutrewrite ((initList StreamOut (reverse l)) =
              (update Stream (list Value) StreamEqDec StreamIn []
       (update Stream (list Value) StreamEqDec StreamOut
          (reverse (sh StreamIn) ++ sh StreamOut) sh))).
  cutrewrite (!1 = update Scalar nat ScalarEqDec ScalarDone 1 h).
  apply runLoop.
   rewrite~ Heqh.
   apply MapExtensional.
   intros. unfold update. destroy_eqdecs ScalarEqDec; best_bet.
   destruct k. destruct n. eauto.

  apply MapExtensional.
   intros.
   rewrite Heqsh.
   unfold initList. unfold update.  destroy_eqdecs StreamEqDec; best_bet.
   apply app_nil_end.

  apply MapExtensional.
   intros.
   unfold scalarWrite.
   unfold update.
   destroy_eqdecs ScalarEqDec; best_bet.
 Qed.

End Id'.

(*

 Theorem exec_always h sh p:
  exists h' sh',
  Exec h sh p h' sh'.
 Proof.
  gen h sh.
  induction p; intros; try solve [eexists; eexists; econstructor].

  - remember (streamPull s0 sh) as pull.
    destruct pull as [sh' o]; destruct o.
    + destruct (IHp (scalarWrite s v h) sh').
      destruct H.
      eexists; eexists; eapply EPullSome; best_bet.
    + edestruct IHp.
      edestruct H.
      eexists; eexists; eapply EPullNone; best_bet.

  - remember (p h) as pred.
    destruct pred.
    + eexists. eexists. eapply EWhileGo. eauto.
*)


Require Export
  Ty
  Coq.Strings.String
  Coq.ZArith.Int
  Coq.QArith.QArith.

From Equations Require Import Equations.
Set Equations With UIP.

Definition UTCTime : Set := nat.

Inductive Literal : PrimType → Set :=
  | LString  : string → Literal PrimString
  | LInteger : Z → Literal PrimInteger
  | LDecimal : Q → Literal PrimDecimal
  | LTime    : UTCTime → Literal PrimTime.

Derive NoConfusion for Literal.

Definition SemPrim (p : PrimType) : Type :=
  match p with
  | PrimInteger => Z
  | PrimDecimal => Q
  | PrimTime    => UTCTime
  | PrimString  => string
  end.

Definition SemLit `(l : Literal ty) : SemPrim ty :=
  match l with
  | LString  s => s
  | LInteger z => z
  | LDecimal q => q
  | LTime    t => t
  end.


Require Import Coq.PArith.BinPos.
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Named.Context.
Require Import Crypto.Compilers.Named.PositiveContext.
Require Import Crypto.Compilers.Named.Syntax.
Require Import Crypto.Compilers.Named.ContextDefinitions.
Require Import Crypto.Compilers.Named.RegisterAssignInterp.
Require Import Crypto.Compilers.Named.DeadCodeElimination.
Require Import Crypto.Util.Decidable.

Section language.
  Context {base_type_code : Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}
          {interp_base_type : base_type_code -> Type}
          {interp_op : forall s d, op s d -> interp_flat_type interp_base_type s -> interp_flat_type interp_base_type d}
          {Name : Type}
          {InContext : Context Name (fun _ : base_type_code => BinNums.positive)}
          {InContextOk : ContextOk InContext}
          {Name_beq : Name -> Name -> bool}
          {InterpContext : Context Name interp_base_type}
          {InterpContextOk : ContextOk InterpContext}
          {base_type_code_beq : base_type_code -> base_type_code -> bool}
          (base_type_code_bl : forall t1 t2, base_type_code_beq t1 t2 = true -> t1 = t2)
          (base_type_code_lb : forall t1 t2, t1 = t2 -> base_type_code_beq t1 t2 = true)
          (Name_bl : forall n1 n2, Name_beq n1 n2 = true -> n1 = n2)
          (Name_lb : forall n1 n2, n1 = n2 -> Name_beq n1 n2 = true).

  Local Notation EliminateDeadCode := (@EliminateDeadCode base_type_code op Name _ base_type_code_bl InContext).
  Local Notation PContext var := (@PositiveContext base_type_code var base_type_code_beq base_type_code_bl).

  Local Instance Name_dec : DecidableRel (@eq Name)
    := dec_rel_of_bool_dec_rel Name_beq Name_bl Name_lb.
  Local Instance base_type_code_dec : DecidableRel (@eq base_type_code)
    := dec_rel_of_bool_dec_rel base_type_code_beq base_type_code_bl base_type_code_lb.

  Lemma interp_EliminateDeadCode
        t e new_names
        (ctxi_interp : PContext _)
        (ctxr_interp : InterpContext)
        eout v1 v2 x
    : @EliminateDeadCode t e new_names = Some eout
      -> interp (interp_op:=interp_op) (ctx:=ctxr_interp) eout x = Some v1
      -> interp (interp_op:=interp_op) (ctx:=ctxi_interp) e x = Some v2
      -> v1 = v2.
  Proof using InContextOk InterpContextOk Name_bl Name_lb base_type_code_lb.
    eapply @interp_register_reassign;
      first [ assumption
            | apply @PositiveContextOk; assumption
            | apply Peqb_true_eq
            | apply Pos.eqb_eq
            | exact _
            | intros *; rewrite !lookupb_empty by (try apply @PositiveContextOk; assumption);
              congruence ].
  Qed.

  Lemma InterpEliminateDeadCode
        t e new_names
        eout
        v1 v2 x
    : @EliminateDeadCode t e new_names = Some eout
      -> Interp (Context:=InterpContext) (interp_op:=interp_op) eout x = Some v1
      -> Interp (Context:=PContext _) (interp_op:=interp_op) e x = Some v2
      -> v1 = v2.
  Proof using InContextOk InterpContextOk Name_bl Name_lb base_type_code_lb.
    apply interp_EliminateDeadCode.
  Qed.
End language.


From iris.base_logic Require Import bi.
From trillium.prelude Require Import quantifiers.
From iris.proofmode Require Import tactics.

Import uPred.

Local Arguments uPred_holds _ !_.

Section extraction.
  Context {M : ucmra}.

  Lemma extract_forall {A} (Φ : A → uPred M) : (⊢ ∀ x, Φ x) ↔ (∀ x, ⊢ Φ x).
  Proof.
    split; intros HP.
    - constructor; unseal.
      intros ? ? ? _.
      destruct HP as [HP]; revert HP; unseal; intros HP.
      apply HP; auto.
    - iIntros (x); iApply HP.
  Qed.

  Local Coercion uPred_holds : uPred >-> Funclass.

  Lemma extract_exists {A} (Φ : A → uPred M) :
    smaller_card A nat → (⊢ ∃ x, Φ x) ↔ (∃ x, ⊢ Φ x).
  Proof.
    intros Hcard.
    split; intros HP.
    - destruct HP as [HP]; revert HP; unseal; intros HP.
      assert (∀ n, ∃ x, Φ x n ε) as HP'.
      { intros; apply HP; eauto using ucmra_unit_validN. }
      apply (forall_exists_swap _ le) in HP' as [x Hx];
        auto using nat_regular with lia; last first.
      { intros ?????; eapply uPred_mono; eauto. }
      exists x.
      constructor; unseal.
      intros ? ? ? _.
      eapply uPred_mono; [apply Hx|apply ucmra_unit_leastN |auto].
    - destruct HP as [x Hx].
      iExists _; iApply Hx.
  Qed.

  Lemma extract_exists_alt {A} (P : A → Prop) (Φ : A → uPred M) :
    smaller_card (sig P) nat → (⊢ ∃ x, ⌜P x⌝ ∧ Φ x) ↔ (∃ x, ⊢ ⌜P x⌝ ∧ Φ x).
  Proof.
    intros Hcard.
    split; intros HP.
    - assert (⊢ ∃ x : sig P, Φ (proj1_sig x)) as HP'.
      { iDestruct HP as (x) "[HPx Hx]".
        iDestruct "HPx" as %HPx.
        iExists (exist _ _ HPx); done. }
      apply extract_exists in HP' as [[x HPx] HΦ]; last done.
      eexists; iSplit; done.
    - destruct HP as [x Hx].
      iExists _; iApply Hx.
  Qed.

  Lemma extract_exists_alt2 {A B} (P : A -> B → Prop) (Φ : A → B -> uPred M) :
    smaller_card (sig (fun '(x, y) => P x y)) nat → (⊢ ∃ x y, ⌜P x y⌝ ∧ Φ x y) ↔ (∃ x y, ⊢ ⌜P x y⌝ ∧ Φ x y).
  Proof.
    intros Hcard.
    split; intros HP.
    - assert (⊢ ∃ x : sig (fun '(x, y) => P x y), Φ (proj1_sig x).1 (proj1_sig x).2)%I as HP'.
      { iDestruct HP as (x y) "[HPx Hx]".
        iDestruct "HPx" as %HPx.
        iExists (exist _ (x,y) HPx); done. }
      apply extract_exists in HP' as [[x HPx] HΦ]; last done.
      eexists _,_; iSplit; eauto. by iPureIntro; destruct x.
    - destruct HP as [x [y Hxy]].
        by iExists _, _.
  Qed.

  Lemma extract_and (P Q : uPred M) : (⊢ P ∧ Q) ↔ ((⊢ P) ∧ (⊢ Q)).
  Proof.
    split; intros HPQ.
    - destruct HPQ as [HPQ]; revert HPQ; unseal; intros HPQ.
      repeat constructor; intros ? ? ? _; apply HPQ; auto.
    - destruct HPQ as [HP HQ].
      iSplit; [iApply HP|iApply HQ].
  Qed.

  Lemma extract_or (P Q : uPred M) : (⊢ P ∨ Q) ↔ ((⊢ P) ∨ (⊢ Q)).
  Proof.
    split; intros HPQ.
    - assert (⊢ ∃ b : bool, if b then P else Q) as HPQ'.
      { iPoseProof HPQ as "[HP|HQ]"; [iExists true|iExists false]; done. }
      apply extract_exists in HPQ'; last first.
      { intros f Hf.
        destruct (f 0) eqn:Hf0; destruct (f 1) eqn:Hf1.
        - rewrite -Hf1 in Hf0; apply Hf in Hf0; lia.
        - destruct (f 2) eqn:Hf2.
          + rewrite -Hf2 in Hf0; apply Hf in Hf0; lia.
          + rewrite -Hf2 in Hf1; apply Hf in Hf1; lia.
        - destruct (f 2) eqn:Hf2.
          + rewrite -Hf2 in Hf1; apply Hf in Hf1; lia.
          + rewrite -Hf2 in Hf0; apply Hf in Hf0; lia.
        - rewrite -Hf1 in Hf0; apply Hf in Hf0; lia. }
      destruct HPQ' as [[|] ?]; eauto.
    - destruct HPQ as [HP|HQ]; [iLeft|iRight]; done.
  Qed.

  Lemma extract_pure φ : (⊢@{uPredI M} ⌜φ⌝) ↔ φ.
  Proof.
    split; last by intros HP; auto.
    intros [Hφ]; revert Hφ; unseal; intros Hφ.
    apply (Hφ 0 ε); first apply ucmra_unit_validN; done.
 Qed.

  Lemma extract_True : (⊢@{uPredI M} True) ↔ (True).
  Proof. apply extract_pure. Qed.

  Lemma extract_False : (⊢@{uPredI M} False) ↔ (False).
  Proof. apply extract_pure. Qed.

  Lemma extract_impl (P Q : uPred M) : (⊢ P → Q) → ((⊢ P) → (⊢ Q)).
  Proof. intros HPQ HP; iApply HPQ; auto. Qed.

  Lemma extract_sep (P Q : uPred M) : (⊢ P ∗ Q) ↔ ((⊢ P) ∧ (⊢ Q)).
  Proof.
    split; intros HPQ.
    - destruct HPQ as [HPQ]; revert HPQ; unseal; intros HPQ.
      repeat constructor; intros ? ? ? _.
      + edestruct (λ He, HPQ n ε He I) as (? & ? & Hrs & ? & ?);
          [apply ucmra_unit_validN|].
        eapply uPred_mono; eauto.
        transitivity (ε : M); last apply ucmra_unit_leastN.
        rewrite Hrs; apply cmra_includedN_l.
      + edestruct (λ He, HPQ n ε He I) as (? & ? & Hrs & ? & ?);
          [apply ucmra_unit_validN|].
        eapply uPred_mono; eauto.
        transitivity (ε : M); last apply ucmra_unit_leastN.
        rewrite Hrs; apply cmra_includedN_r.
    - destruct HPQ as [HP HQ].
      iSplitL; auto.
  Qed.

  Lemma extract_wand (P Q : uPred M) : (⊢ P -∗ Q) → ((⊢ P) → (⊢ Q)).
  Proof. intros HPQ HP; iApply HPQ; auto. Qed.

  Lemma extract_later (P : uPred M) : (⊢ ▷ P) ↔ (⊢ P).
  Proof.
    split; intros HP; destruct HP as [HP]; constructor; revert HP; unseal;
      intros HP n x Hx _.
    - eapply uPred_mono; first apply (HP (S n) ε);
        eauto using ucmra_unit_validN, ucmra_unit_leastN.
    - destruct n; [|apply HP]; auto using cmra_validN_S.
  Qed.

  Lemma extract_except_0 (P : uPred M) : (⊢ ◇ P) ↔ (⊢ P).
  Proof.
    unfold bi_except_0.
    split; intros HP; destruct HP as [HP]; constructor; revert HP; unseal;
      intros HP n x Hx _.
    - specialize (HP (S n)); simpl in *.
      destruct (HP ε); auto using ucmra_unit_validN; first done.
      eapply uPred_mono; eauto using ucmra_unit_validN, ucmra_unit_leastN.
    - destruct n; first by left.
      right.
      apply HP; auto.
  Qed.

  Lemma extract_bupd (P : uPred M) `{!Plain P} : (⊢ |==> P) ↔ (⊢ P).
  Proof.
    split; intros HP.
    - iMod HP as "HP"; done.
    - iModIntro; iApply HP.
  Qed.

  Lemma extract_internal_eq (A : ofe) (x y : A) : (⊢@{uPredI M} x ≡ y) ↔ (x ≡ y).
  Proof.
    split; intros Hxy.
    - destruct Hxy as [Hxy]; revert Hxy; unseal; intros Hxy.
      apply equiv_dist; intros n.
      apply (Hxy n ε); auto using ucmra_unit_validN.
    - by rewrite Hxy; auto.
  Qed.

  Lemma extract_plainly (P : uPred M) : (⊢ ■ P) ↔ (⊢ P).
  Proof.
    split; intros HP.
    - iApply HP.
    - iModIntro; iApply HP.
  Qed.

  Lemma extract_persistently (P : uPred M) : (⊢ □ P) ↔ (⊢ P).
  Proof.
    split; intros HP.
    - iApply HP.
    - iModIntro; iApply HP.
  Qed.

  Lemma extract_own (x : M) : (⊢ uPred_ownM x) ↔ ∀ n, x ≼{n} ε.
  Proof.
    split; intros Hx.
    - destruct Hx as [Hx]; revert Hx; unseal; intros Hx.
      intros n; apply Hx; first apply ucmra_unit_validN; done.
    - constructor; intros.
      eapply uPred_mono; first (by unseal; apply (Hx n); eauto);
        auto using ucmra_unit_leastN.
  Qed.

  Lemma extract_valid {A : ucmra} (x : A) : (⊢@{uPredI M} ✓ x) ↔ ✓ x.
  Proof.
    split; intros Hx.
    - destruct Hx as [Hx]; revert Hx; unseal; intros Hx.
      apply cmra_valid_validN.
      intros n; apply (Hx n ε); first apply ucmra_unit_validN; done.
    - constructor; intros; unseal; apply cmra_valid_validN; done.
  Qed.

End extraction.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University
  Copyright 2018 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/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export sequents_equality.
Require Export sequents_tacs2.
Require Import sequents_tacs.
Require Import sequents_useful.
Require Import tactics2.
Require Import cequiv_tacs.
Require Import subst_tacs.
Require Export rules_pertype.
Require Export subst_per.
Require Export per_props_pertype.

(**

  This is the kind of subgoal we get from using [rule_pertype_elimination4]

 *)
Definition rule_sqper_type {o}
           (R : @NTerm o)
           (x v1 v2 : NVar)
           (H J : barehypotheses) :=
  mk_rule
    (mk_bseq (snoc H (mk_hyp x (mk_pertype (sqper_rel v1 v2 R))) ++ J)
             (mk_concl_t (mk_apply2 (sqper_rel v1 v2 R) (mk_var x) (mk_var x))))
    [ ]
    [ ].

Lemma rule_sqper_type_true {o} :
  forall lib (R : @NTerm o),
  forall x v1 v2 : NVar,
  forall H J : barehypotheses,
    rule_true lib
              (rule_sqper_type
                 R
                 x v1 v2
                 H J).
Proof.
  unfold rule_sqper_type, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  clear hyps.
  unfold closed_extract; simpl.
  exists (@eq_refl bool true).

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (vars_hyps H)
           # !LIn x (vars_hyps J)
           # disjoint (vars_hyps H) (vars_hyps J)) as vhyps.

  dwfseq.
  sp.

  destruct vhyps as [ nifH vhyps ].
  destruct vhyps as [ nifJ disjHJ ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  applydup eqh in sim as eqhyps.
  rw eq_hyps_app in eqhyps; exrepnd; subst; allrw length_snoc.
  rw eq_hyps_snoc in eqhyps5; exrepnd; subst; allsimpl; allrw length_snoc; cpx.
  lsubst_tac.

  dup sim as sim'.
  rw similarity_app in sim'; simpl in sim'; exrepnd; cpx.
  apply app_split in sim'0;
    try (complete (allapply similarity_length; allrw length_snoc; repnd; allrw; sp));
    repnd; subst; cpx.
  apply app_split in sim'2;
    try (complete (allapply similarity_length; allrw length_snoc; repnd; allrw; sp));
    repnd; subst; cpx.
  rw similarity_snoc in sim'5; simpl in sim'5; exrepnd; cpx.
  proof_irr; GC.

  assert (disjoint (free_vars (sqper_rel v1 v2 R)) (vars_hyps J)) as disjper.
  (* begin proof of assert *)
  clear_dependencies p.
  rw cover_vars_pertype in p.
  apply subvars_if_cover_vars_eq_hyps with (s2 := s2a) (H := H) in p; auto.
  rw subvars_prop in p.
  introv i.
  apply p in i.
  apply disjHJ in i; auto.
  (* end proof of assert *)

  assert (!LIn x (free_vars (sqper_rel v1 v2 R))) as nifper.
  (* begin proof of assert *)
  clear_dependencies p.
  rw cover_vars_pertype in p; repnd.
  intro i.
  apply subvars_if_cover_vars_eq_hyps with (s2 := s2a) (H := H) in p; auto.
  rw subvars_prop in p.
  apply p in i; auto.
  (* end proof of assert *)

  lsubst_tac.
  rw tequality_mkc_pertype in eqhyps0; repnd.

  allunfold sqper_rel.

  lsubst_tac.
  repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).

  apply tequality_erase; dands.

  rw equality_in_mkc_pertype in sim'2; repnd.
  repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).

  unfold is_per_type in sim'3.
  destruct sim'3 as [sym trans].

  generalize (sym t0 t3); clear sym; intro sym.
  autodimp sym hyp.
  repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac; auto).

  generalize (trans t0 t3 t0); intro trans1.
  autodimp trans1 hyp.
  repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac; auto).
  autodimp trans1 hyp.
  repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac; auto).

  generalize (trans t3 t0 t3); intro trans2.
  autodimp trans2 hyp.
  repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac; auto).
  autodimp trans2 hyp.
  repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac; auto).

  split; intro k; auto.

  generalize (eqhyps7 t3 t3); intro i.
  destruct i as [i1 i2]; clear i2.
  autodimp i1 hyp.
  repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac; auto).
  rw inhabited_type_erasec in i1; auto.
  rw inhabited_type_erasec in trans1; auto.

  generalize (eqhyps2 t0 t0); clear eqhyps0; intro ty1.
  repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac; auto).
  rw type_erase in ty1; auto.

  generalize (eqhyps5 t3 t3); clear eqhyps5; intro ty2.
  repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac; auto).
  rw type_erase in ty2; auto.
Qed.

(**

  This is the kind of subgoal we get from using [rule_pertype_elimination_t]:
<<
     H, x : t1 = t2 in pertype(sqper_rel v1 v2 R), J |- R t1 t2 is a type
>>

 *)
Definition rule_sqper_type2
           (t1 t2 R : NTerm)
           (x v1 v2 : NVar)
           (H J : barehypotheses) :=
  mk_rule
    (mk_bseq (snoc H (mk_hyp x (mk_equality t1 t2 (mk_pertype (sqper_rel v1 v2 R)))) ++ J)
             (mk_concl_t (mk_apply2 (sqper_rel v1 v2 R) t1 t2)))
    [ ]
    [ ].

Lemma rule_sqper_type2_true :
  forall t1 t2 R : NTerm,
  forall x v1 v2 : NVar,
  forall H J : barehypotheses,
    rule_true (rule_sqper_type2
                 t1 t2 R
                 x v1 v2
                 H J).
Proof.
  unfold rule_sqper_type2, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  clear hyps.
  unfold closed_extract; simpl.
  exists (@eq_refl bool true).

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (vars_hyps H)
           # !LIn x (vars_hyps J)
           # !LIn x (free_vars t1)
           # !LIn x (free_vars t2)
           # disjoint (free_vars t1) (vars_hyps J)
           # disjoint (free_vars t2) (vars_hyps J)
           # disjoint (vars_hyps H) (vars_hyps J)) as vhyps.

  dwfseq.
  sp;
    try (complete (unfold disjoint; unfold disjoint in wg8; introv k l; discover;
                   repeat (first [ progress (allrw in_app_iff) | progress (allrw in_snoc) ]);
                   sp)).

  destruct vhyps as [ nixH vhyps ].
  destruct vhyps as [ nixJ vhyps ].
  destruct vhyps as [ nixt1 vhyps ].
  destruct vhyps as [ nixt2 vhyps ].
  destruct vhyps as [ disjt1J vhyps ].
  destruct vhyps as [ disjt2J disjHJ ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  applydup eqh in sim as eqhyps.
  rw eq_hyps_app in eqhyps; exrepnd; subst; allrw length_snoc.
  rw eq_hyps_snoc in eqhyps5; exrepnd; subst; allsimpl; allrw length_snoc; cpx.
  lsubst_tac.

  dup sim as sim'.
  rw similarity_app in sim'; simpl in sim'; exrepnd; cpx.
  apply app_split in sim'0;
    try (complete (allapply similarity_length; allrw length_snoc; repnd; allrw; sp));
    repnd; subst; cpx.
  apply app_split in sim'2;
    try (complete (allapply similarity_length; allrw length_snoc; repnd; allrw; sp));
    repnd; subst; cpx.
  rw similarity_snoc in sim'5; simpl in sim'5; exrepnd; cpx.
  proof_irr; GC.

  assert (disjoint (free_vars (sqper_rel v1 v2 R)) (vars_hyps J)) as disjper.
  (* begin proof of assert *)
  clear_dependencies p.
  rw cover_vars_equality in p; rw cover_vars_pertype in p; repnd.
  apply subvars_if_cover_vars_eq_hyps with (s2 := s2a) (H := H) in p; auto.
  rw subvars_prop in p.
  introv i.
  apply p in i.
  apply disjHJ in i; auto.
  (* end proof of assert *)

  assert (!LIn x (free_vars (sqper_rel v1 v2 R))) as nifper.
  (* begin proof of assert *)
  clear_dependencies p.
  rw cover_vars_equality in p; rw cover_vars_pertype in p; repnd.
  intro i.
  apply subvars_if_cover_vars_eq_hyps with (s2 := s2a) (H := H) in p; auto.
  rw subvars_prop in p.
  apply p in i; auto.
  (* end proof of assert *)

  lsubst_tac.
  rw tequality_mkc_equality in eqhyps0; repnd.
  rw tequality_mkc_pertype in eqhyps2; repnd.
  repeat (rw equality_in_mkc_pertype in eqhyps5).

  generalize (is_per_type_sqper_rel_change_subst
                v1 v2 R s1a s2a w0 c0 c5
                eqhyps10 eqhyps2); intro isper2.

  allunfold sqper_rel.

  lsubst_tac.
  repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).

  apply tequality_erase; dands.

  split; intro k.

  destruct eqhyps5 as [i1 i2]; clear i2.
  autodimp i1 hyp; dands; auto.
  repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
  rw inhabited_type_erasec; auto.
  repnd.
  repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
  rw inhabited_type_erasec in i0; auto.

  destruct eqhyps5 as [i1 i2]; clear i1.
  autodimp i2 hyp; dands; auto.
  repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
  rw inhabited_type_erasec; auto.
  repnd.
  repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
  rw inhabited_type_erasec in i0; auto.

  generalize (eqhyps8 (lsubstc t1 w1 s1a c1) (lsubstc t2 w2 s1a c2));
    clear eqhyps8; intro ty1.
  repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac; auto).
  rw type_erase in ty1; auto.

  generalize (eqhyps9 (lsubstc t1 w1 s2a c3) (lsubstc t2 w2 s2a c4));
    clear eqhyps9; intro ty2.
  repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac; auto).
  rw type_erase in ty2; auto.
Qed.

Definition rule_per_function_type
           (A B : NTerm)
           (f : NVar)
           (H J : barehypotheses) :=
  mk_rule
    (mk_bseq (snoc H (mk_hyp f (mk_per_function A B)) ++ J)
             (mk_concl_t (mk_apply2 (mk_per_function_rel A B) (mk_var f) (mk_var f))))
    [ ]
    [ ].

Lemma rule_per_function_type_true :
  forall A B : NTerm,
  forall f : NVar,
  forall H J : barehypotheses,
    rule_true (rule_per_function_type
                 A B
                 f
                 H J).
Proof.
  introv.
  unfold rule_per_function_type.
  unfold mk_per_function, mk_per_function_rel.
  remember (newvars5 [A,B]); repnd.
  generalize (rule_sqper_type_true
                (mk_per_function_base p3 p2 p1 p0 p A B)
                f p1 p0 H J); auto.
Qed.


Require Export Basics.

Require Export EnvLibA.
Require Export RelLibA.

Require Export Coq.Program.Equality.
Require Import Coq.Init.Specif.
Require Import Coq.Arith.PeanoNat.
Require Import Omega.
Require Import Coq.Lists.List.
Require Import Coq.Logic.ProofIrrelevance.

Require Import StaticSemA.
Require Import DynamicSemA.
Require Import TRInductA.
Require Import WeakenA.
Require Import TSoundnessA.
Require Import SReducA.
Require Import DetermA.

Require Import Coq.Logic.EqdepFacts.

Module STyping (IdT: IdModType) <: IdModType.

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

Module DetermI := Determ IdT.
Export DetermI.

(******* strong typing properties **************************)

Lemma prmsTyping_aux4 (ftenv: funTC) (tenv: valTC)
        (fenv: funEnv) (env: valEnv) (es: list Exp) (vs: list Value)
        (ts: list VTyp) (s0 s1: W) :
    MatchEnvsT FunTyping fenv ftenv ->
    MatchEnvsT ValueTyping env tenv ->
    PrmsTyping ftenv tenv fenv (PS es) (PT ts) ->
    PrmsClosure fenv env (Conf Prms s0 (PS es))
        (Conf Prms s1 (PS (map Val vs))) ->
    vlsTyping vs ts.
  intros.
  assert (vs = extractPRunValue ftenv tenv fenv (PS es) (PT ts)
                                X1 X env X0 s0).
  eapply (proj2 (PEvalElim ftenv tenv fenv (PS es) (PT ts)
                                X1 X env X0 s0 s1 vs _)).
  rewrite H.
  assert (PrmsTyping emptyE emptyE emptyE
    (PS
       (projT1
          (PrmsEval ftenv tenv fenv (PS es) (PT ts) X1 X env X0 s0)))
    (PT ts)).
  exact (extractPRunTyping ftenv tenv fenv (PS es) (PT ts)
                                X1 X env X0 s0).
  assert (PrmsTyping ftenv tenv fenv
    (PS
       (projT1
          (PrmsEval ftenv tenv fenv (PS es) (PT ts) X1 X env X0 s0)))
    (PT ts)).
  eapply weakenPrmsTyping in X3.
  exact X3.
  constructor.
  auto.
  clear X3.
  simpl in *.
  generalize (extractPRunCons ftenv tenv fenv (PS es)
                              (PT ts) X1 X env X0 s0).
  intros.
  unfold extractPRunEValue in H0.
  rewrite H0 in X4.
  eapply matchListsAux02_T.
  instantiate (1:= map Val vs).
  rewrite <- H.
  constructor.
  auto.
  rewrite <- H in X4.
  exact X4.
  Unshelve.
  auto.
Defined.

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

Lemma ValueStrongTyping :
  forall (v: Value) (t1: VTyp),
     ValueTyping v t1 ->
  forall t2: VTyp,
    ValueTyping v t2 ->
        t1 = t2.
Proof.
  intros.
  inversion H; subst.
  inversion H0; subst.
  subst T T0.
  rewrite H1 in H3.
  assert (H2 = H4).
  eapply loc_pi.
  subst.
  destruct t1.
  destruct t2.
  simpl in *.
  revert H1.
  revert H0.
  revert v1.
  rewrite <- H3.
  intros.
  assert (v0 = v1).
  eapply loc_pi.
  subst.
  auto.
Defined.

Lemma IdStrongTyping :
  forall (tenv: valTC) (x: Id) (t1: VTyp),
     IdTyping tenv x t1 ->
  forall t2: VTyp,
    IdTyping tenv x t2 ->
        t1 = t2.
Proof.
  intros.
  inversion X; subst.
  inversion X0; subst.
  inversion X1; subst.
  inversion X2; subst.
  rewrite H in H0.
  injection H0.
  auto.
Defined.

Lemma EnvStrongTyping :
  forall (env: valEnv) (tenv1: valTC),
     EnvTyping env tenv1 ->
  forall tenv2: valTC,
    EnvTyping env tenv2 ->
        tenv1 = tenv2.
Proof.
  intros.
  dependent induction env.
  inversion X; subst.
  inversion X0; subst.
  auto.
  inversion X; subst.
  inversion X0; subst.
  assert (ls2 = ls0).
  eapply IHenv.
  auto.
  auto.
  assert (v2 = v3).
  eapply ValueStrongTyping.
  eauto.
  auto.
  rewrite H.
  rewrite H0.
  auto.
Defined.

(*
Lemma ListStrongTyping (ftenv: funTC) (tenv: valTC) (fenv: funEnv) :
  forall (ls: list Exp) (ts1: list VTyp),
      Forall2T (ExpTyping ftenv tenv fenv) ls ts1 ->
  forall ts2: list VTyp,
      Forall2T (ExpTyping ftenv tenv fenv) ls ts2 ->
        ts1 = ts2.
Proof.
*)

Definition UniEType :=
  fun (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
      (e: Exp) (t1: VTyp) (k: ExpTyping ftenv tenv fenv e t1) =>
  FEnvTyping fenv ftenv ->
  forall (t2: VTyp) (ftenv0: funTC),
    FEnvTyping fenv ftenv0 ->
    ExpTyping ftenv0 tenv fenv e t2 ->
        t1 = t2.

Definition UniPType :=
  fun (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
      (ps: Prms) (pt1: PTyp) (k: PrmsTyping ftenv tenv fenv ps pt1) =>
    FEnvTyping fenv ftenv ->
    forall (pt2: PTyp) (ftenv0: funTC),
      FEnvTyping fenv ftenv0 ->
      PrmsTyping ftenv0 tenv fenv ps pt2 ->
        pt1 = pt2.

Definition UniQFType :=
  fun (ftenv: funTC) (fenv: funEnv)
      (qf: QFun) (ft1: FTyp) (k: QFunTyping ftenv fenv qf ft1) =>
    FEnvTyping fenv ftenv ->
    forall (ft2: FTyp) (ftenv0: funTC),
    FEnvTyping fenv ftenv0 ->
      QFunTyping ftenv0 fenv qf ft2 ->
        ft1 = ft2.

Definition UniETypeW (ftenv: funTC)
                      (tenv: valTC) (fenv: funEnv)
                      (e: Exp) (t1: VTyp) :=
  ExpTyping ftenv tenv fenv e t1 ->
  FEnvTyping fenv ftenv ->
  forall (t2: VTyp) (ftenv0: funTC),
    FEnvTyping fenv ftenv0 ->
    ExpTyping ftenv0 tenv fenv e t2 ->
        t1 = t2.

Definition UniFTypeS :=
  fun (f: Fun) (ft1: FTyp) (k: FunTyping f ft1) =>
    forall (ft2: FTyp),
      FunTyping f ft2 ->
        ft1 = ft2.

Definition UniFType :=
  fun (f: Fun) (ft: FTyp) (k: FunTyping f ft) =>
   (forall (fps: valTC) (t: VTyp),
    ft = FT fps t ->
    forall (ftenv: funTC) (i: nat) (fenv: funEnv)
           (x: Id) (e0 e1: Exp),
       FEnvTyping fenv ftenv ->
       f = FC fenv fps e0 e1 x i ->
       match i with
       | 0 => UniETypeW ftenv fps fenv e0 t
       | S j => UniETypeW (updateE ftenv x ft) fps
                (updateE fenv x (FC fenv fps e0 e1 x j)) e1 t
       end).

Definition ExpTypingUni_rect :=
  ExpTyping_str_rect UniFType UniQFType UniEType UniPType.

Lemma ExpStrongTyping :
  forall (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
         (e: Exp) (t1: VTyp),
      ExpTyping ftenv tenv fenv e t1 ->
      FEnvTyping fenv ftenv ->
  forall (t2: VTyp) (ftenv0: funTC),
    FEnvTyping fenv ftenv0 ->
    ExpTyping ftenv0 tenv fenv e t2 ->
        t1 = t2.
Proof.
eapply ExpTypingUni_rect.
- (* SLL *)
  unfold Par_SSL, UniEType.
  intros.
  constructor.
- (* SLL *)
  unfold Par_SSL, UniEType.
  intros.
  constructor.
  assumption.
  assumption.
  assumption.
- (* SSA *)
  unfold Par_SSA, UniFType.
  constructor.
- unfold Par_SSA, UniFType.
  intros.
  constructor.
  assumption.
  assumption.
  assumption.
- (* SSB *)
  unfold Par_SSB, Par_SSA, UniFType.
  intros.
  econstructor.
  exact m0.
  exact m1.
  assumption.
  assumption.
  assumption.
  assumption.
  assumption.
  assumption.
- (* Par_F *)
  unfold UniFType, UniETypeW, UniEType.
  intros.
  inversion H0; subst.
  inversion H1; subst.
  intros.
  eapply H.
  auto.
  Focus 2.
  eauto.
  auto.
- (* Par_F *)
  unfold UniFType, UniETypeW, UniEType.
  intros ftenv tenv fenv.
  intros e0 e1 x n t.
  intros K1 K2 K3 HP1 HP2.
  intros fps t0 E3.
  intros ftenv1 i fenv1 x0 e2 e3 K4 E4.
  inversion E3; subst.
  inversion E4; subst.
  intros.
  eapply HP1.
  eapply updateFEnvLemma.
  assumption.
  assumption.
  eassumption.
  assumption.
- (* Par_Q - QF *)
  unfold UniQFType, UniFType, UniEType, UniETypeW.
  intros.
  inversion X1; subst.
  destruct ft as [fps t].
  specialize (H fps t eq_refl).
  inversion k; subst.
  + inversion X2; subst.
    specialize (H ftenv1 0 fenv0 x e0 e1 X3 eq_refl).
    simpl in *.
    assert (t = t0).
    eapply H.
    auto.
    auto.
    Focus 2.
    eassumption.
    auto.
    rewrite H0.
    auto.
  + inversion X2; subst.
    subst ftenv' fenv'.
    subst ftenv'0 fenv'0. (* to compare X5 and X8 *)
    specialize (H ftenv1
                  (S n) fenv0 x e0 e1 X3 eq_refl).
    simpl in *.
    assert (t = t0).
    eapply H.
    auto.
    eapply updateFEnvLemma.
    auto.
    auto.
    Focus 2.
    eauto.
    eapply updateFEnvLemma.
    auto.
    auto.
    rewrite H0.
    auto.

- (* Par_Q - FVar *)
  unfold  UniQFType, UniFType, UniEType, UniETypeW, Par_SSB, Par_SSA.
  intros.
  inversion X; subst.
  clear X.
  clear X3 X4.
  destruct ft as [fps t].
  specialize (H1 fps t eq_refl).
  inversion X2; subst.
  destruct ft2.
  destruct f.

  inversion m; subst.
  inversion X3; subst.

  +
    inversion X; subst.
    rewrite H0 in H4.
    (*inversion X2; subst.
    inversion X8; subst. *)

(***)
    assert (f0 = FC fenv fps e0 e1 x0 0).
    eapply (envAppendCompare FunTyping ls0 ls8 ls1 ls3).
    eauto.
    eauto.
    eauto.
    auto.
    auto.

    rewrite H5 in *.

    specialize (H1 ftenv).
    specialize (H1 0 fenv x0 e0 e1).
    specialize (H1 X6 eq_refl).
    simpl in *.
    inversion X8; subst.

    assert (t = ret_type).
    eapply H1.
    auto.
    auto.
    Focus 2.
    eauto.
    auto.
    rewrite H5.
    auto.

  + inversion X; subst.
    rewrite H0 in H4.
    (* inversion X2; subst.
    inversion X9; subst. *)

    assert (f0 = FC fenv fps e0 e1 x0 (S n0)).
    eapply (envAppendCompare FunTyping ls0 ls8 ls1 ls3).
    eauto.
    eauto.
    eauto.
    auto.
    auto.

    rewrite H5 in *.

    specialize (H1 ftenv).
    specialize (H1 (S n0) fenv x0 e0 e1).
    specialize (H1 X6 eq_refl).
    simpl in *.
    inversion X9; subst.

    assert (t = ret_type).
    eapply H1.
    auto.
    eapply updateFEnvLemma.
    auto.
    auto.
    Focus 2.
    eauto.
    subst ftenv'0.
    eapply updateFEnvLemma.
    auto.
    auto.
    rewrite H5.
    auto.

- (* modify *)
  unfold UniEType.
  intros ftenv tenv fenv T1 T2 VT1 VT2 XF q K H0 t ftenv0 H0' X.
  inversion X; subst.
  eapply inj_pair2 in H6.
  eapply inj_pair2 in H6; subst.
  assert (VT4 = VT1).
  eapply loc_pi.
  subst.
  assert (VT5 = VT2).
  eapply loc_pi.
  subst.
  clear XF2.
  reflexivity.
  (* return *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  inversion X2; subst.
  inversion k; subst.
  eapply ValueStrongTyping.
  eauto.
  eauto.
  inversion k; subst.
  eapply IdStrongTyping.
  eauto.
  auto.
(* bindN *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  eauto.
  auto.
(* bindS *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  subst tenv'.
  assert (t1 = t3).
  eapply H.
  auto.
  Focus 2.
  eauto.
  auto.
  rewrite H1.
  eauto.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H.
  eapply overrideEnvLemmaT.
  assumption.
  assumption.
  Focus 2.
  assert (tenvP = tenvP0).
  eapply EnvStrongTyping.
  eauto.
  auto.
  rewrite H0.
  eauto.
  eapply overrideEnvLemmaT.
  auto.
  auto.
- unfold UniEType, UniQFType, UniPType.
  intros.
  inversion X1; subst.
  assert (FT fps t = FT fps0 t2).
  eapply H.
  auto.
  eauto.
  auto.
  injection H1.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply ValueStrongTyping.
  eauto.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  eauto.
  auto.
- unfold UniEType, Par_SSL, UniPType.
  intros.
  dependent induction X; subst.
  inversion X2; subst.
  inversion X; subst.
  auto.
  destruct pt2.
  destruct ts.
  + inversion X2; subst.
    inversion X3.
  + inversion m; subst.
    inversion X2; subst.
    inversion X5; subst.
    assert (PT bbs = PT ts).
    {*  eapply IHX.
      auto.
      auto.
      Focus 2.
      econstructor.
      eauto.
      auto.
   }
   injection H.
   intro.
   assert (b = v).
   {* eapply p0.
      auto.
      Focus 2.
      eauto.
      auto.
   }
   rewrite H0.
   rewrite H1.
   auto.
Qed.

Definition PrmsTypingUni_rect :=
  PrmsTyping_str_rect UniFType UniQFType UniEType UniPType.

Lemma PrmsStrongTyping :
  forall (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
         (ps: Prms) (pt: PTyp)
         (k: PrmsTyping ftenv tenv fenv ps pt),
         UniPType ftenv tenv fenv ps pt k.
Proof.
eapply PrmsTypingUni_rect.
- (* SLL *)
  unfold Par_SSL, UniEType.
  intros.
  constructor.
- (* SLL *)
  unfold Par_SSL, UniEType.
  intros.
  constructor.
  assumption.
  assumption.
  assumption.
- (* SSA *)
  unfold Par_SSA, UniFType.
  constructor.
- unfold Par_SSA, UniFType.
  intros.
  constructor.
  assumption.
  assumption.
  assumption.
- (* SSB *)
  unfold Par_SSB, Par_SSA, UniFType.
  intros.
  econstructor.
  exact m0.
  exact m1.
  assumption.
  assumption.
  assumption.
  assumption.
  assumption.
  assumption.
- (* Par_F *)
  unfold UniFType, UniETypeW, UniEType.
  intros.
  inversion H0; subst.
  inversion H1; subst.
  intros.
  eapply H.
  auto.
  Focus 2.
  eauto.
  auto.
- (* Par_F *)
  unfold UniFType, UniETypeW, UniEType.
  intros ftenv tenv fenv.
  intros e0 e1 x n t.
  intros K1 K2 K3 HP1 HP2.
  intros fps t0 E3.
  intros ftenv1 i fenv1 x0 e2 e3 K4 E4.
  inversion E3; subst.
  inversion E4; subst.
  intros.
  eapply HP1.
  eapply updateFEnvLemma.
  assumption.
  assumption.
  eassumption.
  assumption.
- (* Par_Q - QF *)
  unfold UniQFType, UniFType, UniEType, UniETypeW.
  intros.
  inversion X1; subst.
  destruct ft as [fps t].
  specialize (H fps t eq_refl).
  inversion k; subst.
  + inversion X2; subst.
    specialize (H ftenv1 0 fenv0 x e0 e1 X3 eq_refl).
    simpl in *.
    assert (t = t0).
    eapply H.
    auto.
    auto.
    Focus 2.
    eassumption.
    auto.
    rewrite H0.
    auto.
  + inversion X2; subst.
    subst ftenv' fenv'.
    subst ftenv'0 fenv'0. (* to compare X5 and X8 *)
    specialize (H ftenv1
                  (S n) fenv0 x e0 e1 X3 eq_refl).
    simpl in *.
    assert (t = t0).
    eapply H.
    auto.
    eapply updateFEnvLemma.
    auto.
    auto.
    Focus 2.
    eauto.
    eapply updateFEnvLemma.
    auto.
    auto.
    rewrite H0.
    auto.

- (* Par_Q - FVar *)
  unfold  UniQFType, UniFType, UniEType, UniETypeW, Par_SSB, Par_SSA.
  intros.
  inversion X; subst.
  clear X.
  clear X3 X4.
  destruct ft as [fps t].
  specialize (H1 fps t eq_refl).
  inversion X2; subst.
  destruct ft2.
  destruct f.

  inversion m; subst.
  inversion X3; subst.

  +
    inversion X; subst.
    rewrite H0 in H4.
    (*inversion X2; subst.
    inversion X8; subst. *)

(***)
    assert (f0 = FC fenv fps e0 e1 x0 0).
    eapply (envAppendCompare FunTyping ls0 ls8 ls1 ls3).
    eauto.
    eauto.
    eauto.
    auto.
    auto.

    rewrite H5 in *.

    specialize (H1 ftenv).
    specialize (H1 0 fenv x0 e0 e1).
    specialize (H1 X6 eq_refl).
    simpl in *.
    inversion X8; subst.

    assert (t = ret_type).
    eapply H1.
    auto.
    auto.
    Focus 2.
    eauto.
    auto.
    rewrite H5.
    auto.

  + inversion X; subst.
    rewrite H0 in H4.
    (* inversion X2; subst.
    inversion X9; subst. *)

    assert (f0 = FC fenv fps e0 e1 x0 (S n0)).
    eapply (envAppendCompare FunTyping ls0 ls8 ls1 ls3).
    eauto.
    eauto.
    eauto.
    auto.
    auto.

    rewrite H5 in *.

    specialize (H1 ftenv).
    specialize (H1 (S n0) fenv x0 e0 e1).
    specialize (H1 X6 eq_refl).
    simpl in *.
    inversion X9; subst.

    assert (t = ret_type).
    eapply H1.
    auto.
    eapply updateFEnvLemma.
    auto.
    auto.
    Focus 2.
    eauto.
    subst ftenv'0.
    eapply updateFEnvLemma.
    auto.
    auto.
    rewrite H5.
    auto.

- (* modify *)
  unfold UniEType.
  intros ftenv tenv fenv T1 T2 VT1 VT2 XF q K H0 t ftenv0 H0' X.
  inversion X; subst.
  eapply inj_pair2 in H6.
  eapply inj_pair2 in H6; subst.
  assert (VT4 = VT1).
  eapply loc_pi.
  subst.
  assert (VT5 = VT2).
  eapply loc_pi.
  subst.
  clear XF2.
  reflexivity.
  (* return *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  inversion X2; subst.
  inversion k; subst.
  eapply ValueStrongTyping.
  eauto.
  eauto.
  inversion k; subst.
  eapply IdStrongTyping.
  eauto.
  auto.
(* bindN *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  eauto.
  auto.
(* bindS *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  subst tenv'.
  assert (t1 = t3).
  eapply H.
  auto.
  Focus 2.
  eauto.
  auto.
  rewrite H1.
  eauto.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H.
  eapply overrideEnvLemmaT.
  assumption.
  assumption.
  Focus 2.
  assert (tenvP = tenvP0).
  eapply EnvStrongTyping.
  eauto.
  auto.
  rewrite H0.
  eauto.
  eapply overrideEnvLemmaT.
  auto.
  auto.
- unfold UniEType, UniQFType, UniPType.
  intros.
  inversion X1; subst.
  assert (FT fps t = FT fps0 t2).
  eapply H.
  auto.
  eauto.
  auto.
  injection H1.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply ValueStrongTyping.
  eauto.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  eauto.
  auto.
- unfold UniEType, Par_SSL, UniPType.
  intros.
  dependent induction X; subst.
  inversion X2; subst.
  inversion X; subst.
  auto.
  destruct pt2.
  destruct ts.
  + inversion X2; subst.
    inversion X3.
  + inversion m; subst.
    inversion X2; subst.
    inversion X5; subst.
    assert (PT bbs = PT ts).
    {*  eapply IHX.
      auto.
      auto.
      Focus 2.
      econstructor.
      eauto.
      auto.
   }
   injection H.
   intro.
   assert (b = v).
   {* eapply p0.
      auto.
      Focus 2.
      eauto.
      auto.
   }
   rewrite H0.
   rewrite H1.
   auto.
Qed.

Definition QFunTypingUni_rect :=
  QFunTyping_str_rect UniFType UniQFType UniEType UniPType.

Lemma QFunStrongTyping :
  forall (ftenv: funTC) (fenv: funEnv)
         (qf: QFun) (ft: FTyp)
         (k: QFunTyping ftenv fenv qf ft),
     UniQFType ftenv fenv qf ft k.
Proof.
eapply QFunTypingUni_rect.
- (* SLL *)
  unfold Par_SSL, UniEType.
  intros.
  constructor.
- (* SLL *)
  unfold Par_SSL, UniEType.
  intros.
  constructor.
  assumption.
  assumption.
  assumption.
- (* SSA *)
  unfold Par_SSA, UniFType.
  constructor.
- unfold Par_SSA, UniFType.
  intros.
  constructor.
  assumption.
  assumption.
  assumption.
- (* SSB *)
  unfold Par_SSB, Par_SSA, UniFType.
  intros.
  econstructor.
  exact m0.
  exact m1.
  assumption.
  assumption.
  assumption.
  assumption.
  assumption.
  assumption.
- (* Par_F *)
  unfold UniFType, UniETypeW, UniEType.
  intros.
  inversion H0; subst.
  inversion H1; subst.
  intros.
  eapply H.
  auto.
  Focus 2.
  eauto.
  auto.
- (* Par_F *)
  unfold UniFType, UniETypeW, UniEType.
  intros ftenv tenv fenv.
  intros e0 e1 x n t.
  intros K1 K2 K3 HP1 HP2.
  intros fps t0 E3.
  intros ftenv1 i fenv1 x0 e2 e3 K4 E4.
  inversion E3; subst.
  inversion E4; subst.
  intros.
  eapply HP1.
  eapply updateFEnvLemma.
  assumption.
  assumption.
  eassumption.
  assumption.
- (* Par_Q - QF *)
  unfold UniQFType, UniFType, UniEType, UniETypeW.
  intros.
  inversion X1; subst.
  destruct ft as [fps t].
  specialize (H fps t eq_refl).
  inversion k; subst.
  + inversion X2; subst.
    specialize (H ftenv1 0 fenv0 x e0 e1 X3 eq_refl).
    simpl in *.
    assert (t = t0).
    eapply H.
    auto.
    auto.
    Focus 2.
    eassumption.
    auto.
    rewrite H0.
    auto.
  + inversion X2; subst.
    subst ftenv' fenv'.
    subst ftenv'0 fenv'0. (* to compare X5 and X8 *)
    specialize (H ftenv1
                  (S n) fenv0 x e0 e1 X3 eq_refl).
    simpl in *.
    assert (t = t0).
    eapply H.
    auto.
    eapply updateFEnvLemma.
    auto.
    auto.
    Focus 2.
    eauto.
    eapply updateFEnvLemma.
    auto.
    auto.
    rewrite H0.
    auto.

- (* Par_Q - FVar *)
  unfold  UniQFType, UniFType, UniEType, UniETypeW, Par_SSB, Par_SSA.
  intros.
  inversion X; subst.
  clear X.
  clear X3 X4.
  destruct ft as [fps t].
  specialize (H1 fps t eq_refl).
  inversion X2; subst.
  destruct ft2.
  destruct f.

  inversion m; subst.
  inversion X3; subst.

  +
    inversion X; subst.
    rewrite H0 in H4.
    (*inversion X2; subst.
    inversion X8; subst. *)

(***)
    assert (f0 = FC fenv fps e0 e1 x0 0).
    eapply (envAppendCompare FunTyping ls0 ls8 ls1 ls3).
    eauto.
    eauto.
    eauto.
    auto.
    auto.

    rewrite H5 in *.

    specialize (H1 ftenv).
    specialize (H1 0 fenv x0 e0 e1).
    specialize (H1 X6 eq_refl).
    simpl in *.
    inversion X8; subst.

    assert (t = ret_type).
    eapply H1.
    auto.
    auto.
    Focus 2.
    eauto.
    auto.
    rewrite H5.
    auto.

  + inversion X; subst.
    rewrite H0 in H4.
    (* inversion X2; subst.
    inversion X9; subst. *)

    assert (f0 = FC fenv fps e0 e1 x0 (S n0)).
    eapply (envAppendCompare FunTyping ls0 ls8 ls1 ls3).
    eauto.
    eauto.
    eauto.
    auto.
    auto.

    rewrite H5 in *.

    specialize (H1 ftenv).
    specialize (H1 (S n0) fenv x0 e0 e1).
    specialize (H1 X6 eq_refl).
    simpl in *.
    inversion X9; subst.

    assert (t = ret_type).
    eapply H1.
    auto.
    eapply updateFEnvLemma.
    auto.
    auto.
    Focus 2.
    eauto.
    subst ftenv'0.
    eapply updateFEnvLemma.
    auto.
    auto.
    rewrite H5.
    auto.

- (* modify *)
  unfold UniEType.
  intros ftenv tenv fenv T1 T2 VT1 VT2 XF q K H0 t ftenv0 H0' X.
  inversion X; subst.
  eapply inj_pair2 in H6.
  eapply inj_pair2 in H6; subst.
  assert (VT4 = VT1).
  eapply loc_pi.
  subst.
  assert (VT5 = VT2).
  eapply loc_pi.
  subst.
  clear XF2.
  reflexivity.
  (* return *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  inversion X2; subst.
  inversion k; subst.
  eapply ValueStrongTyping.
  eauto.
  eauto.
  inversion k; subst.
  eapply IdStrongTyping.
  eauto.
  auto.
(* bindN *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  eauto.
  auto.
(* bindS *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  subst tenv'.
  assert (t1 = t3).
  eapply H.
  auto.
  Focus 2.
  eauto.
  auto.
  rewrite H1.
  eauto.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H.
  eapply overrideEnvLemmaT.
  assumption.
  assumption.
  Focus 2.
  assert (tenvP = tenvP0).
  eapply EnvStrongTyping.
  eauto.
  auto.
  rewrite H0.
  eauto.
  eapply overrideEnvLemmaT.
  auto.
  auto.
- unfold UniEType, UniQFType, UniPType.
  intros.
  inversion X1; subst.
  assert (FT fps t = FT fps0 t2).
  eapply H.
  auto.
  eauto.
  auto.
  injection H1.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply ValueStrongTyping.
  eauto.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  eauto.
  auto.
- unfold UniEType, Par_SSL, UniPType.
  intros.
  dependent induction X; subst.
  inversion X2; subst.
  inversion X; subst.
  auto.
  destruct pt2.
  destruct ts.
  + inversion X2; subst.
    inversion X3.
  + inversion m; subst.
    inversion X2; subst.
    inversion X5; subst.
    assert (PT bbs = PT ts).
    {*  eapply IHX.
      auto.
      auto.
      Focus 2.
      econstructor.
      eauto.
      auto.
   }
   injection H.
   intro.
   assert (b = v).
   {* eapply p0.
      auto.
      Focus 2.
      eauto.
      auto.
   }
   rewrite H0.
   rewrite H1.
   auto.
Qed.

Definition FunTypingUni_rect :=
  FunTyping_str_rect UniFType UniQFType UniEType UniPType.

Lemma FunStrongTyping :
  forall (f: Fun) (ft: FTyp) (k: FunTyping f ft),
    UniFType f ft k.
Proof.
eapply FunTypingUni_rect.
- (* SLL *)
  unfold Par_SSL, UniEType.
  intros.
  constructor.
- (* SLL *)
  unfold Par_SSL, UniEType.
  intros.
  constructor.
  assumption.
  assumption.
  assumption.
- (* SSA *)
  unfold Par_SSA, UniFType.
  constructor.
- unfold Par_SSA, UniFType.
  intros.
  constructor.
  assumption.
  assumption.
  assumption.
- (* SSB *)
  unfold Par_SSB, Par_SSA, UniFType.
  intros.
  econstructor.
  exact m0.
  exact m1.
  assumption.
  assumption.
  assumption.
  assumption.
  assumption.
  assumption.
- (* Par_F *)
  unfold UniFType, UniETypeW, UniEType.
  intros.
  inversion H0; subst.
  inversion H1; subst.
  intros.
  eapply H.
  auto.
  Focus 2.
  eauto.
  auto.
- (* Par_F *)
  unfold UniFType, UniETypeW, UniEType.
  intros ftenv tenv fenv.
  intros e0 e1 x n t.
  intros K1 K2 K3 HP1 HP2.
  intros fps t0 E3.
  intros ftenv1 i fenv1 x0 e2 e3 K4 E4.
  inversion E3; subst.
  inversion E4; subst.
  intros.
  eapply HP1.
  eapply updateFEnvLemma.
  assumption.
  assumption.
  eassumption.
  assumption.
- (* Par_Q - QF *)
  unfold UniQFType, UniFType, UniEType, UniETypeW.
  intros.
  inversion X1; subst.
  destruct ft as [fps t].
  specialize (H fps t eq_refl).
  inversion k; subst.
  + inversion X2; subst.
    specialize (H ftenv1 0 fenv0 x e0 e1 X3 eq_refl).
    simpl in *.
    assert (t = t0).
    eapply H.
    auto.
    auto.
    Focus 2.
    eassumption.
    auto.
    rewrite H0.
    auto.
  + inversion X2; subst.
    subst ftenv' fenv'.
    subst ftenv'0 fenv'0.
    specialize (H ftenv1
                  (S n) fenv0 x e0 e1 X3 eq_refl).
    simpl in *.
    assert (t = t0).
    eapply H.
    auto.
    eapply updateFEnvLemma.
    auto.
    auto.
    Focus 2.
    eauto.
    eapply updateFEnvLemma.
    auto.
    auto.
    rewrite H0.
    auto.

- (* Par_Q - FVar *)
  unfold  UniQFType, UniFType, UniEType, UniETypeW, Par_SSB, Par_SSA.
  intros.
  inversion X; subst.
  clear X.
  clear X3 X4.
  destruct ft as [fps t].
  specialize (H1 fps t eq_refl).
  inversion X2; subst.
  destruct ft2.
  destruct f.

  inversion m; subst.
  inversion X3; subst.

  +
    inversion X; subst.
    rewrite H0 in H4.
    (*inversion X2; subst.
    inversion X8; subst. *)

(***)
    assert (f0 = FC fenv fps e0 e1 x0 0).
    eapply (envAppendCompare FunTyping ls0 ls8 ls1 ls3).
    eauto.
    eauto.
    eauto.
    auto.
    auto.

    rewrite H5 in *.

    specialize (H1 ftenv).
    specialize (H1 0 fenv x0 e0 e1).
    specialize (H1 X6 eq_refl).
    simpl in *.
    inversion X8; subst.

    assert (t = ret_type).
    eapply H1.
    auto.
    auto.
    Focus 2.
    eauto.
    auto.
    rewrite H5.
    auto.

  + inversion X; subst.
    rewrite H0 in H4.
    (* inversion X2; subst.
    inversion X9; subst. *)

    assert (f0 = FC fenv fps e0 e1 x0 (S n0)).
    eapply (envAppendCompare FunTyping ls0 ls8 ls1 ls3).
    eauto.
    eauto.
    eauto.
    auto.
    auto.

    rewrite H5 in *.

    specialize (H1 ftenv).
    specialize (H1 (S n0) fenv x0 e0 e1).
    specialize (H1 X6 eq_refl).
    simpl in *.
    inversion X9; subst.

    assert (t = ret_type).
    eapply H1.
    auto.
    eapply updateFEnvLemma.
    auto.
    auto.
    Focus 2.
    eauto.
    subst ftenv'0.
    eapply updateFEnvLemma.
    auto.
    auto.
    rewrite H5.
    auto.

- (* modify *)
  unfold UniEType.
  intros ftenv tenv fenv T1 T2 VT1 VT2 XF q K H0 t ftenv0 H0' X.
  inversion X; subst.
  eapply inj_pair2 in H6.
  eapply inj_pair2 in H6; subst.
  assert (VT4 = VT1).
  eapply loc_pi.
  subst.
  assert (VT5 = VT2).
  eapply loc_pi.
  subst.
  clear XF2.
  reflexivity.
  (* return *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  inversion X2; subst.
  inversion k; subst.
  eapply ValueStrongTyping.
  eauto.
  eauto.
  inversion k; subst.
  eapply IdStrongTyping.
  eauto.
  auto.
(* bindN *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  eauto.
  auto.
(* bindS *)
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  subst tenv'.
  assert (t1 = t3).
  eapply H.
  auto.
  Focus 2.
  eauto.
  auto.
  rewrite H1.
  eauto.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H.
  eapply overrideEnvLemmaT.
  assumption.
  assumption.
  Focus 2.
  assert (tenvP = tenvP0).
  eapply EnvStrongTyping.
  eauto.
  auto.
  rewrite H0.
  eauto.
  eapply overrideEnvLemmaT.
  auto.
  auto.
- unfold UniEType, UniQFType, UniPType.
  intros.
  inversion X1; subst.
  assert (FT fps t = FT fps0 t2).
  eapply H.
  auto.
  eauto.
  auto.
  injection H1.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply ValueStrongTyping.
  eauto.
  auto.
- unfold UniEType.
  intros.
  inversion X1; subst.
  eapply H0.
  auto.
  Focus 2.
  eauto.
  auto.
- unfold UniEType, Par_SSL, UniPType.
  intros.
  dependent induction X; subst.
  inversion X2; subst.
  inversion X; subst.
  auto.
  destruct pt2.
  destruct ts.
  + inversion X2; subst.
    inversion X3.
  + inversion m; subst.
    inversion X2; subst.
    inversion X5; subst.
    assert (PT bbs = PT ts).
    {*  eapply IHX.
      auto.
      auto.
      Focus 2.
      econstructor.
      eauto.
      auto.
   }
   injection H.
   intro.
   assert (b = v).
   {* eapply p0.
      auto.
      Focus 2.
      eauto.
      auto.
   }
   rewrite H0.
   rewrite H1.
   auto.
Qed.

Lemma UniFTypeLm0 (fenv: funEnv) (tenv0: valTC)
      (e0 e1: Exp) (x: Id) (ft1: FTyp)
      (k: FunTyping (FC fenv tenv0 e0 e1 x 0) ft1) :
  UniFType (FC fenv tenv0 e0 e1 x 0) ft1 k ->
  UniFTypeS (FC fenv tenv0 e0 e1 x 0) ft1 k.
Proof.
  unfold UniFTypeS.
  unfold UniFType, UniFTypeS, UniETypeW.
  intros.
  destruct ft1 as [tenv t].
  destruct ft2.
  specialize (H tenv t eq_refl).
  inversion k; subst.
  inversion X; subst.
  rename prs_type into tenv.
  rename ret_type into t0.
  specialize (H ftenv 0 fenv x e0 e1 X0 eq_refl).
  simpl in *.
  specialize (H X1 X0).
  specialize (H t0 ftenv0 X2 X3).
  assert (t = t0).
  eapply ExpStrongTyping.
  exact X1.
  auto.
  exact X2.
  auto.
  rewrite H0.
  auto.
Qed.

Lemma UniFTypeLm0a (fenv: funEnv) (tenv0: valTC)
      (e0 e1: Exp) (x: Id) (ft1 ft2: FTyp)
      (k: FunTyping (FC fenv tenv0 e0 e1 x 0) ft1) :
  UniFType (FC fenv tenv0 e0 e1 x 0) ft1 k ->
  FunTyping (FC fenv tenv0 e0 e1 x 0) ft2 -> ft1 = ft2.
  intros.
  eapply UniFTypeLm0.
  eauto.
  auto.
Qed.

Lemma UniFTypeLm0b (fenv: funEnv) (tenv0: valTC)
      (e0 e1: Exp) (x: Id) (ft1 ft2: FTyp)
      (k1: FunTyping (FC fenv tenv0 e0 e1 x 0) ft1)
      (k2: FunTyping (FC fenv tenv0 e0 e1 x 0) ft2) : ft1 = ft2.
  intros.
  inversion k1; subst.
  inversion k2; subst.
  assert (t = t0).
  eapply ExpStrongTyping.
  exact X0.
  auto.
  exact X1.
  auto.
  rewrite H.
  auto.
Qed.

Lemma UniFTypeLm1 (fenv: funEnv) (tenv0: valTC)
      (e0 e1: Exp) (x: Id) (ft1: FTyp)
      (k1: FunTyping (FC fenv tenv0 e0 e1 x 1) ft1)
      (k0: FunTyping (FC fenv tenv0 e0 e1 x 0) ft1):
  UniFType (FC fenv tenv0 e0 e1 x 1) ft1 k1 ->
  UniFType (FC fenv tenv0 e0 e1 x 0) ft1 k0.
Proof.
  unfold UniFType.
  intros.
  destruct ft1 as [tenv1 t1].

  inversion H1; subst.
  inversion H0; subst.
  clear H1.
  clear H0.
  unfold UniETypeW in *.

  intros.
  eapply ExpStrongTyping.
  exact X0.
  auto.
  exact X2.
  auto.
Qed.

Lemma UniFTypeLmN (fenv: funEnv) (tenv0: valTC)
      (e0 e1: Exp) (x: Id) (n: nat) (ft1: FTyp)
      (k1: FunTyping (FC fenv tenv0 e0 e1 x (S n)) ft1)
      (k0: FunTyping (FC fenv tenv0 e0 e1 x n) ft1):
  UniFType (FC fenv tenv0 e0 e1 x (S n)) ft1 k1 ->
  UniFType (FC fenv tenv0 e0 e1 x n) ft1 k0.
Proof.
  unfold UniFType.
  intros.
  destruct ft1 as [tenv1 t1].

  inversion H1; subst.
  inversion H0; subst.
  clear H1.
  clear H0.
  unfold UniETypeW in *.

  destruct i.
  intros.
  eapply ExpStrongTyping.
  exact X0.
  auto.
  exact X2.
  auto.

  intros.
  inversion k0; subst.
  subst ftenv' fenv'.
  eapply ExpStrongTyping.
  exact X5.
  eapply updateFEnvLemma.
  auto.
  auto.
  eapply X2.
  auto.
Qed.

Lemma UniFTypeLm1b (fenv: funEnv) (tenv0: valTC)
      (e0 e1: Exp) (x: Id) (ft1 ft2: FTyp)
      (k1: FunTyping (FC fenv tenv0 e0 e1 x 1) ft1)
      (k2: FunTyping (FC fenv tenv0 e0 e1 x 0) ft2) : ft1 = ft2.
  intros.
  inversion k1; subst.
  inversion X1; subst.
  inversion k2; subst.
  subst ftenv' fenv'.
  assert (t = t0).
  eapply ExpStrongTyping.
  exact X3.
  auto.
  exact X4.
  auto.
  rewrite H.
  auto.
Qed.

Lemma UniFTypeLmPb (fenv: funEnv) (tenv0: valTC)
      (e0 e1: Exp) (x: Id) (n: nat) (ft1 ft2: FTyp)
      (k1: FunTyping (FC fenv tenv0 e0 e1 x n) ft1)
      (k2: FunTyping (FC fenv tenv0 e0 e1 x (S n)) ft2) : ft1 = ft2.
Proof.
  intros.
  inversion k1; subst.

  - inversion k2; subst.
    inversion X3; subst.
    assert (t = t0).
    {+ eapply ExpStrongTyping.
       exact X0.
       auto.
       exact X4.
       auto.
    }
    rewrite H.
    auto.

  - inversion k2; subst.
    subst ftenv' fenv' ftenv'0 fenv'0.
    inversion X4; subst.
    subst ftenv' fenv'.
    assert (t = t0).
    {+ eapply ExpStrongTyping.
       exact X0.
       eapply updateFEnvLemma.
       auto.
       auto.
       eapply updateFEnvLemma.
       eauto.
       eauto.
       auto.
    }
    rewrite H.
    auto.
Qed.

Lemma UniFTypeLmNZE1 (fenv: funEnv) (tenv0: valTC)
      (e0 e1: Exp) (x: Id) (ft: FTyp) :
  forall n: nat,
    FunTyping (FC fenv tenv0 e0 e1 x (S n)) ft ->
    sigT (fun ft0 => FunTyping (FC fenv tenv0 e0 e1 x n) ft0).
Proof.
  intros.
  inversion X; subst.
  econstructor.
  eassumption.
Qed.

Lemma UniFTypeLmNZ1 (fenv: funEnv) (tenv0: valTC)
      (e0 e1: Exp) (x: Id) (ft: FTyp) :
  forall n: nat,
    FunTyping (FC fenv tenv0 e0 e1 x (S n)) ft ->
    FunTyping (FC fenv tenv0 e0 e1 x n) ft.
Proof.
  intros.
  generalize X.
  eapply UniFTypeLmNZE1 in X.
  intro.
  destruct X as [ft0 X].
  eapply UniFTypeLmPb with (ft1:=ft0) (ft2:=ft) in X0.
  rewrite <- X0.
  auto.
  auto.
Qed.

Lemma UniFTypeLmNZ (fenv: funEnv) (tenv0: valTC)
      (e0 e1: Exp) (x: Id) (ft: FTyp) :
  forall n: nat,
    FunTyping (FC fenv tenv0 e0 e1 x n) ft ->
    FunTyping (FC fenv tenv0 e0 e1 x 0) ft.
Proof.
  intros.
  induction n.
  auto.
  eapply UniFTypeLmNZ1 in X.
  eapply IHn.
  auto.
Qed.

Lemma UniFTypeLm (f: Fun) (ft1 ft2: FTyp) (k: FunTyping f ft1) :
  UniFType f ft1 k ->
  FunTyping f ft2 -> ft1 = ft2.
Proof.
  destruct f.
  induction n.
  eapply UniFTypeLm0a.
  intros.
  inversion k; subst.
  eapply (IHn X2).
  eapply UniFTypeLmN.
  exact H.
  inversion X; subst.
  auto.
Qed.

Lemma UniqueFunType (f: Fun) (ft1 ft2: FTyp)
      (k1: FunTyping f ft1)
      (k2: FunTyping f ft2) :  ft1 = ft2.
Proof.
  eapply UniFTypeLm with (k:=k1).
  eapply FunStrongTyping.
  eauto.
Qed.

End STyping.


Require Import CT.Automata.Mealy.
Require Import CT.Category.

(** * The category of mealy automata.

Motivation: Modification of https://ncatlab.org/nlab/show/automaton
*)
Program Definition MealyCategory : Category :=
  {| ob := Mealy;
     mor := MealyMorphism;
     comp := fun _ _ _ x y => MealyMorphism_composition x y;
     id := fun _ => MealyMorphism_identity;
     assoc := fun _ _ _ _ => MealyMorphism_assoc
  |}.
Next Obligation.
Proof. symmetry. apply MealyMorphism_assoc. Qed.
Next Obligation.
Proof.
  apply MealyMorphism_eq.
  simpl. reflexivity.
  simpl. reflexivity.
  simpl. reflexivity.
Qed.
Next Obligation.
  apply MealyMorphism_eq.
  simpl. reflexivity.
  simpl. reflexivity.
  simpl. reflexivity.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)

Require Import ssreflect.
Require Import ssrbool ssrfun TestSuite.ssr_mini_mathcomp.
Axiom daemon : False. Ltac myadmit := case: daemon.

(* Ltac debugging feature: recursive elim + eq generation *)
Lemma testL1 : forall A (s : seq A), s = s.
Proof.
move=> A s; elim branch: s => [|x xs _].
match goal with _ : _ = [::] |- [::] = [::] => move: branch => // | _ => fail end.
match goal with _ : _ =  _ :: _ |- _ :: _ = _ :: _ => move: branch => // | _ => fail end.
Qed.

(* The same but with explicit eliminator and a conflict in the intro pattern *)
Lemma testL2 : forall A (s : seq A), s = s.
Proof.
move=> A s; elim/last_ind branch: s => [|x s _].
match goal with _ : _ = [::] |- [::] = [::] => move: branch => // | _ => fail end.
match goal with _ : _ =  rcons _ _ |- rcons _ _ = rcons _ _ => move: branch => // | _ => fail end.
Qed.

(* The same but without names for variables involved in the generated eq *)
Lemma testL3 : forall A (s : seq A), s = s.
Proof.
move=> A s; elim branch: s; move: (s) => _.
match goal with _ : _ = [::] |- [::] = [::] => move: branch => // | _ => fail end.
move=> _; match goal with _ : _ =  _ :: _ |- _ :: _ = _ :: _ => move: branch => // | _ => fail end.
Qed.

Inductive foo : Type := K1 : foo | K2 : foo -> foo -> foo | K3 : (nat -> foo) -> foo.

(* The same but with more intros to be done *)
Lemma testL4 : forall (o : foo), o = o.
Proof.
move=> o; elim branch: o.
match goal with _ : _ = K1 |- K1 = K1 => move: branch => // | _ => fail end.
move=> _; match goal with _ : _ = K2 _ _ |- K2 _ _ = K2 _ _ => move: branch => // | _ => fail end.
move=> _; match goal with _ : _ =  K3 _ |- K3 _ = K3 _ => move: branch => // | _ => fail end.
Qed.

(* Occurrence counting *)
Lemma testO1: forall (b : bool), b = b.
Proof.
move=> b; case: (b) / idP.
match goal with |- is_true b -> true = true => done | _ => fail end.
match goal with |- ~ is_true b -> false = false => done | _ => fail end.
Qed.

(* The same but only the second occ *)
Lemma testO2: forall (b : bool), b = b.
Proof.
move=> b; case: {2}(b) / idP.
match goal with |- is_true b -> b = true => done | _ => fail end.
match goal with |- ~ is_true b -> b = false => move/(introF idP) => // | _ => fail end.
Qed.

(* The same but with eq generation *)
Lemma testO3: forall (b : bool), b = b.
Proof.
move=> b; case E: {2}(b) / idP.
match goal with _ : is_true b, _ : b = true |- b = true => move: E => _; done | _ => fail end.
match goal with H : ~ is_true b, _ : b = false |- b = false => move: E => _; move/(introF idP): H => // | _ => fail end.
Qed.

(* Views *)
Lemma testV1 : forall A (s : seq A), s = s.
Proof.
move=> A s; case/lastP E: {1}s => [| x xs].
match goal with _ : s = [::] |- [::] = s => symmetry; exact E | _ => fail end.
match goal with _ : s = rcons x xs |- rcons _ _ = s => symmetry; exact E | _ => fail end.
Qed.

Lemma testV2 : forall A (s : seq A), s = s.
Proof.
move=> A s; case/lastP E: s => [| x xs].
match goal with _ : s = [::] |- [::] = [::] => done | _ => fail end.
match goal with _ : s = rcons x xs |- rcons _ _ = rcons _ _ => done | _ => fail end.
Qed.

Lemma testV3 : forall A (s : seq A), s = s.
Proof.
move=> A s; case/lastP: s => [| x xs].
match goal with |- [::] = [::] => done | _ => fail end.
match goal with |- rcons _ _ = rcons _ _ => done | _ => fail end.
Qed.

(* Patterns *)
Lemma testP1: forall (x y : nat), (y == x) && (y == x) -> y == x.
move=> x y; elim: {2}(_ == _) / eqP.
match goal with |- (y = x -> is_true ((y == x) && true) -> is_true (y == x)) => move=> -> // | _ => fail end.
match goal with |- (y <> x -> is_true ((y == x) && false) -> is_true (y == x)) => move=> _; rewrite andbC // | _ => fail end.
Qed.

(* The same but with an implicit pattern *)
Lemma testP2 : forall (x y : nat), (y == x) && (y == x) -> y == x.
move=> x y; elim: {2}_ / eqP.
match goal with |- (y = x -> is_true ((y == x) && true) -> is_true (y == x)) => move=> -> // | _ => fail end.
match goal with |- (y <> x -> is_true ((y == x) && false) -> is_true (y == x)) => move=> _; rewrite andbC // | _ => fail end.
Qed.

(* The same but with an eq generation switch *)
Lemma testP3 : forall (x y : nat), (y == x) && (y == x) -> y == x.
move=> x y; elim E: {2}_ / eqP.
match goal with _ : y = x |- (is_true ((y == x) && true) -> is_true (y == x)) => rewrite E; reflexivity | _ => fail end.
match goal with _ : y <> x |- (is_true ((y == x) && false) -> is_true (y == x)) => rewrite E => /= H; exact H  | _ => fail end.
Qed.

Inductive spec : nat -> nat -> nat -> Prop :=
| specK : forall a b c, a = 0 -> b = 2 -> c = 4 -> spec a b c.
Lemma specP : spec 0 2 4. Proof. by constructor. Qed.

Lemma testP4 : (1+1) * 4 = 2 + (1+1) + (2 + 2).
Proof.
case: specP => a b c defa defb defc.
match goal with |- (a.+1 + a.+1) * c = b + (a.+1 + a.+1) + (b + b) => subst; done | _ => fail end.
Qed.

Lemma testP5 : (1+1) * 4 = 2 + (1+1) + (2 + 2).
Proof.
case: (1 + 1) _ / specP => a b c defa defb defc.
match goal with |- b * c = a.+2 + b + (a.+2 + a.+2) => subst; done | _ => fail end.
Qed.

Lemma testP6 : (1+1) * 4 = 2 + (1+1) + (2 + 2).
Proof.
case: {2}(1 + 1) _ / specP => a b c defa defb defc.
match goal with |- (a.+1 + a.+1) * c = a.+2 + b + (a.+2 + a.+2) => subst; done | _ => fail end.
Qed.

Lemma testP7 : (1+1) * 4 = 2 + (1+1) + (2 + 2).
Proof.
case: _ (1 + 1) (2 + _) / specP => a b c defa defb defc.
match goal with |- b * a.+4 = c + c => subst; done | _ => fail end.
Qed.

Lemma testP8 : (1+1) * 4 = 2 + (1+1) + (2 + 2).
Proof.
case E: (1 + 1) (2 + _) / specP=> [a b c defa defb defc].
match goal with |- b * a.+4 = c + c => subst; done | _ => fail end.
Qed.

Variables (T : Type) (tr : T -> T).

Inductive exec (cf0 cf1 : T) : seq T -> Prop :=
| exec_step : tr cf0 = cf1 -> exec cf0 cf1 [::]
| exec_star : forall cf2 t, tr cf0 = cf2 ->
  exec cf2 cf1 t -> exec cf0 cf1 (cf2 :: t).

Inductive execr (cf0 cf1 : T) : seq T -> Prop :=
| execr_step : tr cf0 = cf1 -> execr cf0 cf1 [::]
| execr_star : forall cf2 t, execr cf0 cf2 t ->
  tr cf2 = cf1 -> execr cf0 cf1 (t ++ [:: cf2]).

Lemma execP : forall cf0 cf1 t, exec cf0 cf1 t <-> execr cf0 cf1 t.
Proof.
move=> cf0 cf1 t; split => [] Ecf.
  elim: Ecf.
    match goal with |- forall cf2 cf3 : T, tr cf2 = cf3 ->
      execr cf2 cf3 [::] => myadmit | _ => fail end.
  match goal with |- forall (cf2 cf3 cf4 : T) (t0 : seq T),
   tr cf2 = cf4 -> exec cf4 cf3 t0 -> execr cf4 cf3 t0 ->
   execr cf2 cf3 (cf4 :: t0) => myadmit | _ => fail end.
elim: Ecf.
  match goal with |- forall cf2 : T,
    tr cf0 = cf2 -> exec cf0 cf2 [::] => myadmit | _ => fail end.
match goal with |- forall (cf2 cf3 : T) (t0 : seq T),
 execr cf0 cf3 t0 -> exec cf0 cf3 t0 -> tr cf3 = cf2 ->
 exec cf0 cf2 (t0 ++ [:: cf3]) => myadmit | _ => fail end.
Qed.

Fixpoint plus (m n : nat) {struct n} : nat :=
   match n with
   | 0 => m
   | S p => S (plus m p)
   end.

Definition plus_equation :
forall m n : nat,
       plus m n =
       match n with
       | 0 => m
       | p.+1 => (plus m p).+1
       end
:=
fun m n : nat =>
match
  n as n0
  return
    (forall m0 : nat,
     plus m0 n0 =
     match n0 with
     | 0 => m0
     | p.+1 => (plus m0 p).+1
     end)
with
| 0 => @erefl nat
| n0.+1 => fun m0 : nat => erefl (plus m0 n0).+1
end m.

Definition plus_rect :
forall (m : nat) (P : nat -> nat -> Type),
       (forall n : nat, n = 0 -> P 0 m) ->
       (forall n p : nat,
        n = p.+1 -> P p (plus m p) -> P p.+1 (plus m p).+1) ->
       forall n : nat, P n (plus m n)
:=
fun (m : nat) (P : nat -> nat -> Type)
  (f0 : forall n : nat, n = 0 -> P 0 m)
  (f : forall n p : nat,
       n = p.+1 -> P p (plus m p) -> P p.+1 (plus m p).+1) =>
fix plus0 (n : nat) : P n (plus m n) :=
  eq_rect_r [eta P n]
    (let f1 := f0 n in
     let f2 := f n in
     match
       n as n0
       return
         (n = n0 ->
          (forall p : nat,
           n0 = p.+1 -> P p (plus m p) -> P p.+1 (plus m p).+1) ->
          (n0 = 0 -> P 0 m) ->
          P n0 match n0 with
               | 0 => m
               | p.+1 => (plus m p).+1
               end)
     with
     | 0 =>
         fun (_ : n = 0)
           (_ : forall p : nat,
                0 = p.+1 ->
                P p (plus m p) -> P p.+1 (plus m p).+1)
           (f4 : 0 = 0 -> P 0 m) => unkeyed (f4 (erefl 0))
     | n0.+1 =>
         fun (_ : n = n0.+1)
           (f3 : forall p : nat,
                 n0.+1 = p.+1 ->
                 P p (plus m p) -> P p.+1 (plus m p).+1)
           (_ : n0.+1 = 0 -> P 0 m) =>
         let f5 :=
           let p := n0 in
           let H := erefl n0.+1 : n0.+1 = p.+1 in f3 p H in
         unkeyed (let Hrec := plus0 n0 in f5 Hrec)
     end (erefl n) f2 f1) (plus_equation m n).

Definition plus_ind := plus_rect.

Lemma exF x y z: plus (plus x y) z = plus x (plus y z).
elim/plus_ind: z / (plus _ z).
match goal with |- forall n : nat, n = 0 -> plus x y = plus x (plus y 0) => idtac end.
Undo 2.
elim/plus_ind: (plus _ z).
match goal with |- forall n : nat, n = 0 -> plus x y = plus x (plus y 0) => idtac end.
Undo 2.
elim/plus_ind: {z}(plus _ z).
match goal with |- forall n : nat, n = 0 -> plus x y = plus x (plus y 0) => idtac end.
Undo 2.
elim/plus_ind: {z}_.
match goal with |- forall n : nat, n = 0 -> plus x y = plus x (plus y 0) => idtac end.
Undo 2.
elim/plus_ind: z / _.
match goal with |- forall n : nat, n = 0 -> plus x y = plus x (plus y 0) => idtac end.
 done.
by move=> _ p _ ->.
Qed.

(* BUG elim-False *)
Lemma testeF : False -> 1 = 0.
Proof. by elim. Qed.