(** This file shows that, for any formula [F], the sequent
[|-- [] ; []; UP([F, F ^ ])] is provable *)
Require Export LL.SL.FLL.InvPositivePhase.

Export ListNotations.
Export LLNotations.
Set Implicit Arguments.

Section FLLTheory.
  Context `{OLS: OLSig}.
    Section AdmissibleRules.

Ltac LLPermA M :=
    match goal with
    | [ |- flls _ _ _ ?X ] =>
     eapply @EquivUpArrow2 with (L:=M);[| | perm]
  end;auto.

 Theorem InvTensorS th: forall B PF PG F G,
        flls th B [] (UP [PF;F]) ->
        flls th B [] (UP [PG;G]) ->
        flls th B [F ⊗ G] (UP [PF;PG]) .
    Proof with sauto;solvePolarity;solveLL.
      intros.
      change [F ⊗ G] with (F ⊗ G::[]++[]).
       change [PF ;PG] with ([PF]++[PG]).
      eapply  InvTensor...
Qed.

Theorem InvTensorCS th: forall B PF PG F G,
        flls th B [] (UP [PF;F]) ->
        flls th B [] (UP [PG;G]) ->
        flls th (F ⊗ G::B) [] (UP [PF;PG]) .
    Proof with sauto;solvePolarity;solveLL.
      intros.
      change (flls th (F ⊗ G :: B) [] (UP [PF; PG])) with
                   (flls th (F ⊗ G :: B) ([]++[]) (UP ([PF] ++ [PG]))).
      eapply  InvTensorC with (F:=F) (G:=G)...
     1-2: apply weakening...
Qed.

      Theorem InitGeneral th:
        forall P B, isFormula P -> isFormula (dual P) -> isFormulaL B ->
             flls th B [] (UP [P;dual P]) .
      Proof with sauto;solveLL.
        induction P;intros;intros;
          match goal with
          | [ H: isFormulaL ?B |- _ ] =>
            rename H into isFB
          end;simpl...
       -
          inversion H...
          inversion H0...
          pose proof (IHP1 B H3 H5 isFB);sauto.
          LLPermA [P1 ^ ⊕ P2 ^;P1]...
          eapply InvPlus with (M:=[])...
       -
          inversion H...
          inversion H0...
          pose proof (IHP2 B H4 H6 isFB);sauto.
          LLPermA [P1 ^ ⊕ P2 ^;P2]...
          eapply InvPlusComm with (M:=[])...
       -
          inversion H...
          inversion H0...
          pose proof (IHP1 B H3 H5 isFB);sauto.
          pose proof (IHP2 B H4 H6 isFB);sauto.
          eapply InvTensorS.
          LLPermA [P1; P1 ^]...
          LLPermA [P2; P2 ^]...
       -
          inversion H...
          inversion H0...
          pose proof (IHP1 B H3 H5 isFB);sauto.
          eapply InvPlus with (M:=[])...
         simpl. LLPermA [P1; P1 ^]...
       -
          inversion H...
          inversion H0...
          pose proof (IHP2 B H4 H6 isFB);sauto.
          eapply InvPlusComm with (M:=[])...
         simpl. LLPermA [P2; P2 ^]...
       -
          inversion H...
          inversion H0...
          LLPermA [P1 ^ ⊗ P2 ^; P1;P2]...
          pose proof (IHP1 B H3 H5 isFB);sauto.
          pose proof (IHP2 B H4 H6 isFB);sauto.
          eapply InvTensorS...
       -
          inversion H...
          inversion H0...
          pose proof (IHP B H2 H3 isFB);sauto.
          LFocus...
         eapply AbsorptionClassic with (F:=P ^)...
         eapply weakeningGen_rev...
       -
          inversion H...
          inversion H0...
          pose proof (IHP B H2 H3 isFB);sauto.
          LFocus...
         eapply AbsorptionClassic with (F:=P)...
         eapply weakeningGen_rev...
         LLPermA [P  ; P^]...
        apply Forall_app...
       -
          inversion H0...
          inversion H1...
          pose proof (H4 x). pose proof (H6 x). clear H4 H6.
          pose proof (H x B H2 H7 isFB);sauto.
         LLPermA [∃{ fun x0 : expr con => (o x0) ^}; o x ]...
          eapply InvEx with (M:=[]) (t:=x)...
       -
          inversion H0...
          inversion H1...
          pose proof (H4 x). pose proof (H6 x). clear H4 H6.
          pose proof (H x B H2 H7 isFB);sauto.
          eapply InvEx with (M:=[]) (t:=x)...
          LLPermA [o x; dual ( o x) ]...
          apply Forall_app...
Qed.

     Theorem FLLGeneralInit1 th:
        forall P B, isFormula P -> isFormula (dual P) -> isFormulaL B -> positiveLFormula P ->
                  flls th  B [P] (DW (dual P)).
      Proof with sauto;solvePolarity.
        intros.
assert(flls th  B [] (UP [P; dual P])).
apply InitGeneral...
inversion H3...
  destruct (PositiveOrNegative P)...
 FLLrelease...
  apply PositiveDualNegative in H2...
inversion H2...

simpl...
Qed.

(*
      Theorem FLLEquiv th : forall F, isFormula F -> isFormula (dual F) -> flls th [] []  (UP [F == F]).
      Proof with subst;auto;solveF.
        intros.
        apply tri_with'; eapply tri_par';
          eapply EquivUpArrow2 with (L:=[F;F^]).
        change ([F ^; F]) with ([F ^]++ [F]).
        apply ForallApp...
        apply FLLGeneralInit...
        perm.
        change ([F ^; F]) with ([F ^]++ [F]).
        apply ForallApp...
        apply FLLGeneralInit...
        perm.
      Qed.

      Theorem FLLEquiv' : forall F B, isFormulaL B -> isFormula F -> isFormula (dual F) ->
                                      |-- B; []; (> [F == F]).
      Proof with subst;auto;solveF.
        intros.
        apply tri_with'; eapply tri_par';
          eapply EquivUpArrow2 with (L:=[F;F^]).
        change ([F ^; F]) with ([F ^]++ [F]).
        apply ForallApp...
        apply FLLGeneralInit...
        perm.
        change ([F ^; F]) with ([F ^]++ [F]).
        apply ForallApp...
        apply FLLGeneralInit...
        perm.
      Qed.
 *)
    End AdmissibleRules.
  End FLLTheory.


Require Export CalculusSM_tacs.

Section CalculusSM_derived3.

  Context { pd  : @Data }.
  Context { pn  : @Node }.
  Context { pk  : @Key }.
  Context { pm  : @Msg }.
  Context { qc  : @Quorum_context pn}.
  Context { pat : @AuthTok }.
  Context { paf : @AuthFun pn pk pat pd }.
  Context { pda : @DataAuth pd pn }.
  Context { cad : @ContainedAuthData pd pat pm }.
  Context { dtc : @DTimeContext }.
  Context { iot : @IOTrustedFun }.
  Context { ctp : @ComponentTrust pd pn pat qc iot }.
  Context { cap : @ComponentAuth pd pn pk pat pm dtc iot }.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { base_fun_io       : baseFunIO           }.
  Context { base_state_fun    : baseStateFun        }.
  Context { trusted_state_fun : trustedStateFun     }.
  Context { pkc               : KnowledgeComponents }.

  Local Open Scope kn.

  (***********************************************************)
  Definition DERIVED_RULE_local_before_implies_not_first a {eo : EventOrdering} e R H :=
    MkRule0
      []
      (⟬R⟭ H ⊢ KE_IMPLIES (KE_LOCAL_BEFORE a) KE_NOT_FIRST @ e).

  Lemma DERIVED_RULE_local_before_implies_not_first_true :
    forall a {eo : EventOrdering} e R H,
      rule_true (DERIVED_RULE_local_before_implies_not_first a e R H).
  Proof.
    start_proving_derived st.
    LOCKintro "x".
    LOCKapply@ "x" (PRIMITIVE_RULE_unlocal_before_hyp_true "u" "x").
    LOCKapply@ "u" PRIMITIVE_RULE_not_first_true.
  Qed.

  (***********************************************************)
  Definition DERIVED_RULE_twice_local_before_implies_once {eo : EventOrdering} e R H a :=
    MkRule0
      []
      (⟬R⟭ H ⊢ KE_IMPLIES (KE_LOCAL_BEFORE (KE_LOCAL_BEFORE a)) (KE_LOCAL_BEFORE a) @ e).

  Lemma DERIVED_RULE_twice_local_before_implies_once_true :
    forall {eo : EventOrdering} e R H a,
      rule_true (DERIVED_RULE_twice_local_before_implies_once e R H a).
  Proof.
    start_proving_derived st.
    LOCKintro "x".
    LOCKapply@ "x" (PRIMITIVE_RULE_unlocal_before_hyp_true "u").
    LOCKapply@ "x" (PRIMITIVE_RULE_unlocal_before_hyp_true "v").
    LOCKapply@ "u" PRIMITIVE_RULE_unlocal_before_if_causal_local_true.
    LOCKapply@ "v" PRIMITIVE_RULE_unlocal_before_if_causal_true; LOCKauto.
  Qed.

  (***********************************************************)
  Definition DERIVED_RULE_at_pred_implies_local_before_eq x {eo : EventOrdering} e R H J a :=
    MkRule0
      []
      (⟬R⟭ H • (x › a @ local_pred_n e) » J ⊢ KE_LOCAL_BEFORE_EQ a @ e).

  Lemma DERIVED_RULE_at_pred_implies_local_before_eq_true :
    forall x {eo : EventOrdering} e R H J a,
      rule_true (DERIVED_RULE_at_pred_implies_local_before_eq x e R H J a).
  Proof.
    start_proving_derived st.
    LOCKapply (PRIMITIVE_RULE_cut_after_true "o" x (KE_OR KE_FIRST KE_NOT_FIRST @ e)).
    { LOCKapply PRIMITIVE_RULE_first_dec_true. }

    LOCKelim "o".
    { LOCKintro 1.
      LOCKapply (PRIMITIVE_RULE_introduce_direct_pred_eq_true "u" e); try LOCKauto.
      LOCKapply@ x "u" PRIMITIVE_RULE_subst_causal_eq_hyp_true; try LOCKauto. }

    LOCKintro 0.
    LOCKapply (PRIMITIVE_RULE_introduce_direct_pred_true "u" e); try LOCKauto.
    LOCKapply@ "u" PRIMITIVE_RULE_direct_pred_if_local_pred_true.
    LOCKapply@ "u" PRIMITIVE_RULE_unlocal_before_if_causal_true; try LOCKauto.
  Qed.

End CalculusSM_derived3.


(* DEC1 language development.
   Paolo Torrini,
   Universite' Lille-1 - CRIStAL-CNRS
*)
(* type soundness *)

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 StaticSemA.
Require Import DynamicSemA.
Require Import TRInductA.
Require Import WeakenA.

Require Import IdModTypeA.

Import ListNotations.

Module TSoundness (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 WeakenI := Weaken IdT.
Export WeakenI.

(** type soundness *)

Definition SoundExp (fenv: funEnv) (env: valEnv)
                     (e: Exp) (t: VTyp) (n: W)
  := sigT2 (fun v: Value => ValueTyping v t)
           (fun v: Value => sigT (fun n': W =>
                         EClosure fenv env (Conf Exp n e)
                                                (Conf Exp n' (Val v)))).

Definition SoundPrms (fenv: funEnv) (env: valEnv)
                     (ps: Prms) (pt: PTyp) (n: W)
  := sigT (fun es: list Exp =>
        sigT2 (isValueList2T es)
              (fun vs: list Value =>
                 prod (PrmsTyping emptyE emptyE emptyE (PS es) pt)
                      (sigT (fun n': W =>
                         PrmsClosure fenv env (Conf Prms n ps)
                                               (Conf Prms n' (PS es)))))).

Definition SoundFun (env: valEnv) (tenv: valTC)
                    (f: Fun) (t: VTyp) (n: W)
  := match f with FC fenv' fps e0 e1 x i =>
           fps = tenv ->
           match i with
           | 0 => SoundExp fenv' env e0 t n
           | S j => SoundExp ((x, FC fenv' fps e0 e1 x j) :: fenv')
                           env e1 t n
           end
      end.

Definition SoundQFun (fenv: funEnv) (env: valEnv)
                      (tenv: valTC) (q: QFun) (t: VTyp) (n: W)
  := sigT2 (fun f: Fun => SoundFun env tenv f t n)
           (fun f: Fun => forall n':W, QFClosure fenv (Conf QFun n' q)
                                           (Conf QFun n' (QF f))).

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

Definition FunSoundness :=
     fun (f: Fun) (ft: FTyp)
         (k: FunTyping f ft) =>
      forall env: valEnv,
      MatchEnvsT ValueTyping env (extParType ft) ->
      forall n: W, SoundFun env (extParType ft) f (extRetType ft) n.

Definition QFunSoundness :=
     fun (ftenv: funTC) (fenv: funEnv)
         (q: QFun) (ft: FTyp)
         (k: QFunTyping ftenv fenv q ft) =>
      MatchEnvsT FunTyping fenv ftenv ->
      forall env: valEnv,
      MatchEnvsT ValueTyping env (extParType ft) ->
      forall n: W,
        SoundQFun fenv env (extParType ft) q (extRetType ft) n.
Definition ExpSoundness :=
     fun (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
         (e: Exp) (t: VTyp)
         (k: ExpTyping ftenv tenv fenv e t) =>
   MatchEnvsT FunTyping fenv ftenv ->
   forall env: valEnv,
   MatchEnvsT ValueTyping env tenv ->
   forall n: W, SoundExp fenv env e t n.

Definition PrmsSoundness :=
     fun (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
         (ps: Prms) (pt: PTyp)
         (k: PrmsTyping ftenv tenv fenv ps pt) =>
   MatchEnvsT FunTyping fenv ftenv ->
   forall env: valEnv,
   MatchEnvsT ValueTyping env tenv ->
   forall n: W, SoundPrms fenv env ps pt n.

Definition ExpTypingSound_rect :=
  ExpTyping_str_rect FunSoundness QFunSoundness
                     ExpSoundness PrmsSoundness.

Lemma ExpEval :
  forall (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
   (e: Exp) (t: VTyp)
   (k: ExpTyping ftenv tenv fenv e t),
   ExpSoundness ftenv tenv fenv e t k.

Proof.
eapply ExpTypingSound_rect.

- (** base Par_SSL *)
  unfold Par_SSL, ExpSoundness.
  constructor.

- (** step Par_SSL *)
  unfold Par_SSL, ExpSoundness.
  intros.
  constructor.
  + assumption.
  + assumption.
  + assumption.

- (** base Par_SSA *)
  unfold Par_SSA, FunSoundness.
  constructor.

- (** step Par_SSA *)
  unfold Par_SSA, FunSoundness.
  intros.
  constructor.
  + assumption.
  + assumption.
  + assumption.

- (** Par_SSB *)
  unfold Par_SSB, Par_SSA, FunSoundness.
  intros.
  econstructor.

(*  eapply (Forall2BT_split FunTyping _
                         fenv0 fenv1 ftenv0 ftenv1 x f t). *)
  + exact m0.
  + exact m1.
  + exact k.
  + assumption.
  + assumption.
  + assumption.
  + assumption.
  + assumption.

- (** base Par_F *)
  unfold FunSoundness, ExpSoundness, SoundFun.
  intros.
  simpl in *.
  specialize (X m env X0 n).
  exact X.

- (** step Par_F *)
  unfold FunSoundness, ExpSoundness, SoundFun, SoundExp.
  intros.
  clear H.
  eapply updateFEnvLemma with (x:= x)
            (v1:= FC fenv tenv e0 e1 x n) (v2:= FT tenv t) in m.
  specialize (X m env X1 n0).
  assumption.
  assumption.

- (** Par_Q - QF *)
  unfold QFunSoundness, FunSoundness, SoundQFun.
  intros.
  destruct ft.
  intros.
  constructor 1 with (x:=f).
  * eapply X.
    exact X1.
  * constructor.

- (** Par_Q - FId *)
  unfold QFunSoundness, Par_SSB, FunSoundness, Par_SSA, SoundQFun.
  intros.
  destruct ft.
  simpl.
  inversion X; subst.
  clear X.
  simpl in *.
  constructor 1 with (x:=f).
  + eapply X4.
    exact X1.
  + clear X2 X3 X4.
    constructor.
    constructor.
    constructor.
    inversion m; subst.
    (* rewrite H0. *)
    eapply ExRelValTNone with (venv:=ls1) in H.
    * eapply override_simpl3 with (env0:=(x,f)::ls3) in H.
      rewrite H0.
      rewrite <- H at 1.
      simpl.
      destruct (IdT.IdEqDec x x).
      {- auto. }
      {- intuition n. }
    (* * apply (FT prs_type ret_type). *)
    * eassumption.
(** Par_E *)
-  (* modify *)
  unfold ExpSoundness, SoundExp.
  intros ftenv tenv fenv T1 T2 VT1 VT2 XF q H H0 env H0' n.
  inversion H; subst.
  destruct v.
  destruct v.
  inversion H1; subst.
  subst T.
  simpl in H2.
  destruct H2.
  constructor 1 with (x:=cst T2 (b_eval _ _ XF n v)).
  + constructor.
    * reflexivity.
    * constructor.
  + inversion H; subst.
    * inversion H1; subst.
      subst T.
      simpl in H2.
      clear H2.
      constructor 1 with (x:=b_exec _ _ XF n v).
      eapply StepIsEClos.
      constructor.
  + inversion X; subst.
    eapply ExTDefNatT with (venv:=env) (T:=T1) in X0.
    * destruct X0 as [v k].
      constructor 1 with (x:= cst T2 (b_eval _ _ XF n v)).
      econstructor.
      {- constructor. }
      {- econstructor. }
      {- constructor 1 with (x:=b_exec _ _ XF n v).
         econstructor.
         econstructor.
         econstructor.
         eassumption.
         eapply StepIsEClos.
         constructor. }
    * assumption.
    * assumption.
    * reflexivity.
- (* return *)
  unfold ExpSoundness, SoundExp.
  intros G ftenv tenv fenv q t H H0 env H0' n.
  inversion H; subst.
  + constructor 1 with (x:=v).
    * assumption.
    * constructor 1 with (x:=n).
      econstructor.
      {- econstructor. }
      {- constructor. }
  + inversion X; subst.
    eapply ExTDefVal with (venv:=env) in X0.
    * destruct X0 as [v k1 k2].
      constructor 1 with (x:=v).
      {- assumption. }
      {- constructor 1 with (x:=n).
         econstructor.
         + constructor.
           constructor.
           eassumption.
         + eapply StepIsEClos.
           constructor.
      }
    * auto.
- (* bindN *)
  unfold ExpSoundness, SoundExp.
  intros ftenv tenv fenv e1 e2 t1 t2.
  intros k1 k2 IH1 IH2.
  intros H0 env H0' n.
  specialize (IH1 H0 env H0' n).
  destruct IH1 as [v0 k3 H2].
  destruct H2 as [n0 H2].
  specialize (IH2 H0 env H0' n0).
  destruct IH2 as [v2 k4 H3].
  destruct H3 as [n2 H3].
  constructor 1 with (x:=v2).
  + auto.
  + constructor 1 with (x:=n2).
    eapply (EClosConcat fenv env).
    * instantiate  (1 := Conf Exp n0 (BindN (Val v0) e2)).
      apply  BindN_extended_congruence.
      assumption.
    * econstructor.
      {- econstructor. }
      {- assumption. }
- (* BindS *)
  unfold ExpSoundness, SoundExp.
  intros ftenv tenv fenv x e1 e2 t1 t2.
  intros k1 k2 IH1 IH2.
  intros H0 env H0' n.
  specialize (IH1 H0 env H0' n).
  destruct IH1 as [v1 k3 H1].
  destruct H1 as [n0 H1].
  specialize (IH2 H0 ((x, v1) :: env)).
  cut (MatchEnvsT ValueTyping ((x, v1) :: env) ((x, t1) :: tenv)).
  + intro.
    specialize (IH2 X n0).
    destruct IH2 as [v2 k4 H2].
    destruct H2 as [n1 H2].
    constructor 1 with (x:=v2).
    * assumption.
    * constructor 1 with (x:=n1).
      eapply EClosConcat.
      {- instantiate (1:= (Conf Exp n0 (BindS x (Val v1) e2))).
         apply BindS_extended_congruence.
         assumption.
      }
      {- eapply EClosConcat.
         + eapply StepIsEClos.
           econstructor.
         + eapply EClosConcat.
           * eapply BindMS_extended_congruence.
             {- reflexivity. }
             {- reflexivity. }
             {- rewrite app_nil_l.
                eassumption.
             }
           * eapply StepIsEClos.
             constructor.
       }
  + apply updateVEnvLemma.
    * assumption.
    * assumption.
- (* BindMS *)
  unfold ExpSoundness, SoundExp.
  intros ftenv ftenvP ftenv' tenv tenvP tenv' fenv fenvP fenv' envP e t.
  intros k1 k2 k3 E1 E2 E3 k4 IH.
  intros H0 env H0' n.
  eapply (overrideVEnvLemma envP env tenvP tenv k1) in H0'.
  eapply (overrideFEnvLemma fenvP fenv ftenvP ftenv k3) in H0.
  cut (FEnvTyping fenv' ftenv').
  + cut (EnvTyping (envP ++ env) tenv').
    * intros H1' H1.
      specialize (IH H1 (envP ++ env) H1' n).
      destruct IH as [v k5 H2].
      destruct H2 as [n1 H2].
      constructor 1 with (x:=v).
      {- auto. }
      {- constructor 1 with (x:=n1).
         eapply (EClosConcat fenv env).
         + eapply BindMS_extended_congruence.
           * reflexivity.
           * reflexivity.
           * rewrite <- E3.
             eassumption.
         + eapply StepIsEClos.
           constructor.
      }
    * rewrite E1.
      assumption.
  + rewrite E2.
    rewrite E3.
    assumption.
- (* Apply *)
  unfold QFunSoundness, PrmsSoundness, ExpSoundness, SoundExp.
  intros ftenv tenv fps fenv q ps pt t.
  intros E1 k1 k2 k3 IH1 IH2.
  intros H0 env H0' n.

  cut (sigT (fun n' : W =>
        (sigT (fun f: Fun =>
          sigT2 (fun es: list Exp => isValueListT es)
             (fun es: list Exp => prod
               (EClosure fenv env (Conf Exp n (Apply q ps))
                         (Conf Exp n' (Apply (QF f) (PS es))))
               (sigT2 (fun v : Value =>
                    sigT (fun n'' : W =>
                       EClosure fenv env
                             (Conf Exp n' (Apply (QF f) (PS es)))
                             (Conf Exp n'' (Val v))))
                    (fun v: Value => ValueTyping v t))))))).

  intros.
  + destruct X as [n1 X].
    destruct X as [f X].
    destruct X as [vls k4 X].
    destruct X as [H1 X].
    destruct X as [v X k5].
    destruct X as [n2 H2].
    constructor 1 with (x:=v).
    * assumption.
    * constructor 1 with (x:=n2).
      eapply EClosConcat.
      {- eassumption. }
      {- eassumption. }
  + inversion E1; subst.
    clear H.
    specialize (IH2 H0 env H0' n).
    unfold SoundPrms in IH2.
    destruct IH2 as [es H2].
    destruct H2 as [vs k6 H2].
    destruct H2 as [k7 H2].
    destruct H2 as [n1 H2].
    specialize (IH1 H0).
    specialize (IH1 (mkVEnv fps vs)).
    eapply matchListsAux02_T with (vs:=vs) in k7.
    * eapply prmsTypingAux_T in k7 as k9.
      {- unfold SoundQFun, SoundFun in IH1.
         unfold SoundExp in IH1.
         specialize (IH1 k9 n1).
         destruct IH1 as [f H3 H1].
         specialize (H1 n).
         constructor 1 with (x:=n1).
         constructor 1 with (x:=f).
         constructor 1 with (x:=es).
         + eapply isValueList2IsValueT.
           eassumption.
         + split.
           * eapply EClosConcat.
             {- instantiate (1:=(Conf Exp n (Apply (QF f) ps))).
                eapply Apply2_extended_congruence.
                assumption. }
             {- eapply Apply1_extended_congruence.
                assumption. }
           * assert (length fps = length vs) as H5.
             {- eapply prmsAux2.
                eassumption. }
             {- inversion k2; subst.
                inversion H1; subst.
                destruct f.
                inversion X; subst.

                specialize (H3 eq_refl).
                destruct H3 as [v k8 HF].
                destruct HF as [n2 HF].
                constructor 1 with (x:=v).
                constructor 1 with (x:=n2).
                econstructor.
                eapply Apply_EStep0.
                eassumption.
                assumption.
                reflexivity.
                eapply EClosConcat.
                eapply BindMS_extended_congruence.
                reflexivity.
                reflexivity.
                eapply (weaken fenv0 fenv (mkVEnv fps vs) env) in HF.
                eassumption.
                apply StepIsEClos.
                constructor.
                assumption.

                specialize (H3 eq_refl).
                destruct H3 as [v k8 HF].
                destruct HF as [n3 HF].
                constructor 1 with (x:=v).
                constructor 1 with (x:=n3).
                econstructor.
                eapply Apply_EStep1.
                eassumption.
                assumption.
                reflexivity.
                eapply EClosConcat.
                eapply BindMS_extended_congruence.
                reflexivity.
                reflexivity.
                eapply (weaken _ fenv _ env) in HF.
                eassumption.
                apply StepIsEClos.
                constructor.
                assumption.

                inversion X0.

                destruct f.
                inversion X; subst.
                assert (findE ls1 x = None).
                eapply ExRelValTNone in H.
                exact H.
                (* exact (FT fps t). *)
                exact X1.
                inversion H1; subst.
                inversion X3; subst.
                eapply override_simpl3 with (env0:=(x,f0)::ls3) in H4.
                inversion X4; subst.
                rewrite <- H4 in H6.
                rewrite find_simpl0 in H6.
                inversion H6; subst.
                inversion X0; subst.

                specialize (H3 eq_refl).
                destruct H3 as [v k8 HF].
                destruct HF as [n3 HF].
                constructor 1 with (x:=v).
                constructor 1 with (x:=n3).
                econstructor.
                eapply Apply_EStep0.
                eassumption.
                assumption.
                reflexivity.
                eapply EClosConcat.
                eapply BindMS_extended_congruence.
                reflexivity.
                reflexivity.

                eapply (weaken fenv0 _ _ env) in HF.
                eassumption.
                apply StepIsEClos.
                constructor.
                assumption.

                specialize (H3 eq_refl).
                destruct H3 as [v k8 HF].
                destruct HF as [n3 HF].
                constructor 1 with (x:=v).
                constructor 1 with (x:=n3).
                econstructor.
                eapply Apply_EStep1.
                eassumption.
                assumption.
                reflexivity.
                eapply EClosConcat.
                eapply BindMS_extended_congruence.
                reflexivity.
                reflexivity.

                eapply (weaken _ (ls1 ++
                     (x, FC fenv0 fps e0 e1 x0 (S n2)) :: ls3) _ env) in HF.
                eassumption.
                apply StepIsEClos.
                constructor.
                assumption.
             }
           }
      {- eapply prmsAux2.
         eassumption. }
    * assumption.

- (* Val *)
  unfold ExpSoundness, SoundExp.
  intros.
  constructor 1 with (x:=v).
  + assumption.
  + constructor 1 with (x:=n).
    constructor.
- (* IFThenElse *)
  unfold ExpSoundness, SoundExp.
  intros.
  specialize (X X2 env X3 n).
  destruct X as [v K X].
  destruct X as [n' X].
  specialize (X0 X2 env X3 n').
  destruct X0 as [v0 K0 X0].
  destruct X0 as [n0 X0].
  specialize (X1 X2 env X3 n').
  destruct X1 as [v1 K1 X1].
  destruct X1 as [n1 X1].
  inversion K; subst.
  subst T.
  destruct v as [T v].
  destruct v.

  unfold Bool in H.
  unfold vtyp in H.
  simpl in H.
  inversion H; subst.

  destruct v.
  + constructor 1 with (x:=v0).
    assumption.
    constructor 1 with (x:=n0).
    eapply EClosConcat.
    instantiate (1:=Conf Exp n'
       (IfThenElse (Val (existT ValueI bool (Cst bool true))) e2 e3)).
    eapply IfThenElse_extended_congruence.
    eassumption.

    econstructor.
    econstructor.

    eassumption.
  + constructor 1 with (x:=v1).
    assumption.
    constructor 1 with (x:=n1).
    eapply EClosConcat.
    eapply IfThenElse_extended_congruence.
    eassumption.
    econstructor.
    econstructor.
    eassumption.
- (** Par_P *)
  unfold Par_SSL, ExpSoundness, PrmsSoundness, SoundExp.
  intros.
  dependent induction X.
  constructor 1 with (x:=nil).
  constructor 1 with (x:=nil).
  constructor.
  simpl.
  auto.
  split.
  constructor.
  constructor.
  constructor 1 with (x:=n).
  constructor.
  (**)
  clear X.
  specialize (p0 X0 env X1 n).
  destruct p0 as [v k1 X2].
  destruct X2 as [n1 H].
  inversion m; subst.
  specialize (IHX X2).
  specialize (IHX X0 env X1 n1).
  destruct IHX as [es IHX].
  destruct IHX as [vs k2 IHX].
  destruct IHX as [k3 IHX].
  destruct IHX as [n2 k4].
  constructor 1 with (x:=(Val v::es)).
  constructor 1 with (x:=v::vs).
  constructor.
  eapply IsValueList2T.
  simpl.
  inversion k2; subst.
  auto.
  split.
  constructor.
  constructor.
  constructor.
  assumption.
  inversion k3; subst.
  assumption.
  constructor 1 with (x:=n2).
  eapply PrmsConcat.
  eapply Pars_extended_congruence2.
  eassumption.
  eapply Pars_extended_congruence1.
  assumption.
Defined.

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

Definition FunTypingSound_rect :=
  FunTyping_str_rect FunSoundness QFunSoundness
                     ExpSoundness PrmsSoundness.

Lemma FunEval :
  forall (f: Fun) (ft: FTyp)
   (k: FunTyping f ft),
   FunSoundness f ft k.

Proof.
eapply FunTypingSound_rect.

- (** base Par_SSL *)
  unfold Par_SSL, ExpSoundness.
  constructor.

- (** step Par_SSL *)
  unfold Par_SSL, ExpSoundness.
  intros.
  constructor.
  + assumption.
  + assumption.
  + assumption.

- (** base Par_SSA *)
  unfold Par_SSA, FunSoundness.
  constructor.

- (** step Par_SSA *)
  unfold Par_SSA, FunSoundness.
  intros.
  constructor.
  + assumption.
  + assumption.
  + assumption.

- (** Par_SSB *)
  unfold Par_SSB, Par_SSA, FunSoundness.
  intros.
  econstructor.

(*  eapply (Forall2BT_split FunTyping _
                         fenv0 fenv1 ftenv0 ftenv1 x f t). *)
  + exact m0.
  + exact m1.
  + exact k.
  + assumption.
  + assumption.
  + assumption.
  + assumption.
  + assumption.

- (** base Par_F *)
  unfold FunSoundness, ExpSoundness, SoundFun.
  intros.
  simpl in *.
  specialize (X m env X0 n).
  exact X.

- (** step Par_F *)
  unfold FunSoundness, ExpSoundness, SoundFun, SoundExp.
  intros.
  clear H.
  eapply updateFEnvLemma with (x:= x)
            (v1:= FC fenv tenv e0 e1 x n) (v2:= FT tenv t) in m.
  specialize (X m env X1 n0).
  assumption.
  assumption.

- (** Par_Q - QF *)
  unfold QFunSoundness, FunSoundness, SoundQFun.
  intros.
  destruct ft.
  intros.
  constructor 1 with (x:=f).
  * eapply X.
    exact X1.
  * constructor.

- (** Par_Q - FId *)
  unfold QFunSoundness, Par_SSB, FunSoundness, Par_SSA, SoundQFun.
  intros.
  destruct ft.
  simpl.
  inversion X; subst.
  clear X.
  simpl in *.
  constructor 1 with (x:=f).
  + eapply X4.
    exact X1.
  + clear X2 X3 X4.
    constructor.
    constructor.
    constructor.
    inversion m; subst.
    (* rewrite H0. *)
    eapply ExRelValTNone with (venv:=ls1) in H.
    * eapply override_simpl3 with (env0:=(x,f)::ls3) in H.
      rewrite H0.
      rewrite <- H at 1.
      simpl.
      destruct (IdT.IdEqDec x x).
      {- auto. }
      {- intuition n. }
    (* apply (FT prs_type ret_type). *)
    * eassumption.
(** Par_E *)
-  (* modify *)
  unfold ExpSoundness, SoundExp.
  intros ftenv tenv fenv T1 T2 VT1 VT2 XF q H H0 env H0' n.
  inversion H; subst.
  destruct v.
  destruct v.
  inversion H1; subst.
  subst T.
  simpl in H2.
  destruct H2.
  constructor 1 with (x:=cst T2 (b_eval _ _ XF n v)).
  + constructor.
    * reflexivity.
    * constructor.
  + inversion H; subst.
    * inversion H1; subst.
      subst T.
      simpl in H2.
      clear H2.
      constructor 1 with (x:=b_exec _ _ XF n v).
      eapply StepIsEClos.
      constructor.
  + inversion X; subst.
    eapply ExTDefNatT with (venv:=env) (T:=T1) in X0.
    * destruct X0 as [v k].
      constructor 1 with (x:= cst T2 (b_eval _ _ XF n v)).
      econstructor.
      {- constructor. }
      {- econstructor. }
      {- constructor 1 with (x:=b_exec _ _ XF n v).
         econstructor.
         econstructor.
         econstructor.
         eassumption.
         eapply StepIsEClos.
         constructor. }
    * assumption.
    * assumption.
    * reflexivity.
- (* return *)
  unfold ExpSoundness, SoundExp.
  intros G ftenv tenv fenv q t H H0 env H0' n.
  inversion H; subst.
  + constructor 1 with (x:=v).
    * assumption.
    * constructor 1 with (x:=n).
      econstructor.
      {- econstructor. }
      {- constructor. }
  + inversion X; subst.
    eapply ExTDefVal with (venv:=env) in X0.
    * destruct X0 as [v k1 k2].
      constructor 1 with (x:=v).
      {- assumption. }
      {- constructor 1 with (x:=n).
         econstructor.
         + constructor.
           constructor.
           eassumption.
         + eapply StepIsEClos.
           constructor.
      }
    * auto.
- (* bindN *)
  unfold ExpSoundness, SoundExp.
  intros ftenv tenv fenv e1 e2 t1 t2.
  intros k1 k2 IH1 IH2.
  intros H0 env H0' n.
  specialize (IH1 H0 env H0' n).
  destruct IH1 as [v0 k3 H2].
  destruct H2 as [n0 H2].
  specialize (IH2 H0 env H0' n0).
  destruct IH2 as [v2 k4 H3].
  destruct H3 as [n2 H3].
  constructor 1 with (x:=v2).
  + auto.
  + constructor 1 with (x:=n2).
    eapply (EClosConcat fenv env).
    * instantiate  (1 := Conf Exp n0 (BindN (Val v0) e2)).
      apply  BindN_extended_congruence.
      assumption.
    * econstructor.
      {- econstructor. }
      {- assumption. }
- (* BindS *)
  unfold ExpSoundness, SoundExp.
  intros ftenv tenv fenv x e1 e2 t1 t2.
  intros k1 k2 IH1 IH2.
  intros H0 env H0' n.
  specialize (IH1 H0 env H0' n).
  destruct IH1 as [v1 k3 H1].
  destruct H1 as [n0 H1].
  specialize (IH2 H0 ((x, v1) :: env)).
  cut (MatchEnvsT ValueTyping ((x, v1) :: env) ((x, t1) :: tenv)).
  + intro.
    specialize (IH2 X n0).
    destruct IH2 as [v2 k4 H2].
    destruct H2 as [n1 H2].
    constructor 1 with (x:=v2).
    * assumption.
    * constructor 1 with (x:=n1).
      eapply EClosConcat.
      {- instantiate (1:= (Conf Exp n0 (BindS x (Val v1) e2))).
         apply BindS_extended_congruence.
         assumption.
      }
      {- eapply EClosConcat.
         + eapply StepIsEClos.
           econstructor.
         + eapply EClosConcat.
           * eapply BindMS_extended_congruence.
             {- reflexivity. }
             {- reflexivity. }
             {- rewrite app_nil_l.
                eassumption.
             }
           * eapply StepIsEClos.
             constructor.
       }
  + apply updateVEnvLemma.
    * assumption.
    * assumption.
- (* BindMS *)
  unfold ExpSoundness, SoundExp.
  intros ftenv ftenvP ftenv' tenv tenvP tenv' fenv fenvP fenv' envP e t.
  intros k1 k2 k3 E1 E2 E3 k4 IH.
  intros H0 env H0' n.
  eapply (overrideVEnvLemma envP env tenvP tenv k1) in H0'.
  eapply (overrideFEnvLemma fenvP fenv ftenvP ftenv k3) in H0.
  cut (FEnvTyping fenv' ftenv').
  + cut (EnvTyping (envP ++ env) tenv').
    * intros H1' H1.
      specialize (IH H1 (envP ++ env) H1' n).
      destruct IH as [v k5 H2].
      destruct H2 as [n1 H2].
      constructor 1 with (x:=v).
      {- auto. }
      {- constructor 1 with (x:=n1).
         eapply (EClosConcat fenv env).
         + eapply BindMS_extended_congruence.
           * reflexivity.
           * reflexivity.
           * rewrite <- E3.
             eassumption.
         + eapply StepIsEClos.
           constructor.
      }
    * rewrite E1.
      assumption.
  + rewrite E2.
    rewrite E3.
    assumption.
- (* Apply *)
  unfold QFunSoundness, PrmsSoundness, ExpSoundness, SoundExp.
  intros ftenv tenv fps fenv q ps pt t.
  intros E1 k1 k2 k3 IH1 IH2.
  intros H0 env H0' n.

  cut (sigT (fun n' : W =>
        (sigT (fun f: Fun =>
          sigT2 (fun es: list Exp => isValueListT es)
             (fun es: list Exp => prod
               (EClosure fenv env (Conf Exp n (Apply q ps))
                         (Conf Exp n' (Apply (QF f) (PS es))))
               (sigT2 (fun v : Value =>
                    sigT (fun n'' : W =>
                       EClosure fenv env
                             (Conf Exp n' (Apply (QF f) (PS es)))
                             (Conf Exp n'' (Val v))))
                    (fun v: Value => ValueTyping v t))))))).

  intros.
  + destruct X as [n1 X].
    destruct X as [f X].
    destruct X as [vls k4 X].
    destruct X as [H1 X].
    destruct X as [v X k5].
    destruct X as [n2 H2].
    constructor 1 with (x:=v).
    * assumption.
    * constructor 1 with (x:=n2).
      eapply EClosConcat.
      {- eassumption. }
      {- eassumption. }
  + inversion E1; subst.
    clear H.
    specialize (IH2 H0 env H0' n).
    unfold SoundPrms in IH2.
    destruct IH2 as [es H2].
    destruct H2 as [vs k6 H2].
    destruct H2 as [k7 H2].
    destruct H2 as [n1 H2].
    specialize (IH1 H0).
    specialize (IH1 (mkVEnv fps vs)).
    eapply matchListsAux02_T with (vs:=vs) in k7.
    * eapply prmsTypingAux_T in k7 as k9.
      {- unfold SoundQFun, SoundFun in IH1.
         unfold SoundExp in IH1.
         specialize (IH1 k9 n1).
         destruct IH1 as [f H3 H1].
         specialize (H1 n).
         constructor 1 with (x:=n1).
         constructor 1 with (x:=f).
         constructor 1 with (x:=es).
         + eapply isValueList2IsValueT.
           eassumption.
         + split.
           * eapply EClosConcat.
             {- instantiate (1:=(Conf Exp n (Apply (QF f) ps))).
                eapply Apply2_extended_congruence.
                assumption. }
             {- eapply Apply1_extended_congruence.
                assumption. }
           * assert (length fps = length vs) as H5.
             {- eapply prmsAux2.
                eassumption. }
             {- inversion k2; subst.
                inversion H1; subst.
                destruct f.
                inversion X; subst.

                specialize (H3 eq_refl).
                destruct H3 as [v k8 HF].
                destruct HF as [n2 HF].
                constructor 1 with (x:=v).
                constructor 1 with (x:=n2).
                econstructor.
                eapply Apply_EStep0.
                eassumption.
                assumption.
                reflexivity.
                eapply EClosConcat.
                eapply BindMS_extended_congruence.
                reflexivity.
                reflexivity.
                eapply (weaken fenv0 fenv (mkVEnv fps vs) env) in HF.
                eassumption.
                apply StepIsEClos.
                constructor.
                assumption.

                specialize (H3 eq_refl).
                destruct H3 as [v k8 HF].
                destruct HF as [n3 HF].
                constructor 1 with (x:=v).
                constructor 1 with (x:=n3).
                econstructor.
                eapply Apply_EStep1.
                eassumption.
                assumption.
                reflexivity.
                eapply EClosConcat.
                eapply BindMS_extended_congruence.
                reflexivity.
                reflexivity.
                eapply (weaken _ fenv _ env) in HF.
                eassumption.
                apply StepIsEClos.
                constructor.
                assumption.

                inversion X0.

                destruct f.
                inversion X; subst.
                assert (findE ls1 x = None).
                eapply ExRelValTNone in H.
                exact H.
                (* exact (FT fps t).*)
                exact X1.
                inversion H1; subst.
                inversion X3; subst.
                eapply override_simpl3 with (env0:=(x,f0)::ls3) in H4.
                inversion X4; subst.
                rewrite <- H4 in H6.
                rewrite find_simpl0 in H6.
                inversion H6; subst.
                inversion X0; subst.

                specialize (H3 eq_refl).
                destruct H3 as [v k8 HF].
                destruct HF as [n3 HF].
                constructor 1 with (x:=v).
                constructor 1 with (x:=n3).
                econstructor.
                eapply Apply_EStep0.
                eassumption.
                assumption.
                reflexivity.
                eapply EClosConcat.
                eapply BindMS_extended_congruence.
                reflexivity.
                reflexivity.

                eapply (weaken fenv0 _ _ env) in HF.
                eassumption.
                apply StepIsEClos.
                constructor.
                assumption.

                specialize (H3 eq_refl).
                destruct H3 as [v k8 HF].
                destruct HF as [n3 HF].
                constructor 1 with (x:=v).
                constructor 1 with (x:=n3).
                econstructor.
                eapply Apply_EStep1.
                eassumption.
                assumption.
                reflexivity.
                eapply EClosConcat.
                eapply BindMS_extended_congruence.
                reflexivity.
                reflexivity.

                eapply (weaken _ (ls1 ++
                     (x, FC fenv0 fps e0 e1 x0 (S n2)) :: ls3) _ env) in HF.
                eassumption.
                apply StepIsEClos.
                constructor.
                assumption.
             }
           }
      {- eapply prmsAux2.
         eassumption. }
    * assumption.

- (* Val *)
  unfold ExpSoundness, SoundExp.
  intros.
  constructor 1 with (x:=v).
  + assumption.
  + constructor 1 with (x:=n).
    constructor.
- (* IFThenElse *)
  unfold ExpSoundness, SoundExp.
  intros.
  specialize (X X2 env X3 n).
  destruct X as [v K X].
  destruct X as [n' X].
  specialize (X0 X2 env X3 n').
  destruct X0 as [v0 K0 X0].
  destruct X0 as [n0 X0].
  specialize (X1 X2 env X3 n').
  destruct X1 as [v1 K1 X1].
  destruct X1 as [n1 X1].
  inversion K; subst.
  subst T.
  destruct v as [T v].
  destruct v.

  unfold Bool in H.
  unfold vtyp in H.
  simpl in H.
  inversion H; subst.

  destruct v.
  + constructor 1 with (x:=v0).
    assumption.
    constructor 1 with (x:=n0).
    eapply EClosConcat.
    instantiate (1:=Conf Exp n'
       (IfThenElse (Val (existT ValueI bool (Cst bool true))) e2 e3)).
    eapply IfThenElse_extended_congruence.
    eassumption.

    econstructor.
    econstructor.

    eassumption.
  + constructor 1 with (x:=v1).
    assumption.
    constructor 1 with (x:=n1).
    eapply EClosConcat.
    eapply IfThenElse_extended_congruence.
    eassumption.
    econstructor.
    econstructor.
    eassumption.
- (** Par_P *)
  unfold Par_SSL, ExpSoundness, PrmsSoundness, SoundExp.
  intros.
  dependent induction X.
  constructor 1 with (x:=nil).
  constructor 1 with (x:=nil).
  constructor.
  simpl.
  auto.
  split.
  constructor.
  constructor.
  constructor 1 with (x:=n).
  constructor.
  (**)
  clear X.
  specialize (p0 X0 env X1 n).
  destruct p0 as [v k1 X2].
  destruct X2 as [n1 H].
  inversion m; subst.
  specialize (IHX X2).
  specialize (IHX X0 env X1 n1).
  destruct IHX as [es IHX].
  destruct IHX as [vs k2 IHX].
  destruct IHX as [k3 IHX].
  destruct IHX as [n2 k4].
  constructor 1 with (x:=(Val v::es)).
  constructor 1 with (x:=v::vs).
  constructor.
  eapply IsValueList2T.
  simpl.
  inversion k2; subst.
  auto.
  split.
  constructor.
  constructor.
  constructor.
  assumption.
  inversion k3; subst.
  assumption.
  constructor 1 with (x:=n2).
  eapply PrmsConcat.
  eapply Pars_extended_congruence2.
  eassumption.
  eapply Pars_extended_congruence1.
  assumption.
Defined.

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

Definition QFunTypingSound_rect :=
  QFunTyping_str_rect FunSoundness QFunSoundness
                     ExpSoundness PrmsSoundness.

Lemma QFunEval :
  forall (ftenv: funTC) (fenv: funEnv)
   (q: QFun) (ft: FTyp)
   (k: QFunTyping ftenv fenv q ft),
   QFunSoundness ftenv fenv q ft k.

Proof.
eapply QFunTypingSound_rect.

- (** base Par_SSL *)
  unfold Par_SSL, ExpSoundness.
  constructor.

- (** step Par_SSL *)
  unfold Par_SSL, ExpSoundness.
  intros.
  constructor.
  + assumption.
  + assumption.
  + assumption.

- (** base Par_SSA *)
  unfold Par_SSA, FunSoundness.
  constructor.

- (** step Par_SSA *)
  unfold Par_SSA, FunSoundness.
  intros.
  constructor.
  + assumption.
  + assumption.
  + assumption.

- (** Par_SSB *)
  unfold Par_SSB, Par_SSA, FunSoundness.
  intros.
  econstructor.

(*  eapply (Forall2BT_split FunTyping _
                         fenv0 fenv1 ftenv0 ftenv1 x f t). *)
  + exact m0.
  + exact m1.
  + exact k.
  + assumption.
  + assumption.
  + assumption.
  + assumption.
  + assumption.

- (** base Par_F *)
  unfold FunSoundness, ExpSoundness, SoundFun.
  intros.
  simpl in *.
  specialize (X m env X0 n).
  exact X.

- (** step Par_F *)
  unfold FunSoundness, ExpSoundness, SoundFun, SoundExp.
  intros.
  clear H.
  eapply updateFEnvLemma with (x:= x)
            (v1:= FC fenv tenv e0 e1 x n) (v2:= FT tenv t) in m.
  specialize (X m env X1 n0).
  assumption.
  assumption.

- (** Par_Q - QF *)
  unfold QFunSoundness, FunSoundness, SoundQFun.
  intros.
  destruct ft.
  intros.
  constructor 1 with (x:=f).
  * eapply X.
    exact X1.
  * constructor.

- (** Par_Q - FId *)
  unfold QFunSoundness, Par_SSB, FunSoundness, Par_SSA, SoundQFun.
  intros.
  destruct ft.
  simpl.
  inversion X; subst.
  clear X.
  simpl in *.
  constructor 1 with (x:=f).
  + eapply X4.
    exact X1.
  + clear X2 X3 X4.
    constructor.
    constructor.
    constructor.
    inversion m; subst.
    (* rewrite H0. *)
    eapply ExRelValTNone with (venv:=ls1) in H.
    * eapply override_simpl3 with (env0:=(x,f)::ls3) in H.
      rewrite H0.
      rewrite <- H at 1.
      simpl.
      destruct (IdT.IdEqDec x x).
      {- auto. }
      {- intuition n. }
    (* apply (FT prs_type ret_type). *)
    * eassumption.
(** Par_E *)
-  (* modify *)
  unfold ExpSoundness, SoundExp.
  intros ftenv tenv fenv T1 T2 VT1 VT2 XF q H H0 env H0' n.
  inversion H; subst.
  destruct v.
  destruct v.
  inversion H1; subst.
  subst T.
  simpl in H2.
  destruct H2.
  constructor 1 with (x:=cst T2 (b_eval _ _ XF n v)).
  + constructor.
    * reflexivity.
    * constructor.
  + inversion H; subst.
    * inversion H1; subst.
      subst T.
      simpl in H2.
      clear H2.
      constructor 1 with (x:=b_exec _ _ XF n v).
      eapply StepIsEClos.
      constructor.
  + inversion X; subst.
    eapply ExTDefNatT with (venv:=env) (T:=T1) in X0.
    * destruct X0 as [v k].
      constructor 1 with (x:= cst T2 (b_eval _ _ XF n v)).
      econstructor.
      {- constructor. }
      {- econstructor. }
      {- constructor 1 with (x:=b_exec _ _ XF n v).
         econstructor.
         econstructor.
         econstructor.
         eassumption.
         eapply StepIsEClos.
         constructor. }
    * assumption.
    * assumption.
    * reflexivity.
- (* return *)
  unfold ExpSoundness, SoundExp.
  intros G ftenv tenv fenv q t H H0 env H0' n.
  inversion H; subst.
  + constructor 1 with (x:=v).
    * assumption.
    * constructor 1 with (x:=n).
      econstructor.
      {- econstructor. }
      {- constructor. }
  + inversion X; subst.
    eapply ExTDefVal with (venv:=env) in X0.
    * destruct X0 as [v k1 k2].
      constructor 1 with (x:=v).
      {- assumption. }
      {- constructor 1 with (x:=n).
         econstructor.
         + constructor.
           constructor.
           eassumption.
         + eapply StepIsEClos.
           constructor.
      }
    * auto.
- (* bindN *)
  unfold ExpSoundness, SoundExp.
  intros ftenv tenv fenv e1 e2 t1 t2.
  intros k1 k2 IH1 IH2.
  intros H0 env H0' n.
  specialize (IH1 H0 env H0' n).
  destruct IH1 as [v0 k3 H2].
  destruct H2 as [n0 H2].
  specialize (IH2 H0 env H0' n0).
  destruct IH2 as [v2 k4 H3].
  destruct H3 as [n2 H3].
  constructor 1 with (x:=v2).
  + auto.
  + constructor 1 with (x:=n2).
    eapply (EClosConcat fenv env).
    * instantiate  (1 := Conf Exp n0 (BindN (Val v0) e2)).
      apply  BindN_extended_congruence.
      assumption.
    * econstructor.
      {- econstructor. }
      {- assumption. }
- (* BindS *)
  unfold ExpSoundness, SoundExp.
  intros ftenv tenv fenv x e1 e2 t1 t2.
  intros k1 k2 IH1 IH2.
  intros H0 env H0' n.
  specialize (IH1 H0 env H0' n).
  destruct IH1 as [v1 k3 H1].
  destruct H1 as [n0 H1].
  specialize (IH2 H0 ((x, v1) :: env)).
  cut (MatchEnvsT ValueTyping ((x, v1) :: env) ((x, t1) :: tenv)).
  + intro.
    specialize (IH2 X n0).
    destruct IH2 as [v2 k4 H2].
    destruct H2 as [n1 H2].
    constructor 1 with (x:=v2).
    * assumption.
    * constructor 1 with (x:=n1).
      eapply EClosConcat.
      {- instantiate (1:= (Conf Exp n0 (BindS x (Val v1) e2))).
         apply BindS_extended_congruence.
         assumption.
      }
      {- eapply EClosConcat.
         + eapply StepIsEClos.
           econstructor.
         + eapply EClosConcat.
           * eapply BindMS_extended_congruence.
             {- reflexivity. }
             {- reflexivity. }
             {- rewrite app_nil_l.
                eassumption.
             }
           * eapply StepIsEClos.
             constructor.
       }
  + apply updateVEnvLemma.
    * assumption.
    * assumption.
- (* BindMS *)
  unfold ExpSoundness, SoundExp.
  intros ftenv ftenvP ftenv' tenv tenvP tenv' fenv fenvP fenv' envP e t.
  intros k1 k2 k3 E1 E2 E3 k4 IH.
  intros H0 env H0' n.
  eapply (overrideVEnvLemma envP env tenvP tenv k1) in H0'.
  eapply (overrideFEnvLemma fenvP fenv ftenvP ftenv k3) in H0.
  cut (FEnvTyping fenv' ftenv').
  + cut (EnvTyping (envP ++ env) tenv').
    * intros H1' H1.
      specialize (IH H1 (envP ++ env) H1' n).
      destruct IH as [v k5 H2].
      destruct H2 as [n1 H2].
      constructor 1 with (x:=v).
      {- auto. }
      {- constructor 1 with (x:=n1).
         eapply (EClosConcat fenv env).
         + eapply BindMS_extended_congruence.
           * reflexivity.
           * reflexivity.
           * rewrite <- E3.
             eassumption.
         + eapply StepIsEClos.
           constructor.
      }
    * rewrite E1.
      assumption.
  + rewrite E2.
    rewrite E3.
    assumption.
- (* Apply *)
  unfold QFunSoundness, PrmsSoundness, ExpSoundness, SoundExp.
  intros ftenv tenv fps fenv q ps pt t.
  intros E1 k1 k2 k3 IH1 IH2.
  intros H0 env H0' n.

  cut (sigT (fun n' : W =>
        (sigT (fun f: Fun =>
          sigT2 (fun es: list Exp => isValueListT es)
             (fun es: list Exp => prod
               (EClosure fenv env (Conf Exp n (Apply q ps))
                         (Conf Exp n' (Apply (QF f) (PS es))))
               (sigT2 (fun v : Value =>
                    sigT (fun n'' : W =>
                       EClosure fenv env
                             (Conf Exp n' (Apply (QF f) (PS es)))
                             (Conf Exp n'' (Val v))))
                    (fun v: Value => ValueTyping v t))))))).

  intros.
  + destruct X as [n1 X].
    destruct X as [f X].
    destruct X as [vls k4 X].
    destruct X as [H1 X].
    destruct X as [v X k5].
    destruct X as [n2 H2].
    constructor 1 with (x:=v).
    * assumption.
    * constructor 1 with (x:=n2).
      eapply EClosConcat.
      {- eassumption. }
      {- eassumption. }
  + inversion E1; subst.
    clear H.
    specialize (IH2 H0 env H0' n).
    unfold SoundPrms in IH2.
    destruct IH2 as [es H2].
    destruct H2 as [vs k6 H2].
    destruct H2 as [k7 H2].
    destruct H2 as [n1 H2].
    specialize (IH1 H0).
    specialize (IH1 (mkVEnv fps vs)).
    eapply matchListsAux02_T with (vs:=vs) in k7.
    * eapply prmsTypingAux_T in k7 as k9.
      {- unfold SoundQFun, SoundFun in IH1.
         unfold SoundExp in IH1.
         specialize (IH1 k9 n1).
         destruct IH1 as [f H3 H1].
         specialize (H1 n).
         constructor 1 with (x:=n1).
         constructor 1 with (x:=f).
         constructor 1 with (x:=es).
         + eapply isValueList2IsValueT.
           eassumption.
         + split.
           * eapply EClosConcat.
             {- instantiate (1:=(Conf Exp n (Apply (QF f) ps))).
                eapply Apply2_extended_congruence.
                assumption. }
             {- eapply Apply1_extended_congruence.
                assumption. }
           * assert (length fps = length vs) as H5.
             {- eapply prmsAux2.
                eassumption. }
             {- inversion k2; subst.
                inversion H1; subst.
                destruct f.
                inversion X; subst.

                specialize (H3 eq_refl).
                destruct H3 as [v k8 HF].
                destruct HF as [n2 HF].
                constructor 1 with (x:=v).
                constructor 1 with (x:=n2).
                econstructor.
                eapply Apply_EStep0.
                eassumption.
                assumption.
                reflexivity.
                eapply EClosConcat.
                eapply BindMS_extended_congruence.
                reflexivity.
                reflexivity.
                eapply (weaken fenv0 fenv (mkVEnv fps vs) env) in HF.
                eassumption.
                apply StepIsEClos.
                constructor.
                assumption.

                specialize (H3 eq_refl).
                destruct H3 as [v k8 HF].
                destruct HF as [n3 HF].
                constructor 1 with (x:=v).
                constructor 1 with (x:=n3).
                econstructor.
                eapply Apply_EStep1.
                eassumption.
                assumption.
                reflexivity.
                eapply EClosConcat.
                eapply BindMS_extended_congruence.
                reflexivity.
                reflexivity.
                eapply (weaken _ fenv _ env) in HF.
                eassumption.
                apply StepIsEClos.
                constructor.
                assumption.

                inversion X0.

                destruct f.
                inversion X; subst.
                assert (findE ls1 x = None).
                eapply ExRelValTNone in H.
                exact H.
                (* exact (FT fps t). *)
                exact X1.
                inversion H1; subst.
                inversion X3; subst.
                eapply override_simpl3 with (env0:=(x,f0)::ls3) in H4.
                inversion X4; subst.
                rewrite <- H4 in H6.
                rewrite find_simpl0 in H6.
                inversion H6; subst.
                inversion X0; subst.

                specialize (H3 eq_refl).
                destruct H3 as [v k8 HF].
                destruct HF as [n3 HF].
                constructor 1 with (x:=v).
                constructor 1 with (x:=n3).
                econstructor.
                eapply Apply_EStep0.
                eassumption.
                assumption.
                reflexivity.
                eapply EClosConcat.
                eapply BindMS_extended_congruence.
                reflexivity.
                reflexivity.

                eapply (weaken fenv0 _ _ env) in HF.
                eassumption.
                apply StepIsEClos.
                constructor.
                assumption.

                specialize (H3 eq_refl).
                destruct H3 as [v k8 HF].
                destruct HF as [n3 HF].
                constructor 1 with (x:=v).
                constructor 1 with (x:=n3).
                econstructor.
                eapply Apply_EStep1.
                eassumption.
                assumption.
                reflexivity.
                eapply EClosConcat.
                eapply BindMS_extended_congruence.
                reflexivity.
                reflexivity.

                eapply (weaken _ (ls1 ++
                     (x, FC fenv0 fps e0 e1 x0 (S n2)) :: ls3) _ env) in HF.
                eassumption.
                apply StepIsEClos.
                constructor.
                assumption.
             }
           }
      {- eapply prmsAux2.
         eassumption. }
    * assumption.

- (* Val *)
  unfold ExpSoundness, SoundExp.
  intros.
  constructor 1 with (x:=v).
  + assumption.
  + constructor 1 with (x:=n).
    constructor.
- (* IFThenElse *)
  unfold ExpSoundness, SoundExp.
  intros.
  specialize (X X2 env X3 n).
  destruct X as [v K X].
  destruct X as [n' X].
  specialize (X0 X2 env X3 n').
  destruct X0 as [v0 K0 X0].
  destruct X0 as [n0 X0].
  specialize (X1 X2 env X3 n').
  destruct X1 as [v1 K1 X1].
  destruct X1 as [n1 X1].
  inversion K; subst.
  subst T.
  destruct v as [T v].
  destruct v.

  unfold Bool in H.
  unfold vtyp in H.
  simpl in H.
  inversion H; subst.

  destruct v.
  + constructor 1 with (x:=v0).
    assumption.
    constructor 1 with (x:=n0).
    eapply EClosConcat.
    instantiate (1:=Conf Exp n'
       (IfThenElse (Val (existT ValueI bool (Cst bool true))) e2 e3)).
    eapply IfThenElse_extended_congruence.
    eassumption.

    econstructor.
    econstructor.

    eassumption.
  + constructor 1 with (x:=v1).
    assumption.
    constructor 1 with (x:=n1).
    eapply EClosConcat.
    eapply IfThenElse_extended_congruence.
    eassumption.
    econstructor.
    econstructor.
    eassumption.
- (** Par_P *)
  unfold Par_SSL, ExpSoundness, PrmsSoundness, SoundExp.
  intros.
  dependent induction X.
  constructor 1 with (x:=nil).
  constructor 1 with (x:=nil).
  constructor.
  simpl.
  auto.
  split.
  constructor.
  constructor.
  constructor 1 with (x:=n).
  constructor.
  (**)
  clear X.
  specialize (p0 X0 env X1 n).
  destruct p0 as [v k1 X2].
  destruct X2 as [n1 H].
  inversion m; subst.
  specialize (IHX X2).
  specialize (IHX X0 env X1 n1).
  destruct IHX as [es IHX].
  destruct IHX as [vs k2 IHX].
  destruct IHX as [k3 IHX].
  destruct IHX as [n2 k4].
  constructor 1 with (x:=(Val v::es)).
  constructor 1 with (x:=v::vs).
  constructor.
  eapply IsValueList2T.
  simpl.
  inversion k2; subst.
  auto.
  split.
  constructor.
  constructor.
  constructor.
  assumption.
  inversion k3; subst.
  assumption.
  constructor 1 with (x:=n2).
  eapply PrmsConcat.
  eapply Pars_extended_congruence2.
  eassumption.
  eapply Pars_extended_congruence1.
  assumption.
Defined.

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

Definition PrmsTypingSound_rect :=
  PrmsTyping_str_rect FunSoundness QFunSoundness
                     ExpSoundness PrmsSoundness.

Lemma PrmsEval :
  forall (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
   (ps: Prms) (pt: PTyp)
   (k: PrmsTyping ftenv tenv fenv ps pt),
   PrmsSoundness ftenv tenv fenv ps pt k.

Proof.
eapply PrmsTypingSound_rect.

- (** base Par_SSL *)
  unfold Par_SSL, ExpSoundness.
  constructor.

- (** step Par_SSL *)
  unfold Par_SSL, ExpSoundness.
  intros.
  constructor.
  + assumption.
  + assumption.
  + assumption.

- (** base Par_SSA *)
  unfold Par_SSA, FunSoundness.
  constructor.

- (** step Par_SSA *)
  unfold Par_SSA, FunSoundness.
  intros.
  constructor.
  + assumption.
  + assumption.
  + assumption.

- (** Par_SSB *)
  unfold Par_SSB, Par_SSA, FunSoundness.
  intros.
  econstructor.

(*  eapply (Forall2BT_split FunTyping _
                         fenv0 fenv1 ftenv0 ftenv1 x f t). *)
  + exact m0.
  + exact m1.
  + exact k.
  + assumption.
  + assumption.
  + assumption.
  + assumption.
  + assumption.

- (** base Par_F *)
  unfold FunSoundness, ExpSoundness, SoundFun.
  intros.
  simpl in *.
  specialize (X m env X0 n).
  exact X.

- (** step Par_F *)
  unfold FunSoundness, ExpSoundness, SoundFun, SoundExp.
  intros.
  clear H.
  eapply updateFEnvLemma with (x:= x)
            (v1:= FC fenv tenv e0 e1 x n) (v2:= FT tenv t) in m.
  specialize (X m env X1 n0).
  assumption.
  assumption.

- (** Par_Q - QF *)
  unfold QFunSoundness, FunSoundness, SoundQFun.
  intros.
  destruct ft.
  intros.
  constructor 1 with (x:=f).
  * eapply X.
    exact X1.
  * constructor.

- (** Par_Q - FId *)
  unfold QFunSoundness, Par_SSB, FunSoundness, Par_SSA, SoundQFun.
  intros.
  destruct ft.
  simpl.
  inversion X; subst.
  clear X.
  simpl in *.
  constructor 1 with (x:=f).
  + eapply X4.
    exact X1.
  + clear X2 X3 X4.
    constructor.
    constructor.
    constructor.
    inversion m; subst.
    (* rewrite H0. *)
    eapply ExRelValTNone with (venv:=ls1) in H.
    * eapply override_simpl3 with (env0:=(x,f)::ls3) in H.
      rewrite H0.
      rewrite <- H at 1.
      simpl.
      destruct (IdT.IdEqDec x x).
      {- auto. }
      {- intuition n. }
    (* apply (FT prs_type ret_type). *)
    * eassumption.
(** Par_E *)
-  (* modify *)
  unfold ExpSoundness, SoundExp.
  intros ftenv tenv fenv T1 T2 VT1 VT2 XF q H H0 env H0' n.
  inversion H; subst.
  destruct v.
  destruct v.
  inversion H1; subst.
  subst T.
  simpl in H2.
  destruct H2.
  constructor 1 with (x:=cst T2 (b_eval _ _ XF n v)).
  + constructor.
    * reflexivity.
    * constructor.
  + inversion H; subst.
    * inversion H1; subst.
      subst T.
      simpl in H2.
      clear H2.
      constructor 1 with (x:=b_exec _ _ XF n v).
      eapply StepIsEClos.
      constructor.
  + inversion X; subst.
    eapply ExTDefNatT with (venv:=env) (T:=T1) in X0.
    * destruct X0 as [v k].
      constructor 1 with (x:= cst T2 (b_eval _ _ XF n v)).
      econstructor.
      {- constructor. }
      {- econstructor. }
      {- constructor 1 with (x:=b_exec _ _ XF n v).
         econstructor.
         econstructor.
         econstructor.
         eassumption.
         eapply StepIsEClos.
         constructor. }
    * assumption.
    * assumption.
    * reflexivity.
- (* return *)
  unfold ExpSoundness, SoundExp.
  intros G ftenv tenv fenv q t H H0 env H0' n.
  inversion H; subst.
  + constructor 1 with (x:=v).
    * assumption.
    * constructor 1 with (x:=n).
      econstructor.
      {- econstructor. }
      {- constructor. }
  + inversion X; subst.
    eapply ExTDefVal with (venv:=env) in X0.
    * destruct X0 as [v k1 k2].
      constructor 1 with (x:=v).
      {- assumption. }
      {- constructor 1 with (x:=n).
         econstructor.
         + constructor.
           constructor.
           eassumption.
         + eapply StepIsEClos.
           constructor.
      }
    * auto.
- (* bindN *)
  unfold ExpSoundness, SoundExp.
  intros ftenv tenv fenv e1 e2 t1 t2.
  intros k1 k2 IH1 IH2.
  intros H0 env H0' n.
  specialize (IH1 H0 env H0' n).
  destruct IH1 as [v0 k3 H2].
  destruct H2 as [n0 H2].
  specialize (IH2 H0 env H0' n0).
  destruct IH2 as [v2 k4 H3].
  destruct H3 as [n2 H3].
  constructor 1 with (x:=v2).
  + auto.
  + constructor 1 with (x:=n2).
    eapply (EClosConcat fenv env).
    * instantiate  (1 := Conf Exp n0 (BindN (Val v0) e2)).
      apply  BindN_extended_congruence.
      assumption.
    * econstructor.
      {- econstructor. }
      {- assumption. }
- (* BindS *)
  unfold ExpSoundness, SoundExp.
  intros ftenv tenv fenv x e1 e2 t1 t2.
  intros k1 k2 IH1 IH2.
  intros H0 env H0' n.
  specialize (IH1 H0 env H0' n).
  destruct IH1 as [v1 k3 H1].
  destruct H1 as [n0 H1].
  specialize (IH2 H0 ((x, v1) :: env)).
  cut (MatchEnvsT ValueTyping ((x, v1) :: env) ((x, t1) :: tenv)).
  + intro.
    specialize (IH2 X n0).
    destruct IH2 as [v2 k4 H2].
    destruct H2 as [n1 H2].
    constructor 1 with (x:=v2).
    * assumption.
    * constructor 1 with (x:=n1).
      eapply EClosConcat.
      {- instantiate (1:= (Conf Exp n0 (BindS x (Val v1) e2))).
         apply BindS_extended_congruence.
         assumption.
      }
      {- eapply EClosConcat.
         + eapply StepIsEClos.
           econstructor.
         + eapply EClosConcat.
           * eapply BindMS_extended_congruence.
             {- reflexivity. }
             {- reflexivity. }
             {- rewrite app_nil_l.
                eassumption.
             }
           * eapply StepIsEClos.
             constructor.
       }
  + apply updateVEnvLemma.
    * assumption.
    * assumption.
- (* BindMS *)
  unfold ExpSoundness, SoundExp.
  intros ftenv ftenvP ftenv' tenv tenvP tenv' fenv fenvP fenv' envP e t.
  intros k1 k2 k3 E1 E2 E3 k4 IH.
  intros H0 env H0' n.
  eapply (overrideVEnvLemma envP env tenvP tenv k1) in H0'.
  eapply (overrideFEnvLemma fenvP fenv ftenvP ftenv k3) in H0.
  cut (FEnvTyping fenv' ftenv').
  + cut (EnvTyping (envP ++ env) tenv').
    * intros H1' H1.
      specialize (IH H1 (envP ++ env) H1' n).
      destruct IH as [v k5 H2].
      destruct H2 as [n1 H2].
      constructor 1 with (x:=v).
      {- auto. }
      {- constructor 1 with (x:=n1).
         eapply (EClosConcat fenv env).
         + eapply BindMS_extended_congruence.
           * reflexivity.
           * reflexivity.
           * rewrite <- E3.
             eassumption.
         + eapply StepIsEClos.
           constructor.
      }
    * rewrite E1.
      assumption.
  + rewrite E2.
    rewrite E3.
    assumption.
- (* Apply *)
  unfold QFunSoundness, PrmsSoundness, ExpSoundness, SoundExp.
  intros ftenv tenv fps fenv q ps pt t.
  intros E1 k1 k2 k3 IH1 IH2.
  intros H0 env H0' n.

  cut (sigT (fun n' : W =>
        (sigT (fun f: Fun =>
          sigT2 (fun es: list Exp => isValueListT es)
             (fun es: list Exp => prod
               (EClosure fenv env (Conf Exp n (Apply q ps))
                         (Conf Exp n' (Apply (QF f) (PS es))))
               (sigT2 (fun v : Value =>
                    sigT (fun n'' : W =>
                       EClosure fenv env
                             (Conf Exp n' (Apply (QF f) (PS es)))
                             (Conf Exp n'' (Val v))))
                    (fun v: Value => ValueTyping v t))))))).

  intros.
  + destruct X as [n1 X].
    destruct X as [f X].
    destruct X as [vls k4 X].
    destruct X as [H1 X].
    destruct X as [v X k5].
    destruct X as [n2 H2].
    constructor 1 with (x:=v).
    * assumption.
    * constructor 1 with (x:=n2).
      eapply EClosConcat.
      {- eassumption. }
      {- eassumption. }
  + inversion E1; subst.
    clear H.
    specialize (IH2 H0 env H0' n).
    unfold SoundPrms in IH2.
    destruct IH2 as [es H2].
    destruct H2 as [vs k6 H2].
    destruct H2 as [k7 H2].
    destruct H2 as [n1 H2].
    specialize (IH1 H0).
    specialize (IH1 (mkVEnv fps vs)).
    eapply matchListsAux02_T with (vs:=vs) in k7.
    * eapply prmsTypingAux_T in k7 as k9.
      {- unfold SoundQFun, SoundFun in IH1.
         unfold SoundExp in IH1.
         specialize (IH1 k9 n1).
         destruct IH1 as [f H3 H1].
         specialize (H1 n).
         constructor 1 with (x:=n1).
         constructor 1 with (x:=f).
         constructor 1 with (x:=es).
         + eapply isValueList2IsValueT.
           eassumption.
         + split.
           * eapply EClosConcat.
             {- instantiate (1:=(Conf Exp n (Apply (QF f) ps))).
                eapply Apply2_extended_congruence.
                assumption. }
             {- eapply Apply1_extended_congruence.
                assumption. }
           * assert (length fps = length vs) as H5.
             {- eapply prmsAux2.
                eassumption. }
             {- inversion k2; subst.
                inversion H1; subst.
                destruct f.
                inversion X; subst.

                specialize (H3 eq_refl).
                destruct H3 as [v k8 HF].
                destruct HF as [n2 HF].
                constructor 1 with (x:=v).
                constructor 1 with (x:=n2).
                econstructor.
                eapply Apply_EStep0.
                eassumption.
                assumption.
                reflexivity.
                eapply EClosConcat.
                eapply BindMS_extended_congruence.
                reflexivity.
                reflexivity.
                eapply (weaken fenv0 fenv (mkVEnv fps vs) env) in HF.
                eassumption.
                apply StepIsEClos.
                constructor.
                assumption.

                specialize (H3 eq_refl).
                destruct H3 as [v k8 HF].
                destruct HF as [n3 HF].
                constructor 1 with (x:=v).
                constructor 1 with (x:=n3).
                econstructor.
                eapply Apply_EStep1.
                eassumption.
                assumption.
                reflexivity.
                eapply EClosConcat.
                eapply BindMS_extended_congruence.
                reflexivity.
                reflexivity.
                eapply (weaken _ fenv _ env) in HF.
                eassumption.
                apply StepIsEClos.
                constructor.
                assumption.

                inversion X0.

                destruct f.
                inversion X; subst.
                assert (findE ls1 x = None).
                eapply ExRelValTNone in H.
                exact H.
                (* exact (FT fps t).*)
                exact X1.
                inversion H1; subst.
                inversion X3; subst.
                eapply override_simpl3 with (env0:=(x,f0)::ls3) in H4.
                inversion X4; subst.
                rewrite <- H4 in H6.
                rewrite find_simpl0 in H6.
                inversion H6; subst.
                inversion X0; subst.

                specialize (H3 eq_refl).
                destruct H3 as [v k8 HF].
                destruct HF as [n3 HF].
                constructor 1 with (x:=v).
                constructor 1 with (x:=n3).
                econstructor.
                eapply Apply_EStep0.
                eassumption.
                assumption.
                reflexivity.
                eapply EClosConcat.
                eapply BindMS_extended_congruence.
                reflexivity.
                reflexivity.

                eapply (weaken fenv0 _ _ env) in HF.
                eassumption.
                apply StepIsEClos.
                constructor.
                assumption.

                specialize (H3 eq_refl).
                destruct H3 as [v k8 HF].
                destruct HF as [n3 HF].
                constructor 1 with (x:=v).
                constructor 1 with (x:=n3).
                econstructor.
                eapply Apply_EStep1.
                eassumption.
                assumption.
                reflexivity.
                eapply EClosConcat.
                eapply BindMS_extended_congruence.
                reflexivity.
                reflexivity.

                eapply (weaken _ (ls1 ++
                     (x, FC fenv0 fps e0 e1 x0 (S n2)) :: ls3) _ env) in HF.
                eassumption.
                apply StepIsEClos.
                constructor.
                assumption.
             }
           }
      {- eapply prmsAux2.
         eassumption. }
    * assumption.

- (* Val *)
  unfold ExpSoundness, SoundExp.
  intros.
  constructor 1 with (x:=v).
  + assumption.
  + constructor 1 with (x:=n).
    constructor.
- (* IFThenElse *)
  unfold ExpSoundness, SoundExp.
  intros.
  specialize (X X2 env X3 n).
  destruct X as [v K X].
  destruct X as [n' X].
  specialize (X0 X2 env X3 n').
  destruct X0 as [v0 K0 X0].
  destruct X0 as [n0 X0].
  specialize (X1 X2 env X3 n').
  destruct X1 as [v1 K1 X1].
  destruct X1 as [n1 X1].
  inversion K; subst.
  subst T.
  destruct v as [T v].
  destruct v.

  unfold Bool in H.
  unfold vtyp in H.
  simpl in H.
  inversion H; subst.

  destruct v.
  + constructor 1 with (x:=v0).
    assumption.
    constructor 1 with (x:=n0).
    eapply EClosConcat.
    instantiate (1:=Conf Exp n'
       (IfThenElse (Val (existT ValueI bool (Cst bool true))) e2 e3)).
    eapply IfThenElse_extended_congruence.
    eassumption.

    econstructor.
    econstructor.

    eassumption.
  + constructor 1 with (x:=v1).
    assumption.
    constructor 1 with (x:=n1).
    eapply EClosConcat.
    eapply IfThenElse_extended_congruence.
    eassumption.
    econstructor.
    econstructor.
    eassumption.
- (** Par_P *)
  unfold Par_SSL, ExpSoundness, PrmsSoundness, SoundExp.
  intros.
  dependent induction X.
  constructor 1 with (x:=nil).
  constructor 1 with (x:=nil).
  constructor.
  simpl.
  auto.
  split.
  constructor.
  constructor.
  constructor 1 with (x:=n).
  constructor.
  (**)
  clear X.
  specialize (p0 X0 env X1 n).
  destruct p0 as [v k1 X2].
  destruct X2 as [n1 H].
  inversion m; subst.
  specialize (IHX X2).
  specialize (IHX X0 env X1 n1).
  destruct IHX as [es IHX].
  destruct IHX as [vs k2 IHX].
  destruct IHX as [k3 IHX].
  destruct IHX as [n2 k4].
  constructor 1 with (x:=(Val v::es)).
  constructor 1 with (x:=v::vs).
  constructor.
  eapply IsValueList2T.
  simpl.
  inversion k2; subst.
  auto.
  split.
  constructor.
  constructor.
  constructor.
  assumption.
  inversion k3; subst.
  assumption.
  constructor 1 with (x:=n2).
  eapply PrmsConcat.
  eapply Pars_extended_congruence2.
  eassumption.
  eapply Pars_extended_congruence1.
  assumption.
Defined.

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

(** not used *)

Definition SoundExpT (fenv: funEnv) (env: valEnv)
                   (e: Exp) (t: VTyp) (n: W)
                   (k: SoundExp fenv env e t n) : SoundExp fenv env e t n := k.

Definition SoundPrmsT (fenv: funEnv) (env: valEnv)
                   (ps: Prms) (pt: PTyp) (n: W)
                   (k: SoundPrms fenv env ps pt n) :
  SoundPrms fenv env ps pt n := k.

Definition SoundFunT (f: Fun) (ft: FTyp) (n: W)
        (k0: FunTyping f ft)
        (env: valEnv)
        (k: SoundFun env (extParType ft) f (extRetType ft) n) :
                    SoundFun env (extParType ft) f (extRetType ft) n := k.

Definition SoundQFunT (ftenv: funTC) (fenv: funEnv)
         (q: QFun) (ft: FTyp) (n: W)
         (k0: QFunTyping ftenv fenv q ft)
         (env: valEnv)
         (k: SoundQFun fenv env (extParType ft) q (extRetType ft) n) :
  SoundQFun fenv env (extParType ft) q (extRetType ft) n := k.

(***)

Definition FunSoundnessO :=
     fun (f: Fun) (ft: FTyp)
         (k: FunTyping f ft) =>
   match ft with FT tenv t =>
      forall env: valEnv,
      MatchEnvsT ValueTyping env tenv ->
      forall n: W, SoundFun env tenv f t n
   end.

Definition QFunSoundnessO :=
     fun (ftenv: funTC) (fenv: funEnv)
         (q: QFun) (ft: FTyp)
         (k: QFunTyping ftenv fenv q ft) =>
   match ft with FT tenv t =>
      MatchEnvsT FunTyping fenv ftenv ->
      forall env: valEnv,
      MatchEnvsT ValueTyping env tenv ->
      forall n: W, SoundQFun fenv env tenv q t n
   end.

End TSoundness.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e256m2e224p2e192p2e96m1_6limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Set Warnings "-notation-overridden,-parsing".
From mathcomp Require Import ssreflect ssrbool eqtype div ssralg.
From Tweetnacl.High Require Import mc.
From Tweetnacl.High Require Import mcgroup.
From Tweetnacl.High Require Import montgomery.
From Tweetnacl.High Require Import twist25519_Fp.
From Tweetnacl.High Require Import opt_ladder.
From Tweetnacl.High Require Import Zmodp2.
From Tweetnacl.High Require Import Zmodp2_rules.
From Tweetnacl.High Require Import curve25519_Fp2.
From Tweetnacl.High Require Import curve25519_Fp_twist25519_Fp_eq.
From Tweetnacl.High Require Import Zmodp.
From Tweetnacl.High Require Import GRing_tools.
Require Import Ring.
Require Import ZArith.

Import BinInt.

Open Scope ring_scope.
Import GRing.Theory.

Local Notation "p '#x0'" := (point_x0 p) (at level 30).

(* Conversion between twist25519 over F_p and F_p2 *)
Definition twist_Fp_to_Fp2 (p: point Zmodp.type) : (point Zmodp2.type) :=
match p with
  | EC_Inf => EC_Inf Zmodp2.type
  | EC_In x y => EC_In (Zmodp2.Zmodp2 x 0) (Zmodp2.Zmodp2 0 y)
end.

Lemma ontwist25519_Fp_impl : forall (x y: Zmodp.type),
oncurve twist25519_Fp_mcuType (EC_In x y) ->
(oncurve curve25519_Fp2_mcuType (EC_In (Zmodp2.pi (x, Zmodp.pi 0)) (Zmodp2.pi (Zmodp.pi 0, y)))).
Proof.
move => x y /=.
rewrite /a /b.
ring_simplify_this.
rewrite ?Zmodp2_mulE /= ?Zmodp2_addE /=.
rewrite /twist25519_Fp.a /twist25519_Fp.b.
ring_simplify_this.
move/eqP => -> /=.
apply eq_refl.
Qed.

Local Lemma on_twist_Fp_to_Fp2 : forall (p: point Zmodp.type),
  oncurve twist25519_Fp_mcuType p -> oncurve curve25519_Fp2_mcuType (twist_Fp_to_Fp2 p).
Proof.
  move=> [|x y] => //.
  apply ontwist25519_Fp_impl.
Qed.

Definition twist25519_Fp_to_Fp2 (p: mc twist25519_Fp_mcuType) : (mc curve25519_Fp2_mcuType) :=
match p with
  | MC u P => MC (on_twist_Fp_to_Fp2 u P)
end.

Local Lemma twist_add_Fp_to_Fp2 : forall (p q: point Zmodp_ringType) (p' q': point Zmodp2_ringType),
  p' = twist_Fp_to_Fp2 p ->
  q' = twist_Fp_to_Fp2 q ->
  MCGroup.add curve25519_Fp2_mcuType p' q' = twist_Fp_to_Fp2 (MCGroup.add twist25519_Fp_mcuType p q).
Proof.
  move => [|xp yp] [|xq yq] [|xp' yp'] [|xq' yq'] //= [] -> -> [] -> ->.
  rewrite /twist25519_Fp.a /twist25519_Fp.b.
  match goal with
    | [ |- _ = ?A ] => remember A as Freezer
  end.
  rewrite /eq_op /Equality.op /=.
  rewrite /eq_op /Equality.op /=.
  rewrite !eq_refl ?Bool.andb_true_r.
  rewrite ?expr2.
  have ->: 2%:R = Zmodp2.Zmodp2 (2%:R) 0 => //.
  have ->: 3%:R = Zmodp2.Zmodp2 (3%:R) 0 => //.
  Zmodpify => /=.
  subst Freezer.
  ringify.
  ring_simplify_this.
  case_eq (xp == xq) => -> ; rewrite -Zmodp_mul_comm_2 ?GRing.mulrA //=.
  case_eq ((yp == yq) && (yp != 0)) => -> //=.
Qed.

Local Lemma twist25519_add_Fp_to_Fp2_ : forall (p q: mc twist25519_Fp_mcuType) (p' q': mc curve25519_Fp2_mcuType),
  p' = twist25519_Fp_to_Fp2 p ->
  q' = twist25519_Fp_to_Fp2 q ->
  MCGroup.add curve25519_Fp2_mcuType p' q' = twist_Fp_to_Fp2 (MCGroup.add twist25519_Fp_mcuType p q).
Proof.
  move => [p Hp] [q Hq] [p' Hp'] [q' Hq'] Hpp' Hqq'.
  apply twist_add_Fp_to_Fp2.
  by simpl in Hpp'; inversion Hpp'.
  by simpl in Hqq'; inversion Hqq'.
Qed.

Local Lemma twist25519_add_Fp_to_Fp2: forall (p q: mc twist25519_Fp_mcuType),
  twist25519_Fp_to_Fp2 p + twist25519_Fp_to_Fp2 q = twist25519_Fp_to_Fp2 (p + q).
Proof.
  move => p q.
  have [p' Hp']: exists (p': mc curve25519_Fp2_mcuType), p' = twist25519_Fp_to_Fp2 p by exists (twist25519_Fp_to_Fp2 p).
  have [q' Hq']: exists (q': mc curve25519_Fp2_mcuType), q' = twist25519_Fp_to_Fp2 q by exists (twist25519_Fp_to_Fp2 q).
  ring_unfold.
  apply mc_eq.
  rewrite -(twist25519_add_Fp_to_Fp2_ _ _ _ _ Hp' Hq') Hp' Hq'.
  reflexivity.
Qed.

Lemma nP_is_nP2 : forall (n:nat) (p: mc twist25519_Fp_mcuType),
  twist25519_Fp_to_Fp2 (p *+ n) = (twist25519_Fp_to_Fp2 p) *+n.
Proof.
  elim => [|n IHn] p.
  ring_simplify_this.
  exact: mc_eq.
  by rewrite ?GRing.mulrS -IHn twist25519_add_Fp_to_Fp2.
Qed.

Definition tFp2_to_Fp p := match p with
  | Zmodp2.Zmodp2 x y => x
  end.

Lemma tFp2_to_Fp_cancel : forall (p: mc twist25519_Fp_mcuType),
  p#x0 = tFp2_to_Fp ((twist25519_Fp_to_Fp2 p)#x0).
Proof. by case; case. Qed.

Local Notation "p '/p'" := (tFp2_to_Fp p) (at level 40).

From mathcomp Require Import ssrnat.

Theorem twist25519_ladder_Fp_Fp2 (n : nat) x :
    (n < 2^255)%nat ->
    forall (p  : mc twist25519_Fp_mcuType),
    twist25519_Fp_to_Fp2 p #x0 = Zmodp2.Zmodp2 x 0 ->
    twist25519_Fp_ladder n x = ((twist25519_Fp_to_Fp2 p) *+ n)#x0 /p.
Proof.
  move => Hn p Hp.
  have Hp' := tFp2_to_Fp_cancel p.
  have Hp'' : p #x0 = x.
    rewrite Hp' Hp //.
  rewrite (twist25519_Fp_ladder_ok n x Hn p Hp'').
  rewrite -nP_is_nP2.
  rewrite tFp2_to_Fp_cancel //.
Qed.

Close Scope ring_scope.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas32_2e511m481_24limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C I H1 H2 : Universe, ((wd_ H1 B /\ (wd_ H2 B /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ I H2 /\ (wd_ I H1 /\ (wd_ I B /\ (col_ B H1 A /\ (col_ B H2 C /\ col_ I B H1)))))))))) -> col_ A B I)).
Proof.
  time tac.
Qed.

End FOFProblem.


Set Warnings "-notation-overridden".

Require Import LinearScan.Lib.
Require Import LinearScan.Interval.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Generalizable All Variables.

Section ScanState.

Variable maxReg : nat.          (* max number of registers *)
Hypothesis registers_exist : maxReg > 0.
Definition PhysReg := 'I_maxReg.

(** ** ScanStateDesc *)

(** A [ScanStateDesc] is always relative to a current position as we move
    through the sequentialized instruction stream over which registers are
    allocated. *)

Definition FixedIntervalsType := Vec (option IntervalSig) maxReg.

Record ScanStateDesc : Type := {
    nextInterval : nat;
    IntervalId := 'I_nextInterval;

    intervals : Vec IntervalSig nextInterval;
    fixedIntervals : FixedIntervalsType;

    (* The [nat] in this member indicates the beginning position of the
       interval. *)
    unhandled : seq (IntervalId * nat);     (* starts after pos *)
    active    : seq (IntervalId * PhysReg); (* ranges over pos *)
    inactive  : seq (IntervalId * PhysReg); (* falls in lifetime hole *)
    handled   : seq (IntervalId * option PhysReg); (* ends before pos *)

    unhandledIds := [seq fst i | i <- unhandled];
    activeIds    := [seq fst i | i <- active];
    inactiveIds  := [seq fst i | i <- inactive];
    handledIds   := [seq fst i | i <- handled];

    all_state_lists := unhandledIds ++ activeIds ++ inactiveIds ++ handledIds
}.

Arguments IntervalId /.
Arguments unhandledIds /.
Arguments activeIds /.
Arguments inactiveIds /.
Arguments handledIds /.

Definition getInterval `(i : IntervalId sd) := (vnth (intervals sd) i).2.
Arguments getInterval [sd] i /.

