From RecordUpdate Require Export RecordSet.
Export RecordSetNotations.
From mathcomp Require Export all_ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.

(********************)
(* メタ・アサンプション *)
(********************)

(* finTypeのtimestamp *)
Parameter limit_time' : nat.
Definition limit_time := limit_time' + 1.
Definition timestamp := ordinal limit_time.
Parameter now : timestamp.

(* 各行政機関を表す変数 *)
Inductive admin := Admin of nat.

(* 通貨 *)
Inductive currency := Curr of nat.

Definition plusc (x y : currency) :=
    match x, y with
    | Curr x_, Curr y_ => Curr (x_ + y_)
    end.

Definition minusc (x y : currency) :=
    match x, y with
    | Curr x_, Curr y_ => Curr (x_ - y_)
    end.

(* 市民 *)
Parameter citizen : finType.

(* 乱数 *)
Definition random := Type.

(* 乱数と集合をとり、ランダムに要素を抽出する関数 *)
Parameter random_choice : forall {T : finType}, {set T} -> random -> T.
Axiom random_choice_axiom : forall (T : finType) r (A : {set T}),
    random_choice A r \in A.

(* 乱数と集合をとり、任意の大きさの部分集合を返す関数 *)
(* この公理は、#|A| < n の時に矛盾が生じるので要修正 *)
Parameter random_choice_set : forall {T : finType} (A : {set T}),random -> nat -> {set T}.
Axiom random_choice_set_axiom : forall {T : finType} r (A : {set T}) n,
    let B := @random_choice_set T A r n in
    (B \subset A) && (#|B| == n).

(************)
(* アクション *)
(************)

Inductive proposal  :=
    (* 国庫・予算の入出金 *)
    | PwithdrawTreasury : currency -> proposal
    | PdepositTreasury : currency -> proposal
    | PwithdrawBudget : admin -> currency -> proposal
    | PdepositBudget : admin -> currency -> proposal
    | Pallocate : admin -> currency -> proposal
    (* 役職への任免・罷免 *)
    | PassignMember : admin -> citizen -> proposal
    | PdismissalMember : admin -> citizen -> proposal
    | PassignTenureWorker : admin -> citizen -> timestamp -> proposal
    | PdismissalTenureWorker : admin -> citizen -> proposal
    (* 市民登録・解除 *)
    | Pregister : citizen -> proposal
    | Pderegister : citizen -> proposal
    (* 行政の追加・削除 *)
    | PgenAdmin : admin -> proposal
    | PslashAdmin : admin -> proposal.

Inductive act :=
    (* グローバルな委員会への提案と熟議 *)
    | AglobalPropose : proposal -> random -> random -> random -> nat -> act
    | AglobalDeliberate : act
    (* subStateの委員会への提案と熟議 *)
    | AsubPropose : admin -> proposal -> random -> random -> random -> nat -> act
    | AsubDeliberate : admin -> act.

(************)
(* 状態と熟議 *)
(************)

Record comitee := mkDlb{
    Dproposal : proposal;
    Dprofessional : citizen;
    Dfacilitator : citizen;
    Ddeliberator : {set citizen};
}.

Record subState := mkSubState {
    SSbudget : currency;
    SSmember : {set citizen};
    SScomitee : option comitee;
    SStenureWorker : {set citizen * timestamp};
}.

Definition empty_subState := mkSubState (Curr 0) set0 None set0.

Record state := mkState{
    Streasury : currency;
    Smember : {set citizen};
    Scomitee : option comitee;
    Ssubstate : admin -> option subState
}.

(*******************)
(* 各種インスタンス化 *)
(*+++++++++++++++++*)

Instance etaSubState : Settable subState :=
    settable! mkSubState <SSbudget; SSmember; SScomitee; SStenureWorker>.

Instance etaState : Settable state :=
    settable! mkState
        < Streasury; Smember; Scomitee;Ssubstate >.

Coercion nat_of_admin a := let : Admin n := a in n.
Canonical admin_subType  := [newType for nat_of_admin ].
Definition admin_eqMixin := Eval hnf in [eqMixin of admin by <:].
Canonical admin_eqType := Eval hnf in EqType admin admin_eqMixin.

Coercion nat_of_currency a := let : Curr n := a in n.
Canonical currency_subType  := [newType for nat_of_currency ].
Definition currency_eqMixin := Eval hnf in [eqMixin of currency by <:].
Canonical currency_eqType := Eval hnf in EqType currency currency_eqMixin.

Tactic Notation "mkCompEq"  :=
    refine (EqMixin (compareP _)) => x y;
    unfold decidable; decide equality; apply eq_comparable.
Notation eqMixin := Equality.mixin_of.

Definition proposal_eqMixin : eqMixin proposal. Proof. mkCompEq. Qed.
Canonical Structure proposal_eqType := Eval hnf in @EqType proposal proposal_eqMixin.

Definition comitee_eqMixin  : eqMixin comitee. Proof. mkCompEq. Qed.
Canonical Structure comitee_eqType := Eval hnf in @EqType comitee comitee_eqMixin.

Definition subState_eqMixin : eqMixin subState. Proof.
    refine (EqMixin (compareP _)) => x y.
    unfold decidable; decide equality; apply eq_comparable.
Qed.
Canonical Structure subState_eqType := Eval hnf in @EqType subState subState_eqMixin.

(**********)
(* 状態遷移 *)
(**********)

(* 便利な関数 *)
Definition subst {dom : eqType} {ran} (d : dom) (r : ran) :=
    fun f => fun d' =>  if d == d' then Some r else (f d').
Notation "t ↦ b" := (subst t b)(at level 10).

Lemma subst_lemma {dom ran : finType} (f : dom -> option ran) (d : dom) (r : ran) :
    let f' := subst d r f in f' d = Some r.
Proof. rewrite /subst eq_refl => //. Qed.

Fixpoint findExpiration_ (p : seq (citizen * timestamp)) (c : citizen) : option timestamp :=
    match p with
    | [::] => None
    | (m,n) :: p' => if c == m then Some n else findExpiration_ p' c
    end.

Definition findExpiration (p : {set citizen * timestamp}) (c : citizen) : option timestamp :=
    findExpiration_ (enum p) c.

(* 熟議の実行関数の存在を仮定 *)
Parameter evalD : comitee -> bool.

Definition transv_  (p : proposal) (x : state)  :=
    match p with
    | PwithdrawTreasury n => x <| Streasury ::= minusc n|>
    | PdepositTreasury n => x <| Streasury ::= plusc n|>
    | PwithdrawBudget t n =>
        let ss := Ssubstate x t in
        match ss with
        | None => x
        | Some ss =>
            let ss' := ss <|SSbudget ::= minusc n|> in
            x <| Ssubstate ::= t ↦ ss'|>
        end
    | PdepositBudget t n =>
        let ss := Ssubstate x t in
        match ss with
        | None => x
        | Some ss =>
            let ss' := ss <|SSbudget ::= plusc n|> in
            x <| Ssubstate ::= t ↦ ss'|>
        end
    | Pallocate t n =>
        let ss := Ssubstate x t in
        match ss with
        | None => x
        | Some ss =>
            let ss' := ss <|SSbudget ::= minusc n|> in
            x  <| Ssubstate ::= t ↦ ss'|> <| Streasury ::= minusc n|>
        end

    | PassignMember t m =>
        let ss := Ssubstate x t in
        match ss with
        | None => x
        | Some ss =>
            let ss' := ss <| SSmember ::= fun mem => m |: mem |> in
            x <| Ssubstate ::= t ↦ ss'|>
        end
    | PdismissalMember t m =>
        let ss := Ssubstate x t in
        match ss with
        | None => x
        | Some ss =>
            let ss' := ss <| SSmember ::= fun mem => mem :\ m |> in
            x <| Ssubstate ::= t ↦ ss'|>
        end
    | PassignTenureWorker t m n =>
        let tw := (m,n) in
        let ss := Ssubstate x t in
        match ss with
        | None => x
        | Some ss =>
            let tws := SStenureWorker ss in
            x  <| Ssubstate ::= t ↦ (ss <|SStenureWorker := tw |: tws|>) |>
        end

    | PdismissalTenureWorker t m =>
        let ss := Ssubstate x t in
        match ss with
        | None => x
        | Some ss =>
            let tws := SStenureWorker ss in
            let n := findExpiration tws m in
            match n with
            | None => x
            | Some n' => x <| Ssubstate ::= t ↦ (ss <|SStenureWorker := tws :\ (m,n')|>) |>
            end
        end
    | Pregister m => x <| Smember ::= fun mem => m |: mem|>
    | Pderegister m => x <| Smember ::= fun mem => mem :\ m|>
    | PgenAdmin t =>
        let ss := Ssubstate x t in
        match ss with
        | None => x <|Ssubstate ::= t ↦ empty_subState|>
        | Some _ => x
        end
    | PslashAdmin t =>
        let ss := Ssubstate x t in
        match ss with
        | None => x
        | Some _ => x <|Ssubstate ::= fun f => fun t' => if t' == t then None else f t'|>
        end

    end.

Definition trans_ (a : act) (x : state) :=
    match a with
    | AsubPropose adm a' p_ f_ d_ n =>
        let ss := Ssubstate x adm in
        match ss with
        | None => x
        | Some ss =>
            let mem := SSmember ss in
            let p := random_choice mem p_ in
            let f := random_choice mem f_ in
            let d := random_choice_set mem d_ n in
            let ss' := ss <|SScomitee := Some (mkDlb a' p f d)|> in
            x <| Ssubstate ::= adm ↦ ss'|>
        end

    | AsubDeliberate adm =>
        let ss := Ssubstate x adm in
        match ss with
        | None => x
        | Some ss =>
            let dlb_ := SScomitee ss in
            match dlb_ with
            | Some dlb =>
                if evalD dlb then transv_ (Dproposal dlb) x else x
            | None => x
            end
        end

    | AglobalPropose a' p_ f_ d_ n =>
        let mem := Smember x in
        let p := random_choice mem p_ in
        let f := random_choice mem f_ in
        let d := random_choice_set mem d_ n in
        x <|Scomitee := Some (mkDlb a' p f d)|>

    | AglobalDeliberate =>
        let dlb := Scomitee x in
        match dlb with
        | None => x
        | Some dlb_ =>
            if evalD dlb_ then transv_ (Dproposal dlb_) x else x
        end
    end.

Definition trans a x y := y = trans_ a x.

(***********)
(* 原子命題 *)
(***********)

Inductive var :=
    (* substaeの持ち得る状態についての制約 *)
    | hasNoBudget : admin -> var
    | hasNoComitee : admin -> var
    | hasNoTenureWoker : admin -> var
    | hasNoMember : admin -> var
    (* 行政機関が熟議できる提案の制約 *)
    | treasuryRestriction : admin -> var
    | budgetRestriction : admin -> var
    | allocateRestriction : admin -> var
    | assignRestriction : admin -> var
    | registerRestriction : admin -> var
    | adminControlRestriction : admin -> var
    (* globalStateが熟議できる提案の制約 *)
    | globalRestriction : var
    (* その他 *)
    | isAssigned : admin -> citizen -> var
    | isProposed : admin -> proposal -> var
    | isTenureWorker : admin -> citizen -> var
    | withinExpiration : admin -> citizen-> var
    (* | isValidComitee : admin -> admin -> admin -> var *)
    .

Definition valuation (x : var) (s : state) : bool :=
    match x with
    | hasNoBudget t =>
        let ss := Ssubstate s t in
        match ss with
        | None => true
        | Some ss => SSbudget ss == Curr 0
        end
    | hasNoComitee t =>
        let ss := Ssubstate s t in
        match ss with
        | None => true
        | Some ss => SScomitee ss == None
        end
    | hasNoTenureWoker t =>
        let ss := Ssubstate s t in
        match ss with
        | None => true
        | Some ss => SStenureWorker ss == set0
        end
    | hasNoMember t =>
        let ss := Ssubstate s t in
        match ss with
        | None => true
        | Some ss => SSmember ss == set0
        end
    | treasuryRestriction t =>
            let ss := Ssubstate s t in
            match ss with
            | None => true
            | Some ss => let dlb := SScomitee ss
                in match dlb with
                | None => true
                | Some dlb' => let prp := Dproposal dlb' in
                    match prp with
                    | PwithdrawTreasury  _ => false
                    | PdepositTreasury _ => false
                    | _ => false
                    end
                end
            end
    | budgetRestriction t =>
            let ss := Ssubstate s t in
            match ss with
            | None => true
            | Some ss => let dlb := SScomitee ss
                in match dlb with
                | None => true
                | Some dlb' => let prp := Dproposal dlb' in
                    match prp with
                    | PwithdrawBudget t' _ => t == t'
                    | PdepositBudget t'  _ => t == t'
                    | _ => true
                    end
                end
            end
    | allocateRestriction t =>
            let ss := Ssubstate s t in
            match ss with
            | None => true
            | Some ss => let dlb := SScomitee ss
                in match dlb with
                | None => true
                | Some dlb' => let prp := Dproposal dlb' in
                    match prp with
                    | Pallocate _ _ => false
                    | _ => true
                    end
                end
            end
    | assignRestriction t =>
        let ss := Ssubstate s t in
            match ss with
            | None => true
            | Some ss => let dlb := SScomitee ss
                in match dlb with
                | None => true
                | Some dlb' => let prp := Dproposal dlb' in
                    match prp with
                    | PassignMember  _ _ => false
                    | PdismissalMember  _ _ => false
                    | PassignTenureWorker  _ _ _ => false
                    | PdismissalTenureWorker  _ _ => false
                    | _ => true
                    end
                end
            end
    | registerRestriction t =>
        let ss := Ssubstate s t in
            match ss with
            | None => true
            | Some ss => let dlb := SScomitee ss
                in match dlb with
                | None => true
                | Some dlb' => let prp := Dproposal dlb' in
                    match prp with
                    | Pregister _ => false
                    | Pderegister _ => false
                    | _ => true
                    end
                end
            end
    | adminControlRestriction t =>
        let ss := Ssubstate s t in
            match ss with
            | None => true
            | Some ss => let dlb := SScomitee ss
                in match dlb with
                | None => true
                | Some dlb' => let prp := Dproposal dlb' in
                    match prp with
                    | PgenAdmin _ => false
                    | PslashAdmin _ => false
                    | _ => true
                    end
                end
            end
    | globalRestriction =>
        let dlb := Scomitee s in
        match dlb with
        | None => true
        | Some dlb => let prp := Dproposal dlb in
            match prp with
            | Pregister  _ => false
            | Pderegister _ => false
            | PwithdrawBudget _ _ => false
            | PdepositBudget  _ _ => false
            | _ => true
            end
        end

    | isAssigned a m =>
        let ss := Ssubstate s a in
        match ss with
        | None => true
        | Some ss =>
            let mem := SSmember ss in
            m \in mem
        end
    | isProposed adm a =>
        let ss := Ssubstate s adm in
        match ss with
        | None => true
        | Some ss =>
            let dlb_ := SScomitee ss in
            match dlb_ with
            | Some  dlb =>
                a == Dproposal dlb
            | None => false
            end
        end
    | isTenureWorker t m  =>
        let ss := Ssubstate s t in
        match ss with
        | None => true
        | Some ss =>
            let tws := SStenureWorker ss in
            let n := findExpiration tws m in
            match n with
            | Some _ => true
            | _ => false
            end
        end
    | withinExpiration t m =>
        let ss := Ssubstate s t in
        match ss with
        | None => true
        | Some ss =>
            let tws := SStenureWorker ss in
            let tw := findExpiration tws m in
            match tw with
            | None => false
            | Some n => now < n
            end
        end
    (* | isValidComitee t ps fs =>
        let ss := Ssubstate s t in
        match ss with
        | None => true
        | Some ss =>
            let ssp := Ssubstate s ps in
            let ssf := Ssubstate s fs in
            match ssp, ssf with
            | Some ssp, Some ssf =>
                let pf := SStenureWorker ssp in
                let fc := SStenureWorker ssf in
                let dlb_ := SScomitee ss in
                match dlb_ with
                | Some  dlb =>
                    [exists n,  (Dprofessional dlb, n) \in pf] &&
                    [exists n, (Dfacilitator dlb, n) \in fc] &&
                    (Ddeliberator dlb != set0)
                | None => false
                end
            | _ , _ => false
            end
        end      *)
    end.


Require Import Arith.
Require Import Omega.
Require Import String.
Require Import List.
Import ListNotations.

Require Import OrderedType OrderedTypeEx.
Require FMapList.
Require FMapFacts.
Module NatMap := FMapList.Make Nat_as_OT.
Module NatMapFacts := FMapFacts.WFacts_fun Nat_as_OT NatMap.

Require Import stringfacts.
Require Import base.
Require Import ast.
Require Import logic.
Require Import vfs.

(* ************************************************************ *)
(* ************************************************************ *)
(*                                                              *)
(*                           caponfs                            *)
(*                                                              *)
(* ************************************************************ *)
(* ************************************************************ *)

Hypothesis undefined: forall T, T.

(*
 * the most ... bastardized fs model
 *)

Inductive caponvnode: Set :=
| capondir: nat -> dir_trace -> caponvnode
| caponfile: nat -> file_trace -> caponvnode
.

Inductive caponfs :=
| capon: NatMap.t caponvnode -> caponfs
.

Function caponfs_inum vn :=
   match vn with
   | capondir inum _ => inum
   | caponfile inum _ => inum
   end.

Function caponfs_isdir vn :=
   match vn with
   | capondir _ _ => true
   | caponfile _ _ => false
   end.

Function caponfs_isfile vn :=
   match vn with
   | capondir _ _ => false
   | caponfile _ _ => true
   end.

Function caponfs_dirtrace vn :=
   match vn with
   | capondir _ dt => dt
   | caponfile _ _ => dirtrace_empty (* ugh *)
   end.

Function caponfs_filetrace vn :=
   match vn with
   | capondir _ _ => filetrace_empty (* ugh *)
   | caponfile _ ft => ft
   end.

Function caponfs_getvnode fs inum: caponvnode :=
   match fs with
   | capon itbl => match NatMap.find inum itbl with
        | Some vn => vn
        | None => undefined caponvnode (* XXX *)
        end
   end.

Hypothesis caponfs_lookup: proc (caponvnode * string) (option caponvnode).
Hypothesis caponfs_create: proc (caponvnode * string) (option caponvnode).
Hypothesis caponfs_unlink: proc (caponvnode * string) (option unit).
Hypothesis caponfs_read: proc (caponvnode * nat * nat) bytes.
Hypothesis caponfs_write: proc (caponvnode * bytes * nat) unit.
Hypothesis caponfs_truncate: proc (caponvnode * nat) unit.
Hypothesis caponfs_fsync: proc caponvnode unit.
Hypothesis caponfs_getroot: proc caponfs caponvnode.
Hypothesis caponfs_sync: proc caponfs unit.
Hypothesis caponfs_newfs: proc unit caponfs.

Instance caponvnode_is_vnode: vnodeclass caponvnode := {
   inum_of_vnode := caponfs_inum;
   isdir := caponfs_isdir;
   isfile := caponfs_isfile;
   dirtrace_of_vnode := caponfs_dirtrace;
   filetrace_of_vnode := caponfs_filetrace;

   VOP_LOOKUP := caponfs_lookup;
   VOP_CREATE := caponfs_create;
   VOP_UNLINK := caponfs_unlink;
   VOP_READ := caponfs_read;
   VOP_WRITE := caponfs_write;
   VOP_TRUNCATE := caponfs_truncate;
   VOP_FSYNC := caponfs_fsync;
}.
Proof.
  - admit.
  - admit.
  - admit.
  - admit.
  - admit.
  - admit.
  - admit.
Admitted.

Instance caponfs_is_fs: fsclass caponfs := {
   vnode := caponvnode;
   vnode_is_vnodeclass := caponvnode_is_vnode;

   root_inum := 1;
   getvnode := caponfs_getvnode;

   VFS_GETROOT := caponfs_getroot;
   VFS_SYNC := caponfs_sync;

   newfs := caponfs_newfs;
}.
Proof.
  - admit.
  - admit.
  - admit.
Admitted.


Require Import MetaProp.
Require Import SyntaxProp.
Require Import DynamicProp.
Require Import TypesProp.
Require Import WellFormednessProp.
Require Import Shared.

Hint Constructors is_econtext.
Hint Constructors cfg_blocked.

Lemma exists_declsToRegionLocks :
  forall fs,
    exists RL, declsToRegionLocks fs RL.
Proof with eauto.
  introv. induction fs as [| [f t r] fs' IH].
  + exists (empty (A := region_id) (B := lock_status)).
    econstructor.
    introv fLookup.
    simpl in fLookup...
  + destruct IH as [RL H].
    exists (extend RL r LUnlocked).
    econstructor.
    introv fLookup.
    simpl in fLookup.
    remember (beq_nat f0 f) as fEq.
    destruct fEq.
    - inv_eq.
    - case_extend.
      inv H...
Qed.

Lemma single_threaded_progress :
  forall P t' Gamma H V n Ls e t,
    wfProgram P t' ->
    wfConfiguration P Gamma (H, V, n, T_Thread Ls e) t ->
    threads_done (T_Thread Ls e) \/
    cfg_blocked (H, V, n, T_Thread Ls e) \/
    exists cfg', P / (H, V, n, T_Thread Ls e) ==> cfg'.
Proof with eauto using step.
  introv wfP wfCfg.
  inverts wfCfg as Hfresh wfH wfV wfT wfL.
  inverts wfT as Hfree hasType wfLs wfL.
  hasType_cases(induction hasType) Case;

    (* All non-trivial cases step *)
    simpl; try(solve[eauto]); right;

    (* All variables must be dynamic *)
    match goal with
      | [Hfree : freeVars _ = nil |- _] =>
        simpl in Hfree;
          repeat
          match goal with
           | [Hfree : freeVars _ ++ _ = nil |- _] =>
             simpl in Hfree;
             apply app_eq_nil in Hfree as [Hfree1 Hfree2]
           | [x : var |- _] =>
             destruct x; try(congruence)
          end
      | _ => idtac
    end;

    (* If there's a target x, invert its typing derivation*)
    repeat
    match goal with
      | [H : Types.hasType ?P ?Gamma (EVar (DV ?x)) _ |- _ ] =>
        inv H
      | _ => idtac
    end;

    (* Each variable lookup in Gamma corresponds to some lookup in V *)
    repeat wfEnvLookup...
  + Case "T_New".
    right.
    assert (cLookup: exists i fs ms, classLookup P c = Some (Cls c i fs ms))
      by eauto using classLookup_not_none.
    destruct cLookup as (i & fs & ms & cLookup).
    assert(exRL: exists RL, declsToRegionLocks fs RL) by
        eauto using exists_declsToRegionLocks.
    destruct exRL as [RL].
    eexists; eapply EvalNew...
  + Case "T_Call".
    assert (wfL': wfLocking H (T_Thread Ls e))
      by eauto 3 using wfLocking_econtext.
    assert (IH: threads_done (T_Thread Ls e) \/
                cfg_blocked (H, V, n, T_Thread Ls e) \/
                exists cfg', P / (H, V, n, T_Thread Ls e) ==> cfg')...
    inv IH as [edone | [eBlocked | eSteps]]...
    - SCase "e done".
      right.
      destruct e; try(contradiction).
      inv hasType...
      wfEnvLookup.
      assert (wfC: wfType P (TClass c))...
      inverts wfC as cLookup.
      apply classLookup_not_none in cLookup as (i & fs & ms & cLookup).
      assert (Hsigs: methodSigLookup (extractSigs ms) m = Some (MethodSig m (y, t2) t))
        by eauto using methodSigs_sub.
      eapply extractSigs_sound in Hsigs as [e mLookup].
      assert (methods P (TClass c) = Some ms)
        by (simpl; rewrite cLookup; eauto).
      eexists; eapply EvalCall...
    - SCase "e can step".
      destruct eSteps as [[[[H' V'] n'] T'] eSteps].
      destruct T'...
      inv eSteps...
      inv eSteps...
  + Case "T_Select".
    right.
    inv hasType...
    assert (t2 = TClass c)...
    wfEnvLookup.
    eapply dyn_wfFieldLookup in wfF as [v []]...
    eexists. eapply EvalSelect...
  + Case "T_Update".
    assert (wfL': wfLocking H (T_Thread Ls e))
      by eauto 3 using wfLocking_econtext.
    assert (IH: threads_done (T_Thread Ls e) \/
                cfg_blocked (H, V, n, T_Thread Ls e) \/
                exists cfg', P / (H, V, n, T_Thread Ls e) ==> cfg')...
    inv IH as [edone | [eBlocked | eSteps]]...
    - SCase "e done".
      destruct e; try(contradiction)...
      inv hasType...
      wfEnvLookup...
    - SCase "e can step".
      destruct eSteps as [[[[H' V'] n'] T'] eSteps].
      destruct T'...
      inv eSteps...
      inv eSteps...
  + Case "T_Let".
    remember (fun e : expr => ELet x e body) as ctx.
    assert (is_econtext ctx). subst. apply EC_Let.
    assert (wfL': wfLocking H (T_Thread Ls e))
      by (apply wfLocking_econtext with ctx; crush).
    replace (ELet x e body) with (ctx e) by crush...
    assert (IH: threads_done (T_Thread Ls e) \/
                cfg_blocked (H, V, n, T_Thread Ls e) \/
                exists cfg', P / (H, V, n, T_Thread Ls e) ==> cfg')...
    inversion IH as [edone | [eBlocked | eSteps]]...
    - SCase "e done".
      subst.
      destruct e; try(contradiction)...
    - SCase "e can step".
      destruct eSteps as [[[[H' V'] n'] T'] eSteps].
      destruct T'...
      inverts eSteps...
      inverts eSteps...
  + Case "T_Cast".
    assert (wfL': wfLocking H (T_Thread Ls e))
      by eauto 3 using wfLocking_econtext.
    assert (IH: threads_done (T_Thread Ls e) \/
                cfg_blocked (H, V, n, T_Thread Ls e) \/
                exists cfg', P / (H, V, n, T_Thread Ls e) ==> cfg')...
    inv IH as [edone | [eBlocked | eSteps]]...
    - SCase "e done".
      destruct e; try(contradiction)...
    - SCase "e can step".
      destruct eSteps as [[[[H' V'] n'] T'] eSteps].
      destruct T'...
      inverts eSteps...
      inverts eSteps...
  + Case "T_Lock".
    destruct v...
    inv hasType.
    wfEnvLookup.
    assert (TClass c = t2)
      by (unfold fields in *; destruct t2; eauto).
    subst.
    assert(Hex: exists status, RL r = Some status).
      inv wfRL... rewrite_and_invert.
      destruct H1 as (f & t'' & fLookup)...
    inv Hex as [status RLlookup].
    assert(HIn: {In (l, r) Ls} + {~ In (l, r) Ls})
      by (apply in_dec; apply id_eq_dec).
    assert(wfLs: wfHeldLocks H Ls)
      by (inv wfL; eauto).
    destruct status; destruct HIn as [HIn|HnotIn]...
    eapply wfHeldLocks_taken in HIn...
    rewrite_and_invert.
  + Case "T_Locked".
    assert (wfL': wfLocking H (T_Thread Ls e))
      by eauto 3 using wfLocking_econtext.
    inv hasType1.
    wfEnvLookup.
    assert (HIn: In (l, r) Ls) by
      (inverts wfL as _ _ []; simpls; eauto).
    assert (Hlocked: RL r = Some LLocked)
      by (inv wfL; eauto using wfHeldLocks_taken).
    assert (IH: threads_done (T_Thread Ls e) \/
                cfg_blocked (H, V, n, T_Thread Ls e) \/
                exists cfg', P / (H, V, n, T_Thread Ls e) ==> cfg')...
    inv IH as [edone | [eBlocked | eSteps]]...
    - SCase "e done".
      destruct e; try(contradiction)...
    - destruct eSteps as [[[[H' V'] n'] T'] eSteps].
      destruct T'...
      inverts eSteps...
      inverts eSteps...
Qed.

Theorem progress :
  forall P t' Gamma cfg t,
    wfProgram P t' ->
    wfConfiguration P Gamma cfg t ->
    cfg_exn cfg \/ cfg_done cfg \/ cfg_blocked cfg \/
    exists cfg', P / cfg ==> cfg'.
Proof with eauto.
  introv wfP wfCfg.
  inverts wfCfg as Hfresh wfH wfV wfT wfL.
  gen t.
  induction T; intros; simpl...
  + Case "T = Thread".
    right. eapply single_threaded_progress...
  + Case "T = Async T1 T2 e".
    inverts wfT as Hfree hasType wfT1 wfT2.
    inverts wfL as wfL HL Hdisj wfL1 wfL2.
    right. right.
    pose proof (IHT1 wfL1 t1 wfT1) as IH1.
    pose proof (IHT2 wfL2 t2 wfT2) as IH2.
    destruct IH1 as [T1EXN|[T1Done|[T1Blocked|T1Steps]]]...
    - SCase "T1 done".
      unfolds in T1Done. unfold threads_done in T1Done.
      destruct T1; try(solve[inv T1Done]).
      destruct IH2 as [T2EXN|[T2Done|[T2Blocked|T2Steps]]]...
      * SSCase "T2 steps".
        destruct T2Steps as [[[[H' V'] n'] T2']].
        right. eexists; eapply EvalAsyncRight...
    - SCase "T1 blocked".
      destruct IH2 as [T2EXN|[T2Done|[T2Blocked|T2Steps]]]...
      * SSCase "T2 steps".
        destruct T2Steps as [[[[H' V'] n'] T2']].
        right. eexists; eapply EvalAsyncRight...
    - SCase "T1 steps".
      destruct T1Steps as [[[[H' V'] n'] T2']].
      right. eexists; eapply EvalAsyncLeft...
Qed.


Require Import Coqlib.
Require Import Integers.
Require Import Floats.
Require Import AST.
Require Import Lop.
Require Import Lustre.
Require Import Maps.

(** * Global Declares *)

(** * Types *)

(** Types include short (signed 16 bits), ushort (unsigned 16 bits),int(signed 32 bits),
  uint(unsigned 32 bits), float (32 bits), real (64 bits), bool(true or false), char,
  array, struct and enum. *)

(** The syntax of type expressions.  Some points to note:
- struct type, e.g type s1 = { n : int, m : real } is expressed by syntax as below:
       Tstruct "s1" (Fcons "n" (Tint)
                    (Fcons "m" (Treal)
                    Fnil))
- no recursive type, e.g type s = { m : s } is not allowed, although it canbe expressed by syntax.
*)

Inductive typeL : Type :=
  | Tint : typeL                            (**r integer types, signed 32 bits *)
  | Treal : typeL                           (**r floating-point types, 64 bits *)
  | Tbool : typeL                           (**r bool types *)
  | Tarray : ident -> typeL -> Z -> typeL   (**r array types: array_type_id(ty^len) *)
  | Tstruct : ident -> fieldlistL -> typeL  (**r struct types: struct_type_id {label1_id: type1; ...} *)
  | Tenum : list ident -> typeL    (**r enum types: enum_type_id {value1_id, ...} *)

with fieldlistL : Type :=
  | Fnil : fieldlistL
  | Fcons : ident -> typeL -> fieldlistL -> fieldlistL.

(** const_block
     Const block consisting of all character constants *)

Inductive constL : Type :=
  | IntConstL: int -> constL
  | RealConstL: float -> constL
  | BoolConstL: bool -> constL
  | ConstructConstL : const_listL -> constL     (**r E.g struct {label1 : 1, label2 : 2}, or array [1, 2] *)
  | ID : ident -> constL               (**r to define other constant by character constant *)

with const_listL : Type :=
  | ConstNilL : const_listL
  | ConstConL : constL -> const_listL -> const_listL.

(** * Expressions *)

Definition vars := list (ident * typeL * clock).

Inductive suboperator : Type :=
  | Nodehandler : ident -> bool -> list typeL -> suboperator.

Inductive exprT : Type :=
  | EconstT : const -> typeL -> exprT
  | EvarT : ident -> typeL -> clock -> exprT
  | ListExprT : expr_listT -> exprT                                           (**r list expression *)
  | ApplyExprT : suboperator -> expr_listT ->  exprT 	              (**r operator application *)
  | EconstructT : struct_listT -> exprT                                      (**r construct a struct, e.g {label1 : 3, label2 : false} *)
  | EarrayaccT : exprT -> int -> exprT                                     (**r expr[i], access to (i+1)th member of an array "expr" *)
  | EarraydefT :  exprT -> int -> exprT                               (**r expr ^ i, an array of size "i" with every element "expr" *)
  | EarraydiffT : expr_listT ->  exprT                                      (**r [list expression], build an array with elements "list expression", e.g [1,2]*)
  | EunopT : unary_operationL -> exprT -> exprT                            (**r unary operation *)
  | EbinopT : binary_operationL -> exprT -> exprT -> exprT                 (**r binary operation *)
  | EfieldT : exprT -> ident -> exprT                                      (**r access to a member of a struct *)
  | EpreT : exprT -> exprT                              (**r pre : shift flows on the last instant backward, producing an undefined value at first instant*)
  | EfbyT : expr_listT -> int -> expr_listT -> exprT  (**r fby : fby(b; n; a) = a -> pre fby(b; n-1; a) *)
  | EarrowT : exprT -> exprT -> exprT                                         (**r -> : fix the inital value of flows*)
  | EwhenT : exprT -> clock -> exprT                                          (**r x when h: if h=false, then no value; otherwise x *)
  | EcurrentT: exprT -> exprT
  | EmergeT: ident -> exprT -> exprT -> exprT
  | EifT : exprT -> exprT -> exprT -> exprT                                   (**r conditional*)
  | EdieseT: exprT -> exprT  (**r #(a1, ..., an) -> boolred(0,1,n)[a1, ..., an] *)
  | EnorT: exprT ->  exprT  (**r nor(a1, ..., an) boolred(0,0,n)[a1, ..., an] *)

with expr_listT : Type :=
  | Enil: expr_listT
  | Econs: exprT -> expr_listT -> expr_listT

with struct_listT: Type :=
  | EstructNil: struct_listT
  | EstructCons: ident -> exprT -> struct_listT -> struct_listT.

Inductive megaT : Type :=
  | MegaT : ident -> ident -> megaT.

Inductive ctrl_exprT : Type :=
  | ExprT : exprT -> ctrl_exprT
  | MegaExprT : megaT -> ctrl_exprT.

Inductive ctrl_lhs : Type :=
  | IdentT : vars -> ctrl_lhs
  | MegaLhsT : megaT -> ctrl_lhs.

(** * Equation *)

Inductive equationT : Type :=
  | EquationT: vars -> exprT -> equationT.

Inductive ctrl_equationT : Type :=
  | CtrlEquationT: ctrl_lhs -> ctrl_exprT -> ctrl_equationT.

(** * Node *)

(** Node : kind -> ID -> parameters -> returns -> locals -> body *)

Inductive nodeT : Type :=
  | NodeT : bool -> ident -> vars -> vars -> vars -> list equationT -> nodeT.

Inductive widgetT : Type :=
  | WidgetT : ident -> list(ident * typeL) -> vars -> vars -> widgetT.

Inductive ctrlT : Type :=
  | CtrlT : ident -> vars -> list ctrl_equationT -> ctrlT.

(** * Program *)
Definition wgtenvW := PTree.t widgetT.
Definition empty_wgtenvW := PTree.empty widgetT.

Record programT : Type := mkprogramT {
  type_blockT : list (ident*typeL);
  const_blockT : list (ident*typeL*constL);
  node_blockT : list nodeT;
  controlT : ctrlT;
  widget_blockT : wgtenvW;
  node_mainT : ident
}.


(** Proofs of correctness *)

From MetaCoq Require Import utils.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils
     PCUICLiftSubst PCUICWcbvEval PCUICTyping.

From ConCert Require Import CustomTactics MyEnv
     EnvSubst Ast EvalE PCUICFacts  PCUICTranslate
     PCUICCorrectnessAux Wf Misc.

From Coq Require Import String List.

Import ListNotations ssrbool Basics Lia.
Import NamelessSubst.

Local Set Keyed Unification.

(** Soundness (In the paper: Theorem 1) *)
Theorem expr_to_term_sound (n : nat) (ρ : env val) Σ1 Σ2 (Γ:=[])
        (e1 e2 : expr) (v : val) :
  genv_ok Σ1 ->
  env_ok Σ1 ρ ->
  eval(n, Σ1, ρ, e1) = Ok v ->
  e1.[exprs ρ] = e2 ->
  iclosed_n 0 e2 = true ->
  Σ2 ;;; Γ |- t⟦e2⟧Σ1 ⇓ t⟦of_val_i v⟧Σ1.
Proof.
  revert dependent v.
  revert dependent ρ.
  revert dependent e2.
  revert dependent e1.
  induction n.
  - intros;tryfalse.
  - intros e1 e2 ρ v Hgeok Hρ_ok He Henv Hc;destruct e1.
    + (* eRel *) simpl in *. autounfold with facts in *. simpl in *.
      destruct (lookup_i ρ n0) as [v1| ] eqn:Hlookup;tryfalse; simpl in He;inversion He;subst.
      destruct (Nat.ltb n0 (length ρ)) eqn:Hn0.
      * destruct (inst_env_i_in _ _ Hn0) as [v2 HH].
        destruct HH as [H1 H2].
        assert (v = v2) by congruence. subst.
        assert (ge_val_ok Σ1 v2) by (apply val_ok_ge_val_ok;eapply All_lookup_i;eauto).
        rewrite H2.
        eapply PcbvCurr.value_final; eapply Wcbv_of_value_value; eauto with hints.
        eapply All_lookup_i;eauto.
      * specialize (lookup_i_length_false _ _ Hn0) as Hnone;tryfalse.
    + (* eVar *) simpl;tryfalse.
    + (* eLambda *)
      subst. simpl in *.
      destruct (eval_type_i 0 ρ t) eqn:Hty;tryfalse;simpl in *.
      destruct (valid_env ρ 1 e1) eqn:He1;tryfalse. inv_andb Hc.
      inversion He;subst;simpl;eauto with hints.
      erewrite eval_type_i_subst_env;eauto.
      rewrite subst_env_ty_closed_n_eq with (n:=0) (m:=0);eauto with hints.
    + simpl in *. destruct (valid_env ρ 1 e1) eqn:He1;tryfalse.
      inversion He. subst;clear He.
      simpl. constructor;eauto.
    + (* eLetIn *)
      subst;simpl in *.
      unfold is_true in *;
        repeat rewrite  Bool.andb_true_iff in *.
      destruct Hc as [[? ?] ?].
      destruct (eval (n, Σ1, ρ, e1_1)) eqn:He1;tryfalse.
      destruct (eval_type_i 0 ρ t) eqn:Ht0;tryfalse. inversion He;subst;clear He.
      assert (He11 : Σ2;;; Γ |- t⟦ e1_1 .[ exprs ρ] ⟧ Σ1 ⇓  t⟦ of_val_i v0 ⟧ Σ1)
        by (eauto with hints).
      assert (ty_expr_env_ok (exprs ρ) 0 e1_1) by (eapply eval_ty_expr_env_ok;eauto with hints).

      assert (iclosed_n #|exprs ρ # [e ~> of_val_i v0]| e1_2 = true).
      { simpl. eapply subst_env_iclosed_n_inv with (n:=1);eauto with hints. }

      assert (ty_expr_env_ok (exprs ρ # [e ~> of_val_i v0]) 0 e1_2).
      { change (exprs ρ # [e ~> of_val_i v0]) with (exprs (ρ # [e ~> v0])).
        eapply eval_ty_expr_env_ok;eauto with hints. simpl.
        replace #|ρ| with (#|exprs ρ|) by apply map_length.
        eapply subst_env_iclosed_n_inv with (n:=1);eauto with hints. }

      assert (val_ok Σ1 v0) by (eapply eval_val_ok;eauto with hints).
      assert (He12 : Σ2;;; Γ |- t⟦ e1_2 .[exprs ((e, v0) :: ρ)] ⟧ Σ1 ⇓ t⟦ of_val_i v ⟧ Σ1).
      { eapply IHn with (ρ:=((e, v0) :: ρ));simpl;eauto 6 with hints. }
      simpl in *. unfold subst_env_i in *.
      econstructor;eauto. unfold subst1.
      erewrite <- subst_term_subst_env_par_rec in He12 by eauto with hints.
      erewrite <- subst_term_subst_env_par_rec;eauto with hints.
      now rewrite <- subst_app_simpl.
      now eapply ty_expr_env_ok_app_rec with (n:=0) (ρ1:=[(e,of_val_i v0)]).
    + (* eApp *)
      autounfold with facts in *. subst; cbn in *.
      destruct (expr_eval_general _ _ _ _ e1_2) eqn:He2;tryfalse.
      destruct (expr_eval_general _ _ _ _ e1_1) eqn:He1;tryfalse.
      apply Bool.andb_true_iff in Hc. destruct Hc as [Hce1 Hce2].
      assert (Hneq1 : [t⟦ inst_env_i ρ e1_2 ⟧ Σ1] <> []) by easy.
      destruct v1;tryfalse.
      * (* application evaluates to a constructor *)
        inversion_clear He. simpl_vars_to_apps. subst. simpl in *.
        rename e into n0.
        change (tApp (t⟦ vars_to_apps (eConstr i n0) (map of_val_i l) ⟧ Σ1) (t⟦ of_val_i v0 ⟧ Σ1))
          with (mkApps (t⟦ vars_to_apps (eConstr i n0) (map of_val_i l) ⟧ Σ1) [t⟦ of_val_i v0 ⟧ Σ1]).

        eapply PcbvCurr.eval_app_cong;eauto with hints.
        change (vars_to_apps (eConstr i n0) (map of_val_i l)) with (of_val_i (vConstr i n0 l)).
        eapply IHn;eauto with hints.
      * destruct c.
        ** (* the closure corresponds to lambda *)
          simpl in *. rename e0 into n0.
          simpl in *.
          assert (Hv0 : Σ2;;; Γ |- t⟦e1_2 .[ exprs ρ]⟧ Σ1 ⇓ t⟦ of_val_i v0 ⟧ Σ1)
            by eauto.
          assert (Hv0_ok : val_ok Σ1 v0) by (eapply eval_val_ok;eauto with hints).
          assert (Hlam_ok : val_ok Σ1 (vClos e n0 cmLam t t0 e1)) by
             (eapply eval_val_ok with(e:=e1_1);eauto with hints).
          inversion Hlam_ok;subst.
          assert (He_ok1 : env_ok Σ1 (e # [n0 ~> v0])) by now constructor.
          assert
           (Hlam : Σ2;;; Γ |- t⟦e1_1 .[ exprs ρ]⟧ Σ1 ⇓ t⟦ of_val_i (vClos e n0 cmLam t t0 e1) ⟧ Σ1) by
              (eapply IHn with (ρ:=ρ);eauto).
          assert (AllEnv (fun e1 : expr => iclosed_n 0 e1 = true) (exprs e)).
           { inversion He_ok1. subst.
             apply All_map. unfold compose. simpl.
             eapply (All_impl (P := fun x => val_ok Σ1 (snd x)));eauto.
             intros a ?; destruct a; simpl;eauto with hints. }
           assert (iclosed_n 1 (e1 .[ exprs e] 1) = true)
            by eauto with hints.
           assert (ty_expr_env_ok [(n0, of_val_i v0)] 0 (e1.[exprs e]1)).
           { eapply ty_expr_env_ok_subst_env;eauto;simpl.
             change (exprs e # [n0 ~> of_val_i v0]) with (exprs (e # [n0 ~> v0])).
             eapply eval_ty_expr_env_ok;eauto. }

           assert (Hsubst : Σ2;;;Γ |- (t⟦e1.[exprs e]1⟧Σ1){0 := t⟦of_val_i v0⟧Σ1} ⇓ t⟦of_val_i v⟧ Σ1).
           { rewrite subst_term_subst_env with (nm:=n0); eauto 8 with hints. }

           simpl in *.
           eapply PcbvCurr.eval_beta;eauto.
        ** (* the closure corresponds to fix *)
          simpl in *. rename e into ρ'. rename e0 into n0.
          destruct v0;tryfalse.
          (* destruct (expr_eval_general _ _ _ _ e1) eqn:Hee1;tryfalse. *)
          (* inversion He;subst. *)
          simpl in *.
          remember (t⟦e1_1.[exprs ρ] ⟧ Σ1) as tm1.
          remember (t⟦ e1_2.[exprs ρ] ⟧ Σ1) as tm2.
          assert (Hfix : Σ2;;; Γ |- tm1 ⇓ t⟦ of_val_i (vClos ρ' n0 (cmFix _) t t0 e1) ⟧ Σ1)
            by (subst;eauto with hints).

          change (tApp tm1 tm2) with (mkApps tm1 [tm2]).
          simpl in Hfix.
          assert (Hok_ctor: val_ok Σ1 (vConstr i _ l)) by
              (eapply eval_val_ok with (e:=e1_2);eauto 8 with hints).
          inversion Hok_ctor as [ | | | ?????  HresC |];subst;clear Hok_ctor;eauto.
          assert (Hconstr : is_constructor 0 [t⟦ of_val_i (vConstr i e l) ⟧ Σ1]).
          { simpl. rewrite <- mkApps_vars_to_apps. cbn.
            unfold isConstruct_app.
            rewrite decompose_app_mkApps; now rewrite HresC. }
          eapply PcbvCurr.eval_fix with (args':=[t⟦ of_val_i (vConstr i e l) ⟧ Σ1]);
            subst;eauto with hints;try reflexivity.
          cbn. remember (tFix _ _) as tfix. rewrite simpl_subst_k by auto.
          assert (Hok_fix : val_ok Σ1 ((vClos ρ' n0 (cmFix _) t t0 e1)))
            by (eapply eval_val_ok with (e:=e1_1);eauto with hints).
          assert (tfix = t⟦eFix e2 n0 t t0 (e1.[exprs ρ']2)⟧ Σ1).
          { simpl. inversion Hok_fix;subst. subst.
            repeat rewrite subst_env_i_ty_closed_eq;eauto with hints. }
          clear Heqtfix. subst tfix.
          inversion Hok_fix;subst;clear Hok_fix.

          remember (eFix _ _ _ _ _) as efix.

          assert (Hexprs : AllEnv (fun e => iclosed_n 0 e = true) (exprs ρ')).
          { apply All_map.
            eapply (All_impl (P := fun v => val_ok Σ1 (snd v)));try assumption;
              intros a ?;destruct a;cbv;eauto with hints. }

          eapply PcbvCurr.eval_beta;eauto with hints.
          eapply PcbvCurr.value_final.
          eapply Wcbv_value_vars_to_apps;eauto with hints.
          now eapply All_value_of_val.
          assert (All (fun v0 : val => iclosed_n 0 (of_val_i v0) = true) l).
          { eapply All_impl. apply X. intros.
            eapply of_value_closed;eauto with hints. }

          remember (vars_to_apps _ _) as args.
          assert (ty_expr_env_ok (nil # [e2 ~> efix] # [n0 ~> args]) 0 (e1.[ exprs ρ']2)).
          { subst.
            eapply ty_expr_env_ok_subst_env.
            assert (H : ty_expr_env_ok (exprs ((n0, vConstr i e l) :: (e2, vClos ρ' n0 (cmFix e2) t t0 e1) :: ρ'))  0 e1) by (eapply eval_ty_expr_env_ok;eauto).
            cbn in H. repeat rewrite subst_env_i_ty_closed_0_eq in H by auto. easy.
            now eapply closed_exprs. }

          assert (AllEnv (iclosed_n 0) [(n0, args); (e2, efix)]).
          { subst;repeat constructor;unfold compose;simpl.
            now eapply vars_to_apps_iclosed_n. repeat split_andb;eauto with hints. }

          unfold subst1. rewrite <- subst_app_simpl. simpl.

          erewrite subst_term_subst_env_2 with (nm1:=n0) (nm2:=e2) by eauto with hints.

          remember ((n0,_) :: (e2,_) :: ρ') as ρ''.

          assert (Hok_ctor: val_ok Σ1 (vConstr i _ l)) by eauto 8 with hints.
          assert (Hok_fix : val_ok Σ1 ((vClos ρ' n0 (cmFix e2) t t0 e1))) by
            (eapply eval_val_ok with (ρ:=ρ)(e:=e1_1);eauto with hints).

          eapply IHn with (ρ:=ρ''); subst;eauto with hints.
          rewrite <- subst_env_compose_2;
            (simpl; eauto using vars_to_apps_iclosed_n with hints).
          cbn.
          now repeat rewrite subst_env_i_ty_closed_0_eq by auto.
          repeat split_andb;eauto with hints.
      * rename e0 into n0.
        assert (Hv0 : Σ2;;; Γ |- t⟦e1_2 .[ exprs ρ]⟧ Σ1 ⇓ t⟦ of_val_i v0 ⟧ Σ1)
          by eauto with hints.
        assert (Hv0_ok : val_ok Σ1 v0) by eauto 8 with hints.
        assert (Hlam_ok : val_ok Σ1 (vTyClos e n0 e1))
          by eauto 8 with hints.
        inversion Hlam_ok;subst.
        assert (He_ok1 : env_ok Σ1 (e # [n0 ~> v0])) by now constructor.
        assert
         (Hlam : Σ2;;; Γ |- t⟦e1_1 .[ exprs ρ]⟧ Σ1 ⇓ t⟦ of_val_i (vTyClos e n0 e1) ⟧ Σ1) by
            (eapply IHn with (ρ:=ρ);eauto).
        assert (AllEnv (fun e1 : expr => iclosed_n 0 e1 = true) (exprs e)).
         { inversion He_ok1. subst.
           apply All_map. unfold compose. simpl.
           eapply (All_impl (P := fun x => val_ok Σ1 (snd x)));eauto.
           intros a ?; destruct a; simpl;eauto with hints. }
         assert (iclosed_n 1 (e1 .[ exprs e] 1) = true)
          by eauto with hints.
         assert (ty_expr_env_ok [(n0, of_val_i v0)] 0 (e1.[exprs e]1)).
         { eapply ty_expr_env_ok_subst_env;eauto;simpl.
           change (exprs e # [n0 ~> of_val_i v0]) with (exprs (e # [n0 ~> v0])).
           eapply eval_ty_expr_env_ok;eauto. }

         assert (Hsubst : Σ2;;;Γ |- (t⟦e1.[exprs e]1⟧Σ1){0 := t⟦of_val_i v0⟧Σ1} ⇓ t⟦of_val_i v⟧ Σ1).
         { rewrite subst_term_subst_env with (nm:=n0); eauto 8 with hints. }

         simpl in *.
         eapply PcbvCurr.eval_beta;eauto.
    + (* eConstr *)
      rename e into n0.
      cbn in He. destruct (resolve_constr Σ1 i n0) eqn:Hres;tryfalse.
      inversion He;subst;clear He.
      simpl in *. rewrite Hres in *. eauto with hints.
    + (* eConst *)
      (* The traslation does not support constants yet *)
      inversion He.
    + (* eCase *)
      unfold expr_eval_i in He. destruct p.
      (* dealing with the interpreter *)
      simpl in He.
      unfold is_true in Hc;subst;simpl in Hc;repeat rewrite  Bool.andb_true_iff in *.
      destruct Hc as [[[Hce1 ?] ?] HH].
      destruct (forallb _ l) eqn:Hl;tryfalse.
      destruct (eval_type_i _ _ t) eqn:Ht0;tryfalse;simpl in *.
      destruct (monad_utils.monad_map) eqn:Hmm;tryfalse.
      destruct (expr_eval_general _ _ _ _ e1) eqn:He1;tryfalse.
      destruct v0;tryfalse.
      destruct (string_dec _ _) eqn:Hi;tryfalse;subst.
      unfold resolve_constr in *. simpl.
      destruct (resolve_inductive _ _) eqn:HresI;tryfalse.
      destruct (lookup_with_ind _ _) eqn:Hfind_i;tryfalse.
      destruct p as [nparams cs]. destruct p0 as [i ci].  simpl in *.
      rewrite map_length.
      destruct (Nat.eqb nparams #|l0|) eqn:Hnparams;tryfalse.
      assert (HresC: resolve_constr Σ1 i0 e = Some (nparams,i, ci)).
      { unfold resolve_constr. rewrite HresI. rewrite Hfind_i. reflexivity. }

      destruct (match_pat _ _ _ _) eqn:Hpat;tryfalse.

      (* dealing with the translation and the evaluation in PCUIC *)
      *  assert (IH' : Σ2;;; Γ |- t⟦ e1 .[ exprs ρ] ⟧ Σ1 ⇓ t⟦ of_val_i (vConstr i0 e l2) ⟧ Σ1) by
            eauto with hints.
        simpl in IH'.
        destruct p as [nm tys].
        rewrite map_map.
        erewrite <- mkApps_vars_to_apps_constr in IH' by eauto.
        simpl in IH'.
        eapply PcbvCurr.eval_iota;eauto.
        unfold iota_red in *. simpl in *.
        rewrite <- nth_default_eq in *.
        unfold nth_default in *.
        rewrite map_map.
        destruct (nth_error _) eqn:Hnth;remember ((fun (x : pat * expr) => _)) as f in Hnth.
        ** (* destruct p as [i ci0];simpl in *. *)
           specialize (lookup_ind_nth_error _ _ _ _ Hfind_i) as Hnth_eq.
           rewrite nth_error_map in Hnth_eq. destruct (nth_error cs i) eqn:Nci0;tryfalse.
           2 : { rewrite Nci0 in *;tryfalse. }
           erewrite map_nth_error in Hnth by eauto.
           inversion Hnth as [H1']. clear Hnth.
           rewrite Nci0 in Hnth_eq. simpl in Hnth_eq. inversion Hnth_eq. subst e.

           unfold trans_branch.

           (* Exploiting the fact that pattern-matching succeeds *)
           apply pat_match_succeeds in Hpat.
           destruct Hpat as [pt [Hfnd [Hci [Hl0 Hl2]]]].
           assert (
               Hfind : find (fun x => (pName (fst x) =? c.1)) (map f l) =
                     Some (f (pt, tys))).
           { eapply find_map with (p1 := fun x => (pName (fst x) =? c.1));auto.
             intros a;destruct a. subst f. cbn. reflexivity. }
           specialize (find_forallb_map _ Hfnd HH) as Hce1'. simpl in Hce1'.
           rewrite Hfind. subst f. cbn in *.
           assert (Hci' : #|ci| = #|pVars pt|) by lia.
           rewrite H3. rewrite Hci'. rewrite PeanoNat.Nat.eqb_refl.
           (* inversion H1';clear H1'. *)
           clear Hfind.

           subst. replace ((#|pVars pt| + 0)) with (#|pVars pt|) in * by lia.
           (* assert (Hcomb : *)
           (*           #|rev (combine (pVars p) ci)| = #|map (fun x : val => t⟦ of_val_i x ⟧ Σ1) l0|). *)
           (* { rewrite rev_length;rewrite map_length. rewrite Hl0. rewrite combine_length. rewrite Hci. lia. } *)
           assert (Hok_constr: val_ok Σ1 (vConstr i0 c.1 l2)) by eauto 8 with hints.
           inversion Hok_constr;subst;clear Hok_constr.
           rewrite pat_to_lam_rev.
           apply pat_to_lam_app_par;eauto with hints.
           *** apply All_skipn.
               apply All_map.
               now eapply All_value_of_val.
           *** apply All_forallb;eauto.
               apply All_skipn.
               apply All_map.
               now eapply All_term_closed_of_val.
           *** rewrite rev_length. rewrite combine_length.
               rewrite map_length. rewrite Hci'.
               rewrite PeanoNat.Nat.eqb_eq in Hnparams.
               rewrite skipn_length. rewrite map_length.
               lia.
           *** rewrite PeanoNat.Nat.eqb_eq in Hnparams.
               assert (Hlen_pl0 :
                         #|pVars pt| = #|combine (rev (pVars pt)) (rev l2)|)
                 by (rewrite combine_length; repeat rewrite rev_length; lia).

               assert (#|pVars pt| = #|skipn nparams l2|) by (rewrite skipn_length;lia).
               rewrite <- map_skipn.
               rewrite <- map_rev.
               remember (fun x : val => t⟦ _ ⟧ _) as f.
               remember (fun x : string * expr => t⟦ snd x ⟧ Σ1) as g.
               remember (t⟦ tys .[_] _⟧ _) as te3.
               assert (Hmap : map f (rev (skipn nparams l2)) =
                       map g (map (fun_prod id of_val_i)(rev (combine (pVars pt) (skipn nparams l2))))).
               { rewrite map_map.
                 subst g;simpl.
                 rewrite <- combine_rev by auto.
                 change (fun x : name * val => t⟦ of_val_i (snd x) ⟧ Σ1) with
                  (fun x : name * val => ((expr_to_pcuic Σ1) ∘ of_val_i) (snd x)).
                 rewrite <- map_map with (g:=(expr_to_term Σ1) ∘ of_val_i)
                                        (f:=snd).
                 rewrite map_combine_snd. now subst.
                 now repeat rewrite rev_length. }
               rewrite Hmap. subst g te3.
               rewrite subst_term_subst_env_par;eauto with hints.
               eapply IHn with (ρ:=(rev (combine (pVars pt) (skipn nparams l2)) ++ ρ)%list);
                 eauto with hints.
               ****  eapply All_app_inv;eauto. apply All_rev.
                     eapply All_env_ok;eauto with hints. now apply All_skipn.
               ****
                     (* rewrite <- combine_rev by (subst;auto). *)
                     unfold fun_prod,id.
                     rewrite map_app. subst nparams.
                     remember (rev (combine (pVars pt) (skipn #|l0| l2))) as l_rev.
                     assert (Hlrev : #|pVars pt| = #|exprs l_rev|).
                     { subst. rewrite map_length.
                       rewrite rev_length. rewrite combine_length.
                       rewrite skipn_length;lia. }
                     rewrite Hlrev.
                     symmetry. eapply subst_env_swap_app with (n:=0);
                                 eauto with hints.
                     apply All_map. subst.
                     apply All_rev. unfold compose. simpl.
                     apply All_snd_combine with (p:=(iclosed_n 0) ∘ of_val_i).
                     unfold compose.
                     eapply All_expr_iclosed_of_val;try apply All_skipn;eauto.
               **** rewrite <- combine_rev by auto.
                    rewrite map_combine_snd_funprod.
                    eapply subst_env_iclosed_0;eauto with hints.
                    remember ((combine (rev (pVars pt)) (map of_val_i (rev (skipn _ l2))))) as l_comb.
                    assert (Hlen : #|l_comb| = #|pVars pt|).
                    { subst. rewrite combine_length. rewrite map_length.
                      repeat rewrite rev_length. rewrite skipn_length;lia.  }
                    rewrite <- Hlen.
                    eapply ty_expr_env_ok_subst_env with (k:=0).
                    assert (Hcomb : exprs (rev (combine (pVars pt) (skipn nparams l2))) = l_comb).
                    { subst. repeat rewrite map_rev.  rewrite combine_rev.
                      apply f_equal. now rewrite  map_combine_snd_funprod.
                      rewrite map_length. rewrite skipn_length;lia. }
                    rewrite <- Hcomb. rewrite <- map_app.
                    subst nparams. eapply eval_ty_expr_env_ok;eauto with hints.
                    rewrite app_length.
                    replace (#|rev (combine (pVars pt) (skipn #|l0| l2))|) with #|pVars pt| by
                        (rewrite rev_length, combine_length, skipn_length;lia).
                    replace #|ρ| with #|exprs ρ| by apply map_length. eauto with hints.

                    eapply closed_exprs;eauto.

                    eapply All_snd_combine with (p:=iclosed_n 0);eauto with hints.
                    apply All_map. apply All_rev.
                    eapply All_expr_iclosed_of_val;eauto using All_skipn.

                    rewrite combine_length. rewrite map_length.
                    repeat rewrite rev_length. rewrite skipn_length by lia.
                    replace (min #|pVars pt| (#|l2| - nparams)) with #|pVars pt| by lia.
                    eauto with hints.

               **** rewrite <- combine_rev by auto.
                    rewrite map_combine_snd_funprod.
                    remember ((combine (rev (pVars pt)) (map of_val_i (rev (skipn _ l2))))) as l_comb.
                    assert (Hlen : #|l_comb| = #|pVars pt|).
                    { subst. rewrite combine_length. rewrite map_length.
                      repeat rewrite rev_length. rewrite skipn_length;lia.  }
                    rewrite <- Hlen.
                    eapply ty_expr_env_ok_subst_env with (k:=0).
                    assert (Hcomb : exprs (rev (combine (pVars pt) (skipn nparams l2))) = l_comb).
                    { subst. repeat rewrite map_rev.  rewrite combine_rev.
                      apply f_equal. now rewrite  map_combine_snd_funprod.
                      rewrite map_length. rewrite skipn_length;lia. }
                    rewrite <- Hcomb. rewrite <- map_app.
                    subst nparams. eapply eval_ty_expr_env_ok;eauto with hints.
                    rewrite app_length.
                    replace (#|rev (combine (pVars pt) (skipn #|l0| l2))|) with #|pVars pt| by
                        (rewrite rev_length, combine_length, skipn_length;lia).
                    replace #|ρ| with #|exprs ρ| by apply map_length. eauto with hints.
                    eapply closed_exprs;eauto.
               **** rewrite map_length. subst nparams.
                    replace (#|rev (combine (pVars pt) (skipn #|l0| l2))|) with #|pVars pt| by
                        (rewrite rev_length, combine_length, skipn_length;lia).
                    eauto with hints.
               ****  apply All_map. subst.
                     apply All_rev. unfold compose. simpl.
                     apply All_snd_combine with (p:=(iclosed_n 0) ∘ of_val_i).
                     unfold compose.
                     eapply All_expr_iclosed_of_val;try apply All_skipn;eauto.
        ** specialize (lookup_ind_nth_error _ _ _ _ Hfind_i) as Hnth_eq.
           rewrite nth_error_map in Hnth_eq.
           rewrite nth_error_map in Hnth.
           destruct (nth_error _ _) eqn:Nci0;tryfalse.
    + (* eFix *)
      simpl in *.
      destruct (valid_env _ _ _);tryfalse.
      destruct (eval_type_i 0 ρ t) eqn:Ht0;tryfalse.
      destruct (eval_type_i 0 ρ t0) eqn:Ht1;tryfalse.
      cbn in *. inversion He.
      subst;simpl. repeat erewrite eval_type_i_subst_env by eauto.
      repeat rewrite subst_env_i_ty_closed_eq by eauto 8 with hints.
      constructor;auto.
    + (* eTy *)
      simpl in *.
      destruct (eval_type_i 0 ρ t) eqn:Ht0;tryfalse;simpl in *.
      inversion He;subst;clear He. simpl.
      erewrite eval_type_i_subst_env by eauto.
      eapply Wcvb_type_to_term_eval;eauto with hints.
      eapply closed_exprs;eauto.
Qed.

(** ** Soundness for closed epxressions (In the paper: Corollary 2)*)
Corollary expr_to_term_sound_closed (n : nat) Σ1 Σ2 (Γ:=[])
          (e : expr) (v : val) :
  genv_ok Σ1 ->
  eval(n, Σ1, [], e) = Ok v ->
  iclosed_n 0 e = true ->
  Σ2 ;;; Γ |- t⟦e⟧Σ1 ⇓ t⟦of_val_i v⟧Σ1.
Proof.
  intros.
  eapply expr_to_term_sound;eauto with hints.
  simpl. symmetry. eapply subst_env_i_empty.
Qed.

(** ** Adequacy for terminating programs (In the paper: Theorem 3) *)
Theorem adequacy_terminating (n : nat) Σ1 Σ2 (Γ:=[])
        (e : expr) (t : term) (v : val) :
  genv_ok Σ1 ->
  eval(n, Σ1, [], e) = Ok v (* evaluation terminates *) ->
  Σ2 ;;; Γ |- t⟦e⟧Σ1 ⇓ t ->
  iclosed_n 0 e = true ->
  t = t⟦of_val_i v⟧Σ1.
Proof.
  intros.
  assert (Hcbv1 : Σ2 ;;; Γ |- t⟦ e ⟧Σ1 ⇓ t⟦ of_val_i v ⟧ Σ1)
    by (eapply expr_to_term_sound_closed;eauto).
  eapply PcbvCurr.eval_deterministic;eauto.
Qed.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Functor.
Require Export Category.Construction.Comma.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Definition Arrow {C : Category} : Category := (Id[C] ↓ Id[C]).

Notation "C ⃗" := (@Arrow C) (at level 90) : category_scope.


From cap_machine Require Export rules_Restrict rules_binary_base.
From iris.base_logic Require Export invariants gen_heap.
From iris.program_logic Require Export weakestpre ectx_lifting.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import frac.

Section cap_lang_spec_rules.
  Context `{cfgSG Σ, MachineParameters, invG Σ}.
  Implicit Types P Q : iProp Σ.
  Implicit Types σ : cap_lang.state.
  Implicit Types a b : Addr.
  Implicit Types r : RegName.
  Implicit Types w : Word.
  Implicit Types reg : gmap RegName Word.
  Implicit Types ms : gmap Addr Word.

  Lemma step_Restrict Ep K pc_p pc_g pc_b pc_e pc_a w dst src regs :
    decodeInstrW w = Restrict dst src ->
    isCorrectPC (inr (pc_p, pc_g, pc_b, pc_e, pc_a)) →
    regs !! PC = Some (inr (pc_p, pc_g, pc_b, pc_e, pc_a)) →
    regs_of (Restrict dst src) ⊆ dom _ regs →

    nclose specN ⊆ Ep →

    spec_ctx ∗ ⤇ fill K (Instr Executable) ∗ pc_a ↣ₐ w ∗ ([∗ map] k↦y ∈ regs, k ↣ᵣ y)
    ={Ep}=∗ ∃ retv regs', ⌜ Restrict_spec regs dst src regs' retv ⌝ ∗ ⤇ fill K (of_val retv) ∗ pc_a ↣ₐ w ∗ ([∗ map] k↦y ∈ regs', k ↣ᵣ y).
  Proof.
    iIntros (Hinstr Hvpc HPC Dregs Hcls) "(#Hinv & Hj & Hpc_a & Hmap)".
    iDestruct "Hinv" as (ρ) "Hinv". rewrite /spec_inv.
    iInv specN as ">Hinv'" "Hclose". iDestruct "Hinv'" as (e [σr σm]) "[Hown %] /=".
    iDestruct (regspec_heap_valid_inclSepM with "Hown Hmap") as %Hregs.
    have HPC' := regs_lookup_eq _ _ _ HPC.
    have Hx := lookup_weaken _ _ _ _ HPC Hregs.
    iDestruct (spec_heap_valid with "[$Hown $Hpc_a]") as %Hpc_a.
    iDestruct (spec_expr_valid with "[$Hown $Hj]") as %Heq; subst e.

    specialize (normal_always_step (σr,σm)) as [c [ σ2 Hstep]].
    eapply step_exec_inv in Hstep; eauto.

    specialize (indom_regs_incl _ _ _ Dregs Hregs) as Hri.
    unfold regs_of in Hri, Dregs. assert (Hstep':=Hstep).
    destruct (Hri dst) as [wdst [H'dst Hdst]]. by set_solver+.
    destruct wdst as [| cdst]; [| destruct_cap cdst].
    { rewrite /= /RegLocate Hdst in Hstep.
      destruct src; inv Hstep; simplify_pair_eq.
      all: iFailStep Restrict_fail_dst_noncap. }

    destruct (z_of_argument regs src) as [wsrc|] eqn:Hwsrc;
      pose proof Hwsrc as H'wsrc; cycle 1.
    { destruct src as [| r0]; cbn in Hwsrc; [ congruence |].
      destruct (Hri r0) as [r0v [Hr'0 Hr0]]. by unfold regs_of_argument; set_solver+.
      rewrite Hr'0 in Hwsrc. destruct r0v as [| cc]; [ congruence | destruct_cap cc].
      assert (c = Failed ∧ σ2 = (σr, σm)) as (-> & ->).
      { rewrite /= /RegLocate Hdst Hr0 in Hstep. by simplify_pair_eq. }
      iFailStep Restrict_fail_src_nonz. }
    eapply z_of_argument_Some_inv' in Hwsrc; eauto.

    destruct (decide (cdst = E)).
    { subst cdst. cbn in Hstep. rewrite /RegLocate Hdst in Hstep.
      repeat case_match; inv Hstep; iFailStep Restrict_fail_pE. }

    destruct (PermPairFlowsTo (decodePermPair wsrc) (cdst,cdst3)) eqn:Hflows; cycle 1.
    { rewrite /= /RegLocate Hdst in Hstep.
      destruct Hwsrc as [ -> | (r0 & -> & Hr0 & Hr0') ].
      all: rewrite ?Hr0' Hflows in Hstep.
      all: repeat case_match; inv Hstep; iFailStep Restrict_fail_invalid_perm. }

    assert ((c, σ2) = updatePC (update_reg (σr, σm) dst (inr (decodePermPair wsrc, cdst2, cdst1, cdst0)))) as HH.
    { rewrite /= /RegLocate Hdst in Hstep.
      destruct Hwsrc as [ -> | (r0 & -> & Hr0 & Hr0') ].
      all: rewrite ?Hr0' Hflows in Hstep.
      all: repeat case_match; inv Hstep; eauto; congruence. }
    clear Hstep. rewrite /update_reg /= in HH.

    destruct (incrementPC (<[ dst := inr (decodePermPair wsrc, cdst2, cdst1, cdst0) ]> regs)) eqn:Hregs';
      pose proof Hregs' as H'regs'; cycle 1.
    { apply incrementPC_fail_updatePC with (m:=σm) in Hregs'.
      eapply updatePC_fail_incl with (m':=σm) in Hregs'.
      2: by apply lookup_insert_is_Some'; eauto.
      2: by apply insert_mono; eauto.
      simplify_pair_eq.
      iMod ((regspec_heap_update_inSepM _ _ _ dst) with "Hown Hmap") as "[Hown Hmap]"; eauto.
      iFailStep Restrict_fail_PC_overflow. }

    eapply (incrementPC_success_updatePC _ σm) in Hregs'
      as (p' & g' & b' & e' & a'' & a_pc' & HPC'' & Hincr & HuPC & -> & ?).
    eapply updatePC_success_incl with (m':=σm) in HuPC. 2: by eapply insert_mono; eauto.
    simplify_pair_eq. iFrame.
    iMod ((regspec_heap_update_inSepM _ _ _ dst) with "Hown Hmap") as "[Hr Hmap]"; eauto.
    iMod ((regspec_heap_update_inSepM _ _ _ PC) with "Hr Hmap") as "[Hr Hmap]"; eauto.
    iMod (exprspec_mapsto_update _ _ (fill K (Instr NextI)) with "Hr Hj") as "[Hown Hj]".
    iExists NextIV,_. iFrame.
    iMod ("Hclose" with "[Hown]") as "_".
    { iNext. iExists _,_;iFrame. iPureIntro. eapply rtc_r;eauto.
      prim_step_from_exec.
    }
    iModIntro. iPureIntro. econstructor; eauto. Unshelve. all: try done.
  Qed.

  Lemma step_restrict_success_z Ep K pc_p pc_g pc_b pc_e pc_a pc_a' w r1 p g b e a z :
     decodeInstrW w = Restrict r1 (inl z) →
     isCorrectPC (inr (pc_p,pc_g,pc_b,pc_e,pc_a)) →
     (pc_a + 1)%a = Some pc_a' →
     PermPairFlowsTo (decodePermPair z) (p,g) = true →
     p ≠ E →
     nclose specN ⊆ Ep →

     spec_ctx ∗ ⤇ fill K (Instr Executable)
              ∗ ▷ PC ↣ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a)
              ∗ ▷ pc_a ↣ₐ w
              ∗ ▷ r1 ↣ᵣ inr (p,g,b,e,a)
     ={Ep}=∗ ⤇ fill K (Instr NextI)
         ∗ PC ↣ᵣ inr (pc_p,pc_g,pc_b,pc_e,pc_a')
         ∗ pc_a ↣ₐ w
         ∗ r1 ↣ᵣ inr (decodePermPair z,b,e,a).
  Proof.
    iIntros (Hinstr Hvpc Hpca' Hflows HpE Hnclose) "(Hown & Hj & >HPC & >Hpc_a & >Hr1)".
    iDestruct (map_of_regs_2 with "HPC Hr1") as "[Hmap %]".
    iMod (step_Restrict with "[$Hown $Hj $Hmap $Hpc_a]") as (retv regs' Hspec) "(Hj & Hpc_a & Hregs)";
      eauto; simplify_map_eq_alt; try rewrite lookup_insert; eauto.
      by unfold regs_of; rewrite !dom_insert; set_solver+.

    destruct Hspec as [| * Hfail].
    { (* Success *)
      iFrame. simpl in *. incrementPC_inv; simplify_map_eq_alt.
      rewrite (insert_commute _ PC r1) // insert_insert
              (insert_commute _ PC r1) // insert_insert.
      iDestruct (regs_of_map_2 with "Hregs") as "(?&?)"; eauto; by iFrame. }
    { (* Failure (contradiction) *)
      destruct Hfail; simpl in *; simplify_map_eq_alt; eauto; try congruence.
      incrementPC_inv;[|rewrite lookup_insert_ne// lookup_insert;eauto].
      destruct e4; try congruence. inv Hvpc; naive_solver. }
  Qed.

End cap_lang_spec_rules.


From fae_gtlc_mu.refinements.gradual_static Require Export compat_cast.defs.
From fae_gtlc_mu.stlc_mu Require Export lang.
From fae_gtlc_mu.cast_calculus Require Export types.

Section compat_cast_sum_sum.
  Context `{!implG Σ,!specG Σ}.

  Hint Extern 5 (AsVal _) => eexists; simpl; try done; eapply cast_calculus.lang.of_to_val; fast_done : typeclass_instances.

  Lemma back_cast_ar_sum_sum:
    ∀ (A : list (type * type)) (τ1 τ1' τ2 τ2' : type) (pC1 : alternative_consistency A τ1 τ1') (pC2 : alternative_consistency A τ2 τ2')
      (IHpC1 : back_cast_ar pC1) (IHpC2 : back_cast_ar pC2),
      back_cast_ar (throughSum A τ1 τ1' τ2 τ2' pC1 pC2).
  Proof.
    intros A τ1 τ1' τ2 τ2' pC1 pC2 IHpC1 IHpC2.
    rewrite /back_cast_ar. iIntros (ei' K' v v' fs) "(#Hfs & #Hvv' & #Hei' & Hv')".
    iDestruct "Hfs" as "[% Hfs']"; iAssert (rel_cast_functions A fs) with "[Hfs']" as "Hfs". iSplit; done. iClear "Hfs'".
    rewrite /𝓕c /𝓕. fold (𝓕 pC1) (𝓕 pC2). rewrite between_TSum_subst_rewrite /between_TSum.
    iMod ((step_lam _ ei' K') with "[Hv']") as "Hv'"; auto. simpl.
    rewrite interp_rw_TSum.
    iDestruct "Hvv'" as "[H1 | H2]".
    + iDestruct "H1" as ((v1 , v1')) "[% Hv1v1']". inversion H0. clear H0 H2 H3 v v'.
      iMod ((step_case_inl _ ei' K') with "[Hv']") as "Hv'"; auto. asimpl.
      wp_head.
      iApply (wp_bind [cast_calculus.lang.InjLCtx]).
      iApply (wp_wand with "[-]").
      iApply (IHpC1 ei' (InjLCtx :: K') with "[Hv']"); iFrame; auto.
      iIntros (v1f) "HHH". iDestruct "HHH" as (v1f') "[Hv1f' Hv1fv1f']".
      iApply wp_value.
      iExists (InjLV v1f').
      iSplitL "Hv1f'". done.
      rewrite interp_rw_TSum.
      iLeft. iExists (v1f , v1f'). by iFrame.
    + iDestruct "H2" as ((v1 , v1')) "[% Hv1v1']". inversion H0. clear H0 H2 H3 v v'.
      iMod ((step_case_inr _ ei' K') with "[Hv']") as "Hv'"; auto. asimpl.
      wp_head.
      iApply (wp_bind [cast_calculus.lang.InjRCtx]).
      iApply (wp_wand with "[-]").
      iApply (IHpC2 ei' (InjRCtx :: K') with "[Hv']"); iFrame; auto.
      iIntros (v2f) "HHH". iDestruct "HHH" as (v2f') "[Hv2f' Hv2fv2f']".
      iApply wp_value.
      iExists (InjRV v2f').
      iSplitL "Hv2f'". done.
      rewrite interp_rw_TSum.
      iRight. iExists (v2f , v2f'). by iFrame.
  Qed.

End compat_cast_sum_sum.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition handle_ptimer_sysreg_read_spec (rec: Pointer) (esr: Z64) (adt: RData) : option RData :=
    match esr with
    | VZ64 esr =>
      rely is_int64 esr;
      rely (peq (base rec) buffer_loc);
      rely (offset rec =? SLOT_REC);
      when gidx == (buffer (priv adt)) @ (offset rec);
      rely is_gidx gidx;
      let gn := (gs (share adt)) @ gidx in
      rely (g_tag (ginfo gn) =? GRANULE_STATE_REC);
      rely (ref_accessible gn CPU_ID);
      let rt := __ESR_EL2_SYSREG_ISS_RT esr in
      rely is_int rt;
      let ec := Z.land esr ESR_EL2_SYSREG_MASK in
      if ec =? ESR_EL2_SYSREG_TIMER_CNTP_TVAL_EL0 then
        rely is_int64 (r_cntp_tval_el0 (cpu_regs (priv adt)));
        let g' := gn {grec: (grec gn) {g_regs: set_reg rt (r_cntp_tval_el0 (cpu_regs (priv adt)))
                                                       (g_regs (grec gn))}} in
        Some adt {share: (share adt) {gs: (gs (share adt)) # gidx == g'}}
      else
        if ec =? ESR_EL2_SYSREG_TIMER_CNTP_CTL_EL0 then
          rely is_int64 (r_cntp_ctl_el0 (cpu_regs (priv adt)));
          let cntp_ctl := Z.land (r_cntp_ctl_el0 (cpu_regs (priv adt))) NOT_CNTx_CTL_IMASK in
          let val := (if t_masked (g_ptimer (grec gn)) =? 1
                      then (Z.lor cntp_ctl CNTx_CTL_IMASK)
                      else  cntp_ctl) in
          let g' := gn {grec: (grec gn) {g_regs: set_reg rt val (g_regs (grec gn))}} in
          Some adt {share: (share adt) {gs: (gs (share adt)) # gidx == g'}}
        else
          if ec =? ESR_EL2_SYSREG_TIMER_CNTP_CVAL_EL0 then
            rely is_int64 (r_cntp_cval_el0 (cpu_regs (priv adt)));
            let g' := gn {grec: (grec gn) {g_regs: set_reg rt (r_cntp_cval_el0 (cpu_regs (priv adt)))
                                                          (g_regs (grec gn))}} in
            Some adt {share: (share adt) {gs: (gs (share adt)) # gidx == g'}}
          else Some adt
    end.

End Spec.


From iris.program_logic Require Import language ectxi_language ectx_language lifting.
From st.STLCmu Require Import lang.

Definition STLCmu_head_step (e e' : expr) := head_step e tt [] e' tt [].

Lemma head_to_STLCmu_head (e e' : expr) σ σ' κ efs : head_step e σ κ e' σ' efs → STLCmu_head_step e e'.
Proof. intro H. rewrite /STLCmu_head_step. inversion H; by econstructor. Qed.

Definition STLCmu_reducible (e : expr) := ∃ e', STLCmu_step e e'.
Definition STLCmu_irreducible (e : expr) := ∀ e', ¬ STLCmu_step e e'.
Definition STLCmu_head_reducible (e : expr) := ∃ e', STLCmu_head_step e e'.
Definition STLCmu_head_irreducible (e : expr) := ∀ e', ¬ STLCmu_head_step e e'.

Lemma prim_to_STLCmu (e1 e2 : expr) σ1 σ2 κ efs : prim_step e1 σ1 κ e2 σ2 efs -> STLCmu_step e1 e2.
Proof. intro H. apply STLCmu_pure. apply (prim_step_pure _ _ _ _ _ _ H). Qed.

Lemma STLCmu_prim_red (e : expr) : STLCmu_reducible e <-> reducible e tt.
Proof.
  split. intro H. destruct H as [e' Hstep]. exists [], e', tt, []. apply Hstep.
  intro H. destruct H as (a & e' & b & c & Hstep). exists e'. by eapply prim_to_STLCmu.
Qed.
Lemma STLCmu_prim_irred (e : expr) : STLCmu_irreducible e <-> irreducible e tt.
Proof.
  split.
  + rewrite /STLCmu_irreducible /irreducible.
    intros. intro abs. apply (H e'). by eapply prim_to_STLCmu.
  + intros H e' abs. rewrite /irreducible in H. by apply (H [] e' () []).
Qed.
Lemma STLCmu_prim_head_red (e : expr) : STLCmu_head_reducible e <-> head_reducible e tt.
Proof.
  split. intro H. destruct H as [e' Hstep]. exists [], e', tt, []. apply Hstep.
  intro H. destruct H as (a & e' & b & c & Hstep). exists e'. destruct Hstep; by econstructor.
Qed.
Lemma STLCmu_prim_head_irred (e : expr) : STLCmu_head_irreducible e <-> head_irreducible e tt.
Proof.
  split. intro H. intros κ e' σ efs abs. apply (H e'). by eapply head_to_STLCmu_head.
  intros H e' Hstep. apply (H [] e' () []). auto.
Qed.

Lemma stuck_no_val_irred e : (to_val e = None) → stuck e tt → irreducible e tt.
Proof. rewrite /stuck. intuition. Qed.

(* Ltac head_stuck_solver := *)
(*   lazymatch goal with *)
(*   | |- stuck ?e () => apply head_stuck_stuck; head_stuck_solver *)
(*   | |- head_stuck ?e () => split; head_stuck_solver *)
(*   | |- rtc STLCmu_step _ _ => (eapply rtc_l; first (auto_STLCmu_step); simplify_custom) *)
(*   | |- ectx_language.to_val _ = _ => (by simplify_custom) ; head_stuck_solver *)
(*   | |- head_irreducible _ () => ((apply STLCmu_prim_head_irred; intros e' abs; inversion abs; simplify_option_eq); try done); head_stuck_solver *)
(*   | |- sub_redexes_are_values _ => apply ectxi_language_sub_redexes_are_values; intros Ki' e' eqqq; destruct Ki'; inversion eqqq; head_stuck_solver *)
(*   | |- is_Some _ => (by eexists; simplify_custom) ; head_stuck_solver *)
(*   | |- _ => auto *)
(*   end. *)

(* Inductive reducibility (e : expr) : Type := *)
(*   | is_val v : to_val e = Some v → reducibility e *)
(*   | is_red : reducible e tt → reducibility e *)
(*   | is_stuck : stuck e tt → reducibility e. *)

(* Lemma fill_stuck (K : list ectx_item) (e : expr) : *)
(*     stuck e tt → stuck (fill K e) tt. *)
(* Proof. apply stuck_fill. Qed. *)

(* Lemma dec_expr_reducibility (e : expr) : reducibility e. *)
(* Proof. *)
(*   induction e as [x | e1 IH1 e2 IH2 | e _ | e1 IH1 e2 IH2 | | op e1 IH1 e2 IH2 | e0 IH0 e1 IH1 e2 IH2 | e1 IH1 e2 IH2 | e1 IH1 e2 IH2 | e IH | e IH | e IH | e IH | e0 IH0 e1 IH1 e2 IH2 | e IH | e IH | e IH ]; *)
(*     (try by eapply is_val). *)
(*   - apply is_stuck. head_stuck_solver. *)
(*   - destruct IH1 as [ v1 eq1 | is_red1 | is_stuck1 ]; [ rewrite -(of_to_val _ _ eq1) | | ]. *)
(*     + apply is_red; apply STLCmu_prim_red; eexists; auto_STLCmu_step. *)
(*     + apply is_red; by apply (fill_reducible [LetInCtx _]). *)
(*     + apply is_stuck; by apply (fill_stuck [LetInCtx _]). *)
(*   - destruct IH1 as [ v1 eq1 | is_red1 | is_stuck1 ]; [ rewrite -(of_to_val _ _ eq1) | | ]. *)
(*     + destruct IH2 as [ v2 eq2 | is_red2 | is_stuck2 ]; [ rewrite -(of_to_val _ _ eq2) | | ]. *)
(*       * destruct v1; try by (apply is_stuck; head_stuck_solver). *)
(*         apply is_red; apply STLCmu_prim_red; eexists; auto_STLCmu_step. *)
(*       * apply is_red; by apply (fill_reducible [AppRCtx _]). *)
(*       * apply is_stuck; by apply (fill_stuck [AppRCtx _]). *)
(*     + apply is_red; by apply (fill_reducible [AppLCtx _]). *)
(*     + apply is_stuck; by apply (fill_stuck [AppLCtx _]). *)
(*   - destruct IH1 as [ v1 eq1 | is_red1 | is_stuck1 ]; [ rewrite -(of_to_val _ _ eq1) | | ]. *)
(*     + destruct IH2 as [ v2 eq2 | is_red2 | is_stuck2 ]; [ rewrite -(of_to_val _ _ eq2) | | ]. *)
(*       * destruct v1; (lazymatch goal with | v : base_lit |- _ => destruct v | |- _ => auto end); try by (apply is_stuck; head_stuck_solver). *)
(*         destruct v2; (lazymatch goal with | v : base_lit |- _ => destruct v | |- _ => auto end); try by (apply is_stuck; head_stuck_solver). *)
(*         apply is_red; apply STLCmu_prim_red; eexists; auto_STLCmu_step. *)
(*       * apply is_red; by apply (fill_reducible [BinOpRCtx _ _]). *)
(*       * apply is_stuck; by apply (fill_stuck [BinOpRCtx _ _]). *)
(*     + apply is_red; by apply (fill_reducible [BinOpLCtx _ _]). *)
(*     + apply is_stuck; by apply (fill_stuck [BinOpLCtx _ _]). *)
(*   - destruct IH0 as [ v0 eq0 | is_red0 | is_stuck0 ]; [ rewrite -(of_to_val _ _ eq0) | | ]. *)
(*     + destruct v0; (lazymatch goal with | v : base_lit |- _ => destruct v | |- _ => auto end); try by (apply is_stuck; head_stuck_solver). *)
(*       destruct b; apply is_red; apply STLCmu_prim_red; eexists; auto_STLCmu_step. *)
(*     + apply is_red; by apply (fill_reducible [IfCtx _ _]). *)
(*     + apply is_stuck; by apply (fill_stuck [IfCtx _ _]). *)
(*   - destruct IH1 as [ v1 eq1 | is_red1 | is_stuck1 ]; [ rewrite -(of_to_val _ _ eq1) | | ]. *)
(*     + destruct v1; (lazymatch goal with | v : base_lit |- _ => destruct v | |- _ => auto end); try by (apply is_stuck; head_stuck_solver). *)
(*       apply is_red; apply STLCmu_prim_red; eexists; auto_STLCmu_step. *)
(*     + apply is_red; by apply (fill_reducible [SeqCtx _]). *)
(*     + apply is_stuck; by apply (fill_stuck [SeqCtx _]). *)
(*   - destruct IH1 as [ v1 eq1 | is_red1 | is_stuck1 ]; [ rewrite -(of_to_val _ _ eq1) | | ]. *)
(*     + destruct IH2 as [ v2 eq2 | is_red2 | is_stuck2 ]; [ rewrite -(of_to_val _ _ eq2) | | ]. *)
(*       * by apply (is_val _ (v1, v2)%Vₙₒ); simplify_custom. *)
(*       * apply is_red; by apply (fill_reducible [PairRCtx _]). *)
(*       * apply is_stuck; by apply (fill_stuck [PairRCtx _]). *)
(*     + apply is_red; by apply (fill_reducible [PairLCtx _]). *)
(*     + apply is_stuck; by apply (fill_stuck [PairLCtx _]). *)
(*   - destruct IH as [ v1 eq1 | is_red1 | is_stuck1 ]; [ rewrite -(of_to_val _ _ eq1) | | ]. *)
(*     + destruct v1; try by (apply is_stuck; head_stuck_solver). *)
(*       apply is_red; apply STLCmu_prim_red; eexists; auto_STLCmu_step. *)
(*     + apply is_red. by apply (fill_reducible [FstCtx]). *)
(*     + apply is_stuck; by apply (fill_stuck [FstCtx]). *)
(*   - destruct IH as [ v1 eq1 | is_red1 | is_stuck1 ]; [ rewrite -(of_to_val _ _ eq1) | | ]. *)
(*     + destruct v1; try by (apply is_stuck; head_stuck_solver). *)
(*       apply is_red; apply STLCmu_prim_red; eexists; auto_STLCmu_step. *)
(*     + apply is_red. by apply (fill_reducible [SndCtx]). *)
(*     + apply is_stuck; by apply (fill_stuck [SndCtx]). *)
(*   - destruct IH as [ v1 eq1 | is_red1 | is_stuck1 ]; [ rewrite -(of_to_val _ _ eq1) | | ]. *)
(*     + apply (is_val _ (InjLV v1)). by simplify_custom. *)
(*     + apply is_red. by apply (fill_reducible [InjLCtx]). *)
(*     + apply is_stuck; by apply (fill_stuck [InjLCtx]). *)
(*   - destruct IH as [ v1 eq1 | is_red1 | is_stuck1 ]; [ rewrite -(of_to_val _ _ eq1) | | ]. *)
(*     + apply (is_val _ (InjRV v1)). by simplify_custom. *)
(*     + apply is_red. by apply (fill_reducible [InjRCtx]). *)
(*     + apply is_stuck; by apply (fill_stuck [InjRCtx]). *)
(*   - destruct IH0 as [ v0 eq0 | is_red0 | is_stuck0 ]; [ rewrite -(of_to_val _ _ eq0) | | ]. *)
(*     + (destruct v0; try by (apply is_stuck; head_stuck_solver)); *)
(*       apply is_red; apply STLCmu_prim_red; eexists; auto_STLCmu_step. *)
(*     + apply is_red; by apply (fill_reducible [CaseCtx _ _]). *)
(*     + apply is_stuck; by apply (fill_stuck [CaseCtx _ _]). *)
(*   - destruct IH as [ v1 eq1 | is_red1 | is_stuck1 ]; [ rewrite -(of_to_val _ _ eq1) | | ]. *)
(*     + apply (is_val _ (FoldV v1)). by simplify_custom. *)
(*     + apply is_red. by apply (fill_reducible [FoldCtx]). *)
(*     + apply is_stuck; by apply (fill_stuck [FoldCtx]). *)
(*   - destruct IH as [ v1 eq1 | is_red1 | is_stuck1 ]; [ rewrite -(of_to_val _ _ eq1) | | ]. *)
(*     + destruct v1; try by (apply is_stuck; head_stuck_solver). *)
(*       apply is_red; apply STLCmu_prim_red; eexists; auto_STLCmu_step. *)
(*     + apply is_red. by apply (fill_reducible [UnfoldCtx]). *)
(*     + apply is_stuck; by apply (fill_stuck [UnfoldCtx]). *)
(*   - destruct IH as [ v1 eq1 | is_red1 | is_stuck1 ]; [ rewrite -(of_to_val _ _ eq1) | | ]. *)
(*     + destruct v1; apply is_red; apply STLCmu_prim_red; eexists; auto_STLCmu_step. *)
(*     + apply is_red. by apply (fill_reducible [VirtStepCtx]). *)
(*     + apply is_stuck; by apply (fill_stuck [VirtStepCtx]). *)
(* Qed. *)

Inductive Reducible : expr → Prop :=
  | LetIn_L_Red e1 e2 : Reducible e1 → Reducible (LetIn e1 e2)
  | LetIn_D_Red e1 v1 e2 : to_val e1 = Some v1 → Reducible (LetIn e1 e2)
  | App_L_Red e1 e2 : Reducible e1 → Reducible (App e1 e2)
  | App_R_Red e1 v1 e2 : to_val e1 = Some v1 → Reducible e2 → Reducible (App e1 e2)
  | App_D_Red e1 e2 v2 : to_val e2 = Some v2 → Reducible (App (Lam e1) e2)
  | BinOp_L_Red op e1 e2 : Reducible e1 → Reducible (BinOp op e1 e2)
  | BinOp_R_Red op e1 v1 e2 : to_val e1 = Some v1 → Reducible e2 → Reducible (BinOp op e1 e2)
  | BinOp_D_Red op z1 z2 : Reducible (BinOp op (Lit (LitInt z1)) (Lit (LitInt z2)))
  | If_C_Red e e1 e2 : Reducible e → Reducible (If e e1 e2)
  | If_D_Red b e1 e2 : Reducible (If (Lit (LitBool b)) e1 e2)
  | Seq_C_Red e1 e2 : Reducible e1 → Reducible (Seq e1 e2)
  | Seq_D_Red e2 : Reducible (Seq (Lit LitUnit) e2)
  | Pair_L_Red e1 e2 : Reducible e1 → Reducible (Pair e1 e2)
  | Pair_R_Red e1 v1 e2 : to_val e1 = Some v1 → Reducible e2 → Reducible (Pair e1 e2)
  | Fst_C_Red e1 : Reducible e1 → Reducible (Fst e1)
  | Fst_D_Red e1 e2 v1 v2 : to_val e1 = Some v1 → to_val e2 = Some v2 → Reducible (Fst (Pair e1 e2))
  | Snd_C_Red e1 : Reducible e1 → Reducible (Snd e1)
  | Snd_D_Red e1 e2 v1 v2 : to_val e1 = Some v1 → to_val e2 = Some v2 → Reducible (Snd (Pair e1 e2))
  | InjL_Red e : Reducible e → Reducible (InjL e)
  | InjR_Red e : Reducible e → Reducible (InjR e)
  | Case_C_Red e e1 e2 : Reducible e → Reducible (Case e e1 e2)
  | Case_D_InjL_Red e v e1 e2 : to_val e = Some v → Reducible (Case (InjL e) e1 e2)
  | Case_D_InjR_Red e v e1 e2 : to_val e = Some v → Reducible (Case (InjR e) e1 e2)
  | Fold_Red e : Reducible e → Reducible (Fold e)
  | Unfold_C_Red e : Reducible e → Reducible (Unfold e)
  | Unfold_D_Red e v : to_val e = Some v → Reducible (Unfold (Fold e)).

Lemma Reducible_valid (e : expr) : reducible e tt <-> Reducible e.
Proof.
  induction e.
  Ltac local_tactic := (repeat lazymatch goal with
                               | |- reducible _ () => apply STLCmu_prim_red
                               | H : reducible _ () |- _ => destruct (iffRL (STLCmu_prim_red _) H) as [e' Hstep]
                               end).
  - split; intro red.
    + exfalso.
      assert (head_reducible (Var x) ()). apply prim_head_reducible; auto.
      apply (@ectxi_language_sub_redexes_are_values STLCmu_ectxi_lang).
      { intros Ki' e'' eqqq; destruct Ki'; inversion eqqq. }
      pose proof (iffRL (STLCmu_prim_head_red (Var x)) H).
      inversion H0. inversion H1.
    + exfalso. inversion red.
  - split; intro red.
    + pose proof (iffRL (STLCmu_prim_red _) red).
      inversion H. inversion_clear H0. simpl in *. subst. destruct K as [|Ki K _] using rev_ind.
      * simpl in *. subst. inversion H3. eapply LetIn_D_Red. eauto.
      * simpl in *. rewrite fill_app in H1. destruct Ki; try by inversion H1.
        simpl in *. apply LetIn_L_Red. apply IHe. inversion H1.
        apply STLCmu_prim_red. exists (fill K e2'). econstructor; eauto.
    + inversion red; subst; local_tactic.
      * pose proof (iffRL IHe H0). local_tactic.
        exists (LetIn e' e2). eapply (STLCmu_step_ctx (fill [LetInCtx _])); eauto.
      * exists e2.[e/]. apply head_prim_step. by econstructor.
  - split; intro red.
    + exfalso.
      assert (head_reducible (Lam e) ()). apply prim_head_reducible; auto.
      apply (@ectxi_language_sub_redexes_are_values STLCmu_ectxi_lang).
      { intros Ki' e'' eqqq; destruct Ki'; inversion eqqq. }
      pose proof (iffRL (STLCmu_prim_head_red (Lam e)) H).
      inversion H0. inversion H1.
    + exfalso. inversion red.
  - split; intro red.
    + pose proof (iffRL (STLCmu_prim_red _) red).
      inversion H. inversion_clear H0. simpl in *. subst. destruct K as [|Ki K _] using rev_ind.
      * simpl in *. subst. inversion H3. eapply App_D_Red. eauto.
      * simpl in *. rewrite fill_app in H1. destruct Ki; try by inversion H1.
        -- simpl in *. apply App_L_Red. apply IHe1. inversion H1.
           apply STLCmu_prim_red. exists (fill K e2'). econstructor; eauto.
        -- simpl in *. inversion H1. subst. eapply App_R_Red. by rewrite to_of_val.
           apply IHe2. apply STLCmu_prim_red. exists (fill K e2'). econstructor; eauto.
    + inversion red; subst; local_tactic.
      * pose proof (iffRL IHe1 H0). local_tactic.
        exists (App e' e2). eapply (STLCmu_step_ctx (fill [AppLCtx _])); eauto.
      * pose proof (iffRL IHe2 H2). local_tactic.
        exists (App e1 e'). rewrite -(of_to_val _ _ H1). eapply (STLCmu_step_ctx (fill [AppRCtx _])); eauto.
      * exists e0.[e2/]. apply head_prim_step. by econstructor.
  - split; intro red.
    + exfalso.
      assert (head_reducible (Lit l) ()). apply prim_head_reducible; auto.
      apply (@ectxi_language_sub_redexes_are_values STLCmu_ectxi_lang).
      { intros Ki' e'' eqqq; destruct Ki'; inversion eqqq. }
      pose proof (iffRL (STLCmu_prim_head_red (Lit l)) H).
      inversion H0. inversion H1.
    + exfalso. inversion red.
  - split; intro red.
    + pose proof (iffRL (STLCmu_prim_red _) red).
      inversion H. inversion_clear H0. simpl in *. subst. destruct K as [|Ki K _] using rev_ind.
      * simpl in *. subst. inversion H3. subst. rewrite -(of_to_val _ _ H5) -(of_to_val _ _ H7). eapply BinOp_D_Red.
      * simpl in *. rewrite fill_app in H1. destruct Ki; try by inversion H1.
        -- simpl in *. apply BinOp_L_Red. apply IHe1. inversion H1.
           apply STLCmu_prim_red. exists (fill K e2'). econstructor; eauto.
        -- simpl in *. inversion H1. subst. eapply BinOp_R_Red. by rewrite to_of_val.
           apply IHe2. apply STLCmu_prim_red. exists (fill K e2'). econstructor; eauto.
    + inversion red; subst; local_tactic.
      * pose proof (iffRL IHe1 H0). local_tactic.
        exists (BinOp op e' e2). eapply (STLCmu_step_ctx (fill [BinOpLCtx _ _])); eauto.
      * pose proof (iffRL IHe2 H3). local_tactic.
        exists (BinOp op e1 e'). rewrite -(of_to_val _ _ H1). eapply (STLCmu_step_ctx (fill [BinOpRCtx _ _])); eauto.
      * eexists _. apply head_prim_step. by econstructor.
  - split; intro red.
    + pose proof (iffRL (STLCmu_prim_red _) red).
      inversion H. inversion_clear H0. simpl in *. subst. destruct K as [|Ki K _] using rev_ind.
      * simpl in *. subst. inversion H3; subst; eapply If_D_Red.
      * simpl in *. rewrite fill_app in H1. destruct Ki; try by inversion H1.
        simpl in *. apply If_C_Red. apply IHe1. inversion H1.
        apply STLCmu_prim_red. exists (fill K e2'). econstructor; eauto.
    + inversion red; subst; local_tactic.
      * pose proof (iffRL IHe1 H0). local_tactic.
        exists (If e' e2 e3). eapply (STLCmu_step_ctx (fill [IfCtx _ _])); eauto.
      * destruct b; [exists e2 | exists e3]; apply head_prim_step; by econstructor.
  - split; intro red.
    + pose proof (iffRL (STLCmu_prim_red _) red).
      inversion H. inversion_clear H0. simpl in *. subst. destruct K as [|Ki K _] using rev_ind.
      * simpl in *. subst. inversion H3; subst. rewrite -(of_to_val _ _ H4). eapply Seq_D_Red.
      * simpl in *. rewrite fill_app in H1. destruct Ki; try by inversion H1.
        simpl in *. apply Seq_C_Red. apply IHe1. inversion H1.
        apply STLCmu_prim_red. exists (fill K e2'). econstructor; eauto.
    + inversion red; subst; local_tactic.
      * pose proof (iffRL IHe1 H0). local_tactic.
        exists (Seq e' e2). eapply (STLCmu_step_ctx (fill [SeqCtx _])); eauto.
      * exists e2; apply head_prim_step; by econstructor.
  - split; intro red.
    + pose proof (iffRL (STLCmu_prim_red _) red).
      inversion H. inversion_clear H0. simpl in *. subst. destruct K as [|Ki K _] using rev_ind.
      * simpl in *. subst. inversion H3.
      * simpl in *. rewrite fill_app in H1. destruct Ki; try by inversion H1.
        -- simpl in *. apply Pair_L_Red. apply IHe1. inversion H1.
           apply STLCmu_prim_red. exists (fill K e2'). econstructor; eauto.
        -- simpl in *. inversion H1. subst. eapply Pair_R_Red. by rewrite to_of_val.
           apply IHe2. apply STLCmu_prim_red. exists (fill K e2'). econstructor; eauto.
    + inversion red; subst; local_tactic.
      * pose proof (iffRL IHe1 H0). local_tactic.
        exists (Pair e' e2). eapply (STLCmu_step_ctx (fill [PairLCtx _])); eauto.
      * pose proof (iffRL IHe2 H2). local_tactic.
        exists (Pair e1 e'). rewrite -(of_to_val _ _ H1). eapply (STLCmu_step_ctx (fill [PairRCtx _])); eauto.
  - split; intro red.
    + pose proof (iffRL (STLCmu_prim_red _) red).
      inversion H. inversion_clear H0. simpl in *. subst. destruct K as [|Ki K _] using rev_ind.
      * simpl in *. subst. inversion H3; subst. rewrite -(of_to_val _ _ H1) -(of_to_val _ _ H2). eapply Fst_D_Red; by rewrite to_of_val.
      * simpl in *. rewrite fill_app in H1. destruct Ki; try by inversion H1.
        simpl in *. apply Fst_C_Red. apply IHe. inversion H1.
        apply STLCmu_prim_red. exists (fill K e2'). econstructor; eauto.
    + inversion red; subst; local_tactic.
      * pose proof (iffRL IHe H0). local_tactic.
        exists (Fst e'). eapply (STLCmu_step_ctx (fill [FstCtx])); eauto.
      * exists e1; apply head_prim_step. econstructor. by rewrite H0. by rewrite H1.
  - split; intro red.
    + pose proof (iffRL (STLCmu_prim_red _) red).
      inversion H. inversion_clear H0. simpl in *. subst. destruct K as [|Ki K _] using rev_ind.
      * simpl in *. subst. inversion H3; subst. rewrite -(of_to_val _ _ H1) -(of_to_val _ _ H2). eapply Snd_D_Red; by rewrite to_of_val.
      * simpl in *. rewrite fill_app in H1. destruct Ki; try by inversion H1.
        simpl in *. apply Snd_C_Red. apply IHe. inversion H1.
        apply STLCmu_prim_red. exists (fill K e2'). econstructor; eauto.
    + inversion red; subst; local_tactic.
      * pose proof (iffRL IHe H0). local_tactic.
        exists (Snd e'). eapply (STLCmu_step_ctx (fill [SndCtx])); eauto.
      * exists e2; apply head_prim_step. econstructor. by rewrite H0. by rewrite H1.
  - split; intro red.
    + pose proof (iffRL (STLCmu_prim_red _) red).
      inversion H. inversion_clear H0. simpl in *. subst. destruct K as [|Ki K _] using rev_ind.
      * simpl in *. subst. inversion H3; subst.
      * simpl in *. rewrite fill_app in H1. destruct Ki; try by inversion H1.
        simpl in *. apply InjL_Red. apply IHe. inversion H1.
        apply STLCmu_prim_red. exists (fill K e2'). econstructor; eauto.
    + inversion red; subst; local_tactic.
      pose proof (iffRL IHe H0). local_tactic.
      exists (InjL e'). eapply (STLCmu_step_ctx (fill [InjLCtx])); eauto.
  - split; intro red.
    + pose proof (iffRL (STLCmu_prim_red _) red).
      inversion H. inversion_clear H0. simpl in *. subst. destruct K as [|Ki K _] using rev_ind.
      * simpl in *. subst. inversion H3; subst.
      * simpl in *. rewrite fill_app in H1. destruct Ki; try by inversion H1.
        simpl in *. apply InjR_Red. apply IHe. inversion H1.
        apply STLCmu_prim_red. exists (fill K e2'). econstructor; eauto.
    + inversion red; subst; local_tactic.
      pose proof (iffRL IHe H0). local_tactic.
      exists (InjR e'). eapply (STLCmu_step_ctx (fill [InjRCtx])); eauto.
  - split; intro red.
    + pose proof (iffRL (STLCmu_prim_red _) red).
      inversion H. inversion_clear H0. simpl in *. subst. destruct K as [|Ki K _] using rev_ind.
      * simpl in *. subst. inversion H3; subst.
        -- rewrite -(of_to_val _ _ H6). eapply Case_D_InjL_Red. by rewrite to_of_val.
        -- rewrite -(of_to_val _ _ H6). eapply Case_D_InjR_Red. by rewrite to_of_val.
      * simpl in *. rewrite fill_app in H1. destruct Ki; try by inversion H1.
        simpl in *. apply Case_C_Red. apply IHe. inversion H1.
        apply STLCmu_prim_red. exists (fill K e2'). econstructor; eauto.
    + inversion red; subst; local_tactic.
      * pose proof (iffRL IHe H0). local_tactic.
        exists (Case e' e1 e2). eapply (STLCmu_step_ctx (fill [CaseCtx _ _])); eauto.
      * exists e1.[e0/]. apply head_prim_step; by econstructor.
      * exists e2.[e0/]. apply head_prim_step; by econstructor.
  - split; intro red.
    + pose proof (iffRL (STLCmu_prim_red _) red).
      inversion H. inversion_clear H0. simpl in *. subst. destruct K as [|Ki K _] using rev_ind.
      * simpl in *. subst. inversion H3; subst.
      * simpl in *. rewrite fill_app in H1. destruct Ki; try by inversion H1.
        simpl in *. apply Fold_Red. apply IHe. inversion H1.
        apply STLCmu_prim_red. exists (fill K e2'). econstructor; eauto.
    + inversion red; subst; local_tactic.
      pose proof (iffRL IHe H0). local_tactic.
      exists (Fold e'). eapply (STLCmu_step_ctx (fill [FoldCtx])); eauto.
  - split; intro red.
    + pose proof (iffRL (STLCmu_prim_red _) red).
      inversion H. inversion_clear H0. simpl in *. subst. destruct K as [|Ki K _] using rev_ind.
      * simpl in *. subst. inversion H3; subst. rewrite -(of_to_val _ _ H1). eapply Unfold_D_Red; by rewrite to_of_val.
      * simpl in *. rewrite fill_app in H1. destruct Ki; try by inversion H1.
        simpl in *. apply Unfold_C_Red. apply IHe. inversion H1.
        apply STLCmu_prim_red. exists (fill K e2'). econstructor; eauto.
    + inversion red; subst; local_tactic.
      * pose proof (iffRL IHe H0). local_tactic.
        exists (Unfold e'). eapply (STLCmu_step_ctx (fill [UnfoldCtx])); eauto.
      * exists e0; apply head_prim_step. econstructor. by rewrite H0.
Qed.