Require Import String.
Require Import Functors.
Require Import MonadLib.
Require Import Names.
Require Import PNames.
Require Import EffPure.
Require Import EffState.
Require Import EffExcept.
Require Import EffReader.
Require Import Arith.
Require Import Bool.
Require Import Lambda.
Require Import Ref.
Require Import Exception.
Require Import Lambda_Arith.
Require Import Lambda_Bool.
Require Import Lambda_Ref.
Require Import Lambda_Exception.
Require Import ESoundERS.

Section Test_Section.

  Definition D := AType :+: BType :+: LType :+: UnitType :+: RefType.
  Definition E (A : Set) := Arith :+: Bool :+: Lambda D A :+: RefE :+: ExceptE D.

  Global Instance Fun_E : forall (A : Set),
    Functor (E A).
  Proof.
    eauto with typeclass_instances.
  Defined.

  Definition V := StuckValue :+: NatValue :+: BoolValue :+:
    (ClosValue E) :+: LocValue :+: UnitValue.

  Variable MT : Set -> Set.
  Context `{Fail_MT : FailMonad MT}.
  Context {Inj_MT : InjMonad MT}.
  Context {Reasonable_MT : Reasonable_Monad MT}.
  Context {MT_eq_dec : forall (A : Set) (mta : MT A),
    {exists a, mta = return_ a} + {mta = fail}}.

  Variable ME : Set -> Set.
  Context `{Mon_ME : Environment ME (list (Value V))}.
  Context {State_ME : StateM ME (list (Value V))}.
  Context {Fail_ME : FailMonad ME}.
  Context {FailEnvM : FailEnvironmentMonad (Env (Value V)) ME}.
  Context {Exception_ME : Exception ME Datatypes.unit}.

  Definition EQV_E (A B : Set) := (Arith_eqv E A B) ::+:: (Bool_eqv E A B)
    ::+:: (Lambda_eqv D E A B) ::+:: (RefE_eqv E A B)
    ::+:: (Exception_eqv D E A B).

  Definition WFV := (WFValue_VI V D (list (Names.DType D) * list (Names.DType D))) ::+::
    (WFValue_VB D V _) ::+:: (WFValue_Clos D E MT V EQV_E _)
    ::+:: (WFValue_Unit D V _) ::+:: (WFValue_Loc D V _).

  Definition WFVM := (WFValueM_base D V MT ME _ WFV) ::+:: (WFValueM_Environment D MT V ME _ WFV)
    ::+:: (WFValueM_Bot D V MT ME _) ::+:: (WFValueM_State D V MT ME _
      (TypContextCE := SigGamma_GammaTypContextCE _)
      (TypContext_WFE := SigGamma_WF_EnvC _ _ WFV))
    ::+:: (WFValueM_Except D V MT ME _).

  Instance eval_alg : FAlgebra EvalName (Exp (E nat)) (evalMR V ME) (E nat).
  Proof.
    eauto 250 with typeclass_instances.
  Defined.

  Instance typeof_alg : forall T, FAlgebra TypeofName T (typeofR D MT) (E (DType D)).
  Proof.
    intros; eauto 150 with typeclass_instances.
  Defined.

  Instance eqv_soundness_X_alg eval_rec :
    iPAlgebra soundness_X'_Name
    (soundness_X'_P D V E MT ME _ EQV_E WFVM (fun e => typeof _ _ MT (proj1_sig e)) eval_rec
      (f_algebra (FAlgebra := typeof_alg _))
      (f_algebra (FAlgebra := eval_alg))) (EQV_E _ _).
  Proof.
    repeat apply iPAlgebra_Plus.
    apply eqv_soundness_X'_Arith_eqv with (WFV := WFV) (Fail_MT := Fail_MT)
      (monad := monad0) (TypContextCE := SigGamma_GammaTypContextCE _)
      (Sub_AType_D := _) (Sub_StuckValue_V := _) (Sub_NatValue_V := _);
      intros; eauto 550 with typeclass_instances.
    apply eqv_soundness_X'_Bool_eqv with (WFV := WFV) (Fail_MT := Fail_MT)
      (monad := monad0) (TypContextCE := SigGamma_GammaTypContextCE _)
      (Sub_BType_D := _) (Sub_StuckValue_V := _) (Sub_BoolValue_V := _)
      (eq_DType_DT := _); intros; eauto 550 with typeclass_instances.
    apply eqv_soundness_X'_Lambda_eqv with (WFV := WFV) (Fail_MT := Fail_MT)
      (TypContextCE := SigGamma_GammaTypContextCE _)
      (Environment_ME := Mon_ME) (Sub_LType_D := _)
      (Sub_StuckValue_V := _) (Sub_ClosValue_V := _)
      (eq_DType_DT := _); intros; eauto 550 with typeclass_instances.
    apply eqv_soundness_X'_RefE_eqv with  (WFV := WFV) (TypContext_S := _)
      (TypContextCE := SigGamma_GammaTypContextCE _)
      (TypContext_WFE := SigGamma_WF_EnvC _ _ WFV) (Fail_MT := Fail_MT) (StateM_ME := State_ME)
      (Sub_RefType_D := _) (Sub_StuckValue_V := _) (Sub_LocValue_V := _)
      (eq_DType_DT := _) (Sub_UnitType_D := _) (Sub_UnitValue_V := _);
      intros; eauto 550 with typeclass_instances.
    apply eqv_soundness_X'_Except_eqv with (Fail_MT := Fail_MT)
      (TypContextCE := SigGamma_GammaTypContextCE _)
      (Exception_ME := Exception_ME) (eq_DType_DT := _);
      intros; eauto 550 with typeclass_instances.
  Qed.

  Variable put_local : forall (A : Set) sigma f (m : ME A),
    put (M := ME) sigma >> (local f m) = local f (put sigma >> m).

  Variable local_throw : forall (A : Set) f t,
    local f (throw t) = throw t (A := A).
  Variable local_catch : forall (A : Set) e h f,
    local f (catch (A := A) e h) = catch (local f e) (fun t => local f (h t)).

  Variable catch_fail : forall (A : Set) h,
    catch (A := A) fail h = fail.
  Context {fail_neq_throw : forall A env env',
    put env >> fail (M := ME) <> put env' >> throw (A := A) tt}.

  Context {Put_Exception_Disc :
    forall (A B : Set) (a : A) (mb : ME B) env n,
      (put env >>= fun _ => return_ a) <> mb >>= fun _ => throw n}.

  Context {put_catch : forall (A : Set) (env : list (Value V)) e h,
    put env >>= (fun _ => catch (A := A) e h) = catch (put env >>= fun _ => e) h}.
  Context {put_throw : forall (A B : Set) (env env' : list (Value V)) t,
    put env >>= (fun _ => throw t (A := A)) = put env' >>= (fun _ => throw t) ->
    put env >>= (fun _ => throw t (A := B)) = put env' >>= (fun _ => throw t)}.

  Context {ME_eq_dec' : forall (A : Set) (mte : ME A) (env gamma'' : list (Names.Value V)),
    (exists a : A, exists env' : list (Names.Value V),
      put env >> (local (fun _ => gamma'') mte) = put env' >> return_ a) \/
    (exists env', put env >> (local (fun _ => gamma'') mte) = put env' >> fail) \/
    (exists env', put env >> (local (fun _ => gamma'') mte) = put env' >> throw tt)}.

  Instance Except_State_Sound_X_WFVM :
    iPAlgebra Except_State_Sound_X_Name (Except_State_Sound_X_P D V MT ME WFV) WFVM.
  Proof.
    eauto 850 with typeclass_instances.
  Qed.

  Theorem eval_Sound :
    forall (n : nat) Sigma gamma gamma' gamma'' e' e'',
      E_eqvC E EQV_E gamma' gamma e'' e' ->
      forall (WF_gamma : forall n b, lookup gamma' n = Some b ->
        exists T, lookup gamma b = Some T)
      (WF_gamma'' : WF_Environment _ _ _ WFV Sigma gamma'' gamma)
      (WF_gamma2 : List.length gamma = List.length gamma')
      (WF_gamma' : forall n b, lookup gamma' n = Some b -> b = n)
      (WF_Sigma : Gamma D Sigma = gamma)
      (T : DType D)
      (env : Env (Names.Value V))
      (WF_env : WF_Environment _ _ _ WFV Sigma env (fst Sigma)),
      typeof D (E (DType D)) MT (proj1_sig e') = return_ T ->
      (exists env', put env >>
        local (M := ME) (fun _ => gamma'') (bevalM V E ME n e'') = put env' >> fail) \/
      (exists t, exists env', exists Sigma',
        put env >> local (M := ME) (fun _ => gamma'') (bevalM V E ME n e'') = put env' >> throw t
        /\ WF_Environment D V _ WFV Sigma' env' (fst Sigma')
        /\ ConsExtension Sigma' Sigma) \/
        exists v : Value V,
          exists env' : Env (Value V),
          exists Sigma' ,
            ConsExtension Sigma' Sigma /\
          put env >> local (M := ME) (fun _ => gamma'') (bevalM V E ME n e'') =
          put env' >> return_ (M := ME) v /\ WFValueC _ _ _ WFV Sigma' v T
          /\ WF_Environment D V _ WFV Sigma' env' (fst Sigma').
  Proof.
    intros.
    apply Except_State_Sound_X with (EQV_E := EQV_E) (WFVM := WFVM) (Mon_MT := monad)
      (Typeof_E := typeof_alg) (gamma := gamma) (gamma' := gamma') (e' := e');
      eauto 250 with typeclass_instances.
  Qed.

  Open Scope string_scope.

  Eval compute in ("Type Soundness for Arith + Bool + Ref + Lambda + Exception Proven!").

End Test_Section.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Import
        Fiat.BinEncoders.Env.Common.Specs
        Fiat.BinEncoders.Env.Lib2.Word.
Require Import
        Bedrock.Word
        Coq.Strings.Ascii
        Coq.Numbers.BinNums
        Coq.NArith.BinNat.

Section Ascii.
  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {transformer : Transformer B}.
  Context {transformerUnit : TransformerUnit transformer bool}.

  Definition encode_ascii (c : ascii) (ce : CacheEncode) : B * CacheEncode :=
    encode_word (NToWord 8 (N_of_ascii c)) ce.

  Definition decode_ascii (b : B) (cd : CacheDecode) : ascii * B * CacheDecode :=
    let (bundle, cd) := decode_word (sz:=8) b cd in
    let (n, b) := bundle in
        (ascii_of_N (wordToN n), b, cd).

  Open Local Scope nat.
  Theorem Ascii_decode_correct :
    encode_decode_correct cache transformer (fun n => True) encode_ascii decode_ascii.
  Proof.
    unfold encode_decode_correct, encode_ascii, decode_ascii.
    intros env env' xenv xenv' c c' bin' ext ext' Eeq Ppred Penc Pdec.
    destruct (decode_word (transform bin' ext) env') as [[? ?] ?] eqn: ?.
    inversion Pdec; subst; clear Pdec.
    pose proof (Word_decode_correct env env' xenv xenv' (NToWord 8 (N_of_ascii c)) w
                  bin' ext ext' Eeq I Penc Heqp).
    intuition eauto.
    rewrite <- H. clear.
    rewrite wordToN_nat. rewrite NToWord_nat.
    destruct (wordToNat_natToWord' 8 (BinNat.N.to_nat (N_of_ascii c))).
    assert (x = 0).
    { destruct x; eauto; exfalso.
      remember (wordToNat (natToWord 8 (BinNat.N.to_nat (N_of_ascii c)))) as xx; clear Heqxx.
      replace (xx + S x * pow2 8) with (256 + (xx + x * 256)) in H.
      assert (BinNat.N.to_nat (N_of_ascii c) < 256).
      assert (N.lt (N_of_ascii c) 256).
      clear H. induction c; repeat (match goal with
                                    | B : bool |- _ => destruct B
                                    end); simpl; unfold Nlt; eauto.
      change (256%nat) with (N.to_nat 256).
      apply Nomega.Nlt_out. eauto.
      omega. change (pow2 8) with 256. omega.
    }
    subst. rewrite <- plus_n_O in H. rewrite H. clear H.
    rewrite Nnat.N2Nat.id. rewrite ascii_N_embedding. eauto.
  Qed.
End Ascii.


Require Export MicroBFT.
Require Export MicroBFTtacts.
Require Export ComponentAxiom.
Require Export CalculusSM.

Section MicroBFTkn.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc                 : DTimeContext          }.
  Context { microbft_context    : MicroBFT_context      }.
  Context { m_initial_keys      : MicroBFT_initial_keys }.
  Context { u_initial_keys      : USIG_initial_keys     }.
  Context { usig_hash           : USIG_hash             }.
  Context { microbft_auth       : MicroBFT_auth         }.

  (* === INSTANTIATION OF ComponentTrust === *)

  Definition auth_data2ui (a : AuthenticatedData) : list UI :=
    match a with
    | MkAuthData (MicroBFT_msg_bare_request _ pui) [d] => [Build_UI pui d]
    | _ => []
    end.

  Definition USIG_output_interface2ui (cn : PreCompName) (o : USIG_output_interface) : option UI :=
    match o with
    | create_ui_out ui => Some ui
    | verify_ui_out b => None
    | verify_ui_out_def => None
    end.

  Global Instance MicroBFT_I_ComponentTrust : ComponentTrust :=
    MkComponentTrust
      UI
      auth_data2ui
      USIG_output_interface2ui
      (fun n => Some (ui2rep n)).

  (* === ======================== === *)

  (* === INSTANTIATION OF ComponentAuth === *)

  Definition MicroBFT_ca_create (eo : EventOrdering) (e : Event) (a : MicroBFT_Bare_Msg) : list MicroBFT_digest :=
    match a with
    | MicroBFT_msg_bare_request n pui =>
      match M_byz_state_sys_before_event MicroBFTsys e USIGname with
      | Some u => [ui2digest (snd (create_UI n u))]
      | None => []
      end
    end.

  Definition MicroBFT_ca_verify (eo : EventOrdering) (e : Event) (a : AuthenticatedData) : bool :=
    match a with
    | MkAuthData (MicroBFT_msg_bare_request n pui) [d] =>
      match M_byz_state_sys_before_event MicroBFTsys e USIGname with
      | Some u =>
        verify_UI n (Build_UI pui d) u
      | None => false
      end

   | _ => false
    end.

  Global Instance MicroBFT_I_ComponentAuth : ComponentAuth :=
    MkComponentAuth
      MicroBFT_ca_create
      MicroBFT_ca_verify.

  (* === ======================== === *)

  (* === INSTANTIATION OF KnowledgeComponents === *)

  Inductive MicroBFT_data :=
  | microbft_data_rdata (c  : Commit)
  | microbft_data_acc   (a  : Accept)
  | microbft_data_ui    (ui : UI).

  Lemma microbft_data_ui_inj : injective microbft_data_ui.
  Proof.
    introv h; inversion h; auto.
  Qed.

  Definition Request2HashData (c : Commit) : HashData :=
    Build_HashData
      (commit_n c)
      (ui_pre (commit_ui c)).

  Definition accept2hdata (a : Accept) : HashData :=
    Build_HashData
      (accept_r a)
      (Build_preUI MicroBFT_primary (accept_c a)).

  Definition data2hdata (d : MicroBFT_data) : option HashData :=
    match d with
    | microbft_data_rdata rd => Some (Request2HashData rd)
    | microbft_data_acc a => Some (accept2hdata a)
    | microbft_data_ui _ => None
    end.

  Definition hash_data2id (h : HashData) : MicroBFT_node :=
    pre_ui_id (hd_pre h).

  Definition MicroBFT_data2owner (d : MicroBFT_data) : option node_type :=
    match d with
    | microbft_data_rdata rd => Some (commit2sender rd)
    | microbft_data_acc a => None (*Some MicroBFT_primary*)
    | microbft_data_ui ui => Some (ui2rep ui)
    end.

  Definition MicroBFT_auth2data (a : AuthenticatedData) : list MicroBFT_data :=
    match a with
    | MkAuthData (MicroBFT_msg_bare_request n pui) [d] =>
      let ui := Build_UI pui d in
      [microbft_data_rdata (commit n ui),
       microbft_data_ui ui]

    | _ => []
    end.

  Definition MicroBFT_data2trust (d : MicroBFT_data) : list UI :=
    match d with
    | microbft_data_rdata rd => [commit_ui rd]
    | microbft_data_acc a => []
    | microbft_data_ui ui => [ui]
    end.

  Lemma MicroBFT_data2trust_correct : forall t, In t (MicroBFT_data2trust (microbft_data_ui t)).
  Proof.
    introv; simpl; tcsp.
  Qed.

  Lemma MicroBFT_auth2trust_correct :
    forall a t,
      In t (auth_data2ui a)
      <-> exists d, In t (MicroBFT_data2trust d) /\ In d (MicroBFT_auth2data a).
  Proof.
    introv.
    destruct a as [ad tok], ad; simpl; tcsp; split; intro h; exrepnd; tcsp;[|].

    { repeat (destruct tok; simpl in *; tcsp).
      repndors; subst; tcsp.
      exists (microbft_data_ui (Build_UI pui t0)); simpl; tcsp. }

    { repeat (destruct tok; simpl in *; tcsp).
      repndors; subst; tcsp. }
  Qed.

  Definition generated_for (d : MicroBFT_data) (ui : UI) :=
    match d with
    | microbft_data_rdata rd =>
      commit_ui rd = ui
      /\ exists r, verify_hash_usig (Request2HashData rd) (ui2digest ui) (usig_initial_keys r) = true
      (*/\ create_hash_usig (Request2HashData rd) (usig_initial_keys (ui2rep ui)) = ui2digest ui*)
    | microbft_data_acc a =>
      (*create_hash_usig (accept2hdata a) (usig_initial_keys (ui2rep ui)) = ui2digest ui
      /\*) exists r, verify_hash_usig (accept2hdata a) (ui2digest ui) (usig_initial_keys r) = true
    | microbft_data_ui x => x = ui
    end.
  (* We're currently only ever using the same keys in all USIGs *)

  Definition similar_data (d1 d2 : MicroBFT_data) : Prop :=
    match d1, d2 with
    | microbft_data_rdata _, microbft_data_rdata _ => True
    | microbft_data_acc   _, microbft_data_acc   _ => True
    | microbft_data_ui    _, microbft_data_ui    _ => True
    | _, _ => False
    end.

  Lemma similar_data_sym : symmetric _ similar_data.
  Proof.
    introv sim; unfold similar_data in *; destruct x, y; tcsp.
  Qed.

  Parameter collision_resistant :
    forall (ui : UI) (d1 d2 : MicroBFT_data),
      generated_for d1 ui -> generated_for d2 ui -> similar_data d1 d2 -> d1 = d2.

  Lemma same_ui2owner :
    forall (t : UI), MicroBFT_data2owner (microbft_data_ui t) = Some (ui2rep t).
  Proof.
    tcsp.
  Qed.

  Definition ui_in_log_entry (ui : UI) (e : Commit) : bool :=
    if UI_dec ui (commit_ui e)  then true else false.

  Definition ui_in_log ui l : bool :=
    existsb (ui_in_log_entry ui) l.

  Lemma HashData_Deq : Deq HashData.
  Proof.
    repeat introv.
    destruct x as [n1 pui1], y as [n2 pui2].

    destruct (deq_nat n1 n2); subst; prove_dec.

    destruct pui1 as [id1 counter1], pui2 as [id2 counter2].
    destruct (deq_nat counter1 counter2); subst; prove_dec.

    destruct id1, id2; prove_dec.
  Defined.

  Definition RequestAndUI2HashData (n : nat) (ui : UI) : HashData :=
    Build_HashData
      n
      (ui_pre ui).

  Definition hash_data_in_log_entry (hd : HashData) (e : Commit) : bool :=
    if HashData_Deq hd (Request2HashData e) then true  else false.

  Definition hash_data_in_log (hd : HashData) (l : LOG_state) : bool :=
    existsb (hash_data_in_log_entry hd) l.

  Definition in_log (rd : Commit) (l : LOG_state) : Prop := In rd l.

  Definition Request_dec : Deq Commit.
  Proof.
    introv.
    destruct x as [n1 ui1], y as [n2 ui2].
    destruct (deq_nat n1 n2); subst; prove_dec.
    destruct (UI_dec ui1 ui2); subst; prove_dec.
  Defined.

  Definition request_in_log (r : Commit) (l : LOG_state) : bool :=
    if in_dec Request_dec r l then true else false.

  Definition MicroBFT_data_in_log (d : MicroBFT_data) (l : LOG_state) :=
    match d with
    | microbft_data_rdata   rd => request_in_log rd l
    | microbft_data_acc     a  => false
    | microbft_data_ui      ui => ui_in_log ui l
    end.

  Definition MicroBFT_data_knows (d : MicroBFT_data) (l : LOG_state) : Prop :=
    MicroBFT_data_in_log d l = true.

  Lemma MicroBFT_data_knows_dec : forall (d : MicroBFT_data) (m : LOG_state), decidable (MicroBFT_data_knows d m).
  Proof.
    introv.
    unfold MicroBFT_data_knows.
    destruct (MicroBFT_data_in_log d m); prove_dec.
  Defined.

  Lemma no_initial_memory :
    forall n i, on_state_of_component LOGname (MicroBFTsys n) (fun s => ~ MicroBFT_data_knows i s).
  Proof.
    introv.
    unfold on_state_of_component; simpl.
    destruct n; simpl; auto;
      try (complete (intro h; unfold MicroBFT_data_knows in h; simpl in *; destruct i; simpl in *; ginv)).
  Qed.

  Lemma ui_characterization :
    forall t1 t2,
      ui2counter t1 = ui2counter t2
      -> ui2rep t1 = ui2rep t2
      -> ui2digest t1 = ui2digest t2
      -> t1 = t2.
  Proof.
    introv h q w.
    destruct t1 as [p1 d1], t2 as [p2 d2], p1, p2; simpl in *.
    unfold ui2counter, ui2rep in *; simpl in *; subst; tcsp.
  Qed.

  Definition MicroBFTmsg2data (m : MicroBFT_msg) : list MicroBFT_data :=
    match m with
    | MicroBFT_request _ => []
    | MicroBFT_commit  c => [microbft_data_rdata c, microbft_data_ui (commit_ui c)]
    | MicroBFT_accept  a => [microbft_data_acc a]
    end.

  Lemma lt_transitive : transitive _ lt.
  Proof.
    introv; omega.
  Qed.

  Lemma lt_antireflexive : antireflexive lt.
  Proof.
    introv; omega.
  Qed.

  Definition ui_has_counter (ui : UI) (c : nat) :=
    ui2counter ui = c.

  Definition similar_ui (ui1 ui2 : UI) : Prop := True.

  Lemma similar_ui_pres :
    forall t t' a b,
      ui_has_counter t a
      -> ui_has_counter t b
      -> similar_ui t t'
      -> ui_has_counter t' a
      -> ui_has_counter t' b.
  Proof.
    introv hca hcb sim hcc.
    unfold ui_has_counter, similar_ui in *; try congruence.
  Qed.

  Lemma similar_ui_equivalence : equivalence _ similar_ui.
  Proof.
    split; introv; tcsp.
  Qed.

  Lemma ui_has_counter_pres :
    forall t a b c,
      ui_has_counter t a
      -> ui_has_counter t c
      -> (a < b \/ a = b)
      -> (b < c \/ b = c)
      -> ui_has_counter t b.
  Proof.
    introv hca hcb h q.
    unfold ui_has_counter in *; subst; repndors; tcsp; try omega.
  Qed.

  Definition init_counter : nat := 0.

  Lemma init_counter_cond :
    forall n : node_type,
    exists m,
      state_of_component USIGname (MicroBFTsys (node2name n)) = Some m
      /\ usig_counter m = init_counter.
  Proof.
    introv; simpl.
    unfold state_of_component; simpl.
    eexists; dands; eauto.
  Qed.

  Definition ext_prim := True.
  Definition ext_prim_interp : forall (eo : EventOrdering) (e : Event), ext_prim -> Prop :=
    fun eo e p => True.

  Global Instance MicroBFT_I_KnowledgeComponents : KnowledgeComponents :=
    MkKnowledgeComponents
      MicroBFT_data
      microbft_data_ui
      microbft_data_ui_inj
      generated_for
      similar_data
      similar_data_sym
      collision_resistant
      MicroBFT_data2owner
      same_ui2owner
      MicroBFT_auth2data
      MicroBFT_data2trust
      MicroBFT_data2trust_correct
      MicroBFT_auth2trust_correct
      LOGname
      preUSIGname
      MicroBFT_data_knows
      MicroBFT_data_knows_dec
      MicroBFTfunLevelSpace
      MicroBFTsys
      no_initial_memory
      MicroBFTmsg2data
      nat
      lt
      lt_transitive
      lt_antireflexive
      ui_has_counter
      ui_has_counter_pres
      similar_ui
      similar_ui_equivalence
      similar_ui_pres
      usig_counter
      ext_prim
      ext_prim_interp.

  (* === ======================== === *)

End MicroBFTkn.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj9synthconj5 : forall  (lv0 : natural), (@eq natural (Succ lv0) (plus Zero (Succ lv0))).
Admitted.
QuickChick conj9synthconj5.


Set Implicit Arguments.
Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export Infrastructure.

Lemma WF_type: forall E T,
    WF E T -> type T.
Proof with auto.
  intros.
  induction H...
  apply type_all with (L:=L)...
  apply type_all_lb with (L:=L)...
  apply type_mu with (L:=L)...
Qed.

Lemma WF_weakening: forall E1 E2 T E,
    WF (E1 ++ E2) T ->
    WF (E1 ++ E ++ E2) T.
Proof with eauto.
  intros.
  generalize dependent E.
  dependent induction H;intros...
  -
    apply WF_all with (L:=L)...
    intros.
    rewrite_alist (([(X, bind_sub T1)] ++ E1) ++ E ++ E2).
    apply H1...
  -
    apply WF_all_lb with (L:=L)...
    intros.
    rewrite_alist (([(X, bind_sub_lb T1)] ++ E1) ++ E ++ E2).
    apply H1...
  -
    apply WF_rec with (L:=L)...
    intros.
    rewrite_alist (([(X, bind_sub typ_top)] ++ E1) ++ E ++ E2).
    apply H0...
    intros.
    rewrite_alist (([(X, bind_sub typ_top)] ++ E1) ++ E ++ E2).
    apply H2...
Qed.

Lemma WF_narrowing : forall V U T E F X,
  WF (F ++ X ~ bind_sub V ++ E) T ->
  WF (F ++ X ~ bind_sub U ++ E) T.
Proof with eauto.
  intros.
  dependent induction H;try solve [analyze_binds H;eauto]...
  -
    apply WF_all with (L:=L)...
    intros.
    rewrite_alist (([(X0, bind_sub T1)] ++ F) ++ [(X, bind_sub U)] ++ E)...
    eapply H1 with (V0:=V)...
  -
    apply WF_all_lb with (L:=L)...
    intros.
    rewrite_alist (([(X0, bind_sub_lb T1)] ++ F) ++ [(X, bind_sub U)] ++ E)...
    eapply H1 with (V0:=V)...
  -
    apply WF_rec with (L:=L);intros...
    rewrite_alist (([(X0, bind_sub typ_top)] ++ F) ++ [(X, bind_sub U)] ++ E)...
    eapply H0 with (V0:=V)...
    rewrite_alist (([(X0, bind_sub typ_top)] ++ F) ++ [(X, bind_sub U)] ++ E)...
    eapply H2 with (V0:=V)...
Qed.

Lemma WF_narrowing_lb : forall V U T E F X,
  WF (F ++ X ~ bind_sub_lb V ++ E) T ->
  WF (F ++ X ~ bind_sub_lb U ++ E) T.
Proof with eauto.
  intros.
  dependent induction H;try solve [analyze_binds H;eauto]...
  -
    apply WF_all with (L:=L)...
    intros.
    rewrite_alist (([(X0, bind_sub T1)] ++ F) ++ [(X, bind_sub_lb U)] ++ E)...
    eapply H1 with (V0:=V)...
  -
    apply WF_all_lb with (L:=L)...
    intros.
    rewrite_alist (([(X0, bind_sub_lb T1)] ++ F) ++ [(X, bind_sub_lb U)] ++ E)...
    eapply H1 with (V0:=V)...
  -
    apply WF_rec with (L:=L);intros...
    rewrite_alist (([(X0, bind_sub typ_top)] ++ F) ++ [(X, bind_sub_lb U)] ++ E)...
    eapply H0 with (V0:=V)...
    rewrite_alist (([(X0, bind_sub typ_top)] ++ F) ++ [(X, bind_sub_lb U)] ++ E)...
    eapply H2 with (V0:=V)...
Qed.

Lemma subst_tt_open_tt_twice: forall X X0 A A0,
    X <> X0 -> type A0 ->
      (subst_tt X A0 (open_tt A (typ_label X0 (open_tt A X0)))) =
      (open_tt (subst_tt X A0 A) (typ_label X0 (open_tt (subst_tt X A0 A) X0))).
Proof with auto.
  intros.
  rewrite subst_tt_open_tt...
  f_equal...
  simpl...
  f_equal...
  rewrite subst_tt_open_tt_var...
Qed.

Lemma subst_tt_wf : forall E A B X,
    WF E A ->
    WF E B ->
    WF E (subst_tt X A B).
Proof with auto.
  intros.
  generalize dependent A.
  induction H0;intros;simpl...
  -
    destruct (X0==X)...
    apply WF_var with (U:=U)...
  -
    destruct (X0==X)...
    apply WF_var_lb with (U:=U)...
  -
    apply WF_all with (L:=L \u fv_tt A \u {{X}})...
    intros.
    rewrite subst_tt_open_tt_var...
    add_nil.
    apply WF_narrowing with (V:=T1)...
    apply H1...
    add_nil.
    apply WF_weakening...
    apply WF_type in H2...
  -
    apply WF_all_lb with (L:=L \u fv_tt A \u {{X}})...
    intros.
    rewrite subst_tt_open_tt_var...
    add_nil.
    apply WF_narrowing_lb with (V:=T1)...
    apply H1...
    add_nil.
    apply WF_weakening...
    apply WF_type in H2...
  -
    apply WF_rec with (L:=L \u fv_tt A \u {{X}});intros...
    rewrite subst_tt_open_tt_var...
    apply H0...
    add_nil.
    apply WF_weakening...
    apply WF_type in H3...
    rewrite <- subst_tt_open_tt_twice...
    apply H2...
    add_nil.
    apply WF_weakening...
    apply WF_type in H3...
Qed.

Lemma binds_map_free: forall F X  Y U  P,
    In (X, bind_sub U) F ->
    X <> Y ->
    In (X, bind_sub (subst_tt Y P U)) (map (subst_tb Y P) F).
Proof with auto.
  induction F;intros...
  apply in_inv in H.
  destruct H...
  -
    destruct a.
    inversion H;subst.
    simpl...
  -
    simpl...
Qed.

Lemma binds_map_free_lb: forall F X  Y U  P,
    In (X, bind_sub_lb U) F ->
    X <> Y ->
    In (X, bind_sub_lb (subst_tt Y P U)) (map (subst_tb Y P) F).
Proof with auto.
  induction F;intros...
  apply in_inv in H.
  destruct H...
  -
    destruct a.
    inversion H;subst.
    simpl...
  -
    simpl...
Qed.

Lemma subst_tb_wf : forall F Q E Z P T,
  WF (F ++ Z ~ Q ++ E) T ->
  WF E P ->
  WF (map (subst_tb Z P) F ++ E) (subst_tt Z P T).
Proof with eauto.
  intros.
  generalize dependent P.
  dependent induction H;intros;simpl in *...
  -
    destruct (X==Z);subst...
    add_nil.
    apply WF_weakening...
    analyze_binds H...
    apply WF_var with (U:=(subst_tt Z P U))...
    unfold binds in *.
    apply In_lemmaL.
    apply binds_map_free...
  -
    destruct (X==Z);subst...
    add_nil.
    apply WF_weakening...
    analyze_binds H...
    apply WF_var_lb with (U:=(subst_tt Z P U))...
    unfold binds in *.
    apply In_lemmaL.
    apply binds_map_free_lb...
  -
    apply WF_all with (L:=L \u {{Z}})...
    intros.
    rewrite subst_tt_open_tt_var...
    rewrite_env (map (subst_tb Z P) (X ~ bind_sub T1 ++ F) ++ E).
    apply H1 with (Q0:=Q)...
    apply WF_type in H2...
  -
    apply WF_all_lb with (L:=L \u {{Z}})...
    intros.
    rewrite subst_tt_open_tt_var...
    rewrite_env (map (subst_tb Z P) (X ~ bind_sub_lb T1 ++ F) ++ E).
    apply H1 with (Q0:=Q)...
    apply WF_type in H2...
  -
    apply WF_rec with (L:=L \u {{Z}});intros...
    rewrite subst_tt_open_tt_var...
    rewrite_env (map (subst_tb Z P) (X ~ bind_sub typ_top ++ F) ++ E).
    apply H0 with (Q0:=Q)...
    apply WF_type in H3...
    rewrite <- subst_tt_open_tt_twice...
    rewrite_env (map (subst_tb Z P) (X ~ bind_sub typ_top ++ F) ++ E).
    apply H2 with (Q0:=Q)...
    apply WF_type in H3...

Qed.

Lemma subst_tb_wf2 : forall F Q E Z P T,
  WF (F ++ Z ~ Q ++ E) T ->
  WF (Z ~ Q ++ E) P ->
  WF (map (subst_tb Z P) F ++ Z~Q ++ E) (subst_tt Z P T).
Proof with eauto.
  intros.
  generalize dependent P.
  dependent induction H;intros;simpl in *...
  -
    destruct (X==Z);subst...
    add_nil.
    apply WF_weakening...
    analyze_binds H...
    apply WF_var with (U:=(subst_tt Z P U))...
    unfold binds in *.
    apply In_lemmaL.
    apply binds_map_free...
  -
    destruct (X==Z);subst...
    add_nil.
    apply WF_weakening...
    analyze_binds H...
    apply WF_var_lb with (U:=(subst_tt Z P U))...
    unfold binds in *.
    apply In_lemmaL.
    apply binds_map_free_lb...
  -
    apply WF_all with (L:=L \u {{Z}})...
    intros.
    rewrite subst_tt_open_tt_var...
    rewrite_env (map (subst_tb Z P) (X ~ bind_sub T1 ++ F) ++ (Z,Q):: E).
    apply H1 with (Q0:=Q)...
    apply WF_type in H2...
  -
    apply WF_all_lb with (L:=L \u {{Z}})...
    intros.
    rewrite subst_tt_open_tt_var...
    rewrite_env (map (subst_tb Z P) (X ~ bind_sub_lb T1 ++ F) ++ (Z,Q):: E).
    apply H1 with (Q0:=Q)...
    apply WF_type in H2...
  -
    apply WF_rec with (L:=L \u {{Z}});intros...
    rewrite subst_tt_open_tt_var...
    rewrite_env (map (subst_tb Z P) (X ~ bind_sub typ_top ++ F) ++ (Z,Q)::E).
    apply H0 with (Q0:=Q)...
    apply WF_type in H3...
    rewrite <- subst_tt_open_tt_twice...
    rewrite_env (map (subst_tb Z P) (X ~ bind_sub typ_top ++ F) ++ (Z,Q)::E).
    apply H2 with (Q0:=Q)...
    apply WF_type in H3...
Qed.

Lemma subst_tb_wf3 : forall F  E Z P T S,
  WF (F ++ Z ~ bind_sub S ++ E) T ->
  WF E P ->
  WF (map (subst_tb Z S) F ++ E) (subst_tt Z P T).
Proof with eauto.
  intros.
  generalize dependent P.
  dependent induction H;intros;simpl in *...
  -
    destruct (X==Z);subst...
    add_nil.
    apply WF_weakening...
    analyze_binds H...
    apply WF_var with (U:=(subst_tt Z S U))...
    unfold binds in *.
    apply In_lemmaL.
    apply binds_map_free...
  -
    destruct (X==Z);subst...
    add_nil.
    apply WF_weakening...
    analyze_binds H...
    apply WF_var_lb with (U:=(subst_tt Z S U))...
    unfold binds in *.
    apply In_lemmaL.
    apply binds_map_free_lb...
  -
    apply WF_all with (L:=L \u {{Z}})...
    intros.
    rewrite subst_tt_open_tt_var...
    add_nil.
    apply WF_narrowing with (V:=subst_tt Z S T1)...
    rewrite_env (map (subst_tb Z S) (X ~ bind_sub T1 ++ F) ++ E).
    apply H1 with (S0:=S)...
    apply WF_type in H2...
  -
    apply WF_all_lb with (L:=L \u {{Z}})...
    intros.
    rewrite subst_tt_open_tt_var...
    add_nil.
    apply WF_narrowing_lb with (V:=subst_tt Z S T1)...
    rewrite_env (map (subst_tb Z S) (X ~ bind_sub_lb T1 ++ F) ++ E).
    apply H1 with (S0:=S)...
    apply WF_type in H2...
  -
    apply WF_rec with (L:=L \u {{Z}});intros...
    rewrite subst_tt_open_tt_var...
    rewrite_env (map (subst_tb Z S) (X ~ bind_sub typ_top ++ F) ++ E).
    apply H0 with (S0:=S)...
    apply WF_type in H3...
    rewrite <- subst_tt_open_tt_twice...
    rewrite_env (map (subst_tb Z S) (X ~ bind_sub typ_top ++ F) ++ E).
    apply H2 with (S0:=S)...
    apply WF_type in H3...
Qed.

Lemma subst_tb_wf3_lb : forall F  E Z P T S,
  WF (F ++ Z ~ bind_sub_lb S ++ E) T ->
  WF E P ->
  WF (map (subst_tb Z S) F ++ E) (subst_tt Z P T).
Proof with eauto.
  intros.
  generalize dependent P.
  dependent induction H;intros;simpl in *...
  -
    destruct (X==Z);subst...
    add_nil.
    apply WF_weakening...
    analyze_binds H...
    apply WF_var with (U:=(subst_tt Z S U))...
    unfold binds in *.
    apply In_lemmaL.
    apply binds_map_free...
  -
    destruct (X==Z);subst...
    add_nil.
    apply WF_weakening...
    analyze_binds H...
    apply WF_var_lb with (U:=(subst_tt Z S U))...
    unfold binds in *.
    apply In_lemmaL.
    apply binds_map_free_lb...
  -
    apply WF_all with (L:=L \u {{Z}})...
    intros.
    rewrite subst_tt_open_tt_var...
    add_nil.
    apply WF_narrowing with (V:=subst_tt Z S T1)...
    rewrite_env (map (subst_tb Z S) (X ~ bind_sub T1 ++ F) ++ E).
    apply H1 with (S0:=S)...
    apply WF_type in H2...
  -
    apply WF_all_lb with (L:=L \u {{Z}})...
    intros.
    rewrite subst_tt_open_tt_var...
    add_nil.
    apply WF_narrowing_lb with (V:=subst_tt Z S T1)...
    rewrite_env (map (subst_tb Z S) (X ~ bind_sub_lb T1 ++ F) ++ E).
    apply H1 with (S0:=S)...
    apply WF_type in H2...
  -
    apply WF_rec with (L:=L \u {{Z}});intros...
    rewrite subst_tt_open_tt_var...
    rewrite_env (map (subst_tb Z S) (X ~ bind_sub typ_top ++ F) ++ E).
    apply H0 with (S0:=S)...
    apply WF_type in H3...
    rewrite <- subst_tt_open_tt_twice...
    rewrite_env (map (subst_tb Z S) (X ~ bind_sub typ_top ++ F) ++ E).
    apply H2 with (S0:=S)...
    apply WF_type in H3...
Qed.

Lemma WF_renaming: forall E1 E2 X Y A T,
    WF (E1 ++ X ~ bind_sub T ++ E2) A ->
    Y \notin {{X}} \u fv_tt A ->
    WF (map (subst_tb X Y) E1 ++ Y ~ bind_sub T ++ E2) (subst_tt X Y A).
Proof with auto.
  intros.
  dependent induction H;simpl in *...
  -
    destruct (X0==X)...
    apply WF_var with (U:=T)...
    analyze_binds H...
    apply WF_var with (U:=subst_tt X Y U)...
    apply In_lemmaL.
    apply  binds_map_free...
    apply WF_var with (U:=U)...
  -
    destruct (X0==X)...
    apply WF_var with (U:=T)...
    analyze_binds H...
    apply WF_var_lb with (U:=subst_tt X Y U)...
    apply In_lemmaL.
    apply  binds_map_free_lb...
    apply WF_var_lb with (U:=U)...
  -
    apply WF_all with (L:=L \u {{X}} \u {{Y}})...
    intros.
    rewrite subst_tt_open_tt_var...
    rewrite_env ((map (subst_tb X Y) (X0 ~ bind_sub T1 ++ E1)) ++ (Y, bind_sub T) :: E2).
    apply H1...
    solve_notin.
  - apply WF_all_lb with (L:=L \u {{X}} \u {{Y}})...
    intros.
    rewrite subst_tt_open_tt_var...
    rewrite_env ((map (subst_tb X Y) (X0 ~ bind_sub_lb T1 ++ E1)) ++ (Y, bind_sub T) :: E2).
    apply H1...
    solve_notin.
  -
    apply WF_rec with (L:=L \u {{X}} \u {{Y}});intros.
    rewrite subst_tt_open_tt_var...
    rewrite_env ((map (subst_tb X Y) (X0 ~ bind_sub typ_top ++ E1)) ++ (Y, bind_sub T) :: E2).
    apply H0...
    solve_notin.
    rewrite <- subst_tt_open_tt_twice...
    rewrite_env ((map (subst_tb X Y) (X0 ~ bind_sub typ_top ++ E1)) ++ (Y, bind_sub T) :: E2).
    apply H2...
    solve_notin.
Qed.

Lemma WF_renaming_lb: forall E1 E2 X Y A T,
    WF (E1 ++ X ~ bind_sub_lb T ++ E2) A ->
    Y \notin {{X}} \u fv_tt A ->
    WF (map (subst_tb X Y) E1 ++ Y ~ bind_sub_lb T ++ E2) (subst_tt X Y A).
Proof with auto.
  intros.
  dependent induction H;simpl in *...
  -
    destruct (X0==X)...
    apply WF_var_lb with (U:=T)...
    analyze_binds H...
    apply WF_var with (U:=subst_tt X Y U)...
    apply In_lemmaL.
    apply  binds_map_free...
    apply WF_var with (U:=U)...
  -
    destruct (X0==X)...
    apply WF_var_lb with (U:=T)...
    analyze_binds H...
    apply WF_var_lb with (U:=subst_tt X Y U)...
    apply In_lemmaL.
    apply  binds_map_free_lb...
    apply WF_var_lb with (U:=U)...
  -
    apply WF_all with (L:=L \u {{X}} \u {{Y}})...
    intros.
    rewrite subst_tt_open_tt_var...
    rewrite_env ((map (subst_tb X Y) (X0 ~ bind_sub T1 ++ E1)) ++ (Y, bind_sub_lb T) :: E2).
    apply H1...
    solve_notin.
  - apply WF_all_lb with (L:=L \u {{X}} \u {{Y}})...
    intros.
    rewrite subst_tt_open_tt_var...
    rewrite_env ((map (subst_tb X Y) (X0 ~ bind_sub_lb T1 ++ E1)) ++ (Y, bind_sub_lb T) :: E2).
    apply H1...
    solve_notin.
  -
    apply WF_rec with (L:=L \u {{X}} \u {{Y}});intros.
    rewrite subst_tt_open_tt_var...
    rewrite_env ((map (subst_tb X Y) (X0 ~ bind_sub typ_top ++ E1)) ++ (Y, bind_sub_lb T) :: E2).
    apply H0...
    solve_notin.
    rewrite <- subst_tt_open_tt_twice...
    rewrite_env ((map (subst_tb X Y) (X0 ~ bind_sub typ_top ++ E1)) ++ (Y, bind_sub_lb T) :: E2).
    apply H2...
    solve_notin.
Qed.

Lemma sub_regular : forall E A B,
    sub E A B -> wf_env E /\ WF E A /\ WF E B.
Proof with auto.
  intros.
  induction H;destruct_hypos...
  -
    repeat split...
    apply WF_var with (U:=U)...
  -
    repeat split...
    apply WF_var_lb with (U:=U)...
  -
    repeat split...
    apply WF_all with (L:=L);intros...
    rewrite_env (nil ++ X ~ bind_sub S1 ++ E).
    eapply WF_narrowing with (V:=S2)...
    eapply H2...
    apply WF_all with (L:=L);intros...
    eapply H2...
  -
    repeat split...
    apply WF_all_lb with (L:=L);intros...
    rewrite_env (nil ++ X ~ bind_sub_lb S1 ++ E).
    eapply WF_narrowing_lb with (V:=S2)...
    eapply H2...
    apply WF_all_lb with (L:=L);intros...
    eapply H2...
  -
    split.
    pick fresh X.
    specialize_x_and_L X L.
    destruct_hypos.
    dependent destruction H2...
    split...
    +
      apply WF_rec with (L:=L \u fv_tt A1 \u fv_tt A2);intros...
      eapply H2...
    +
      apply WF_rec with (L:=L \u fv_tt A1 \u fv_tt A2);intros...
      eapply H2...
Qed.

Ltac get_well_form :=
    repeat match goal with
    | [ H : sub _ _ _ |- _ ] => apply sub_regular in H;destruct_hypos
           end.

Ltac get_type :=
    repeat match goal with
           | [ H : sub _ _ _ |- _ ] => get_well_form
           | [ H : WF _ _ |- _ ] => apply WF_type in H
           end.

Lemma Reflexivity: forall E A,
    WF E A ->
    wf_env E ->
    sub E A A.
Proof with auto.
  intros.
  induction H...
  -
    constructor...
    apply WF_var with (U:=U)...
  -
    constructor...
    apply WF_var_lb with (U:=U)...
  -
    apply sa_all with (L:=L \u dom E \u fv_env E \u fl_env E)...
  -
    apply sa_all_lb with (L:=L \u dom E \u fv_env E \u fl_env E)...
  -
    apply sa_rec with (L:=L \u dom E \u fv_env E \u fl_env E)...
Qed.

Lemma Sub_weakening: forall E1 E2 A B E,
    sub (E1 ++ E2) A B ->
    wf_env (E1 ++ E ++ E2) ->
    sub (E1 ++ E ++ E2) A B.
Proof with eauto using WF_weakening.
  intros.
  generalize dependent E.
  dependent induction H;intros...
  -
    apply sa_all with (L:=L \u dom E1 \u dom E2 \u dom E \u fv_env (E1++E++E2) \u fl_env (E1++E++E2))...
    intros.
    rewrite_alist (([(X, bind_sub S2)] ++ E1) ++ E ++ E2).
    apply H2...
    get_well_form.
    rewrite_alist ([(X, bind_sub S2)] ++ E1 ++ E ++ E2)...
  -
    apply sa_all_lb with (L:=L \u dom E1 \u dom E2 \u dom E \u fv_env (E1++E++E2) \u fl_env (E1++E++E2))...
    intros.
    rewrite_alist (([(X, bind_sub_lb S2)] ++ E1) ++ E ++ E2).
    apply H2...
    get_well_form.
    rewrite_alist ([(X, bind_sub_lb S2)] ++ E1 ++ E ++ E2)...
  -
    apply sa_rec with (L:=L \u dom E1 \u dom E2 \u dom E \u fv_env (E1++E++E2) \u fl_env (E1++E++E2));intros...
    rewrite_alist (([(X, bind_sub typ_top)] ++ E1) ++ E ++ E2)...
    apply WF_weakening...
    apply H...
    rewrite_alist (([(X, bind_sub typ_top)] ++ E1) ++ E ++ E2).
    apply WF_weakening...
    apply H0...
    rewrite_alist (([(X, bind_sub typ_top)] ++ E1) ++ E ++ E2).
    apply H2...
    rewrite_alist ([(X, bind_sub typ_top)] ++ E1 ++ E ++ E2)...
Qed.

Lemma uniq_from_wf_env : forall E,
  wf_env E ->
  uniq E.
Proof.
  intros E H; induction H; auto.
Qed.

Lemma in_binds: forall x a U x0,
    a `in` dom (x ++ (a, bind_sub U) :: x0).
Proof with auto.
  induction x;intros...
  simpl...
  simpl...
  destruct a...
Qed.

Lemma in_binds_lb: forall x a U x0,
    a `in` dom (x ++ (a, bind_sub_lb U) :: x0).
Proof with auto.
  induction x;intros...
  simpl...
  simpl...
  destruct a...
Qed.

Lemma union_subset_6: forall A B C,
    A [<=] B ->
    A [<=] union B C.
Proof with auto.
  intros.
  unfold "[<=]" in *.
  intros.
  apply H in H0...
Qed.

Lemma union_subset_7: forall A B C,
    union A B [<=] C ->
    A [<=] C /\ B [<=] C.
Proof with auto.
  intros.
  unfold "[<=]" in *.
  split;intros...
Qed.

Lemma fv_open_tt_notin: forall T S (X:atom),
    X \notin fv_tt T ->
    fv_tt T [<=] S ->
    fv_tt (open_tt T X) [<=] add X S.
Proof with auto.
  intros.
  unfold open_tt.
  generalize 0.
  induction T;intros;simpl in *;try solve [apply AtomSetProperties.subset_add_2;apply KeySetProperties.subset_empty]...
  -
    destruct (n0==n);simpl...
    unfold "[<=]".
    intros...
    apply AtomSetNotin.D.F.singleton_iff in H1...
    apply KeySetProperties.subset_empty.
  -
    apply AtomSetProperties.subset_add_2...
  -
    apply notin_union in H.
    apply union_subset_7 in H0.
    destruct_hypos.
    apply KeySetProperties.union_subset_3...
  -
    apply notin_union in H.
    apply union_subset_7 in H0.
    destruct_hypos.
    apply KeySetProperties.union_subset_3...
  -
    apply notin_union in H.
    apply union_subset_7 in H0.
    destruct_hypos.
    apply KeySetProperties.union_subset_3...
Qed.

Lemma fv_open_tt_notin_inv: forall T S (X:atom),
    X \notin fv_tt T ->
    fv_tt (open_tt T X) [<=] add X S ->
    fv_tt T [<=] S.
Proof with auto.
  intro T.
  unfold open_tt in *.
  generalize 0.
  induction T;intros;simpl in *;try solve [apply KeySetProperties.subset_empty]...
  -
    unfold "[<=]" in *.
    intros...
    apply AtomSetNotin.D.F.singleton_iff in H1...
    subst.
    assert (a0 `in` singleton a0) by auto.
    specialize (H0 a0 H1)...
    apply AtomSetImpl.add_3 in H0...
  -
    apply union_subset_7 in H0.
    apply notin_union in H.
    destruct_hypos.
    apply KeySetProperties.union_subset_3...
    apply IHT1 with (X:=X) (n:=n)...
    apply IHT2 with (X:=X) (n:=n)...
  -
    apply union_subset_7 in H0.
    apply notin_union in H.
    destruct_hypos.
    apply KeySetProperties.union_subset_3...
    apply IHT1 with (X:=X) (n:=n)...
    apply IHT2 with (X:=X) (n:=(Datatypes.S n))...
  -
    apply union_subset_7 in H0.
    apply notin_union in H.
    destruct_hypos.
    apply KeySetProperties.union_subset_3...
    apply IHT1 with (X:=X) (n:=n)...
    apply IHT2 with (X:=X) (n:=(Datatypes.S n))...
  -
    apply IHT with (X:=X) (n:=(Datatypes.S n))...
  -
    apply IHT with (X:=X) (n:=n)...
Qed.

Lemma fl_open_tt_notin_inv: forall T S (X:atom),
    X \notin fv_tt T \u fl_tt T ->
    fl_tt (open_tt T X) [<=] add X S ->
    fl_tt T [<=] S.
Proof with auto.
  intro T.
  unfold open_tt in *.
  generalize 0.
  induction T;intros;simpl in *;try solve [apply KeySetProperties.subset_empty]...
  -
    apply union_subset_7 in H0.
    apply notin_union in H.
    destruct_hypos.
    apply KeySetProperties.union_subset_3...
    apply IHT1 with (X:=X) (n:=n)...
    apply IHT2 with (X:=X) (n:=n)...
  -
    apply union_subset_7 in H0.
    apply notin_union in H.
    destruct_hypos.
    apply KeySetProperties.union_subset_3...
    apply IHT1 with (X:=X) (n:=n)...
    apply IHT2 with (X:=X) (n:=(Datatypes.S n))...
  -
    apply union_subset_7 in H0.
    apply notin_union in H.
    destruct_hypos.
    apply KeySetProperties.union_subset_3...
    apply IHT1 with (X:=X) (n:=n)...
    apply IHT2 with (X:=X) (n:=(Datatypes.S n))...
  -
    apply IHT with (X:=X) (n:=(Datatypes.S n))...
  -
    apply KeySetProperties.union_subset_3...
    apply union_subset_7 in H0.
    destruct H0.
    unfold "[<=]" in *.
    intros.
    assert (Ht:=H2).
    apply H0 in H2.
    apply AtomSetProperties.FM.singleton_iff in Ht.
    subst.
    apply AtomSetImpl.add_3 in H2...
    apply IHT with (X:=X) (n:=n)...
    apply union_subset_7 in H0.
    destruct_hypos...
Qed.

Lemma WF_imply_dom: forall E A,
    WF E A ->
    fv_tt A [<=] dom E.
Proof with auto.
  intros.
  induction H;simpl in *;try solve [apply KeySetProperties.subset_empty]...
  -
    unfold binds in H...
    unfold "[<=]".
    intros.
    apply KeySetFacts.singleton_iff in H0.
    subst.
    apply in_split in H.
    destruct_hypos.
    rewrite H...
    apply in_binds...
  -
    unfold binds in H...
    unfold "[<=]".
    intros.
    apply KeySetFacts.singleton_iff in H0.
    subst.
    apply in_split in H.
    destruct_hypos.
    rewrite H...
    apply in_binds_lb...
  -
    apply KeySetProperties.union_subset_3...
  -
    apply KeySetProperties.union_subset_3...
    pick fresh X.
    specialize_x_and_L X L.
    apply fv_open_tt_notin_inv in H1...
  -
    apply KeySetProperties.union_subset_3...
    pick fresh X.
    specialize_x_and_L X L.
    apply fv_open_tt_notin_inv in H1...
  -
    pick fresh X.
    specialize_x_and_L X L.
    apply fv_open_tt_notin_inv in H0...
Qed.

Lemma wf_env_cons: forall E1 E2,
    wf_env (E1++E2) ->
    wf_env E2.
Proof with auto.
  induction E1;intros...
  destruct a...
  dependent destruction H...
Qed.

Lemma fv_env_ls_dom: forall E,
    wf_env E ->
    fv_env E [<=] dom E.
Proof with auto.
  induction E;intros;simpl in *...
  -
    apply AtomSetProperties.subset_empty...
  -
    destruct a.
    destruct b.
    +
      dependent destruction H.
      apply KeySetProperties.subset_add_2...
      apply AtomSetProperties.union_subset_3...
      apply WF_imply_dom...
    +
      dependent destruction H.
      apply KeySetProperties.subset_add_2...
      apply AtomSetProperties.union_subset_3...
      apply WF_imply_dom...
    +
      dependent destruction H.
      apply KeySetProperties.subset_add_2...
      apply AtomSetProperties.union_subset_3...
      apply WF_imply_dom...
Qed.

Lemma notin_from_wf_env: forall E1 X T E2,
    wf_env (E1 ++ (X, bind_sub T) :: E2) ->
    X \notin fv_tt T \u dom E2 \u dom E1 \u fv_env E2.
Proof with auto.
  induction E1;intros...
  -
    dependent destruction H...
    apply WF_imply_dom in H0...
    apply fv_env_ls_dom in H...
  -
    dependent destruction H...
    + simpl in *...
      apply IHE1 in H...
    + simpl in *...
      apply IHE1 in H...
    + simpl in *...
      apply IHE1 in H...
Qed.

Lemma notin_from_wf_env_lb: forall E1 X T E2,
    wf_env (E1 ++ (X, bind_sub_lb T) :: E2) ->
    X \notin fv_tt T \u dom E2 \u dom E1 \u fv_env E2.
Proof with auto.
  induction E1;intros...
  -
    dependent destruction H...
    apply WF_imply_dom in H0...
    apply fv_env_ls_dom in H...
  -
    dependent destruction H...
    + simpl in *...
      apply IHE1 in H...
    + simpl in *...
      apply IHE1 in H...
    + simpl in *...
      apply IHE1 in H...
Qed.

Lemma WF_from_binds_typ : forall x U E,
  wf_env E ->
  binds x (bind_sub U) E ->
  WF E U.
Proof with auto.
  induction 1; intros J; analyze_binds J...
  -
    inversion BindsTacVal;subst.
    add_nil.
    apply WF_weakening...
  -
    add_nil.
    apply WF_weakening...
 -
    add_nil.
    apply WF_weakening...
 -
    add_nil.
    apply WF_weakening...
Qed.

Lemma WF_from_binds_typ_lb : forall x U E,
  wf_env E ->
  binds x (bind_sub_lb U) E ->
  WF E U.
Proof with auto.
  induction 1; intros J; analyze_binds J...
  -
    add_nil.
    apply WF_weakening...
  -
    inversion BindsTacVal;subst.
    add_nil.
    apply WF_weakening...
 -
    add_nil.
    apply WF_weakening...
 -
    add_nil.
    apply WF_weakening...
Qed.

Lemma notin_partial: forall X E1 E2,
    X \notin E2 ->
    E1 [<=] E2 ->
    X \notin E1.
Proof with auto.
  unfold "[<=]".
  intros...
Qed.


Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Structures.Applicative.
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Data.String.
Require Import ExtLib.Tactics.Consider.
Require Import ExtLib.Tactics.

Require Import MirrorCore.TypesI.
Require Import MirrorCore.syms.SymEnv.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.Lambda.ExprVariables.
Require Import MirrorCore.Lambda.ExprTac.
Require Import MirrorCore.SymI.
Require Import MirrorCore.syms.SymSum.

Require Import Charge.Open.Stack.
Require Import Charge.Open.Subst.
Require Import Charge.ModularFunc.Denotation.
Require Import Charge.ModularFunc.BaseType.
Require Import Charge.ModularFunc.ListType.
Require Import Charge.ModularFunc.SubstType.
Require Import Charge.ModularFunc.ListFunc.
Require Import Charge.ModularFunc.ILogicFunc.
Require Import Charge.ModularFunc.BILogicFunc.
Require Import Charge.ModularFunc.BaseFunc.
Require Import Charge.ModularFunc.EmbedFunc.
Require Import Charge.Rel.

Require Import Coq.Strings.String.
Require Import Coq.Bool.Bool.
Require Import FunctionalExtensionality.

Set Implicit Arguments.
Set Strict Implicit.
Set Maximal Implicit Insertion.

  Inductive open_func typ {RType_typ : RType typ} {HST : SubstType typ} :=
    | of_const (_ : typ)
    | of_ap (_ _ : typ)
    | of_null
    | of_stack_get
    | of_stack_set
    | of_apply_subst (_ : typ)
    | of_single_subst
    | of_subst
    | of_trunc_subst.

Implicit Arguments open_func [[RType_typ] [HST]].

Class OpenFunc (typ func : Type) {RType_typ : RType typ} {HST : SubstType typ} := {
  fConst : typ -> func;
  fAp : typ -> typ -> func;

  fNull : func;

  fStackGet : func;
  fStackSet : func;

  fApplySubst : typ -> func;
  fSingleSubst : func;
  fSubst : func;
  fTruncSubst : func;

  open_funcS : func -> option (open_func typ)
}.

Implicit Arguments OpenFunc [[RType_typ] [HST]].

Section OpenFuncSum.
	Context {typ func : Type} `{H : OpenFunc typ func}.

	Global Instance OpenFuncSumL (A : Type) :
	   OpenFunc typ (func + A) := {
		  fConst t := inl (fConst t);
		  fAp t u := inl (fAp t u);

		  fNull := inl fNull;

		  fStackGet := inl fStackGet;
		  fStackSet := inl fStackSet;

		  fApplySubst t := inl (fApplySubst t);
		  fSingleSubst := inl fSingleSubst;
		  fSubst := inl fSubst;
		  fTruncSubst := inl fTruncSubst;

		  open_funcS f := match f with
		  				    | inl f => open_funcS f
		  				    | inr _ => None
		  				  end
       }.

	Global Instance OpenFuncSumR (A : Type) :
	   OpenFunc typ (A + func) := {
		  fConst t := inr (fConst t);
		  fAp t u := inr (fAp t u);

		  fNull := inr fNull;

		  fStackGet := inr fStackGet;
		  fStackSet := inr fStackSet;

		  fApplySubst t := inr (fApplySubst t);
		  fSingleSubst := inr fSingleSubst;
		  fSubst := inr fSubst;
		  fTruncSubst := inr fTruncSubst;

		  open_funcS f := match f with
		  				    | inr f => open_funcS f
		  				    | inl _ => None
		  				  end

       }.

	Global Instance OpenFuncExpr :
	   OpenFunc typ (expr typ func) := {
		  fConst t := Inj (fConst t);
		  fAp t u := Inj (fAp t u);

		  fNull := Inj fNull;

		  fStackGet := Inj fStackGet;
		  fStackSet := Inj fStackSet;

		  fApplySubst t := Inj (fApplySubst t);
		  fSingleSubst := Inj fSingleSubst;
		  fSubst := Inj fSubst;
		  fTruncSubst := Inj fTruncSubst;

		  open_funcS f := match f with
		  				    | Inj f => open_funcS f
		  				    | _ => None
		  				  end

       }.

End OpenFuncSum.

Section OpenFuncInst.

	Context {typ func : Type} {BT : BaseType typ} {LT : ListType typ}.
	Context {RType_typ : RType typ} {Heq : RelDec (@eq typ)} {HC : RelDec_Correct Heq}.

    Context {Typ2_tyArr : Typ2 _ Fun}.
    Context {Typ0_tyProp : Typ0 _ Prop}.

    Context {ST : SubstType typ} {HV : ValNull (typD tyVal)}.
    Context {BTD : BaseTypeD BT} {LTD : ListTypeD LT}.

    Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.
    Let tyProp : typ := @typ0 _ _ _ _.

	Local Notation "'tyStack'" := (tyArr tyString tyVal).
    Local Notation "'tySubst'" := (tyArr tyString (tyArr tyStack tyVal)).
	Local Notation "'tyExpr'" := (tyArr tyStack tyVal).
	Local Notation "'tySubstList'" := (tyList (tyProd tyString (tyArr tyStack tyVal))).

	Definition stack := @stack (typD tyString) (typD tyVal).

	Global Instance OpenFuncInst : OpenFunc typ (open_func typ) := {
	  fConst := of_const;
	  fAp := of_ap;
	  fNull := of_null;
	  fStackGet := of_stack_get;
	  fStackSet := of_stack_set;
	  fApplySubst := of_apply_subst;
	  fSingleSubst := of_single_subst;
	  fSubst := of_subst;
	  fTruncSubst := of_trunc_subst;

	  open_funcS f := Some f
	}.

  Definition typeof_open_func (f : open_func typ) : option typ :=
    match f with
    | of_const t => Some (tyArr t (tyArr tyStack t))
    | of_ap t u => Some (tyArr (tyArr tyStack (tyArr t u)) (tyArr (tyArr tyStack t) (tyArr tyStack u)))
    | of_apply_subst t => Some (tyArr (tyArr tyStack t) (tyArr tySubst (tyArr tyStack t)))
	| of_null => Some tyVal
    | of_stack_get => Some (tyArr tyString tyExpr)
    | of_stack_set => Some (tyArr tyString (tyArr tyVal (tyArr tyStack tyStack)))
    | of_single_subst => Some (tyArr tyExpr (tyArr tyString tySubst))
    | of_subst => Some (tyArr tySubstList tySubst)
    | of_trunc_subst => Some (tyArr tySubstList tySubst)
	end.

  Global Instance RelDec_open_func : RelDec (@eq (open_func typ)) :=
  { rel_dec := fun a b =>
	         match a, b with
	  	       | of_const t, of_const t'
	  	       | of_apply_subst t, of_apply_subst t' => t ?[eq] t'
	  	       | of_ap t u, of_ap t' u' => (t ?[eq] t' && u ?[eq] u')%bool
	  	       | of_null, of_null
	  	       | of_stack_get, of_stack_get
	  	       | of_stack_set, of_stack_set
	  	       | of_single_subst, of_single_subst
	  	       | of_subst, of_subst
	  	       | of_trunc_subst, of_trunc_subst => true
	  	       | _, _ => false
	         end
  }.

  Global Instance RelDec_Correct_open_func : RelDec_Correct RelDec_open_func.
  Proof.
    constructor.
    destruct x; destruct y; simpl; try rewrite andb_true_iff;
    repeat rewrite rel_dec_correct; try intuition congruence.
  Qed.

	Local Instance Applicative_Fun A : Applicative (Fun A) :=
	{ pure := fun _ x _ => x
	; ap := fun _ _ f x y => (f y) (x y)
	}.

    Definition substListD (lst : typD tySubstList) : substlist (A := typD tyString) (val := (typD tyVal)) :=
      trmD lst (listE (pairE eq_refl (funE (funE eq_refl eq_refl) eq_refl))).

	 Definition substD (s : typD tySubst) : subst :=
	   (fun e f => (tyArrD2 s) e (tyArrR f)).

	 Definition substR (s : subst) : typD tySubst :=
	   tyArrR2 (fun a b => s a (tyArrD b)).

	 Definition constD t : typD (tyArr t (tyArr tyStack t)) :=
	   tyArrR (fun x => (tyArrR (pure x))).

	 Definition stack_getD : typD (tyArr tyString (tyArr tyStack tyVal)) :=
	   tyArrR2 (fun x s => (tyArrD s) x).

	 Definition stack_setD : typD (tyArr tyString (tyArr tyVal (tyArr tyStack tyStack))) :=
	   tyArrR4 (fun a b c d => stack_add a b (tyArrD c) d).

	 Definition apD t u : typD (tyArr (tyArr tyStack (tyArr t u)) (tyArr (tyArr tyStack t) (tyArr tyStack u))) :=
	   tyArrR3 (fun a b c => @ap (Fun (typD tyStack)) (Applicative_Fun _) (typD t) (typD u)
	   	 (tyArrD2 a) (tyArrD b) c).

	 Program Definition applySubstD (t : typ) : typD (tyArr (tyArr tyStack t) (tyArr tySubst (tyArr tyStack t))) :=
	   tyArrR3 (fun a b c => apply_subst
	     (fun x => tyArrD a (tyArrR x)) (substD b)
	     (tyArrD c)).

	 Definition singleSubstD :=
	   tyArrR2 (fun a b => substR (subst1 (fun x => tyArrD a (tyArrR x)) b)).

	 Definition parSubstD :=
	   tyArrR (fun a => substR (substl_aux (substListD a))).

	 Definition truncSubstD :=
	   tyArrR (fun a => substR (substl_trunc_aux (substListD a))).

	 Definition open_func_symD f : match typeof_open_func f with
	                                 | Some t => typD t
	                                 | None => unit
	                               end :=
		match f as f return match typeof_open_func f with
								| Some t => typD t
								| None => unit
							  end with
	      | of_const t => constD t
	      | of_ap t u => apD t u
	      | of_null => null
	      | of_stack_get => stack_getD
	      | of_stack_set => stack_setD
	      | of_apply_subst t => applySubstD t
	      | of_single_subst => singleSubstD
	      | of_subst => parSubstD
	      | of_trunc_subst => truncSubstD
	    end.

	Global Program Instance RSym_OpenFunc : SymI.RSym (open_func typ) := {
	  typeof_sym := typeof_open_func;
	  symD := open_func_symD;
	  sym_eqb := (fun a b => Some (rel_dec a b))
	}.

  Global Instance RSymOk_lopen_func : SymI.RSymOk RSym_OpenFunc.
  Proof.
    constructor.
    intros. unfold sym_eqb; simpl.
    consider (a ?[ eq ] b); auto.
  Qed.

End OpenFuncInst.

Section OpenFuncOk.
  Context {typ func : Type} {BT : BaseType typ} {LT : ListType typ} {ST : SubstType typ}.
  Context {RType_typ : RType typ} {HO: OpenFunc typ func} {Heq : RelDec (@eq typ)}.
  Context {RSym_func : RSym func}.
  Context {HV : ValNull (typD tyVal)}.

  Context {BTD : BaseTypeD BT} {LTD : ListTypeD LT}.

  Context  {Typ2_tyArr : Typ2 _ Fun}.
  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.

  Class OpenFuncOk := {
    of_funcAsOk f e : open_funcS f = Some e -> forall t, funcAs f t = funcAs e t;
    of_fConstOk t : open_funcS (fConst t) = Some (of_const t);
    of_fApOk t u : open_funcS (fAp t u) = Some (of_ap t u);
    of_fNullOk : open_funcS fNull = Some of_null;
    of_fStackGetOk : open_funcS fStackGet = Some of_stack_get;
    of_fStackSetOk : open_funcS fStackSet = Some of_stack_set;
    of_fApplySubstOk t : open_funcS (fApplySubst t) = Some (of_apply_subst t);
    of_fSingleSubstOk : open_funcS fSingleSubst = Some of_single_subst;
    of_fSubstOk : open_funcS fSubst = Some of_subst;
    of_fTruncSubstOk : open_funcS fTruncSubst = Some of_trunc_subst
  }.

End OpenFuncOk.

Implicit Arguments OpenFuncOk [[BT] [LT] [ST] [RType_typ] [HO] [RSym_func] [Heq] [HV] [BTD] [LTD] [Typ2_tyArr]].

Section OpenFuncBaseOk.
  Context {typ func : Type} {BT : BaseType typ} {LT : ListType typ} {ST : SubstType typ}.
  Context {RType_typ : RType typ} {HO: OpenFunc typ func} {Heq' : RelDec (@eq typ)}.
  Context {RSym_func : RSym func}.
  Context {HV : ValNull (typD tyVal)}.

  Context {BTD : BaseTypeD BT} {LTD : ListTypeD LT}.

  Context  {Typ2_tyArr : Typ2 _ Fun}.
  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.

  Program Instance open_funcOk : OpenFuncOk typ (open_func typ) := {
    of_funcAsOk := fun _ _ _ _ => eq_refl;
    of_fConstOk t := eq_refl;
    of_fApOk t u := eq_refl;
    of_fNullOk := eq_refl;
    of_fStackGetOk := eq_refl;
    of_fStackSetOk := eq_refl;
    of_fApplySubstOk t := eq_refl;
    of_fSingleSubstOk := eq_refl;
    of_fSubstOk := eq_refl;
    of_fTruncSubstOk := eq_refl
  }.

End OpenFuncBaseOk.

Section OpenFuncExprOk.
  Context {typ func : Type} `{HOK : OpenFuncOk typ func}.
  Context {HROk : RTypeOk}.

  Lemma open_funcSome (f : func) (e : open_func typ) (t : typ)
    (H : open_funcS f = Some e) :
      match typeof_open_func e with
        | Some t => funcAs f t <> None
        | None => False
      end.
  Proof.
    destruct HOK as [H1].
    specialize (H1 _ _ H).
    destruct e; simpl in *; intros H2;
    match goal with
      | H : funcAs _ ?t = None |- _ =>
        specialize (H1 t); rewrite H in H1; clear H;
              unfold funcAs in H1; simpl in H1;
              rewrite type_cast_refl in H1; [|apply _]; inversion H1
    end.
  Qed.

  Lemma OpenFunc_typeOk (f : func) (e : open_func typ) (H : open_funcS f = Some e) :
    typeof_sym f = typeof_open_func e.
  Proof.
    destruct HOK as [H1].
    specialize (H1 _ _ H).
 	destruct e; simpl in *;
    match goal with
      | |- typeof_sym ?f = Some ?t =>
	 	specialize (H1 t);
	 	simpl in H1;
 	 	unfold funcAs in H1; simpl in H1; rewrite type_cast_refl in H1; [|apply _];
 		generalize dependent (symD f);
 		destruct (typeof_sym f); simpl; intros; [forward|]; inversion H1
    end.
  Qed.

  Existing Instance RSym_sum.
  Existing Instance RSymOk_sum.

  Context {A : Type} {RSymA : RSym A}.

  Global Program Instance OpenFuncOkSumR : OpenFuncOk typ (A + func) := {
    of_funcAsOk :=
      fun a f H t =>
        match a with
          | inl b => _
          | inr b => _
        end;
    of_fConstOk t := of_fConstOk t (func := func);
    of_fApOk t u := of_fApOk t u (func := func);
    of_fNullOk := of_fNullOk (func := func);
    of_fStackGetOk := of_fStackGetOk (func := func);
    of_fStackSetOk := of_fStackSetOk (func := func);
    of_fApplySubstOk t := of_fApplySubstOk t (func := func);
    of_fSingleSubstOk := of_fSingleSubstOk (func := func);
    of_fSubstOk := of_fSubstOk (func := func);
    of_fTruncSubstOk := of_fTruncSubstOk (func := func)
  }.
  Next Obligation.
    apply (of_funcAsOk _ H).
  Qed.

  Global Program Instance OpenFuncOkSumL : OpenFuncOk typ (func + A) := {
    of_funcAsOk :=
      fun a f H t =>
        match a with
          | inl b => _
          | inr b => _
        end;
    of_fConstOk t := of_fConstOk t (func := func);
    of_fApOk t u := of_fApOk t u (func := func);
    of_fNullOk := of_fNullOk (func := func);
    of_fStackGetOk := of_fStackGetOk (func := func);
    of_fStackSetOk := of_fStackSetOk (func := func);
    of_fApplySubstOk t := of_fApplySubstOk t (func := func);
    of_fSingleSubstOk := of_fSingleSubstOk (func := func);
    of_fSubstOk := of_fSubstOk (func := func);
    of_fTruncSubstOk := of_fTruncSubstOk (func := func)
  }.
  Next Obligation.
    apply (of_funcAsOk _ H).
  Qed.

End OpenFuncExprOk.

Section MakeOpen.
	Context {typ func : Type} {HR : RType typ} {HS : SubstType typ}.
	Context {H : OpenFunc typ func} {H1 : ListFunc typ func}
	        {HBT : BaseType typ}.

    Context  {Typ2_tyArr : Typ2 _ Fun}.
    Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.

	Local Notation "'tyStack'" := (tyArr tyString tyVal).

    Definition mkNull : expr typ func := Inj fNull.
	Definition mkConst (t : typ) (e : expr typ func) := App (fConst t) e.
	Definition mkAp (t u : typ) (f e : expr typ func) := App (App (fAp t u) f) e.
	Definition mkStackGet (x s : expr typ func) := App (App fStackGet x) s.
	Definition mkStackSet (x v s : expr typ func) := App (App (App fStackSet x) v) s.
	Definition mkApplySubst (t : typ) (P s : expr typ func) := App (App (fApplySubst t) P) s.
	Definition mkSingleSubst (e x : expr typ func) := App (App fSingleSubst e) x.
	Definition mkApplySingleSubst t P x e := mkApplySubst t P (mkSingleSubst x e).
	Definition mkSubst (s : expr typ func) := App fSubst s.
	Definition mkTruncSubst (s : expr typ func) := App fTruncSubst s.
	Definition mkApplyTruncSubst t P s := mkApplySubst t P (mkTruncSubst s).

	Fixpoint mkAps f es t :=
		match es with
			| nil => mkConst t f
			| (e, t')::es => mkAp t' t (mkAps f es (tyArr t' t)) e
		end.

	Context {HSf : RSym func}.
(*
	Fixpoint ap_lift_aux tus tvs (e : expr typ func) (t : typ) : option (expr typ func) :=
	  match e with
		| App f a =>
		  match typeof_expr tus tvs a with
		    | Some u =>
		        match ap_lift_aux tus tvs f (tyArr u t), ap_lift_aux tus tvs a u with
		    	  | Some f', Some a' => Some (mkAp u t f' a')
		    	  | _, _ => None
		    	end
		    | None => None
		  end
		| Inj f => Some (mkConst t (Inj f))
		| Abs u f => match (ap_lift_aux tus (u::tvs) f (tyArr u t)) with
					   | Some f' => Some (Abs (tyArr tyStack u) f')
					   | None => None
					 end

		| _ => Some e
	  end.

	Definition ap_lift2 tus tvs (e : expr typ func) :=
		match typeof_expr tus tvs e with
		  | Some t => ap_lift_aux tus tvs e t
		  | None => None
		end.
*)

	Context {HIL : ILogicFunc typ func}.
	Context {HBIL : BILogicFunc typ func}.

	Fixpoint il_lift tus tvs (e : expr typ func) :=
	  match e with
	    | App (App f a) b =>
	      match ilogicS f with
	        | Some (ilf_entails t) =>
	          match il_lift tus tvs a, il_lift tus tvs b with
	            | Some a', Some b' => Some (mkEntails (tyArr tyStack t) a' b')
	            | _, _ => None
	          end
	        | Some (ilf_and t) =>
	          match il_lift tus tvs a, il_lift tus tvs b with
	            | Some a', Some b' => Some (mkAnd (tyArr tyStack t) a' b')
	            | _, _ => None
	          end
	        | Some (ilf_or t) =>
	          match il_lift tus tvs a, il_lift tus tvs b with
	            | Some a', Some b' => Some (mkOr (tyArr tyStack t) a' b')
	            | _, _ => None
	          end
	        | Some (ilf_impl t) =>
	          match il_lift tus tvs a, il_lift tus tvs b with
	            | Some a', Some b' => Some (mkImpl (tyArr tyStack t) a' b')
	            | _, _ => None
	          end
	        | _ =>
	          match bilogicS f with
	            | Some (bilf_star t) =>
		          match il_lift tus tvs a, il_lift tus tvs b with
		            | Some a', Some b' => Some (mkStar (tyArr tyStack t) a' b')
		            | _, _ => None
		          end
	            | Some (bilf_wand t) =>
		          match il_lift tus tvs a, il_lift tus tvs b with
		            | Some a', Some b' => Some (mkWand (tyArr tyStack t) a' b')
		            | _, _ => None
		          end
	            | _ =>
	              match typeof_expr tus tvs e, typeof_expr tus tvs a, typeof_expr tus tvs b with
	                | Some t, Some u, Some v =>
	            	  match il_lift tus tvs f, il_lift tus tvs a, il_lift tus tvs b with
	            	    | Some f', Some a', Some b' =>
	            	      Some (mkAp v t (mkAp u (tyArr v t) f' a') b')
	            	    | _, _, _ => None
	            	  end
	            	| _, _, _ => None
	              end
	          end
	      end
	    | App f a =>
	      match ilogicS f with
	        | Some (ilf_exists u v) =>
	          match il_lift tus tvs a with
	            | Some a' => Some (App (fExists (tyArr tyStack u) (tyArr tyStack v)) a')
	            | None => None
	          end
	        | Some (ilf_forall u v) =>
	          match il_lift tus tvs a with
	            | Some a' => Some (App (fForall (tyArr tyStack u) (tyArr tyStack v)) a')
	            | None => None
	          end
	        | _ =>
	          match typeof_expr tus tvs e, typeof_expr tus tvs a with
	            | Some t, Some u =>
	              match il_lift tus tvs f, il_lift tus tvs a with
	                | Some f', Some a' => Some (mkAp u t f' a')
	                | _, _ => None
	              end
	            | _, _ => None
	          end
	      end
	    | Inj f =>
	      match ilogicS f with
	        | Some (ilf_true t) => Some (mkTrue (tyArr tyStack t))
	        | Some (ilf_false t) => Some (mkFalse (tyArr tyStack t))
	        | _ =>
	          match bilogicS f with
	            | Some (bilf_emp t) => Some (mkEmp (tyArr tyStack t))
	            | _ =>
	              match typeof_expr tus tvs e with
	                | Some t => Some (mkConst t e)
	                | None => None
	              end
	          end
	      end
		| Abs t f =>
		  match il_lift tus (t::tvs) f with
		    | Some f' => Some (Abs (tyArr tyStack t) f')
		    | None => None
		  end
	    | _ => Some e
	  end.
(*
	with ap_lift tus tvs (e : expr typ func) {struct e} :=
		match e with
		  | Abs t f =>
		    match il_lift tus (t::tvs) f with
		      | Some f' => Some (Abs (tyArr tyStack t) f')
		      | None => None
		    end
		  | Inj f =>
		    match typeof_expr tus tvs e with
		      | Some t => Some (mkConst t (Inj f))
		      | None => None
		    end
		  | App f a =>
		    match typeof_expr tus tvs e, typeof_expr tus tvs a with
		      | Some t, Some u =>
		        match il_lift tus tvs f, il_lift tus tvs a with
		          | Some f', Some a' => Some (mkAp u t f' a')
		          | _, _ => None
		        end
		      | _, _ => None
		    end
		  | _ => Some e
		end.
*)
End MakeOpen.

Section TypeOfFunc.
  Context {typ func : Type}.
  Context {RType_typ : RType typ}.
  Context {RTypeOk_typ : RTypeOk}.
  Context {RSym_func : RSym func}.
    Lemma typeof_funcAs f t e (H : funcAs f t = Some e) : typeof_sym f = Some t.
    Proof.
      unfold funcAs in H.
      generalize dependent (symD f).
      destruct (typeof_sym f); intros; [|congruence].
      destruct (type_cast t0 t); [|congruence].
      destruct r; reflexivity.
    Qed.

      Lemma funcAs_Some f t (pf : typeof_sym f = Some t) :
        funcAs f t =
        Some (match pf in (_ = z)
          return match z with
                   | Some z' => typD z'
                   | None => unit
                 end
          with
          | eq_refl => symD f
          end).
      Proof.
        unfold funcAs.
        generalize (symD f).
        rewrite pf. intros.
        rewrite type_cast_refl. reflexivity. apply _.
      Qed.

End TypeOfFunc.

Section MakeOpenSound.
  Context {typ func : Type} {ST : SubstType typ} {BT : BaseType typ} {RType_typ : RType typ}.
  Context {OF : OpenFunc typ func} {ILF : ILogicFunc typ func} {BILF : BILogicFunc typ func} {BF : BaseFunc typ func}.
  Context {LT : ListType typ}.
  Context {EF : EmbedFunc typ func}.
  Context {RelDec_typ : RelDec (@eq typ)}.
  Context {RTypeOk_typ : RTypeOk}.
  Context {RSym_func : RSym func}.
  Context {RSym_funcOk : RSymOk RSym_func}.
  Context {Typ2_tyArr : Typ2 _ Fun}.
  Context {Typ0_Prop : Typ0 _ Prop}.
  Context {Typ2_tyArrOk : Typ2Ok Typ2_tyArr}.
  Context {HV : ValNull (typD tyVal)}.
  Context {BTD : BaseTypeD BT} {LTD : ListTypeD LT}.
  Context {OFOK : OpenFuncOk typ func}.

  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.

  Let Expr_expr := Expr_expr (typ := typ) (func := func).
  Let ExprOk_expr := ExprOk_expr (typ := typ) (func := func).
  Let ExprUVar_expr := ExprUVar_expr (typ := typ) (func := func).

  Local Existing Instance Expr_expr.
  Local Existing Instance ExprOk_expr.
  Local Existing Instance ExprUVar_expr.

  Local Notation "'tyStack'" := (tyArr tyString tyVal).
  Local Notation "'tySubst'" := (tyArr tyString (tyArr tyStack tyVal)).
  Local Notation "'tyExpr'" := (tyArr tyStack tyVal).
  Local Notation "'tySubstList'" := (tyList (tyProd tyString (tyArr tyStack tyVal))).

  Lemma funcAs_fNull_eq : funcAs fNull tyVal = Some null.
  Proof.
   rewrite (of_funcAsOk _ of_fNullOk).
   unfold funcAs; simpl.
   rewrite type_cast_refl; [reflexivity | apply _].
  Qed.

  Lemma funcAs_fConst_eq t : funcAs (fConst t) (tyArr t (tyArr tyStack t)) = Some (constD t).
  Proof.
   rewrite (of_funcAsOk _ (of_fConstOk t)).
   unfold funcAs; simpl.
   rewrite type_cast_refl; [reflexivity | apply _].
  Qed.

  Lemma funcAs_fAp_eq t u : funcAs (fAp t u) (tyArr (tyArr tyStack (tyArr t u)) (tyArr (tyArr tyStack t) (tyArr tyStack u))) = Some (apD t u).
  Proof.
   rewrite (of_funcAsOk _ (of_fApOk t u)).
   unfold funcAs; simpl.
   rewrite type_cast_refl; [reflexivity | apply _].
  Qed.

  Lemma funcAs_fStackGet_eq : funcAs fStackGet (tyArr tyString (tyArr (tyArr tyString tyVal) tyVal)) = Some stack_getD.
  Proof.
   rewrite (of_funcAsOk _ of_fStackGetOk).
   unfold funcAs; simpl.
   rewrite type_cast_refl; [reflexivity | apply _].
  Qed.

  Lemma funcAs_fStackSet_eq : funcAs fStackSet (tyArr tyString (tyArr tyVal (tyArr tyStack tyStack))) = Some stack_setD.
  Proof.
   rewrite (of_funcAsOk _ of_fStackSetOk).
   unfold funcAs; simpl.
   rewrite type_cast_refl; [reflexivity | apply _].
  Qed.

  Lemma funcAs_fApplySubst_eq t : funcAs (fApplySubst t) (tyArr (tyArr tyStack t) (tyArr tySubst (tyArr tyStack t))) = Some (applySubstD t).
  Proof.
   rewrite (of_funcAsOk _ (of_fApplySubstOk t)).
   unfold funcAs; simpl.
   rewrite type_cast_refl; [reflexivity | apply _].
  Qed.

  Lemma funcAs_fSingleSubst_eq : funcAs fSingleSubst (tyArr (tyArr tyStack tyVal) (tyArr tyString tySubst)) = Some singleSubstD.
  Proof.
   rewrite (of_funcAsOk _ of_fSingleSubstOk).
   unfold funcAs; simpl.
   rewrite type_cast_refl; [reflexivity | apply _].
  Qed.

  Lemma funcAs_fSubst_eq : funcAs fSubst (tyArr (tyList (tyProd tyString tyExpr)) (tyArr tyString tyExpr)) = Some parSubstD.
  Proof.
   rewrite (of_funcAsOk _ of_fSubstOk).
   unfold funcAs; simpl.
   rewrite type_cast_refl; [reflexivity | apply _].
  Qed.

  Lemma funcAs_fTruncSubst_eq : funcAs fTruncSubst (tyArr (tyList (tyProd tyString tyExpr)) (tyArr tyString tyExpr)) = Some truncSubstD.
  Proof.
   rewrite (of_funcAsOk _ of_fTruncSubstOk).
   unfold funcAs; simpl.
   rewrite type_cast_refl; [reflexivity | apply _].
  Qed.

  Lemma typeof_fNull_eq : typeof_sym fNull = Some tyVal.
  Proof.
    eapply typeof_funcAs; apply funcAs_fNull_eq.
  Qed.

  Lemma typeof_fConst_eq t : typeof_sym (fConst t) = Some (tyArr t (tyArr tyStack t)).
  Proof.
    eapply typeof_funcAs; apply funcAs_fConst_eq.
  Qed.

  Lemma typeof_fAp_eq t u : typeof_sym (fAp t u) = Some (tyArr (tyArr tyStack (tyArr t u)) (tyArr (tyArr tyStack t) (tyArr tyStack u))).
  Proof.
    eapply typeof_funcAs; apply funcAs_fAp_eq.
  Qed.

  Lemma typeof_fStackGet_eq : typeof_sym fStackGet = Some (tyArr tyString (tyArr (tyArr tyString tyVal) tyVal)).
  Proof.
    eapply typeof_funcAs; apply funcAs_fStackGet_eq.
  Qed.

  Lemma typeof_fStackSet_eq : typeof_sym fStackSet = Some (tyArr tyString (tyArr tyVal (tyArr tyStack tyStack))).
  Proof.
    eapply typeof_funcAs; apply funcAs_fStackSet_eq.
  Qed.

  Lemma typeof_fStackApplySubst_eq t : typeof_sym (fApplySubst t) = Some (tyArr (tyArr tyStack t) (tyArr tySubst (tyArr tyStack t))).
  Proof.
    eapply typeof_funcAs; apply funcAs_fApplySubst_eq.
  Qed.

  Lemma typeof_fSingleSubst_eq : typeof_sym fSingleSubst = Some (tyArr (tyArr tyStack tyVal) (tyArr tyString tySubst)).
  Proof.
    eapply typeof_funcAs; apply funcAs_fSingleSubst_eq.
  Qed.

  Lemma typeof_fSubst_eq : typeof_sym fSubst = Some (tyArr (tyList (tyProd tyString tyExpr)) (tyArr tyString tyExpr)).
  Proof.
    eapply typeof_funcAs; apply funcAs_fSubst_eq.
  Qed.

  Lemma typeof_fTruncSubst_eq : typeof_sym fTruncSubst = Some (tyArr (tyList (tyProd tyString tyExpr)) (tyArr tyString tyExpr)).
  Proof.
    eapply typeof_funcAs; apply funcAs_fTruncSubst_eq.
  Qed.

  Lemma of_const_func_type_eq (t u : typ) (f : func) (df : typD u)
    (Ho : open_funcS f = Some (of_const t))
    (Hf : funcAs f u = Some df) :
    Rty u (tyArr t (tyArr tyStack t)).
  Proof.
    pose proof (of_funcAsOk _ Ho) as H; rewrite H in Hf.
    unfold funcAs in Hf. simpl in Hf.
    forward; inv_all; subst.
    rewrite <- r. reflexivity.
  Qed.

  Lemma of_const_type_eq tus tvs (e : expr typ func) t u df
    (Ho : open_funcS e = Some (of_const t))
    (Hf : exprD' tus tvs u e = Some df) :
    Rty u (tyArr t (tyArr tyStack t)).
  Proof.
    destruct e; simpl in *; try congruence.
    autorewrite with exprD_rw in Hf; simpl in Hf; forward; inv_all; subst.
    eapply of_const_func_type_eq; eassumption.
  Qed.

  Lemma of_ap_func_type_eq (t u v : typ) (f : func) (df : typD v)
    (Ho : open_funcS f = Some (of_ap t u))
    (Hf : funcAs f v = Some df) :
    Rty v (tyArr (tyArr tyStack (tyArr t u)) (tyArr (tyArr tyStack t) (tyArr tyStack u))).
  Proof.
    pose proof (of_funcAsOk _ Ho) as H; rewrite H in Hf.
    unfold funcAs in Hf. simpl in Hf.
    forward; inv_all; subst.
    rewrite <- r. reflexivity.
  Qed.

  Lemma of_ap_type_eq tus tvs (e : expr typ func) t u v df
    (Ho : open_funcS e = Some (of_ap t u))
    (Hf : exprD' tus tvs v e = Some df) :
    Rty v (tyArr (tyArr tyStack (tyArr t u)) (tyArr (tyArr tyStack t) (tyArr tyStack u))).
  Proof.
    destruct e; simpl in *; try congruence.
    autorewrite with exprD_rw in Hf; simpl in Hf; forward; inv_all; subst.
    eapply of_ap_func_type_eq; eassumption.
  Qed.

  Lemma of_stack_get_func_type_eq t (f : func) (df : typD t)
    (Ho : open_funcS f = Some of_stack_get)
    (Hf : funcAs f t = Some df) :
    Rty t (tyArr tyString (tyArr (tyArr tyString tyVal) tyVal)).
  Proof.
    pose proof (of_funcAsOk _ Ho) as H; rewrite H in Hf.
    unfold funcAs in Hf. simpl in Hf.
    forward; inv_all; subst.
    rewrite <- r. reflexivity.
  Qed.

  Lemma of_stack_get_type_eq tus tvs (e : expr typ func) t df
    (Ho : open_funcS e = Some of_stack_get)
    (Hf : exprD' tus tvs t e = Some df) :
    Rty t (tyArr tyString (tyArr (tyArr tyString tyVal) tyVal)).
  Proof.
    destruct e; simpl in *; try congruence.
    autorewrite with exprD_rw in Hf; simpl in Hf; forward; inv_all; subst.
    eapply of_stack_get_func_type_eq; eassumption.
  Qed.

  Lemma of_apply_subst_func_type_eq t u (f : func) (df : typD u)
    (Ho : open_funcS f = Some (of_apply_subst t))
    (Hf : funcAs f u = Some df) :
    Rty u (tyArr (tyArr tyStack t) (tyArr tySubst (tyArr tyStack t))).
  Proof.
    pose proof (of_funcAsOk _ Ho) as H; rewrite H in Hf.
    unfold funcAs in Hf. simpl in Hf.
    forward; inv_all; subst.
    rewrite <- r. reflexivity.
  Qed.

  Lemma of_apply_subst_type_eq tus tvs (e : expr typ func) t u df
    (Ho : open_funcS e = Some (of_apply_subst t))
    (Hf : exprD' tus tvs u e = Some df) :
    Rty u (tyArr (tyArr tyStack t) (tyArr tySubst (tyArr tyStack t))).
  Proof.
    destruct e; simpl in *; try congruence.
    autorewrite with exprD_rw in Hf; simpl in Hf; forward; inv_all; subst.
    eapply of_apply_subst_func_type_eq; eassumption.
  Qed.

  Lemma of_single_subst_func_type_eq t (f : func) (df : typD t)
    (Ho : open_funcS f = Some of_single_subst)
    (Hf : funcAs f t = Some df) :
    Rty t (tyArr (tyArr tyStack tyVal) (tyArr tyString tySubst)).
  Proof.
    pose proof (of_funcAsOk _ Ho) as H; rewrite H in Hf.
    unfold funcAs in Hf. simpl in Hf.
    forward; inv_all; subst.
    rewrite <- r. reflexivity.
  Qed.

  Lemma of_single_subst_type_eq tus tvs (e : expr typ func) t df
    (Ho : open_funcS e = Some of_single_subst)
    (Hf : exprD' tus tvs t e = Some df) :
    Rty t (tyArr (tyArr tyStack tyVal) (tyArr tyString tySubst)).
  Proof.
    destruct e; simpl in *; try congruence.
    autorewrite with exprD_rw in Hf; simpl in Hf; forward; inv_all; subst.
    eapply of_single_subst_func_type_eq; eassumption.
  Qed.

  Lemma of_trunc_subst_func_type_eq t (f : func) (df : typD t)
    (Ho : open_funcS f = Some of_trunc_subst)
    (Hf : funcAs f t = Some df) :
    Rty t (tyArr (tyList (tyProd tyString tyExpr)) (tyArr tyString tyExpr)).
  Proof.
    pose proof (of_funcAsOk _ Ho) as H; rewrite H in Hf.
    unfold funcAs in Hf. simpl in Hf.
    forward; inv_all; subst.
    symmetry. apply r.
  Qed.

  Lemma of_trunc_subst_type_eq tus tvs t (e : expr typ func) df
    (Ho : open_funcS e = Some of_trunc_subst)
    (Hf : exprD' tus tvs t e = Some df) :
    Rty t (tyArr (tyList (tyProd tyString tyExpr)) (tyArr tyString tyExpr)).
  Proof.
    destruct e; simpl in *; try congruence.
    autorewrite with exprD_rw in Hf; simpl in Hf; forward; inv_all; subst.
    eapply of_trunc_subst_func_type_eq; eassumption.
  Qed.

  Lemma of_apply_subst_func_eq (t : typ) (f : func) (df : typD (tyArr (tyArr tyStack t) (tyArr tySubst (tyArr tyStack t))))
    (Ho : open_funcS f = Some (of_apply_subst t))
    (Hf : funcAs f (tyArr (tyArr tyStack t) (tyArr tySubst (tyArr tyStack t))) = Some df) :
    df = applySubstD t.
  Proof.
   rewrite (of_funcAsOk _ Ho) in Hf.
   unfold funcAs in Hf; simpl in *.
   rewrite type_cast_refl in Hf; [| apply _].
   unfold Rcast, Relim_refl in Hf.
   inversion Hf. reflexivity.
  Qed.

  Lemma of_apply_subst_eq tus tvs (t : typ) (e : expr typ func)
    (df : ExprI.exprT tus tvs (typD  (tyArr (tyArr tyStack t) (tyArr tySubst (tyArr tyStack t)))))
    (Ho : open_funcS e = Some (of_apply_subst t))
    (Hf : exprD' tus tvs (tyArr (tyArr tyStack t) (tyArr tySubst (tyArr tyStack t))) e = Some df) :
    df = fun us vs => applySubstD t.
  Proof.
   destruct e; simpl in *; try congruence.
   autorewrite with exprD_rw in Hf; simpl in Hf; forward; inv_all; subst.
   erewrite <- of_apply_subst_func_eq; try eassumption; reflexivity.
  Qed.

  Lemma of_ap_func_eq (t u : typ) (f : func)
    (df : typD (tyArr (tyArr tyStack (tyArr t u)) (tyArr (tyArr tyStack t) (tyArr tyStack u))))
    (Ho : open_funcS f = Some (of_ap t u))
    (Hf : funcAs f (tyArr (tyArr tyStack (tyArr t u)) (tyArr (tyArr tyStack t) (tyArr tyStack u))) = Some df) :
    df = apD t u.
  Proof.
   rewrite (of_funcAsOk _ Ho) in Hf.
   unfold funcAs in Hf; simpl in *.
   rewrite type_cast_refl in Hf; [| apply _].
   unfold Rcast, Relim_refl in Hf.
   inversion Hf. reflexivity.
  Qed.

  Lemma of_ap_eq tus tvs (t u : typ) (e : expr typ func)
    (df : ExprI.exprT tus tvs (typD  (tyArr (tyArr tyStack (tyArr t u)) (tyArr (tyArr tyStack t) (tyArr tyStack u)))))
    (Ho : open_funcS e = Some (of_ap t u))
    (Hf : exprD' tus tvs (tyArr (tyArr tyStack (tyArr t u)) (tyArr (tyArr tyStack t) (tyArr tyStack u))) e = Some df) :
    df = fun us vs => apD t u.
  Proof.
   destruct e; simpl in *; try congruence.
   autorewrite with exprD_rw in Hf; simpl in Hf; forward; inv_all; subst.
   erewrite <- of_ap_func_eq; try eassumption; reflexivity.
  Qed.

  Lemma of_const_func_eq (t : typ) (f : func)
    (df : typD (tyArr t (tyArr tyStack t)))
    (Ho : open_funcS f = Some (of_const t))
    (Hf : funcAs f (tyArr t (tyArr tyStack t)) = Some df) :
    df = constD t.
  Proof.
   rewrite (of_funcAsOk _ Ho) in Hf.
   unfold funcAs in Hf; simpl in *.
   rewrite type_cast_refl in Hf; [| apply _].
   unfold Rcast, Relim_refl in Hf.
   inversion Hf. reflexivity.
  Qed.

  Lemma of_const_eq tus tvs (t : typ) (e : expr typ func)
    (df : ExprI.exprT tus tvs (typD (tyArr t (tyArr tyStack t))))
    (Ho : open_funcS e = Some (of_const t))
    (Hf : exprD' tus tvs (tyArr t (tyArr tyStack t)) e = Some df) :
    df = fun us vs => constD t.
  Proof.
   destruct e; simpl in *; try congruence.
   autorewrite with exprD_rw in Hf; simpl in Hf; forward; inv_all; subst.
   erewrite <- of_const_func_eq; try eassumption; reflexivity.
  Qed.

  Lemma of_stack_get_func_eq (f : func)
    (df : typD (tyArr tyString (tyArr tyStack tyVal)))
    (Ho : open_funcS f = Some of_stack_get)
    (Hf : funcAs f (tyArr tyString (tyArr tyStack tyVal)) = Some df) :
    df = stack_getD.
  Proof.
   rewrite (of_funcAsOk _ Ho) in Hf.
   unfold funcAs in Hf; simpl in *.
   rewrite type_cast_refl in Hf; [| apply _].
   unfold Rcast, Relim_refl in Hf.
   inversion Hf. reflexivity.
  Qed.

  Lemma of_stack_get_eq tus tvs (e : expr typ func)
    (df : ExprI.exprT tus tvs (typD (tyArr tyString (tyArr tyStack tyVal))))
    (Ho : open_funcS e = Some of_stack_get)
    (Hf : exprD' tus tvs (tyArr tyString (tyArr tyStack tyVal)) e = Some df) :
    df = fun us vs => stack_getD.
  Proof.
   destruct e; simpl in *; try congruence.
   autorewrite with exprD_rw in Hf; simpl in Hf; forward; inv_all; subst.
   erewrite <- of_stack_get_func_eq; try eassumption; reflexivity.
  Qed.

  Lemma of_trunc_subst_func_eq (f : func)
    (df : typD (tyArr (tyList (tyProd tyString tyExpr)) (tyArr tyString tyExpr)))
    (Ho : open_funcS f = Some of_trunc_subst)
    (Hf : funcAs f (tyArr (tyList (tyProd tyString tyExpr)) (tyArr tyString tyExpr)) = Some df) :
    df = truncSubstD.
  Proof.
   rewrite (of_funcAsOk _ Ho) in Hf.
   unfold funcAs in Hf; simpl in *.
   rewrite type_cast_refl in Hf; [| apply _].
   unfold Rcast, Relim_refl in Hf.
   inversion Hf. reflexivity.
  Qed.

  Lemma of_trunc_subst_eq tus tvs (e : expr typ func)
    (df : ExprI.exprT tus tvs (typD (tyArr (tyList (tyProd tyString tyExpr)) (tyArr tyString tyExpr))))
    (Ho : open_funcS e = Some of_trunc_subst)
    (Hf :exprD' tus tvs (tyArr (tyList (tyProd tyString tyExpr)) (tyArr tyString tyExpr)) e = Some df) :
    df = fun us vs => truncSubstD.
  Proof.
   destruct e; simpl in *; try congruence.
   autorewrite with exprD_rw in Hf; simpl in Hf; forward; inv_all; subst.
   erewrite <- of_trunc_subst_func_eq; try eassumption; reflexivity.
  Qed.

  Lemma of_single_subst_func_eq (f : func)
    (df : typD  (tyArr (tyArr tyStack tyVal) (tyArr tyString tySubst)))
    (Ho : open_funcS f = Some of_single_subst)
    (Hf : funcAs f (tyArr (tyArr tyStack tyVal) (tyArr tyString tySubst)) = Some df) :
    df = singleSubstD.
  Proof.
   rewrite (of_funcAsOk _ Ho) in Hf.
   unfold funcAs in Hf; simpl in *.
   rewrite type_cast_refl in Hf; [| apply _].
   unfold Rcast, Relim_refl in Hf.
   inversion Hf. reflexivity.
  Qed.

  Lemma of_single_subst_eq tus tvs (e : expr typ func)
    (df : ExprI.exprT tus tvs (typD (tyArr(tyArr tyStack tyVal) (tyArr tyString tySubst))))
    (Ho : open_funcS e = Some of_single_subst)
    (Hf :exprD' tus tvs (tyArr (tyArr tyStack tyVal) (tyArr tyString tySubst)) e = Some df) :
    df = fun us vs => singleSubstD.
  Proof.
   destruct e; simpl in *; try congruence.
   autorewrite with exprD_rw in Hf; simpl in Hf; forward; inv_all; subst.
   erewrite <- of_single_subst_func_eq; try eassumption; reflexivity.
  Qed.

  Lemma mkNull_sound (tus tvs : tenv typ) :
    exprD' tus tvs tyVal mkNull = Some (fun _ _ => null).
  Proof.
    unfold mkNull; simpl.
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    pose proof of_fNullOk as Ho.
    pose proof (of_funcAsOk _ Ho) as H.
    rewrite H.
    unfold funcAs. simpl.
    rewrite type_cast_refl; [reflexivity | apply _].
  Qed.

  Lemma mkConst_sound (tus tvs : tenv typ) (t : typ) (c : expr typ func)
    (dc : ExprI.exprT tus tvs (typD t)) (Hc : exprD' tus tvs t c = Some dc) :
    exprD' tus tvs (tyArr tyStack t) (mkConst t c) = Some (exprT_App (fun _ _ => constD t) dc).
  Proof.
    unfold mkConst; simpl.
    pose proof (exprD_typeof_Some _ _ _ _ _ Hc) as Htc.
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    pose proof (of_fConstOk t) as Ho.
    pose proof (of_funcAsOk _ Ho) as H1.
    rewrite H1.
    unfold funcAs; simpl.
    rewrite type_cast_refl; [reflexivity|apply _].
  Qed.

  Lemma mkAp_sound (tus tvs : tenv typ) (t u : typ) (p q : expr typ func)
    (dp : ExprI.exprT tus tvs (typD (tyArr tyStack (tyArr t u))))
    (dq : ExprI.exprT tus tvs (typD (tyArr tyStack t)))
    (Hp : exprD' tus tvs (tyArr tyStack (tyArr t u)) p = Some dp)
    (Hq : exprD' tus tvs (tyArr tyStack t) q = Some dq) :
    exprD' tus tvs (tyArr tyStack u) (mkAp t u p q) =
      Some (exprT_App (exprT_App (fun _ _ => apD t u) dp) dq).
  Proof.
    unfold mkAp; simpl.
    pose proof (exprD_typeof_Some _ _ _ _ _ Hp) as Htp.
    pose proof (exprD_typeof_Some _ _ _ _ _ Hq) as Htq.
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    pose proof (of_fApOk t u) as Ho.
    pose proof (of_funcAsOk _ Ho) as H3; rewrite H3.
    unfold funcAs; simpl; rewrite type_cast_refl; [reflexivity | apply _].
  Qed.

  Lemma mkApplySubst_sound (tus tvs : tenv typ) (t : typ) (e s : expr typ func)
    (de : ExprI.exprT tus tvs (typD (tyArr tyStack t)))
    (ds : ExprI.exprT tus tvs (typD tySubst))
    (Hs : exprD' tus tvs tySubst s = Some ds)
    (He : exprD' tus tvs (tyArr tyStack t) e = Some de) :
    exprD' tus tvs (tyArr tyStack t) (mkApplySubst t e s) =
      Some (exprT_App (exprT_App (fun _ _ => applySubstD t) de) ds).
  Proof.
    unfold mkApplySubst; simpl.
    pose proof (exprD_typeof_Some _ _ _ _ _ Hs) as Hts.
    pose proof (exprD_typeof_Some _ _ _ _ _ He) as Hte.
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    pose proof (of_fApplySubstOk t) as Ho.
    pose proof (of_funcAsOk _ Ho) as H3; rewrite H3.
    unfold funcAs; simpl; rewrite type_cast_refl; [reflexivity | apply _].
  Qed.

  Lemma mkTruncSubst_sound (tus tvs : tenv typ) (s : expr typ func)
    (ds : ExprI.exprT tus tvs (typD tySubstList))
    (Hs : exprD' tus tvs tySubstList s = Some ds) :
    exprD' tus tvs tySubst (mkTruncSubst s) =
      Some (exprT_App (fun _ _ => truncSubstD) ds).
  Proof.
    unfold mkTruncSubst; simpl.
    pose proof (exprD_typeof_Some _ _ _ _ _ Hs) as Hts.
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    pose proof (of_fTruncSubstOk) as Ho.
    pose proof (of_funcAsOk _ Ho) as H3; rewrite H3.
    unfold funcAs; simpl; rewrite type_cast_refl; [reflexivity | apply _].
  Qed.

End MakeOpenSound.