Definition sortRegisterVector (fixedAndIntersects : Vec bool maxReg) :
  Vec (option nat) maxReg -> seq (PhysReg * option nat) :=
  vfoldl_with_index
    (fun reg acc mpos =>
       let f x y :=
           let: (xreg, xmpos) := x in
           let: (yreg, ympos) := y in
           let xfi := vnth fixedAndIntersects xreg in
           let yfi := vnth fixedAndIntersects yreg in
           if xfi && ~~ yfi
           then false
           else
             if xmpos is Some xn
             then
               if ympos is Some yn
               then xn > yn
               else false
             else true in
       insert f (reg, mpos) acc) [::].

(** Given a vector of optional positions associated with a register, return
    the first register (counting upwards) which is either [None], or the
    highest of [Some] value.

    The worst case scenario is that every register has [Some n] with the same
    n, in which case register 0 is selected. *)
Definition registerWithHighestPos (fixedAndIntersects : Vec bool maxReg) :
  Vec (option nat) maxReg -> PhysReg * option nat :=
  head (Ordinal registers_exist, Some 0)
    \o sortRegisterVector fixedAndIntersects.

Definition handledIntervalDescsForReg (sd : ScanStateDesc) (reg : PhysReg)
  : seq IntervalDesc :=
  [seq getIntervalDesc (getInterval (fst x))
  | x <- handled sd & snd x == Some reg].

