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 InvertA.

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 InvertI := Invert IdT.
Export InvertI.

(** 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.


(************************************************************************)
(* Copyright (c) 2021, Gergei Bana and Qianli Zhang                     *)
(*                                                                      *)
(* This work is licensed under the MIT license. The license is          *)
(* described in the file "LICENSE" available at the root of the source  *)
(* or at https://opensource.org/licenses/MIT                            *)
(************************************************************************)

Require Export Core.

(*  *)

Definition  Compls : Symbols Deterministic (narg 1) := symbols Deterministic (narg 1) [3; 1].
Notation "'Compl'" := (FuncInt Deterministic (narg 1) Compls).
Notation compl x := ((FuncInt Deterministic (narg 1) Compls) [x]).

(*  *)

Axiom ComplNeq: forall t,  ((compl t) ≟ t) = FAlse.

(* Axiom ComplLen_prop: forall t, forall L : list ppt -> ppt, L [compl t] =  L [ t ]. *)


Require Import List.
Import ListNotations.

Require Import Coq.ZArith.BinInt.

From Verbatim Require Import regex.
From Verbatim Require Import state.
From Verbatim Require Import lexer.abstraction.

From Verbatim Require Import Table.
From Verbatim Require Import DFA.
From Verbatim Require Import lexer.impl.
From Verbatim Require Import Utils.ltac.
From Verbatim Require Import Utils.asciiFinite.
From Verbatim Require Import Utils.ascii_order.
From Verbatim Require Import concrete_table.

From Verbatim Require Import memo.memo.
From Verbatim Require Import memo.impl.
From Verbatim Require Import memo.correctness.
From Verbatim Require Import concrete_memo.

Module LexerFn (ALPHABET : SIGMA) (LABELS : LABEL).

  Module Export MEM <: memo.T.

    Module Export STT <: state.T.

      Module TabT <: Table.T.

        Module Export R <: regex.T.

          Module Export Ty <: SIGMA := ALPHABET.

          Module Export Defs := regex.DefsFn Ty.

        End R.

        Module TabTy <: TABLE R := FTable R.

        Module Export Defs := DefsFn R TabTy.

      End TabT.

      Module Export R := TabT.R.
      Import R.Ty.
      Export R.Defs.Helpers.

      Module Export Ty <: STATE R.

        Module Export D := DFAFn TabT.

        Definition Label : Type := LABELS.Label.
        Definition defLabel : Label := LABELS.defLabel.
        Lemma Label_eq_dec : forall (l l' : Label), {l = l'} + {l <> l'}.
        Proof. apply LABELS.Label_eq_dec. Qed.

        Definition Pointer : Type := regex.
        Definition defPointer : Pointer := EmptySet.
        Definition Delta : Type := TabT.TabTy.Table * TabT.R.Defs.reFS.t.
        Definition defDelta := (TabT.TabTy.emptyTable, TabT.TabTy.reFS.empty).
        Definition State := prod Pointer Delta.
        Definition defState := (defPointer, defDelta).

        Definition transition (a : Sigma) (e : State) : State :=
          match e with
            (x, (y, z)) =>
            match DFAtransition a (x,y,z) with
              (x',y',z') => (x',(y',z'))
            end
          end.
        Definition transition_list (bs : list Sigma) (e : State) : State :=
          match e with
            (x, (y, z)) =>
            match DFAtransition_list bs (x,y,z) with
              (x',y',z') => (x',(y',z'))
            end
          end.

        Lemma transition_list_nil : forall fsm,
            transition_list [] fsm = fsm.
        Proof.
          intros. unfold transition_list. repeat dm.
        Qed.

        Lemma transition_list_cons : forall bs a fsm,
            transition_list (a :: bs) fsm = transition_list bs (transition a fsm).
        Proof.
          intros. unfold transition_list. repeat dm. sis. repeat dm.
          - repeat inj_all.
            assert((r, t2, t1) = (r0, t6, t5)).
            { rewrite <- E1. rewrite <- E5. auto. }
            inv H. auto.
          - repeat inj_all.
            assert((r, t2, t1) = (r0, t6, t5)).
            { rewrite <- E1. rewrite <- E5. auto. }
            inv H. auto.
        Qed.

        Lemma transition_Delta : forall a p p' d d',
            transition a (p, d) = (p', d') -> d = d'.
        Proof.
          intros. unfold transition in *. repeat dm. repeat inj_all.
          apply DFAtransition_Delta in E0. destruct E0. subst. auto.
        Qed.

        Definition accepts (s : String) (e : State) : bool :=
          match e with
            (x, (y, z)) => DFAaccepts s (x, y, z)
          end.
        Definition accepting (e : State) :=
          match e with
            (x, (y, z)) => DFAaccepting (x, y, z)
          end.

        Lemma accepts_nil: forall(fsm : State), accepting fsm = accepts [] fsm.
        Proof. intros fsm. reflexivity. Qed.

        Lemma accepts_transition : forall cand a fsm,
            accepts cand (transition a fsm) = accepts (a :: cand) fsm.
        Proof.
          intros. unfold accepts. repeat dm. rewrite accepts_cons. unfold transition in E.
          repeat dm. repeat inj_all. auto.
        Qed.

        Definition init_state (r : regex) : State :=
          match regex2dfa r with
            (x, y, z) => (x, (y, z))
          end.
        Definition init_state_inv (r : State) : regex :=
          match r with
            (x, (y, z)) => dfa2regex (x, y, z)
          end.

        Lemma invert_init_correct : forall r s,
            exp_match s (init_state_inv (init_state r)) <-> exp_match s r.
        Proof. intros. simpl. apply TabT.Defs.FillTable.canon_equiv. Qed.

        Lemma accepts_matches : forall(s : String) (e : regex),
            true = accepts s (init_state e) <-> exp_match s e.
        Proof.
          split; intros.
          - symmetry in H. apply r2d_accepts_match. auto.
          - symmetry. apply r2d_accepts_match. auto.
        Qed.

        Definition accepting_dt_list : forall bs e,
            accepting (transition_list bs (init_state e))
            = accepting (init_state (derivative_list bs e)).
        Proof.
          intros. unfold accepting. repeat dm.
          unfold transition_list in E. repeat dm. repeat inj_all.
          unfold init_state in *. repeat dm. repeat inj_all.
          assert(DFAaccepting (p, t, t0)
                 = DFAaccepting (DFAtransition_list bs (p1, t3, t4))).
          { rewrite E5. auto. }
          rewrite H. clear H.
          assert(DFAaccepting (p0, t1, t2)
                 = DFAaccepting (regex2dfa (derivative_list bs e))).
          { rewrite E. auto. }
          rewrite H. clear H.
          assert(DFAaccepting (DFAtransition_list bs (p1, t3, t4))
                 = DFAaccepting (DFAtransition_list bs (regex2dfa e))).
          { rewrite E2. auto. }
          rewrite H. clear H.
          apply DFAaccepting_dt_list.
        Qed.

        Definition pointer_compare (s1 s2 : Pointer) : comparison :=
          re_compare s1 s2.

        Lemma pointer_compare_eq : forall x y,
            pointer_compare x y = Eq <-> x = y.
        Proof. apply re_compare_eq. Qed.

        Lemma pointer_compare_trans : forall c x y z,
            pointer_compare x y = c -> pointer_compare y z = c -> pointer_compare x z = c.
        Proof. apply re_compare_trans. Qed.

        Fixpoint pos2list (p : positive) : list bool :=
          match p with
          | xH => []
          | xO p' => false :: (pos2list p')
          | xI p' => true :: (pos2list p')
          end.

        Fixpoint list2pos (bs : list bool) : positive :=
          match bs with
          | [] => xH
          | false :: bs' => xO (list2pos bs')
          | true :: bs' => xI (list2pos bs')
          end.

        Lemma list_inv_pos : forall p,
            list2pos (pos2list p) = p.
        Proof.
          induction p; sis; try rewrite IHp; auto.
        Qed.

        Definition int2list (z : Z) : list bool :=
          match z with
          | 0%Z => []
          | Z.pos z' => true :: (pos2list z')
          | Z.neg z' => false :: (pos2list z')
          end.

        Definition list2int (bs : list bool) : Z :=
          match bs with
          | [] => 0%Z
          | true :: bs' => Z.pos (list2pos bs')
          | false :: bs' => Z.neg (list2pos bs')
          end.

        Lemma list_inv_int : forall z,
            list2int (int2list z) = z.
        Proof.
          destruct z.
          - sis. auto.
          - sis. rewrite list_inv_pos. auto.
          - sis. rewrite list_inv_pos. auto.
        Qed.

        Definition index : Type := Z.
        Definition index0 : index := 0%Z.

        Lemma index_eq_dec : forall (i ii : index), {i = ii} + {i <> ii}.
        Proof. repeat decide equality. Qed.

        Definition init_index (n : nat) : index :=
          match n with
          | 0 => index0
          | S m => Z.pos (P_of_succ_nat m)
          end.

        Definition index2list : index -> list bool:= int2list.
        Definition list2index : list bool -> index := list2int.

        Lemma list_inv : forall (x : index), list2index (index2list x) = x.
        Proof. apply list_inv_int. Qed.

        Definition incr : index -> index := Z.succ.
        Definition decr : index -> index := Z.pred.

        (* for index correctness *)
        Lemma decr_inv_incr : forall i, decr (incr i) = i.
        Proof. apply Z.pred_succ. Qed.

        Lemma incr_inv_decr : forall i, incr (decr i) = i.
        Proof. apply Z.succ_pred. Qed.

        Lemma decr_inv_S : forall n, decr (init_index (S n)) = init_index n.
        Proof.
          induction n; auto.
          sis. repeat dm.
          - sis. inv E0.
          - sis. inv E0. inv E. apply f_equal. rewrite H0. apply Pos.pred_double_succ.
          - sis. inv E0.
        Qed.

        Lemma incr_is_S : forall n, init_index (S n) = incr (init_index n).
        Proof.
          induction n; auto.
          unfold init_index. unfold incr. apply Pos2Z.inj_succ.
        Qed.

        Lemma n_det_index : forall n1 n2, init_index n1 = init_index n2 -> n1 = n2.
        Proof.
          intros. unfold init_index in *. destruct n1; destruct n2; try discriminate; auto.
          repeat rewrite Znat.Zpos_P_of_succ_nat in H. repeat rewrite <- Znat.Nat2Z.inj_succ in *.
          apply Znat.Nat2Z.inj; auto.
        Qed.

      End Ty.

      Module Export Defs := state.DefsFn R Ty.

    End STT.

    Module Export MemTy <: MEMO STT := FMemo STT.

    Module Export Defs := memo.MemoDefsFn STT MemTy.

  End MEM.

  Module Import Correctness := memo.correctness.CorrectFn MEM.

  Module Export LitLexer <: LEXER STT.

    Import IMPL.
    Definition lex := lex_M.
    Definition lex_sound := lex_sound__M.
    Definition lex_complete := lex_complete__M.

  End LitLexer.

  Export STT.
  Export R.Defs.
  Export STT.Defs.
  Export STT.R.Defs.

