From st.STLCmuVS Require Import lang typing contexts scopedness.
From st.STLCmu Require Import types.
From st.backtranslations.un_syn Require Import universe.base expressions contexts typed.
From st.backtranslations.sem_syn Require Import embed_project gamma_lib.
From st.prelude Require Import forall_three.

Definition back_ctx_nil (C : ctx) (τ : type) : ctx :=
  [CTX_AppR (ep_pair Project TUnit)] ++ universe_back_ctx C ++ [CTX_AppR (ep_pair Embed τ)].

Definition back_ctx_cons (C : ctx) (Γ : list type) (τ : type) : ctx :=
  let P : expr :=
      let filled_hole : expr :=
          ep_pair Embed τ (
                    wrap_funs_vars (Var (length Γ)) 0
                             ((fun τ => ep_pair Project τ) <$> Γ)
                  )
      in
      fill_ctx (universe_back_ctx C) filled_hole
  in
  [CTX_LetInL (ep_pair Project TUnit P)] ++ (LamGamma_ctx (length Γ)).

Definition back_ctx (C : ctx) (Γ : list type) (τ : type) : ctx :=
  match (length Γ) with
  | 0 => back_ctx_nil C τ
  | S n => back_ctx_cons C Γ τ
  end.

Lemma back_ctx_nil_typed (C : ctx) (τ : type) (pτ : Closed τ)
  (H : |sC> 0 ⊢ₙₒ C ☾ 0 ☽) :
  |C> [] ⊢ₙₒ (back_ctx_nil C τ) ☾ [] ; τ ☽ : TUnit.
Proof.
  rewrite /back_ctx_nil. eapply typed_ctx_app. econstructor. constructor. instantiate (1 := TUniverse).
  apply ep_pair_typed. intro σ; by asimpl. constructor.
  eapply typed_ctx_app. change [] with (replicate 0 TUniverse).
  apply universe_back_ctx_typed. eauto. econstructor. constructor. instantiate (1 := τ).
  apply ep_pair_typed. auto. constructor.
Qed.

Lemma back_ctx_cons_typed (C : ctx) (Γ : list type) (pΓ : Forall Closed Γ) (τ : type) (pτ : Closed τ)
  (H : |sC> 0 ⊢ₙₒ C ☾ length Γ ☽) :
  |C> [] ⊢ₙₒ (back_ctx_cons C Γ τ) ☾ Γ ; τ ☽ : TUnit.
Proof.
  Opaque ep_pair.
  eapply typed_ctx_app; [| apply LamGamma_ctx_typed].
  econstructor. 2: constructor. simpl.
  constructor. apply App_typed with (τ1 := TUniverse). apply typed_nil, ep_pair_typed. intros σ; by asimpl.
  eapply typed_ctx_typed with (Γ := (map (fun _ => TUniverse) Γ) ++ [GammaType Γ τ]) (τ := TUniverse).
  apply App_typed with (τ1 := τ). apply typed_nil, ep_pair_typed; auto.
  rewrite -(map_length (fun _ => TUniverse) Γ). apply wrap_funs_vars_typed.
  apply Forall3_fmap_l, Forall3_fmap_m, Forall3_same. eapply Forall_impl; eauto.
  simpl. intros. apply typed_nil, ep_pair_typed. auto.
  change [GammaType Γ τ] with ([] ++ [GammaType Γ τ]) at 2.
  apply typed_ctx_append. change [] with (replicate 0 TUniverse).
  replace (map (fun _ => TUniverse) Γ) with (replicate (length Γ) TUniverse).
  by apply universe_back_ctx_typed. rewrite -(const_fmap (fun _ => TUniverse)); auto.
Qed.

Lemma back_ctx_typed (C : ctx) (Γ : list type) (pΓ : Forall Closed Γ) (τ : type) (pτ : Closed τ)
  (H : |sC> 0 ⊢ₙₒ C ☾ length Γ ☽) :
  |C> [] ⊢ₙₒ (back_ctx C Γ τ) ☾ Γ ; τ ☽ : TUnit.
Proof.
  destruct (length Γ) eqn:eq.
  - rewrite (nil_length_inv _ eq) /=. by apply back_ctx_nil_typed.
  - rewrite /back_ctx eq. apply back_ctx_cons_typed; auto. by rewrite eq.
Qed.


(* Se definen componentes y lemas comunes para generar los testigos
* que se dan en las demostraciones de las propiedades postuladas *)
Require Import Estado.
Require Import DefBasicas.
Require Import Maps.

Parameter a1 a2:idApp.
Axiom asdiff :a1<>a2.

Theorem idAppa1a2Right : exists e, idApp_eq a1 a2 = right e.
Proof.
    destruct (idApp_eq a1 a2).
    destruct asdiff;auto.
    exists n.
    auto.
Qed.

Theorem idAppa2a1Right : exists e, idApp_eq a2 a1 = right e.
Proof.
    destruct (idApp_eq a2 a1).
    destruct asdiff;auto.
    exists n.
    auto.
Qed.

Theorem idAppAALeft : forall a, exists e, idApp_eq a a = left e.
Proof.
    intros.
    destruct (idApp_eq a a).
    exists e;auto.
    destruct n;auto.
Qed.

Parameter c:Cert.

Definition emptyPermGroups := map_empty idApp (list idGrp).

Definition emptyPerms := map_empty idApp (list Perm).

Definition emptyRunning := map_empty iCmp Cmp.

Definition emptyDelPPerms:= map_empty (idApp * CProvider * uri) PType.

Definition emptyDelTPerms:= map_empty (iCmp * CProvider * uri) PType.

Definition emptyResCont:= map_empty (idApp * res) Val.

Definition addAppValue (V:Set) (a:idApp) (v:V) (mp:mapping idApp V) :=
    map_add idApp_eq mp a v.

Parameter witnessPermId : idPerm.
Parameter witnessPermGrp : idGrp.

Definition emptyManifests:= map_empty idApp Manifest.
Definition emptyCerts:= map_empty idApp Cert.
Definition emptyDefPerms:= map_empty idApp (list Perm).

Definition simpleManifest (hisCmps : list Cmp) (permsUsed : list Perm) (permsDeclared : list Perm) :=
    mf hisCmps (Some 23) (Some 23) permsUsed permsDeclared None.


Require Import Coq.Logic.PropExtensionality Coq.Logic.FunctionalExtensionality.
Require Import Coq.Lists.List. Import ListNotations. Open Scope list_scope.
Require Import coqutil.Map.Interface coqutil.Map.Properties.
Require Import coqutil.Tactics.fwd.
Require Import coqutil.Tactics.Tactics.
Require Import coqutil.Tactics.syntactic_unify.
Require Import bedrock2.Lift1Prop.
Require Import bedrock2.Map.DisjointUnion.
Require Import bedrock2.TacticError.
Require Import bedrock2.PurifySep.
Require Import bedrock2.Map.SeparationLogic. Local Open Scope sep_scope.

(* to mark hypotheses about heaplets *)
Definition with_mem{mem: Type}(m: mem)(P: mem -> Prop): Prop := P m.

Declare Scope heapletwise_scope.
Open Scope heapletwise_scope.

Set Ltac Backtrace.

Notation "m |= P" := (with_mem m P) (at level 72) : heapletwise_scope.

