(* Distributed under the terms of the MIT license. *)
From Coq Require Import ssreflect ssrbool.
From MetaCoq.Template Require Import config utils.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICLiftSubst PCUICTyping PCUICCumulativity
     PCUICReduction PCUICWeakeningConv PCUICWeakeningTyp PCUICEquality PCUICUnivSubstitutionConv
     PCUICSigmaCalculus PCUICContextReduction
     PCUICParallelReduction PCUICParallelReductionConfluence PCUICClosedConv PCUICClosedTyp
     PCUICRedTypeIrrelevance PCUICOnFreeVars PCUICConfluence PCUICSubstitution.

Require Import CRelationClasses CMorphisms.
Require Import Equations.Prop.DepElim.
Require Import Equations.Type.Relation Equations.Type.Relation_Properties.
From Equations Require Import Equations.

(* We show that conversion/cumulativity starting from well-typed terms is transitive.
  We first use typing to decorate the reductions/comparisons with invariants
  showing that all the considered contexts/terms are well-scoped. In a second step
  we use confluence of one-step reduction on well-scoped terms [ws_red_confluence], which also
  commutes with alpha,universe-equivalence of contexts and terms [red1_eq_context_upto_l].
  We can now derive transitivity of the conversion relation on *well-scoped*
  terms. To deal with the closedness side condition we put them in the definition
  of conversion/cumulativity: as terms need to move between contexts, and
  we sometimes need to consider conversion in open contexts, we work with
  them in an unpacked style.
  This allows to state theorems about conversion/cumulativity of general terms
  and contexts without wrapping/unwrapping them constantly into subsets.
*)

Reserved Notation " Σ ;;; Γ ⊢ t ≤[ pb ] u" (at level 50, Γ, t, u at next level,
  format "Σ  ;;;  Γ  ⊢  t  ≤[ pb ]  u").

Implicit Types (cf : checker_flags) (Σ : global_env_ext).

Inductive ws_cumul_pb {cf} (pb : conv_pb) (Σ : global_env_ext) (Γ : context) : term -> term -> Type :=
| ws_cumul_pb_compare (t u : term) :
  is_closed_context Γ -> is_open_term Γ t -> is_open_term Γ u ->
  compare_term pb Σ.1 (global_ext_constraints Σ) t u -> Σ ;;; Γ ⊢ t ≤[pb] u
| ws_cumul_pb_red_l (t u v : term) :
  is_closed_context Γ ->
  is_open_term Γ t -> is_open_term Γ u -> is_open_term Γ v ->
  red1 Σ Γ t v -> Σ ;;; Γ ⊢ v ≤[pb] u -> Σ ;;; Γ ⊢ t ≤[pb] u
| ws_cumul_pb_red_r (t u v : term) :
  is_closed_context Γ ->
  is_open_term Γ t -> is_open_term Γ u -> is_open_term Γ v ->
  Σ ;;; Γ ⊢ t ≤[pb] v -> red1 Σ Γ u v -> Σ ;;; Γ ⊢ t ≤[pb] u
where " Σ ;;; Γ ⊢ t ≤[ pb ] u " := (ws_cumul_pb pb Σ Γ t u) : type_scope.
Derive Signature NoConfusion for ws_cumul_pb.

Notation " Σ ;;; Γ ⊢ t ≤ u " := (ws_cumul_pb Cumul Σ Γ t u) (at level 50, Γ, t, u at next level,
    format "Σ  ;;;  Γ  ⊢  t  ≤  u") : type_scope.

Notation " Σ ;;; Γ ⊢ t = u " := (ws_cumul_pb Conv Σ Γ t u) (at level 50, Γ, t, u at next level,
  format "Σ  ;;;  Γ  ⊢  t  =  u") : type_scope.

Lemma ws_cumul_pb_refl' {pb} {cf} {Σ} (Γ : closed_context) (t : open_term Γ) : ws_cumul_pb pb Σ Γ t t.
Proof.
  constructor; eauto with fvs. reflexivity.
Qed.

#[global]
Instance ws_cumul_pb_sym {cf Σ Γ} : Symmetric (ws_cumul_pb Conv Σ Γ).
Proof.
  move=> x y; elim.
  - move=> t u clΓ clt clu eq.
    constructor 1; eauto with fvs.
    cbn in *; now symmetry.
  - move=> t u v clΓ clt clu clv r c c'.
    econstructor 3; tea.
  - move=> t u v clΓ clt clu clv r c c'.
    econstructor 2; tea.
Qed.

Lemma red1_is_open_term {cf : checker_flags} {Σ} {wfΣ : wf Σ} {Γ : context} x y :
  red1 Σ Γ x y ->
  is_closed_context Γ ->
  is_open_term Γ x ->
  is_open_term Γ y.
Proof.
  intros. eapply red1_on_free_vars; eauto with fvs.
Qed.
#[global] Hint Immediate red1_is_open_term : fvs.

Lemma red_is_open_term {cf : checker_flags} {Σ} {wfΣ : wf Σ} {Γ : context} x y :
  red Σ Γ x y ->
  is_closed_context Γ ->
  is_open_term Γ x ->
  is_open_term Γ y.
Proof.
  intros. eapply red_on_free_vars; eauto with fvs.
Qed.
#[global] Hint Immediate red_is_open_term : fvs.

Lemma ws_cumul_pb_is_open_term {cf : checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ : context} {x y} :
  ws_cumul_pb pb Σ Γ x y ->
  [&& is_closed_context Γ, is_open_term Γ x & is_open_term Γ y].
Proof.
  now induction 1; rewrite ?i ?i0 ?i1 ?i2.
Qed.

Lemma ws_cumul_pb_is_closed_context {cf : checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ : context} {x y} :
  ws_cumul_pb pb Σ Γ x y -> is_closed_context Γ.
Proof.
  now induction 1; rewrite ?i ?i0 ?i1 ?i2.
Qed.

Lemma ws_cumul_pb_is_open_term_left {cf : checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ}
  {Γ : context} {x y} :
  ws_cumul_pb pb Σ Γ x y -> is_open_term Γ x.
Proof.
  now induction 1; rewrite ?i ?i0 ?i1 ?i2.
Qed.

Lemma ws_cumul_pb_is_open_term_right {cf : checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ : context} {x y} :
  ws_cumul_pb pb Σ Γ x y -> is_open_term Γ y.
Proof.
  now induction 1; rewrite ?i ?i0 ?i1.
Qed.

#[global] Hint Resolve ws_cumul_pb_is_closed_context ws_cumul_pb_is_open_term_left ws_cumul_pb_is_open_term_right : fvs.