Definition verifyNewHandled (sd : ScanStateDesc) (int : IntervalDesc)
  (reg : PhysReg) : bool :=
  let check y := ~~ intervalsIntersect int y in
  all check (handledIntervalDescsForReg sd reg) &&
  if vnth (fixedIntervals sd) reg is Some i
  then ~~ intervalIntersectsWithSubrange int i.1
  else true.

(** ** ScanState *)

(** The [ScanState] inductive data type describes the allowable state
    transitions that can be applied to a [ScanStateDesc] value.

    In essence there are five mutating operations:

    1. Create a new unhandled interval.  This can occur for two reasons:

       a. Adding a new interval to be considered before the linear scan
          algorithm has started.
       b. Splitting the current interval, which pushes back its "pieces" as
          new unhandled intervals.

    2. Remove the first unhandled interval.  This happens when we remove it in
       order to make it the new current interval.

    3. Add the current interval to the active list.

    4. Move an item from the active list to the inactive or handled lists.

    5. Move an item from the inactive list to the active or handled lists. *)

Inductive ScanStateStatus := Pending | InUse.

Inductive ScanState : ScanStateStatus -> ScanStateDesc -> Prop :=
  | ScanState_nil :
    ScanState Pending
      {| nextInterval     := 0
       ; unhandled        := nil
       ; active           := nil
       ; inactive         := nil
       ; handled          := nil
       ; intervals        := vnil _
       ; fixedIntervals   := vconst None
       |}

  (* This is the only constructor which may add work to the scan state. *)
  | ScanState_newUnhandled b sd :
    ScanState b sd -> forall `(i : Interval d),
    let n   := (ord_max, ibeg d) in
    let unh := map widen_fst (unhandled sd) in
    (if b is Pending
     then (* While a [ScanState] is [Pending], unhandled intervals may be
             added at any position.  Once it is finalized and [InUse],
             unhandled intervals (arising from splits) may only be added
             after the current position. *)
          True
     else if unhandled sd is (_, u) :: _
          then u < ibeg d
          else False) ->
    ScanState b
      {| nextInterval     := (nextInterval sd).+1
       ; unhandled        := insert (lebf (@snd _ _)) n unh
       ; active           := map widen_fst (active sd)
       ; inactive         := map widen_fst (inactive sd)
       ; handled          := map widen_fst (handled sd)
       ; intervals        := vshiftin (intervals sd) (d; i)
       ; fixedIntervals   := fixedIntervals sd
       |}

  | ScanState_finalize sd :
      ScanState Pending sd -> ScanState InUse sd

  | ScanState_newHandled sd :
    ScanState InUse sd -> forall `(i : Interval d),
    firstUseReqReg i == None ->
    ScanState InUse
      {| nextInterval     := (nextInterval sd).+1
       ; unhandled        := map widen_fst (unhandled sd)
       ; active           := map widen_fst (active sd)
       ; inactive         := map widen_fst (inactive sd)
       ; handled          := (ord_max, None) :: map widen_fst (handled sd)
       ; intervals        := vshiftin (intervals sd) (d; i)
       ; fixedIntervals   := fixedIntervals sd
       |}

  | ScanState_setInterval sd :
    ScanState InUse sd -> forall xid `(i : Interval d),
    let xi := (vnth (intervals sd) xid).2 in
    intervalStart i == intervalStart xi ->
    intervalEnd i   <= intervalEnd   xi ->
    xid \notin handledIds sd ->
    ScanState InUse
      {| nextInterval     := nextInterval sd
       ; unhandled        := unhandled sd
       ; active           := active sd
       ; inactive         := inactive sd
       ; handled          := handled sd
       ; intervals        := vreplace (intervals sd) xid (d; i)
       ; fixedIntervals   := fixedIntervals sd
       |}

  | ScanState_setFixedIntervals sd :
    ScanState Pending sd -> forall (regs : FixedIntervalsType),
    ScanState Pending
      {| nextInterval     := nextInterval sd
       ; unhandled        := unhandled sd
       ; active           := active sd
       ; inactive         := inactive sd
       ; handled          := handled sd
       ; intervals        := intervals sd
       ; fixedIntervals   := regs
       |}

  | ScanState_moveUnhandledToActive
      ni unh act inact hnd ints fixints x reg :
    ScanState InUse
      {| nextInterval     := ni
       ; unhandled        := x :: unh
       ; active           := act
       ; inactive         := inact
       ; handled          := hnd
       ; intervals        := ints
       ; fixedIntervals   := fixints
       |} ->
    reg \notin [seq snd i | i <- act] ->
    ScanState InUse
      {| nextInterval     := ni
       ; unhandled        := unh
       ; active           := (fst x, reg) :: act
       ; inactive         := inact
       ; handled          := hnd
       ; intervals        := ints
       ; fixedIntervals   := fixints
       |}

  | ScanState_moveUnhandledToHandled (* allocate a spill slot *)
      ni unh act inact hnd ints fixints x :
    ScanState InUse
      {| nextInterval     := ni
       ; unhandled        := x :: unh
       ; active           := act
       ; inactive         := inact
       ; handled          := hnd
       ; intervals        := ints
       ; fixedIntervals   := fixints
       |} ->
    firstUseReqReg (vnth ints (fst x)).2 == None ->
    ScanState InUse
      {| nextInterval     := ni
       ; unhandled        := unh
       ; active           := act
       ; inactive         := inact
       ; handled          := (fst x, None) :: hnd
       ; intervals        := ints
       ; fixedIntervals   := fixints
       |}

  | ScanState_moveActiveToInactive sd :
    ScanState InUse sd -> forall x, x \in active sd ->
    ScanState InUse
      {| nextInterval     := nextInterval sd
       ; unhandled        := unhandled sd
       ; active           := rem x (active sd)
       ; inactive         := x :: inactive sd
       ; handled          := handled sd
       ; intervals        := intervals sd
       ; fixedIntervals   := fixedIntervals sd
       |}

  | ScanState_moveActiveToHandled sd spilled :
    ScanState InUse sd -> forall x, x \in active sd ->
    (let int := vnth (intervals sd) (fst x) in
     if spilled
     then firstUseReqReg int.2 == None
     else verifyNewHandled sd int.1 (snd x)) ->
    ScanState InUse
      {| nextInterval     := nextInterval sd
       ; unhandled        := unhandled sd
       ; active           := rem x (active sd)
       ; inactive         := inactive sd
       ; handled          := (fst x, if spilled
                                     then None
                                     else Some (snd x)) :: handled sd
       ; intervals        := intervals sd
       ; fixedIntervals   := fixedIntervals sd
       |}

  | ScanState_moveInactiveToActive sd :
    ScanState InUse sd -> forall x, x \in inactive sd ->
    snd x \notin [seq snd i | i <- active sd] ->
    ScanState InUse
      {| nextInterval     := nextInterval sd
       ; unhandled        := unhandled sd
       ; active           := x :: active sd
       ; inactive         := rem x (inactive sd)
       ; handled          := handled sd
       ; intervals        := intervals sd
       ; fixedIntervals   := fixedIntervals sd
       |}

  | ScanState_moveInactiveToHandled sd spilled :
    ScanState InUse sd -> forall x, x \in inactive sd ->
    (let int := vnth (intervals sd) (fst x) in
     if spilled
     then firstUseReqReg int.2 == None
     else verifyNewHandled sd int.1 (snd x)) ->
    ScanState InUse
      {| nextInterval     := nextInterval sd
       ; unhandled        := unhandled sd
       ; active           := active sd
       ; inactive         := rem x (inactive sd)
       ; handled          := (fst x, if spilled
                                     then None
                                     else Some (snd x)) :: handled sd
       ; intervals        := intervals sd
       ; fixedIntervals   := fixedIntervals sd
       |}.

Definition ScanStateSig (b : ScanStateStatus) :=
  { sd : ScanStateDesc | ScanState b sd }.

Definition getScanStateDesc `(st : ScanState InUse sd) := sd.
Arguments getScanStateDesc [sd] st /.