End LexerFn.


From Coq Require Import Uint63.
From mathcomp Require Import all_ssreflect all_algebra.
From CoqEAL Require Import refinements hrel param.
Local Open Scope ring_scope.
Import Refinements Op.
Require Import int63 int63_ordinal.

Section InstancesInt63.

Global Instance zero_int63 : zero_of int63 := 0%uint63.
Global Instance one_int63 : one_of int63 := 1%uint63.
Global Instance add_int63 : add_of int63 := Uint63.add.
Global Instance mul_int63 : mul_of int63 := Uint63.mul.
Global Instance le_int63 : leq_of int63 := Uint63.leb.
Global Instance lt_int63 : lt_of int63 := Uint63.ltb.
Global Instance eq_int63 : eq_of int63 := Uint63.eqb.

End InstancesInt63.

Section RefineInt63Nat.

Definition r_natint63 := fun_hrel int63_to_nat.

Global Instance refine_natint63_zero: refines r_natint63 0%nat 0%C.
Proof. by rewrite refinesE /r_natint63 /fun_hrel. Qed.

Global Instance refine_natint63_one: refines r_natint63 1%nat 1%C.
Proof. by rewrite refinesE /r_natint63 /fun_hrel. Qed.

Global Instance refine_natint63_eq:
  refines (r_natint63 ==> r_natint63 ==> bool_R)%rel eqtype.eq_op eq_op.