Lemma ws_cumul_pb_alt `{cf : checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} Γ t u :
  Σ ;;; Γ ⊢ t ≤[pb] u <~>
  ∑ v v',
    [× is_closed_context Γ, is_open_term Γ t, is_open_term Γ u,
      red Σ Γ t v, red Σ Γ u v' & compare_term pb Σ (global_ext_constraints Σ) v v'].
Proof.
  split.
  - induction 1.
    + exists t, u. intuition auto.
    + destruct IHX as (v' & v'' & [-> _ -> redv redv' leqv]).
      rewrite i0 /=.
      exists v', v''. split; auto. now eapply red_step.
    + destruct IHX as (v' & v'' & [-> -> cl redv redv' leqv ]).
      exists v', v''. split; auto. now eapply red_step.
  - intros (v' & v'' & [clΓ clt clu redv redv' leqv]).
    apply clos_rt_rt1n in redv.
    apply clos_rt_rt1n in redv'.
    induction redv in u, v'', redv', leqv, clt, clu |- *.
    * induction redv' in x, leqv, clt, clu |- *.
    ** constructor; auto.
    ** econstructor 3; tas. 2:eapply IHredv'. all:tea; eauto with fvs.
    * econstructor 2; revgoals. eapply IHredv; cbn; eauto with fvs. all:eauto with fvs.
Qed.

Lemma ws_cumul_pb_forget {cf:checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ} {x y} :
  ws_cumul_pb pb Σ Γ x y -> Σ ;;; Γ |- x <=[pb] y.
Proof.
  induction 1.
  - constructor; auto.
  - econstructor 2; eauto.
  - econstructor 3; eauto.
Qed.

Lemma ws_cumul_pb_forget_cumul {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ} {x y} :
  ws_cumul_pb Cumul Σ Γ x y -> Σ ;;; Γ |- x <=[Cumul] y.
Proof. apply (ws_cumul_pb_forget (pb:=Cumul)). Qed.

Lemma ws_cumul_pb_forget_conv {cf:checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ} {x y} :
  ws_cumul_pb Conv Σ Γ x y -> Σ ;;; Γ |- x <=[Conv] y.
Proof. apply (ws_cumul_pb_forget (pb:=Conv)). Qed.
#[global] Hint Resolve ws_cumul_pb_forget_cumul ws_cumul_pb_forget_conv : pcuic.

#[global]
Instance ws_cumul_pb_trans {cf:checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ} :
  Transitive (ws_cumul_pb pb Σ Γ).
Proof.
  move=> t u v /ws_cumul_pb_alt [t' [u' [clΓ clt clu tt' uu' eq]]]
    /ws_cumul_pb_alt[u'' [v' [_ clu' clv uu'' vv' eq']]].
  eapply ws_cumul_pb_alt.
  destruct (red_confluence (Γ := exist Γ clΓ) (t:=exist u clu) uu' uu'') as [u'nf [ul ur]].
  destruct pb; cbn in *.
  { eapply red_eq_term_upto_univ_r in ul as [tnf [redtnf ?]]; tea; try tc.
    eapply red_eq_term_upto_univ_l in ur as [unf [redunf ?]]; tea; try tc.
    exists tnf, unf.
    split; auto; eauto with fvs.
    - now transitivity t'.
    - now transitivity v'.
    - now transitivity u'nf. }
  { eapply red_eq_term_upto_univ_r in ul as [tnf [redtnf ?]]; tea; try tc.
    eapply red_eq_term_upto_univ_l in ur as [unf [redunf ?]]; tea; try tc.
    exists tnf, unf.
    split; eauto with fvs.
    - now transitivity t'.
    - now transitivity v'.
    - now transitivity u'nf. }
Qed.

Arguments wt_cumul_pb_dom {cf c Σ Γ T U}.
Arguments wt_cumul_pb_codom {cf c Σ Γ T U}.
Arguments wt_cumul_pb_eq {cf c Σ Γ T U}.

Section EqualityLemmas.
  Context {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ}.

  Lemma isType_open {Γ T} : isType Σ Γ T -> on_free_vars (shiftnP #|Γ| xpred0) T.
  Proof using wfΣ.
    move/isType_closedPT. now rewrite closedP_shiftnP.
  Qed.

  Lemma into_ws_cumul_pb {pb} {Γ : context} {T U} :
    Σ;;; Γ |- T <=[pb] U ->
    is_closed_context Γ -> is_open_term Γ T ->
    is_open_term Γ U ->
    Σ ;;; Γ ⊢ T ≤[pb] U.
  Proof using wfΣ.
    induction 1.
    - constructor; auto.
    - intros. econstructor 2 with v; cbn; eauto with fvs.
    - econstructor 3 with v; cbn; eauto with fvs.
  Qed.

  Lemma isType_ws_cumul_pb_refl {pb} Γ T : isType Σ Γ T -> Σ ;;; Γ ⊢ T ≤[pb] T.
  Proof using wfΣ.
    intros H.
    pose proof (isType_wf_local H).
    eapply (ws_cumul_pb_refl' (exist Γ (wf_local_closed_context X)) (exist T (isType_open H))).
  Qed.

  (** From well-typed to simply well-scoped equality. *)
  Lemma wt_cumul_pb_ws_cumul_pb {pb} {Γ : context} {T U} :
    wt_cumul_pb pb Σ Γ T U ->
    ws_cumul_pb pb Σ Γ T U.
  Proof using wfΣ.
    move=> [] dom codom equiv; cbn.
    generalize (wf_local_closed_context (isType_wf_local dom)).
    generalize (isType_open dom) (isType_open codom). clear -wfΣ equiv.
    intros. apply into_ws_cumul_pb => //.
  Qed.

  Lemma wt_cumul_pb_trans pb Γ :
    Transitive (wt_cumul_pb pb Σ Γ).
  Proof using wfΣ.
    intros x y z cum cum'.
    have wscum := (wt_cumul_pb_ws_cumul_pb cum).
    have wscum' := (wt_cumul_pb_ws_cumul_pb cum').
    generalize (transitivity wscum wscum'). clear wscum wscum'.
    destruct cum, cum'; split=> //.
    apply ws_cumul_pb_forget in X. now cbn in X.
  Qed.

  Global Instance conv_trans Γ : Transitive (wt_conv Σ Γ).
  Proof using wfΣ. apply wt_cumul_pb_trans. Qed.

  Global Instance cumul_trans Γ : Transitive (wt_cumul Σ Γ).
  Proof using wfΣ. apply wt_cumul_pb_trans. Qed.

End EqualityLemmas.

Set Warnings "-uniform-inheritance".
Coercion wt_cumul_pb_ws_cumul_pb : wt_cumul_pb >-> ws_cumul_pb.
Set Warnings "uniform-inheritance".

#[global] Hint Immediate isType_ws_cumul_pb_refl : pcuic.

Record closed_relation {R : context -> term -> term -> Type} {Γ T U} :=
  { clrel_ctx : is_closed_context Γ;
    clrel_src : is_open_term Γ T;
    clrel_rel : R Γ T U }.
Arguments closed_relation : clear implicits.

#[global] Hint Immediate clrel_ctx clrel_src : fvs.

Definition closed_red1 Σ := (closed_relation (red1 Σ)).
Definition closed_red1_red1 {Σ Γ T U} (r : closed_red1 Σ Γ T U) := clrel_rel r.
#[global] Hint Resolve closed_red1_red1 : fvs.
Coercion closed_red1_red1 : closed_red1 >-> red1.

Lemma closed_red1_open_right {cf} {Σ Γ T U} {wfΣ : wf Σ} (r : closed_red1 Σ Γ T U) : is_open_term Γ U.
Proof.
  destruct r. eauto with fvs.
Qed.

Definition closed_red Σ := (closed_relation (red Σ)).
Definition closed_red_red {Σ Γ T U} (r : closed_red Σ Γ T U) := clrel_rel r.
#[global] Hint Immediate closed_red_red : fvs.
Coercion closed_red_red : closed_red >-> red.

Lemma closed_red_open_right {cf} {Σ Γ T U} {wfΣ : wf Σ} (r : closed_red Σ Γ T U) : is_open_term Γ U.
Proof.
  destruct r. eauto with fvs.
Qed.

From Equations.Type Require Import Relation_Properties.

(* \rightsquigarrow *)
Notation "Σ ;;; Γ ⊢ t ⇝ u" := (closed_red Σ Γ t u) (at level 50, Γ, t, u at next level,
  format "Σ  ;;;  Γ  ⊢  t  ⇝  u").

Lemma closed_red1_red {Σ Γ t t'} : closed_red1 Σ Γ t t' -> Σ ;;; Γ ⊢ t ⇝ t'.
Proof.
  intros []. split => //.
  now eapply red1_red.
Qed.

Lemma ws_cumul_pb_alt_closed {cf} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} Γ t u :
  Σ ;;; Γ ⊢ t ≤[pb] u <~>
  ∑ v v',
    [× closed_red Σ Γ t v, closed_red Σ Γ u v' &
       compare_term pb Σ (global_ext_constraints Σ) v v'].
Proof.
  etransitivity. apply ws_cumul_pb_alt.
  split; intros (v & v' & cl); exists v, v'; intuition.
Qed.

Lemma biimpl_introT {T} {U} : Logic.BiImpl T U -> T -> U.
Proof. intros [] => //. Qed.

Hint View for move/ biimpl_introT|2.

Lemma ws_cumul_pb_refl {cf} {Σ} {pb Γ t} : is_closed_context Γ -> is_open_term Γ t -> Σ ;;; Γ ⊢ t ≤[pb] t.
Proof.
  move=> clΓ clt.
  constructor; cbn; eauto with fvs. reflexivity.
Qed.
#[global] Hint Immediate ws_cumul_pb_refl : pcuic.

Section RedConv.
  Context {cf} {Σ} {wfΣ : wf Σ}.

  Lemma red_conv {pb Γ t u} : Σ ;;; Γ ⊢ t ⇝ u -> Σ ;;; Γ ⊢ t ≤[pb] u.
  Proof using wfΣ.
    move=> [clΓ clT /clos_rt_rt1n_iff r].
    induction r.
    - now apply ws_cumul_pb_refl.
    - econstructor 2. 5:tea.
      all:eauto with fvs.
  Qed.

  Lemma red_ws_cumul_pb_left {pb Γ} {t u v} :
    Σ ;;; Γ ⊢ t ⇝ u -> Σ ;;; Γ ⊢ u ≤[pb] v -> Σ ;;; Γ ⊢ t ≤[pb] v.
  Proof using wfΣ.
    move=> [clΓ clT /clos_rt_rt1n_iff r].
    induction r; auto.
    econstructor 2. 5:tea. all:eauto with fvs.
  Qed.

  Lemma red_ws_cumul_pb_right {pb Γ t u v} :
    Σ ;;; Γ ⊢ t ⇝ u -> Σ ;;; Γ ⊢ v ≤[pb] u -> Σ ;;; Γ ⊢ v ≤[pb] t.
  Proof using wfΣ.
    move=> [clΓ clT /clos_rt_rt1n_iff r].
    induction r; auto.
    econstructor 3. 5:eapply IHr. all:eauto with fvs.
  Qed.

  (* synonym of red_conv *)
  Lemma red_ws_cumul_pb {pb Γ t u} :
    Σ ;;; Γ ⊢ t ⇝ u -> Σ ;;; Γ ⊢ t ≤[pb] u.
  Proof using wfΣ.
    move=> r; eapply red_ws_cumul_pb_left; tea.
    eapply ws_cumul_pb_refl; eauto with fvs.
  Qed.

  Lemma red_ws_cumul_pb_inv {pb Γ t u} :
    Σ ;;; Γ ⊢ t ⇝ u ->
    Σ ;;; Γ ⊢ u ≤[pb] t.
  Proof using wfΣ.
    move=> r; eapply red_ws_cumul_pb_right; tea.
    eapply ws_cumul_pb_refl; eauto with fvs.
  Qed.
End RedConv.

#[global] Hint Resolve red_conv red_ws_cumul_pb red_ws_cumul_pb_inv : pcuic.

Set SimplIsCbn.

Definition conv_cum {cf:checker_flags} pb Σ Γ T T' :=
  Σ ;;; Γ |- T <=[pb] T'.

Notation ws_decl Γ d := (on_free_vars_decl (shiftnP #|Γ| xpred0) d).

Definition open_decl (Γ : context) := { d : context_decl | ws_decl Γ d }.
Definition open_decl_proj {Γ : context} (d : open_decl Γ) := proj1_sig d.
Coercion open_decl_proj : open_decl >-> context_decl.

Definition vass_open_decl {Γ : closed_context} (na : binder_annot name) (t : open_term Γ) : open_decl Γ :=
  exist (vass na t) (proj2_sig t).

Definition ws_cumul_decls {cf : checker_flags} (pb : conv_pb) (Σ : global_env_ext)
  (Γ : context) (d : context_decl) (d' : context_decl) :=
  All_decls_alpha_pb pb (fun pb => @ws_cumul_pb cf pb Σ Γ) d d'.

Lemma ws_cumul_decls_wf_decl_left {cf} {pb} {Σ} {wfΣ : wf Σ} {Γ d d'} :
  ws_cumul_decls pb Σ Γ d d' -> ws_decl Γ d.
Proof.
  intros []; cbn; eauto with fvs.
Qed.

Lemma ws_cumul_decls_wf_decl_right {cf} {pb} {Σ} {wfΣ : wf Σ} {Γ d d'} :
  ws_cumul_decls pb Σ Γ d d' -> ws_decl Γ d'.
Proof.
  intros []; cbn; eauto with fvs.
Qed.
#[global] Hint Immediate ws_cumul_decls_wf_decl_left ws_cumul_decls_wf_decl_right : fvs.

Lemma ws_cumul_decls_cumul_pb_decls {cf : checker_flags} (pb : conv_pb) {Σ : global_env_ext} {wfΣ : wf Σ}
  {Γ Γ' : context} {d d'} :
  ws_cumul_decls pb Σ Γ d d' ->
  cumul_pb_decls cumulAlgo_gen pb Σ Γ Γ' d d'.
Proof.
  intros. intuition eauto with fvs.
  destruct X; destruct pb; constructor; pcuic.
Qed.

Lemma into_ws_cumul_decls {cf : checker_flags} {pb : conv_pb} {Σ : global_env_ext} {wfΣ : wf Σ}
  (Γ Γ' : context) d d' :
  cumul_pb_decls cumulAlgo_gen pb Σ Γ Γ' d d' ->
  on_free_vars_ctx xpred0 Γ ->
  on_free_vars_ctx xpred0 Γ' ->
  is_open_decl Γ d ->
  is_open_decl Γ d' ->
  ws_cumul_decls pb Σ Γ d d'.
Proof.
  case: pb; move=> pb clΓ clΓ' isd isd';
    destruct pb; cbn; constructor; auto; try inv_on_free_vars; eauto with fvs.
  all:try apply: into_ws_cumul_pb; tea; eauto 3 with fvs.
Qed.

Lemma ws_cumul_decls_inv {cf} (pb : conv_pb) {Σ : global_env_ext} {wfΣ : wf Σ}
  {Γ Γ' : context} {d d'} :
  ws_cumul_decls pb Σ Γ d d' ->
  [× on_free_vars_ctx xpred0 Γ, is_open_decl Γ d, is_open_decl Γ d' & cumul_pb_decls cumulAlgo_gen pb Σ Γ Γ' d d'].
Proof.
  intros. split; eauto with fvs.
  - destruct X; now destruct eqt.
  - now eapply ws_cumul_decls_cumul_pb_decls.
Qed.

#[global]
Instance ws_cumul_decls_trans {cf : checker_flags} {pb} {Σ : global_env_ext} {wfΣ : wf Σ} {Γ : context} :
  Transitive (ws_cumul_decls pb Σ Γ).
Proof.
  intros d d' d''.
  rewrite /ws_cumul_decls.
  intros ond ond'; destruct ond; depelim ond'.
  econstructor; now etransitivity.
  econstructor; etransitivity; tea.
Qed.

Inductive wt_cumul_pb_decls {cf : checker_flags} (pb : conv_pb) (Σ : global_env_ext) (Γ Γ' : context) : context_decl -> context_decl -> Type :=
| wt_cumul_pb_vass {na na' : binder_annot name} {T T' : term} :
    isType Σ Γ T -> isType Σ Γ' T' ->
    conv_cum pb Σ Γ T T' ->
    eq_binder_annot na na' ->
    wt_cumul_pb_decls pb Σ Γ Γ' (vass na T) (vass na' T')
| wt_cumul_pb_vdef {na na' : binder_annot name} {b b' T T'} :
    eq_binder_annot na na' ->
    isType Σ Γ T -> isType Σ Γ' T' ->
    Σ ;;; Γ |- b : T -> Σ ;;; Γ' |- b' : T' ->
    Σ ;;; Γ |- b = b' ->
    conv_cum pb Σ Γ T T' ->
    wt_cumul_pb_decls pb Σ Γ Γ' (vdef na b T) (vdef na' b' T').
Derive Signature for wt_cumul_pb_decls.

Definition ws_cumul_ctx_pb {cf:checker_flags} (pb : conv_pb) (Σ : global_env_ext) (Γ Γ' : context) :=
  All2_fold (fun Γ Γ' => ws_cumul_decls pb Σ Γ) Γ Γ'.

Notation "Σ ⊢ Γ ≤[ pb ] Δ" := (ws_cumul_ctx_pb pb Σ Γ Δ) (at level 50, Γ, Δ at next level,
  format "Σ  ⊢  Γ  ≤[ pb ]  Δ") : pcuic.

Notation "Σ ⊢ Γ = Δ" := (ws_cumul_ctx_pb Conv Σ Γ Δ) (at level 50, Γ, Δ at next level,
  format "Σ  ⊢  Γ  =  Δ") : pcuic.

Notation "Σ ⊢ Γ ≤ Δ" := (ws_cumul_ctx_pb Cumul Σ Γ Δ) (at level 50, Γ, Δ at next level,
  format "Σ  ⊢  Γ  ≤  Δ") : pcuic.

Lemma ws_cumul_ctx_pb_closed_right {cf:checker_flags} {pb : conv_pb} {Σ} {wfΣ : wf Σ} {Γ Γ'}:
  ws_cumul_ctx_pb pb Σ Γ Γ' -> is_closed_context Γ'.
Proof.
  intros X. red in X.
  induction X; auto.
  rewrite on_free_vars_ctx_snoc IHX /= //.
  rewrite -(All2_fold_length X); eauto with fvs.
Qed.

Lemma ws_cumul_ctx_pb_closed_left {cf:checker_flags} {pb : conv_pb} {Σ} {wfΣ : wf Σ} {Γ Γ'}:
  ws_cumul_ctx_pb pb Σ Γ Γ' -> is_closed_context Γ.
Proof.
  intros X. red in X.
  induction X; auto.
  rewrite on_free_vars_ctx_snoc IHX /=.
  eauto with fvs.
Qed.

#[global] Hint Resolve ws_cumul_ctx_pb_closed_left ws_cumul_ctx_pb_closed_right : fvs.

Definition wt_cumul_ctx_pb {cf:checker_flags} (pb : conv_pb) (Σ : global_env_ext) :=
  All2_fold (wt_cumul_pb_decls pb Σ).

Notation "Σ ⊢ Γ ≤[ pb ] Δ ✓" := (wt_cumul_ctx_pb pb Σ Γ Δ) (at level 50, Γ, Δ at next level,
  format "Σ  ⊢  Γ  ≤[ pb ]  Δ  ✓") : pcuic.

Notation wt_cumul_context Σ := (wt_cumul_ctx_pb Cumul Σ).
Notation wt_conv_context Σ := (wt_cumul_ctx_pb Conv Σ).

Section WtContextConversion.
  Context {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ}.

  Definition wt_decl Γ d :=
    match d with
    | {| decl_body := None; decl_type := ty |} => isType Σ Γ ty
    | {| decl_body := Some b; decl_type := ty |} => isType Σ Γ ty × Σ ;;; Γ |- b : ty
    end.

  Lemma wf_local_All_fold Γ :
    wf_local Σ Γ <~>
    All_fold wt_decl Γ.
  Proof using Type.
    split.
    - induction 1; constructor; auto.
      red in t0, t1. cbn. split; auto.
    - induction 1; [constructor|].
      destruct d as [na [b|] ty]; cbn in p; constructor; intuition auto.
  Qed.

  Lemma wt_cumul_ctx_pb_forget {pb} {Γ Γ' : context} :
    wt_cumul_ctx_pb pb Σ Γ Γ' ->
    [× wf_local Σ Γ, wf_local Σ Γ' & cumul_pb_context cumulAlgo_gen pb Σ Γ Γ'].
  Proof using Type.
    move=> wteq.
    eapply (All2_fold_impl (Q:=fun Γ Γ' d d' => wt_decl Γ d × wt_decl Γ' d' × cumul_pb_decls cumulAlgo_gen pb Σ Γ Γ' d d')) in wteq.
    2:{ intros ???? []; intuition (cbn; try constructor; auto). }
    eapply All2_fold_All_fold_mix_inv in wteq as [wteq [wfΓ wfΓ']].
    eapply wf_local_All_fold in wfΓ. eapply wf_local_All_fold in wfΓ'.
    split; auto.
  Qed.

  Lemma into_wt_cumul_ctx_pb {pb} {Γ Γ' : context} {T U : term} :
    wf_local Σ Γ -> wf_local Σ Γ' ->
    cumul_pb_context cumulAlgo_gen pb Σ Γ Γ' ->
    wt_cumul_ctx_pb pb Σ Γ Γ'.
  Proof using Type.
    move=> /wf_local_All_fold wfΓ /wf_local_All_fold wfΓ'.
    destruct pb=> eq.
    eapply All2_fold_All_fold_mix in eq; tea.
    eapply All2_fold_impl; tea; clear => Γ Γ' d d' [wtd [wtd' cum]] /=.
    destruct cum; cbn in wtd, wtd'; constructor; intuition auto.
    eapply All2_fold_All_fold_mix in eq; tea.
    eapply All2_fold_impl; tea; clear => Γ Γ' d d' [wtd [wtd' cum]] /=.
    destruct cum; cbn in wtd, wtd'; constructor; intuition auto.
  Qed.

  Lemma wt_ws_ws_cumul_ctx_pb {pb} {Γ Γ' : context} {T U : term} :
    wt_cumul_ctx_pb pb Σ Γ Γ' ->
    ws_cumul_ctx_pb pb Σ Γ Γ'.
  Proof using wfΣ.
    intros a; eapply All2_fold_impl_ind; tea.
    intros ???? wt ws eq;
    pose proof (All2_fold_length wt).
    destruct eq.
    - pose proof (isType_wf_local i).
      eapply wf_local_closed_context in X.
      eapply isType_open in i. apply isType_open in i0.
      eapply into_ws_cumul_decls with Δ; eauto with fvs.
      constructor; auto.
      rewrite (All2_fold_length ws) //.
    - pose proof (isType_wf_local i).
      eapply wf_local_closed_context in X.
      eapply isType_open in i. apply isType_open in i0.
      eapply PCUICClosedTyp.subject_closed in t.
      eapply PCUICClosedTyp.subject_closed in t0.
      eapply (@closedn_on_free_vars xpred0) in t.
      eapply (@closedn_on_free_vars xpred0) in t0.
      eapply into_ws_cumul_decls with Δ; eauto with fvs.
      destruct pb; constructor; auto.
      rewrite (All2_fold_length ws) //; eauto with fvs.
  Qed.

  Lemma ws_cumul_ctx_pb_inv {pb} {Γ Γ' : context} :
    ws_cumul_ctx_pb pb Σ Γ Γ' ->
    [× on_free_vars_ctx xpred0 Γ, on_free_vars_ctx xpred0 Γ' & cumul_pb_context cumulAlgo_gen pb Σ Γ Γ'].
  Proof using wfΣ.
    move=> wteq.
    split; eauto with fvs.
    eapply All2_fold_impl; tea; move=> ???? []; constructor; eauto with pcuic.
    all:try now eapply ws_cumul_pb_forget in eqt.
  Qed.

  #[global]
  Instance ws_cumul_decls_sym Γ : Symmetric (ws_cumul_decls Conv Σ Γ).
  Proof using Type.
    move=> x y [na na' T T' eqan cv|na na' b b' T T' eqna eqb eqT];
    constructor; now symmetry.
  Qed.

  Lemma ws_cumul_ctx_pb_forget {pb Γ Γ'} :
    ws_cumul_ctx_pb pb Σ Γ Γ' -> cumul_pb_context cumulAlgo_gen pb Σ Γ Γ'.
  Proof using wfΣ.
    now move/ws_cumul_ctx_pb_inv => [].
  Qed.

  Lemma ws_cumul_ctx_pb_refl pb Γ : is_closed_context Γ -> ws_cumul_ctx_pb pb Σ Γ Γ.
  Proof using wfΣ.
    move=> onΓ. cbn.
    move/on_free_vars_ctx_All_fold: onΓ => a.
    eapply (All_fold_All2_fold_impl a). clear -wfΣ.
    move=> Γ d a IH ond.
    move/on_free_vars_ctx_All_fold: a => clΓ.
    eapply (into_ws_cumul_decls _ Γ); auto.
    destruct d as [na [b|] ty]; constructor; auto; reflexivity.
  Qed.

End WtContextConversion.


Require Import Coq.omega.Omega.
Require Import Bedrock.IL Bedrock.SepIL.
Require Import Bedrock.Word Bedrock.Memory.
Import List.
Require Import Bedrock.DepList Bedrock.EqdepClass.
Require Import Bedrock.PropX.
Require Import Bedrock.Expr Bedrock.SepExpr Bedrock.SepCancel.
Require Import Bedrock.Prover Bedrock.ILEnv.
Require Import Bedrock.Tactics Bedrock.Reflection.
Require Import Bedrock.TacPackIL.
Require Bedrock.ExprUnify.

Set Implicit Arguments.
Set Strict Implicit.

Module U := ExprUnify.UNIFIER.
Module CANCEL := SepCancel.Make U SepIL.SH.

Section existsSubst.
  Variable types : list type.
  Variable funcs : functions types.
  Variable meta_base : env types.
  Variable var_env : env types.
  Variable sub : U.Subst types.

  Definition ExistsSubstNone (_ : tvar) (_ : expr types) :=
    False.

  Fixpoint substInEnv (from : nat) (vals : env types) (ret : env types -> Prop) : Prop :=
    match vals with
      | nil => ret nil
      | val :: vals =>
        match U.Subst_lookup from sub with
          | None => substInEnv (S from) vals (fun e => ret (val :: e))
          | Some v =>
            match exprD funcs meta_base var_env v (projT1 val) with
              | None => ExistsSubstNone (projT1 val) v
              | Some v' => projT2 val = v' /\ substInEnv (S from) vals (fun e => ret (existT _ (projT1 val) v' :: e))
            end
        end
    end.

  Fixpoint existsMaybe (vals : list { t : tvar & option (tvarD types t) }) (ret : env types -> Prop) : Prop :=
    match vals with
      | nil => ret nil
      | existT t None :: vals => exists x : tvarD types t, existsMaybe vals (fun e => ret (existT _ t x :: e))
      | existT t (Some v) :: vals => existsMaybe vals (fun e => ret (existT _ t v :: e))
    end.

End existsSubst.

Definition existsSubst types funcs var_env sub (from : nat) (vals : list { t : tvar & option (tvarD types t) }) (ret : env types -> Prop) :=
  existsMaybe vals (fun e => @substInEnv types funcs e var_env sub from e ret).

Fixpoint consistent {ts} (vals : list { x : tvar & option (tvarD ts x) }) (e : list { x : tvar & tvarD ts x }) : Prop :=
  match vals , e with
    | nil , nil => True
    | existT t None :: vals , existT t' _ :: e =>
      t = t' /\ @consistent _ vals e
    | existT t (Some v) :: vals , existT t' v' :: e =>
      match equiv_dec t t' return Prop with
        | left pf =>
          v' = match (pf : t = t') in _ = t return tvarD ts t with
                 | refl_equal => v
               end /\ @consistent _ vals e
        | right _ => False
      end
    | _ , _ => False
  end.

Lemma ex_iff : forall T (P P' : T -> Prop),
  (forall x, P x <-> P' x) ->
  ((exists x, P x) <-> (exists x, P' x)).
Proof. split; intuition; destruct H0 as [ x ? ]; exists x; firstorder. Qed.

Theorem existsMaybe_sem : forall types vals (ret : env types -> Prop),
  existsMaybe vals ret <->
  existsEach (map (@projT1 _ _) vals) (fun e => consistent vals e /\ ret e).
Proof.
  induction vals; simpl; intros.
  { intuition. }
  { destruct a. destruct o.
    { rewrite IHvals. intuition. exists t. apply existsEach_sem. apply existsEach_sem in H.
      destruct H. exists x0. simpl in *. rewrite EquivDec_refl_left. intuition.
      destruct H. apply existsEach_sem. apply existsEach_sem in H. destruct H.
      exists x1. simpl in *. rewrite EquivDec_refl_left in H. intuition; subst; auto. }
    { simpl. eapply ex_iff. intros. rewrite IHvals.
      intuition; apply existsEach_sem in H; apply existsEach_sem; destruct H; exists x1; intuition. } }
Qed.

Lemma substInEnv_sem : forall types funcs meta_env var_env sub vals from ret,
  @substInEnv types funcs meta_env var_env sub from vals ret <->
  (U.Subst_equations_to funcs meta_env var_env sub from vals /\ ret vals).
Proof.
  induction vals; simpl; intros.
  { intuition. }
  { destruct a; simpl in *.
    consider (U.Subst_lookup from sub); simpl; intros.
    consider (exprD funcs meta_env var_env e x); simpl; intros.
    { rewrite IHvals. intuition; subst; auto. }
    { intuition. }
    { rewrite IHvals. intuition. } }
Qed.

Lemma existsSubst_sem : forall ts (funcs : functions ts) vals sub vars_env from ret,
  existsSubst funcs vars_env sub from vals ret <->
  existsEach (map (@projT1 _ _) vals) (fun meta_env =>
    consistent vals meta_env /\ U.Subst_equations_to funcs meta_env vars_env sub from meta_env /\ ret meta_env).
Proof.
  intros. unfold existsSubst.
  rewrite existsMaybe_sem. rewrite existsEach_sem. rewrite existsEach_sem.
  apply ex_iff. intros. rewrite substInEnv_sem. intuition.
Qed.

Lemma AllProvable_impl_AllProvable : forall ts (funcs : functions ts) U G P ps,
  AllProvable funcs U G ps ->
  AllProvable_impl funcs U G P ps ->
  P.
Proof. clear. induction ps; simpl; intros; eauto. intuition. Qed.

Section canceller.
  Variable ts : list type.
  Let types := Env.repr BedrockCoreEnv.core ts.
  Variable funcs : functions types.
  Variable preds : SEP.predicates types BedrockCoreEnv.pc BedrockCoreEnv.st.
  Variable algos : ILAlgoTypes.AllAlgos ts.

  Record CancellerResult : Type :=
  { AllExt : variables
  ; ExExt  : variables
  ; Lhs    : SH.SHeap types BedrockCoreEnv.pc BedrockCoreEnv.st
  ; Rhs    : SH.SHeap types BedrockCoreEnv.pc BedrockCoreEnv.st
  ; Subst  : U.Subst types
  }.

  Definition canceller (uvars : list tvar) (hyps : Expr.exprs types)
    (lhs rhs : SEP.sexpr types BedrockCoreEnv.pc BedrockCoreEnv.st) : option CancellerResult :=
    let prover :=
      match ILAlgoTypes.Prover algos with
        | None => provers.ReflexivityProver.reflexivityProver
        | Some p => p
      end
    in
    let hints :=
      match ILAlgoTypes.Hints algos with
        | None => UNF.default_hintsPayload _ _ _
        | Some h => h
      end
    in
    let (ql, lhs) := SH.hash lhs in
    let facts := Summarize prover (map (liftExpr 0 0 0 (length ql)) hyps ++ SH.pures lhs) in
    let pre :=
      {| UNF.Vars  := rev ql
       ; UNF.UVars := uvars
       ; UNF.Heap  := lhs
      |}
    in
    match UNF.forward hints prover 10 facts pre with
      | ({| UNF.Vars := vars' ; UNF.UVars := uvars' ; UNF.Heap := lhs |}, n_forward) =>
        let (qr, rhs) := SH.hash rhs in
        let rhs :=
          UNF.HEAP_FACTS.sheapSubstU 0 (length qr) (length uvars') rhs
        in
        let post :=
          {| UNF.Vars  := vars'
           ; UNF.UVars := uvars' ++ rev qr
           ; UNF.Heap  := rhs
          |}
        in
        match UNF.backward hints prover 10 facts post with
          | ({| UNF.Vars := vars' ; UNF.UVars := uvars' ; UNF.Heap := rhs |}, n_backward) =>
            let new_vars  := vars' in
            let new_uvars := skipn (length uvars) uvars' in
            let bound := length uvars' in
            match CANCEL.sepCancel preds prover bound facts lhs rhs (U.Subst_empty _) false with
              | Some (l,r,s) =>
                Some {| AllExt := new_vars
                      ; ExExt  := new_uvars
                      ; Lhs    :=
                        (** TODO: this is a hack for the moment to ensure that
                         ** the pure premises are well typed without the new
                         ** unification variables
                         **)
                        {| SH.impures := SH.impures l
                         ; SH.pures   := SH.pures lhs
                         ; SH.other   := SH.other l
                         |}
                      ; Rhs    := r
                      ; Subst  := s
                      |}
              | None =>
                if match ql , qr with
                     | nil , nil =>
                       match SH.pures lhs , SH.pures rhs with
                         | nil, nil =>
                           if EqNat.beq_nat n_forward 10 then EqNat.beq_nat n_backward 10 else false
                         | _ , _ => false
                       end
                     | _ , _ => false
                   end then
                  None
                else
                  Some {| AllExt := new_vars
                        ; ExExt  := new_uvars
                        ; Lhs    := lhs
                        ; Rhs    := rhs
                        ; Subst  := U.Subst_empty _
                        |}
            end
        end
    end.

  Lemma AllProvable_and_sem : forall U G P Ps,
    AllProvable_and funcs U G P Ps <-> (AllProvable funcs U G Ps /\ P).
  Proof. induction Ps; simpl; intros; intuition auto. Qed.
  Lemma app_inj_length : forall T (a b c d : list T),
    a ++ b = c ++ d ->
    length a = length c ->
    a = c /\ b = d.
  Proof.
    induction a; destruct c; simpl; intros; think; try solve [ intuition ].
    inversion H; subst.  eapply IHa in H3. intuition; subst; auto. omega.
  Qed.
  Lemma WellTyped_env_app : forall ts a b c d,
    WellTyped_env a c ->
    WellTyped_env b d ->
    WellTyped_env (types := ts) (a ++ b) (c ++ d).
  Proof. clear.
    intros. unfold WellTyped_env in *. unfold typeof_env in *. subst.
    rewrite map_app. reflexivity.
  Qed.
  Ltac t_list_length := repeat (rewrite typeof_env_length || rewrite rev_length || rewrite map_length || rewrite app_length).
  Hint Extern 1 (_ = _) => t_list_length; auto : list_length.

  Ltac env_resolution :=
    repeat (rewrite typeof_env_app || unfold typeof_env || rewrite map_app || rewrite map_rev || (f_equal; []) || assumption).

  Lemma consistent_app : forall ts a b c,
    consistent (ts := ts) (a ++ b) c ->
    consistent a (firstn (length a) c) /\ consistent b (skipn (length a) c).
  Proof. clear.
    induction a; simpl; intros; auto.
    destruct a. destruct o. destruct c; try contradiction. destruct s. destruct (equiv_dec x x0); try contradiction.
    destruct H. eapply IHa in H0. intuition.
    destruct c; try contradiction. destruct s. destruct H. apply IHa in H0. intuition.
  Qed.
  Lemma consistent_Some : forall ts a c,
    consistent (ts := ts) (map (fun x => existT _ (projT1 x) (Some (projT2 x))) a) c ->
    a = c.
  Proof.
    induction a; destruct c; simpl; intros; try contradiction; auto.
    destruct s. destruct a; simpl in *. destruct (equiv_dec x0 x); try contradiction.
    unfold equiv in e. intuition; subst. f_equal; eauto.
  Qed.
  Lemma skipn_length : forall T a (b : list T),
    length (skipn a b) = length b - a.
  Proof. induction a; destruct b; simpl; intros; auto. Qed.

  Lemma himp_remove_pure_p : forall cs U G p P Q,
    (Provable funcs U G p ->
      SH.SE.himp funcs preds U G cs P Q) ->
    SH.SE.himp funcs preds U G cs (SEP.Star (@SEP.Inj _ _ _ p) P) Q.
  Proof. clear.
    intros. unfold SH.SE.himp. simpl. unfold Provable in *.
    destruct (exprD funcs U G p tvProp); eapply himp_star_pure_c; intuition.
  Qed.
  Lemma himp_remove_pures_p : forall cs U G ps P Q,
    (AllProvable funcs U G ps ->
      SH.SE.himp funcs preds U G cs P Q) ->
    SH.SE.himp funcs preds U G cs (SH.starred (@SEP.Inj _ _ _) ps P) Q.
  Proof. clear.
    induction ps; intros.
    { rewrite SH.starred_nil. apply H. exact I. }
    { rewrite SH.starred_cons. apply himp_remove_pure_p. intros.
      eapply IHps. intro. apply H; simpl; auto. }
  Qed.
  Lemma himp_remove_pure_c : forall cs U G p P Q,
    Provable funcs U G p ->
    SH.SE.himp funcs preds U G cs P Q ->
    SH.SE.himp funcs preds U G cs P (SEP.Star (@SEP.Inj _ _ _ p) Q).
  Proof. clear.
    intros. unfold SH.SE.himp. simpl. unfold Provable in *.
    destruct (exprD funcs U G p tvProp); eapply himp_star_pure_cc; intuition.
  Qed.
  Lemma himp_remove_pures_c : forall cs U G ps P Q,
    AllProvable funcs U G ps ->
    SH.SE.himp funcs preds U G cs P Q ->
    SH.SE.himp funcs preds U G cs P (SH.starred (@SEP.Inj _ _ _) ps Q).
  Proof. clear.
    induction ps; intros.
    { rewrite SH.starred_nil. apply H0. }
    { rewrite SH.starred_cons. simpl in *. apply himp_remove_pure_c; intuition. }
  Qed.

  Lemma ApplyCancelSep_with_eq' :
    forall (algos_correct : ILAlgoTypes.AllAlgos_correct funcs preds algos),
    forall (meta_env : env types) (hyps : Expr.exprs types),
    Expr.AllProvable funcs meta_env nil hyps ->
    forall (l r : SEP.sexpr types BedrockCoreEnv.pc BedrockCoreEnv.st) res cs,
    forall (WTR : SEP.WellTyped_sexpr (typeof_funcs funcs) (SEP.typeof_preds preds) (typeof_env meta_env) nil r = true),
    canceller (typeof_env meta_env) hyps l r = Some res ->
    match res with
      | {| AllExt := new_vars
         ; ExExt  := new_uvars
         ; Lhs    := lhs'
         ; Rhs    := rhs'
         ; Subst  := subst
         |} =>
        Expr.forallEach new_vars (fun nvs : Expr.env types =>
          let var_env := nvs in
          Expr.AllProvable_impl funcs meta_env var_env
          (existsSubst funcs var_env subst 0
            (map (fun x => existT (fun t => option (tvarD types t)) (projT1 x) (Some (projT2 x))) meta_env ++
             map (fun x => existT (fun t => option (tvarD types t)) x None) new_uvars)
            (fun meta_env : Expr.env types =>
                (Expr.AllProvable_and funcs meta_env var_env
                  (himp cs
                    (SEP.sexprD funcs preds meta_env var_env
                      (SH.sheapD (SH.Build_SHeap _ _ (SH.impures lhs') nil (SH.other lhs'))))
                    (SEP.sexprD funcs preds meta_env var_env
                      (SH.sheapD (SH.Build_SHeap _ _ (SH.impures rhs') nil (SH.other rhs')))))
                  (SH.pures rhs')) ))
            (SH.pures lhs'))
    end ->
    himp cs (@SEP.sexprD _ _ _ funcs preds meta_env nil l)
            (@SEP.sexprD _ _ _ funcs preds meta_env nil r).
  Proof.
    Opaque UNF.backward UNF.forward Env.repr.
    intros. unfold canceller in *.
    assert (PC : ProverT_correct
              match ILAlgoTypes.Prover algos with
              | Some p => p
              | None => ReflexivityProver.reflexivityProver
              end funcs).
    { generalize (ILAlgoTypes.Acorrect_Prover algos_correct).
      destruct (ILAlgoTypes.Prover algos); intros; auto.
      apply ReflexivityProver.reflexivityProver_correct. }
    generalize dependent (match ILAlgoTypes.Prover algos with
                            | Some p => p
                            | None => ReflexivityProver.reflexivityProver
                          end).
    match goal with
      | [ |- context [ ?X ] ] =>
        match X with
          | match ILAlgoTypes.Hints _ with _ => _ end =>
            assert (HC : UNF.hintsSoundness funcs preds X); [ | generalize dependent X ]
        end
    end.
    { generalize (ILAlgoTypes.Acorrect_Hints algos_correct).
      destruct (ILAlgoTypes.Hints algos); auto using UNF.hintsSoundness_default. }
    intros h HC p ? PC.
    consider (SH.hash l); intros.
    rewrite SH.hash_denote. rewrite H0; clear H0; simpl.
    consider (SH.hash r); intros.
    rewrite SH.hash_denote with (s := r). rewrite H0; simpl.
    rewrite UNF.himp_existsEach_ST_EXT_existsEach.
    rewrite UNF.ST_EXT.himp_existsEach_p; [ reflexivity | intros ].
    rewrite app_nil_r.
    apply CANCEL.HEAP_FACTS.himp_pull_pures; intro.
    match goal with
      | [ H : context [ Summarize ?P ?ps ] |- _ ] =>
        assert (Valid PC meta_env (rev G) (Summarize P ps)); [ | generalize dependent (Summarize P ps); intros ]
    end.
    { eapply Summarize_correct.
      apply AllProvable_app; auto.
      revert H; clear - H3. induction hyps; simpl; intros; auto.
      intuition. clear - H0 H3. unfold Provable in *.
      generalize (liftExpr_ext funcs meta_env nil nil nil (rev G) nil a tvProp); simpl.
      rewrite app_nil_r. rewrite rev_length. subst. rewrite map_length.
      intro. rewrite H in *. auto. }
    match goal with
      | [ H : match ?X with _ => _ end = _ |- _ ] => consider X
    end; intros.
    apply CANCEL.SEP_FACTS.himp_WellTyped_sexpr; intro.

    (** Forward **)
    destruct (UNF.forwardLength _ _ _ _ _ H2).
    assert (SH.WellTyped_sheap (typeof_funcs funcs) (UNF.SE.typeof_preds preds) (typeof_env meta_env) (rev v) s = true).
    { rewrite SH.WellTyped_sheap_WellTyped_sexpr. rewrite <- H3. rewrite <- map_rev. apply H7. }

    generalize (@UNF.forward_WellTyped _ _ _ _ _ _ _ HC _ _ _ _ _ H2 H9); intro.
    simpl in *.
    assert (WellTyped_env (rev v) (rev G)).
    { unfold WellTyped_env. subst. rewrite <- map_rev. auto. }
    eapply UNF.forwardOk  with (cs := cs) in H2; simpl; eauto using typeof_env_WellTyped_env.
    simpl in H2. etransitivity; [ eapply H2 | clear H11; simpl in * ].
    rewrite UNF.ST_EXT.himp_existsEach_p; [ reflexivity | intros ].
    destruct H8.
    (** NOTE: I can't shift s0 around until I can witness the existential **)

    (** Open up everything **)
    destruct u.
    consider (UNF.backward h p 10 f
           {| UNF.Vars := Vars
            ; UNF.UVars := UVars ++ rev v0
            ; UNF.Heap := UNF.HEAP_FACTS.sheapSubstU 0 (length v0) (length UVars) s0 |}); intros.
    destruct (UNF.backwardLength _ _ _ _ _ H6); simpl in *.
    destruct u.

    assert (AllExt res = Vars0 /\ ExExt res = skipn (length (typeof_env meta_env)) UVars0
            /\ SH.pures (Lhs res) = SH.pures Heap).
    { clear - H13.
      match goal with
        | [ H : match ?X with _ => _ end = _ |- _ ] => destruct X
      end; intros. destruct p0; destruct p0. inversion H13; auto.
      match goal with
        | [ H : match ?X with _ => _ end = _ |- _ ] => destruct X
      end; try congruence. inversion H13; auto. }
    intuition; subst.

    rewrite ListFacts.rw_skipn_app in H11 by (auto with list_length).

    destruct res. simpl in *. subst AllExt0; subst ExExt0.
    eapply forallEach_sem with (env := rev G ++ G0) in H1; [ | solve [ env_resolution ] ].

    eapply (@CANCEL.HEAP_FACTS.himp_pull_pures types _ _ funcs preds cs meta_env (rev G ++ G0) Heap). intro.
    eapply AllProvable_impl_AllProvable in H1; [ clear H3 | rewrite H19; assumption ].

    apply existsSubst_sem in H1. apply existsEach_sem in H1.
    destruct H1. intuition.
    assert (meta_env = firstn (length meta_env) x1 /\
            typeof_env (skipn (length (rev v0)) (skipn (length meta_env) x1)) = x0 /\
            typeof_env (firstn (length (rev v0)) (skipn (length meta_env) x1)) = rev v0).
    { subst. clear - H3 H1.
      generalize (typeof_env_length x1). rewrite H3; intros.
      rewrite <- firstn_skipn with (n := length meta_env) (l := x1) in H3.
      repeat (rewrite map_app in *  || rewrite map_map in * || rewrite map_id in * || rewrite app_ass in *
        || rewrite ListFacts.rw_skipn_app in * by eauto || rewrite typeof_env_app in * ).
      simpl in *. rewrite typeof_env_app in *. eapply app_inj_length in H3.
      Focus 2. revert H. t_list_length. rewrite firstn_length. intro. rewrite min_l; omega.
      destruct H3.
      rewrite <- firstn_skipn with (n := length (rev v0)) (l := skipn (length meta_env) x1) in H2.
      rewrite typeof_env_app in *.
      eapply app_inj_length in H2. destruct H2. intuition.
      { eapply consistent_app in H1. destruct H1; clear - H1.
        revert H1. t_list_length. intros.
        eapply consistent_Some in H1. auto. }
      revert H. t_list_length. intro. rewrite firstn_length; rewrite min_l; auto.
      rewrite skipn_length. omega. }
    intuition. clear H3 H1.

    eapply AllProvable_and_sem in H14. destruct H14.
    rewrite app_ass in *.

    subst UVars0.
    assert (SH.WellTyped_sheap (typeof_funcs funcs) (UNF.SE.typeof_preds preds)
     (typeof_env meta_env ++ rev v0)
     (rev (map (projT1 (P:=tvarD types)) G) ++ x)
     (UNF.HEAP_FACTS.sheapSubstU 0 (length v0) (length (typeof_env meta_env))
        s0) = true).
    { rewrite <- SH.WellTyped_sheap_WellTyped_sexpr in H7.
      generalize (@UNF.HEAP_FACTS.sheapSubstU_WellTyped types BedrockCoreEnv.pc BedrockCoreEnv.st (typeof_funcs funcs) (UNF.SE.typeof_preds preds) (typeof_env meta_env) nil (rev v0) nil s0); simpl.
      rewrite app_nil_r. intro XX.
      rewrite SH.WellTyped_hash in WTR. rewrite H0 in WTR. simpl in WTR. rewrite app_nil_r in WTR.
      apply XX in WTR. clear XX.
      eapply SH.WellTyped_sheap_weaken with (tU' := nil) (tG := nil) (tG' := (rev (map (projT1 (P:=tvarD types)) G) ++ x)) in WTR.
      simpl in WTR. rewrite app_nil_r in WTR.
      rewrite Plus.plus_0_r in *. rewrite rev_length in WTR. apply WTR. }

    generalize (@UNF.backward_WellTyped _ _ _ _ _ _ _ HC _ _ _ _ _ H6 H14); simpl.
    eapply UNF.backwardOk with (cs := cs) in H6; simpl in *.
    2: eassumption.
    2: solve [ rewrite <- H18; eapply WellTyped_env_app; eauto using typeof_env_WellTyped_env ].
    Focus 2.
    rewrite <- map_rev.
    eapply WellTyped_env_app. eapply typeof_env_WellTyped_env.
    instantiate (1 := G0). symmetry. apply H11.
    2: eassumption.
    2: solve [ eapply Valid_weaken; eassumption ].
    intro.

    (** **)
    rewrite UNF.himp_existsEach_ST_EXT_existsEach.
    eapply UNF.ST_EXT.himp_existsEach_c. exists (rev (firstn (length (rev v0)) (skipn (length meta_env) x1))); split.
    { rewrite map_rev. unfold typeof_env in H18. rewrite H18. apply rev_involutive. }
    rewrite rev_involutive.

    (** In order to call the canceller, they must have the same environments. **)
    assert (SH.SE.ST.heq cs
              (SH.SE.sexprD funcs preds meta_env (rev G ++ G0) (SH.sheapD Heap))
              (SH.SE.sexprD funcs preds x1 (rev G ++ G0) (SH.sheapD Heap))).
    { rewrite <- firstn_skipn with (l := x1) (n := length meta_env).
      rewrite <- H15.
      generalize (@CANCEL.SEP_FACTS.sexprD_weaken_wt types _ _ funcs preds cs meta_env (skipn (length meta_env) x1) nil
        (SH.sheapD Heap) (rev G ++ G0)).
      rewrite app_nil_r. intro XX; apply XX; clear XX.
      rewrite <- SH.WellTyped_sheap_WellTyped_sexpr. rewrite <- H10. f_equal.
      rewrite typeof_env_app. f_equal. rewrite <- map_rev. reflexivity.
      rewrite <- H11. reflexivity. }
    etransitivity; [ eapply H17 | clear H17 ].

    assert (SH.SE.ST.heq cs
              (SH.SE.sexprD funcs preds (meta_env ++ firstn (length (rev v0)) (skipn (length meta_env) x1)) (rev G ++ G0) (SH.sheapD (UNF.HEAP_FACTS.sheapSubstU 0 (length v0)
                       (length (typeof_env meta_env)) s0)))
              (UNF.SE.sexprD funcs preds meta_env
                (firstn (length (rev v0)) (skipn (length meta_env) x1) ++ nil)
                (SH.sheapD s0))).
    { generalize (@UNF.HEAP_FACTS.sheapSubstU_sheapD types _ _ funcs preds cs
        meta_env nil (firstn (length (rev v0)) (skipn (length meta_env) x1)) nil s0).
      simpl. repeat rewrite app_nil_r. intros XX; rewrite XX; clear XX.
      generalize (@CANCEL.SEP_FACTS.sexprD_weaken_wt types _ _ funcs preds cs
        (meta_env ++ firstn (length (rev v0)) (skipn (length meta_env) x1))
        nil (rev G ++ G0)
          (SH.sheapD (UNF.HEAP_FACTS.sheapSubstU 0
              (length (firstn (length (rev v0)) (skipn (length meta_env) x1)) +
               0) (length meta_env) s0)) nil).
      simpl. t_list_length.
      intro XX; rewrite XX; clear XX.
      rewrite H15. rewrite app_ass.
      cutrewrite (length (firstn (length meta_env) x1) = length meta_env).
      rewrite app_nil_r.
      cutrewrite (length (firstn (length v0) (skipn (length meta_env) x1)) + 0 = length v0).
      reflexivity.
      rewrite Plus.plus_0_r. rewrite <- rev_length with (l := v0).
      rewrite <- H18 at 2. t_list_length. reflexivity.
      rewrite <- H15. reflexivity.
      rewrite <- SH.WellTyped_sheap_WellTyped_sexpr.
      rewrite SH.WellTyped_hash in WTR.
      rewrite SH.WellTyped_sheap_WellTyped_sexpr in WTR. rewrite H0 in *. simpl in WTR.
      clear - WTR H15 H12 H18 H11.
      rewrite <- SH.WellTyped_sheap_WellTyped_sexpr in WTR.
      generalize (@UNF.HEAP_FACTS.sheapSubstU_WellTyped_eq types BedrockCoreEnv.pc BedrockCoreEnv.st (typeof_funcs funcs) (SEP.typeof_preds preds)
        (typeof_env meta_env) nil (rev v0) nil s0). simpl. t_list_length. rewrite app_nil_r in *.
      intro XX; rewrite XX in WTR; clear XX.
      rewrite <- WTR. rewrite <- H18. t_list_length. rewrite typeof_env_app. repeat rewrite Plus.plus_0_r.
      f_equal. f_equal. rewrite <- rev_length with (l := v0). rewrite <- H18 at 2.
      t_list_length. reflexivity. }
    rewrite <- H17; clear H17.
    revert H6. t_list_length.
    intro H6. etransitivity; [ clear H6 | eapply H6 ].

    (** witness the conclusion **)
    eapply UNF.ST_EXT.himp_existsEach_c.
    exists (skipn (length (rev v0)) (skipn (length meta_env) x1)). split.
    { t_list_length. rewrite firstn_length; rewrite skipn_length. rewrite <- app_ass. rewrite ListFacts.rw_skipn_app.
      rewrite <- H12. t_list_length. reflexivity.
      env_resolution. t_list_length. f_equal. rewrite min_l; auto.
      clear - H18 H15 H12.
      assert (x1 = firstn (length meta_env) x1 ++ (firstn (length (rev v0)) (skipn (length meta_env) x1)) ++
        (skipn (length (rev v0)) (skipn (length meta_env) x1))).
      repeat rewrite firstn_skipn. reflexivity.
      generalize dependent (firstn (length meta_env) x1).
      generalize dependent (skipn (length (rev v0)) (skipn (length meta_env) x1)).
      generalize dependent (firstn (length (rev v0)) (skipn (length meta_env) x1)).
      intros. subst. rewrite <- rev_length. rewrite <- H18. t_list_length. omega. }
    rewrite app_ass. rewrite H15 at 1.
    t_list_length. repeat rewrite firstn_skipn.
    clear H2.

    assert (U.Subst_WellTyped (typeof_funcs funcs) (typeof_env x1)
      (typeof_env (rev G ++ G0)) (U.Subst_empty types)).
    { eapply U.Subst_empty_WellTyped. }
    assert (SH.WellTyped_sheap (typeof_funcs funcs) (CANCEL.SE.typeof_preds preds)
      (typeof_env x1) (typeof_env (rev G ++ G0)) Heap0 = true).
    { rewrite <- H16. f_equal.
      rewrite H15. rewrite <- H18. rewrite <- H12. t_list_length.
      repeat rewrite <- typeof_env_app. repeat rewrite firstn_skipn. reflexivity.
      rewrite typeof_env_app. f_equal. rewrite typeof_env_rev. reflexivity. apply H11. }
    assert (SH.WellTyped_sheap (typeof_funcs funcs) (CANCEL.SE.typeof_preds preds)
     (typeof_env x1) (typeof_env (rev G ++ G0)) Heap = true).
    { eapply SH.WellTyped_sheap_weaken with (tG' := nil) (tU' := typeof_env (skipn (length meta_env) x1)) in H10.
      rewrite H15 in H10 at 1. rewrite <- typeof_env_app in H10. rewrite firstn_skipn in H10.
      rewrite app_nil_r in H10. rewrite <- H10. f_equal.
      rewrite typeof_env_app. rewrite typeof_env_rev. f_equal. apply H11. }
    consider (CANCEL.sepCancel preds p (length (typeof_env meta_env ++ rev v0 ++ x0)) f Heap Heap0 (U.Subst_empty _) false);
    intros; try congruence.
    { destruct p0. destruct p0. inversion H20; clear H20. subst s3. subst s1.
      subst Lhs0. clear H19. simpl in *.
      eapply CANCEL.sepCancel_correct with (cs := cs) (funcs := funcs) (U := x1) (G := rev G ++ G0) in H13; try eassumption.
      { instantiate (1 := PC). eapply Valid_weaken with (ue := skipn (length meta_env) x1) (ge := G0) in H5.
        rewrite <- firstn_skipn with (n := length meta_env) (l := x1). rewrite <- H15. assumption. }
      { (* eapply CANCEL.sepCancel_PuresPrem in H13; try eassumption. *)
        match type of H3 with
          | himp ?CS (SEP.sexprD ?F ?P ?U ?G ?L) (SEP.sexprD ?F ?P ?U ?G ?R) =>
            change (SEP.himp F P U G CS L R) in H3
        end.
        do 2 rewrite SH.sheapD_def. do 2 rewrite SH.sheapD_def in H3. simpl in *.
        do 2 rewrite CANCEL.SEP_FACTS.heq_star_emp_l in H3.
        rewrite CANCEL.SEP_FACTS.heq_star_comm
          with (P := SH.starred (SEP.Inj (stateType:=BedrockCoreEnv.st)) (SH.pures s2) SEP.Emp).
        rewrite CANCEL.SEP_FACTS.heq_star_comm
          with (P := SH.starred (SEP.Inj (stateType:=BedrockCoreEnv.st)) (SH.pures Rhs0) SEP.Emp).
        do 2 rewrite <- CANCEL.SEP_FACTS.heq_star_assoc.
        apply CANCEL.SEP_FACTS.himp_star_frame. assumption.
        eapply himp_remove_pures_p; intros.
        eapply himp_remove_pures_c; auto. reflexivity. }
      { eapply CANCEL.sepCancel_PureFacts in H13. 4: eapply H6.
        eapply U.Subst_equations_to_Subst_equations; intuition.
        intuition. intuition. } }
    { match goal with
      | [ H : (if ?X then _ else _) = _ |- _ ] =>
        destruct X; try congruence
      end.
      inversion H20; clear H20.
      destruct Lhs0; destruct Rhs0; simpl in *.
      etransitivity. etransitivity; [ | eapply H3 ].
      { repeat rewrite SH.sheapD_def; simpl; repeat apply ST.himp_star_frame; try reflexivity.
        change (SEP.himp funcs preds x1 (rev G ++ G0) cs (SH.starred (SEP.Inj (stateType:=BedrockCoreEnv.st)) pures SEP.Emp) SEP.Emp).
        clear. induction pures. reflexivity.
        rewrite CANCEL.HEAP_FACTS.starred_cons.
         rewrite IHpures.
         eapply himp_remove_pure_p. intro; reflexivity. }
      { repeat rewrite SH.sheapD_def; simpl; repeat apply ST.himp_star_frame; try reflexivity.
        change (SEP.himp funcs preds x1 (rev G ++ G0) cs SEP.Emp (SH.starred (SEP.Inj (stateType:=BedrockCoreEnv.st)) pures0 SEP.Emp)).
        clear - H1. induction pures0. reflexivity.
        rewrite CANCEL.HEAP_FACTS.starred_cons.
        simpl in H1; intuition.
        rewrite <- H1 by assumption.
        eapply himp_remove_pure_c; auto. reflexivity. } }
  Qed.

  Lemma ApplyCancelSep_with_eq :
    forall (algos_correct : ILAlgoTypes.AllAlgos_correct funcs preds algos),
    forall (meta_env : env (Env.repr BedrockCoreEnv.core types)) (hyps : Expr.exprs (_)),

    forall (l r : SEP.sexpr types BedrockCoreEnv.pc BedrockCoreEnv.st) res,
    canceller (typeof_env meta_env) hyps l r = Some res ->
    Expr.AllProvable funcs meta_env nil hyps ->
    forall (WTR : SEP.WellTyped_sexpr (typeof_funcs funcs) (SEP.typeof_preds preds) (typeof_env meta_env) nil r = true) cs,

    match res with
      | {| AllExt := new_vars
         ; ExExt  := new_uvars
         ; Lhs    := lhs'
         ; Rhs    := rhs'
         ; Subst  := subst
         |} =>
        Expr.forallEach new_vars (fun nvs : Expr.env types =>
          let var_env := nvs in
          Expr.AllProvable_impl funcs meta_env var_env
          (existsSubst funcs var_env subst 0
            (map (fun x => existT (fun t => option (tvarD types t)) (projT1 x) (Some (projT2 x))) meta_env ++
             map (fun x => existT (fun t => option (tvarD types t)) x None) new_uvars)
            (fun meta_env : Expr.env types =>
                (Expr.AllProvable_and funcs meta_env var_env
                  (himp cs
                    (SEP.sexprD funcs preds meta_env var_env
                      (SH.sheapD (SH.Build_SHeap _ _ (SH.impures lhs') nil (SH.other lhs'))))
                    (SEP.sexprD funcs preds meta_env var_env
                      (SH.sheapD (SH.Build_SHeap _ _ (SH.impures rhs') nil (SH.other rhs')))))
                  (SH.pures rhs')) ))
            (SH.pures lhs'))
    end ->
    himp cs (@SEP.sexprD _ _ _ funcs preds meta_env nil l)
            (@SEP.sexprD _ _ _ funcs preds meta_env nil r).
  Proof. intros. eapply ApplyCancelSep_with_eq'; eauto. Qed.

  Lemma ApplyCancelSep :
    forall (algos_correct : ILAlgoTypes.AllAlgos_correct funcs preds algos),
    forall (meta_env : env (Env.repr BedrockCoreEnv.core types)) (hyps : Expr.exprs (_)),
    forall (l r : SEP.sexpr types BedrockCoreEnv.pc BedrockCoreEnv.st),
      Expr.AllProvable funcs meta_env nil hyps ->
    forall (WTR : SEP.WellTyped_sexpr (typeof_funcs funcs) (SEP.typeof_preds preds) (typeof_env meta_env) nil r = true) cs,
    match canceller (typeof_env meta_env) hyps l r with
      | Some {| AllExt := new_vars
         ; ExExt  := new_uvars
         ; Lhs    := lhs'
         ; Rhs    := rhs'
         ; Subst  := subst
         |} =>
        Expr.forallEach new_vars (fun nvs : Expr.env types =>
          let var_env := nvs in
          Expr.AllProvable_impl funcs meta_env var_env
          (existsSubst funcs var_env subst 0
            (map (fun x => existT (fun t => option (tvarD types t)) (projT1 x) (Some (projT2 x))) meta_env ++
             map (fun x => existT (fun t => option (tvarD types t)) x None) new_uvars)
            (fun meta_env : Expr.env types =>
                (Expr.AllProvable_and funcs meta_env var_env
                  (himp cs
                    (SEP.sexprD funcs preds meta_env var_env
                      (SH.sheapD (SH.Build_SHeap _ _ (SH.impures lhs') nil (SH.other lhs'))))
                    (SEP.sexprD funcs preds meta_env var_env
                      (SH.sheapD (SH.Build_SHeap _ _ (SH.impures rhs') nil (SH.other rhs')))))
                  (SH.pures rhs')) ))
            (SH.pures lhs'))
      | None =>
        himp cs (@SEP.sexprD _ _ _ funcs preds meta_env nil l)
                (@SEP.sexprD _ _ _ funcs preds meta_env nil r)
    end ->
    himp cs (@SEP.sexprD _ _ _ funcs preds meta_env nil l)
            (@SEP.sexprD _ _ _ funcs preds meta_env nil r).
  Proof.
    intros. consider (canceller (typeof_env meta_env) hyps l r); intros; auto.
    eapply ApplyCancelSep_with_eq; eauto.
  Qed.

End canceller.


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

Section cap_lang_rules.
  Context `{memG Σ, regG Σ}.
  Context `{MachineParameters}.
  Implicit Types P Q : iProp Σ.
  Implicit Types σ : ExecConf.
  Implicit Types c : cap_lang.expr.
  Implicit Types a b : Addr.
  Implicit Types r : RegName.
  Implicit Types v : cap_lang.val.
  Implicit Types w : Word.
  Implicit Types reg : gmap RegName Word.
  Implicit Types ms : gmap Addr Word.

  Inductive Mov_spec (regs: Reg) (dst: RegName) (src: Z + RegName) (regs': Reg): cap_lang.val -> Prop :=
  | IsPtr_spec_success w:
      word_of_argument regs src = Some w →
      incrementPC (<[ dst := w ]> regs) = Some regs' →
      Mov_spec regs dst src regs' NextIV
  | Mov_spec_failure w:
      word_of_argument regs src = Some w →
      incrementPC (<[ dst := w ]> regs) = None →
      Mov_spec regs dst src regs' FailedV.

  Lemma wp_Mov Ep pc_p pc_g pc_b pc_e pc_a w dst src regs :
    decodeInstrW w = Mov dst src ->
    isCorrectPC (inr ((pc_p, pc_g), pc_b, pc_e, pc_a)) →
    regs !! PC = Some (inr ((pc_p, pc_g), pc_b, pc_e, pc_a)) →
    regs_of (Mov dst src) ⊆ dom _ regs →
    {{{ ▷ pc_a ↦ₐ w ∗
        ▷ [∗ map] k↦y ∈ regs, k ↦ᵣ y }}}
      Instr Executable @ Ep
    {{{ regs' retv, RET retv;
        ⌜ Mov_spec regs dst src regs' retv ⌝ ∗
        pc_a ↦ₐ w ∗
        [∗ map] k↦y ∈ regs', k ↦ᵣ y }}}.
  Proof.
    iIntros (Hinstr Hvpc HPC Dregs φ) "(>Hpc_a & >Hmap) Hφ".
    iApply wp_lift_atomic_head_step_no_fork; auto.
    iIntros (σ1 l1 l2 n) "Hσ1 /=". destruct σ1 as [r m]; simpl.
    iDestruct "Hσ1" as "[Hr Hm]".
    iDestruct (gen_heap_valid_inclSepM with "Hr Hmap") as %Hregs.
    have HPC' := regs_lookup_eq _ _ _ HPC.
    have ? := lookup_weaken _ _ _ _ HPC Hregs.
    iDestruct (@gen_heap_valid with "Hm Hpc_a") as %Hpc_a; auto.
    iModIntro. iSplitR. by iPureIntro; apply normal_always_head_reducible.
    iNext. iIntros (e2 σ2 efs Hpstep).
    apply prim_step_exec_inv in Hpstep as (-> & -> & (c & -> & Hstep)).
    iSplitR; auto. eapply step_exec_inv in Hstep; eauto.

    specialize (indom_regs_incl _ _ _ Dregs Hregs) as Hri. unfold regs_of in Hri.
    destruct (Hri dst) as [wdst [H'dst Hdst]]. by set_solver+.

    assert (exists w, word_of_argument regs src = Some w) as [wsrc Hwsrc].
    { destruct src as [| r0]; eauto; cbn.
      destruct (Hri r0) as [? [? ?]]. set_solver+. eauto. }

    pose proof Hwsrc as Hwsrc'. eapply word_of_argument_Some_inv' in Hwsrc; eauto.

    assert ((c, σ2) = updatePC (update_reg (r, m) dst wsrc)) as HH.
    { destruct Hwsrc as [ [? [? ?] ] | [? (? & ? & Hr') ] ]; simplify_eq; eauto.
      by rewrite /= /RegLocate Hr' in Hstep. }
    rewrite /update_reg /= in HH.

    destruct (incrementPC (<[ dst := wsrc ]> regs)) as [regs'|] eqn:Hregs';
      pose proof Hregs' as H'regs'; cycle 1.
    { apply incrementPC_fail_updatePC with (m:=m) in Hregs'.
      eapply updatePC_fail_incl with (m':=m) in Hregs'.
      2: by apply lookup_insert_is_Some'; eauto.
      2: by apply insert_mono; eauto.
      simplify_pair_eq.
      iMod ((gen_heap_update_inSepM _ _ dst) with "Hr Hmap") as "[Hr Hmap]"; eauto.
      iFrame. iApply "Hφ"; iFrame. iPureIntro. econstructor; eauto. }

    eapply (incrementPC_success_updatePC _ m) in Hregs'
      as (p' & g' & b' & e' & a'' & a_pc' & HPC'' & Ha_pc' & HuPC & -> & ?).
    eapply updatePC_success_incl with (m':=m) in HuPC. 2: by eapply insert_mono; eauto.
    simplify_pair_eq. iFrame.
    iMod ((gen_heap_update_inSepM _ _ dst) with "Hr Hmap") as "[Hr Hmap]"; eauto.
    iMod ((gen_heap_update_inSepM _ _ PC) with "Hr Hmap") as "[Hr Hmap]"; eauto.
    iFrame. iModIntro. iApply "Hφ". iFrame. iPureIntro. econstructor; eauto.
  Qed.

  Lemma wp_move_success_z E pc_p pc_g pc_b pc_e pc_a pc_a' w r1 wr1 z :
    decodeInstrW w = Mov r1 (inl z) →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →
    (pc_a + 1)%a = Some pc_a' →

    {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ ▷ pc_a ↦ₐ w
        ∗ ▷ r1 ↦ᵣ wr1 }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ r1 ↦ᵣ inl z }}}.
  Proof.
    iIntros (Hinstr Hvpc Hpca' ϕ) "(>HPC & >Hpc_a & >Hr1) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hr1") as "[Hmap %]".
    iApply (wp_Mov with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [|].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC r1) // insert_insert insert_commute // insert_insert.
      iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      incrementPC_inv; simplify_map_eq; eauto. destruct H4; try congruence.
      inv Hvpc. naive_solver. }
  Qed.

  Lemma wp_move_success_reg E pc_p pc_g pc_b pc_e pc_a pc_a' w r1 wr1 rv wrv :
    decodeInstrW w = Mov r1 (inr rv) →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →
    (pc_a + 1)%a = Some pc_a' →

    {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ ▷ pc_a ↦ₐ w
        ∗ ▷ r1 ↦ᵣ wr1
        ∗ ▷ rv ↦ᵣ wrv }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ r1 ↦ᵣ wrv
          ∗ rv ↦ᵣ wrv }}}.
  Proof.
    iIntros (Hinstr Hvpc Hpca' ϕ) "(>HPC & >Hpc_a & >Hr1 & >Hrv) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hr1 Hrv") as "[Hmap (%&%&%)]".
    iApply (wp_Mov with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [|].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC r1) // insert_insert (insert_commute _ PC r1) // insert_insert.
      iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      incrementPC_inv; simplify_map_eq; eauto.
      destruct H6; try congruence. inv Hvpc. naive_solver. }
  Qed.

  Lemma wp_move_success_reg_same E pc_p pc_g pc_b pc_e pc_a pc_a' w r1 wr1 :
    decodeInstrW w = Mov r1 (inr r1) →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →
    (pc_a + 1)%a = Some pc_a' →

    {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ ▷ pc_a ↦ₐ w
        ∗ ▷ r1 ↦ᵣ wr1 }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ r1 ↦ᵣ wr1 }}}.
  Proof.
    iIntros (Hinstr Hvpc Hpca' ϕ) "(>HPC & >Hpc_a & >Hr1) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hr1") as "[Hmap %]".
    iApply (wp_Mov with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [|].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC r1) // insert_insert insert_commute // insert_insert.
      iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      incrementPC_inv; simplify_map_eq; eauto.
      destruct H4; try congruence. inv Hvpc. naive_solver. }
  Qed.

  Lemma wp_move_success_reg_samePC E pc_p pc_g pc_b pc_e pc_a pc_a' w :
    decodeInstrW w = Mov PC (inr PC) →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →
    (pc_a + 1)%a = Some pc_a' →

    {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ ▷ pc_a ↦ₐ w }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w }}}.
  Proof.
    iIntros (Hinstr Hvpc Hpca' ϕ) "(>HPC & >Hpc_a) Hφ".
    iDestruct (map_of_regs_1 with "HPC") as "Hmap".
    iApply (wp_Mov with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [|].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite !insert_insert.
      iDestruct (regs_of_map_1 with "Hmap") as "?"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      incrementPC_inv; simplify_map_eq; eauto.
      destruct H3; try congruence. inv Hvpc. naive_solver. }
  Qed.

  (*
  Lemma wp_move_success_reg_toPC E pc_p pc_g pc_b pc_e pc_a w r1 p g b e a a' :
    decodeInstrW w = Mov PC (inr r1) →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →
    (a + 1)%a = Some a' →

    {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ ▷ pc_a ↦ₐ w
        ∗ ▷ r1 ↦ᵣ inr ((p,g),b,e,a) }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr ((p,g),b,e,a')
          ∗ pc_a ↦ₐ w
          ∗ r1 ↦ᵣ inr ((p,g),b,e,a) }}}.
  Proof.
    iIntros (Hinstr Hvpc Hpca' ϕ) "(>HPC & >Hpc_a & >Hr1) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hr1") as "[Hmap %]".
    iApply (wp_Mov with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [|].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC r1) // insert_insert insert_commute // insert_insert.
      iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      incrementPC_inv; simplify_map_eq; eauto. congruence. }
  Qed.*)

  Lemma wp_move_success_reg_fromPC E pc_p pc_g pc_b pc_e pc_a pc_a' w r1 wr1 :
    decodeInstrW w = Mov r1 (inr PC) →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →
    (pc_a + 1)%a = Some pc_a' →

    {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ ▷ pc_a ↦ₐ w
        ∗ ▷ r1 ↦ᵣ wr1 }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ r1 ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a) }}}.
  Proof.
    iIntros (Hinstr Hvpc Hpca' ϕ) "(>HPC & >Hpc_a & >Hr1) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hr1") as "[Hmap %]".
    iApply (wp_Mov with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    destruct Hspec as [|].
    { (* Success *)
      iApply "Hφ". iFrame. incrementPC_inv; simplify_map_eq.
      rewrite (insert_commute _ PC r1) // insert_insert insert_commute // insert_insert.
      iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
    { (* Failure (contradiction) *)
      incrementPC_inv; simplify_map_eq; eauto.
      destruct H4; try congruence. inv Hvpc. naive_solver. }
  Qed.

End cap_lang_rules.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*              Object Primitives                                      *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

Require Import Coqlib.
Require Import Maps.
Require Import AuxStateDataType.
Require Import FlatMemory.
Require Import AbstractDataType.
Require Import Integers.
Require Import Values.
Require Import RealParams.
Require Import Constant.
Require Import CalRealIDPDE.
Require Import CalRealInitPTE.
Require Import CalRealPTPool.
Require Import CalRealPT.

Section PRIM_Container.

  Context `{real_params: RealParams}.

    Function container_init_spec (mbi: Z) (adt: RData) : option RData :=
      match (init adt, pg adt, ikern adt, ihost adt) with
        | (false, false, true, true) =>
          Some adt {vmxinfo: real_vmxinfo} {AT: real_AT (AT adt)} {nps: real_nps}
                   {init: true} {AC: real_AC}
        | _ => None
      end.

    Function container_init0_spec (mbi: Z) (adt: RData) : option RData :=
      match (init adt, pg adt, ikern adt, ihost adt, ipt adt) with
        | (false, false, true, true, true) =>
          Some adt {vmxinfo: real_vmxinfo} {AT: real_AT (AT adt)} {nps: real_nps}
                   {init: true} {AC: real_AC}
        | _ => None
      end.

    Function container_get_parent_spec (i: Z) (adt: RData): option Z :=
      let c := ZMap.get i (AC adt) in
      match (ikern adt, ihost adt, cused c) with
        | (true, true, true) => Some (cparent c)
        | _ => None
      end.

    Function container_get_nchildren_spec (i: Z) (adt: RData) : option Z :=
      let c := ZMap.get i (AC adt) in
      match (ikern adt, ihost adt, cused c) with
        | (true, true, true) => Some (Z_of_nat (length (cchildren c)))
        | _ => None
      end.

    Function container_get_quota_spec (i: Z) (adt: RData) : option Z :=
      let c := ZMap.get i (AC adt) in
      match (ikern adt, ihost adt, cused c) with
        | (true, true, true) => Some (cquota c)
        | _ => None
      end.

    Function container_get_usage_spec (i: Z) (adt: RData): option Z :=
      let c := ZMap.get i (AC adt) in
      match (ikern adt, ihost adt, cused c) with
        | (true, true, true) => Some (cusage c)
        | _ => None
      end.

    Function container_can_consume_spec (i: Z) (n: Z) (adt: RData) : option Z :=
      match (ikern adt, ihost adt, cused (ZMap.get i (AC adt))) with
        | (true, true, true) =>
          Some (if zle_le 0 n (cquota (ZMap.get i (AC adt)) - cusage (ZMap.get i (AC adt)))
                then 1 else 0)
        | _ => None
      end.

    Function container_split_spec (id: Z) (q: Z) (adt: RData) : option (RData*Z) :=
      let c := ZMap.get id (AC adt) in
      let i := id * max_children + 1 + Z_of_nat (length (cchildren c)) in
      match (ikern adt, ihost adt, cused c, zle_lt 0 i num_id,
             zlt (Z_of_nat (length (cchildren c))) max_children,
             zle_le 0 q (cquota c - cusage c)) with
      | (true, true, true, left _, left _, left _) =>
           let child := mkContainer q 0 id nil true in
             Some (adt {AC: ZMap.set i child ((AC adt) {usage id := cusage c + q}
                                                       {children id := (i :: cchildren c)})}, i)
      | _ => None
      end.