Section HeapletwiseHyps.
  Context {key value: Type} {mem: map.map key value} {mem_ok: map.ok mem}
          {key_eqb: key -> key -> bool} {key_eqb_spec: EqDecider key_eqb}.

  Lemma split_du: forall (m m1 m2: mem),
      map.split m m1 m2 <-> mmap.du m1 m2 = m.
  Proof.
    unfold map.split, mmap.du, map.du, mmap.of_option. split; intros; fwd.
    - eapply map.disjointb_spec in Hp1. rewrite Hp1. reflexivity.
    - eapply map.disjointb_spec in E0. auto.
  Qed.

  Definition anymem: mem -> Prop := fun _ => True.

  Definition wand(P1 P2: mem -> Prop): mem -> Prop :=
    fun mdiff => forall m1 m2, map.split m2 mdiff m1 -> P1 m1 -> P2 m2.

  (* with mmap.du instead of map.split: *)
  Definition wand'(P1 P2: mem -> Prop): mem -> Prop :=
    fun mdiff => forall m1 m2, mmap.du (mmap.Def mdiff) (mmap.Def m1) = mmap.Def m2 ->
                               P1 m1 -> P2 m2.

  Lemma wand_alt: wand = wand'.
  Proof.
    extensionality P. extensionality Q. extensionality m.
    eapply propositional_extensionality. unfold wand, wand';
      split; intros; eapply split_du in H0; eauto.
  Qed.

  Lemma wand_adjoint: forall (P Q R: mem -> Prop),
      impl1 (sep P Q) R <-> impl1 P (wand Q R).
  Proof.
    unfold impl1, sep, wand. intros; split; intros; fwd; eauto 7.
  Qed.

  (* modus ponens for wand only holds in one direction! *)
  Lemma wand_mp: forall P Q,
      impl1 (sep P (wand P Q)) Q.
  Proof.
    intros. rewrite sep_comm. rewrite (wand_adjoint (wand P Q) P Q). reflexivity.
  Qed.

  Lemma ramify_funspec_hyp: forall (calleePre calleePost callerPost: mem -> Prop) m,
      (* non-ramified hypothesis: requires creating an evar for Frame too early *)
      (exists Frame,
          sep calleePre Frame m /\ (forall m', sep calleePost Frame m' -> callerPost m')) <->
      (* ramified hypothesis: no frame needed *)
      sep calleePre (wand calleePost callerPost) m.
  Proof.
    split; intros; fwd.
    - revert m Hp0.
      change (impl1 (sep calleePre Frame) (sep calleePre (wand calleePost callerPost))).
      reify_goal. ecancel_step_by_implication. cbn [seps].
      eapply (wand_adjoint Frame calleePost callerPost). rewrite sep_comm. unfold impl1.
      exact Hp1.
    - eexists. split. 1: exact H.
      change (impl1 (sep calleePost (wand calleePost callerPost)) callerPost).
      eapply wand_mp.
  Qed.

  Lemma sep_assoc_eq: forall (p q r: mem -> Prop),
      sep (sep p q) r = sep p (sep q r).
  Proof.
    intros. eapply iff1ToEq. eapply sep_assoc.
  Qed.

  Lemma sep_to_with_mem_and_with_mem: forall (P Q: mem -> Prop) m,
      sep P Q m ->
      exists m1 m2, with_mem m1 P /\ with_mem m2 Q /\ m1 \*/ m2 = m.
  Proof.
    unfold with_mem, sep, map.split. intros. fwd. do 2 eexists. ssplit.
    1,2: eassumption.
    simpl. unfold map.du. eapply map.disjointb_spec in Hp0p1. rewrite Hp0p1.
    reflexivity.
  Qed.

  Lemma sep_to_with_mem_and_unpacked: forall (P Q: mem -> Prop) m,
      sep P Q m ->
      exists m1 m2, with_mem m1 P /\ Q m2 /\ m1 \*/ m2 = m.
  Proof. exact sep_to_with_mem_and_with_mem. Qed.

  Lemma sep_to_unpacked_and_with_mem: forall (P Q: mem -> Prop) m,
      sep P Q m ->
      exists m1 m2, P m1 /\ with_mem m2 Q /\ m1 \*/ m2 = m.
  Proof. exact sep_to_with_mem_and_with_mem. Qed.

  Lemma sep_to_unpacked_and_unpacked: forall (P Q: mem -> Prop) m,
      sep P Q m ->
      exists m1 m2, P m1 /\ Q m2 /\ m1 \*/ m2 = m.
  Proof. exact sep_to_with_mem_and_with_mem. Qed.

  Lemma merge_two_split_equations: forall {m} {om1 om2: mmap mem},
      om1 = mmap.Def m ->
      om2 = mmap.Def m ->
      om1 \=/ om2 = mmap.Def m.
  Proof.
    unfold mmap.equal_union. intros. subst. destr (mmap.map__eqb m m); congruence.
  Qed.

  Inductive mem_tree :=
  | NLeaf(m: mem)
  | NDisjointUnion(t1 t2: mem_tree)
  | NEqualUnion(t1 t2: mem_tree).

  Lemma invert_Some_eq_equal_union: forall m (om1 om2: mmap mem),
      mmap.equal_union om1 om2 = mmap.Def m ->
      om1 = mmap.Def m /\ om2 = mmap.Def m.
  Proof.
    unfold mmap.equal_union. intros. fwd. auto.
  Qed.

  Fixpoint interp_mem_tree(t: mem_tree): mmap mem :=
    match t with
    | NLeaf m => mmap.Def m
    | NDisjointUnion t1 t2 => mmap.du (interp_mem_tree t1) (interp_mem_tree t2)
    | NEqualUnion t1 t2 => mmap.equal_union (interp_mem_tree t1) (interp_mem_tree t2)
    end.

  Fixpoint mem_tree_lookup(t: mem_tree)(path: list bool): option mem :=
    match t with
    | NLeaf m =>
        match path with
        | nil => Some m
        | cons _ _ => None
        end
    | NDisjointUnion t1 t2 | NEqualUnion t1 t2 =>
        match path with
        | nil => None
        | cons b rest => mem_tree_lookup (if b then t2 else t1) rest
        end
    end.

  (* outer option is for Success/Failure, inner option is for whether the result
     is empty *)
  Fixpoint mem_tree_remove(t: mem_tree)(path: list bool): option (option mem_tree) :=
    match t with
    | NLeaf m =>
        match path with
        | nil => Some None
        | cons _ _ => None
        end
    | NDisjointUnion t1 t2 =>
        match path with
        | nil => None (* can only remove leaves *)
        | cons b rest =>
            if b then
              match mem_tree_remove t2 rest with
              | Some (Some t2') => Some (Some (NDisjointUnion t1 t2'))
              | Some None => Some (Some t1)
              | None => None
              end
            else
              match mem_tree_remove t1 rest with
              | Some (Some t1') => Some (Some (NDisjointUnion t1' t2))
              | Some None => Some (Some t2)
              | None => None
              end
        end
    | NEqualUnion t1 t2 =>
        match path with
        | nil => None (* can only remove leaves *)
        | cons b rest =>
            (* Note: only one subtree survives (and gets one leaf removed),
               while the other subtree is completely discarded *)
            mem_tree_remove (if b then t2 else t1) rest
        end
    end.

  Definition canceling(Ps: list (mem -> Prop))(om: mmap mem)(Rest: Prop): Prop :=
    (forall m, om = mmap.Def m -> seps Ps m) /\ Rest.

  Lemma canceling_start_and: forall {Ps m om Rest},
      om = mmap.Def m ->
      canceling (Tree.flatten Ps) om Rest ->
      Tree.to_sep Ps m /\ Rest.
  Proof.
    unfold canceling. intros. fwd. split. 2: assumption.
    eapply Tree.flatten_iff1_to_sep. eauto.
  Qed.

  Lemma canceling_start_noand: forall {Ps m om},
      om = mmap.Def m ->
      canceling (Tree.flatten Ps) om True ->
      Tree.to_sep Ps m.
  Proof.
    unfold canceling. intros. fwd. eapply Tree.flatten_iff1_to_sep. eauto.
  Qed.

  Lemma canceling_done_anymem: forall {om} {Rest: Prop},
      Rest -> canceling [anymem] om Rest.
  Proof.
    unfold canceling, anymem. simpl. intros. auto.
  Qed.

  Lemma canceling_done_frame_generic: forall om (P: (mem -> Prop) -> Prop),
      (* This hypothesis holds for all (P F) of the form
         "forall m', (calleePost * F) m' -> callerPost m'"
         even if it has some additional foralls and existentials that can't
         be abstracted easily, so we'll prove this hyp with a generic Ltac *)
      P (fun mFrame : mem => P (eq mFrame)) ->
      (* This hypothesis verifies the rest of the program: *)
      (forall mFrame, om = mmap.Def mFrame -> P (eq mFrame)) ->
      canceling [fun mFrame => P (eq mFrame)] om (P (fun mFrame => P (eq mFrame))).
  Proof.
    intros. split; assumption.
  Qed.

  (* used to instantiate the frame with a magic wand
     (ramification trick to avoid evar scoping issues) *)
  Lemma canceling_done_frame_wand: forall om (calleePost callerPost: mem -> Prop),
      let F := (wand calleePost callerPost) in
      (forall mFrame, om = mmap.Def mFrame -> F mFrame) ->
      canceling [F] om (forall m', sep calleePost F m' -> callerPost m').
  Proof.
    unfold canceling. cbn [seps]. intros. split. 1: assumption.
    change (impl1 (sep calleePost (wand calleePost callerPost)) callerPost).
    eapply wand_mp.
  Qed.

  (* used to instantiate the frame with an unfolded magic wand
     (ramification trick to avoid evar scoping issues) *)
  Lemma canceling_done_frame: forall om (calleePost callerPost: mem -> Prop),
      (forall mNew mModified,
          mmap.du om (mmap.Def mModified) = mmap.Def mNew ->
          calleePost mModified -> callerPost mNew) ->
      (* F is (wand calleePost callerPost) unfolded *)
      let F := (fun mFrame => forall mModified mNew,
                    mmap.du (mmap.Def mFrame) (mmap.Def mModified) = mmap.Def mNew ->
                    calleePost mModified -> callerPost mNew) in
      canceling [F] om (forall m', sep calleePost F m' -> callerPost m').
  Proof.
    intros.
    pose proof (canceling_done_frame_wand om calleePost callerPost) as P.
    rewrite wand_alt in P. eapply P. clear P F.
    unfold wand'. intros. eapply H. 2: eassumption. rewrite H0. assumption.
  Qed.

  Lemma consume_mem_tree: forall {hs path m mFull},
      mem_tree_lookup hs path = Some m ->
      mem_tree_remove hs path = Some None ->
      interp_mem_tree hs = mmap.Def mFull ->
      m = mFull.
  Proof.
    induction hs; simpl; intros; fwd.
    - reflexivity.
    - destruct b; fwd; destruct o; simpl in *; fwd; discriminate.
    - eapply invert_Some_eq_equal_union in H1. fwd.
      destruct b; fwd; eauto.
  Qed.

  Lemma split_mem_tree: forall {hs hs' path m mFull},
      mem_tree_lookup hs path = Some m ->
      mem_tree_remove hs path = Some (Some hs') ->
      interp_mem_tree hs = mmap.Def mFull ->
      mmap.du (interp_mem_tree hs') (mmap.Def m) = mmap.Def mFull.
  Proof.
    induction hs; simpl; intros; fwd.
    - discriminate.
    - unfold mmap.du in H1. fwd.
      destruct b; fwd.
      + destruct o; fwd; simpl.
        * specialize IHhs2 with (1 := H) (2 := E1) (3 := eq_refl).
          rewrite mmap.du_assoc. rewrite IHhs2.
          rewrite E. exact H1.
        * pose proof (consume_mem_tree H E1 E0). subst.
          rewrite E. exact H1.
      + destruct o; fwd; simpl.
        * specialize IHhs1 with (1 := H) (2 := E1) (3 := eq_refl).
          rewrite mmap.du_assoc.
          rewrite (mmap.du_comm (interp_mem_tree hs2) m).
          rewrite <- mmap.du_assoc.
          rewrite IHhs1.
          rewrite E0. exact H1.
        * epose proof (consume_mem_tree H E1 E). subst.
          rewrite E0. rewrite mmap.du_comm. exact H1.
    - eapply invert_Some_eq_equal_union in H1. fwd.
      destruct b; fwd; eauto.
  Qed.

  Lemma cancel_head: forall hs path {P: mem -> Prop} {Ps hs' m Rest},
      with_mem m P ->
      mem_tree_lookup hs path = Some m ->
      mem_tree_remove hs path = Some (Some hs') ->
      canceling Ps (interp_mem_tree hs') Rest ->
      canceling (P :: Ps) (interp_mem_tree hs) Rest.
  Proof.
    unfold with_mem, canceling. intros. destruct H2 as [H2 HR]. split; [intros |exact HR].
    eapply seps_cons.
    pose proof (split_mem_tree H0 H1 H3) as A.
    unfold mmap.du in A. fwd.
    specialize (H2 _ eq_refl).
    eapply split_du in A.
    eapply sep_comm.
    exists m1, m. auto.
  Qed.

  Lemma cancel_pure_head: forall {P: Prop} {Ps om Rest},
      P ->
      canceling Ps om Rest ->
      canceling (emp P :: Ps) om Rest.
  Proof.
    unfold canceling. intros. destruct H0 as [H2 HR]. split; [intros |exact HR].
    eapply seps_cons. eapply sep_emp_l. eauto.
  Qed.

  Lemma canceling_last_step: forall hs path {P m} {Rest: Prop},
      with_mem m P ->
      mem_tree_lookup hs path = Some m ->
      mem_tree_remove hs path = Some None ->
      Rest ->
      canceling [P] (interp_mem_tree hs) Rest.
  Proof.
    unfold canceling. simpl. intros. split. 2: assumption.
    intros.
    pose proof (consume_mem_tree H0 H1 H3) as A. subst. assumption.
  Qed.

  (* for home-made rewrite *)
  Lemma subst_mem_eq(mSmall mBig: mem){omSmall: mmap mem}(C: mmap mem -> mmap mem):
    omSmall = mmap.Def mSmall ->
    C (mmap.Def mSmall) = mmap.Def mBig ->
    C omSmall = mmap.Def mBig.
  Proof. intros. rewrite <- H in H0. exact H0. Qed.

  Lemma sep_from_disjointb: forall m1 m2 (P Q: mem -> Prop),
      map.disjointb m1 m2 = true ->
      P m1 ->
      Q m2 ->
      sep P Q (map.putmany m1 m2).
  Proof.
    intros. unfold sep, map.split. do 2 eexists. eapply map.disjointb_spec in H.
    ssplit. 1: reflexivity. all: eassumption.
  Qed.
End HeapletwiseHyps.

Ltac reify_mem_tree e :=
  lazymatch e with
  | mmap.du ?e1 ?e2 =>
      let t1 := reify_mem_tree e1 in
      let t2 := reify_mem_tree e2 in
      constr:(NDisjointUnion t1 t2)
  | mmap.equal_union ?e1 ?e2 =>
      let t1 := reify_mem_tree e1 in
      let t2 := reify_mem_tree e2 in
      constr:(NEqualUnion t1 t2)
  | mmap.Def ?m => constr:(NLeaf m)
  end.

Ltac should_unpack P :=
 lazymatch P with
 | sep _ _ => constr:(true)
 | (fun m => Some m = _) => constr:(true)
 | _ => constr:(false)
 end.

Ltac clear_if_dup_or_trivial H :=
  let t := type of H in
  lazymatch t with
  | True => clear H
  | ?x = ?x => clear H
  | _ => match goal with
         | H': t |- _ => tryif constr_eq H H' then fail else clear H
         | |- _ => idtac
         end
  end.

Ltac heapletwise_hyp_pre_clear_default H :=
  let tHOrig := type of H in
  unfold with_mem in H;
  lazymatch type of H with
  | ?P ?m =>
      tryif is_var P then idtac (* It's a frame, nothing to purify *)
      else (
        let g := open_constr:(purify P _) in
        let pf := match constr:(Set) with
                  | _ => constr:(ltac:(eauto with purify) : g)
                  | _ => constr:(tt)
                 end in
        lazymatch pf with
        | tt => pose_err Error:(g "can't be solved by" "eauto with purify");
                change tHOrig in H
        | _ => let HP := fresh "old_" H "_pure" in pose proof (pf _ H) as HP;
               clear_if_dup_or_trivial HP
        end
      )
  end.

Ltac heapletwise_hyp_pre_clear_hook H := heapletwise_hyp_pre_clear_default H.

Ltac clear_heapletwise_hyp H :=
  let tH := type of H in
  let m := lazymatch tH with
           | with_mem ?m _ => m
           | _ ?m => m
           | _ => fail 1000 H "has unexpected shape" tH
           end in
  heapletwise_hyp_pre_clear_hook H;
  (clear H || fail 1000 "Can't clear" H ": probably a bug!");
  try clear m.

Ltac clear_heapletwise_hyps :=
  repeat match goal with
         | _: tactic_error _ |- _ => fail 1 (* pose at most one error *)
         | H: with_mem _ _ |- _ => clear_heapletwise_hyp H
         end.

(* can be overridden using ::= *)
Ltac same_pred_and_addr P Q :=
  lazymatch P with
  | ?pred ?val1 ?addr =>
      lazymatch Q with
      | pred ?val2 addr => idtac
      end
  end.

(* given a new mem hyp H, replace the corresponding old mem hyp by H *)
Ltac replace_with_new_mem_hyp H :=
  let Pnew := lazymatch type of H with
              | with_mem _ ?Pnew => Pnew
              | ?Pnew ?m => let __ := match constr:(O) with
                                      | _ => change (with_mem m Pnew) in H
                                      end in Pnew
              end in
  lazymatch Pnew with
  | sep _ _ => fail "first destruct the sep"
  | _ => idtac
  end;
  let HOld := match reverse goal with
              | HOld: with_mem ?mOld ?Pold |- _ =>
                  let __ := match constr:(Set) with
                            | _ => tryif constr_eq HOld H then
                                    fail (*bad choice of HOld: don't replace H by itself*)
                                   else same_pred_and_addr Pnew Pold
                            end in HOld
              end in
  move H before HOld;
  clear_heapletwise_hyp HOld;
  rename H into HOld.

(* Called whenever a new heapletwise hyp is created whose type will get destructed further *)
Ltac new_heapletwise_hyp_hook h t := idtac.

Ltac new_mem_hyp h :=
  let t := type of h in
  let p := lazymatch t with
           | with_mem ?m ?p => p
           | ?p ?m => p
           end in
  lazymatch p with
  | sep _ _ => idtac
  | emp _ => idtac
  | ex1 _ => idtac
  | _ => new_heapletwise_hyp_hook h t
  end.

Ltac split_sep_step :=
  let D := fresh "D" in
  let m1 := fresh "m0" in
  let m2 := fresh "m0" in
  let H1 := fresh "H0" in
  let H2 := fresh "H0" in
  lazymatch goal with
  | H: with_mem ?m1 (eq ?m2) |- _ =>
      match goal with
      | H': with_mem m2 _ |- _ => move H' after H
      | |- _ => idtac
      end;
      unfold with_mem in H; subst m1
  | H: @sep _ _ ?mem ?P ?Q ?parent_m |- _ =>
      let unpackP := should_unpack P in
      let unpackQ := should_unpack Q in
      lazymatch constr:((unpackP, unpackQ)) with
      | (true, true) => eapply sep_to_unpacked_and_unpacked in H
      | (false, true) => eapply sep_to_with_mem_and_unpacked in H
      | (true, false) => eapply sep_to_unpacked_and_with_mem in H
      | (false, false) => eapply sep_to_with_mem_and_with_mem in H
      end;
      destruct H as (m1 & m2 & H1 & H2 & D);
      new_mem_hyp H1;
      new_mem_hyp H2;
      move m1 before parent_m; (* before in direction of movement == below *)
      move m2 before m1;
      try replace_with_new_mem_hyp H1;
      try replace_with_new_mem_hyp H2;
      let E := match goal with
               | E: ?om = mmap.Def ?mBig |- _ =>
                   lazymatch om with
                   | context C[mmap.Def parent_m] => E
                   end
               | |- _ => constr:(tt) (* in first sep destruct step, there's no E yet *)
               end in
      (* re-match, but this time lazily, to preserve error messages: *)
      lazymatch type of E with
      | ?om = mmap.Def ?mBig =>
          lazymatch om with
          | context C[mmap.Def parent_m] =>
              (* home-made rewrite in hyp because we already have context C *)
              eapply (subst_mem_eq parent_m mBig
                        (fun hole: mmap mem =>
                           ltac:(let r := context C[hole] in exact r))
                        D) in E;
              (* (Some parent_m) might also appear in below the line (if canceling) *)
              rewrite <-?D;
              clear parent_m D
          end
      | unit => idtac
      end
  end.

Ltac destruct_ex1_step :=
  lazymatch goal with
  | H: with_mem ?m (ex1 (fun name => _)) |- _ =>
      let x := fresh name in
      destruct H as [x H]
  end.

Ltac destruct_emp_step :=
  lazymatch goal with
  | H: with_mem ?m (emp ?P), D: _ = mmap.Def _ |- _ =>
      destruct H as [? H];
      subst m;
      rewrite ?mmap.du_empty_l, ?mmap.du_empty_r in D
  end.

(* usually already done by split_sep_step, but when introducing hyps from the
   frame after a call, separate merging might still be needed: *)
Ltac merge_du_step :=
  match reverse goal with
  | E1: ?om1 = mmap.Def ?m, E2: ?om2 = mmap.Def ?m |- _ =>
      let D := fresh "D" in
      pose proof (merge_two_split_equations E1 E2) as D;
      clear E1 E2
  | H: map.split _ _ _ |- _ => eapply split_du in H
  | E1: ?om1 = @mmap.Def _ _ ?Mem ?m, E2: ?om2 = mmap.Def ?m' |- _ =>
      lazymatch om1 with
      | mmap.du _ _ => idtac
      | mmap.equal_union _ _ => idtac
      end;
      lazymatch om2 with
      | mmap.du _ _ => idtac
      | mmap.equal_union _ _ => idtac
      end;
      lazymatch om2 with
      | context C[mmap.Def m] =>
          (* home-made rewrite *)
          eapply (subst_mem_eq m m'
                    (fun hole: mmap Mem => ltac:(let r := context C[hole] in exact r))
                    E1) in E2;
          clear m E1
      end
  | H: mmap.Def ?m1 = mmap.Def ?m2 |- _ =>
      is_var m1; is_var m2; apply mmap.eq_of_eq_Def in H; subst m1
  end.

Ltac start_canceling :=
  lazymatch goal with
  | D: _ = mmap.Def ?m |- sep ?P ?Q ?m /\ ?Rest =>
      let clausetree := reify (sep P Q) in change (Tree.to_sep clausetree m /\ Rest);
      eapply (canceling_start_and D)
  | D: _ = mmap.Def ?m |- sep ?P ?Q ?m =>
      let clausetree := reify (sep P Q) in change (Tree.to_sep clausetree m);
      eapply (canceling_start_noand D)
  end;
  cbn [Tree.flatten Tree.interp bedrock2.Map.SeparationLogic.app].

Ltac path_in_mem_tree om m :=
  lazymatch om with
  | NLeaf m => constr:(@nil bool)
  | NLeaf _ => fail "could not find" m "in" om
  | NDisjointUnion ?t1 ?t2 =>
      match constr:(O) with
      | _ => let p := path_in_mem_tree t1 m in constr:(cons false p)
      | _ => let p := path_in_mem_tree t2 m in constr:(cons true p)
      | _ => fail 1 "could not find" m "in" om
      end
  | NEqualUnion ?t1 ?t2 =>
      match constr:(O) with
      | _ => let p := path_in_mem_tree t1 m in constr:(cons false p)
      | _ => let p := path_in_mem_tree t2 m in constr:(cons true p)
      | _ => fail 1 "could not find" m "in" om
      end
  | _ => fail "Expected a mem_tree, but got" om
  end.

Ltac cancel_head_with_hyp H :=
  lazymatch goal with
  | |- canceling (cons _ ?Ps) ?om _ =>
      let m := lazymatch type of H with with_mem ?m _ => m end in
      let hs := reify_mem_tree om in
      let p := path_in_mem_tree hs m in
      let lem := lazymatch Ps with
                 | nil => open_constr:(canceling_last_step hs p H)
                 | cons _ _ => open_constr:(cancel_head hs p H)
                 end in
      eapply lem;
      [ reflexivity
      | reflexivity
      | cbn [interp_mem_tree] ]
  end.

Ltac canceling_step :=
  lazymatch goal with
  | |- canceling [anymem] _ _ => eapply canceling_done_anymem
  | |- canceling (cons ?R ?Ps) ?om ?P =>
      tryif is_evar R then
        lazymatch Ps with
        | nil =>
            let P := lazymatch eval pattern R in P with ?f _ => f end in
            lazymatch P with
            | (fun _ => ?doesNotDependOnArg) => eapply canceling_done_anymem
            | _ => eapply (canceling_done_frame_generic om P);
                   [ solve [clear; unfold sep; intros; fwd; eauto 20] | ]
            end
        | cons _ _ => fail 1000 "frame evar must be last in list"
        end
      else
        lazymatch R with
        | emp _ => eapply cancel_pure_head
        | _ => let H :=
                 match goal with
                 | H: with_mem _ ?P' |- _ =>
                     let __ := match constr:(Set) with _ => syntactic_unify P' R end in H
                 end in
               cancel_head_with_hyp H
        end
  | |- True => constructor
  end.

Ltac intro_step :=
  lazymatch goal with
  | m: ?mem, H: @with_mem ?mem _ _ |- forall (_: ?mem), _ =>
      let m' := fresh "m0" in intro m'; move m' before m
  | HOld: _ = mmap.Def ?mOld |- _ = mmap.Def _ -> _ =>
      let tmp := fresh "tmp" in
      intro tmp; move tmp before HOld; clear mOld HOld; rename tmp into HOld
  | H: with_mem _ _ |- sep _ _ _ -> _ =>
      let H' := fresh "H0" in
      intro H'; move H' before H
  end.

Ltac and_step :=
  lazymatch goal with
  | |- (fun _ => _ /\ _) _ /\ _ => cbv beta
  | |- ?P /\ _ => is_destructible_and P; eapply and_assoc
  end.

Ltac heapletwise_step :=
  first
    [ intro_step
    | split_sep_step
    | destruct_ex1_step
    | destruct_emp_step
    | merge_du_step
    | and_step
    | start_canceling
    | canceling_step ].

Ltac collect_heaplets_into_one_sepclause M :=
  lazymatch goal with
  | D: _ = mmap.Def ?m |- _ =>
      eassert (_ m) as M;
      unfold mmap.du in D; unfold mmap.of_option, map.du in D; fwd;
      [ solve [ repeat lazymatch goal with
                  | WM: with_mem ?m _ |- _ ?m => exact WM
                  | D: map.disjointb ?m1 ?m2 = true |- _ (map.putmany ?m1 ?m2) =>
                      eapply sep_from_disjointb; [exact D | | ]
                  | |- ?g => fail 2 "no heaplet hypothesis for" g
                  end ]
      | ]
  end;
  repeat match goal with
    | H: with_mem _ _ |- _ => clear H
    | H: map.disjointb _ _ = true |- _ => clear H
    end;
  lazymatch type of M with
  | _ ?putmanys =>
      let m := fresh "m0" in forget putmanys as m;
      let mem := type of m in
      repeat match goal with
        | heaplet: mem |- _ => clear heaplet
        end
  end.

Section HeapletwiseHypsTests.
  Context {key value: Type} {mem: map.map key value} {mem_ok: map.ok mem}
          {key_eqb: key -> key -> bool} {key_eqb_spec: EqDecider key_eqb}.

  Hypothesis scalar: nat -> nat -> mem -> Prop.

  Lemma purify_scalar: forall v a, purify (scalar v a) True.
  Proof. unfold purify. intros. constructor. Qed.
  Hint Resolve purify_scalar: purify.

  Context (fname: Type).
  Context (cmd: Type) (trace: Type) (locals: Type).
  Context (cmd_call: fname -> list nat -> cmd).
  Context (wp: cmd -> trace -> mem -> locals -> (trace -> mem -> locals -> Prop) -> Prop).

  Context (call: fname -> trace -> mem -> list nat ->
                 (trace -> mem -> list nat -> Prop) -> Prop).

  Context (update_locals: locals -> list nat -> locals -> Prop).

  (* each program logic needs to prove & apply a lemma to shoehorn its function specs
     from the definition-site format into the use-site format: *)
  Hypothesis wp_call: forall f t m args l
      (calleePre: Prop)
      (calleePost: trace -> mem -> list nat -> Prop)
      (callerPost: trace -> mem -> locals -> Prop),
      (* definition-site format: *)
      (calleePre -> call f t m args calleePost) ->
      (* use-site format: *)
      (calleePre /\
         forall t' m' l' rets,
           calleePost t' m' rets -> update_locals l rets l' -> callerPost t' m' l') ->
      (* conclusion: *)
      wp (cmd_call f args) t m l callerPost.

  Context (frobnicate: fname).
  Context (frobnicate_ok: forall (a1 a2 v1 v2: nat) t m (R: mem -> Prop),
              sep (sep (emp True) (scalar v1 a1)) (sep (scalar v2 a2) R) m ->
              call frobnicate t m [a1; a2] (fun t' m' rets =>
                   exists d, rets = [d] /\ d <= v1 /\
                   sep (scalar (v1 + v2 + d) a1) (sep (scalar (v1 - v2 - d) a2) R) m')).

  Ltac program_logic_step :=
    match goal with
    | |- forall _, _ => intro
    | H: with_mem _ (scalar ?v ?a) |- canceling (cons (scalar ?v' ?a) _) _ _ =>
        replace v with v' in H by Lia.lia
    | |- _ => progress fwd
    | |- wp (cmd_call frobnicate _) _ _ _ _ => eapply wp_call; [eapply frobnicate_ok | ]
    | |- exists _, _ => eexists
    end.

  Ltac step := first [ heapletwise_step | program_logic_step ].

  Goal forall m v1 v2 v3 v4 (Rest: mem -> Prop),
      (sep (scalar v1 1) (sep (sep (scalar v2 2) (scalar v3 3)) (sep (scalar v4 4) Rest))) m ->
      exists R a4 a3, sep (sep (scalar a4 4) (scalar a3 3)) R m.
  Proof.
    step. step. step. step. step. step. step.
    (* split seps into separate hyps: *)
    step. step. step. step.
    (* just for desting, join them back together: *)
    let H := fresh in collect_heaplets_into_one_sepclause H.
    (* and split again: *)
    step. step. step. step.
    (* existentials: *)
    step. step. step.
    start_canceling.

(*
  m, m0, m3, m5, m1, m4 : mem
  v1, v2, v3, v4 : nat
  Rest : mem -> Prop
  H0 : m0 |= scalar v1 1
  H3 : m3 |= scalar v2 2
  H5 : m5 |= scalar v3 3
  H1 : m1 |= scalar v4 4
  H4 : m4 |= Rest
  D : m0 \*/ ((m3 \*/ m5) \*/ (m1 \*/ m4)) = m
  ============================
  canceling [scalar ?a4 4; scalar ?a3 3; ?R] (m0 \*/ ((m3 \*/ m5) \*/ (m1 \*/ m4))) True
*)

    canceling_step.
    canceling_step.
    canceling_step.
    step.
  Qed.

  (* sample caller: *)
  Goal forall (p1 p2 p3 x y: nat) t (m: mem) l (R: mem -> Prop),
      sep (scalar x p1) (sep (scalar y p2) (sep (scalar x p3) R)) m ->
      wp (cmd_call frobnicate [p1; p3]) t m l (fun t m l =>
        wp (cmd_call frobnicate [p3; p1]) t m l (fun t m l =>
           exists res,
           sep (scalar 0 p1) (sep (scalar y p2) (sep (scalar res p3) R)) m)).
  Proof.
    repeat step.
  Qed.

  Let scalar_pair(v1 v2 a1 a2: nat) := sep (scalar v1 a1) (scalar v2 a2).

  Lemma purify_scalar_pair: forall v1 v2 a1 a2, purify (scalar_pair v1 v2 a1 a2) True.
  Proof. unfold purify. intros. constructor. Qed.
  Hint Resolve purify_scalar_pair : purify.

  (* sample caller where argument is a field: *)
  Goal forall (p1 p2 p3 x y: nat) t m l (R: mem -> Prop),
      sep (scalar x p1) (sep (scalar_pair y x p2 p3) R) m ->
      wp (cmd_call frobnicate [p1; p3]) t m l (fun t m l =>
        wp (cmd_call frobnicate [p3; p1]) t m l (fun t m l =>
           exists res, (* TODO: scalar_pair in postcondition *)
           sep (scalar 0 p1) (sep (scalar y p2) (sep (scalar res p3) R)) m)).
  Proof.
    repeat step.

    (* unfolding/splitting hyp during cancellation: *)
    unfold scalar_pair in H2.
    unfold with_mem in H2.

    step. (* <-- substitutes (mmap.Def m2) both in D and in the goal *)
    step.
    step. (* <- instantiates the frame ?R with a P that gets passed itself as an argument,
                see canceling_done_frame_generic *)
    step. step. step. step. step. step. step. step. step. step. step. step. step.

    repeat step.
  Qed.

(* sample unfolded spec of indirect_add:

    forall (a b c va : word) (Ra : mem -> Prop) (vb : word)
         (Rb : mem -> Prop) (vc : word) (Rc : mem -> Prop) (t : trace)
         (m : mem),
       (scalar a va ⋆ Ra)%sep m /\ (scalar b vb ⋆ Rb)%sep m /\ (scalar c vc ⋆ Rc)%sep m ->
       call functions "indirect_add" t m [a; b; c]
         (fun (t' : trace) (m' : mem) (rets : list word) =>
          rets = [] /\ t = t' /\ (scalar a (word.add vb vc) ⋆ Ra)%sep m')

*)

  Context (aliasing_add: fname).
  Hypothesis aliasing_add_ok: forall a b c va vb vc (Ra Rb Rc: mem -> Prop) t m,
      sep (scalar va a) Ra m /\
      sep (scalar vb b) Rb m /\
      sep (scalar vc c) Rc m ->
      call aliasing_add t m [c; a; b] (fun t' m' rets =>
        sep (scalar (va + vb) c) Rc m').

  Goal forall x y z vx vy vz (R: mem -> Prop) t m l,
      sep (scalar vx x) (sep (scalar vy y) (sep (scalar vz z) R)) m ->
      wp (cmd_call aliasing_add [x; y; z]) t m l (fun t m l =>
        wp (cmd_call aliasing_add [x; y; y]) t m l (fun t m l =>
          wp (cmd_call aliasing_add [x; x; z]) t m l (fun t m l =>
            wp (cmd_call aliasing_add [x; x; x]) t m l (fun t m l =>
              sep (scalar (vy + vy + vz + (vy + vy + vz)) x)
                (sep (scalar vy y) (sep (scalar vz z) R)) m)))).
  Proof.
    clear frobnicate frobnicate_ok scalar_pair.
    intros.
    repeat step.
    eapply wp_call. 1: eapply aliasing_add_ok.
    repeat step.
    eapply wp_call. 1: eapply aliasing_add_ok.
    repeat step.
    eapply wp_call. 1: eapply aliasing_add_ok.
    repeat step.
    eapply wp_call. 1: eapply aliasing_add_ok.
    repeat step.
  Qed.
End HeapletwiseHypsTests.


From Coq Require Import ZArith List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
From BitBlasting Require Import QFBV CNF BBCommon.
From ssrlib Require Import ZAriths Seqs Tactics.
From nbits Require Import NBits.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

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

Definition bit_blast_concat g ls1 ls0 : generator * cnf * word :=
  (g, [::], ls0 ++ ls1) .

Definition mk_env_concat E g ls1 ls0 : env * generator * cnf * word :=
  (E, g, [::], ls0 ++ ls1) .

Lemma bit_blast_concat_correct E g bs0 bs1 ls0 ls1 g' cs lr :
  bit_blast_concat g ls1 ls0 = (g', cs, lr) ->
    enc_bits E ls0 bs0 ->
    enc_bits E ls1 bs1 ->
    enc_bits E lr (cat bs0 bs1) .
Proof .
  case => _ _ <-; exact: enc_bits_cat .
Qed .

Lemma mk_env_concat_is_bit_blast_concat E g ls0 ls1 E' g' cs lr :
  mk_env_concat E g ls1 ls0 = (E', g', cs, lr) ->
  bit_blast_concat g ls1 ls0 = (g', cs, lr) .
Proof .
  rewrite /mk_env_concat /bit_blast_concat .
  case => _ <- <- <- // .
Qed .

Lemma mk_env_concat_newer_gen E g ls0 ls1 E' g' cs lr :
  mk_env_concat E g ls1 ls0 = (E', g', cs, lr) ->
  (g <=? g')%positive .
Proof .
  rewrite /mk_env_concat; case => _ <- _ _ .
  t_auto_newer .
Qed .

Lemma mk_env_concat_newer_res E g ls0 ls1 E' g' cs lrs :
  mk_env_concat E g ls1 ls0 = (E', g', cs, lrs) ->
  newer_than_lits g ls0 -> newer_than_lits g ls1 ->
  newer_than_lits g' lrs .
Proof .
  rewrite /mk_env_concat; case => _ <- _ <- Hls0 Hls1 .
  rewrite newer_than_lits_cat Hls0 Hls1 // .
Qed .

Lemma mk_env_concat_newer_cnf E g ls0 ls1 E' g' cs lrs :
  mk_env_concat E g ls1 ls0 = (E', g', cs, lrs) ->
  newer_than_lits g ls0 -> newer_than_lits g ls1 ->
  newer_than_cnf g' cs .
Proof .
  rewrite /mk_env_concat; case => _ <- <- _ // .
Qed .

Lemma mk_env_concat_preserve E g ls0 ls1 E' g' cs lrs :
  mk_env_concat E g ls1 ls0 = (E', g', cs, lrs) -> env_preserve E E' g .
Proof .
  rewrite /mk_env_concat; case => <- _ _ _ // .
Qed .

Lemma mk_env_concat_sat E g ls0 ls1 E' g' cs lrs :
  mk_env_concat E g ls1 ls0 = (E', g', cs, lrs) ->
  newer_than_lits g ls0 -> newer_than_lits g ls1 ->
  interp_cnf E' cs .
Proof .
  rewrite /mk_env_concat; case => <- _ <- _ // .
Qed .

Lemma mk_env_concat_env_equal E1 E2 g ls1 ls2 E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_concat E1 g ls1 ls2 = (E1', g1', cs1, lrs1) ->
  mk_env_concat E2 g ls1 ls2 = (E2', g2', cs2, lrs2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lrs1 = lrs2.
Proof.
  rewrite /mk_env_concat => Heq.
  case=> ? ? ? ?; case=> ? ? ? ?; subst. done.
Qed.


Require Import Program.Equality Ring Lia Omega.
From mathcomp Require Import ssreflect ssrfun ssrbool seq eqtype ssrnat.
From istari Require Import source subst_src rules_src lemmas0.
From istari Require Import Sigma Tactics
     Syntax Subst SimpSub Promote Hygiene
     ContextHygiene Equivalence Rules Defined.

Definition oof M A: (@Syntax.judgement obj) := deq M M A.

Definition oof_t M: (@Syntax.judgement obj) := deqtype M M.
(*more useful inference rules*)

Lemma tr_arrow_elim: forall G a b m n p q,
    tr G (deqtype a a) ->
    tr G (deqtype b b) ->
      tr G (deq m n (arrow a b))
      -> tr G (deq p q a)
      -> tr G (deq (app m p) (app n q) b).
intros.
suffices: (subst1 p (subst sh1 b)) = b. move => Heq.
rewrite - Heq.
eapply (tr_pi_elim _ a); try assumption.
eapply tr_eqtype_convert; try apply tr_arrow_pi_equal; assumption.
simpsub. auto. Qed.

Lemma tr_arrow_intro: forall G a b m n,
    tr G (deqtype a a) ->
      tr G (deqtype b b)
      -> tr (cons (hyp_tm a) G) (deq m n (subst sh1 b))
      -> tr G (deq (lam m) (lam n) (arrow a b) ).
intros. eapply tr_eqtype_convert.
apply tr_eqtype_symmetry. apply tr_arrow_pi_equal; try assumption.
eapply tr_pi_intro; try assumption. Qed.

Lemma tr_karrow_elim: forall G a b m n p q,
    tr G (deqtype a a) ->
    tr G (deqtype b b) ->
      tr G (deq m n (karrow a b))
      -> tr G (deq p q a)
      -> tr G (deq (app m p) (app n q) b).
  intros. apply (tr_arrow_elim _ a); try assumption.
  eapply tr_eqtype_convert. apply tr_eqtype_symmetry.
  apply tr_arrow_karrow_equal; assumption.
  assumption. Qed.

Lemma kind_type: forall {G K i},
    tr G (deq K K (kuniv i)) -> tr G (deqtype K K).
  move => G K i H. eapply tr_formation_weaken.
  eapply tr_kuniv_weaken. apply H. Qed.

Lemma tr_prod_intro G A B M M' N N' :
    tr G (deq M M' A) -> tr G (deq N N' B) ->
    tr G (deq (ppair M N) (ppair M' N') (prod A B)).
  intros H0 H1.
  pose proof (tr_inhabitation_formation _#4 H0) as Ha.
  pose proof (tr_inhabitation_formation _#4 H1) as Hb.
  eapply tr_eqtype_convert.
  apply tr_eqtype_symmetry. apply tr_prod_sigma_equal; try assumption.
  eapply tr_sigma_intro; try assumption. simpsub. assumption.
  match goal with |- tr ?G' ?J => change J with (substj (under 0 sh1)
                                                    (deqtype B B));
                                  change G' with (nil ++ G') end.
  change nil with (@substctx Rules.obj sh1 nil).
  apply tr_weakening. assumption.
  Qed.

Lemma tr_booltp_eta_hyp0 :
    forall G m n p q a,
      tr G (deq m n (subst1 btrue a))
      -> tr G (deq p q (subst1 bfalse a))
      -> tr ((hyp_tm booltp)::G) (deq
              (bite (var 0)
                 (subst sh1 m)
                 (subst sh1 p))
              (bite (var 0)
                 (subst sh1 n)
                 (subst sh1 q) )
              a).
  intros. rewrite - (cat0s ((hyp_tm booltp)::G)).
  change (sh1) with (@ under obj 0 sh1).
  change 0 with (size ([::]: @context False)).
  apply tr_booltp_eta_hyp; simpl; assumption.
Qed.

Lemma tr_weakening_appends: forall G1 G2 G3 J1 J2 t J1' J2' t',
    tr G1 (deq J1 J2 t) ->
    J1' = (shift (size G2) J1) ->
    J2' = (shift (size G2) J2) ->
    t' = (shift (size G2) t) ->
    G3 = G2 ++ G1 ->
      tr G3 (deq J1' J2' t').
 move => G1 G2.  induction G2; intros.
 -  simpl. subst. repeat rewrite - subst_sh_shift. simpsub. assumption.
 -
  suffices: (tr (substctx sh1 [::] ++ cons a (G2 ++ G1))
                (substj (under (length [::]) sh1)
                        (substj (sh (size G2)) (deq J1 J2 t)))).
  move => Hdone.
  simpl in Hdone. subst.
  rewrite (size_ncons 1).
  rewrite - plusE.
  repeat rewrite subst_sh_shift.
  repeat rewrite - shift_sum.
  repeat rewrite subst_sh_shift in Hdone.
  rewrite cat_cons.
 apply (Hdone False).
 intros.
 eapply tr_weakening.
 simpl. repeat rewrite subst_sh_shift. eapply IHG2; try reflexivity. assumption.
Qed.

 Lemma tr_weakening_append: forall (G1: context) G2 J1 J2 t,
      tr G1 (deq J1 J2 t) ->
      tr (G2 ++ G1) (
                       (deq (shift (size G2) J1)
                            (shift (size G2) J2)
                            (shift (size G2) t))).
   move =>> H. eapply tr_weakening_appends; try apply H; try reflexivity.
   Qed.

 Lemma tr_weakening_appendt: forall (G1: context) G2 J1 J2,
      tr G1 (deqtype J1 J2) ->
      tr (G2 ++ G1) (deqtype (shift (size G2) J1)
                             (shift (size G2) J2)).
   intros. unfold deqtype.
   rewrite - ! subst_sh_shift - subst_eqtype.
   change triv with (@shift obj (size G2) triv).
   rewrite ! subst_sh_shift. apply tr_weakening_append.
   assumption. Qed.

 Lemma tr_weakening_append1: forall G1 x J1 J2 t,
      tr G1 (deq J1 J2 t) ->
      tr (x::G1) (
                       (deq (shift 1 J1)
                            (shift 1 J2)
                            (shift 1 t))).
   intros. rewrite make_app1. apply tr_weakening_append. assumption. Qed.

 Lemma tr_weakening_append2: forall G1 x y J1 J2 t,
      tr G1 (deq J1 J2 t) ->
      tr (x::y::G1) (
                       (deq (shift 2 J1)
                            (shift 2 J2)
                            (shift 2 t))).
   intros. rewrite make_app2. apply tr_weakening_append. assumption. Qed.

 Lemma tr_weakening_append3: forall G1 x y z J1 J2 t,
      tr G1 (deq J1 J2 t) ->
      tr (x::y::z::G1) (
                       (deq (shift 3 J1)
                            (shift 3 J2)
                            (shift 3 t))).
   intros. rewrite make_app3. apply tr_weakening_append. assumption. Qed.

Lemma tr_weakening_append4: forall G1 x y z a J1 J2 t,
      tr G1 (deq J1 J2 t) ->
      tr (x::y::z::a::G1) (
                       (deq (shift 4 J1)
                            (shift 4 J2)
                            (shift 4 t))).
   intros. rewrite make_app4. apply tr_weakening_append. assumption. Qed.

Lemma tr_weakening_append5: forall G1 x y z a b J1 J2 t,
      tr G1 (deq J1 J2 t) ->
      tr (x::y::z::a::b::G1) (
                       (deq (shift 5 J1)
                            (shift 5 J2)
                            (shift 5 t))).
   intros. rewrite make_app5. apply tr_weakening_append. assumption. Qed.
Lemma tr_weakening_append6: forall G1 x y z a b c J1 J2 t,
      tr G1 (deq J1 J2 t) ->
      tr (x::y::z::a::b::c::G1) (
                       (deq (shift 6 J1)
                            (shift 6 J2)
                            (shift 6 t))).
   intros. rewrite make_app6.  apply tr_weakening_append. assumption. Qed.

Lemma tr_weakening_append7: forall G1 x y z a b c d J1 J2 t,
      tr G1 (deq J1 J2 t) ->
      tr (x::y::z::a::b::c::d::G1) (
                       (deq (shift 7 J1)
                            (shift 7 J2)
                            (shift 7 t))).
  intros. change [:: x, y, z, a, b, c, d & G1] with
             ( [:: x; y; z; a; b; c; d] ++ G1).
  apply tr_weakening_append. assumption. Qed.

Lemma tr_weakening_append8: forall G1 x y z a b c d e J1 J2 t,
      tr G1 (deq J1 J2 t) ->
      tr (x::y::z::a::b::c::d::e::G1) (
                       (deq (shift 8 J1)
                            (shift 8 J2)
                            (shift 8 t))).
  intros. change [:: x, y, z, a, b, c, d, e & G1] with
             ( [:: x; y; z; a; b; c; d; e] ++ G1).
  apply tr_weakening_append. assumption. Qed.

Lemma deqtype_intro :
  forall G a b m n,
    tr G (deq m n (eqtype a b))
    -> tr G (deqtype a b).
Proof.
intros G a b m n H.
unfold deqtype.
apply (tr_transitivity _ _ m).
  {
  apply tr_symmetry.
  apply tr_eqtype_eta.
  apply (tr_transitivity _ _ n); auto.
  apply tr_symmetry; auto.
  }

  {
  apply tr_eqtype_eta.
  apply (tr_transitivity _ _ n); auto.
  apply tr_symmetry; auto.
  }
Qed.

Lemma tr_eqtype_reflexivity:
  forall G a a',
    tr G (deqtype a a') ->
    tr G (deqtype a a).
  intros  G a a' H0. pose proof (tr_eqtype_symmetry _#3 H0) as H1.
  apply (tr_eqtype_transitivity _#4 H0 H1).
Qed.

Lemma tr_eq_reflexivity:
  forall G m n a,
    tr G (deq m n a) ->
    tr G (deq m m a).
  intros  G m n a H0. pose proof (tr_symmetry _#4 H0) as H1.
  apply (tr_transitivity _#5 H0 H1).
Qed.

Lemma deq_intro :
  forall G a m n p q,
    tr G (deq p q (equal a m n))
    -> tr G (deq m n a).
Proof.
intros G a m n p q H.
apply tr_equal_elim.
apply (tr_transitivity _ _ p).
  {
  apply tr_symmetry.
  apply tr_equal_eta.
  apply (tr_transitivity _ _ q); auto.
  apply tr_symmetry; auto.
  }

  {
  apply tr_equal_eta.
  apply (tr_transitivity _ _ q); auto.
  apply tr_symmetry; auto.
  }
Qed.

Ltac prove_equiv_compat :=
  intros;
  apply equiv_compat;
  apply mc_oper; repeat2 (apply mcr_cons); [.. | apply mcr_nil]; auto.

Lemma equiv_eqtype {a a' b b'}:
    equiv a a'
    -> equiv b b'
    -> equiv (eqtype a b) (@eqtype obj a' b').
  prove_equiv_compat.
Qed.

Lemma equiv_equalterm {a a' m m' n n'}:
    equiv a a'
    -> equiv m m'
    -> equiv n n'
    -> equiv (equal a m n) (@equal obj a' m' n').
  prove_equiv_compat.
Qed.


(** * PHOAS Representation of Gallina which allows exact denotation *)
Require Import Coq.Strings.String.
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.SmartMap.
Require Import Crypto.Compilers.ExprInversion.
Require Import Crypto.Compilers.InterpProofs.
Require Import Crypto.Util.Tuple.
Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.Tactics.RewriteHyp.
Require Import Crypto.Util.Notations.

(** We parameterize the language over a type of basic type codes (for
    things like [Z], [word], [bool]), as well as a type of n-ary
    operations returning one value, and n-ary operations returning two
    values. *)
Local Open Scope ctype_scope.
Section language.
  Context (base_type_code : Type).

  Local Notation flat_type := (flat_type base_type_code).
  Inductive type := Tflat (A : flat_type) | Arrow (A : flat_type) (B : type).

  Section expr_param.
    Context (interp_base_type : base_type_code -> Type).
    Context (op : flat_type (* input tuple *) -> flat_type (* output type *) -> Type).
    Local Notation interp_flat_type_gen := interp_flat_type.
    Local Notation interp_flat_type := (interp_flat_type interp_base_type).

    Fixpoint interp_type (t : type) :=
      match t with
      | Tflat A => interp_flat_type A
      | Arrow A B => (interp_flat_type A -> interp_type B)%type
      end.

    Section expr.
      Context {var : flat_type -> Type}.

      (** N.B. [Let] destructures pairs *)
      Inductive exprf : flat_type -> Type :=
      | Const {t : flat_type} : interp_flat_type t -> exprf t
      | Var {t} : var t -> exprf t
      | Op {t1 tR} : op t1 tR -> exprf t1 -> exprf tR
      | LetIn : forall {tx}, exprf tx -> forall {tC}, (var tx -> exprf tC) -> exprf tC
      | Pair : forall {t1}, exprf t1 -> forall {t2}, exprf t2 -> exprf (Prod t1 t2)
      | MatchPair : forall {t1 t2}, exprf (Prod t1 t2) -> forall {tC}, (var t1 -> var t2 -> exprf tC) -> exprf tC.
      Inductive expr : type -> Type :=
      | Return {T} : exprf T -> expr (Tflat T)
      | Abs {src dst} : (var src -> expr dst) -> expr (Arrow src dst).

      Definition Fst {t1 t2} (v : exprf (Prod t1 t2)) : exprf t1 := MatchPair v (fun x y => Var x).
      Definition Snd {t1 t2} (v : exprf (Prod t1 t2)) : exprf t2 := MatchPair v (fun x y => Var y).
    End expr.

    Definition Expr (t : type) := forall var, @expr var t.

    Section interp.
      Context (interp_op : forall src dst, op src dst -> interp_flat_type src -> interp_flat_type dst).

      Fixpoint interpf {t} (e : @exprf interp_flat_type t) : interp_flat_type t
        := match e in exprf t return interp_flat_type t with
           | Const _ x => x
           | Var _ x => x
           | Op _ _ op args => @interp_op _ _ op (@interpf _ args)
           | LetIn _ ex _ eC => dlet x := @interpf _ ex in @interpf _ (eC x)
           | Pair _ ex _ ey => (@interpf _ ex, @interpf _ ey)
           | MatchPair _ _ ex _ eC => match @interpf _ ex with pair x y => @interpf _ (eC x y) end
           end.
      Fixpoint interp {t} (e : @expr interp_flat_type t) : interp_type t
        := match e in expr t return interp_type t with
           | Return _ v => interpf v
           | Abs _ _ f => fun x => @interp _ (f x)
           end.

      Definition Interp {t} (E : Expr t) : interp_type t := interp (E _).
    End interp.

    Section compile.
      Context {var : base_type_code -> Type}
              (make_const : forall t, interp_base_type t -> op Unit (Tbase t)).

      Fixpoint compilet (t : type) : Syntax.type base_type_code
        := Syntax.Arrow
             match t with
             | Tflat T => Unit
             | Arrow A (Tflat B) => A
             | Arrow A B
               => A * domain (compilet B)
             end%ctype
             match t with
             | Tflat T => T
             | Arrow A B => codomain (compilet B)
             end.

      Fixpoint SmartConst (t : flat_type) : interp_flat_type t -> Syntax.exprf base_type_code op (var:=var) t
        := match t return interp_flat_type t -> Syntax.exprf _ _ t with
           | Unit => fun _ => TT
           | Tbase _ => fun v => Syntax.Op (make_const _ v) TT
           | Prod _ _ => fun v => Syntax.Pair (@SmartConst _ (fst v))
                                              (@SmartConst _ (snd v))
           end.

      Fixpoint compilef {t} (e : @exprf (interp_flat_type_gen var) t) : @Syntax.exprf base_type_code op var t
        := match e in exprf t return @Syntax.exprf _ _ _ t with
           | Const _ x => @SmartConst _ x
           | Var _ x => SmartMap.SmartVarf x
           | Op _ _ op args => Syntax.Op op (@compilef _ args)
           | LetIn _ ex _ eC => Syntax.LetIn (@compilef _ ex) (fun x => @compilef _ (eC x))
           | Pair _ ex _ ey => Syntax.Pair (@compilef _ ex) (@compilef _ ey)
           | MatchPair _ _ ex _ eC => Syntax.LetIn (@compilef _ ex) (fun xy => @compilef _ (eC (fst xy) (snd xy)))
           end.

      (* ugh, so much manual annotation *)
      Fixpoint compile {t} (e : @expr (interp_flat_type_gen var) t) : @Syntax.expr base_type_code op var (compilet t)
        := match e in expr t return @Syntax.expr _ _ _ (compilet t) with
           | Return _ v => Syntax.Abs (fun _ => compilef v)
           | Abs src dst f
             => let res := fun x => @compile _ (f x) in
                match dst
                      return (_ -> Syntax.expr _ _ (compilet dst))
                             -> Syntax.expr _ _ (compilet (Arrow src dst))
                with
                | Tflat T
                  => fun resf => Syntax.Abs (fun x => invert_Abs (resf x) tt)
                | Arrow A B as dst'
                  => match compilet dst' as cdst
                           return (_ -> Syntax.expr _ _ cdst)
                                  -> Syntax.expr _ _ (Syntax.Arrow
                                                        (_ * domain cdst)
                                                        (codomain cdst))
                     with
                     | Syntax.Arrow A' B'
                       => fun resf => Syntax.Abs (fun x : interp_flat_type_gen var (_ * _)
                                                  => invert_Abs (resf (fst x)) (snd x))
                     end
                end res
               end.
    End compile.

    Definition Compile
               (make_const : forall t, interp_base_type t -> op Unit (Tbase t))
               {t} (e : Expr t) : Syntax.Expr base_type_code op (compilet t)
      := fun var => compile make_const (e _).

    Section compile_correct.
      Context (make_const : forall t, interp_base_type t -> op Unit (Tbase t))
              (interp_op : forall src dst, op src dst -> interp_flat_type src -> interp_flat_type dst)
              (make_const_correct : forall T v, interp_op Unit (Tbase T) (make_const T v) tt = v).

      Lemma SmartConst_correct t v
        : Syntax.interpf interp_op (SmartConst make_const t v) = v.
      Proof using Type*.
        induction t; try destruct v; simpl in *; congruence.
      Qed.

      Lemma compilef_correct {t} (e : @exprf interp_flat_type t)
      : Syntax.interpf interp_op (compilef make_const e) = interpf interp_op e.
      Proof using Type*.
        induction e;
          repeat match goal with
                 | _ => reflexivity
                 | _ => progress unfold LetIn.Let_In
                 | _ => progress simpl in *
                 | _ => rewrite interpf_SmartVarf
                 | _ => rewrite SmartConst_correct
                 | _ => rewrite <- surjective_pairing
                 | _ => progress rewrite_hyp *
                 | [ |- context[let (x, y) := ?v in _] ]
                   => rewrite (surjective_pairing v); cbv beta iota
                 end.
      Qed.

      Lemma compile_flat_correct {T} (e : expr (Tflat T))
      : forall x, Syntax.interp interp_op (compile make_const e) x = interp interp_op e.
      Proof using Type*.
        intros []; simpl.
        let G := match goal with |- ?G => G end in
        let G := match (eval pattern T, e in G) with ?G _ _ => G end in
        refine match e in expr t return match t return expr t -> _ with
                                        | Tflat T => G T
                                        | _ => fun _ => True
                                        end e
               with
               | Return _ _ => _
               | Abs _ _ _ => I
               end; simpl.
        apply compilef_correct.
      Qed.

      Lemma Compile_flat_correct_flat {T} (e : Expr (Tflat T))
        : forall x, Syntax.Interp interp_op (Compile make_const e) x = Interp interp_op e.
      Proof using Type*. apply compile_flat_correct. Qed.

      Lemma Compile_correct {src dst} (e : @Expr (Arrow src (Tflat dst)))
      : forall x, Syntax.Interp interp_op (Compile make_const e) x = Interp interp_op e x.
      Proof using Type*.
        unfold Interp, Compile, Syntax.Interp; simpl.
        pose (e interp_flat_type) as E.
        repeat match goal with |- context[e ?f] => change (e f) with E end.
        clearbody E; clear e.
        let G := match goal with |- ?G => G end in
        let G := match (eval pattern src, dst, E in G) with ?G _ _ _ => G end in
        refine match E in expr t return match t return expr t -> _ with
                                        | Arrow src (Tflat dst) => G src dst
                                        | _ => fun _ => True
                                        end E
               with
               | Abs src dst e
                 => match dst
                          return (forall e : _ -> expr dst,
                                     match dst return expr (Arrow src dst) -> _ with
                                     | Tflat dst => G src dst
                                     | _ => fun _ => True
                                     end (Abs e))
                    with
                    | Tflat _
                      => fun e0 x
                         => _
                    | Arrow _ _ => fun _ => I
                    end e
               | Return _ _ => I
               end; simpl.
        refine match e0 x as e0x in expr t
                     return match t return expr t -> _ with
                            | Tflat _
                              => fun e0x
                                 => Syntax.interpf _ (invert_Abs (compile _ e0x) _)
                                    = interp _ e0x
                            | _ => fun _ => True
                            end e0x
               with
               | Abs _ _ _ => I
               | Return _ _ => _
               end; simpl.
        apply compilef_correct.
      Qed.
    End compile_correct.
  End expr_param.
End language.

Global Arguments Arrow {_} _ _.
Global Arguments Tflat {_} _.
Global Arguments Const {_ _ _ _ _} _.
Global Arguments Var {_ _ _ _ _} _.
Global Arguments Op {_ _ _ _ _ _} _ _.
Global Arguments LetIn {_ _ _ _ _} _ {_} _.
Global Arguments MatchPair {_ _ _ _ _ _} _ {_} _.
Global Arguments Fst {_ _ _ _ _ _} _.
Global Arguments Snd {_ _ _ _ _ _} _.
Global Arguments Pair {_ _ _ _ _} _ {_} _.
Global Arguments Return {_ _ _ _ _} _.
Global Arguments Abs {_ _ _ _ _ _} _.
Global Arguments Compile {_ _ _} make_const {t} _ _.


Require Import List.
Import ListNotations.

Require Export Map.
Require Export Shared.

Definition var := nat.
Definition id := nat.
Definition loc := nat.

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

Inductive ty : Type :=
  | TAct : ty
  | TBes : ty
  | TPas : ty
  | TArr : ty -> ty -> ty
  | TUnit: ty
.

Function is_active (t : ty) : bool :=
  match t with
    | TAct => true
    | TBes => true
    | _ => false
  end.

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

Inductive expr : Type :=
  | EVar : var -> expr
  | EApp : expr -> expr -> expr
  | ESend : expr -> var -> ty -> expr -> expr
  | EMut : expr -> expr
  | ENew : ty -> expr
  | EBes : expr -> expr
  | ELam : var -> ty -> expr -> expr
  | EUnit : expr
  | EId : id -> expr
  | ELoc : loc -> expr
  | EBId : loc -> id -> expr
.

Tactic Notation "expr_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "EVar"
  | Case_aux c "EApp"
  | Case_aux c "ESend"
  | Case_aux c "EMut"
  | Case_aux c "ENew"
  | Case_aux c "EBes"
  | Case_aux c "ELam"
  | Case_aux c "EUnit"
  | Case_aux c "EId"
  | Case_aux c "ELoc"
  | Case_aux c "EBId"
].

Inductive is_val : expr -> Prop :=
  | LamIsVal : forall x t e, is_val (ELam x t e)
  | UnitIsVal : is_val EUnit
  | IdIsVal : forall id, is_val (EId id)
  | LocIsVal : forall l, is_val (ELoc l)
  | BIdIsVal : forall l id, is_val (EBId l id)
.

Definition econtext := expr -> expr.

Definition ctx_appl (e' : _) : econtext := (fun e => EApp e e').
Hint Unfold ctx_appl.
Definition ctx_appr (v : _) : econtext := (fun e => EApp v e).
Hint Unfold ctx_appr.
Definition ctx_send (x : _) (ty : _) (e' : _): econtext := (fun e => ESend e x ty e').
Hint Unfold ctx_send.
Definition ctx_mut : econtext := (fun e => EMut e).
Hint Unfold ctx_mut.
Definition ctx_bes : econtext := (fun e => EBes e).
Hint Unfold ctx_bes.

Inductive is_econtext : econtext -> Prop :=
  | EC_AppL :
      forall e',
        is_econtext (ctx_appl e')
  | EC_AppR :
      forall v,
        is_val v ->
        is_econtext (ctx_appr v)
  | EC_Send :
      forall x t e,
        is_econtext (ctx_send x t e)
  | EC_Mut :
        is_econtext ctx_mut
  | EC_Bes :
        is_econtext ctx_bes
.

Fixpoint freeVars (e : expr) : list var :=
  match e with
    | EVar x => [x]
    | EApp e1 e2 => freeVars e1 ++ freeVars e2
    | ESend e1 x _ e2 => freeVars e1 ++ List.remove id_eq_dec x (freeVars e2)
    | EMut e' => freeVars e'
    | EBes e' => freeVars e'
    | ELam x _ e' => List.remove id_eq_dec x (freeVars e')
    | _ => []
  end.

Fixpoint freeLocs (e : expr) : list loc :=
  match e with
    | ELoc l => [l]
    | EApp e1 e2 => freeLocs e1 ++ freeLocs e2
    | ESend e1 x _ e2 => freeLocs e1 ++ freeLocs e2
    | EMut e' => freeLocs e'
    | EBes e' => freeLocs e'
    | ELam x _ e' => freeLocs e'
    | _ => []
  end.

Fixpoint freeIds (e : expr) : list id :=
  match e with
    | EId id => [id]
    | EApp e1 e2 => freeIds e1 ++ freeIds e2
    | ESend e1 x _ e2 => freeIds e1 ++ freeIds e2
    | EMut e' => freeIds e'
    | EBes e' => freeIds e'
    | ELam x _ e' => freeIds e'
    | _ => []
  end.

Fixpoint freeBIds (e : expr) : list (loc * id) :=
  match e with
    | EBId l id => [(l, id)]
    | EApp e1 e2 => freeBIds e1 ++ freeBIds e2
    | ESend e1 x _ e2 => freeBIds e1 ++ freeBIds e2
    | EMut e' => freeBIds e'
    | EBes e' => freeBIds e'
    | ELam x _ e' => freeBIds e'
    | _ => []
  end.

Fixpoint subst (x : var) (v : expr) (e : expr) : expr :=
  match e with
    | EVar y => if id_eq_dec x y then v else e
    | EApp e1 e2 => EApp (subst x v e1) (subst x v e2)
    | ESend e1 y t e2 =>
      ESend (subst x v e1) y t
            (if id_eq_dec x y
             then e2
             else subst x v e2)
    | EMut e' => EMut (subst x v e')
    | EBes e' => EBes (subst x v e')
    | ELam y t e' =>
      ELam y t
           (if id_eq_dec x y then
              e'
            else
              (subst x v e'))
    | _ => e
  end.

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

Inductive is_msg : expr -> Prop :=
  | LamIsMsg : forall x t e, is_msg (ELam x t e)
.

Definition actor := (loc * list loc * list expr * expr)%type.

Definition heap := list actor.

Definition heapExtend (H : heap) (a : actor) := snoc H a.

Definition heapLookup (H : heap) (id : id) :=
  nth_error H id.

Fixpoint heapUpdate (H : heap) (id : id) (a : actor) :=
  match H with
  | nil => nil
  | a' :: H' =>
    match id with
    | O    => a :: H'
    | S id' => a' :: (heapUpdate H' id' a)
    end
  end.

Definition LH (H : heap) (id : id) :=
  match heapLookup H id with
    | Some (_, L, _, _) => Some L
    | None => None
  end.

(*
--------------
Configuration
--------------
*)

Inductive actor_idle : actor -> Prop :=
  | ActorIdle : forall l L v, is_val v -> actor_idle (l, L, [], v)
.

Definition heap_done := Forall actor_idle.

Definition configuration := (heap * nat)%type.

Definition actor_done (cfg : configuration) (id : id) : Prop :=
  match cfg with
    | (h, _) => match heapLookup h id with
                  | Some a => actor_idle a
                  | None => False
                end
  end
.

Definition cfg_done (cfg : configuration) : Prop :=
  match cfg with
    | (h, _) => heap_done h
  end
.