Proof.
rewrite refinesE /r_natint63 /fun_hrel.
move=> ? x <- ? y <-; rewrite /eq_op /eq_int63.
rewrite eqEint63; exact: bool_Rxx.
Qed.

Global Instance refine_natint63_le:
  refines (r_natint63 ==> r_natint63 ==> bool_R)%rel
    (fun x y : nat => (x <= y)%nat) leq_op.
Proof.
rewrite refinesE /r_natint63 /fun_hrel.
move=> ? x <- ? y <-; rewrite /leq_op /le_int63.
rewrite leEint63; exact: bool_Rxx.
Qed.

Global Instance refine_natint63_lt:
  refines (r_natint63 ==> r_natint63 ==> bool_R)%rel
    (fun x y : nat => (x < y)%nat) lt_op.
Proof.
rewrite refinesE /r_natint63 /fun_hrel.
move=> ? x <- ? y <-; rewrite /lt_op /lt_int63.
rewrite ltEint63; exact: bool_Rxx.
Qed.

Global Instance refine_natint63_to_int63 x:
  refines r_natint63 (int63_to_nat x) x.
Proof. by rewrite refinesE /r_natint63 /fun_hrel. Qed.

End RefineInt63Nat.

Section TestNat.

Goal (int63_to_nat 5 <= int63_to_nat 10)%O.
Proof.
by coqeal.
Abort.