(*
    Function container_revoke_spec (adt: RData) (i: Z) : option RData :=
      if zeq i 0 then None else
      let c := ZMap.get i (AC adt) in
      let p := ZMap.get (cparent c) (AC adt) in
      match (ikern adt, ihost adt, cused c, cchildren c) with
      | (true, true, true, nil) =>
         let p' := mkContainer (cquota p) (cusage p - cquota c)
                     (cparent p) (remove zeq i (cchildren p)) (cused p) in
           Some (mkRData (HP adt) (MM adt) (MMSize adt)
                (ZMap.set (cparent c) p' (ZMap.set i Container_unused (AC adt)))
                (CR3 adt) (ti adt) (pg adt) (ikern adt) (ihost adt))
      | _ => None
      end.
*)
    Function container_alloc_spec (id: Z) (adt: RData)  : option (RData*Z) :=
      let c := ZMap.get id (AC adt) in
      match (ikern adt, ihost adt, init adt, cused c) with
      | (true, true, true, true) =>
        if cusage c <? cquota c then
          let cur := mkContainer (cquota c) (cusage c + 1) (cparent c)
                                 (cchildren c) (cused c) in
          match first_free (AT adt) (nps adt) with
            | inleft (exist i _) =>
              Some (adt {AT: ZMap.set i (ATValid true ATNorm 0) (AT adt)}
                        {pperm: ZMap.set i PGAlloc (pperm adt)}
                        {AC: ZMap.set id cur (AC adt)}, i)
            | _ => None
          end
        else Some (adt, 0)
      | _ => None
    end.
(*
    Function container_free_spec (adt: RData) (i: Z) : option RData :=
      let c := ZMap.get i (AC adt) in
      match (ikern adt, ihost adt, cused c, 0 <? cusage c) with
      | (true, true, true, true) =>
        let cur := mkContainer (cquota c) (cusage c - 1) (cparent c)
                        (cchildren c) (cused c) in
        Some (mkRData (HP adt) (MM adt) (MMSize adt) (ZMap.set i cur (AC adt))
             (CR3 adt) (ti adt) (pg adt) (ikern adt) (ihost adt))
      | _ => None
      end.
*)

End PRIM_Container.

Section CVALID.

  Lemma cvalid_unused_child_id_range :
    forall C, Container_valid C ->
      forall i, cused (ZMap.get i C) = true ->
        forall j, i * max_children + 1 + Z_of_nat (length (cchildren (ZMap.get i C))) <=
                  j < i * max_children + 1 + max_children -> cused (ZMap.get j C) = false.
  Proof.
    intros C Hvalid i Hi j Hrange; destruct Hvalid.
    destruct (cused (ZMap.get j C)) eqn:Hj; auto.
    destruct (zeq j 0) as [Heq|Hneq]; subst.
    specialize (cvalid_id _ Hi); omega.
    specialize (cvalid_parents_child _ Hj Hneq).
    rewrite (cvalid_parent_id _ Hj) in cvalid_parents_child.
    destruct (zeq j 0); try congruence.
    replace ((j-1) / max_children) with i in cvalid_parents_child.
    specialize (cvalid_child_id_range _ Hi); rewrite Forall_forall in cvalid_child_id_range.
    specialize (cvalid_child_id_range _ cvalid_parents_child); omega.
    apply Zdiv.Zdiv_unique with (r:= j - (i * max_children + 1)); omega.
  Qed.

  Lemma cvalid_unused_next_child :
    forall C, Container_valid C ->
      forall i, cused (ZMap.get i C) = true ->
        Z_of_nat (length (cchildren (ZMap.get i C))) < max_children ->
        cused (ZMap.get (i * max_children + 1 +
                         Z_of_nat (length (cchildren (ZMap.get i C)))) C) = false.
  Proof.
    intros; eapply cvalid_unused_child_id_range; eauto; omega.
  Qed.

  Lemma cvalid_child_id_pos :
    forall C, Container_valid C ->
      forall i, cused (ZMap.get i C) = true ->
        forall k, k >= 0 -> 0 < i * max_children + 1 + k.
  Proof.
    intros C Hvalid i Hi k Hk; destruct Hvalid.
    specialize (cvalid_id _ Hi); omega.
  Qed.

  Lemma cvalid_child_id_neq :
    forall C, Container_valid C ->
      forall i, cused (ZMap.get i C) = true ->
        i <> i * max_children + 1 + Z_of_nat (length (cchildren (ZMap.get i C))).
  Proof.
    intros C Hvalid i Hi; destruct Hvalid.
    assert (Hmath: forall i j, 0 <= i -> 0 <= j -> i <> i * max_children + 1 + j) by (intros; omega).
    apply Hmath.
    specialize (cvalid_id _ Hi); omega.
    apply Nat2Z.is_nonneg.
  Qed.

End CVALID.

Require Import liblayers.compat.CompatGenSem.
Require Import liblayers.compat.CompatLayers.
Require Import CommonTactic.
Require Import RefinementTactic.
Require Import PrimSemantics.
Require Import AuxLemma.
Require Import Observation.

Section OBJ_SIM.

  Context `{Hobs: Observation}.

  Context `{data : CompatData(Obs:=Obs) RData}.
  Context `{data0 : CompatData(Obs:=Obs) RData}.

  Context `{Hstencil: Stencil}.
  Context `{Hmem: Mem.MemoryModel}.
  Context `{Hmwd: UseMemWithData mem}.

  Notation HDATAOps := (cdata (cdata_prf := data) RData).
  Notation LDATAOps := (cdata (cdata_prf := data0) RData).

  Context `{rel_prf: CompatRel _ (Obs:=Obs) (memory_model_ops:= memory_model_ops) _
                               (stencil_ops:= stencil_ops) HDATAOps LDATAOps}.

  Context {re1: relate_impl_iflags}.
  Context {re2: relate_impl_init}.
  Context {re3: relate_impl_AC}.

  Section CONTAINER_INIT_SIM.

    Context `{real_params: RealParams}.

    Context {re4: relate_impl_AT}.
    Context {re5: relate_impl_nps}.
    Context {re6: relate_impl_vmxinfo}.

    Lemma container_init_exist:
      forall s habd habd' labd mbi f,
        container_init_spec mbi habd = Some habd'
        -> relate_AbData s f habd labd
        -> exists labd', container_init_spec mbi labd = Some labd'
                         /\ relate_AbData s f habd' labd'.
    Proof.
      unfold container_init_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_init_eq; eauto.
      exploit relate_impl_AC_eq; eauto.
      exploit relate_impl_AT_eq; eauto.
      exploit relate_impl_nps_eq; eauto.
      exploit relate_impl_vmxinfo_eq; eauto. intros.
      revert H; subrewrite. subdestruct.
      inv HQ. refine_split'; trivial.

      apply relate_impl_AC_update.
      apply relate_impl_init_update.
      apply relate_impl_nps_update.
      apply relate_impl_AT_update.
      apply relate_impl_vmxinfo_update. assumption.
    Qed.

    Context {mt1: match_impl_iflags}.
    Context {mt2: match_impl_init}.
    Context {mt3: match_impl_AC}.
    Context {mt4: match_impl_AT}.
    Context {mt5: match_impl_nps}.
    Context {mt6: match_impl_vmxinfo}.

    Lemma container_init_match:
      forall s d d' m mbi f,
        container_init_spec mbi d = Some d'
        -> match_AbData s d m f
        -> match_AbData s d' m f.
    Proof.
      unfold container_init_spec; intros. subdestruct. inv H.
      apply match_impl_AC_update.
      apply match_impl_init_update.
      apply match_impl_nps_update.
      apply match_impl_AT_update.
      apply match_impl_vmxinfo_update. assumption.
    Qed.

    Context {inv: PreservesInvariants (HD:= data) container_init_spec}.
    Context {inv0: PreservesInvariants (HD:= data0) container_init_spec}.

    Lemma container_init_sim :
      forall id,
        sim (crel RData RData) (id ↦ gensem container_init_spec)
            (id ↦ gensem container_init_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      exploit container_init_exist; eauto 1; intros [labd' [HP HM]].
      match_external_states_simpl.
      eapply container_init_match; eauto.
    Qed.

  End CONTAINER_INIT_SIM.

  Section CONTAINER_INIT0_SIM.

    Context `{real_params: RealParams}.

    Context {re4: relate_impl_AT}.
    Context {re5: relate_impl_nps}.
    Context {re6: relate_impl_vmxinfo}.
    Context {re7: relate_impl_ipt}.

    Lemma container_init0_exist:
      forall s habd habd' labd mbi f,
        container_init0_spec mbi habd = Some habd'
        -> relate_AbData s f habd labd
        -> exists labd', container_init0_spec mbi labd = Some labd'
                         /\ relate_AbData s f habd' labd'.
    Proof.
      unfold container_init0_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_init_eq; eauto.
      exploit relate_impl_AC_eq; eauto.
      exploit relate_impl_AT_eq; eauto.
      exploit relate_impl_nps_eq; eauto.
      exploit relate_impl_vmxinfo_eq; eauto.
      exploit relate_impl_ipt_eq; eauto. intros.
      revert H; subrewrite. subdestruct.
      inv HQ. refine_split'; trivial.

      apply relate_impl_AC_update.
      apply relate_impl_init_update.
      apply relate_impl_nps_update.
      apply relate_impl_AT_update.
      apply relate_impl_vmxinfo_update. assumption.
    Qed.

    Context {mt1: match_impl_iflags}.
    Context {mt2: match_impl_init}.
    Context {mt3: match_impl_AC}.
    Context {mt4: match_impl_AT}.
    Context {mt5: match_impl_nps}.
    Context {mt6: match_impl_vmxinfo}.

    Lemma container_init0_match:
      forall s d d' m mbi f,
        container_init0_spec mbi d = Some d'
        -> match_AbData s d m f
        -> match_AbData s d' m f.
    Proof.
      unfold container_init0_spec; intros. subdestruct. inv H.
      apply match_impl_AC_update.
      apply match_impl_init_update.
      apply match_impl_nps_update.
      apply match_impl_AT_update.
      apply match_impl_vmxinfo_update. assumption.
    Qed.

    Context {inv: PreservesInvariants (HD:= data) container_init0_spec}.
    Context {inv0: PreservesInvariants (HD:= data0) container_init0_spec}.

    Lemma container_init0_sim :
      forall id,
        sim (crel RData RData) (id ↦ gensem container_init0_spec)
            (id ↦ gensem container_init0_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      exploit container_init0_exist; eauto 1; intros [labd' [HP HM]].
      match_external_states_simpl.
      eapply container_init0_match; eauto.
    Qed.

  End CONTAINER_INIT0_SIM.

  Section CONTAINER_GET_PARENT_SIM.

    Lemma container_get_parent_exist:
      forall s habd labd i p f,
        container_get_parent_spec i habd = Some p
        -> relate_AbData s f habd labd
        -> container_get_parent_spec i labd = Some p.
    Proof.
      unfold container_get_parent_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_AC_eq; eauto. intros.
      revert H. subrewrite.
    Qed.

    Lemma container_get_parent_sim:
      forall id,
        sim (crel RData RData) (id ↦ gensem container_get_parent_spec)
                               (id ↦ gensem container_get_parent_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      match_external_states_simpl.
      erewrite container_get_parent_exist; eauto 1.
      reflexivity.
    Qed.

  End CONTAINER_GET_PARENT_SIM.

  Section CONTAINER_GET_NCHILDREN_SIM.

    Lemma container_get_nchildren_exist:
      forall s habd labd i p f,
        container_get_nchildren_spec i habd = Some p
        -> relate_AbData s f habd labd
        -> container_get_nchildren_spec i labd = Some p.
    Proof.
      unfold container_get_nchildren_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_AC_eq; eauto. intros.
      revert H. subrewrite.
    Qed.

    Lemma container_get_nchildren_sim:
      forall id,
        sim (crel RData RData) (id ↦ gensem container_get_nchildren_spec)
                               (id ↦ gensem container_get_nchildren_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      match_external_states_simpl.
      erewrite container_get_nchildren_exist; eauto 1.
      reflexivity.
    Qed.

  End CONTAINER_GET_NCHILDREN_SIM.

  Section CONTAINER_GET_QUOTA_SIM.

    Lemma container_get_quota_exist:
      forall s habd labd i p f,
        container_get_quota_spec i habd = Some p
        -> relate_AbData s f habd labd
        -> container_get_quota_spec i labd = Some p.
    Proof.
      unfold container_get_quota_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_AC_eq; eauto. intros.
      revert H. subrewrite.
    Qed.

    Lemma container_get_quota_sim:
      forall id,
        sim (crel RData RData) (id ↦ gensem container_get_quota_spec)
                               (id ↦ gensem container_get_quota_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      match_external_states_simpl.
      erewrite container_get_quota_exist; eauto 1.
      reflexivity.
    Qed.

  End CONTAINER_GET_QUOTA_SIM.

  Section CONTAINER_GET_USAGE_SIM.

    Lemma container_get_usage_exist:
      forall s habd labd i p f,
        container_get_usage_spec i habd = Some p
        -> relate_AbData s f habd labd
        -> container_get_usage_spec i labd = Some p.
    Proof.
      unfold container_get_usage_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_AC_eq; eauto. intros.
      revert H. subrewrite.
    Qed.

    Lemma container_get_usage_sim:
      forall id,
        sim (crel RData RData) (id ↦ gensem container_get_usage_spec)
                               (id ↦ gensem container_get_usage_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      match_external_states_simpl.
      erewrite container_get_usage_exist; eauto 1.
      reflexivity.
    Qed.

  End CONTAINER_GET_USAGE_SIM.

  Section CONTAINER_CAN_CONSUME_SIM.

    Lemma container_can_consume_exist:
      forall s habd labd i n b f,
        container_can_consume_spec i n habd = Some b
        -> relate_AbData s f habd labd
        -> container_can_consume_spec i n labd = Some b.
    Proof.
      unfold container_can_consume_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_AC_eq; eauto. intros.
      revert H. subrewrite.
    Qed.

    Lemma container_can_consume_sim:
      forall id,
        sim (crel RData RData) (id ↦ gensem container_can_consume_spec)
                               (id ↦ gensem container_can_consume_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      match_external_states_simpl.
      erewrite container_can_consume_exist; eauto 1.
      reflexivity.
    Qed.

  End CONTAINER_CAN_CONSUME_SIM.

  Section CONTAINER_SPLIT_SIM.

    Lemma container_split_exist:
      forall s habd habd' labd i n z f,
        container_split_spec i n habd = Some (habd', z)
        -> relate_AbData s f habd labd
        -> exists labd', container_split_spec i n labd = Some (labd', z)
                         /\ relate_AbData s f habd' labd'.
    Proof.
      unfold container_split_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_init_eq; eauto.
      exploit relate_impl_AC_eq; eauto. intros.
      revert H; subrewrite. subdestruct.
      inv HQ. refine_split'; trivial.

      apply relate_impl_AC_update. assumption.
    Qed.

    Context {mt2: match_impl_AC}.

    Lemma container_split_match:
      forall s d d' m i n z f,
        container_split_spec i n d = Some (d', z)
        -> match_AbData s d m f
        -> match_AbData s d' m f.
    Proof.
      unfold container_split_spec; intros. subdestruct. inv H.
      eapply match_impl_AC_update. assumption.
    Qed.

    Context {inv: PreservesInvariants (HD:= data) container_split_spec}.
    Context {inv0: PreservesInvariants (HD:= data0) container_split_spec}.

    Lemma container_split_sim :
      forall id,
        sim (crel RData RData) (id ↦ gensem container_split_spec)
            (id ↦ gensem container_split_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      exploit container_split_exist; eauto 1; intros [labd' [HP HM]].
      match_external_states_simpl.
      eapply container_split_match; eauto.
    Qed.

  End CONTAINER_SPLIT_SIM.

  Section CONTAINER_ALLOC_SIM.

    Context {re4: relate_impl_AT}.
    Context {re5: relate_impl_pperm}.
    Context {re6: relate_impl_nps}.

    Lemma container_alloc_exist:
      forall s habd habd' labd i f z,
        container_alloc_spec i habd = Some (habd', z)
        -> relate_AbData s f habd labd
        -> exists labd', container_alloc_spec i labd = Some (labd', z)
                         /\ relate_AbData s f habd' labd'.
    Proof.
      unfold container_alloc_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_init_eq; eauto.
      exploit relate_impl_AT_eq; eauto.
      exploit relate_impl_pperm_eq; eauto.
      exploit relate_impl_nps_eq; eauto.
      exploit relate_impl_AC_eq; eauto. intros.
      revert H; subrewrite.
      subdestruct; inv HQ; refine_split'; trivial.
      apply relate_impl_AC_update.
      apply relate_impl_pperm_update.
      apply relate_impl_AT_update. assumption.
    Qed.

    Context {mt1: match_impl_AC}.
    Context {mt2: match_impl_pperm}.
    Context {mt3: match_impl_AT}.

    Lemma container_alloc_match:
      forall s d d' m i f z,
        container_alloc_spec i d = Some (d',z)
        -> match_AbData s d m f
        -> match_AbData s d' m f.
    Proof.
      unfold container_alloc_spec; intros.
      subdestruct; inv H; auto.
      apply match_impl_AC_update.
      apply match_impl_pperm_update.
      apply match_impl_AT_update. assumption.
    Qed.

    Context {inv: PreservesInvariants (HD:= data) container_alloc_spec}.
    Context {inv0: PreservesInvariants (HD:= data0) container_alloc_spec}.

    Lemma container_alloc_sim :
      forall id,
        sim (crel RData RData) (id ↦ gensem container_alloc_spec)
            (id ↦ gensem container_alloc_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      exploit container_alloc_exist; eauto 1; intros [labd' [HP HM]].
      match_external_states_simpl.
      eapply container_alloc_match; eauto.
    Qed.

  End CONTAINER_ALLOC_SIM.

End OBJ_SIM.