Definition packScanState `(st : ScanState b sd) := exist (ScanState b) sd st.
Arguments packScanState [b sd] st /.

End ScanState.

Require Import Coq.Strings.String.

Tactic Notation "ScanState_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ScanState_nil"
  | Case_aux c "ScanState_newUnhandled"
  | Case_aux c "ScanState_finalize"
  | Case_aux c "ScanState_newHandled"
  | Case_aux c "ScanState_setInterval"
  | Case_aux c "ScanState_setFixedIntervals"
  | Case_aux c "ScanState_moveUnhandledToActive"
  | Case_aux c "ScanState_moveUnhandledToHandled"
  | Case_aux c "ScanState_moveActiveToInactive"
  | Case_aux c "ScanState_moveActiveToHandled"
  | Case_aux c "ScanState_moveInactiveToActive"
  | Case_aux c "ScanState_moveInactiveToHandled"
  ].


Require Import CSet Le Var.

Require Import Plus Util AllInRel Map CSet ListUpdateAt.
Require Import Val Var Envs IL Annotation Infra.Lattice DecSolve Filter ContextMap.
Require Import Analysis AnalysisForward FiniteFixpointIteration Terminating Subterm.

Remove Hints trans_eq_bool.

Set Implicit Arguments.

Definition reachability_transform (sT:stmt)
           (ZL:ctxmap params)
           (st:stmt) (ST:subTerm st sT)
           (d:bool)
  : anni bool :=
  match st with
  | stmtLet x e s => anni1 d
  | stmtIf e s t =>
    anni2 (if [op2bool e = Some false] then false else d)
          (if [op2bool e = Some true] then false else d)
  | stmtApp f Y => anni1 d
  | stmtReturn e => anni1 d
  | _ => anni1 d
  end.

Lemma reachability_transform_monotone (sT s : stmt) (ST : subTerm s sT)
      (ZL : ctxmap params) (a b : bool)
  : a ⊑ b
    -> reachability_transform ZL ST a ⊑ reachability_transform ZL ST b.
Proof.
  intros; destruct s; simpl; try econstructor; simpl; eauto;
    repeat cases; simpl in *; eauto.
Qed.

Lemma reachability_transform_ext (sT s : stmt) (ST : subTerm s sT)
      (ZL : ctxmap params) (a b : bool)
  : a ≣ b
    -> reachability_transform ZL ST a ≣ reachability_transform ZL ST b.
Proof.
  intros; destruct s; simpl; try econstructor; simpl; eauto;
    repeat cases; simpl in *; eauto.
Qed.

Hint Resolve reachability_transform_monotone reachability_transform_ext.

Definition reachability_analysis s :=
  makeForwardAnalysis (fun s => bool ) _ _ _
                      reachability_transform
                      reachability_transform_monotone
                      (fun s => terminating_bool) s true.

Definition reachabilityAnalysis s :=
  proj1_sig (proj1_sig (safeFixpoint (reachability_analysis s))).


Require Import Util DecSolve Coq.Classes.RelationClasses.
Require Import Infra.PartialOrder Terminating Option OptionR.

Instance PartialOrder_option Dom `{PartialOrder Dom}
: PartialOrder (option Dom) := {
  poLe := option_R poLe;
  poLe_dec := @option_R_dec _ _ poLe poLe_dec;
  poEq := option_R poEq;
  poEq_dec := @option_R_dec _ _ poEq poEq_dec;
}.
Proof.
  - intros; inv H0; eauto using option_R, poLe_refl.