End TestNat.

Section RefineInt63Ord63.

Definition r_ord63int63 := fun_hrel int63_to_ord63.

Global Instance refine_ord63int63_zero: refines r_ord63int63 0%R 0%C.
Proof. by rewrite refinesE /r_ord63int63 /fun_hrel ord63_0P. Qed.

Global Instance refine_ord63int63_one: refines r_ord63int63 1 1%C.
Proof. by rewrite refinesE /r_ord63int63 /fun_hrel ord63_1P. Qed.

Global Instance refine_ord63int63_add:
  refines (r_ord63int63 ==> r_ord63int63 ==> r_ord63int63)%rel +%R +%C.
Proof.
rewrite refinesE /r_ord63int63 /fun_hrel.
by move=> ?? <- ?? <-; rewrite ord63_addP.
Qed.

Global Instance refine_ord63int63_mul:
  refines (r_ord63int63 ==> r_ord63int63 ==> r_ord63int63)%rel *%R *%C.
Proof.
rewrite refinesE /r_ord63int63 /fun_hrel.
by move=> ?? <- ?? <-; rewrite ord63_mulP.
Qed.

Global Instance refine_ord63int63_eq:
  refines (r_ord63int63 ==> r_ord63int63 ==> bool_R)%rel eqtype.eq_op eq_op.
Proof.
rewrite refinesE /r_ord63int63 /fun_hrel.
move=> ? x <- ? y <-; rewrite /eq_op /eq_int63.
rewrite ord63_eqbP; exact: bool_Rxx.
Qed.

Global Instance refine_ord63int63_le:
  refines (r_ord63int63 ==> r_ord63int63 ==> bool_R)%rel
    (fun x y : ord63 => (x <= y)%nat) leq_op.
Proof.
rewrite refinesE /r_ord63int63 /fun_hrel.
move=> ? x <- ? y <-.
rewrite -ord63_leP; exact: bool_Rxx.
Qed.

Global Instance refine_ord63int63_lt:
  refines (r_ord63int63 ==> r_ord63int63 ==> bool_R)%rel
    (fun x y : ord63 => (x < y)%nat) lt_op.
Proof.
rewrite refinesE /r_ord63int63 /fun_hrel.
move=> ? x <- ? y <-.
rewrite -ord63_ltP; exact: bool_Rxx.
Qed.

Global Instance refine_ord63int63_to_int63 x:
  refines r_ord63int63 (int63_to_ord63 x) x.
Proof. by rewrite refinesE /r_ord63int63 /fun_hrel. Qed.

End RefineInt63Ord63.

Section Test.

Notation "[ x ]" := (int63_to_ord63 x).

Goal [100] + [1] == [101].
coqeal.
Abort.

Goal ([10] * [10] < [101])%nat.
Proof.
coqeal.
Abort.

Goal ([10] * [10] + [5000] <= [5101])%nat.
Proof.
coqeal.
Abort.

Goal 1 + 0 == 1 :> ord63.
by [].
(* by apply: refines_goal. *)
Abort.

Goal 2 + 0 == 2 :> ord63.
Fail by [].
apply: refines_goal.
Abort.

End Test.