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 List Coq.Strings.String RelationClasses Morphisms Setoid.
Require Import Lang Util.

Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Tactics.Consider.

Require Import ExtLib.Data.Pair.
Require Import ExtLib.Data.List.

Set Implicit Arguments.
Unset Strict Implicit.

Section RelDecNoDup.
	Require Import Coq.Bool.Bool.

	Context {A : Type} {RelDec_A : RelDec (@eq A)}
	        {RelDec_Correct_A : RelDec_Correct RelDec_A}.

	Fixpoint inb (x : A) (lst : list A) :=
	  match lst with
	    | nil => false
	    | l::ls => if x ?[ eq ] l then true else inb x ls
	  end.

    Lemma inb_sound (x : A) (lst : list A) (H : inb x lst = true) : In x lst.
    Proof.
      induction lst; simpl in *; try congruence.
	  consider (x ?[ eq ] a); intros; subst.
	  + left; reflexivity.
	  + right; apply IHlst; assumption.
    Qed.

    Lemma inb_complete (x : A) (lst : list A) (H : In x lst) : inb x lst = true.
    Proof.
	  induction lst; simpl in *; try intuition congruence.
      consider (x ?[ eq ] a); intros; destruct H as [H | H]; try congruence.
      apply IHlst; assumption.
    Qed.

	Fixpoint nodup (lst : list A) : bool :=
		match lst with
		  | nil => true
		  | l :: ls => (negb (inb l ls) && nodup ls)%bool
		end.

	Lemma nodup_sound (lst : list A) (H : nodup lst = true) : NoDup lst.
	Proof.
	  induction lst.
	  + constructor.
	  + simpl in *. rewrite andb_true_iff in H; destruct H as [H1 H2].
	    rewrite negb_true_iff in H1. constructor.
	    * intro H. apply inb_complete in H. intuition congruence.
	    * apply IHlst; assumption.
	Qed.

	Lemma nodup_complete (lst : list A) (H : NoDup lst) : nodup lst = true.
	Proof.
	  induction lst.
	  + constructor.
	  + simpl in *. rewrite andb_true_iff. inversion H; subst; split; clear H.
	    * apply eq_true_not_negb. intros H; apply H2. apply inb_sound; assumption.
	    * apply IHlst; assumption.
	Qed.

End RelDecNoDup.

Record Method := {
  m_params: list var;
  m_body: cmd;
  m_ret: dexpr
}.

Instance RelDec_Method : RelDec (@eq Method) := {
	rel_dec m1 m2 := (m_params m1 ?[ eq ] m_params m2 &&
					  m_body m1 ?[ eq ] m_body m2 &&
					  m_ret m1 ?[ eq ] m_ret m2)%bool
}.

Instance RelDec_Correct_Method : RelDec_Correct RelDec_Method.
Proof.
	split; intros; destruct x, y; simpl.
	consider (m_params0 ?[ eq ] m_params1);
	consider (m_body0 ?[ eq ] m_body1);
	consider (m_ret0 ?[ eq ] m_ret1); simpl; intuition congruence.
Qed.

Record Class := {
  c_fields  : list field;
  c_methods : list (string * Method)
}.

Instance RelDec_Class : RelDec (@eq Class) := {
	rel_dec c1 c2 := (c_fields c1 ?[ eq ] c_fields c2 &&
					  c_methods c1 ?[ eq ] c_methods c2)%bool
}.

Instance RelDec_Correct_Class : RelDec_Correct RelDec_Class.
Proof.
	split; intros; destruct x, y; simpl.
	consider (c_fields0 ?[ eq ] c_fields1);
	consider (c_methods0 ?[ eq ] c_methods1); intros;
		 simpl; try intuition congruence.
Qed.

Record Program := {
  p_classes: list (string * Class)
}.

Instance RelDec_Program : RelDec (@eq Program) := {
  rel_dec p1 p2 := (p_classes p1) ?[ eq ] (p_classes p2)
}.

Instance RelDec_Correct_Program : RelDec_Correct RelDec_Program.
Proof.
	split; intros; destruct x, y; simpl.
	consider (p_classes0 ?[ eq ] p_classes1); intuition congruence.
