Require Import Coq.Lists.List.
Require Import Poulet4.P4light.Syntax.Typed.
Require Import Poulet4.P4light.Syntax.Syntax.
Require Import Poulet4.P4light.Syntax.Value.
Require Import Poulet4.P4light.Semantics.Semantics.
Require Import ProD3.core.Coqlib.
Require Import ProD3.core.Hoare.
Require ProD3.core.AssertionLang.
Require Import ProD3.core.AssertionNotations.
Require Import ProD3.core.ConcreteHoare.
Require Import ProD3.core.Modifies.
Require Import ProD3.core.ExtPred.
Require Import ProD3.core.Result.
Require Import Hammer.Plugin.Hammer.

Section FuncSpec.

Context {tags_t: Type} {tags_t_inhabitant : Inhabitant tags_t}.
Notation Val := (@ValueBase bool).
Notation Sval := (@ValueBase (option bool)).
Notation Lval := ValueLvalue.

Notation ident := (String.string).
Notation path := (list ident).

Context `{target : @Target tags_t (@Expression tags_t)}.

(* A func spec contains two levels binders. A func spec is like
  WITH (p : path) ... ,
    PATH p
    MOD [...] [...]
    WITH (x : X) ... ,
      PRE ...
      POST ...
*)

Inductive func_spec_hoare : Type :=
  | fsh_base : arg_assertion -> arg_ret_assertion -> func_spec_hoare
  | fsh_bind {A} : (A -> func_spec_hoare) -> func_spec_hoare.

Record func_spec_aux : Type := mk_func_spec {
  func_spec_p : path;
  func_spec_body : func_spec_hoare;
  func_spec_mod_vars : option (list path); (* None means anything can be modified. *)
  func_spec_mod_exts : list path
}.

Inductive func_spec : Type :=
  | fs_base : func_spec_aux -> func_spec
  | fs_bind {A} : (A -> func_spec) -> func_spec.

Fixpoint fundef_satisfies_hoare (ge : genv) (p : path) (func : fundef) (targs : list (P4Type)) (fs : func_spec_hoare) :=
  match fs with
  | fsh_base pre post =>
       hoare_func ge p pre func targs post
  | @fsh_bind A fs =>
      (* How can we keep binder names? They are preserved when intro-ing them
        through our tactic. *)
      forall (x : A), fundef_satisfies_hoare ge p func targs (fs x)
  end.

Definition func_sound_aux (ge : genv) (func : fundef) (targs : list (P4Type)) (fs : func_spec_aux) :=
  let '(mk_func_spec p body vars exts) := fs in
  fundef_satisfies_hoare ge p func targs body
    /\ func_modifies ge p func vars exts.

Fixpoint func_sound (ge : genv) (func : fundef) (targs : list (P4Type)) (fs : func_spec) :=
  match fs with
  | fs_base fs =>
      func_sound_aux ge func targs fs
  | @fs_bind A fs =>
      (* How can we keep binder names? *)
      forall (x : A), func_sound ge func targs (fs x)
  end.

Definition path_eq_dec : forall (p p' : path), {p = p'} + {p <> p'}.
Proof.
  apply list_eq_dec, String.string_dec.
Defined.

Definition exclude {A} (mods : list path) (l : list (path * A)) :=
  filter (fun '(p, _) => negb (In_dec path_eq_dec p mods)) l.

Fixpoint disjoint (p1 p2 : path) : bool :=
  match p1 with
  | [] => false
  | n :: p1 =>
      match p2 with
      | [] => false
      | m :: p2 =>
          if String.eqb n m then disjoint p1 p2 else true
      end
  end.

(* This is an iff, but we only prove one direction. *)
Lemma disjoint_spec : forall p1 p2,
  disjoint p1 p2 ->
  forall q, negb (is_prefix p1 q && is_prefix p2 q).
Proof.
  induction p1 as [ | s1 p1]; destruct p2 as [ | s2 p2]; intros; inv H.
  destruct q as [ | t q].
  - auto.
  - simpl.
    destruct (String.eqb s1 s2) eqn:H_eqb_s1_s2;
      destruct (String.eqb s1 t) eqn:H_eqb_s1_t;
      destruct (String.eqb s2 t) eqn:H_eqb_s2_t;
      try auto.
    + hfcrush use: String.eqb_eq.
    + hfcrush use: String.eqb_eq.
    + hauto b: on.
Qed.

(* For symbolic paths, we cannot decide whether two paths are disjoint. So we define a weaker
  version: we use a tactic to generate a result for each test, which is either disjoint or
  unknown.
    We want to separate the decision procedure to test disjoint from the filter process,
  so we do not directly define a relation (list ext_pred -> list ext_pred -> Prop). *)

(* Test if modifying in the scopes of mods is disjoint from ep. *)
Definition ext_disjoint (mods : list path) (ep : ext_pred) :=
  forallb (fun q => forallb (disjoint q) ep.(ep_paths)) mods.

Fixpoint ext_exclude (mods : list path) (a_ext : list ext_pred)
    (rs : res_list (ext_disjoint mods) a_ext) : list ext_pred.
Proof.
  inversion rs as [ | ep eps].
  - exact nil.
  - exact (
      if r then ep :: ext_exclude mods eps rs0 else ext_exclude mods eps rs0).
Defined.

Definition hoare_func_frame (ge : genv) (p : path) (pre : arg_assertion) (func : @fundef tags_t) (targs : list P4Type) (post : assertion) :=
  forall st inargs st' outargs sig,
    pre inargs st ->
    exec_func ge read_ndetbit p st func targs inargs st' outargs sig ->
    post st'.

Lemma modifies_exts_disjoint : forall (ep : ext_pred) exts st st',
  modifies_exts exts st st' ->
  ep (snd st) ->
  ext_disjoint exts ep ->
  ep (snd st').
Proof.
  intros.
  eapply ep_wellformed; only 2 : eauto.
  intros; eapply H. clear H.
  induction exts.
  - auto.
  - simpl in H1. rewrite Reflect.andE in H1. destruct H1.
    assert (~(in_scope p a)). {
      remember (ep_paths ep) as ps.
      clear -H H2.
      induction ps.
      - auto.
      - simpl in H. rewrite Reflect.andE in H. destruct H.
        simpl in H2. rewrite Reflect.orE in H2. destruct H2.
        + pose proof disjoint_spec.
          hauto b: on.
        + auto.
    }
    assert (~(in_scopes p exts)). {
      auto.
    }
    clear -H3 H4.
    hauto b: on.
Qed.

Lemma hoare_func_frame_intro : forall ge p a_arg a_mem a_ext func targs vars exts ext_rs a_mem' a_ext',
  func_modifies_vars ge p func vars ->
  func_modifies_exts ge p func exts ->
  force (fun _ => []) (option_map exclude vars) a_mem = a_mem' ->
  ext_exclude exts a_ext ext_rs = a_ext' ->
  hoare_func_frame ge p (ARG a_arg (MEM a_mem (EXT a_ext))) func targs (MEM a_mem' (EXT a_ext')).
Proof.
  unfold func_modifies_vars, func_modifies_exts, hoare_func_frame; intros.
  destruct st; destruct st'.
  split.
  - clear -H H1 H3 H4.
    destruct vars as [vars | ].
    2 : { subst; constructor. }
    specialize (H _ _  _ _ _ _ H4).
    destruct H3 as [_ []].
    generalize dependent a_mem'.
    induction a_mem; intros.
    + subst. constructor.
    + simpl in H1. destruct a as [p' ?]. destruct (in_dec path_eq_dec p' vars) as [H_In | H_In].
      * subst; simpl. apply IHa_mem; auto.
        inv H0; auto.
      * subst; simpl. constructor.
        ++simpl in H; simpl.
          rewrite <- H by auto.
          inv H0; auto.
        ++apply IHa_mem; auto.
          inv H0; auto.
  - clear -H0 H2 H3 H4.
    generalize dependent a_ext'.
    specialize (H0 _ _  _ _ _ _ H4).
    destruct H3 as [_ []].
    induction ext_rs; intros.
    + subst. constructor.
    + simpl in H2. destruct r as [H_disjoint | _].
      * subst; split.
        ++eapply (modifies_exts_disjoint _ _ _ _ H0 (proj1 H1)).
          auto.
        ++apply IHext_rs.
        { apply H1. }
        { reflexivity. }
      * apply IHext_rs.
        { apply H1. }
        { apply H2. }
Qed.

Inductive func_post_combine : assertion -> arg_ret_assertion -> arg_ret_assertion -> Prop :=
  | func_post_combine_base : forall f_mem f_ext a_arg a_ret a_mem a_ext,
      func_post_combine
        (MEM f_mem (EXT f_ext))
        (ARG_RET a_arg a_ret (MEM a_mem (EXT a_ext)))
        (ARG_RET a_arg a_ret (MEM (f_mem ++ a_mem) (EXT (f_ext ++ a_ext))))
  | func_post_combine_ex : forall [A] F (P : A -> arg_ret_assertion) Q,
      (forall (x : A), func_post_combine F (P x) (Q x)) ->
      func_post_combine F (arg_ret_exists P) (arg_ret_exists Q).

Lemma func_post_combine_sound : forall outargs retv st F P Q,
  func_post_combine F P Q ->
  F st ->
  P outargs retv st ->
  Q outargs retv st.
Proof.
  intros. induction H.
  - destruct H1 as [? []].
    split; eauto.
    split; eauto.
    destruct st; split.
    + apply AssertionLang.mem_denote_app. sfirstorder.
    + apply AssertionLang.ext_denote_app. sfirstorder.
  - destruct H1.
    eexists; eauto.
Qed.

Lemma func_spec_combine : forall ge p pre pre' func targs post post' frame,
  arg_implies pre pre' ->
  hoare_func ge p pre' func targs post' ->
  hoare_func_frame ge p pre func targs frame ->
  func_post_combine frame post' post ->
  hoare_func ge p pre func targs post.
Proof.
  unfold hoare_func; intros.
  specialize (H _ _ H3).
  epose proof (H0 _ _ _ _ _ ltac:(eassumption) ltac:(eassumption)).
  destruct sig; only 1, 3, 4 : solve [inv H5].
  eapply (func_post_combine_sound _ _ _ _ _ _ H2); eauto.
Qed.

Lemma func_spec_combine' : forall ge p pre_arg pre_mem pre_ext pre_arg' pre_mem' pre_ext' func targs post vars exts ext_rs post' f_mem f_ext,
  fundef_satisfies_hoare ge p func targs
    (fsh_base (ARG pre_arg' (MEM pre_mem' (EXT pre_ext'))) post')
    /\ func_modifies ge p func vars exts ->
  arg_implies (ARG pre_arg (MEM pre_mem (EXT pre_ext))) (ARG pre_arg' (MEM pre_mem' (EXT pre_ext'))) ->
  force (fun _ => []) (option_map exclude vars) pre_mem = f_mem ->
  ext_exclude exts pre_ext ext_rs = f_ext ->
  func_post_combine (MEM f_mem (EXT f_ext)) post' post ->
  hoare_func ge p (ARG pre_arg (MEM pre_mem (EXT pre_ext))) func targs post.
Proof.
  intros.
  destruct H.
  eapply func_spec_combine; eauto.
  eapply hoare_func_frame_intro; eauto.
  - destruct vars.
    + unfold func_modifies_vars; simpl; intros.
      refine (proj1 (H4 _ _ _ _ _ _ _) _ _); eauto.
    + unfold func_modifies_vars; simpl; auto.
  - unfold func_modifies_exts, modifies_exts; intros.
    refine (proj2 (H4 _ _ _ _ _ _ _) _ _); eauto.
Qed.

End FuncSpec.

Declare Scope func_spec.
Delimit Scope func_spec with func_spec.
Declare Scope func_hoare.
Delimit Scope func_hoare with func_hoare.

Notation "'WITH' , P " :=
  (fs_base P%func_spec) (at level 65, right associativity) : func_spec.

Notation "'WITH' x .. y , P " :=
  (fs_bind (fun x => .. (fs_bind (fun y => fs_base P%func_spec)) ..)) (at level 65, x binder, y binder, right associativity) : func_spec.

Notation "'PATH' p 'MOD' vars exts body" :=
  (mk_func_spec p body%func_hoare vars exts) (at level 64, vars at level 0, exts at level 0) : func_spec.

Notation "'WITH' , 'PRE' pre 'POST' post" :=
  (fsh_base pre post) (at level 63, right associativity) : func_hoare.

Notation "'WITH' x .. y , 'PRE' pre 'POST' post" :=
  (fsh_bind (fun x => .. (fsh_bind (fun y => fsh_base pre post)) ..)) (at level 63, x binder, y binder, right associativity) : func_hoare.


(*! ORAAT | Proof of the One-rule-at-a-time theorem !*)
Require Import
        Koika.Common Koika.Syntax Koika.TypedSyntax
        Koika.TypedSyntaxFunctions Koika.SemanticProperties.
Require Import Coq.setoid_ring.Ring_theory Coq.setoid_ring.Ring Coq.setoid_ring.Ring.

Open Scope bool_scope.

Section Proof.
  Context {pos_t var_t fn_name_t rule_name_t reg_t ext_fn_t: Type}.
  Context {reg_t_eq_dec: EqDec reg_t}.

  Context {R: reg_t -> type}.
  Context {Sigma: ext_fn_t -> ExternalSignature}.
  Context {REnv: Env reg_t}.
  Context (r: REnv.(env_t) R).
  Context (sigma: forall f, Sig_denote (Sigma f)).

  Notation Log := (Log R REnv).
  Notation action := (action pos_t var_t fn_name_t R Sigma).
  Notation rule := (rule pos_t var_t fn_name_t R Sigma).
  Notation scheduler := (scheduler pos_t rule_name_t).

  Context (rules: rule_name_t -> rule).

  Fixpoint interp_scheduler'_trace
           (sched_log: Log)
           (s: scheduler)
           {struct s} :=
    let interp_try rl s1 s2 :=
        match interp_rule r sigma sched_log (rules rl) with
        | Some l => match interp_scheduler'_trace (log_app l sched_log) s1 with
                   | Some (rs, log) => Some (rl :: rs, log)
                   | None => None
                   end
        | None => interp_scheduler'_trace sched_log s2
        end in
    match s with
    | Done => Some ([], sched_log)
    | Cons rl s => interp_try rl s s
    | Try rl s1 s2 => interp_try rl s1 s2
    | SPos _ s => interp_scheduler'_trace sched_log s
    end.

  Definition interp_scheduler_trace_and_update
        l
        (s: scheduler) :=
    match interp_scheduler'_trace l s with
    | Some (rs, log) => Some (rs, commit_update r log)
    | None => None
    end.

  Definition interp_oraat r rl: REnv.(env_t) R :=
    interp_cycle sigma rules (Try rl Done Done) r.

  Ltac set_forallb_fns :=
    repeat match goal with
           | [  |- context[log_forallb _ _ ?fn] ] =>
             match fn with
             | (fun _ => _) => set fn
             end
           end.

  Lemma may_read_app_sl :
    forall (sl sl': Log) prt idx,
      may_read (log_app sl sl') prt idx =
      may_read sl prt idx && may_read sl' prt idx.
  Proof.
    unfold may_read; intros.
    destruct prt; rewrite !log_forallb_not_existsb, !log_forallb_app;
      ring_simplify; f_equal.
  Qed.

  Lemma may_write_app_sl :
    forall (sl sl': Log) l prt idx,
      may_write (log_app sl sl') l prt idx =
      may_write sl l prt idx && may_write sl' l prt idx.
  Proof.
    unfold may_write; intros.
    destruct prt; rewrite !log_forallb_not_existsb, !log_forallb_app;
      ring_simplify;
      repeat (destruct (log_forallb _ _ _); cbn; try reflexivity).
  Qed.

  Ltac bool_step :=
    match goal with
    | _ => progress Common.bool_step
    | [ H: log_forallb (log_app _ _) _ _ = _ |- _ ] =>
      rewrite log_forallb_app in H
    end.

  Lemma may_read0_no_writes :
    forall (sl: Log) idx,
      may_read sl P0 idx = true ->
      latest_write sl idx = None.
  Proof.
    unfold may_read; intros.
    rewrite !log_forallb_not_existsb in H.
    repeat (cleanup_step || bool_step).
    unfold log_forallb in *.
    rewrite forallb_forall in *.
    unfold is_write0, is_write1, latest_write, log_find in *.
    apply find_none_notb.
    intros a HIn.
    repeat match goal with
           | [ H: forall (_: LogEntry _), _ |- _ ] => specialize (H a HIn)
           end.
    destruct a; cbn in *; destruct kind; subst; try reflexivity.
    destruct port; cbn in *; try discriminate.
  Qed.

  Lemma may_read1_latest_write_is_0 :
    forall (l: Log) idx,
      may_read l P1 idx = true ->
      latest_write l idx = latest_write0 l idx.
  Proof.
    unfold may_read, latest_write, latest_write0, log_find, log_forallb.
    intros * H.
    rewrite log_forallb_not_existsb in H; unfold log_forallb in H.
    set (getenv REnv l idx) as ls in *; cbn in *; clearbody ls.
    set (R idx) as t in *; cbn in *.
    revert H.
    induction ls.
    - reflexivity.
    - intros * H; cbn in H.
      repeat (bool_step || cleanup_step).
      rewrite (IHls ltac:(eassumption)).
      unfold log_latest_write_fn; cbn.
      destruct a, kind, port; try discriminate; reflexivity.
  Qed.

  Create HintDb oraat.
  Hint Unfold interp_cycle : oraat.
  Hint Unfold interp_oraat : oraat.
  Hint Unfold interp_rule : oraat.

  Ltac t_step :=
    match goal with
    | _ => cleanup_step
    | _ => progress autounfold with oraat in *
    | [ H: context[may_read (log_app _ _) _ _] |- _ ] =>
      rewrite may_read_app_sl in H
    | [ H: context[may_write (log_app _ _) _ _ _] |- _ ] =>
      rewrite may_write_app_sl in H
    | [ H: Some _ = Some _ |- _ ] =>
      inversion H; subst; clear H
    | [ H: opt_bind ?x _ = Some _ |- _ ] =>
      destruct x eqn:?; cbn in H; try discriminate
    | [ H: match ?x with _ => _ end = Some _ |- _ ] =>
      destruct x eqn:?; subst; cbn in H; try discriminate
    | _ =>
      bool_step
    | [ H: match ?x with _ => _ end = ?c |- _ ] =>
      let c_hd := constr_hd c in
      is_constructor c_hd; destruct x eqn:?
    | [ H: ?x = _ |- context[match ?x with _ => _ end] ] =>
      rewrite H
    | [ H: context[_ -> _ = Some _] |- _ ] =>
      erewrite H by eauto
    | _ => reflexivity
    end.

  Ltac t :=
    repeat t_step.

  Lemma interp_action_commit:
    forall {sig tau} (a: action sig tau) (Gamma: tcontext sig) (sl sl': Log) action_log lv,
      interp_action r sigma Gamma (log_app sl sl') action_log a = Some lv ->
      interp_action (commit_update r sl') sigma Gamma sl action_log a = Some lv.
  Proof.
    fix IH 3; destruct a; cbn;
      intros Gamma sl sl' action_log lv HSome; try congruence.

    - (* Assign *) t.
    - (* Seq *) t.
    - (* Bind *) t.
    - (* If *) t.
    - destruct port; t.
      + (* Read0 *)
        erewrite getenv_commit_update by eassumption.
        erewrite may_read0_no_writes by eauto.
        reflexivity.
      + (* Read1 *)
        rewrite log_app_assoc.
        rewrite (latest_write0_app (log_app action_log sl) sl').
        destruct latest_write0.
        * reflexivity.
        * erewrite getenv_commit_update by eassumption.
          rewrite may_read1_latest_write_is_0 by eassumption.
          reflexivity.
    - (* Write *) t.
    - (* UnOp *) t.
    - (* BinOp *) t.
    - (* ExternalCall *) t.
    - (* InternalCall *)
      assert (let interp_action r sigma :=
                  @interp_action pos_t var_t fn_name_t reg_t ext_fn_t R Sigma REnv r sigma in
              forall argspec (args: acontext sig argspec) (Gamma: tcontext sig) (sl sl': Log) action_log lv,
                interp_args' (interp_action r sigma) Gamma (log_app sl sl') action_log args = Some lv ->
                interp_args' (interp_action (commit_update r sl') sigma) Gamma sl action_log args = Some lv).
      { clear -IH; intro.
        fix IHargs 2; destruct args; cbn;
          intros Gamma sl sl' action_log lv **.
        + t.
        + t. }
      t.
    - (* APos *) t.
  Qed.

  Lemma OneRuleAtATime':
    forall s rs r' l0,
      interp_scheduler_trace_and_update l0 s = Some (rs, r') ->
      List.fold_left interp_oraat rs (commit_update r l0) = r'.
  Proof.
    induction s; cbn;
      unfold interp_scheduler_trace_and_update; cbn.
    - (* Done *) inversion 1; subst; cbn in *; eauto.
    - (* Cons *) intros; t.
      + erewrite interp_action_commit by (rewrite log_app_empty_r; eassumption);
          cbn.
        rewrite log_app_empty_l.
        rewrite commit_update_assoc.
        eapply IHs.
        unfold interp_scheduler_trace_and_update.
        rewrite Heqo1; reflexivity.
      + eapply IHs.
        unfold interp_scheduler_trace_and_update; rewrite Heqo.
        reflexivity.
    - (* Try *) intros; t.
      + erewrite interp_action_commit by (rewrite log_app_empty_r; eassumption);
          cbn.
        rewrite log_app_empty_l.
        rewrite commit_update_assoc.
        eapply IHs1.
        unfold interp_scheduler_trace_and_update.
        rewrite Heqo1; reflexivity.
      + eapply IHs2.
        unfold interp_scheduler_trace_and_update; rewrite Heqo.
        reflexivity.
    - (* SPos *) eauto.
  Qed.

  Lemma interp_scheduler_trace_correct :
    forall s l0 log,
      interp_scheduler' r sigma rules l0 s = log ->
      exists rs, interp_scheduler'_trace l0 s = Some (rs, log).
  Proof.
    induction s; cbn.
    - (* Done *) inversion 1; subst; eauto.
    - (* Cons *) intros * Heq. destruct interp_rule as [log' | ] eqn:?.
      + destruct (IHs _ _ Heq) as (rs & Heq').
        rewrite Heq'; eauto.
      + destruct (IHs _ _ Heq) as (rs & Heq').
        rewrite Heq'; eauto.
    - (* Try *) intros * Heq. destruct interp_rule as [log' | ] eqn:?.
      + destruct (IHs1 _ _ Heq) as (rs & Heq').
        rewrite Heq'; eauto.
      + destruct (IHs2 _ _ Heq) as (rs & Heq').
        rewrite Heq'; eauto.
    - (* SPos *) eauto.
  Qed.

  Lemma scheduler_trace_in_scheduler :
    forall s log l0 rs,
      interp_scheduler'_trace l0 s = Some (rs, log) ->
      (forall r : rule_name_t, In r rs -> In r (scheduler_rules s)).
  Proof.
    induction s; cbn in *.
    - (* Done *) inversion 1; subst; inversion 1.
    - (* Cons *) intros * H * H'; t.
      + inversion H'; subst; eauto.
      + eauto.
    - (* Try *) intros * H * H'; rewrite in_app_iff; t.
      + inversion H'; subst; eauto.
      + eauto.
    - (* SPos *) eauto.
  Qed.

  Theorem OneRuleAtATime:
    forall s log,
      interp_scheduler r sigma rules s = log ->
      exists rs,
        (forall rl, List.In rl rs -> List.In rl (scheduler_rules s)) /\
        List.fold_left interp_oraat rs r = commit_update r log.
  Proof.
    intros * H.
    apply interp_scheduler_trace_correct in H; destruct H as (rs & H).
    exists rs; split.
    - eauto using scheduler_trace_in_scheduler.
    - rewrite <- (commit_update_empty r) at 1.
      eapply OneRuleAtATime'.
      unfold interp_scheduler_trace_and_update; rewrite H; reflexivity.
  Qed.
End Proof.


(** printing |-#    %\vdash_{\#}%    #⊢##     *)
(** printing |-##   %\vdash_{\#\#}%  #⊢&#35&#35#  *)
(** printing |-##v  %\vdash_{\#\#v}% #⊢&#35&#35v# *)
(** printing |-!    %\vdash_!%       #⊢!#         *)
(** remove printing ~ *)

Set Implicit Arguments.

Require Import TLC.LibLN.
Require Import String.
Require Import Coq.Program.Equality.

Require Import Definitions RecordAndInertTypes Decompose ConstrLangAlt ConstrInterp.
Require Import TightTyping GeneralToTight.
Require Import ConstrEntailment.
Require Import TightConstrInterp.

(** * Tight Entailment for Constraints *)

(** ** Definition of tight entailment *)
Definition constr_entail_t (C1 C2 : constr) :=
  forall tm vm G,
    inert G ->
    ok G ->
    (tm, vm, G) ⊧# C1 -> (tm, vm, G) ⊧# C2.

Notation "C '⊩#' D" := (constr_entail_t C D) (at level 50).

Ltac introe_t :=
  match goal with
  | |- _ => introv Hi Hok He
  end.

(** * Equivalence Theorems *)

Theorem tight_to_general_entailment : forall C1 C2,
    C1 ⊩# C2 -> C1 ⊩ C2.
Proof.
  introv Ht. introe.
  apply* tight_to_general_interp.
  apply* Ht.
  apply* general_to_tight_interp.
Qed.

Theorem general_to_tight_entailment : forall C1 C2,
    C1 ⊩ C2 -> C1 ⊩# C2.
Proof.
  introv Ht. introe.
  apply* general_to_tight_interp.
  apply* Ht.
  apply* tight_to_general_interp.
Qed.


(** STG in COQ by Maciej Piróg, University of Wrocław, 2010 *)

(** This library contains the definition of the explicit-environment
semantics and proof of its equivalence with the argument-accumulating
semantics. *)

Require Export Heaps.
Require Export Sem02.
Require Import Min.

(** * Explicit Environment Semantics *)

Reserved Notation "($ a $ b $ g $ e ↓↓↓ c $ d $ h $ f )"
  (at level 70, no associativity).

Inductive EES : heapB -> expr -> env -> vars -> heapB -> expr -> env ->
  vars -> Prop :=

| E_Con : forall Gamma C pi sigma,
  ($ Gamma $ Constr C pi $ sigma $ nil ↓↓↓ Gamma $ Constr C pi $ sigma $ nil)

| E_Accum : forall Gamma Delta x xm sigma_xm qn w rs sigma rho,
  xm <> nil ->
  env_map sigma xm = Some sigma_xm ->
  ($ Gamma $ App x nil $ sigma $ sigma_xm ++ qn ↓↓↓ Delta $ w $ rho $ rs) ->
  ($ Gamma $ App x xm  $ sigma $ qn             ↓↓↓ Delta $ w $ rho $ rs)

| E_App1 : forall Gamma p x pn m e sigma tau,
  env_find sigma x = Some (Atom p) ->
  Gamma p = Some (Lf_n m e, tau) ->
  m > length pn ->
  ($ Gamma $ App x nil $ sigma $ pn ↓↓↓ Gamma $ App x nil $ sigma $ pn)

| E_App2_5 : forall Gamma Delta m e x tau p pn w rs sigma rho,
  env_find sigma x = Some (Atom p) ->
  Gamma p = Some (Lf_n m e, tau) ->
  m <= length pn ->
  ($ Gamma $ e         $ zip_var_list m (firstn m pn) ++ shift m tau $ skipn m pn ↓↓↓ Delta $ w $ rho $ rs) ->
  ($ Gamma $ App x nil $ sigma                                       $ pn         ↓↓↓ Delta $ w $ rho $ rs)

| E_App4 : forall Gamma Delta sigma tau rho e p x C xs,
  env_find sigma x = Some (Atom p) ->
  Gamma p = Some (Lf_u e, tau) ->
  ($ Gamma $ e         $ tau   $ nil ↓↓↓ Delta                                            $ Constr C xs $ rho $ nil) ->
  ($ Gamma $ App x nil $ sigma $ nil ↓↓↓ setB Delta p (Lf_n 0 (Constr C xs), trim rho xs) $ Constr C xs $ rho $ nil)

| E_App5 : forall Gamma Delta Theta x p pn y q qk e f n w rs sigma rho nu
  mu tau,
  env_find sigma x = Some (Atom p) ->
  env_find rho y = Some (Atom q) ->
  Gamma p = Some (Lf_u e, tau) ->
  Delta q = Some (Lf_n n f, mu) ->
  length qk < n ->
  ($ Gamma $ e         $ tau   $ nil      ↓↓↓ Delta $ App y nil      $ rho $ qk) ->
  ($ setB Delta p (Lf_n (n - length qk) f, trim (zip_var_list (length qk) qk ++ shift (length qk) mu) (fv (Lf_n (n - length qk) f))) $
             App y nil $ rho   $ qk ++ pn ↓↓↓ Theta $ w              $ nu  $ rs) ->
  ($ Gamma $ App x nil $ sigma $ pn       ↓↓↓ Theta $ w              $ nu  $ rs)

| E_Let : forall Gamma Delta sigma rho lfs e w (ats : list nat) rs ss,
  length ats = length lfs ->
  (forall a : nat, In a ats -> Gamma a = None) ->
  ($ allocB Gamma ats
      (map (fun lf => (lf, trim (zip_var_list (length lfs) (map Atom ats) ++ shift (length lfs) sigma) (fv lf))) lfs)
    $ e $ zip_var_list (length lfs) (map Atom ats) ++ shift (length lfs) sigma $ rs
    ↓↓↓ Delta $ w $ rho $ ss) ->
  ($ Gamma $ Letrec lfs e $ sigma $ rs ↓↓↓ Delta $ w $ rho $ ss)

| E_Case_of : forall Gamma Delta Theta b e e0 als ys w c c0 rho_ys rs qs
  sigma rho nu,
  length ys = b ->
  env_map rho ys = Some rho_ys ->
  select_case als c = Some (Alt c0 b e0) ->
  ($ Gamma $ e          $ sigma                                  $ nil ↓↓↓ Delta $ Constr c ys $ rho $ nil) ->
  ($ Delta $ e0         $ zip_var_list b rho_ys ++ shift b sigma $ qs  ↓↓↓ Theta $ w           $ nu $ rs) ->
  ($ Gamma $ Case e als $ sigma                                  $ qs  ↓↓↓ Theta $ w           $ nu $ rs)

where "($ a $ b $ g $ e ↓↓↓ c $ d $ h $ f )" := (EES a b g e c d h f).

Hint Constructors EES.

(** * [heapB_ok] *)

Definition heapB_ok (hb : heapB) : Prop :=
(forall n lf tau, hb n = Some (lf, tau) -> no_atoms_lf lf) /\
(forall n lf tau, hb n = Some (lf, tau) ->
  closed_by_lf (assoc_keys tau) 0 lf).

Lemma empty_ok:
heapB_ok emptyB.
Proof.
unfold heapB_ok.
split; isa;
unfold emptyB in *; discriminate.
Qed.

(** * Properties of the semantics *)

Lemma no_atoms_EES_no_atoms_aux:
forall Xi a beta Ps Omega c xi Qs,
  ($ Xi $ a $ beta $ Ps ↓↓↓ Omega $ c $ xi $ Qs) ->
  no_atoms a ->
  (forall n lf tau, Xi n = Some (lf, tau) -> no_atoms_lf lf) ->
  no_atoms c /\
  (forall n lf tau, Omega n = Some (lf, tau) -> no_atoms_lf lf).
Proof with isa; eauto.
isa.
induction H...
(* [6] Case *)
apply IHEES...
constructor...
inversion H0.
trivial.
constructor...
contradiction.
(* [5] Case *)
apply IHEES...
assert (no_atoms_lf (Lf_n m e))...
inversion_clear H5...
(* [4] Case *)
split...
apply IHEES...
assert (no_atoms_lf (Lf_u e))...
inversion_clear H4...
unfold setB in H4.
destruct eq_nat_dec.
subst.
inversion_clear H4.
constructor.
apply IHEES...
assert (no_atoms_lf (Lf_u e))...
inversion_clear H4...
assert (no_atoms_lf (Lf_u e))...
inversion_clear H5...
apply IHEES in H6...
destruct H6...
(* [3] Case *)
apply IHEES2...
assert (no_atoms_lf (Lf_u e))...
inversion_clear H8...
apply IHEES1...
unfold setB in H8.
assert (no_atoms_lf (Lf_u e))...
inversion_clear H9.
destruct eq_nat_dec.
subst.
inversion_clear H8.
assert (no_atoms_lf (Lf_n n f)).
  apply IHEES1 in H10...
  destruct H10...
inversion_clear H8.
constructor...
apply IHEES1 in H10;
  [destruct H10; eapply H10 | eapply H1 ]...
(* [2] Case *)
inversion H0; subst.
apply IHEES...
destruct (In_dec eq_nat_dec n ats).
apply allocB_in in H4...
eapply in_map_iff in H4.
destruct H4.
destruct H4.
inversion H4; subst...
rewrite map_length...
rewrite allocB_nin in H4...
(* [1] Case *)
inversion H0; subst.
apply IHEES2...
apply In_select_case in H3.
apply H9 in H3.
inversion H3; subst...
apply IHEES1 in H8...
destruct H8...
Qed.

Lemma no_atoms_EES_no_atoms :
forall Xi a beta Ps Omega c xi Qs,
  ($ Xi $ a $ beta $ Ps ↓↓↓ Omega $ c $ xi $ Qs) ->
  no_atoms a ->
  (forall n lf tau, Xi n = Some (lf, tau) -> no_atoms_lf lf) ->
  no_atoms c.
Proof with eauto.
intros.
eapply no_atoms_EES_no_atoms_aux in H1...
destruct H1...
Qed.

(** * [only_atoms] restriction *)

Definition oa_heap (hb : heapB) :=
forall v lf tau, hb v = Some (lf, tau) ->
  forall n a, In (n, a) tau -> is_atom a.

Definition oa_env (e : env) :=
forall n a, In (n, a) e -> is_atom a.

Definition oa_accum (vs : vars) :=
are_atoms vs.

Inductive only_atoms (hb : heapB) (e : env) (vs : vars) : Prop :=
| oa_c : oa_heap hb -> oa_env e -> oa_accum vs -> only_atoms hb e vs.

Ltac oa_inversion OA :=
case OA;
  let  a := fresh "OA_ACCUM"
  with b := fresh "OA_ENV"
  with c := fresh "OA_HEAP"
  in intros c b a.

Lemma oa_env_map :
forall sigma xm sigma_xm,
  oa_env sigma ->
  env_map sigma xm = Some sigma_xm ->
  oa_accum sigma_xm.
Proof with isa; try discriminate.
isa.
revert sigma_xm H0.
induction xm...
(* nil *)
inversion H0...
unfold oa_accum...
apply atoms_nil.
(* cons *)
destruct a...
assert (exists s, env_map sigma xm = Some s).
  remember_destruct (env_map sigma xm).
  exists v...
  rewrite <- X in H0...
destruct H1.
rewrite H1 in *.
assert (exists p, find_assoc sigma n = Some p).
  remember_destruct (find_assoc sigma n).
  exists v...
  rewrite <- X in H0...
destruct H2.
rewrite H2 in *.
inversion H0.
assert (oa_accum x).
  apply IHxm...
apply find_assoc_in in H2.
unfold oa_env in H.
unfold oa_accum.
unfold are_atoms...
destruct H5.
subst.
eapply H; eauto.
unfold oa_accum in H3.
unfold are_atoms in H3.
apply H3...
Qed.

Create HintDb oa.

Lemma oa_accum_app :
forall vs ws,
  oa_accum vs ->
  oa_accum ws ->
  oa_accum (vs ++ ws).
Proof.
intros.
unfold oa_accum in *.
apply atoms_app; auto.
Qed.

Lemma oa_env_app :
forall sigma tau,
  oa_env sigma ->
  oa_env tau ->
  oa_env (sigma ++ tau).
Proof with intros; eauto.
intros.
unfold oa_env in *...
apply in_app_or in H1.
destruct H1...
Qed.

Lemma oa_env_shift :
forall m tau,
  oa_env tau -> oa_env (shift m tau).
Proof with intros; eauto.
intros.
unfold oa_env in *...
apply In_shift in H0...
Qed.

Lemma oa_heap_val :
forall Gamma p lf tau,
  Gamma p = Some (lf, tau) ->
  oa_heap Gamma ->
  oa_env tau.
Proof with eauto.
intros.
unfold oa_heap in H0.
unfold oa_env...
Qed.

Lemma oa_accum_nil :
oa_accum nil.
Proof.
unfold oa_accum.
unfold are_atoms.
intros.
inversion H.
Qed.

Lemma oa_accum_skipn :
forall ps n,
  oa_accum ps ->
  oa_accum (skipn n ps).
Proof with isa.
intros.
unfold oa_accum in *.
apply atoms_skipn...
Qed.

Hint Resolve
  atoms_skipn     In_zip_var_list
  oa_env_map      oa_accum_app
  oa_env_app      oa_env_shift
  oa_heap_val     oa_accum_nil
  oa_accum_skipn
: oa.

Lemma oa_empty:
oa_heap emptyB.
Proof.
unfold oa_heap.
unfold emptyB.
intros; discriminate.
Qed.

Lemma oa_empty_nil_nil:
only_atoms emptyB nil nil.
Proof.
constructor.
apply oa_empty.
unfold oa_env; intros; inversion H.
auto with oa.
Qed.

Lemma oa_accum_map_subst_var :
forall beta x xs,
  closed_by_expr (assoc_keys beta) 0 (App x xs) ->
  oa_env beta ->
  oa_accum (map (subst_var beta) xs).
Proof with auto with oa.
intros.
induction xs...
simpl.
inversion H; subst.
unfold oa_accum.
inversion H4.
unfold are_atoms.
intros.
destruct (eq_var_dec a0 (subst_var beta a)).
(* eq *)
subst.
elim H1 with (v := a); isa...
apply find_assoc_in_keys_ex_value in H5.
destruct H5.
rewrite <- plus_n_O.
rewrite H5.
apply find_assoc_in in H5.
unfold oa_env in H0.
eapply H0; eauto.
inversion H5.
(* neq *)
inversion H2...
  (* case *)
destruct n...
  (* case *)
fold (In a0 (map (subst_var beta) xs)) in H5.
assert (closed_by_expr (assoc_keys beta) 0 (App x xs)).
  constructor...
  constructor.
  intros.
  apply H1...
  right...
apply IHxs in H6...
Qed.

Lemma oa_setB :
forall Delta a lf mu,
  oa_env mu ->
  oa_heap Delta ->
  oa_heap (setB Delta a (lf, mu)).
Proof with eauto with oa.
intros.
unfold oa_heap in *.
intros.
unfold setB in H1.
destruct eq_nat_dec...
inversion H1; subst...
Qed.

Lemma oa_env_zip_var_list :
forall qk n,
  oa_accum qk ->
  oa_env (zip_var_list n qk).
Proof with eisa; auto with oa.
intros.
unfold oa_env...
unfold oa_accum in H.
unfold are_atoms in H.
apply H.
eapply In_zip_var_list...
Qed.

Hint Resolve oa_setB oa_env_zip_var_list : oa.

Lemma oa_env_trim :
forall beta xs,
  oa_env beta ->
  oa_env (trim beta xs).
Proof with eisa.
intros.
unfold trim.
unfold oa_env in *...
apply filter_In in H0.
destruct H0...
Qed.

Hint Resolve oa_env_trim : oa.

Lemma trim_app_distr :
forall beta tau vs,
  trim (beta ++ tau) vs = trim beta vs ++ trim tau vs.
Proof with isa.
induction beta...
destruct a.
destruct In_dec...
f_equal...
Qed.

Lemma In_trim :
forall beta n a vs,
  In (n, a) (trim beta vs) ->
  In (n, a) beta.
Proof with isa.
intros.
unfold trim in *.
apply filter_In in H.
destruct H...
Qed.

Lemma only_atoms_EES_only_atoms :
forall Xi a beta Ps Omega c xi Qs,
  ($ Xi $ a $ beta $ Ps ↓↓↓ Omega $ c $ xi $ Qs) ->
  forall (OA : only_atoms Xi beta Ps),
  only_atoms Omega xi Qs.
Proof with eauto with oa.
intros.
oa_inversion OA.
induction H.
(* [8] *)
constructor...
(* [7] *)
apply IHEES...
constructor...
(* [6] *)
constructor...
(* [5] *)
apply IHEES...
constructor...
apply oa_env_app...
unfold oa_env.
intros.
apply In_zip_var_list in H3.
apply In_firstn in H3...
unfold oa_accum...
apply oa_env_app...
unfold oa_env.
intros.
apply In_zip_var_list in H3.
apply In_firstn in H3...
unfold oa_accum...
(* [4] *)
elim IHEES...
constructor...
constructor...
(* [3] *)
elim IHEES1; isa...
apply IHEES2...
constructor...
apply oa_setB...
apply oa_env_trim...
apply oa_setB...
apply oa_env_trim...
constructor...
(* [2] *)
assert (oa_heap
          (allocB Gamma ats
             (map
                (fun lf : lambda_form =>
                 (lf, trim
                 (zip_var_list (length lfs) (map Atom ats) ++
                 shift (length lfs) sigma) (fv lf))) lfs))).
  unfold oa_heap.
  isa.
  destruct (In_dec eq_nat_dec v ats)...
    (* in *)
  apply allocB_in in H2...
  eapply in_map_iff in H2.
  destruct H2.
  destruct H2.
  inversion H2; subst; clear H2...
  rewrite trim_app_distr in H3.
  apply in_app_or in H3.
  destruct H3.
  apply In_trim in H2.
  apply In_zip_var_list in H2.
  apply in_map_iff in H2.
  do 2 destruct H2.
  destruct a.
  discriminate.
  simpl...
  apply In_trim in H2.
  apply oa_env_shift with (m := length lfs) in OA_ENV.
  unfold oa_env in OA_ENV...
  rewrite map_length...
    (* not in *)
  rewrite allocB_nin in H2...
assert (oa_env
          (zip_var_list (length lfs) (map Atom ats) ++
           shift (length lfs) sigma)).
  apply oa_env_app...
  apply oa_env_zip_var_list.
  unfold oa_accum.
  apply atoms_map_atom.
assert (oa_accum rs)...
apply IHEES...
constructor...
(* [1] *)
elim IHEES1; isa...
apply IHEES2...
constructor...
constructor...
Qed.

Lemma subst_var_no_index :
forall sigma n,
  oa_env sigma ->
  is_atom (subst_var sigma (Index n)) \/
  subst_var sigma (Index n) = Index n.
Proof with eisa.
intros.
destruct (In_dec eq_nat_dec n (assoc_keys sigma)).
(* in *)
left.
unfold subst_var.
apply find_assoc_in_keys_ex_value in i.
destruct i.
rewrite H0.
apply find_assoc_in in H0.
unfold oa_env in H.
eapply H...
(* not in *)
right.
apply find_assoc_notin in n0.
unfold subst_var.
rewrite n0...
Qed.

Lemma subst_lemma :
forall e m tau pn,
  oa_env tau ->
  m >= length pn ->
  (e ~ [shift m tau]) ~ [zip_var_list m pn] =
  e ~ [zip_var_list m pn ++ shift m tau].
Proof with isa.
intros.
unfold subst.
rewrite map_expr_compose.
f_equal.
apply functional_extensionality.
intro v.
unfold compose.
destruct v.
(* Index *)
destruct (le_lt_dec m n).
  (* <= *)
rewrite subst_var_app_shift_ge; auto.
apply oa_env_shift with (m := m) in H.
apply subst_var_no_index with (n := n) in H.
destruct H.
   (* left *)
to_atom (subst_var (shift m tau) (Index n)).
apply subst_var_atom.
   (* right *)
rewrite H.
cutrewrite (zip_var_list m pn = zip_var_list m pn ++ shift m nil).
apply subst_var_app_shift_ge with (tau := shift 0 nil)...
simpl.
apply app_nil_end.
  (* > *)
rewrite shift_lt_subst_var_id; try auto.
rewrite subst_var_app_shift_lt...
(* Atom *)
unfold compose.
do 3 rewrite subst_var_atom...
Qed.

Lemma apply_with_offset_shift :
forall m n v beta,
  oa_env beta ->
  apply_with_offset (subst_var beta) (m + n) v =
  apply_with_offset (subst_var (shift m beta)) n v.
Proof with eisa.
intros.
unfold apply_with_offset.
destruct v...
destruct le_lt_dec.
unfold plus_offset.
unfold subst_var.
unfold minus_offset.
cutrewrite (n0 - (m + n) = n0 - n - m); try omega.
rewrite find_assoc_shift.
remember (find_assoc (shift m beta) (n0 - n)) as F.
assert (forall v, F = Some v -> is_atom v).
  intros.
  symmetry in HeqF.
  subst.
  apply find_assoc_in in H0.
  apply oa_env_shift with (m := m) in H.
  unfold oa_env in H...
remember_destruct F.
assert (is_atom v)...
destruct v; try contradiction...
destruct le_lt_dec.
f_equal.
assert (n < n).
  omega.
apply n_lt_n_false in H2; contradiction.
destruct le_lt_dec; f_equal; omega...
omega.
destruct le_lt_dec...
assert (n0 - n < m).
  omega.
rewrite find_assoc_shift_lt; try omega...
f_equal.
omega.
Qed.

Lemma map_expr_shift :
forall beta e m n,
  oa_env beta ->
  map_expr (subst_var beta) (m + n) e =
  map_expr (subst_var (shift m beta)) n e.
Proof with isa.
intro beta.
induction e using expr_ind2 with
    (P1 := fun (lf : lambda_form) => forall m n,
      oa_env beta ->
      map_lf (subst_var beta) (m + n) lf =
      map_lf (subst_var (shift m beta)) n lf)
    (P2 := fun (al : alt) => forall m n,
      oa_env beta ->
      map_alt (subst_var beta) (m + n) al =
      map_alt (subst_var (shift m beta)) n al);
  intros; try unfold subst; simpl; try f_equal;
  try rewrite <- plus_assoc; isa;
  try apply map_ext_in; isa;
  try apply map_ext; isa;
  try apply apply_with_offset_shift...
Qed.

Lemma subst_shift :
forall beta m e,
  oa_env beta ->
  map_expr (subst_var beta) m e = e~[shift m beta].
Proof with isa.
intros.
assert (m = m + 0); try omega.
rewrite H0 at 1.
apply map_expr_shift...
Qed.

Lemma alloc_similar_no_trim :
forall (lfsF : defs) atsF beta
(LENGTHF : length lfsF = length atsF)
ats XiP Gamma lfs pi0 pi1 b0 b1 e tau etau a
(SIMILAR : similar Gamma XiP)
(LENGTH : length ats = length lfs)
(OA_ENV : oa_env beta)
(B : allocB XiP ats
       (map
          (fun lf : lambda_form =>
           (lf,
           zip_var_list (length lfsF) (map Atom atsF) ++
           shift (length lfsF) beta)) lfs) a = Some (Lf pi1 b1 e, tau))
(A : allocA Gamma (map Atom ats)
       (map (subst_lf (zip_var_list (length lfsF) (map Atom atsF)))
          (map (map_lf (subst_var beta) (length lfsF)) lfs)) (Atom a) =
     Some (Lf pi0 b0 etau)),
pi0 = pi1 /\ b0 = b1 /\ etau = e~[shift b1 tau].
Proof with eisa.
induction ats.
(* [2] nil *)
isa.
destruct lfs; simpl in *; try discriminate...
unfold allocA in A...
unfold allocB in B...
destruct SIMILAR.
destruct H0...
(* [1] cons *)
isa.
destruct lfs; simpl in *; try discriminate...
unfold allocA in A...
unfold allocB in B...
destruct (eq_nat_dec a a0); try subst a0...
  (* eq *)
unfold setA in A.
unfold setB in B.
destruct eq_var_dec; try tauto...
destruct eq_nat_dec; try tauto...
destruct l.
inversion A; subst.
inversion B; subst.
split...
split...
rewrite subst_shift.
rewrite subst_shift...
rewrite shift_app_distr.
rewrite shift_zip_var_list; try (rewrite map_length; omega).
rewrite shift_cummulative.
rewrite plus_comm.
apply subst_lemma; try (rewrite map_length; omega)...
unfold oa_env...
apply In_zip_var_list in H.
apply in_map_iff in H.
do 2 destruct H.
subst.
unfold is_atom...
  (* neq *)
unfold allocA in IHats.
unfold allocB in IHats.
unfold setA in *.
unfold setB in *.
assert (a0 <> a); auto.
destruct eq_var_dec; try tauto...
destruct eq_nat_dec; try tauto...
inversion e0; tauto.
destruct eq_nat_dec; try tauto...
Qed.

Lemma trim_fv :
forall e b k atsF pi beta
  (OA : oa_env beta),
  k >= length atsF ->
  e~[shift b (trim
      (zip_var_list k (map Atom atsF) ++
       shift k beta) (fv (Lf pi b e)))] =
  e~[shift b (zip_var_list k (map Atom atsF) ++
       shift k beta)].
Proof with isa.
intros.
assert (map_lf (subst_var (zip_var_list k (map Atom atsF) ++
    shift k beta)) 0 (Lf pi b e) =
    map_lf (subst_var (trim (zip_var_list k (map Atom atsF) ++
    shift k beta) (fv (Lf pi b e)))) 0 (Lf pi b e)).
  apply trim_fv_lf.
assert (OA2 : oa_env (zip_var_list k (map Atom atsF) ++ shift k beta)).
  apply oa_env_app.
  unfold oa_env...
  apply In_zip_var_list in H1.
  apply in_map_iff in H1.
  destruct H1.
  destruct H1.
  subst...
  apply oa_env_shift...
simpl in H0.
inversion H0; subst.
unfold subst.
assert (H1 : b = b + 0); auto with arith.
rewrite H1 in H2 at 1 3.
rewrite map_expr_shift in H2...
rewrite map_expr_shift in H2.
symmetry in H2...
apply oa_env_trim...
Qed.

(** * Completeness *)

Lemma alloc_similar :
forall (lfsF : defs) atsF beta
(LENGTHF : length lfsF = length atsF)
ats XiP Gamma lfs pi0 pi1 b0 b1 e tau etau a
(SIMILAR : similar Gamma XiP)
(LENGTH : length ats = length lfs)
(OA_ENV : oa_env beta)
(B : allocB XiP ats
       (map
          (fun lf : lambda_form =>
           (lf, trim
             (zip_var_list (length lfsF) (map Atom atsF) ++
             shift (length lfsF) beta) (fv lf))) lfs) a =
           Some (Lf pi1 b1 e, tau))
(A : allocA Gamma (map Atom ats)
       (map (subst_lf (zip_var_list (length lfsF) (map Atom atsF)))
          (map (map_lf (subst_var beta) (length lfsF)) lfs)) (Atom a) =
     Some (Lf pi0 b0 etau)),
pi0 = pi1 /\ b0 = b1 /\ etau = e~[shift b1 tau].
Proof with eisa.
induction ats...
(* [2] nil *)
destruct lfs; simpl in *; try discriminate...
unfold allocA in A...
unfold allocB in B...
destruct SIMILAR.
destruct H0...
(* [1] cons *)
destruct lfs; simpl in *; try discriminate...
unfold allocA in A...
unfold allocB in B...
destruct (eq_nat_dec a a0); try subst a0...
  (* eq *)
unfold setA in A.
unfold setB in B.
destruct eq_var_dec; try tauto...
destruct eq_nat_dec; try tauto...
destruct l.
inversion A; subst.
inversion B; subst.
split...
split...
rewrite trim_fv; try omega...
rewrite subst_shift.
rewrite subst_shift...
rewrite shift_app_distr.
rewrite shift_zip_var_list; try (rewrite map_length; omega).
rewrite shift_cummulative.
rewrite plus_comm.
apply subst_lemma; try (rewrite map_length; omega)...
unfold oa_env...
apply In_zip_var_list in H.
apply in_map_iff in H.
destruct H.
destruct H.
subst.
unfold is_atom...
  (* neq *)
unfold allocA in IHats.
unfold allocB in IHats.
unfold setA in *.
unfold setB in *.
assert (a0 <> a); auto.
destruct eq_var_dec; try tauto...
destruct eq_nat_dec; try tauto...
inversion e0; tauto.
destruct eq_nat_dec; try tauto...
Qed.

Lemma select_case_subst :
forall als als0 c c0 b e beta
  (OA : oa_env beta),
  select_case als c = Some (Alt c0 b e) ->
  als = map (map_alt (subst_var beta) 0) als0 ->
  exists e0,
  select_case als0 c = Some (Alt c0 b e0) /\
  e = e0~[shift b beta].
Proof with isa.
induction als...
discriminate.
destruct als0...
discriminate.
destruct a.
destruct a0.
destruct eq_nat_dec.
(* c = c1 *)
inversion H0; subst.
inversion H; subst; clear H.
destruct eq_nat_dec; try tauto.
clear e.
exists e1.
split...
apply subst_shift...
(* c <> c1 *)
inversion H0; subst.
destruct eq_nat_dec; subst...
tauto.
Qed.

Lemma lf_subst_lemma :
forall ats lfs sigma,
  oa_env sigma ->
  length lfs = length ats ->
  map (subst_lf (zip_var_list (length lfs) (map Atom ats) ++
    shift (length lfs) sigma)) lfs =
  map (subst_lf (zip_var_list (length lfs) (map Atom ats)))
       (map (map_lf (subst_var sigma) (length lfs)) lfs).
Proof with isa.
intros.
rewrite map_map.
apply map_ext_in...
destruct a.
unfold subst_lf...
f_equal...
rewrite subst_shift.
cutrewrite (b = b + 0)...
rewrite map_expr_shift...
rewrite map_expr_shift...
rewrite map_expr_shift...
simpl_arith.
rewrite shift_app_distr.
rewrite shift_cummulative.
rewrite shift_zip_var_list.
rewrite plus_comm at 1.
rewrite <- subst_lemma.
unfold subst.
cutrewrite (b + length lfs = length lfs + b)...
(* premises *)
omega.
trivial.
rewrite map_length; omega.
rewrite map_length; omega.
auto with oa.
apply oa_env_zip_var_list.
unfold oa_accum.
apply atoms_map_atom...
apply oa_env_app; auto with oa.
apply oa_env_zip_var_list.
unfold oa_accum.
apply atoms_map_atom...
Qed.

Lemma select_case_subst_right :
forall als c c0 b e beta
  (OA : oa_env beta),
  select_case als c = Some (Alt c0 b e) ->
  select_case (map (map_alt (subst_var beta) 0) als) c =
    Some (Alt c0 b (e~[shift b beta])).
Proof with isa.
induction als...
discriminate.
destruct a...
destruct eq_nat_dec...
inversion_clear H.
f_equal...
f_equal...
apply subst_shift...
Qed.

Lemma oa_accum_map :
forall vs,
  oa_accum vs ->
  exists ns, vs = map Atom ns.
Proof with isa.
intros.
induction vs.
(* nil *)
exists nil...
(* cons *)
unfold oa_accum in *.
dupl H.
apply atoms_head in H.
to_atom a.
apply atoms_tail in H0.
intuition.
destruct H1.
exists (a :: x)...
f_equal...
Qed.

Proposition EES_complete :
forall Xi Omega abeta Ps Qs cxi,
    ($ Xi $ abeta $ Ps ↓↓ Omega $ cxi $ Qs) ->
    forall a beta,
    closed_by_expr (assoc_keys beta) 0 a ->
    abeta = a~[beta] ->
    no_atoms a ->
  forall XiP, similar Xi XiP -> heapB_ok XiP ->
  forall (ONLYATOMS : only_atoms XiP beta Ps),
  exists OmegaP, exists xi, exists c,
    similar Omega OmegaP /\
    ($ XiP $ a $ beta $ Ps ↓↓↓ OmegaP $ c $ xi $ Qs) /\
    closed_by_expr (assoc_keys xi) 0 c /\
    cxi = c~[xi] /\
    heapB_ok OmegaP.
Proof with isa.
intros ? ? ebeta ? ? ? H.
dupl H. rename H0 into CASE.
induction H; intros a beta CBY EQe NOATOMS...
(* [8] Case Con *)
subst_inversion EQe.
exists XiP.
exists beta.
exists (Constr C vs)...
(* [7] Case Accum *)
subst_inversion EQe.
apply IHAAS with (XiP := XiP) (beta := beta) (a := App x nil) in H0...
  (* thesis *)
destruct H0 as [x0 [x1 [ x2 []]]].
destruct H3.
destruct H6.
destruct H7.
exists x0.
exists x1.
exists x2.
    (* similar *)
split...
    (* reduction *)
split.
eapply E_Accum with (sigma_xm := map (subst_var beta) xs).
      (* xs <> nil *)
eapply map_neq_nil; eauto.
      (* env_map *)
inversion_clear CBY.
apply env_map_map_subst...
inversion_clear NOATOMS...
      (* premise *)
rewrite H5 in H3.
apply H3.
    (* closed, subst and heap_ok*)
auto.
  (* premises of the IH *)
    (* closed_by_expr *)
inversion_clear CBY.
constructor...
constructor...
contradiction.
    (* subst *)
unfold subst; subst...
rewrite apply_with_offset_0_v...
    (* no_atoms *)
inversion_clear NOATOMS.
constructor...
constructor; isa; contradiction.
    (* only_atoms *)
oa_inversion ONLYATOMS.
constructor; auto with oa.
apply oa_accum_app...
subst; apply oa_accum_map_subst_var with (x := x)...
(* [6] Case App1 *)
subst_inversion EQe.
destruct xs; [ | discriminate ]...
exists XiP.
exists beta.
exists (App x nil).
  (* similar *)
split...
  (* reduction *)
split...
dupl H.
apply similar_dom_atom with (GammaP := XiP) in H3...
destruct p; try contradiction...
similar_value H XiP.
apply E_App1 with (p := a) (m := m) (e := x0) (tau := x1)...
    (* env_find *)
apply subst_var_env_find...
inversion NOATOMS...
  (* closed *)
split...
  (* subst *)
split.
unfold subst; subst...
rewrite apply_with_offset_0_v...
  (* heap_ok *)
auto.
(* [5] Case App2_5 *)
subst_inversion EQe.
dupl H.
apply similar_dom_atom with (GammaP := XiP) in H4...
destruct p; try contradiction...
similar_value H XiP.
rename e into etau.
rename x1 into tau.
rename x0 into e.
apply IHAAS with (XiP := XiP) (a := e)
  (beta := zip_var_list m (firstn m pn) ++ shift m tau) in H1...
  (* thesis *)
clear IHAAS.
destruct H1 as [x0 [x1 [x2 []]]].
destruct H8.
exists x0.
exists x1.
exists x2.
    (* similar *)
split...
    (* reduction *)
split.
destruct xs; [ | discriminate ]...
eapply E_App2_5 with (sigma := beta) (x := x) (p := a) in H8...
      (* env_find *)
apply subst_var_env_find...
inversion NOATOMS...
    (* closed, subst and keap_ok *)
auto.
  (* premises of the IH *)
    (* closed_by_expr *)
inversion_clear H3.
apply H9 in H.
inversion H; subst.
clear IHAAS H1.
simpl in H10.
assert (ZER : 0 = length (firstn m pn) - length (firstn m pn)).
  auto with *.
assert (LEN : m = length (firstn m pn)).
  symmetry.
  apply firstn_le_length...
rewrite LEN at 1.
rewrite LEN at 3.
rewrite LEN in H10.
rewrite ZER.
apply closed_transfer...
    (* subst *)
rewrite H7.
apply subst_lemma.
oa_inversion ONLYATOMS.
eapply oa_heap_val; eauto.
rewrite firstn_length.
auto with arith.
    (* no_atoms *)
inversion_clear H3.
set (lf := Lf Dont_update m e).
assert (no_atoms_lf lf).
  eapply H8.
  apply H.
inversion_clear H3...
    (* only_atoms *)
oa_inversion ONLYATOMS.
constructor...
apply oa_env_app...
  unfold oa_env...
  apply In_zip_var_list in H8.
  apply In_firstn in H8...
apply oa_env_shift.
eapply oa_heap_val; eauto.
apply oa_accum_skipn...
(* [4] Case App4 *)
subst_inversion EQe.
destruct xs; [ | discriminate ]...
dupl H.
apply similar_dom_atom with (GammaP := XiP) in H3...
destruct p; try contradiction...
similar_value H XiP.
rename e into etau.
rename x0 into e.
rename x1 into tau.
apply IHAAS with (XiP := XiP) (a := e) (beta := tau) in H0...
  (* thesis *)
destruct H0 as [x0 [x1 [x2 []]]].
destruct H7.
destruct H8.
destruct H9.
subst_inversion H9.
apply E_App4 with (x := x) (sigma := beta) (p := a) in H7... (* A *)
exists (setB x0 a (Lf_n 0 (Constr C vs), trim x1 vs)).
exists x1.
exists (Constr C vs).
    (* similar *)
split...
unfold similar.
      (* similar 1 *)
split.
intro.
rewrite <- H4.
unfold setA.
destruct eq_var_dec; [ discriminate | ]...
inversion_clear H0.
apply H6.
      (* similar 2 *)
split.
intro.
rewrite <- H4.
unfold setA.
unfold setB.
destruct eq_nat_dec; destruct eq_var_dec.
subst; split; intro; discriminate.
subst; destruct n; auto.
inversion e0; tauto.
inversion_clear H0.
inversion_clear H11.
apply H0.
      (* similar 3 *)
inversion_clear H0.
inversion_clear H11.
rewrite <- H4.
unfold setA.
unfold setB.
intros.
destruct eq_nat_dec; destruct eq_var_dec; subst;
  inversion H11; inversion H13; subst...
rewrite shift_0_v.
  rewrite H9.
  split...
  split...
  unfold subst...
  f_equal.
  rewrite apply_with_offset_0_id.
  rewrite apply_with_offset_0_id.
  rewrite subst_trim_vars...
destruct n; auto.
inversion e1; tauto.
apply H12 with (a := a0)...
    (* reduction *)
split.
clear IHAAS...
    (* closed*)
split...
    (* subst *)
split...
    (* heap_ok *)
unfold heapB_ok.
      (* heap_ok 1 *)
split...
unfold setB in H6.
destruct eq_nat_dec.
  inversion H6.
  subst.
  apply no_atoms_EES_no_atoms in H7...
  constructor...
  destruct H2.
  eauto.
destruct H10.
eapply H10...
apply H6.
      (* heap_ok 2 *)
unfold setB in H6.
destruct eq_nat_dec.
  subst.
  inversion H6.
  subst.
  constructor.
  clear IHAAS.
  simpl_arith.
  inversion H8; subst.
  constructor.
  apply closed_trim_vars...
destruct H10.
eapply H11.
apply H6.
    (* A (env_find) *)
apply subst_var_env_find...
inversion NOATOMS...
  (* premises of the IH *)
    (* closed_by_expr *)
inversion_clear H2.
set (lf := Lf Update 0 e).
assert (closed_by_lf (assoc_keys tau) 0 lf).
  eapply H8.
  apply H.
inversion_clear H2...
    (* subst *)
rewrite H6.
rewrite shift_0_v.
trivial.
    (* no_atoms *)
inversion_clear H2.
set (lf := Lf Update 0 e).
assert (no_atoms_lf lf).
  eapply H7.
  apply H.
inversion_clear H2...
    (* only_atoms *)
oa_inversion ONLYATOMS.
constructor...
eapply oa_heap_val; eauto.
(* [3] Case E_App5 *)
subst_inversion EQe.
dupl H.
apply similar_dom_atom with (GammaP := XiP) in H6...
destruct p; try contradiction...
similar_value H XiP.
rename e into etau.
rename x0 into e.
rename x1 into tau.
rewrite shift_0_v in H9.
eapply IHAAS1 with (a := e) (beta := tau) (XiP := XiP) in H2...
  (* thesis *)
destruct H2.
rename x0 into DeltaP.
destruct H2.
rename x0 into rho.
destruct H2 as [x0 []].
destruct H10.
destruct H11.
destruct H12.
subst_inversion H12.
destruct xs0; isa; try discriminate.
destruct xs;  isa; try discriminate.
dupl H0.
apply similar_dom_atom with (GammaP := DeltaP) in H9...
destruct q; try contradiction...
similar_value H0 DeltaP.
rename f into fmu.
rename x0 into f.
rename x2 into mu.
apply IHAAS2 with (a1 := App x1 nil) (beta := rho)
    (XiP := setB DeltaP a
      (Lf_n (n - length qk) f, trim (zip_var_list (length qk) qk ++
        shift (length qk) mu) (fv (Lf_n (n - length qk) f))))
  in H3...
  (* thesis *)
destruct H3.
rename x0 into OmegaP.
destruct H3.
rename x0 into xi.
destruct H3.
destruct H3.
destruct H17.
destruct H18.
destruct H19.
exists OmegaP.
exists xi.
exists x0.
    (* similar *)
split...
    (* reduction *)
split.
apply E_App5 with (p := a) (q := a0) (n := n) (Theta := OmegaP)
  (x := x) (pn := pn) (rs := rs) (nu := xi) (w := x0)
  (sigma := beta) (f := f) (mu := mu) in H10...
      (* env_find 1 *)
apply subst_var_env_find...
inversion NOATOMS...
      (* env_find 2 *)
apply subst_var_env_find...
apply no_atoms_EES_no_atoms in H10.
destruct H5.
inversion H10...
  set (lf := Lf Update 0 e).
  assert (no_atoms_lf lf).
    eapply H5.
    eauto.
inversion_clear H21...
apply H5.
    (* closed, subst and heap_ok *)
auto.
  (* premises of IHAAS2 *)
    (* subst *)
unfold subst...
rewrite apply_with_offset_0_v...
    (* no_atoms *)
apply no_atoms_EES_no_atoms in H10...
set (lf := Lf_u e).
assert (no_atoms_lf lf).
  destruct H5.
  eapply H5.
  eauto.
inversion_clear H17...
destruct H5.
eapply H5.
eauto.
    (* similar *)
      (* similar 1 *)
split.
intro.
unfold setA.
destruct eq_var_dec; try discriminate...
inversion_clear H2.
apply H17.
      (* similar 2 *)
split.
intro.
unfold setA.
unfold setB.
destruct eq_nat_dec; destruct eq_var_dec.
subst; split; intro; discriminate.
subst; destruct n0; auto.
inversion e0; tauto.
inversion_clear H2.
inversion_clear H18.
apply H2.
      (* similar 3 *)
inversion_clear H2.
inversion_clear H18.
unfold setA.
unfold setB.
intros.
destruct eq_nat_dec; destruct eq_var_dec; subst;
  inversion H18; inversion H20; subst.
split...
split...
apply only_atoms_EES_only_atoms in H10.
oa_inversion H10.
apply oa_accum_map in OA_ACCUM.
case OA_ACCUM.
intros x0 EQ.
rewrite -> EQ.
unfold Lf_n.
rewrite trim_fv.
rewrite shift_app_distr.
rewrite shift_cummulative.
rewrite <- EQ.
clear x0 EQ.
cutrewrite (n - length qk + length qk = n).
rewrite shift_zip_var_list.
cutrewrite (length qk + (n - length qk) = n)...
apply subst_lemma.
apply oa_heap_val with (Gamma := DeltaP) (p := a0) (lf := Lf_n n e0)...
omega.
omega.
omega.
omega.
clear IHAAS1.
clear IHAAS2.
unfold oa_heap in OA_HEAP.
unfold oa_env.
eapply OA_HEAP; eauto.
rewrite map_length; omega.
oa_inversion ONLYATOMS.
assert (oa_env tau).
  eapply oa_heap_val; eauto.
assert (only_atoms XiP beta nil).
  constructor; auto with oa.
apply only_atoms_EES_only_atoms in H10.
oa_inversion H10...
constructor; auto with oa.
constructor; auto with oa.
destruct n0; auto.
inversion e1; tauto.
apply H19 with (a := a1)...
    (* heap_ok *)
unfold heapB_ok.
      (* heap_ok 1 *)
split...
unfold setB in H17.
destruct eq_nat_dec.
  inversion H17.
  subst.
  inversion H13.
  set (lf := Lf_n n f).
  assert (no_atoms_lf lf).
    eapply H16.
    apply H0.
  inversion_clear H19.
  constructor...
inversion H13.
eapply H18...
eauto.
      (* heap_ok 2 *)
unfold setB in H17.
destruct eq_nat_dec.
        (* eq *)
inversion H17; subst.
clear IHAAS1 IHAAS2.
inversion H13; subst.
apply H18 in H0.
inversion H0; subst...
constructor...
apply closed_trim_fv.
apply closed_transfer...
omega.
        (* neq *)
inversion H13; subst.
eapply H19; eauto.
    (* only_atoms *)
oa_inversion ONLYATOMS.
assert (oa_env tau).
  eapply oa_heap_val; eauto.
assert (only_atoms XiP tau nil).
  constructor; auto with oa.
apply only_atoms_EES_only_atoms in H10...
oa_inversion H10.
constructor; auto with oa.
apply oa_setB...
apply oa_env_trim.
apply oa_env_app.
apply oa_env_zip_var_list...
  apply oa_env_shift.
  eapply oa_heap_val; eauto.
  (* premises of IHAAS1 *)
    (* closed_by_expr *)
inversion H5.
set (lf := Lf Update 0 e).
assert (closed_by_lf (assoc_keys tau) 0 lf).
  eapply H11.
  apply H.
inversion_clear H12...
    (* no_atoms *)
inversion H5.
set (lf := Lf Update 0 e).
assert (no_atoms_lf lf).
  eapply H10.
  apply H.
inversion_clear H12...
    (* only_atoms *)
oa_inversion ONLYATOMS.
constructor; auto with oa...
eapply oa_heap_val; eauto.
(* [2] Case Let *)
subst_inversion EQe.
apply atoms_exists in H0.
destruct H0.
rename x into ats0.
assert (length lfs = length lfs0).
  rewrite H6.
  rewrite map_length.
  trivial.
rename H5 into H9.
apply IHAAS with
    (XiP := allocB XiP ats0 (map
      (fun lf => (lf, trim (zip_var_list (length lfs) (map Atom ats0)
        ++ shift (length lfs) beta) (fv lf))) lfs0))
    (a := e0)
    (beta := zip_var_list (length lfs0) (map Atom ats0) ++
      shift (length lfs0) beta)
  in H2...
  (* thesis *)
clear IHAAS.
destruct H2 as [x [x0 [x1 []]]].
destruct H5.
rename x into DeltaP.
rename w into wxi.
rename x1 into w.
rename x0 into xi.
exists DeltaP.
exists xi.
exists w.
    (* similar *)
split...
    (* reduction *)
rewrite H9 in H5.
apply E_Let in H5...
      (* length *)
rewrite H0 in H.
rewrite map_length in H.
rewrite H6 in H.
rewrite map_length in H.
trivial.
      (* freshness *)
rewrite H0 in H1.
destruct H3.
destruct H11.
apply H11 in H1.
apply H1.
apply in_map...
  (* premises of the IH *)
    (* closed_by_expr *)
inversion CBY; subst...
clear IHAAS H2.
assert (LEN : length lfs0 = length (map Atom ats0)).
  rewrite map_length in *.
  rewrite map_length in H.
  auto.
assert (ZER : 0 = length (map Atom ats0) - length (map Atom ats0)).
  omega.
rewrite LEN in *.
rewrite ZER.
apply closed_transfer...
  (* subst *)
rewrite H7.
oa_inversion ONLYATOMS.
rewrite subst_shift...
rewrite <- H0.
rewrite H9.
oa_inversion ONLYATOMS.
apply subst_lemma...
omega.
  (* no_atoms *)
inversion NOATOMS...
  (* similar *)
    (* similar 1 *)
split...
destruct (In_dec eq_var_dec (Index n) ats).
      (* in *)
rewrite H0 in i.
rewrite in_map_iff in i.
destruct i.
destruct H5.
discriminate.
      (* not in *)
rewrite allocA_nin...
inversion H3...
    (* similar 2 *)
split...
destruct (In_dec eq_nat_dec a ats0).
      (* in *)
rewrite H0.
dupl i.
eapply allocB_some with (H := XiP) in i.
destruct i.
rewrite H5; clear H5.
assert (In (Atom a) ats).
  rewrite H0.
  apply in_map...
eapply allocA_some with (H := Gamma) in H5.
destruct H5.
rewrite <- H0.
rewrite H5.
intuition; discriminate.
rewrite map_length...
rewrite map_length...
rewrite H0 in H.
rewrite map_length in H.
rewrite H6 in H.
rewrite map_length in H.
trivial.
      (* not in *)
inversion H3.
inversion H8.
rewrite allocA_nin...
rewrite allocB_nin...
rewrite H0.
intro.
apply in_map_iff in H12.
destruct H12.
destruct H12.
inversion H12.
rewrite H15 in H13.
tauto.
    (* similar 3 *)
subst.
oa_inversion ONLYATOMS.
rewrite map_length in *.
rewrite map_length in *.
eapply alloc_similar; eauto...
  (* heapB_ok *)
    (* no_atoms *)
split...
destruct (In_dec eq_nat_dec n ats0).
      (* in *)
apply allocB_in in H5...
apply in_map_iff in H5.
destruct H5.
destruct H5.
inversion H5.
inversion NOATOMS.
subst.
apply H14...
rewrite map_length.
subst.
rewrite map_length in H.
rewrite map_length in H...
      (* not in *)
rewrite allocB_nin in H5...
inversion H4.
eapply H8; eauto...
    (* closed_by *)
destruct (In_dec eq_nat_dec n ats0).
      (* in *)
apply allocB_in in H5.
apply in_map_iff in H5.
destruct H5.
destruct H5.
inversion CBY; subst.
clear IHAAS.
clear H2.
inversion H5; subst.
clear H5.
destruct lf.
constructor...
clear EQe.
clear CASE.
apply H12 in H8.
rewrite map_length.
inversion H8; subst.
assert (LEN : length lfs0 = length (map Atom ats0)).
  rewrite map_length in *.
  rewrite map_length in H.
  symmetry...
assert (B : b = length lfs0 + b - length lfs0).
  auto with arith.
apply closed_trim_fv.
rewrite B.
rewrite LEN.
apply closed_transfer; try omega...
rewrite <- LEN...
rewrite map_length.
rewrite H0 in H.
rewrite map_length in H.
rewrite H9 in H...
auto.
      (* not in *)
rewrite allocB_nin in H5...
destruct H4.
eapply H8; eauto.
  (* only_atoms *)
oa_inversion ONLYATOMS.
constructor.
    (* heap *)
unfold oa_heap...
destruct (In_dec eq_nat_dec v ats0).
      (* in *)
apply allocB_in in H5...
apply in_map_iff in H5.
destruct H5.
destruct H5.
inversion H5.
assert (oa_env tau).
  rewrite <- H13.
  apply oa_env_trim.
  apply oa_env_app; auto with oa.
  apply oa_env_zip_var_list.
  unfold oa_accum.
  apply atoms_map_atom.
unfold oa_env in H11.
eauto.
rewrite map_length.
rewrite H0 in H.
rewrite map_length in H.
rewrite H6 in H.
rewrite map_length in H...
      (* not in *)
rewrite allocB_nin in H5...
eauto with oa.
    (* env *)
apply oa_env_app; auto with oa.
apply oa_env_zip_var_list.
unfold oa_accum.
apply atoms_map_atom.
    (* accum *)
auto.
(* [1] Case Case_of *)
subst_inversion EQe.
oa_inversion ONLYATOMS.
destruct (select_case_subst als als0 c c0 (length ps) e0 beta)...
destruct H.
rename x into e00.
apply IHAAS1 with (XiP := XiP) (beta := beta) (a := f) in H1...
  (* thesis *)
destruct H1.
destruct H1.
destruct H1.
destruct H1.
destruct H8.
rename x into DeltaP.
rename x0 into rho.
destruct H9.
destruct H10.
subst_inversion H10.
clear EQe.
apply IHAAS2 with (XiP := DeltaP) (beta0 :=
    zip_var_list (length ps) ps ++
    shift (length ps) beta)
  (a := e00) in H2...
    (* thesis *)
clear IHAAS1.
clear IHAAS2.
destruct H2.
destruct H2.
destruct H2.
rename x into ThetaP.
rename x0 into xi.
rename x1 into d.
destruct H2.
destruct H5.
exists ThetaP.
exists xi.
exists d.
destruct H6.
destruct H7.
      (* similar *)
split...
      (* reduction *)
split.
apply E_Case_of with (Delta := DeltaP) (e0 := e00) (rho := rho) (c := c)
  (c0 := c0) (ys := vs) (b := length ps) (rho_ys := ps)...
        (* length *)
unfold subst in H10; simpl in H10; inversion H10.
rewrite map_length...
        (* env_map *)
rewrite env_map_map_subst.
unfold subst in H10; simpl in H10; inversion H10.
rewrite apply_with_offset_0_id...
inversion NOATOMS; subst.
apply no_atoms_EES_no_atoms in H8...
inversion H8; subst.
inversion H8; subst...
destruct H4.
eapply H4; eauto.
inversion H9; subst...
      (*  closed_by, subst and heap_ok *)
split...
    (* premises of the second IH *)
      (* closed_by *)
clear CASE IHAAS1 IHAAS2.
inversion CBY; subst.
apply In_select_case in H.
apply H12 in H.
inversion H; subst...
assert (ZER : 0 = length ps - length ps); try omega.
rewrite ZER.
apply closed_transfer...
      (* subst*)
apply subst_lemma.
oa_inversion ONLYATOMS...
omega.
      (* no_atoms *)
inversion NOATOMS; subst.
apply In_select_case in H.
apply H12 in H.
inversion H; subst...
      (* only_atoms *)
oa_inversion ONLYATOMS.
clear IHAAS1.
clear IHAAS2.
apply only_atoms_EES_only_atoms in H8.
inversion H8; subst; constructor...
apply oa_env_app; auto with oa.
apply oa_env_zip_var_list.
inversion H9; subst.
unfold subst in H10; simpl in H10.
rewrite apply_with_offset_0_id in H10.
inversion H10.
apply oa_accum_map_subst_var with (x := Atom 0)...
constructor; auto; constructor...
constructor; auto with oa.
  (* premises of the first IH *)
    (* closed_by *)
inversion CBY; subst...
    (* no_atoms *)
inversion NOATOMS; subst...
    (* only_atoms *)
oa_inversion ONLYATOMS.
constructor; auto with oa.
Qed.

(** * Soundness *)

Proposition EES_sound :
forall GammaP e beta rs OmegaP f xi qs
    (RED : ($ GammaP $ e $ beta $ rs ↓↓↓ OmegaP $ f $ xi $ qs))
    (Gamma : heapA)
    (NOATOMS : no_atoms e)
    (ONLYATOMS : only_atoms GammaP beta rs)
    (OK_GammaP : heapB_ok GammaP)
    (SIM_Gamma : similar Gamma GammaP)
    (CLOSED : closed_by_expr (assoc_keys beta) 0 e),
  exists Omega,
    ($ Gamma $ e~[beta] $ rs ↓↓ Omega $ f~[xi] $ qs) /\
    similar Omega OmegaP /\
    heapB_ok OmegaP /\
    closed_by_expr (assoc_keys xi) 0 f.
Proof with isa.
intros ? ? ? ? ? ? ? ? ?.
induction RED...
(* [8] Case Con *)
exists Gamma0.
split...
unfold subst...
(* [7] Case Accum *)
apply IHRED in SIM_Gamma...
destruct SIM_Gamma.
destruct H1.
exists x0.
split...
apply A_Accum.
destruct xm...
intro; discriminate.
unfold subst in H1...
rewrite apply_with_offset_0_v in *.
rewrite apply_with_offset_0_id in *.
apply map_subst_env_map in H0.
rewrite H0.
inversion NOATOMS; subst...
constructor...
inversion NOATOMS; subst...
constructor; isa; contradiction.
oa_inversion ONLYATOMS.
constructor...
apply oa_accum_app...
eapply oa_env_map; eauto.
inversion CLOSED; subst.
constructor...
constructor...
contradiction.
(* [6] Case App1 *)
exists Gamma0.
split...
apply env_find_subst_var in H.
unfold subst...
rewrite apply_with_offset_0_id.
rewrite H.
eapply similar_value_left in H0; eauto.
(* [5] Case App2_5 *)
assert (TAU : oa_env tau).
  oa_inversion ONLYATOMS.
  unfold oa_heap in OA_HEAP.
  unfold oa_env.
  eapply OA_HEAP; eauto.
assert (E : no_atoms e).
  destruct OK_GammaP.
  apply H2 in H0.
  inversion H0; subst...
assert (CLOSED_E : closed_by_expr
    (assoc_keys (zip_var_list m (firstn m pn) ++ shift m tau)) 0 e).
  destruct OK_GammaP.
  apply H3 in H0.
  inversion H0; subst...
  cutrewrite (0 = m - m).
  assert (m = length (firstn m pn)).
    symmetry.
    apply firstn_le_length...
  rewrite H4 at 1 3 4 5.
  apply closed_transfer.
  trivial.
  rewrite <- H4...
  omega.
apply env_find_subst_var in H.
eapply similar_value_left in H0; eauto.
apply IHRED in SIM_Gamma...
destruct SIM_Gamma.
destruct H2.
exists x0.
split...
eapply A_App2_5; eauto.
clear IHRED.
rewrite apply_with_offset_0_id.
rewrite H.
apply H0.
rewrite subst_lemma...
rewrite firstn_length.
auto with arith.
oa_inversion ONLYATOMS.
constructor; auto with oa.
apply oa_env_app; auto with oa.
apply oa_env_zip_var_list.
unfold oa_accum in *.
apply atoms_firstn...
(* [4] Case App4 *)
assert (TAU : oa_env tau).
  oa_inversion ONLYATOMS.
  unfold oa_heap in OA_HEAP.
  unfold oa_env.
  eapply OA_HEAP; eauto.
assert (E : no_atoms e).
  destruct OK_GammaP.
  apply H1 in H0.
  inversion H0; subst...
assert (CLOSED_E : closed_by_expr (assoc_keys tau) 0 e).
  destruct OK_GammaP.
  apply H2 in H0.
  inversion H0; subst...
eapply similar_value_left in H0; eauto.
dupl SIM_Gamma.
apply IHRED in SIM_Gamma0...
destruct SIM_Gamma0.
exists (setA x0 (Atom p) (Lf_n 0 ((Constr C xs)~[rho]))).
unfold subst...
rewrite apply_with_offset_0_v.
rewrite apply_with_offset_0_id.
apply env_find_subst_var in H.
rewrite H.
split.
eapply A_App4; eauto.
rewrite shift_0_v.
destruct H1.
unfold subst in *...
rewrite apply_with_offset_0_id in *...
split.
  (* similar *)
unfold similar.
    (* similar 1 *)
split.
intro.
unfold setA.
destruct eq_var_dec; [ discriminate | ]...
destruct H1.
destruct H2.
inversion_clear H2.
apply H4.
      (* similar 2 *)
split.
intro.
unfold setA.
unfold setB.
destruct eq_nat_dec; destruct eq_var_dec.
subst; split; intro; discriminate.
subst; destruct n; auto.
inversion e0; tauto.
destruct H1.
destruct H2.
inversion_clear H2.
inversion_clear H5.
apply H2.
      (* similar 3 *)
destruct H1.
destruct H2.
inversion_clear H2.
inversion_clear H5.
unfold setA.
unfold setB.
intros.
destruct eq_nat_dec; destruct eq_var_dec; subst;
  inversion H5; inversion H7; subst...
rewrite shift_0_v; auto.
  split...
  split...
  unfold subst...
  rewrite apply_with_offset_0_id...
  f_equal.
  apply subst_trim_vars.
destruct n; auto.
inversion e1; tauto.
apply H6 with (a := a)...
  (* heap_ok *)
split.
destruct H1.
destruct H2.
unfold heapB_ok.
    (* heap_ok 1 *)
split...
unfold setB in H4.
destruct eq_nat_dec.
  inversion H4.
  subst.
  apply no_atoms_EES_no_atoms in RED...
  constructor...
  destruct OK_GammaP.
  eauto.
destruct H3.
eapply H3...
apply H4.
      (* heap_ok 2 *)
unfold setB in H4.
destruct eq_nat_dec.
  subst.
  inversion H4.
  subst.
  constructor.
  destruct H3...
  constructor.
  inversion H5; subst.
  apply closed_trim_vars...
destruct H3.
destruct H3.
eapply H6.
apply H4.
    (* closed_by *)
tauto.
  (* only_atoms *)
oa_inversion ONLYATOMS.
constructor...
(* [3] Case App5 *)
assert (TAU : oa_env tau).
  oa_inversion ONLYATOMS.
  unfold oa_heap in OA_HEAP.
  unfold oa_env.
  eapply OA_HEAP; eauto.
assert (CLOSED_E : closed_by_expr (assoc_keys tau) 0 e).
  destruct OK_GammaP.
  apply H5 in H1.
  inversion H1; subst...
dupl SIM_Gamma.
apply IHRED1 in SIM_Gamma0...
destruct SIM_Gamma0.
destruct H4.
destruct H5.
destruct H6.
rename Delta into DeltaP.
rename x0 into Delta.
remember (f~[shift n mu]) as fmu.
apply IHRED2 with (Gamma := setA Delta (Atom p)
  (Lf_n (n - length qk) (fmu~[zip_var_list n qk]))) in H7.
destruct H7.
exists x0.
    (* red *)
split.
unfold subst...
rewrite apply_with_offset_0_v.
apply env_find_subst_var in H.
rewrite H.
remember (w~[nu]) as wnu.
dupl Heqwnu.
unfold subst in Heqwnu0.
rewrite <- Heqwnu0.
remember (e~[tau]) as etau.
unfold subst in H4...
rewrite apply_with_offset_0_v in H4.
apply env_find_subst_var in H0.
rewrite H0 in H4.
destruct H7.
apply A_App5 with (Delta := Delta) (q := Atom q) (qk := qk)
  (e := etau) (f := fmu) (n := n)...
      (* App *)
eapply similar_value_left in H1; eauto.
rewrite shift_0_v in H1.
subst...
      (* App *)
eapply similar_value_left in H2; eauto.
subst...
      (* App *)
assert (QQQ : App y nil ~ [rho] = App (Atom q) nil).
  unfold subst...
  rewrite apply_with_offset_0_v.
  rewrite H0...
rewrite QQQ in H7...
    (* similar *)
destruct H7.
destruct H8.
destruct H9...
  (* no atoms *)
unfold env_find in H0.
destruct y...
constructor.
constructor.
constructor...
contradiction.
discriminate.
  (* only atoms *)
oa_inversion ONLYATOMS.
apply only_atoms_EES_only_atoms in RED1.
oa_inversion RED1...
constructor...
    (* heap *)
unfold oa_heap...
unfold setB in H8.
destruct eq_nat_dec.
      (* eq *)
inversion H8; subst; clear H8.
apply In_trim in H9.
apply in_app_or in H9.
destruct H9.
apply In_zip_var_list in H8...
assert (OAMU : oa_env mu).
  unfold oa_heap in OA_HEAP0.
  unfold oa_env...
  eapply OA_HEAP0; eauto...
apply oa_env_shift with (m := length qk) in OAMU.
unfold oa_env in OAMU.
eapply OAMU; eauto.
      (* neq *)
assert (OATAU0 : oa_env tau0).
unfold oa_heap in OA_HEAP0.
unfold oa_env...
eapply OA_HEAP0; eauto...
unfold oa_env in OATAU0.
eapply OATAU0; eauto.
    (* accum *)
apply oa_accum_app...
constructor; auto with oa.
  (* heap_ok *)
unfold heapB_ok.
    (* heap_ok 1 *)
split...
unfold setB in H8.
destruct eq_nat_dec.
      (* eq *)
inversion H8; subst; clear H8.
destruct H6.
apply H6 in H2.
inversion H2; subst.
constructor...
      (* neq *)
destruct H6.
eapply H6; eauto.
    (* heap_ok 2 *)
unfold setB in H8.
destruct eq_nat_dec.
      (* eq *)
inversion H8; subst; clear H8.
destruct H6.
apply H8 in H2.
inversion H2; subst.
constructor...
apply closed_trim_fv.
apply closed_transfer...
omega.
      (* neq *)
destruct H6.
eapply H9; eauto.
  (* similar *)
unfold similar.
    (* similar 1 *)
split...
unfold setA.
destruct eq_var_dec.
discriminate.
destruct H5...
    (* similar 2 *)
split...
unfold setA.
unfold setB.
destruct eq_nat_dec; destruct eq_var_dec.
subst; split; intro; discriminate.
subst; destruct n0; auto.
inversion e0; tauto.
inversion_clear H5.
inversion_clear H9.
apply H5.
    (* similar 3 *)
inversion_clear H5.
inversion_clear H11.
unfold setA in *.
unfold setB in *.
destruct eq_nat_dec; destruct eq_var_dec; subst;
  inversion H8; inversion H9; subst...
split...
split...
  apply only_atoms_EES_only_atoms in RED1.
  oa_inversion RED1.
  apply oa_accum_map in OA_ACCUM.
  case OA_ACCUM.
  intros x0 EQ.
  rewrite -> EQ.
  unfold Lf_n.
  rewrite trim_fv.
  rewrite shift_app_distr.
  rewrite shift_cummulative.
  rewrite <- EQ.
  clear x0 EQ.
  cutrewrite (n - length qk + length qk = n).
  rewrite shift_zip_var_list.
  cutrewrite (length qk + (n - length qk) = n)...
  apply subst_lemma.
apply oa_heap_val with (Gamma := DeltaP) (p := q) (lf := Lf_n n e0)...
omega.
omega.
omega.
omega.
unfold oa_heap in OA_HEAP.
unfold oa_env.
eapply OA_HEAP; eauto.
rewrite map_length; omega.
oa_inversion ONLYATOMS.
assert (oa_env tau).
  eapply oa_heap_val; eauto.
assert (only_atoms Gamma sigma nil).
  constructor; auto with oa.
apply only_atoms_EES_only_atoms in RED1.
oa_inversion RED1...
constructor; auto with oa.
constructor; auto with oa.
destruct n0; auto.
inversion e1; tauto.
apply H12 with (a := a)...
  (* no atoms *)
destruct OK_GammaP.
apply H4 in H1.
inversion H1; subst...
  (* only atoms *)
oa_inversion ONLYATOMS.
constructor...
unfold oa_accum.
apply atoms_nil.
(* [2] Case Let *)
rename Gamma into GammaP.
rename Gamma0 into Gamma.
assert (NAE : no_atoms e).
  inversion NOATOMS...
apply IHRED with
    (Gamma := allocA Gamma (map Atom ats)
    (map (subst_lf (zip_var_list (length lfs) (map Atom ats) ++
      shift (length lfs) sigma)) lfs))
  in NAE.
destruct NAE.
rename Delta into DeltaP.
rename x into Delta.
exists Delta.
  (* thesis *)
oa_inversion ONLYATOMS.
destruct H1.
destruct H2.
destruct H3.
split...
remember (w~[rho]) as wrho.
unfold subst...
apply A_Let with (ats := map Atom ats).
    (* length *)
rewrite map_length.
rewrite map_length.
trivial.
    (* atoms *)
apply atoms_map_atom.
    (* freshness *)
intros.
clear IHRED.
destruct SIM_Gamma.
inversion H7.
assert (is_atom a).
  apply atom_in_map_atom with (ats := ats)...
to_atom a.
case H8 with (a := a)...
apply H12.
apply H0.
apply in_map_iff in H5.
destruct H5.
destruct H5.
inversion H5; subst...
    (* red *)
rewrite map_length.
rewrite subst_shift.
rewrite subst_lemma...
rewrite lf_subst_lemma in H1...
rewrite map_length.
rewrite <- H.
apply le_refl.
trivial.
  (* premises of the IH *)
    (* only atoms *)
oa_inversion ONLYATOMS.
constructor...
unfold oa_heap...
destruct (In_dec eq_nat_dec v ats).
      (* in *)
apply allocB_in in H1.
apply in_map_iff in H1.
destruct H1.
destruct H1.
inversion H1; subst; clear H1.
apply In_trim in H2.
apply in_app_or in H2.
destruct H2.
apply In_zip_var_list in H1.
apply in_map_iff in H1.
destruct H1.
destruct H1.
subst...
apply oa_env_shift with (m := length lfs) in OA_ENV...
unfold oa_env in OA_ENV.
eauto.
rewrite map_length...
auto.
      (* not in *)
rewrite allocB_nin in H1...
unfold oa_heap in OA_HEAP.
eapply OA_HEAP; eauto.
    (*  *)
apply oa_env_app; auto with oa.
apply oa_env_zip_var_list; auto with oa.
unfold oa_accum.
apply atoms_map_atom.
    (* heap ok *)
unfold heapB_ok.
      (* heap ok 1 *)
split...
destruct (In_dec eq_nat_dec n ats).
        (* in *)
apply allocB_in in H1...
apply in_map_iff in H1.
destruct H1.
destruct H1.
inversion H1; subst; clear H1.
inversion NOATOMS; subst.
apply H4...
rewrite map_length...
        (* not in *)
rewrite allocB_nin in H1...
unfold heapB_ok in OK_GammaP.
destruct OK_GammaP.
eauto.
      (* heap ok 2 *)
destruct (In_dec eq_nat_dec n ats).
        (* in *)
apply allocB_in in H1...
apply in_map_iff in H1.
destruct H1.
destruct H1.
inversion H1; subst; clear H1.
inversion CLOSED; subst.
apply H4 in H2...
inversion H2; subst.
apply closed_transfer with (qk := map Atom ats) in H1.
constructor...
apply closed_trim_fv.
assert (L : length lfs + b - length (map Atom ats) = b).
  rewrite map_length.
  rewrite <- H.
  auto with arith.
rewrite L in H1.
cutrewrite (length lfs = length (map Atom ats))...
  rewrite map_length...
rewrite map_length...
rewrite <- H.
auto with arith.
rewrite map_length...
        (* not in *)
rewrite allocB_nin in H1...
unfold heapB_ok in OK_GammaP.
destruct OK_GammaP.
eauto.
    (* similar *)
unfold similar.
      (* similar 1 *)
split...
destruct (In_dec eq_var_dec (Index n) (map Atom ats))...
        (* in *)
apply in_map_iff in i.
destruct i.
destruct H1.
discriminate.
        (* not in *)
rewrite allocA_nin...
unfold similar in SIM_Gamma.
destruct SIM_Gamma...
      (* similar 2 *)
split...
destruct (In_dec eq_nat_dec a ats).
        (* in *)
dupl i.
eapply allocB_some with (H := GammaP) in i0.
destruct i0.
rewrite H1; clear H1.
dupl i.
apply in_map with (f := Atom) in i0.
eapply allocA_some with (H := Gamma) in i0.
destruct i0.
rewrite H1.
intuition; discriminate.
rewrite map_length.
rewrite map_length...
rewrite map_length...
        (* not in *)
inversion SIM_Gamma.
inversion H2.
rewrite allocA_nin...
rewrite allocB_nin...
intro.
apply in_map_iff in H5.
destruct H5.
destruct H5.
inversion H5.
rewrite H8 in H6.
tauto.
      (* similar 3 *)
oa_inversion ONLYATOMS.
eapply alloc_similar; eauto...
rewrite <- lf_subst_lemma...
    (* closed by *)
inversion CLOSED; subst.
rewrite plus_comm in H4.
apply closed_transfer with (qk := (map Atom ats)) in H4.
cutrewrite (0 = length lfs + 0 - length lfs); try omega.
rewrite assoc_keys_app_distr in *.
assert (length lfs = length (map Atom ats)).
  rewrite map_length...
rewrite H1 in *...
rewrite map_length in *.
rewrite <- H.
auto with arith.
(* [1] Case Case_of *)
dupl SIM_Gamma.
apply IHRED1 in SIM_Gamma0...
destruct SIM_Gamma0.
destruct H2.
destruct H3.
destruct H4.
clear IHRED1.
rename Delta into DeltaP.
rename x into Delta.
dupl H4.
apply IHRED2 with (Gamma := Delta) in H4...
destruct H4.
destruct H4.
destruct H7.
destruct H8.
clear IHRED2.
exists x.
split...
oa_inversion ONLYATOMS.
apply map_subst_env_map in H0.
apply select_case_subst_right with (beta := sigma) in H1...
assert (CYS : Constr c ys ~ [rho] = Constr c rho_ys).
  unfold subst...
  rewrite apply_with_offset_0_id.
  rewrite H0...
rewrite CYS in H2.
apply A_Case_of with (Delta := Delta) (b := b) (e0 := e0 ~ [shift b sigma])
  (c := c) (c0 := c0) (ps := rho_ys)...
  (* length *)
rewrite <- H0.
rewrite map_length...
  (* reduction *)
rewrite subst_lemma...
  (* length *)
rewrite <- H0.
rewrite map_length...
omega.
  (* no atoms in alt *)
clear IHRED2.
inversion NOATOMS; subst.
apply In_select_case in H1.
apply H10 in H1.
inversion H1; subst...
  (* only atoms *)
oa_inversion ONLYATOMS.
apply only_atoms_EES_only_atoms in RED1.
oa_inversion RED1.
constructor...
apply oa_env_app; auto with oa.
apply oa_env_zip_var_list.
eapply oa_env_map; eauto.
constructor; auto with oa.
  (* closed by *)
clear IHRED2.
inversion CLOSED; subst.
apply In_select_case in H1.
apply H10 in H1.
inversion H1; subst...
assert (LRHO : length ys = length rho_ys).
  apply map_subst_env_map in H0.
  rewrite <- H0.
  rewrite map_length...
cutrewrite (0 = length rho_ys - length rho_ys); try omega.
rewrite LRHO in *.
apply closed_transfer...
  (* no atoms *)
inversion NOATOMS; subst...
  (* only atoms *)
oa_inversion ONLYATOMS.
constructor; auto with oa.
  (* closed by *)
inversion CLOSED...
Qed.


Lemma nat_id_ok : forall n, id n = n.
Proof.

Print bool.


From MSSL Require Import Syntax.
Require Import Coq.FSets.FMapList.
Require Import Coq.Structures.OrdersEx.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Structures.OrderedTypeEx.
Require Import Syntax.
Require Import Relations.

Require Import List.
Import ListNotations.
Require Import Variables.

Require Import Monoid MonoidExamples.
Require Import Functor.
Require Import Coq.Sets.Ensembles.
Open Scope type_scope.

Require Import Coq.Program.Basics.

Require Import Lifetime Store LVal Value.

Require Import Transition.

Require Import Monad.
Open Scope monad_scope.

Open Scope type_scope.

    Import MSSLSyntax.
    Import Value.

    Module D <: StoreDomain.
        Definition loc := location.
        Definition val := partialValue * sum Lifetime.t nat.
    End D.

    Module S := Store (D).

    Definition isValue (e : expression) : Prop :=
            match e with EVal v => True | _ => False end.

    Definition getValue (e : expression) (H : isValue e) : Value.value :=
        match e as e0 return (isValue e0 -> Value.value) with
            | EVal v => const v
            | _ => False_rect _
        end H.

    Coercion EVal : Value.value >-> expression.

    Axiom instantiate : S.t -> Lifetime.t -> expression -> expression.

    Definition threadId := nat.
    Definition pool := list (threadId * expression * Lifetime.t).

Inductive context : Type :=
    | CEmpty : context
    | CSeq : context -> expression -> context
    | CBinding : Var.t -> context -> context
    | CAssign : lval -> context -> context
    | CBox : context -> context
    | CTrc : context -> context
    | CSpawn : Var.t -> list Value.value -> context -> list expression -> context.

Fixpoint build (c : context) (e : expression) : expression :=
    match c with
        | CEmpty => e
        | CSeq c e' => ESeq (build c e) e'
        | CBinding x c =>  EBinding x (build c e)
        | CAssign w c => EAssign w (build c e)
        | CBox c => EBox (build c e)
        | CTrc c => ETrc (build c e)
        | CSpawn f vl c el => ESpawn f ((List.map EVal vl)++[(build c e)]++el)
        end.

    Definition lstate := S.t * expression.

    Definition read (σ : S.t) (l : Lifetime.t) (ω : lval) :
        option (Value.partialValue * sum Lifetime.t nat) :=
            S.loc σ l ω >>= S.get σ.

    Definition write (σ : S.t) (l : Lifetime.t) (ω : lval)  (v : Value.partialValue) :
        option S.t :=
            S.loc σ l ω >>= (fun a => S.get σ a >>= (fun x =>  S.set σ a (v, snd x))).

    Inductive step (p : program) (l : Lifetime.t) :
        transition lstate pool :=
            S_Copy : forall σ ω v m,
            read σ l ω = Some (Some v, m) ->
            step p l (σ, ERead Copy ω)  [] (σ, EVal v)
        |   S_Move : forall σ ω v σ' m,
            read σ l ω = Some (Some v, m) ->
            write σ l ω None = Some σ' ->
            step p l (σ, ERead Move ω) [] (σ', EVal v)
        |   S_Box : forall  (σ σ' : S.t) (m : nat) (v : value),
            ~ S.defined σ (inr m) ->
            S.allocate σ [(inr m, (Some v, inl Lifetime.glob))] = Some σ' ->
            step p l (σ, EBox v) [] (σ', EVal (Value.Location (inr m) Owned))
        |   S_Trc : forall  (σ σ' : S.t) (m : nat) (v : value),
            ~ S.defined σ (inr m) ->
            S.allocate σ [(inr m, (Some v, inr 1))] = Some σ' ->
            step p l (σ, ETrc v) [] (σ', EVal (Location (inr m) (Trc true)))
        |   S_Clone : forall  (σ σ' : S.t) (ω : lval) (m i : nat),
            read σ l ω = Some (Some (Location (inr m) (Trc true)), inr i) ->
            S.clone σ l ω = Some σ' ->
            step p l (σ, EClone ω) [] (σ', EVal (Location (inr m) (Trc false)))
        |   S_Borrow : forall σ ω ℓ b,
            S.loc σ l ω = Some ℓ ->
            step p l (σ, ERef b ω) [] (σ, EVal (Location ℓ Borrowed))
        |   S_Declare : forall (σ σ' : S.t) (x : Var.t) (v : value),
            write σ l (LVar x) (Some v) = Some σ' ->
            step p l (σ, EBinding x v) [] (σ', EVal Unit)
        |   S_Assign : forall (σ σ' σ'' : S.t) (ω : lval)
            (v:value) (v' : partialValue) m,
            read σ l ω = Some (v', m) ->
            (* S.drop_val σ (Singleton _ v') = Some σ'' -> *)
            write σ'' l ω (Some v) = Some σ' ->
            step p l (σ, EAssign ω (EVal v)) [] (σ', EVal Unit)
        |   S_Seq : forall (σ σ' : S.t) (v :value) (e1 e2  : expression),
            (* Store.drop_val σ (Singleton _ (Some v)) = Some σ' -> *)
            step p l (σ, ESeq (EVal v) e2) [] (σ, e2)
        |   S_Block1 : forall ( m : Lifetime.t) (σ σ' : S.t) (e e' : expression) T,
            step p m (σ, e) T (σ', e') ->
            step p l (σ, EBlock e m) T (σ', EBlock e' m)
        |   S_Block2 : forall (m : Lifetime.t) (σ σ' : S.t) (v : value),
            (* Store.drop_lft σ m = Some σ' -> *)
            step p l (σ, EBlock (EVal v) m) [] (σ, EVal v)
        |   S_Spawn : forall (m m' : Lifetime.t) (σ σ' : S.t) (f : Var.t) (mth : method)
                (e e' : expression) (el : list expression) (vl : list value) (t :threadId),
            functions p f = Some mth ->
            el = List.map EVal vl ->
            instantiate σ l (EBlock e m) = EBlock e' m' ->
            let xl := List.map (fun x =>  inl (fst x, m')) (params mth) in
            let vl' := List.map (fun v => (Some v, inl m')) vl in
            let u := List.combine xl vl' in
            S.allocate σ u = Some σ' ->
            step p l (σ, ESpawn f el) [(t, e', m')] (σ', EVal Unit).

    Definition run (p : program) (l : Lifetime.t) :
        transition lstate (list (threadId * expression * Lifetime.t)) :=
            reachable _ _ (step p l).

    Inductive react (p : program) : relation (S.t * pool) :=
        | react_done : forall σ, react p (σ, []) (σ, [])
        | react_step : forall l t σ σ' σ'' e e' T0 T T',
            step p l (σ, e) T0 (σ', e') ->
            react p (σ'',T) (σ', T') ->
            react p (σ, (t, e, l)::T) (σ', (t,e',l)::T' ++ T0).

    Inductive reset : relation expression :=
        | reset_val : reset (EVal Unit) (EVal Unit)
        | reset_cooperate : forall e e' C,
            e  = build C ECooperate ->
            e' = build C (EVal Unit) ->
            reset e e'.

    Definition resetAll : relation pool :=
        fun (l1 l2 : pool) => forall i,
            match nth_error l1 i, nth_error l2 i with
                | None, None => True
                | Some (_, e1, _), Some (_, e2, _) => reset e1 e2
                | _, _ => False
            end.

    Definition instant (p : program) : relation (S.t * pool) :=
        fun st st' =>
        let (σ, T) := st in
        let (σ', T') := st' in
        exists T'', react p (σ, T) (σ', T') /\ resetAll T'' T'.

    Definition reachable (p : program) : relation (S.t * pool) :=
        clos_refl_trans _ (instant p).