Defined.

Instance terminating_option Dom `{PO:PartialOrder Dom}
  : Terminating Dom poLt
    -> Terminating (option Dom) poLt.
Proof.
  intros. hnf; intros.
  destruct x.
  - specialize (H d).
    general induction H.
    econstructor; intros. inv H1; inv H2.
    eapply H0; eauto using option_R.
    split; eauto. intro. eapply H3; econstructor; eauto.
  - econstructor; intros. inv H0.
    exfalso. inv H1. eapply H2; reflexivity.
Qed.

Instance PartialOrder_option_fstNoneOrR Dom `{PartialOrder Dom}
: PartialOrder (option Dom) := {
  poLe := fstNoneOrR poLe;
  poLe_dec := _;
  poEq := option_R poEq;
  poEq_dec := _;
}.
Proof.
  - intros; inv H0; eauto using fstNoneOrR, poLe_refl.
Defined.

Lemma poLe_opt_inv T H a b
  : @poLe (option T) (@PartialOrder_option_fstNoneOrR T H)
          (@Some T a) (@Some T b)
    -> poLe a b.
Proof.
  inversion 1; eauto.
Qed.

Smpl Add
     match goal with
     | [ H : @poLe (option ?T) (@PartialOrder_option_fstNoneOrR ?T ?H')
                   ?A (@Some ?T ?b) |- _ ] =>
       eapply (@poLe_opt_inv T H') in H
     | [ H : @poLe (option ?T) (@PartialOrder_option_fstNoneOrR ?T ?H')
                   (@Some ?T ?a) None |- _ ] =>
       exfalso; inv H
     | [ H : @poLe (option ?T) (@PartialOrder_option_fstNoneOrR ?T ?H')
                   None _ |- _ ] => clear H
     end : inv_trivial.

Lemma poEq_None_inv (T : Type) (H : PartialOrder T) a
  : a ≣ None -> a = None.
Proof.
  intros. invc H0. reflexivity.
Qed.

Smpl Add
     match goal with
     | [ H : ?Y ≣ ⎣⎦ |- _ ] => eapply poEq_None_inv in H; try subst Y
     | [ H : ⎣⎦ ≣ ?Y |- _ ] => symmetry in H; eapply poEq_None_inv in H; try subst Y
     end : inv_trivial.

Lemma poEq_Some_inv (T : Type) (H : PartialOrder T) a b
  : a ≣ Some b -> exists a', a = Some a' /\ poEq a' b.
Proof.
  intros. invc H0. eauto.
Qed.

Smpl Add
     match goal with
     | [ H : ?Y ≣ Some _ |- _ ] => eapply poEq_Some_inv in H;
                                   destruct H as [? [? H]]; try subst Y
     | [ H : Some _ ≣ ?Y |- _ ] => symmetry in H; eapply poEq_Some_inv in H;
                                   destruct H as [? [? H]]; try subst Y
     end : inv_trivial.

Lemma poLe_option_None X `{PartialOrder X} (x:option X)
  :  None ⊑ x.
Proof.
  econstructor.
Qed.

Hint Resolve poLe_option_None.

Lemma poLe_Some_struct A `{PartialOrder A} (a b : A)
  : poLe a b
    -> poLe (Some a) (Some b).
Proof.
  econstructor; eauto.
Qed.

Hint Resolve poLe_Some_struct.

Smpl Add match goal with
         | [ H : poLe _ None |- _ ] => invc H
         | [ H : ⎣ ?x ⎦ <> ⎣ ?x ⎦ |- _ ] => exfalso; apply H; reflexivity
         end : inv_trivial.