Qed.

Definition valid_method (M : Method) := nodup (m_params M).

Definition valid_class (C : Class) : bool :=
	let (names, methods) := split (c_methods C) in
	nodup (c_fields C) && nodup names &&
	  forallb (fun M => valid_method M) methods.

Definition valid_program (P : Program) : bool :=
	let (names, classes) := split (p_classes P) in
	    nodup names &&
		forallb valid_class classes.

Fixpoint class_lookup_aux C (lst : list (string * Class)) :=
	match lst with
		| nil => None
		| (c, Crec)::ls => if C ?[ eq ] c then Some Crec else class_lookup_aux C ls
	end.

Definition class_lookup C P := class_lookup_aux C (p_classes P).

Fixpoint method_lookup_aux m (lst : list (string * Method)) :=
	match lst with
		| nil => None
		| (m', M)::ls => if m ?[ eq ] m' then Some M else method_lookup_aux m ls
	end.

Definition method_lookup' C M P :=
  match class_lookup C P with
    | Some Crec => method_lookup_aux M (c_methods Crec)
    | None => None
  end.

Lemma split_Prop {A B C : Type} (lst : list (A * B)) (P : list A -> list B -> C) :
	(let (a, b) := split lst in P a b) =
	P (fst (split lst)) (snd (split lst)).
Proof.
  generalize dependent C.
  induction lst; try reflexivity; intros; destruct a; simpl.
  replace (let (g, d) := split lst in (a :: g, b :: d)) with
  		  (a :: fst (split lst), b :: snd (split lst)) by (symmetry; apply IHlst).
  reflexivity.
Qed.

Section Pwf.

  Variable Prog: Program.
  Variable (Valid : valid_program Prog = true).

  Definition field_lookup (C:class) (fields: list field) :=
  	exists Crec, In (C, Crec) (p_classes Prog) /\
  		fields = c_fields Crec.

  Lemma field_lookup_function C f f'
  	(H1 : field_lookup C f) (H2 : field_lookup C f') : f = f'.
  Proof.
    unfold field_lookup in *.
    destruct H1 as [m [H11 H12]]; destruct H2 as [n [H21 H22]].
    unfold valid_program in Valid. simpl in *.
    assert (m = n); [|subst; reflexivity].
    rewrite split_Prop, andb_true_iff in Valid.
    destruct Valid; clear Valid.
    induction (p_classes Prog); simpl in *; try intuition congruence.
    destruct a; simpl in *.
    rewrite split_Prop in H, H0; simpl in *; rewrite andb_true_iff in H, H0.
    destruct H, H0.
    rewrite negb_true_iff in H.
    destruct H11, H21.
    + inversion H3; inversion H4; subst; apply H9.
    + inversion H3; subst; clear IHl.
      assert (~inb C (fst (split l)) = true) by (unfold class; intuition congruence).
	  contradiction H5; clear H H5.
	  apply inb_complete.
	  apply in_split_l in H4. apply H4.
	+ inversion H4; subst; clear IHl.
      assert (~inb C (fst (split l)) = true) by (unfold class; intuition congruence).
	  contradiction H5; clear H H5.
	  apply inb_complete.
	  apply in_split_l in H3. apply H3.
    + apply IHl; try assumption.
  Qed.

  Definition method_lookup (C:class) m mrec :=
    exists Crec, In (C, Crec) (p_classes Prog) /\
      In (m, mrec) (c_methods Crec).

  Lemma method_lookup_function : forall C m mr0 mr1
    (HML0 : method_lookup C m mr0)
    (HML1 : method_lookup C m mr1),
    mr0 = mr1.
  Proof.
    unfold Pwf.method_lookup; intros; destruct HML0 as [C0 [HC0 HM0]];
      destruct HML1 as [C1 [HC1 HM1]].
   unfold valid_program in Valid. simpl in *.
    rewrite split_Prop, andb_true_iff in Valid.
    destruct Valid; clear Valid.
    induction (p_classes Prog); simpl in *; try intuition congruence.
    destruct a; simpl in *.
    rewrite split_Prop in H, H0; simpl in *; rewrite andb_true_iff in H, H0.
    destruct H, H0.
    rewrite negb_true_iff in H.
    destruct HC0, HC1.
    + clear IHl; inversion H3; inversion H4. repeat subst; clear H H1 H2 H3 H4 H8.
	  unfold valid_class in H0. rewrite split_Prop in H0; repeat rewrite andb_true_iff in H0.
	  destruct H0 as [[_ H] _].
	  induction (c_methods C1); simpl in *; try intuition congruence.
	  destruct a; rewrite split_Prop in H; simpl in H.
	  rewrite andb_true_iff in H; destruct H as [H1 H2].
	  rewrite negb_true_iff in H1.
	  destruct HM1, HM0.
	  * inversion H; inversion H0; repeat subst; reflexivity.
	  * inversion H; subst; clear IHl0.
        assert (~inb m (fst (split l0)) = true) by intuition congruence.
        contradiction H3. apply inb_complete.
        apply in_split_l in H0; apply H0.
	  * inversion H0; subst; clear IHl0.
        assert (~inb m (fst (split l0)) = true) by intuition congruence.
        contradiction H3. apply inb_complete.
        apply in_split_l in H; apply H.
	  * apply IHl0; assumption.
    + inversion H3; subst; clear IHl.
      assert (~inb C (fst (split l)) = true) by (unfold class; intuition congruence).
	  contradiction H5; clear H H5.
	  apply inb_complete.
	  apply in_split_l in H4. apply H4.
	+ inversion H4; subst; clear IHl.
      assert (~inb C (fst (split l)) = true) by (unfold class; intuition congruence).
	  contradiction H5; clear H H5.
	  apply inb_complete.
	  apply in_split_l in H3. apply H3.
    + apply IHl; try assumption.
  Qed.

  Lemma method_lookup_nodup C m mr (H : method_lookup C m mr) : NoDup (m_params mr).
  Proof.
    unfold method_lookup in H.
    destruct H as [Crec [H1 H2]].
    unfold valid_program in Valid.
    rewrite split_Prop, andb_true_iff in Valid.
    destruct Valid as [H3 H4]; clear Valid.
	induction (p_classes Prog); simpl in *; try intuition congruence.
	destruct a; rewrite split_Prop in H3; simpl in *.
	rewrite andb_true_iff in H3; destruct H3 as [H3 H5].
	rewrite negb_true_iff in H3.
	rewrite split_Prop in H4; simpl in *.
	rewrite andb_true_iff in H4; destruct H4 as [H4 H6].
	unfold valid_class in H4. rewrite split_Prop in H4; repeat rewrite andb_true_iff in H4.
	destruct H4 as [[H4 _] H7].
	destruct H1 as [H1 | H1]; [
		inversion H1; repeat subst; clear H1 IHl|
		apply IHl; assumption
	].
	clear H3 H4 H5 H6 l C Prog.
	induction (c_methods Crec); simpl in *; try intuition congruence.
	destruct a; simpl in *; rewrite split_Prop in H7; simpl in *.
	rewrite andb_true_iff in H7; destruct H7 as [H1 H3].
	destruct H2 as [H2 | H2]; [|apply IHl; assumption].
	inversion H2; subst; clear H2 H3 IHl.
	unfold valid_method in H1. apply nodup_sound; assumption.
Qed.

End Pwf.

Definition Prog_compat (P Q : Program) :=
  forall C, ~ (In C (p_classes P) /\ In C (p_classes Q)).

Definition Prog_sub (P Q : Program) :=
  forall C crec, In (C, crec) (p_classes P) ->
    exists crec', In (C, crec') (p_classes Q) /\
      c_fields crec = c_fields crec' /\
      c_methods crec = c_methods crec'.

Instance Prog_sub_preo : PreOrder Prog_sub.
Proof.
  split.
  + intros P x C HF; exists C; repeat split; trivial.
  + intros P Q R HPQ HQR x C HF.
  destruct (HPQ _ _ HF) as [D [HLu [HFs HMs]]].
  destruct (HQR _ _ HLu) as [E [HLuR [HFs' HMs']]].
  exists E; split; [assumption | split; etransitivity; eassumption].
Qed.


From CoqAlgs Require Import Base.

Definition Queue (A : Type) : Type := list A * list A.

Definition isQueue {A : Type} (q : Queue A) : Prop :=
  let '(f, r) := q in f = [] -> r = [].

(** See note in Okasaki, p. 56 *)
Definition queue {A : Type} (f r : list A) : Queue A :=
match f with
    | [] => (rev r, [])
    | _ => (f, r)
end.

Definition empty {A : Type} : Queue A := ([], []).

Definition isEmpty {A : Type} (q : Queue A) : bool :=
match q with
    | ([], _) => true
    | _ => false
end.

Definition snoc {A : Type} (x : A) (q : Queue A) : Queue A :=
  let '(f, r) := q in queue f (x :: r).

Definition head {A : Type} (q : Queue A) : option A :=
match q with
    | ([], _) => None
    | (h :: _, _) => Some h
end.

Definition tail {A : Type} (q : Queue A) : option (Queue A) :=
match q with
    | ([], _) => None
    | (_ :: t, r) => Some (queue t r)
end.

Lemma empty_isQueue :
  forall A : Type, isQueue (@empty A).
Proof. cbn. trivial. Qed.

Lemma queue_isQueue :
  forall (A : Type) (f r : list A),
    isQueue (queue f r).
Proof.
  destruct f; cbn; intros.
    trivial.
    inversion H.
Qed.

Definition tail_isQueue :
  forall (A : Type) (q q' : Queue A),
    tail q = Some q' -> isQueue q'.
Proof.
  destruct q as [[| h t] r]; cbn; inversion 1.
    apply queue_isQueue.
Qed.

Definition snoc_isQueue :
  forall (A : Type) (x : A) (q : Queue A),
    isQueue (snoc x q).
Proof.
  destruct q as [[| h t] r]; inversion 1; trivial.
Qed.

(* Properties of [isEmpty]. *)
Lemma isEmpty_empty :
  forall A : Type, isEmpty (@empty A) = true.
Proof. reflexivity. Qed.

Lemma isEmpty_queue_true :
  forall (A : Type) (f r : list A),
    isEmpty (queue f r) = true -> f = [] /\ r = [].
Proof.
  destruct f; cbn; intros.
    case_eq (rev r); intros.
      assert (rev (rev r) = rev []) by congruence.
        rewrite rev_involutive in H1. auto.
      rewrite H0 in H. congruence.
    congruence.
Qed.

Lemma isEmpty_queue_false :
  forall (A : Type) (f r : list A),
    isEmpty (queue f r) = false -> f <> [] \/ r <> [].
Proof.
  destruct f; cbn; intros.
    case_eq (rev r); intros.
      rewrite H0 in H. congruence.
      right. intro. rewrite H1 in H0. inv H0.
    left. congruence.
Qed.

Lemma isEmpty_tail_false :
  forall (A : Type) (q : Queue A),
    isEmpty q = false -> exists q' : Queue A, tail q = Some q'.
Proof.
  destruct q as [[| h t] r]; cbn; intro.
    inv H.
    eauto.
Qed.

Lemma isEmpty_tail_false' :
  forall (A : Type) (q : Queue A),
    isEmpty q = false -> tail q <> None.
Proof.
  intros A [[| h t] r]; cbn; congruence.
Qed.

Lemma isEmpty_tail_true :
  forall (A : Type) (q : Queue A),
    isEmpty q = true -> tail q = None.
Proof.
  destruct q as [[| h t] r]; cbn; firstorder congruence.
Qed.

Lemma isEmpty_snoc :
  forall (A : Type) (x : A) (q : Queue A),
    isEmpty (snoc x q) = false.
Proof.
  destruct q as [[| h t] r]; cbn.
    case_eq (rev r ++ [x]); intros.
      destruct (rev r); inv H.
      all: trivial.
Qed.

(* [size] and its properties. *)
Definition size {A : Type} (q : Queue A) : nat :=
  let '(f, r) := q in length f + length r.

Lemma size_empty :
  forall A : Type, size (@empty A) = 0.
Proof. reflexivity. Qed.

Lemma size_queue :
  forall (A : Type) (f r : list A),
    size (queue f r) = length f + length r.
Proof.
  destruct f; cbn; intros.
    rewrite rev_length, <- Nat.add_0_r. reflexivity.
    reflexivity.
Qed.

Lemma size_tail :
  forall (A : Type) (q q' : Queue A),
    tail q = Some q' -> size q' = pred (size q).
Proof.
  destruct q as [[| h t] r]; cbn; intros; inv H.
    rewrite size_queue. reflexivity.
Qed.

Lemma size_snoc :
  forall (A : Type) (x : A) (q : Queue A),
    size (snoc x q) = S (size q).
Proof.
  destruct q as [[| h t] r]; cbn; intros.
    rewrite app_length, rev_length, Nat.add_0_r, Nat.add_comm; cbn. reflexivity.
    rewrite Nat.add_comm. cbn. rewrite Nat.add_comm. reflexivity.
Qed.

(* [fmap] and its properties. *)
Definition fmap {A B : Type} (f : A -> B) (q : Queue A) : Queue B :=
  let '(front, rear) := q in (map f front, map f rear).

Lemma fmap_queue :
  forall (A B : Type) (g : A -> B) (f r : list A),
    fmap g (queue f r) = queue (map g f) (map g r).
Proof.
  destruct f as [| h t]; cbn; intros; rewrite ?map_rev; reflexivity.
Qed.

Lemma fmap_empty :
  forall (A B : Type) (f : A -> B),
    fmap f (@empty A) = @empty B.
Proof. reflexivity. Qed.

Lemma fmap_isEmpty :
  forall (A B : Type) (f : A -> B) (q : Queue A),
    isEmpty (fmap f q) = isEmpty q.
Proof.
  destruct q as [[| h t] r]; cbn; reflexivity.
Qed.

Lemma fmap_snoc :
  forall (A B : Type) (f : A -> B) (x : A) (q : Queue A),
    fmap f (snoc x q) = snoc (f x) (fmap f q).
Proof.
  destruct q. cbn. rewrite fmap_queue. reflexivity.
Qed.

Lemma fmap_head :
  forall (A B : Type) (f : A -> B) (q : Queue A),
    head (fmap f q) =
    match head q with
        | None => None
        | Some x => Some (f x)
    end.
Proof.
  destruct q as [[| h t] r]; cbn; reflexivity.
Qed.

Lemma fmap_tail :
  forall (A B : Type) (f : A -> B) (q q' : Queue A),
    tail q = Some q' -> tail (fmap f q) = Some (fmap f q').
Proof.
  destruct q as [[| h t] r]; cbn; intros; inv H.
  rewrite fmap_queue. reflexivity.
Qed.

Lemma fmap_size :
  forall (A B : Type) (f : A -> B) (q : Queue A),
    size (fmap f q) = size q.
Proof.
  destruct q. cbn. rewrite ?map_length. reflexivity.
Qed.

(* Properties of [head]. *)
Lemma head_empty :
  forall A : Type, head (@empty A) = None.
Proof. reflexivity. Qed.

Lemma head_singl :
  forall (A : Type) (x : A),
    head (snoc x empty) = Some x.
Proof. reflexivity. Qed.

Lemma head_snoc_false :
  forall (A : Type) (x : A) (q : Queue A),
    isEmpty q = false -> head (snoc x q) = head q.
Proof.
  destruct q as [[| h t] r]; cbn; intros.
    congruence.
    trivial.
Qed.

Lemma head_snoc_true :
  forall (A : Type) (x : A) (q : Queue A),
    isQueue q -> isEmpty q = true -> head (snoc x q) = Some x.
Proof.
  destruct q as [[| h t] r]; cbn; intros.
    rewrite (H eq_refl). cbn. trivial.
    congruence.
Qed.

(* Properties of tail. *)
Lemma tail_empty :
  forall A : Type, tail (@empty A) = None.
Proof. reflexivity. Qed.

Lemma tail_singl :
  forall (A : Type) (x : A),
    tail (snoc x empty) = Some empty.
Proof. reflexivity. Qed.