From hahn Require Import Hahn.
Require Import Events.
Require Import Execution.
Require Import AuxRel2.

Set Implicit Arguments.

Section CO.

Variables G : execution.
Variable I : actid -> Prop.  (* issued *)
Variable T : actid -> Prop.  (* all writes in certified thread *)

Notation "'E'" := (acts_set G).
Notation "'lab'" := (lab G).
Notation "'sb'" := (sb G).
Notation "'rf'" := (rf G).
Notation "'co'" := (co G).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'loc'" := (loc lab).
Notation "'same_loc'" := (same_loc lab).
Notation "'Loc_' l" := (fun x => loc x = Some l) (at level 1).
Notation "'W_' l" := (W ∩₁ Loc_ l) (at level 1).

Hypothesis IT: I ∪₁ T ≡₁ E ∩₁ W.

Lemma IN_I: I ⊆₁ E ∩₁ W.
Proof using IT.
rewrite <- IT; basic_solver 21.
Qed.

Lemma IN_T: T ⊆₁ E ∩₁ W.
Proof using IT.
rewrite <- IT; basic_solver 21.
Qed.

Hypothesis wf_coE : co ≡ ⦗E⦘ ⨾ co ⨾ ⦗E⦘.
Hypothesis wf_coD : co ≡ ⦗W⦘ ⨾ co ⨾ ⦗W⦘.
Hypothesis wf_col : co ⊆ same_loc.
Hypothesis co_trans : transitive co.
Hypothesis wf_co_total : forall ol, is_total (E ∩₁ W ∩₁ (fun x => loc x = ol)) co.
Hypothesis co_irr : irreflexive co.

Definition col l := (⦗Loc_ l⦘ ⨾ co ⨾ ⦗Loc_ l⦘).

Definition col0 l := (⦗I⦘ ⨾ col l ⨾ ⦗I⦘ ∪ ⦗T⦘ ⨾ col l ⨾ ⦗T⦘ ∪ ⦗I⦘ ⨾ col l ⨾ ⦗T⦘)⁺.

Definition new_col l := pref_union (col0 l) ((I ∩₁ Loc_ l) × (E ∩₁ W ∩₁ Loc_ l \₁ I)).

Definition new_co x y := exists l, (new_col l) x y.

Lemma col_in_co l : col l ⊆ co.
Proof using.
unfold col; basic_solver.
Qed.

Lemma co_in_col x y : co x y -> exists l, col l x y.
Proof using wf_coD wf_col.
unfold new_co, col; ins; unfolder; ins; desf.
hahn_rewrite (dom_l wf_coD) in H; unfolder in H; desc.
generalize (is_w_loc lab x H); ins; desf.
eexists; splits; eauto.
eexists; splits; eauto.
eexists; splits; eauto.
apply wf_col in H0; unfold Events.same_loc in H0; congruence.
Qed.

Lemma wf_colE l : col l ≡ ⦗E⦘ ⨾ col l ⨾ ⦗E⦘.
Proof using wf_coE.
apply dom_helper_3; unfold col; rewrite wf_coE; basic_solver.
Qed.

Lemma wf_colD l : col l ≡ ⦗W_ l⦘ ⨾ col l ⨾ ⦗W_ l⦘.
Proof using wf_coD.
apply dom_helper_3; unfold col; rewrite wf_coD; basic_solver.
Qed.

Lemma wf_coll l : col l ⊆ same_loc.
Proof using wf_col.
unfold col; rewrite wf_col; basic_solver.
Qed.

Lemma col_trans l : transitive (col l).
Proof using co_trans.
unfold col.
rewrite <- restr_relE.
by apply transitive_restr.
Qed.

Lemma wf_col_total l : is_total (E ∩₁ W ∩₁ Loc_ l) (col l).
Proof using wf_coD wf_coE wf_co_total.
rewrite wf_colD, wf_colE.
unfold col; rewrite !seqA.
arewrite (⦗W_ l⦘ ⨾ ⦗E⦘ ⨾ ⦗Loc_ l⦘ ≡ ⦗E ∩₁ W ∩₁ Loc_ l⦘) by basic_solver.
arewrite (⦗Loc_ l⦘ ⨾ ⦗E⦘ ⨾ ⦗W_ l⦘ ≡ ⦗E ∩₁ W ∩₁ Loc_ l⦘) by basic_solver.
rewrite <- restr_relE.
apply is_total_restr.
apply wf_co_total.
Qed.

Lemma col_irr l: irreflexive (col l).
Proof using co_irr.
unfold col.
rewrite <- restr_relE.
by apply irreflexive_restr.
Qed.

Lemma acyclic_new_col l : acyclic (new_col l).
Proof using IT co_irr co_trans wf_coD wf_coE wf_co_total.
eapply acyclic_pref_union with (dom:=I ∩₁ Loc_ l).
- unfold col0.
  arewrite_id ⦗I⦘.
  arewrite_id ⦗T⦘.
  relsf.
  generalize (@col_trans l); ins; relsf; apply col_irr.
- unfold col0; relsf.
- assert (XX: restr_rel (I ∩₁ Loc_ l) (col l) ⊆ col0 l).
  by unfold col0; rewrite <- ct_step; basic_solver 21.
  rewrite <- XX.
  apply is_total_restr.
  rewrite IN_I.
  eapply wf_col_total.
- unfolder; ins; desf; splits; eauto; intro; desf.
Qed.

Lemma wf_new_colE l : new_col l ≡ ⦗E⦘ ⨾ new_col l ⨾ ⦗E⦘.
Proof using IT wf_coE.
apply dom_helper_3.
unfold new_col, pref_union, col0; unfolder; ins; desf.
2: by generalize (IN_I H); basic_solver 12.
induction H; [|basic_solver].
desf; apply (wf_colE l) in H0; unfolder in H0; desf; eauto.
Qed.

Lemma wf_new_colD l : new_col l ≡ ⦗W_ l⦘ ⨾ new_col l ⨾ ⦗W_ l⦘.
Proof using IT wf_coD.
apply dom_helper_3.
unfold new_col, pref_union, col0; unfolder; ins; desf.
2: by generalize (IN_I H); basic_solver 12.
induction H; [|basic_solver].
desf; apply (wf_colD l) in H0; unfolder in H0; desf; eauto.
Qed.

Lemma wf_new_coll l : new_col l ⊆ same_loc.
Proof using IT wf_coD.
rewrite wf_new_colD; unfold Events.same_loc.
unfolder; ins; desf; congruence.
Qed.

Lemma wf_new_col_total l : is_total (E ∩₁ W ∩₁ Loc_ l) (new_col l).
Proof using IT wf_coD wf_coE wf_co_total.
unfold new_col, pref_union.
unfolder; ins; desf.
destruct (classic (col0 l a b)) as [|X]; eauto 8.
destruct (classic (col0 l b a)) as [|Y]; eauto 8.
assert (XX: ~ (⦗I⦘ ⨾ col l ⨾ ⦗I⦘ ∪ ⦗T⦘ ⨾ col l ⨾ ⦗T⦘ ∪ ⦗I⦘ ⨾ col l ⨾ ⦗T⦘) a b).
by intro; eapply X; vauto.
assert (YY: ~ (⦗I⦘ ⨾ col l ⨾ ⦗I⦘ ∪ ⦗T⦘ ⨾ col l ⨾ ⦗T⦘ ∪ ⦗I⦘ ⨾ col l ⨾ ⦗T⦘) b a).
by intro; eapply Y; vauto.

assert (Ta: ~ I a -> T a).
by assert (S: (E ∩₁ W) a) by basic_solver; apply IT in S; unfolder in S; ins; desf.
assert (Tb: ~ I b -> T b).
by assert (S: (E ∩₁ W) b) by basic_solver; apply IT in S; unfolder in S; ins; desf.

assert (TOT: col l a b \/ col l b a).
by apply wf_col_total; basic_solver.
destruct (classic (I a)), (classic (I b)); desf.
- exfalso; unfolder in XX; basic_solver 22.
- exfalso; unfolder in YY; basic_solver 22.
- exfalso; unfolder in XX; basic_solver 22.
- eauto 20.
- eauto 20.
- exfalso; unfolder in YY; basic_solver 22.
- exfalso; unfolder in XX; basic_solver 22.
- exfalso; unfolder in YY; basic_solver 22.
Qed.

Lemma new_col_trans l : transitive (new_col l).
Proof using IT co_irr co_trans wf_coD wf_coE wf_co_total.
apply transitiveI; unfolder; ins; desf.
eapply tot_ex.
- apply wf_new_col_total.
- hahn_rewrite wf_new_colE in H0.
hahn_rewrite wf_new_colD in H0.
unfolder in H0; basic_solver 21.
- hahn_rewrite wf_new_colE in H.
hahn_rewrite wf_new_colD in H.
unfolder in H; basic_solver 21.
- intro.
eapply acyclic_new_col.
eapply t_trans, t_trans; vauto.
- intro.
eapply acyclic_new_col.
eapply t_trans; vauto.
Qed.

Lemma new_col_irr l : irreflexive (new_col l).
Proof using IT co_irr co_trans wf_coD wf_coE wf_co_total.
red; ins; eapply acyclic_new_col; vauto.
Qed.

Lemma wf_new_coE : new_co ≡ ⦗E⦘ ⨾ new_co ⨾ ⦗E⦘.
Proof using IT wf_coE.
unfold new_co; unfolder; ins; desf; splits; ins; desf; eauto.
apply (wf_new_colE l) in H; unfolder in H; desf; eauto.
Qed.

Lemma wf_new_coD : new_co ≡ ⦗W⦘ ⨾ new_co ⨾ ⦗W⦘.
Proof using IT wf_coD.
unfold new_co; unfolder; ins; desf; splits; ins; desf; eauto.
apply (wf_new_colD l) in H; unfolder in H; desf; eauto.
Qed.

Lemma wf_new_col : new_co ⊆ same_loc.
Proof using IT wf_coD.
unfold new_co; unfolder; ins; desf; splits; ins; desf; eauto.
apply (@wf_new_coll l) in H; unfolder in H; desf; eauto.
Qed.

Lemma new_co_trans : transitive new_co.
Proof using IT co_irr co_trans wf_coD wf_coE wf_co_total.
unfold new_co; unfolder; ins; desf; splits; ins; desf; eauto.
hahn_rewrite wf_new_colD in H0.
hahn_rewrite wf_new_colD in H.
unfolder in H0; unfolder in H; desf.
exists l; eapply new_col_trans; eauto.
Qed.

Lemma wf_new_co_total : forall ol, is_total (E ∩₁ W ∩₁ (fun x => loc x = ol)) new_co.
Proof using IT wf_coD wf_coE wf_co_total.
unfold new_co; ins; unfolder; ins; desf.
generalize (is_w_loc lab a IWa1); ins; desf.
cut (new_col l a b \/ new_col l b a); [by basic_solver 21|].
apply wf_new_col_total; auto.
basic_solver.
unfolder; splits; ins; desf; congruence.
Qed.

Lemma new_co_irr : irreflexive new_co.
Proof using IT co_irr co_trans wf_coD wf_coE wf_co_total.
unfold new_co; ins; unfolder; ins; desf.
eapply new_col_irr; eauto.
Qed.

Lemma new_co_I : new_co ⨾ ⦗ I ⦘  ⊆ co ⨾ ⦗ I ⦘.
Proof using IT co_irr co_trans wf_coD wf_coE wf_co_total.
unfolder; intros x y [R K]; desf.
unfold new_co in R; desc.
hahn_rewrite wf_new_colE in R.
hahn_rewrite wf_new_colD in R.
unfolder in R; desf; splits; auto.
eapply tot_ex.
- apply wf_co_total.
- basic_solver.
- unfolder; splits; eauto; congruence.
- intro.
assert (S: (E ∩₁ W) z) by basic_solver.
apply IT in S; unfolder in S; ins; desf.
* eapply new_col_irr, new_col_trans; try edone.
red; red; unfold col0, col; left; apply t_step; basic_solver 12.
* eapply new_col_irr, new_col_trans; try edone.
red; red; unfold col0, col; left; apply t_step; basic_solver 12.
- intro; subst.
eby eapply new_col_irr.
Qed.

Lemma T_new_co : ⦗ T ⦘ ⨾ new_co  ⊆ ⦗ T ⦘ ⨾ co.
Proof using IT co_irr co_trans wf_coD wf_coE wf_co_total.
unfolder; intros x y [K1 R]; desf.
unfold new_co in R; desc.
hahn_rewrite wf_new_colE in R.
hahn_rewrite wf_new_colD in R.
unfolder in R; desf; splits; auto.
eapply tot_ex.
- apply wf_co_total.
- basic_solver.
- unfolder; splits; eauto; congruence.
- intro.
assert (S: (E ∩₁ W) z) by basic_solver.
apply IT in S; unfolder in S; ins; desf.
* eapply new_col_irr, new_col_trans; try edone.

red; red; unfold col0, col. left; apply t_step.
assert (I y \/ T y) by (apply IT; basic_solver).
desf; basic_solver 12.
* eapply new_col_irr, new_col_trans; try edone.
red; red; unfold col0, col; left; apply t_step.
assert (I y \/ T y) by (apply IT; basic_solver).
desf; basic_solver 12.
- intro; subst.
eby eapply new_col_irr.
Qed.

Lemma new_co_in : new_co  ⊆ co ⨾ ⦗ I ⦘ ∪
⦗ T ⦘ ⨾ co ∪ ⦗ I \₁ T ⦘ ⨾ new_co ⨾ ⦗ T \₁ I ⦘.
Proof using IT co_irr co_trans wf_coD wf_coE wf_co_total.
rewrite (wf_new_coD), (wf_new_coE) at 1.
rewrite !seqA.
arewrite (⦗W⦘ ⨾ ⦗E⦘ ⊆ ⦗E ∩₁ W⦘) by basic_solver.
arewrite (⦗E⦘ ⨾ ⦗W⦘ ⊆ ⦗E ∩₁ W⦘) by basic_solver.
rewrite <- IT.

arewrite (I ∪₁ T ⊆₁ (I \₁ T) ∪₁ T) at 1.
unfolder; ins; desf; tauto.

arewrite (I ∪₁ T ⊆₁ (T \₁ I) ∪₁ I) at 1.
unfolder; ins; desf; tauto.

rewrite !id_union; relsf.

sin_rewrite !T_new_co.
sin_rewrite new_co_I.
basic_solver 21.
Qed.

Lemma T_I_col0_I_T l :
  ⦗ T \₁ I ⦘ ⨾ col0 l ⨾ ⦗ I \₁ T ⦘  ⊆
  ⦗ T \₁ I ⦘ ⨾ col l ⨾ ⦗ I ∩₁ T ⦘ ⨾ col l ⨾ ⦗ I \₁ T ⦘.
Proof using co_trans.
unfold col0 at 1.
arewrite (⦗T⦘ ⊆ ⦗T \₁ I⦘ ∪ ⦗I ∩₁ T⦘) at 2.
unfolder; ins ;desf; tauto.
relsf.
rewrite <- !unionA.
rewrite unionC.
rewrite <- !unionA.
rewrite path_ut_first; relsf; unionL.
- transitivity (∅₂ : actid -> actid -> Prop); [|basic_solver].
  rewrite path_ut_last; relsf; unionL.
  rewrite ct_begin; basic_solver.
  rewrite (rtE (⦗I⦘ ⨾ col l ⨾ ⦗T⦘ ∪ ⦗I⦘ ⨾ col l ⨾ ⦗I⦘)).
  relsf; unionL.
  basic_solver.
  rewrite ct_begin; basic_solver.
- arewrite (⦗I⦘ ⨾ col l ⨾ ⦗T⦘ ∪ ⦗I⦘ ⨾ col l ⨾ ⦗I⦘ ∪ ⦗T⦘ ⨾ col l ⨾ ⦗T \₁ I⦘ ⊆ col l).
  basic_solver.
  arewrite (col l ∪ ⦗T⦘ ⨾ col l ⨾ ⦗I ∩₁ T⦘ ⊆ col l).
  basic_solver.
  generalize (@col_trans l); ins; relsf.
  basic_solver 21.
Qed.

Lemma T_I_new_col_I_T l :
  ⦗ T \₁ I ⦘ ⨾ new_col l ⨾ ⦗ I \₁ T ⦘  ⊆
  col l ⨾ ⦗ I ∩₁ T ⦘ ⨾ col l.
Proof using co_trans.
unfold new_col, pref_union.
unfolder; ins; desf.
assert (A: (⦗ T \₁ I ⦘ ⨾ col0 l ⨾ ⦗ I \₁ T ⦘) x y) by basic_solver.
apply T_I_col0_I_T in A; unfolder in A; basic_solver 10.
Qed.

Lemma T_I_new_co_I_T :
  ⦗ T \₁ I ⦘ ⨾ new_co ⨾ ⦗ I \₁ T ⦘  ⊆
  co ⨾ ⦗ I ∩₁ T ⦘ ⨾ co.
Proof using co_trans.
unfold new_co.
unfolder; ins; desf.
assert (A: (⦗ T \₁ I ⦘ ⨾ new_col l ⨾ ⦗ I \₁ T ⦘) x y) by basic_solver.
apply T_I_new_col_I_T in A; unfolder in A; desf.
unfold col in *; unfolder in *; desf; eauto 10.
Qed.

Lemma co_for_split: codom_rel (⦗set_compl I⦘ ⨾ (immediate new_co)) ⊆₁ T.
Proof using IT wf_coD wf_coE.
unfolder; ins; desf.
destruct (classic (T x)) as [|X]; auto.
exfalso.
hahn_rewrite wf_new_coE in H0.
hahn_rewrite wf_new_coD in H0.
unfolder in H0; desf.
assert (Ix: I x).
by assert (S: (E ∩₁ W) x) by basic_solver; apply IT in S; unfolder in S; ins; desf.
unfold new_co, new_col, pref_union in *; desc.
destruct H4 as [K|]; cycle 1.
by unfolder in H2; basic_solver 21.
unfold col0 in *.
destruct K.
unfolder in H2; basic_solver 21.
eauto 12.
Qed.

Lemma new_col_helper l : ⦗ T ⦘ ⨾ col l ⨾ ⦗ I ∩₁ T ⦘ ⨾ col l ⨾ ⦗ I ⦘ ⊆ new_col l.
Proof using.
unfold new_col, pref_union, col0.
unfolder; ins; left; desf.
eapply t_trans; apply t_step; eauto 15.
Qed.

Lemma new_co_helper : ⦗ T ⦘ ⨾ co ⨾ ⦗ I ∩₁ T ⦘ ⨾ co ⨾ ⦗ I ⦘ ⊆ new_co.
Proof using wf_coD wf_col.
unfold new_co.
unfolder; ins; desf.
apply co_in_col in H0.
apply co_in_col in H2.
desf.
assert (l = l0); subst.
{ hahn_rewrite wf_colD in H0.
  hahn_rewrite wf_colD in H2.
  unfolder in *; desf. }
exists l0.
apply new_col_helper.
basic_solver 12.
Qed.

Lemma I_co_in_new_co : ⦗ I ⦘ ⨾ co ⊆ new_co.
Proof using IT wf_coD wf_coE wf_col.
unfold new_co.
unfolder; ins; desf.
apply co_in_col in H0.
desf.
exists l.
unfold new_col, pref_union, col0.
left.
apply t_step.
destruct (classic (I y)).
basic_solver 11.
right; unfolder; splits; eauto.
hahn_rewrite (wf_colE) in H0.
hahn_rewrite (wf_colD) in H0.
unfolder in H0; desf.
assert ((I ∪₁ T) y).
eapply IT; basic_solver.
unfolder in *; desf.
Qed.

End CO.

Global Add Parametric Morphism : col0 with signature
    eq ==> (@set_subset actid) ==> (@set_subset actid) ==> eq ==>
       (@inclusion actid) as col0_mori.
Proof using.
  ins. unfold col0. rewrite H, H0. basic_solver.
Qed.

Global Add Parametric Morphism : col0 with signature
    eq ==> (@set_equiv actid) ==> (@set_equiv actid) ==> eq ==>
       (@same_relation actid) as col0_more.
Proof using.
  ins. destruct H, H0.
  split; apply col0_mori; basic_solver.
Qed.

Global Add Parametric Morphism : new_co with signature
    eq ==> (@set_equiv actid) ==> (@set_equiv actid) ==>
       (@inclusion actid) as new_co_more_impl.
Proof using.
  ins. unfold new_co, new_col.
  unfolder. ins. desc. red in H1.
  destruct H, H0.
  exists l. des.
  { left. eapply col0_mori; eauto. }
  apply pref_union_alt.
  right. split.
  { splits; vauto.
    { by apply H. }
    intro. apply H6. basic_solver. }
  intro. apply H4. eapply col0_mori; eauto.
Qed.

Global Add Parametric Morphism : new_co with signature
    eq ==> (@set_equiv actid) ==> (@set_equiv actid) ==>
       (@same_relation actid) as new_co_more.
Proof using.
  ins. split; [| symmetry in H, H0]; eapply new_co_more_impl; eauto.
Qed.


Require Import Coq.Strings.String.
Require Import Mem.
Require Import Prog.
Require Import List.
Require Import Word.
Require Import Rec.
Require Import BFile.
Require Import BasicProg.
Require Import Log.
Require Import Hoare.
Require Import Pred PredCrash.
Require Import Omega.
Require Import Rec.
Require Import Array.
Require Import ListPred.
Require Import GenSepN.
Require Import BFile.
Require Import FileRecArray.
Require Import Bool.
Require Import SepAuto.
Require Import Log.
Require Import Cache.
Require Import ListUtils.
Require Import AsyncDisk.
Require Import Errno.
Require Import DestructVarname.
Import ListNotations.
Require HexString.

Set Implicit Arguments.

Module DIR.

  Definition filename_len := (HexString.to_nat "0x400" (* 1024 *) - addrlen - addrlen).
  Definition filename := word filename_len.

  Module DentSig <: FileRASig.

    Definition itemtype : Rec.type := Rec.RecF
        ([("name",  Rec.WordF filename_len);
          ("inum",  Rec.WordF addrlen);
          ("valid", Rec.WordF 1);
          ("isdir", Rec.WordF 1);
          ("unused", Rec.WordF (addrlen - 2))
         ]).

    Definition items_per_val := valulen / (Rec.len itemtype).

    Theorem blocksz_ok : valulen = Rec.len (Rec.ArrayF itemtype items_per_val).
    Proof.
      unfold items_per_val; simpl.
      rewrite valulen_is. apply Nat.eqb_eq.
      compute; reflexivity.
    Qed.

  End DentSig.

  Module Dent := FileRecArray DentSig.

  (*************  dirent accessors  *)

  Definition dent := Dent.Defs.item.
  Definition dent0 := Dent.Defs.item0.

  Fact resolve_selN_dent0 : forall l i d,
    d = dent0 -> selN l i d = selN l i dent0.
  Proof.
    intros; subst; auto.
  Qed.

  Hint Rewrite resolve_selN_dent0 using reflexivity : defaults.

  Definition bit2bool bit := if (bit_dec bit) then false else true.
  Definition bool2bit bool : word 1 := if (bool_dec bool true) then $1 else $0.

  Definition DEIsDir (de : dent) := Eval compute_rec in de :-> "isdir".
  Definition DEValid (de : dent) := Eval compute_rec in de :-> "valid".
  Definition DEName  (de : dent) := Eval compute_rec in de :-> "name".
  Definition DEInum  (de : dent) := Eval compute_rec in # (de :-> "inum").
  Definition mk_dent (name : filename) inum isdir : dent := Eval cbn in
      dent0 :=> "valid" := $1 :=>
                "name" := name :=>
                "inum" := $ inum :=>
                "isdir" := bool2bit isdir.

  Definition is_dir   (de : dent) := bit2bool (DEIsDir de).
  Definition is_valid (de : dent) := bit2bool (DEValid de).
  Definition name_is  (n : filename) (de : dent) :=
      if (weq n (DEName de)) then true else false.

  (*************  rep invariant  *)

  Definition dmatch (de: dent) : @pred filename (@weq filename_len) (addr * bool) :=
    if bool_dec (is_valid de) false then emp
    else (DEName de) |-> (DEInum de, is_dir de) * [[ DEInum de <> 0 ]].

  Definition rep f dmap :=
    exists delist,
    (Dent.rep f delist)%pred (list2nmem (BFILE.BFData f)) /\
    listpred dmatch delist dmap.

  Definition rep_macro Fm Fi m bxp ixp inum dmap ilist frees f ms sm : (@pred _ addr_eq_dec valuset) :=
    (exists flist,
    [[[ m ::: Fm * BFILE.rep bxp sm ixp flist ilist frees (BFILE.MSAllocC ms) (BFILE.MSCache ms) (BFILE.MSICache ms) (BFILE.MSDBlocks ms) ]]] *
    [[[ flist ::: Fi * inum |-> f ]]] *
    [[ rep f dmap ]])%pred.

  (*************  program  *)

  Definition lookup_f name de (_ : addr) := (is_valid de) && (name_is name de).

  Definition ifind_lookup_f lxp ixp dnum name ms :=
    Dent.ifind lxp ixp dnum (lookup_f name) ms.

  Definition ifind_invalid lxp ixp dnum ms :=
    Dent.ifind lxp ixp dnum (fun de _ => negb (is_valid de)) ms.

  Definition lookup lxp ixp dnum name ms :=
    let^ (ms, r) <- ifind_lookup_f lxp ixp dnum name ms;
    match r with
    | None => Ret ^(ms, None)
    | Some (_, de) => Ret ^(ms, Some (DEInum de, is_dir de))
    end.

  Definition readent := (filename * (addr * bool))%type.

  Definition readdir lxp ixp dnum ms :=
    let^ (ms, dents) <- Dent.readall lxp ixp dnum ms;
    let r := map (fun de => (DEName de, (DEInum de, is_dir de))) (filter is_valid dents) in
    Ret ^(ms, r).

  Definition unlink lxp ixp dnum name ms :=
    let^ (ms, r) <- ifind_lookup_f lxp ixp dnum name ms;
    match r with
    | None => Ret ^(ms, 0, Err ENOENT)
    | Some (ix, _) =>
        ms <- Dent.put lxp ixp dnum ix dent0 ms;
        Ret ^(ms, ix, OK tt)
    end.

  Definition link' lxp bxp ixp dnum name inum isdir ms :=
    let de := mk_dent name inum isdir in
    let^ (ms, r) <- ifind_invalid lxp ixp dnum ms;
    match r with
    | Some (ix, _) =>
        ms <- Dent.put lxp ixp dnum ix de ms;
        Ret ^(ms, ix+1, OK tt)
    | None =>
        let^ (ms, ok) <- Dent.extend lxp bxp ixp dnum de ms;
        Ret ^(ms, 0, ok)
    end.

  (* link without hint *)
  Definition link'' lxp bxp ixp dnum name inum isdir (ix0:addr) ms :=
    let^ (ms, ix, r0) <- link' lxp bxp ixp dnum name inum isdir ms;
    Ret ^(ms, ix, r0).

  (* link with hint *)
  Definition link lxp bxp ixp dnum name inum isdir ix0 ms :=
    let de := mk_dent name inum isdir in
    let^ (ms, len) <- BFILE.getlen lxp ixp dnum ms;
    If (lt_dec ix0 (len * Dent.RA.items_per_val)) {
      let^ (ms, res) <- Dent.get lxp ixp dnum ix0 ms;
      match (is_valid res) with
      | true =>
        let^ (ms, ix, r0) <- link' lxp bxp ixp dnum name inum isdir ms;
        Ret ^(ms, ix, r0)
      | false =>
        ms <- Dent.put lxp ixp dnum ix0 de ms;
        Ret ^(ms, ix0+1, OK tt)
      end
    } else {
(* calling extend here slows down performance drastically.
        let^ (ms, ok) <- Dent.extend lxp bxp ixp dnum de ms;
        Ret ^(ms, ix0+1, ok)  *)
      let^ (ms, ix, r0) <- link' lxp bxp ixp dnum name inum isdir ms;
      Ret ^(ms, ix, r0)
    }.

  (*************  basic lemmas  *)

  Fact bit2bool_0 : bit2bool $0 = false.
  Proof.
    unfold bit2bool; destruct (bit_dec $0); auto.
    contradict e; apply natToWord_discriminate; auto.
  Qed.

  Fact bit2bool_1 : bit2bool $1 = true.
  Proof.
    unfold bit2bool; destruct (bit_dec $1); auto.
    apply eq_sym in e; contradict e.
    apply natToWord_discriminate; auto.
  Qed.

  Fact bit2bool_1_ne : bit2bool $1 <> false.
  Proof. rewrite bit2bool_1; congruence. Qed.

  Fact bit2bool_0_ne : bit2bool $0 <> true.
  Proof. rewrite bit2bool_0; congruence. Qed.

  Local Hint Resolve bit2bool_0 bit2bool_1 bit2bool_0_ne bit2bool_1_ne.

  Lemma bit2bool2bit : forall b, bit2bool (bool2bit b) = b.
  Proof.
    destruct b; cbn; auto.
  Qed.

  Lemma bool2bit2bool : forall b,  bool2bit (bit2bool b) = b.
  Proof.
    unfold bit2bool; intros.
    destruct (bit_dec b); subst; auto.
  Qed.

  Lemma lookup_f_ok: forall name de a,
    lookup_f name de a = true ->
    is_valid de = true /\ DEName de = name.
  Proof.
    unfold lookup_f, name_is; intuition.
    apply andb_true_iff in H; tauto.
    destruct (weq name (DEName de)); auto.
    contradict H.
    rewrite andb_true_iff; easy.
  Qed.

  Lemma lookup_f_nf: forall name de a,
    lookup_f name de a = false ->
    is_valid de = false \/ DEName de <> name.
  Proof.
    unfold lookup_f, name_is; intuition.
    apply andb_false_iff in H; intuition.
    destruct (weq name (DEName de)); intuition.
  Qed.

  Lemma lookup_notindomain': forall l ix name,
    Forall (fun e => (lookup_f name e ix) = false) l
    -> listpred dmatch l =p=> notindomain name.
  Proof.
    induction l; unfold pimpl; simpl; intros.
    apply emp_notindomain; auto.
    inversion H; subst.

    destruct (Sumbool.sumbool_of_bool (is_valid a)).
    destruct (lookup_f_nf name a ix); try congruence.
    eapply notindomain_mem_except; eauto.
    eapply ptsto_mem_except.
    pred_apply; unfold dmatch at 1.
    rewrite e, IHl by eauto; simpl; cancel.

    pred_apply; rewrite IHl by eauto; cancel.
    unfold dmatch; rewrite e; simpl; auto.
  Qed.

  Lemma lookup_notindomain: forall l name,
    (forall i, i < length l -> lookup_f name (selN l i dent0) i = false) ->
    listpred dmatch l =p=> notindomain name.
  Proof.
    intros.
    eapply lookup_notindomain' with (ix := 0).
    eapply selN_Forall; eauto.
  Qed.

  Definition dmatch_ex name (de: dent) : @pred filename (@weq filename_len) (addr * bool) :=
    if (name_is name de) then emp
    else dmatch de.

  Definition dmatch_ex_same : forall de,
    dmatch_ex (DEName de) de = emp.
  Proof.
    unfold dmatch_ex, name_is; intros.
    destruct (weq (DEName de) (DEName de)); congruence.
  Qed.

  Definition dmatch_ex_diff : forall name de,
    name <> (DEName de) ->
    dmatch_ex name de = dmatch de.
  Proof.
    unfold dmatch_ex, name_is; intros.
    destruct (weq name (DEName de)); congruence.
  Qed.

  Lemma dmatch_ex_ptsto : forall l name v,
    (name |-> v * listpred dmatch l)
    =p=> (name |-> v * listpred (dmatch_ex name) l).
  Proof.
    induction l; simpl; intros; auto.
    unfold dmatch_ex at 1, dmatch at 1, dmatch at 2, name_is.
    destruct (bool_dec (is_valid a) false).
    destruct (weq name (DEName a));
    rewrite sep_star_comm, sep_star_assoc;
    setoid_rewrite sep_star_comm at 2; rewrite IHl; cancel.

    destruct (weq name (DEName a)); subst.
    unfold pimpl; intros; exfalso.
    eapply ptsto_conflict_F with (m := m) (a := DEName a).
    pred_apply; cancel.
    eapply pimpl_trans with (b := (name |-> v * listpred dmatch l * [[DEInum a <> 0 ]] * _)%pred).
    cancel. rewrite IHl. cancel.
  Qed.

  Lemma lookup_ptsto: forall l name ix,
    ix < length l ->
    lookup_f name (selN l ix dent0) ix = true ->
    listpred dmatch l =p=> listpred (dmatch_ex name) l *
       (name |-> (DEInum (selN l ix dent0), is_dir (selN l ix dent0))).
  Proof.
    induction l; intros.
    simpl; inversion H.
    pose proof (lookup_f_ok _ _ _ H0) as [Hx Hy].
    destruct ix; subst; simpl in *.
    unfold dmatch at 1; rewrite Hx, dmatch_ex_same; simpl.
    eapply pimpl_trans with (b := (DEName a |-> _ * listpred dmatch l * _)%pred).
    cancel. rewrite dmatch_ex_ptsto; cancel.

    assert (ix < length l) by omega.
    rewrite IHl; eauto; try solve [ cancel ].
    unfold dmatch_ex at 2, dmatch, name_is.
    destruct (bool_dec (is_valid _) false);
    destruct (weq (DEName _) _); try solve [ cancel ].
    rewrite e; repeat destruct_prod.
    unfold pimpl; intros; exfalso.
    eapply ptsto_conflict_F with (m := m) (a := DEName (w, (w0, (w1, (w2, (w3, u)))))).
    pred_apply; cancel.
  Qed.

  Definition readmatch (de: readent) : @pred _ (@weq filename_len) _ :=
    fst de |-> snd de.

  Lemma readmatch_ok : forall l,
    listpred dmatch l =p=> listpred readmatch
      (map (fun de => (DEName de, (DEInum de, is_dir de))) (filter is_valid l)).
  Proof.
    induction l; simpl; auto.
    unfold dmatch at 1; destruct (is_valid a); simpl.
    rewrite IHl; cancel.
    cancel.
  Qed.

  Lemma dmatch_dent0_emp :  dmatch dent0 = emp.
  Proof.
    unfold dmatch, dent0.
    destruct (bool_dec (is_valid _) false); auto.
    contradict n.
    compute; auto.
  Qed.

  Lemma listpred_dmatch_dent0_emp : forall l i dmap,
    listpred dmatch l dmap ->
    is_valid (selN l i dent0) = true ->
    i < length l ->
    listpred dmatch (updN l i dent0) (mem_except dmap (DEName (selN l i dent0))).
  Proof.
    intros.
    apply listpred_updN; auto.
    rewrite dmatch_dent0_emp.
    eapply ptsto_mem_except; pred_apply.
    rewrite listpred_isolate by eauto.
    unfold dmatch at 2; rewrite H0; simpl.
    repeat cancel.
  Qed.

  Lemma dmatch_mk_dent : forall name inum isdir,
    goodSize addrlen inum ->
    dmatch (mk_dent name inum isdir) = (name |-> (inum, isdir) * [[ inum <> 0 ]])%pred.
  Proof.
    unfold dmatch, mk_dent, is_valid, is_dir; intros; cbn.
    rewrite bit2bool_1, wordToNat_natToWord_idempotent', bit2bool2bit; auto.
  Qed.

  Lemma listpred_dmatch_mem_upd : forall l i dmap name inum isdir,
    notindomain name dmap ->
    negb (is_valid (selN l i dent0)) = true ->
    listpred dmatch l dmap ->
    i < length l -> inum <> 0 ->
    goodSize addrlen inum ->
    listpred dmatch (updN l i (mk_dent name inum isdir)) (Mem.upd dmap name (inum, isdir)).
  Proof.
    intros.
    apply listpred_updN; auto.
    rewrite dmatch_mk_dent by auto.
    eapply pimpl_apply. cancel.
    apply ptsto_upd_disjoint.
    apply negb_true_iff in H0.
    pred_apply.
    setoid_rewrite listpred_isolate with (def := dent0) at 1; eauto.
    unfold dmatch at 2; rewrite H0; cancel.
    eauto.
  Qed.

  Lemma listpred_dmatch_repeat_dent0 : forall n,
    listpred dmatch (repeat dent0 n) <=p=> emp.
  Proof.
    induction n; intros; simpl; eauto.
    split; rewrite dmatch_dent0_emp, IHn; cancel.
  Qed.

  Lemma listpred_dmatch_ext_mem_upd : forall l dmap name inum isdir,
    notindomain name dmap ->
    (forall i, i < length l -> negb (is_valid (selN l i dent0)) = false) ->
    listpred dmatch l dmap ->
    goodSize addrlen inum -> inum <> 0 ->
    listpred dmatch (l ++ @updN (Rec.data Dent.RA.itemtype) (Dent.Defs.block0) 0 (mk_dent name inum isdir))
                    (Mem.upd dmap name (inum, isdir)).
  Proof.
    intros.
    pose proof (Dent.Defs.items_per_val_gt_0).
    erewrite <- Nat.sub_diag, <- updN_app2, Dent.Defs.block0_repeat by auto.
    apply listpred_updN; auto.
    rewrite app_length, repeat_length; omega.

    replace (length l) with (length l + 0) by omega.
    rewrite removeN_app_r, removeN_repeat, listpred_app by auto.
    rewrite listpred_dmatch_repeat_dent0.
    rewrite dmatch_mk_dent by auto.
    eapply pimpl_apply. cancel.
    apply ptsto_upd_disjoint; auto.
  Qed.

  Lemma listpred_dmatch_eq_mem : forall l m m',
    listpred dmatch l m -> listpred dmatch l m' ->
    m = m'.
  Proof.
    induction l; cbn; intros m m' H H'.
    - apply emp_empty_mem_only in H.
      apply emp_empty_mem_only in H'.
      congruence.
    - unfold dmatch at 1 in H.
      unfold dmatch at 1 in H'.
      destruct bool_dec.
      apply IHl; pred_apply; cancel.
      eapply pimpl_trans in H; [| cancel..].
      eapply pimpl_trans in H'; [| cancel..].
      revert H. revert H'.
      unfold_sep_star.
      intros. repeat deex.
      match goal with H1 : (ptsto _ _ ?m), H2 : (ptsto _ _ ?m') |- _ =>
        assert (m = m') by (eapply ptsto_complete; eauto); subst
      end.
      f_equal.
      eauto.
  Qed.

  Lemma listpred_dmatch_notindomain: forall delist dmap name x,
    notindomain name dmap ->
    listpred dmatch delist (upd dmap name x) ->
    listpred dmatch delist =p=> notindomain name * name |-> x.
  Proof.
    intros. intros m ?.
    replace m with (upd dmap name x) in * by (eauto using listpred_dmatch_eq_mem).
    apply ptsto_upd_disjoint; auto.
  Qed.

  Lemma dmatch_no_0_inum: forall f m, dmatch f m ->
    forall name isdir, m name = Some (0, isdir) -> False.
  Proof.
    unfold dmatch.
    intros; destruct bool_dec; destruct_lifts.
    congruence.
    unfold ptsto in *. intuition.
    destruct (weq name (DEName f)); subst.
    congruence.
    denote (m name = Some _) as Hm.
    denote (m _ = None) as Ha.
    rewrite Ha in Hm by auto.
    congruence.
  Unshelve.
    all: auto; repeat constructor.
  Qed.

  Lemma listpred_dmatch_no_0_inum: forall dmap m,
    listpred dmatch dmap m ->
    forall name isdir, m name = Some (0, isdir) -> False.
  Proof.
    induction dmap; cbn; intros.
    congruence.
    revert H.
    unfold_sep_star.
    intros. repeat deex.
    unfold mem_union in *.
    destruct (m1 name) eqn:?.
    denote (Some _ = Some _) as Hs; inversion Hs; subst; clear Hs.
    eauto using dmatch_no_0_inum.
    eauto.
  Unshelve.
    all: eauto.
  Qed.

  (*************  correctness theorems  *)

  Notation MSLL := BFILE.MSLL.
  Notation MSAlloc := BFILE.MSAlloc.
  Notation MSCache := BFILE.MSCache.
  Notation MSAllocC := BFILE.MSAllocC.
  Notation MSIAllocC := BFILE.MSIAllocC.
  Notation MSDBlocks := BFILE.MSDBlocks.

  Theorem lookup_ok : forall lxp bxp ixp dnum name ms,
    {< F Fm Fi m0 sm m dmap ilist frees f,
    PRE:hm LOG.rep lxp F (LOG.ActiveTxn m0 m) (MSLL ms) sm hm *
           rep_macro Fm Fi m bxp ixp dnum dmap ilist frees f ms sm
    POST:hm' RET:^(ms',r)
           LOG.rep lxp F (LOG.ActiveTxn m0 m) (MSLL ms') sm hm' *
           rep_macro Fm Fi m bxp ixp dnum dmap ilist frees f ms' sm *
           [[ MSAlloc ms' = MSAlloc ms ]] *
           [[ MSAllocC ms' = MSAllocC ms ]] *
         ( [[ r = None /\ notindomain name dmap ]] \/
           exists inum isdir Fd,
           [[ r = Some (inum, isdir) /\ inum <> 0 /\
                   (Fd * name |-> (inum, isdir))%pred dmap ]])
    CRASH:hm'  exists ms',
           LOG.rep lxp F (LOG.ActiveTxn m0 m) (MSLL ms') sm hm'
    >} lookup lxp ixp dnum name ms.
  Proof.
    unfold lookup, ifind_lookup_f, rep_macro, rep.
    safestep.
    safestep.
    or_r; cancel.
    eapply listpred_dmatch_no_0_inum; eauto.
    eapply ptsto_valid'.
    denote DEInum as Hd.
    erewrite selN_inb in Hd by auto.
    rewrite <- Hd.
    eapply lookup_ptsto; eauto.
    eapply lookup_ptsto; eauto.
    or_l; cancel.
    apply lookup_notindomain; auto.
  Unshelve.
    all: try (exact false || exact emp).
    all: eauto.
  Qed.

  Theorem readdir_ok : forall lxp bxp ixp dnum ms,
    {< F Fm Fi m0 sm m dmap ilist frees f,
    PRE:hm   LOG.rep lxp F (LOG.ActiveTxn m0 m) (MSLL ms) sm hm *
             rep_macro Fm Fi m bxp ixp dnum dmap ilist frees f ms sm
    POST:hm' RET:^(ms',r)
             LOG.rep lxp F (LOG.ActiveTxn m0 m) (MSLL ms') sm hm' *
             rep_macro Fm Fi m bxp ixp dnum dmap ilist frees f ms' sm *
             [[ listpred readmatch r dmap ]] *
             [[ MSAlloc ms' = MSAlloc ms ]] *
             [[ MSCache ms' = MSCache ms ]] *
             [[ MSAllocC ms' = MSAllocC ms ]] *
             [[ MSIAllocC ms' = MSIAllocC ms ]] *
             [[ MSDBlocks ms' = MSDBlocks ms ]]
    CRASH:hm'  exists ms',
           LOG.rep lxp F (LOG.ActiveTxn m0 m) (MSLL ms') sm hm'
    >} readdir lxp ixp dnum ms.
  Proof.
    unfold readdir, rep_macro, rep.
    safestep.
    step.
    apply readmatch_ok.
  Qed.

  Local Hint Resolve mem_except_notindomain.

  Theorem unlink_ok : forall lxp bxp ixp dnum name ms,
    {< F Fm Fi m0 sm m dmap ilist frees,
    PRE:hm   LOG.rep lxp F (LOG.ActiveTxn m0 m) (MSLL ms) sm hm *
             exists f, rep_macro Fm Fi m bxp ixp dnum dmap ilist frees f ms sm
    POST:hm' RET:^(ms', hint, r) exists m' dmap',
             LOG.rep lxp F (LOG.ActiveTxn m0 m') (MSLL ms') sm hm' *
             exists f', rep_macro Fm Fi m' bxp ixp dnum dmap' ilist frees f' ms' sm *
             [[ dmap' = mem_except dmap name ]] *
             [[ notindomain name dmap' ]] *
             [[ r = OK tt -> indomain name dmap ]] *
             [[ MSAlloc ms' = MSAlloc ms ]] *
             [[ MSAllocC ms' = MSAllocC ms ]] *
             [[ MSIAllocC ms' = MSIAllocC ms ]]
    CRASH:hm' LOG.intact lxp F m0 sm hm'
    >} unlink lxp ixp dnum name ms.
  Proof.
    unfold unlink, ifind_lookup_f, rep_macro, rep.
    step.
    step.

    apply Dent.Defs.item0_wellformed.
    msalloc_eq.

    denote (lookup_f) as HH.
    pose proof (lookup_f_ok _ _ _ HH) as [Hx Hy].

    step.

    eexists; split; eauto.
    apply listpred_dmatch_dent0_emp; auto.

    rewrite lookup_ptsto by eauto.
    unfold pimpl; intros.
    eapply sep_star_ptsto_indomain.
    pred_apply; cancel.

    rewrite <- notindomain_mem_eq; auto.
    eapply lookup_notindomain; eauto.
    eapply lookup_notindomain; eauto.

  Unshelve.
    all: easy.
  Qed.

  Theorem link'_ok : forall lxp bxp ixp dnum name inum isdir ms,
    {< F Fm Fi m0 sm m dmap ilist frees,
    PRE:hm   LOG.rep lxp F (LOG.ActiveTxn m0 m) (MSLL ms) sm hm *
             exists f, rep_macro Fm Fi m bxp ixp dnum dmap ilist frees f ms sm *
             [[ notindomain name dmap ]] *
             [[ goodSize addrlen inum ]] *
             [[ inum <> 0 ]]
    POST:hm' RET:^(ms', ixhint', r) exists m',
             [[ MSAlloc ms' = MSAlloc ms ]] *
             [[ MSIAllocC ms' = MSIAllocC ms ]] *
           (([[ isError r ]] * LOG.rep lxp F (LOG.ActiveTxn m0 m') (MSLL ms') sm hm')
        \/  ([[ r = OK tt ]] *
             exists dmap' Fd ilist' frees' f',
             LOG.rep lxp F (LOG.ActiveTxn m0 m') (MSLL ms') sm hm' *
             rep_macro Fm Fi m' bxp ixp dnum dmap' ilist' frees' f' ms' sm *
             [[ dmap' = Mem.upd dmap name (inum, isdir) ]] *
             [[ (Fd * name |-> (inum, isdir))%pred dmap' ]] *
             [[ (Fd dmap /\ notindomain name dmap) ]] *
             [[ BFILE.ilist_safe ilist  (BFILE.pick_balloc frees  (MSAlloc ms'))
                                 ilist' (BFILE.pick_balloc frees' (MSAlloc ms')) ]] *
             [[ BFILE.treeseq_ilist_safe dnum ilist ilist' ]] ))
    CRASH:hm' LOG.intact lxp F m0 sm hm'
    >} link' lxp bxp ixp dnum name inum isdir ms.
  Proof.
    unfold link', ifind_lookup_f, ifind_invalid, rep_macro, rep.
    step.
    step; msalloc_eq.

    (* case 1: use avail entry *)
    cbv; tauto.
    step; msalloc_eq.
    or_r; cancel.
    eexists; split; eauto.
    apply listpred_dmatch_mem_upd; auto.
    eapply ptsto_upd_disjoint; eauto.
    apply BFILE.ilist_safe_refl.
    apply BFILE.treeseq_ilist_safe_refl.

    (* case 2: extend new entry *)
    cbv; tauto.

    step; msalloc_eq.
    or_r; cancel; eauto.
    eexists; split; eauto.
    eapply listpred_dmatch_ext_mem_upd; eauto.
    eapply ptsto_upd_disjoint; eauto.
  Unshelve.
    all: eauto.
  Qed.

  Hint Extern 1 ({{ _ }} Bind (link' _ _ _ _ _ _ _ _) _) => apply link'_ok : prog.

  Theorem link_ok : forall lxp bxp ixp dnum name inum isdir ixhint ms,
    {< F Fm Fi m0 sm m dmap ilist frees,
    PRE:hm   LOG.rep lxp F (LOG.ActiveTxn m0 m) (MSLL ms) sm hm *
             exists f, rep_macro Fm Fi m bxp ixp dnum dmap ilist frees f ms sm *
             [[ notindomain name dmap ]] *
             [[ goodSize addrlen inum ]] *
             [[ inum <> 0 ]]
    POST:hm' RET:^(ms', ixhint', r) exists m',
             [[ MSAlloc ms' = MSAlloc ms ]] *
             [[ MSIAllocC ms' = MSIAllocC ms ]] *
           (([[ isError r ]] * LOG.rep lxp F (LOG.ActiveTxn m0 m') (MSLL ms') sm hm')
        \/  ([[ r = OK tt ]] *
             exists dmap' Fd ilist' frees' f',
             LOG.rep lxp F (LOG.ActiveTxn m0 m') (MSLL ms') sm hm' *
             rep_macro Fm Fi m' bxp ixp dnum dmap' ilist' frees' f' ms' sm *
             [[ dmap' = Mem.upd dmap name (inum, isdir) ]] *
             [[ (Fd * name |-> (inum, isdir))%pred dmap' ]] *
             [[ (Fd dmap /\ notindomain name dmap) ]] *
             [[ BFILE.ilist_safe ilist  (BFILE.pick_balloc frees  (MSAlloc ms'))
                                 ilist' (BFILE.pick_balloc frees' (MSAlloc ms')) ]] *
             [[ BFILE.treeseq_ilist_safe dnum ilist ilist' ]] ))
    CRASH:hm' LOG.intact lxp F m0 sm hm'
    >} link lxp bxp ixp dnum name inum isdir ixhint ms.
  Proof.
    unfold link, rep_macro, rep.
    step.
    step; msalloc_eq.

    (* case 1: try entry hint *)
    step.
    erewrite Dent.items_length_ok with (xp := f) (m := (list2nmem (BFILE.BFData f))).
    unfold Dent.RA.RALen. auto.
    pred_apply; cancel.
    destruct is_valid eqn:?.
    (* working around a 'not found' Coq bug, probably #4202 in simpl *)
    prestep. unfold rep_macro, rep. norm. cancel.
    intuition ((pred_apply; cancel) || eauto).
    step.
    or_r. cancel.
    eauto.
    eapply listpred_dmatch_notindomain; eauto.
    eauto.
    cancel.

    (* case 2: use hinted entry *)
    step; msalloc_eq.
    erewrite Dent.items_length_ok with (xp := f) (m := (list2nmem (BFILE.BFData f))).
    unfold Dent.RA.RALen. auto.
    pred_apply; cancel.
    cbv; tauto.
    step.
    or_r; cancel.
    eexists; split; eauto.
    apply listpred_dmatch_mem_upd; auto.
    rewrite Bool.negb_true_iff; auto.
    erewrite Dent.items_length_ok with (xp := f) (m := (list2nmem (BFILE.BFData f))).
    unfold Dent.RA.RALen. auto.
    pred_apply; cancel.
    eapply ptsto_upd_disjoint; auto.
    apply BFILE.ilist_safe_refl.
    apply BFILE.treeseq_ilist_safe_refl.

    (* case 3: hint was out of bounds, so ignore it *)
    (* working around a 'not found' Coq bug, probably #4202 in simpl *)
    prestep. unfold rep_macro, rep. norm. cancel.
    intuition ((pred_apply; cancel) || eauto).
    step.
    or_r. cancel.
    eauto.
    eapply listpred_dmatch_notindomain; eauto.
    eauto.
    cancel.
  Unshelve.
    all: eauto.
  Qed.

  Hint Extern 1 ({{_}} Bind (lookup _ _ _ _ _) _) => apply lookup_ok : prog.
  Hint Extern 1 ({{_}} Bind (unlink _ _ _ _ _) _) => apply unlink_ok : prog.
  Hint Extern 1 ({{_}} Bind (link _ _ _ _ _ _ _ _ _) _) => apply link_ok : prog.
  Hint Extern 1 ({{_}} Bind (readdir _ _ _ _) _) => apply readdir_ok : prog.

  Hint Extern 0 (okToUnify (rep ?f _) (rep ?f _)) => constructor : okToUnify.

  (*************  Lemma for callers *)

  Theorem dmatch_complete : forall de m1 m2, dmatch de m1 -> dmatch de m2 -> m1 = m2.
  Proof.
    unfold dmatch, is_dir; intros.
    destruct (bool_dec (is_valid de) false).
    apply emp_complete; eauto.
    eapply ptsto_complete; pred_apply; cancel.
  Qed.

  Lemma listpred_dmatch_eq : forall l m1 m2,
    listpred dmatch l m1
    -> listpred dmatch l m2
    -> m1 = m2.
  Proof.
    induction l; simpl; auto.
    apply emp_complete; auto.
    intros m1 m2.
    unfold_sep_star; intuition.
    repeat deex; f_equal.
    eapply dmatch_complete; eauto.
    eapply IHl; eauto.
  Qed.

  Lemma rep_mem_eq : forall f m1 m2,
    rep f m1 ->
    rep f m2 ->
    m1 = m2.
  Proof.
    unfold rep; intros.
    repeat deex.
    pose proof (Dent.rep_items_eq H0 H1); subst.
    eapply listpred_dmatch_eq; eauto.
  Qed.

  Theorem bfile0_empty : rep BFILE.bfile0 empty_mem.
  Proof.
    unfold rep, Dent.rep, Dent.items_valid.
    exists nil; firstorder.
    exists nil; simpl.
    setoid_rewrite Dent.Defs.ipack_nil.
    assert (emp (list2nmem (@nil valuset))) by firstorder.
    pred_apply; cancel.
    apply Forall_nil.
  Qed.

  Theorem rep_no_0_inum: forall f m, rep f m ->
    forall name isdir, m name = Some (0, isdir) -> False.
  Proof.
    unfold rep. intros. repeat deex.
    eauto using listpred_dmatch_no_0_inum.
  Qed.

  Theorem crash_eq : forall f f' m1 m2,
    BFILE.file_crash f f' ->
    rep f m1 ->
    rep f' m2 ->
    m1 = m2.
  Proof.
    intros.
    apply eq_sym.
    eapply rep_mem_eq; eauto.

    unfold rep in *.
    repeat deex.
    eexists; intuition eauto.
    assert (delist0 = delist).
    eapply Dent.file_crash_rep_eq; eauto.
    subst; eauto.
  Qed.

  Theorem crash_rep : forall f f' m,
    BFILE.file_crash f f' ->
    rep f m ->
    rep f' m.
  Proof.
    unfold rep; intros.
    repeat deex.
    eexists; intuition eauto.
    eapply Dent.file_crash_rep; eauto.
  Qed.

End DIR.


 Require Import Coqlib AList.
Require Import STS.
Require Import Behavior.
Require Import ModSem.
Require Import Skeleton.
Require Import PCM.
From Ordinal Require Export Ordinal Arithmetic Inaccessible.
Require Import Any.
Require Import IRed.

From ExtLib Require Import
     Core.RelDec
     Structures.Maps
     Data.Map.FMapAList.

Set Implicit Arguments.

(*** TODO: move to ITreelib, and replace raw definitions with this ***)
Definition trivial_Handler `{E -< F}: Handler E F := fun T X => trigger X.

Inductive ord: Type :=
| ord_pure (n: Ord.t)
| ord_top
.

Definition is_pure (o: ord): bool := match o with | ord_pure _ => true | _ => false end.

Definition ord_lt (next cur: ord): Prop :=
  match next, cur with
  | ord_pure next, ord_pure cur => (next < cur)%ord
  | _, ord_top => True
  | _, _ => False
  end
.

(**
(defface hi-light-green-b
  '((((min-colors 88)) (:weight bold :foreground "dark magenta"))
    (t (:weight bold :foreground "dark magenta")))
  "Face for hi-lock mode."
  :group 'hi-lock-faces)

 **)

Section PSEUDOTYPING.

(*** execute following commands in emacs (by C-x C-e)
     (progn (highlight-phrase "Any" 'hi-red-b) (highlight-phrase "Any_src" 'hi-green-b) (highlight-phrase "Any_tgt" 'hi-blue-b)
            (highlight-phrase "Any_mid" 'hi-light-green-b)
            (highlight-phrase "Y" 'hi-green-b) (highlight-phrase "Z" 'hi-green-b)) ***)
Let Any_src := Any.t. (*** src argument (e.g., List nat) ***)
Let Any_mid := Any.t. (*** src argument (e.g., List nat) ***)
Let Any_tgt := Any.t. (*** tgt argument (i.e., list val) ***)

Require Import IPM.

Section FSPEC.
  Context `{Σ: GRA.t}.

  (*** spec table ***)
  Record fspec: Type := mk_fspec {
    meta: Type;
    measure: meta -> ord;
    precond: option mname -> meta -> Any.t -> Any_tgt -> iProp; (*** meta-variable -> new logical arg -> current logical arg -> resource arg -> Prop ***)
    postcond: option mname -> meta -> Any.t -> Any_tgt -> iProp; (*** meta-variable -> new logical ret -> current logical ret -> resource ret -> Prop ***)
  }
  .

  Definition mk (X AA AR: Type) (measure: X -> ord) (precond: X -> AA -> Any_tgt -> iProp) (postcond: X -> AR -> Any_tgt -> iProp) :=
    @mk_fspec
      X
      measure
      (fun _ x arg_src arg_tgt => (∃ (aa: AA), ⌜arg_src = aa↑⌝ ∧ precond x aa arg_tgt)%I)
      (fun _ x ret_src ret_tgt => (∃ (ar: AR), ⌜ret_src = ar↑⌝ ∧ postcond x ar ret_tgt)%I)
  .

  Definition fspec_trivial: fspec :=
    mk_fspec (meta:=unit) (fun _ => ord_top) (fun _ _ argh argl => (⌜argh = argl⌝: iProp)%I)
             (fun _ _ reth retl => (⌜reth = retl⌝: iProp)%I)
  .
End FSPEC.

Section PROOF.
  (* Context {myRA} `{@GRA.inG myRA Σ}. *)
  Context {Σ: GRA.t}.
  Let GURA: URA.t := GRA.to_URA Σ.
  Local Existing Instance GURA.

  Definition mput E `{pE -< E} `{eventE -< E} (mr: Σ): itree E unit :=
    st <- trigger PGet;; '(mp, _) <- ((Any.split st)?);;
    trigger (PPut (Any.pair mp mr↑))
  .

  Definition mget E `{pE -< E} `{eventE -< E}: itree E Σ :=
    st <- trigger PGet;; '(_, mr) <- ((Any.split st)?);;
    mr↓?
  .

  Definition pput E `{pE -< E} `{eventE -< E} (mp: Any.t): itree E unit :=
    st <- trigger PGet;; '(_, mr) <- ((Any.split st)?);;
    trigger (PPut (Any.pair mp mr))
  .

  Definition pget E `{pE -< E} `{eventE -< E}: itree E Any.t :=
    st <- trigger PGet;; '(mp, _) <- ((Any.split st)?);;
    Ret mp
  .

  Definition ASSUME (Cond: Any.t -> Any.t -> iProp) (valp: Any.t): stateT Σ (itree Es) Any.t :=
    fun fr =>
      '(cres, ctx) <- trigger (Take (Σ * Σ));;
      mr <- mget;;
      assume(URA.wf (cres ⋅ fr ⋅ ctx ⋅ mr));;;
      valv <- trigger (Take Any.t);;
      assume(Cond valv valp cres);;;
      Ret (ctx, valv)
  .

  Definition ASSERT (Cond: Any.t -> Any.t -> iProp) (valv: Any.t): stateT Σ (itree Es) Any.t :=
    fun ctx =>
      '(cres, fr, mr) <- trigger (Choose (Σ * Σ * Σ));;
      mput mr;;;
      guarantee(URA.wf (cres ⋅ fr ⋅ ctx ⋅ mr));;;
      valp <- trigger (Choose Any.t);;
      guarantee(Cond valv valp cres);;;
      Ret (fr, valp)
  .

  Definition HoareCall
             (mn: mname)
             (tbr: bool)
             (ord_cur: ord)
             (fsp: fspec):
    gname -> Any.t -> stateT (Σ) (itree Es) Any.t :=
    fun fn varg_src ctx =>

      x <- trigger (Choose fsp.(meta));;
      '(fr, varg_tgt) <- (ASSERT (fsp.(precond) (Some mn) x) varg_src ctx);;

      let ord_next := fsp.(measure) x in
      guarantee(ord_lt ord_next ord_cur /\ (tbr = true -> is_pure ord_next) /\ (tbr = false -> ord_next = ord_top));;;

      vret_tgt <- trigger (Call fn varg_tgt);;

      ASSUME (fsp.(postcond) (Some mn) x) vret_tgt fr
  .

End PROOF.

(*** TODO: Move to Coqlib. TODO: Somehow use case_ ??? ***)
(* Definition map_fst A0 A1 B (f: A0 -> A1): (A0 * B) -> (A1 * B) := fun '(a, b) => (f a, b). *)
(* Definition map_snd A B0 B1 (f: B0 -> B1): (A * B0) -> (A * B1) := fun '(a, b) => (a, f b). *)

Variant hCallE: Type -> Type :=
| hCall (tbr: bool) (fn: gname) (varg_src: Any_src): hCallE Any_src
(*** tbr == to be removed ***)
.

Variant hAPCE: Type -> Type :=
| hAPC: hAPCE unit
.

Notation Es' := (hCallE +' pE +' eventE).

Definition hEs := (hAPCE +' Es).

Definition hcall {X Y} (fn: gname) (varg: X): itree (hCallE +' pE +' eventE) Y :=
  vret <- trigger (hCall false fn varg↑);; vret <- vret↓ǃ;; Ret vret.

Program Fixpoint _APC (at_most: Ord.t) {wf Ord.lt at_most}: itree Es' unit :=
  break <- trigger (Choose _);;
  if break: bool
  then Ret tt
  else
    n <- trigger (Choose Ord.t);;
    trigger (Choose (n < at_most)%ord);;;
    '(fn, varg) <- trigger (Choose _);;
    trigger (hCall true fn varg);;;
    _APC n.
Next Obligation.
  i. auto.
Qed.
Next Obligation.
  eapply Ord.lt_well_founded.
Qed.

Definition APC: itree Es' unit :=
  at_most <- trigger (Choose _);;
  _APC at_most
.

Lemma unfold_APC:
  forall at_most, _APC at_most =
                  break <- trigger (Choose _);;
                  if break: bool
                  then Ret tt
                  else
                    n <- trigger (Choose Ord.t);;
                    guarantee (n < at_most)%ord;;;
                    '(fn, varg) <- trigger (Choose _);;
                    trigger (hCall true fn varg);;;
                    _APC n.
Proof.
  i. unfold _APC. rewrite Fix_eq; eauto.
  { repeat f_equal. extensionality break. destruct break; ss.
    repeat f_equal. extensionality n.
    unfold guarantee. rewrite bind_bind.
    repeat f_equal. extensionality p.
    rewrite bind_ret_l. repeat f_equal. extensionality x. destruct x. auto. }
  { i. replace g with f; auto. extensionality o. eapply H. }
Qed.
Global Opaque _APC.

Section CANCEL.

  Context `{Σ: GRA.t}.

  Record fspecbody: Type := mk_specbody {
    fsb_fspec:> fspec;
    fsb_body: (option mname * Any.t) -> itree (hAPCE +' Es) Any.t;
  }
  .

  (*** argument remains the same ***)
  (* Definition mk_simple (mn: string) {X: Type} (P: X -> Any_tgt -> Σ -> ord -> Prop) (Q: X -> Any_tgt -> Σ -> Prop): fspec. *)
  (*   econs. *)
  (*   { apply mn. } *)
  (*   { i. apply (P X0 X2 X3 H /\ X1↑ = X2). } *)
  (*   { i. apply (Q X0 X2 X3 /\ X1↑ = X2). } *)
  (* Unshelve. *)
  (*   apply (list val). *)
  (*   apply (val). *)
  (* Defined. *)
  Definition mk_simple {X: Type} (DPQ: X -> ord * (Any_tgt -> iProp) * (Any_tgt -> iProp)): fspec :=
    mk_fspec (fst ∘ fst ∘ DPQ)
             (fun _ x y a => (((snd ∘ fst ∘ DPQ) x a: iProp) ∧ ⌜y = a⌝)%I)
             (fun _ x z a => (((snd ∘ DPQ) x a: iProp) ∧ ⌜z = a⌝)%I)
  .

  Section INTERP.
  (* Variable stb: gname -> option fspec. *)
  (*** TODO: I wanted to use above definiton, but doing so makes defining ms_src hard ***)
  (*** We can fix this by making ModSemL.fnsems to a function, but doing so will change the type of
       ModSemL.add to predicate (t -> t -> t -> Prop), not function.
       - Maybe not. I thought one needed to check uniqueness of gname at the "add",
         but that might not be the case.
         We may define fnsems: string -> option (list val -> itree Es val).
         When adding two ms, it is pointwise addition, and addition of (option A) will yield None when both are Some.
 ***)
  (*** TODO: try above idea; if it fails, document it; and refactor below with alist ***)

  Variable mn: mname.
  Variable stb: gname -> option fspec.

  Definition handle_hAPCE_src: hAPCE ~> itree Es :=
    fun _ '(hAPC) => Ret tt.

  Definition interp_hEs_src: itree hEs ~> itree Es :=
    interp (case_ handle_hAPCE_src trivial_Handler)
  .

  Definition body_to_src {X} (body: X -> itree hEs Any.t): X -> itree Es Any.t :=
    (@interp_hEs_src _) ∘ body
  .

  Definition fun_to_src (body: (option mname * Any.t) -> itree hEs Any.t): ((option mname * Any.t) -> itree Es Any_src) :=
    (body_to_src body)
  .

  Definition handle_hAPCE_tgt: hAPCE ~> itree Es' :=
    fun _ '(hAPC) => APC.

  Definition handle_callE_hEs: callE ~> itree Es' :=
    fun _ '(Call fn arg) => trigger (hCall false fn arg).

  Definition interp_hEs_tgt: itree (hAPCE +' Es) ~> itree Es' :=
    interp (case_ (bif:=sum1) (handle_hAPCE_tgt)
                  (case_ (bif:=sum1) (handle_callE_hEs)
                         trivial_Handler)).

  Definition handle_hCallE_mid2: hCallE ~> itree Es :=
    fun _ '(hCall tbr fn varg_src) =>
      match tbr with
      | true => tau;; trigger (Choose _)
      | false => trigger (Call fn varg_src)
      end
  .

  Definition interp_hCallE_mid2: itree Es' ~> itree Es :=
    interp (case_ (bif:=sum1) (handle_hCallE_mid2)
                  trivial_Handler)
  .

  Definition body_to_mid2 {X} (body: X -> itree (hCallE +' pE +' eventE) Any.t): X -> itree Es Any.t :=
    (@interp_hCallE_mid2 _) ∘ body
  .

  Definition fun_to_mid2 (body: (option mname * Any.t) -> itree hEs Any.t): (option mname * Any_src -> itree Es Any_src) :=
    body_to_mid2 ((@interp_hEs_tgt _) ∘ body)
  .

  Definition handle_hCallE_mid (ord_cur: ord): hCallE ~> itree Es :=
    fun _ '(hCall tbr fn varg_src) =>
      tau;;
      f <- (stb fn)ǃ;; guarantee (tbr = true -> ~ (forall x, f.(measure) x = ord_top));;;
      ord_next <- (if tbr then o0 <- trigger (Choose _);; Ret (ord_pure o0) else Ret ord_top);;
      guarantee(ord_lt ord_next ord_cur);;;
      let varg_mid: Any_mid := Any.pair ord_next↑ varg_src in
      trigger (Call fn varg_mid)
  .

  Definition interp_hCallE_mid (ord_cur: ord): itree Es' ~> itree Es :=
    interp (case_ (bif:=sum1) (handle_hCallE_mid ord_cur)
                  ((fun T X => trigger X): _ ~> itree Es))
  .

  Definition body_to_mid (ord_cur: ord) {X} (body: X -> itree (hCallE +' pE +' eventE) Any.t): X -> itree Es Any.t :=
    fun varg_mid => interp_hCallE_mid ord_cur (body varg_mid)
  .

  Definition fun_to_mid (body: (option mname * Any.t) -> itree hEs Any.t): (option mname * Any_mid -> itree Es Any_src) :=
    fun '(mn, ord_varg_src) =>
      '(ord_cur, varg_src) <- (Any.split ord_varg_src)ǃ;; ord_cur <- ord_cur↓ǃ;;
      interp_hCallE_mid ord_cur (interp_hEs_tgt
                                   (match ord_cur with
                                    | ord_pure n => _ <- trigger hAPC;; trigger (Choose _)
                                    | _ => body (mn, varg_src)
                                    end)).

  Definition handle_hCallE_tgt (ord_cur: ord): hCallE ~> stateT (Σ) (itree Es) :=
    fun _ '(hCall tbr fn varg_src) 'ctx =>
      f <- (stb fn)ǃ;;
      HoareCall mn tbr ord_cur f fn varg_src ctx
  .

  Definition handle_pE_tgt: pE ~> itree Es :=
    Eval unfold pput, pget in
      (fun _ e =>
         match e with
         | PPut st => pput st
         | PGet => pget
         end).

  Definition interp_hCallE_tgt (ord_cur: ord): itree Es' ~> stateT Σ (itree Es) :=
    interp_state (case_ (bif:=sum1) (handle_hCallE_tgt ord_cur)
                        (case_ (bif:=sum1)
                               ((fun T X s => x <- handle_pE_tgt X;; Ret (s, x)): _ ~> stateT Σ (itree Es))
                               ((fun T X s => x <- trigger X;; Ret (s, x)): _ ~> stateT Σ (itree Es))))
  .

  Definition body_to_tgt (ord_cur: ord)
             {X} (body: X -> itree (hCallE +' pE +' eventE) Any_src): X -> stateT Σ (itree Es) Any_src :=
    (@interp_hCallE_tgt ord_cur _) ∘ body.

  Definition HoareFun
             {X: Type}
             (D: X -> ord)
             (P: option mname -> X -> Any.t -> Any_tgt -> iProp)
             (Q: option mname -> X -> Any.t -> Any_tgt -> iProp)
             (body: (option mname * Any.t) -> itree hEs Any.t): option mname * Any_tgt -> itree Es Any_tgt := fun '(mn_caller, varg_tgt) =>
    x <- trigger (Take X);;
    '(ctx, varg_src) <- (ASSUME (P mn_caller x) varg_tgt ε);;

    let ord_cur := D x in
    '(ctx, vret_src) <- interp_hCallE_tgt
                          ord_cur
                          (interp_hEs_tgt
                             (match ord_cur with
                              | ord_pure n => _ <- trigger hAPC;; trigger (Choose _)
                              | _ => body (mn_caller, varg_src)
                              end)) ctx;;

    '(_, vret_tgt) <- (ASSERT (Q mn_caller x) vret_src ctx);;
    Ret vret_tgt
  .

  Definition fun_to_tgt (sb: fspecbody): (option mname * Any_tgt -> itree Es Any_tgt) :=
    let fs: fspec := sb.(fsb_fspec) in
    (HoareFun (fs.(measure)) (fs.(precond)) (fs.(postcond)) (sb.(fsb_body)))
  .

(*** NOTE:
body can execute eventE events.
Notably, this implies it can also execute UB.
With this flexibility, the client code can naturally be included in our "type-checking" framework.
Also, note that body cannot execute "rE" on its own. This is intended.

NOTE: we can allow normal "callE" in the body too, but we need to ensure that it does not call "HoareFun".
If this feature is needed; we can extend it then. At the moment, I will only allow hCallE.
***)

  Definition HoareFunArg
             {X: Type}
             (P: option mname -> X -> Any.t -> Any_tgt -> iProp):
    option mname * Any_tgt -> itree Es ((Σ) * (option mname * X * Any.t)) := fun '(mn_caller, varg_tgt) =>
    x <- trigger (Take X);;
    '(ctx, varg_src) <- (ASSUME (P mn_caller x) varg_tgt ε);;
    Ret (ctx, (mn_caller, x, varg_src))
  .

  Definition HoareFunRet
             {X: Type}
             (Q: option mname -> X -> Any.t -> Any_tgt -> iProp):
    option mname -> X -> ((Σ) * Any.t) -> itree Es Any_tgt := fun mn x '(ctx, vret_src) =>
    '(_, vret_tgt) <- (ASSERT (Q mn x) vret_src ctx);;
    Ret vret_tgt
  .

  Lemma HoareFun_parse
        {X: Type}
        (D: X -> ord)
        (P: option mname -> X -> Any.t -> Any_tgt -> iProp)
        (Q: option mname -> X -> Any.t -> Any_tgt -> iProp)
        (body: (option mname * Any.t) -> itree hEs Any.t)
        (varg_tgt: option mname * Any_tgt)
    :
      HoareFun D P Q body varg_tgt =
      '(ctx, (mn_caller, x, varg_src)) <- HoareFunArg P varg_tgt;;
      interp_hCallE_tgt (D x)
                        (interp_hEs_tgt
                           (match D x with
                            | ord_pure n => _ <- trigger hAPC;; trigger (Choose _)
                            | _ => body (mn_caller, varg_src)
                            end)) ctx >>= (HoareFunRet Q mn_caller x).
  Proof.
    unfold HoareFun, HoareFunArg, HoareFunRet. grind.
  Qed.

  End INTERP.

  Variable md_tgt: ModL.t.
  Let ms_tgt: ModSemL.t := (ModL.get_modsem md_tgt md_tgt.(ModL.sk)).

  Variable sbtb: alist gname fspecbody.
  Let stb: alist gname fspec := List.map (fun '(gn, fsb) => (gn, fsb_fspec fsb)) sbtb.

End CANCEL.

End PSEUDOTYPING.

Module SModSem.
Section SMODSEM.

  Context `{Σ: GRA.t}.

  Record t: Type := mk {
    fnsems: list (gname * fspecbody);
    mn: mname;
    initial_mr: Σ;
    initial_st: Any.t;
  }
  .

  Definition transl (tr: mname -> fspecbody -> (option mname * Any.t -> itree Es Any.t)) (mst: t -> Any.t) (ms: t): ModSem.t := {|
    ModSem.fnsems := List.map (fun '(fn, sb) => (fn, tr ms.(mn) sb)) ms.(fnsems);
    ModSem.mn := ms.(mn);
    ModSem.initial_st := mst ms;
  |}
  .

  Definition to_src (ms: t): ModSem.t := transl (fun mn => fun_to_src ∘ fsb_body) initial_st ms.
  Definition to_mid (stb: gname -> option fspec) (ms: t): ModSem.t := transl (fun mn => fun_to_mid stb ∘ fsb_body) initial_st ms.
  Definition to_mid2 (stb: gname -> option fspec) (ms: t): ModSem.t := transl (fun mn => fun_to_mid2 ∘ fsb_body) initial_st ms.
  Definition to_tgt (stb: gname -> option fspec) (ms: t): ModSem.t := transl (fun mn => fun_to_tgt mn stb) (fun ms => Any.pair ms.(initial_st) ms.(initial_mr)↑) ms.

  Definition main (mainpre: Any.t -> iProp) (mainbody: (option mname * Any.t) -> itree hEs Any.t): t := {|
      fnsems := [("main", (mk_specbody (mk_simple (fun (_: unit) => (ord_top, mainpre, fun _ => (⌜True⌝: iProp)%I))) mainbody))];
      mn := "Main";
      initial_mr := ε;
      initial_st := tt↑;
    |}
  .

End SMODSEM.
End SModSem.

Module SMod.
Section SMOD.

  Context `{Σ: GRA.t}.

  Record t: Type := mk {
    get_modsem: Sk.t -> SModSem.t;
    sk: Sk.t;
  }
  .

  Definition transl (tr: Sk.t -> mname -> fspecbody -> (option mname * Any.t -> itree Es Any.t)) (mst: SModSem.t -> Any.t) (md: t): Mod.t := {|
    Mod.get_modsem := fun sk => SModSem.transl (tr sk) mst (md.(get_modsem) sk);
    Mod.sk := md.(sk);
  |}
  .

  Definition to_src (md: t): Mod.t := transl (fun _ _ => fun_to_src ∘ fsb_body) SModSem.initial_st md.
  Definition to_mid (stb: gname -> option fspec) (md: t): Mod.t := transl (fun _ _ => fun_to_mid stb ∘ fsb_body) SModSem.initial_st md.
  Definition to_mid2 (stb: gname -> option fspec) (md: t): Mod.t := transl (fun _ _ => fun_to_mid2 ∘ fsb_body) SModSem.initial_st md.
  Definition to_tgt (stb: Sk.t -> gname -> option fspec) (md: t): Mod.t :=
    transl (fun sk mn => fun_to_tgt mn (stb sk)) (fun ms => Any.pair ms.(SModSem.initial_st) ms.(SModSem.initial_mr)↑) md.

  Definition get_stb (mds: list t): Sk.t -> alist gname fspec :=
    fun sk => map (map_snd fsb_fspec) (flat_map (SModSem.fnsems ∘ (flip get_modsem sk)) mds).

  Definition get_sk (mds: list t): Sk.t :=
    Sk.sort (fold_right Sk.add Sk.unit (List.map sk mds)).

  Definition get_initial_mrs (mds: list t): Sk.t -> Σ :=
    fun sk => fold_left (⋅) (List.map (SModSem.initial_mr ∘ (flip get_modsem sk)) mds) ε.

  (* Definition transl (tr: SModSem.t -> ModSem.t) (md: t): Mod.t := {| *)
  (*   Mod.get_modsem := (SModSem.transl tr) ∘ md.(get_modsem); *)
  (*   Mod.sk := md.(sk); *)
  (* |} *)
  (* . *)

  (* Definition to_src (md: t): Mod.t := transl SModSem.to_src md. *)
  (* Definition to_mid (md: t): Mod.t := transl SModSem.to_mid md. *)
  (* Definition to_tgt (stb: list (gname * fspec)) (md: t): Mod.t := transl (SModSem.to_tgt stb) md. *)
  Lemma to_src_comm: forall sk smd,
      (SModSem.to_src) (get_modsem smd sk) = (to_src smd).(Mod.get_modsem) sk.
  Proof. refl. Qed.
  Lemma to_mid_comm: forall sk stb smd,
      (SModSem.to_mid stb) (get_modsem smd sk) = (to_mid stb smd).(Mod.get_modsem) sk.
  Proof. refl. Qed.
  Lemma to_tgt_comm: forall sk stb smd,
      (SModSem.to_tgt (stb sk)) (get_modsem smd sk) = (to_tgt stb smd).(Mod.get_modsem) sk.
  Proof. refl. Qed.

  (* Definition l_bind A B (x: list A) (f: A -> list B): list B := List.flat_map f x. *)
  (* Definition l_ret A (a: A): list A := [a]. *)

  Declare Scope l_monad_scope.
  Local Open Scope l_monad_scope.
  Notation "'do' X <- A ; B" := (List.flat_map (fun X => B) A) : l_monad_scope.
  Notation "'do' ' X <- A ; B" := (List.flat_map (fun _x => match _x with | X => B end) A) : l_monad_scope.
  Notation "'ret'" := (fun X => [X]) (at level 60) : l_monad_scope.

  Lemma unconcat
        A (xs: list A)
    :
      List.concat (List.map (fun x => [x]) xs) = xs
  .
  Proof.
    induction xs; ii; ss. f_equal; ss.
  Qed.

  Lemma red_do_ret A B (xs: list A) (f: A -> B)
    :
      (do x <- xs; ret (f x)) = List.map f xs
  .
  Proof.
    rewrite flat_map_concat_map.
    erewrite <- List.map_map with (f:=f) (g:=ret).
    rewrite unconcat. ss.
  Qed.

  Lemma red_do_ret2 A0 A1 B (xs: list (A0 * A1)) (f: A0 -> A1 -> B)
    :
      (do '(x0, x1) <- xs; ret (f x0 x1)) = List.map (fun '(x0, x1) => f x0 x1) xs
  .
  Proof.
    induction xs; ss. rewrite IHxs. destruct a; ss.
  Qed.

  Local Opaque Mod.add_list.

  Lemma transl_sk
        tr0 mr0 mds
    :
      <<SK: ModL.sk (Mod.add_list (List.map (transl tr0 mr0) mds)) = fold_right Sk.add Sk.unit (List.map sk mds)>>
  .
  Proof.
    induction mds; ii; ss.
    rewrite Mod.add_list_cons. ss. r. f_equal. ss.
  Qed.

  Lemma transl_sk_stable
        tr0 tr1 mr0 mr1 mds
    :
      ModL.sk (Mod.add_list (List.map (transl tr0 mr0) mds)) =
      ModL.sk (Mod.add_list (List.map (transl tr1 mr1) mds))
  .
  Proof. rewrite ! transl_sk. ss. Qed.

  Definition load_fnsems (sk: Sk.t) (mds: list t) (tr0: mname -> fspecbody -> option mname * Any.t -> itree Es Any.t) :=
    do md <- mds;
    let ms := (get_modsem md sk) in
      (do '(fn, fsb) <- ms.(SModSem.fnsems);
       let fsem := tr0 ms.(SModSem.mn) fsb in
       ret (fn, transl_all (T:=_) ms.(SModSem.mn) ∘ fsem))
  .

  Let transl_fnsems_aux
        tr0 mr0 mds
        (sk: Sk.t)
    :
      (ModSemL.fnsems (ModL.get_modsem (Mod.add_list (List.map (transl tr0 mr0) mds)) sk)) =
      (load_fnsems sk mds (tr0 sk))
  .
  Proof.
    induction mds; ii; ss.
    rewrite Mod.add_list_cons. cbn. f_equal; ss.
    rewrite ! List.map_map.

    rewrite flat_map_concat_map.
    replace (fun _x: string * fspecbody => let (fn, fsb) := _x in [(fn, transl_all (T:=_) (SModSem.mn (get_modsem a sk)) ∘ (tr0 sk (get_modsem a sk).(SModSem.mn) fsb))]) with
        (ret ∘ (fun _x: string * fspecbody => let (fn, fsb) := _x in (fn, transl_all (T:=_) (SModSem.mn (get_modsem a sk)) ∘ (tr0 sk (get_modsem a sk).(SModSem.mn) fsb))));
      cycle 1.
    { apply func_ext. i. des_ifs. }
    erewrite <- List.map_map with (g:=ret).
    rewrite unconcat.
    apply map_ext. ii. des_ifs.
  Qed.

  Lemma transl_fnsems
        tr0 mr0 mds
    :
      (ModSemL.fnsems (ModL.enclose (Mod.add_list (List.map (transl tr0 mr0) mds)))) =
      (load_fnsems (Sk.sort (List.fold_right Sk.add Sk.unit (List.map sk mds))) mds (tr0 (Sk.sort (List.fold_right Sk.add Sk.unit (List.map sk mds)))))
  .
  Proof.
    unfold ModL.enclose.
    rewrite transl_fnsems_aux. do 2 f_equal. rewrite transl_sk. ss.
    rewrite transl_sk. auto.
  Qed.

  Lemma flat_map_assoc
        A B C
        (f: A -> list B)
        (g: B -> list C)
        (xs: list A)
    :
      (do y <- (do x <- xs; f x); g y) =
      (do x <- xs; do y <- (f x); g y)
  .
  Proof.
    induction xs; ii; ss.
    rewrite ! flat_map_concat_map in *. rewrite ! map_app. rewrite ! concat_app. f_equal; ss.
  Qed.

  Lemma transl_fnsems_stable
        tr0 tr1 mr0 mr1 mds
    :
      List.map fst (ModL.enclose (Mod.add_list (List.map (transl tr0 mr0) mds))).(ModSemL.fnsems) =
      List.map fst (ModL.enclose (Mod.add_list (List.map (transl tr1 mr1) mds))).(ModSemL.fnsems)
  .
  Proof.
    rewrite ! transl_fnsems.
    unfold load_fnsems.
    rewrite <- ! red_do_ret.
    rewrite ! flat_map_assoc. eapply flat_map_ext. i.
    rewrite ! flat_map_assoc. eapply flat_map_ext. i.
    des_ifs.
  Qed.

  Definition load_initial_mrs {A} (sk: Sk.t) (mds: list t) (mr0: SModSem.t -> A): list (string * A) :=
    do md <- mds;
    let ms := (get_modsem md sk) in
    ret (ms.(SModSem.mn), mr0 ms)
  .

  Let transl_initial_mrs_aux
        tr0 mr0 mds
        (sk: Sk.t)
    :
      (ModSemL.initial_mrs (ModL.get_modsem (Mod.add_list (List.map (transl tr0 mr0) mds)) sk)) =
      (load_initial_mrs sk mds mr0)
  .
  Proof.
    induction mds; ii; ss.
    rewrite Mod.add_list_cons. cbn. f_equal; ss.
  Qed.

  Lemma transl_initial_mrs
        tr0 mr0 mds
    :
      (ModSemL.initial_mrs (ModL.enclose (Mod.add_list (List.map (transl tr0 mr0) mds)))) =
      (load_initial_mrs (Sk.sort (List.fold_right Sk.add Sk.unit (List.map sk mds))) mds mr0)
  .
  Proof.
    unfold ModL.enclose.
    rewrite transl_initial_mrs_aux. do 2 f_equal. rewrite transl_sk. ss.
  Qed.

  Lemma transl_stable_mn
        tr0 tr1 mr0 mr1 mds
    :
      List.map fst (ModL.enclose (Mod.add_list (List.map (transl tr0 mr0) mds))).(ModSemL.initial_mrs) =
      List.map fst (ModL.enclose (Mod.add_list (List.map (transl tr1 mr1) mds))).(ModSemL.initial_mrs)
  .
  Proof.
    rewrite ! transl_initial_mrs. unfold load_initial_mrs. rewrite <- ! red_do_ret.
    rewrite ! flat_map_assoc. eapply flat_map_ext. i. ss.
  Qed.

  Definition main (mainpre: Any.t -> iProp) (mainbody: (option mname * Any.t) -> itree hEs Any.t): t := {|
    get_modsem := fun _ => (SModSem.main mainpre mainbody);
    sk := Sk.unit;
  |}
  .

End SMOD.
End SMod.

  Hint Resolve Ord.lt_le_lt Ord.le_lt_lt OrdArith.lt_add_r OrdArith.le_add_l
       OrdArith.le_add_r Ord.lt_le
       Ord.lt_S
       Ord.S_lt
       Ord.S_supremum
       Ord.S_pos
    : ord.
  Hint Resolve Ord.le_trans Ord.lt_trans: ord_trans.
  Hint Resolve OrdArith.add_base_l OrdArith.add_base_r: ord_proj.

  Global Opaque EventsL.interp_Es.

  Require Import Red.

  Ltac interp_red := erewrite interp_vis ||
                              erewrite interp_ret ||
                              erewrite interp_tau ||
                              erewrite interp_trigger ||
                              erewrite interp_bind.

  (* TODO: remove it *)
  Ltac interp_red2 := rewrite interp_vis ||
                              rewrite interp_ret ||
                              rewrite interp_tau ||
                              rewrite interp_trigger ||
                              rewrite interp_bind.

  Ltac _red_itree f :=
    match goal with
    | [ |- ?itr >>= _ = _] =>
      match itr with
      | _ >>= _ =>
        instantiate (f:=_continue); apply bind_bind; fail
      | Tau _ =>
        instantiate (f:=_break); apply bind_tau; fail
      | Ret _ =>
        instantiate (f:=_continue); apply bind_ret_l; fail
      | _ =>
        fail
      end
    | _ => fail
    end.

Section AUX.

Context `{Σ: GRA.t}.
(* itree reduction *)
Lemma interp_tgt_bind
      (R S: Type)
      (s : itree (hCallE +' pE +' eventE) R) (k : R -> itree (hCallE +' pE +' eventE) S)
      mn stb o ctx
  :
    (interp_hCallE_tgt mn stb o (s >>= k)) ctx
    =
    st <- interp_hCallE_tgt mn stb o s ctx;; interp_hCallE_tgt mn stb o (k st.2) st.1.
Proof.
  unfold interp_hCallE_tgt in *. eapply interp_state_bind.
Qed.

Lemma interp_tgt_tau mn stb o ctx
      (U: Type)
      (t : itree _ U)
  :
    (interp_hCallE_tgt mn stb o (Tau t) ctx)
    =
    (Tau (interp_hCallE_tgt mn stb o t ctx)).
Proof.
  unfold interp_hCallE_tgt in *. eapply interp_state_tau.
Qed.

Lemma interp_tgt_ret mn stb o ctx
      (U: Type)
      (t: U)
  :
    (interp_hCallE_tgt mn stb o (Ret t) ctx)
    =
    Ret (ctx, t).
Proof.
  unfold interp_hCallE_tgt in *. eapply interp_state_ret.
Qed.

Lemma interp_tgt_triggerp mn stb o ctx
      (R: Type)
      (i: pE R)
  :
    (interp_hCallE_tgt mn stb o (trigger i) ctx)
    =
    (handle_pE_tgt i >>= (fun r => tau;; Ret (ctx, r))).
Proof.
  unfold interp_hCallE_tgt. rewrite interp_state_trigger. cbn. grind.
Qed.

Lemma interp_tgt_triggere mn stb o ctx
      (R: Type)
      (i: eventE R)
  :
    (interp_hCallE_tgt mn stb o (trigger i) ctx)
    =
    (trigger i >>= (fun r => tau;; Ret (ctx, r))).
Proof.
  unfold interp_hCallE_tgt. rewrite interp_state_trigger. cbn. grind.
Qed.

Lemma interp_tgt_hcall mn stb o ctx
      (R: Type)
      (i: hCallE R)
  :
    (interp_hCallE_tgt mn stb o (trigger i) ctx)
    =
    ((handle_hCallE_tgt mn stb o i ctx) >>= (fun r => tau;; Ret r)).
Proof.
  unfold interp_hCallE_tgt in *. rewrite interp_state_trigger. cbn. auto.
Qed.

Lemma interp_tgt_triggerUB mn stb o ctx
      (R: Type)
  :
    (interp_hCallE_tgt mn stb o (triggerUB) ctx)
    =
    triggerUB (A:=Σ*R).
Proof.
  unfold interp_hCallE_tgt, triggerUB in *. rewrite unfold_interp_state. cbn. grind.
Qed.

Lemma interp_tgt_triggerNB mn stb o ctx
      (R: Type)
  :
    (interp_hCallE_tgt mn stb o (triggerNB) ctx)
    =
    triggerNB (A:=Σ*R).
Proof.
  unfold interp_hCallE_tgt, triggerNB in *. rewrite unfold_interp_state. cbn. grind.
Qed.

Lemma interp_tgt_unwrapU mn stb o ctx
      (R: Type)
      (i: option R)
  :
    (interp_hCallE_tgt mn stb o (@unwrapU (hCallE +' pE +' eventE) _ _ i) ctx)
    =
    r <- (unwrapU i);; Ret (ctx, r).
Proof.
  unfold interp_hCallE_tgt, unwrapU in *. des_ifs.
  { etrans.
    { eapply interp_tgt_ret. }
    { grind. }
  }
  { etrans.
    { eapply interp_tgt_triggerUB. }
    { unfold triggerUB. grind. }
  }
Qed.

Lemma interp_tgt_unwrapN mn stb o ctx
      (R: Type)
      (i: option R)
  :
    (interp_hCallE_tgt mn stb o (@unwrapN (hCallE +' pE +' eventE) _ _ i) ctx)
    =
    r <- (unwrapN i);; Ret (ctx, r).
Proof.
  unfold interp_hCallE_tgt, unwrapN in *. des_ifs.
  { etrans.
    { eapply interp_tgt_ret. }
    { grind. }
  }
  { etrans.
    { eapply interp_tgt_triggerNB. }
    { unfold triggerNB. grind. }
  }
Qed.

Lemma interp_tgt_assume mn stb o ctx
      P
  :
    (interp_hCallE_tgt mn stb o (assume P) ctx)
    =
    (assume P;;; tau;; Ret (ctx, tt))
.
Proof.
  unfold assume. rewrite interp_tgt_bind. rewrite interp_tgt_triggere. grind. eapply interp_tgt_ret.
Qed.

Lemma interp_tgt_guarantee mn stb o ctx
      P
  :
    (interp_hCallE_tgt mn stb o (guarantee P) ctx)
    =
    (guarantee P;;; tau;; Ret (ctx, tt)).
Proof.
  unfold guarantee. rewrite interp_tgt_bind. rewrite interp_tgt_triggere. grind. eapply interp_tgt_ret.
Qed.

Lemma interp_tgt_ext mn stb o ctx
      R (itr0 itr1: itree _ R)
      (EQ: itr0 = itr1)
  :
    (interp_hCallE_tgt mn stb o itr0 ctx)
    =
    (interp_hCallE_tgt mn stb o itr1 ctx)
.
Proof. subst; et. Qed.

Global Program Instance interp_hCallE_tgt_rdb: red_database (mk_box (@interp_hCallE_tgt)) :=
  mk_rdb
    1
    (mk_box interp_tgt_bind)
    (mk_box interp_tgt_tau)
    (mk_box interp_tgt_ret)
    (mk_box interp_tgt_hcall)
    (mk_box interp_tgt_triggere)
    (mk_box interp_tgt_triggerp)
    (mk_box interp_tgt_triggerp)
    (mk_box interp_tgt_triggerUB)
    (mk_box interp_tgt_triggerNB)
    (mk_box interp_tgt_unwrapU)
    (mk_box interp_tgt_unwrapN)
    (mk_box interp_tgt_assume)
    (mk_box interp_tgt_guarantee)
    (mk_box interp_tgt_ext)
.

End AUX.

Section AUX.

Context `{Σ: GRA.t}.
Variable stb: gname -> option fspec.
(* itree reduction *)
Lemma interp_mid_bind
      (R S: Type)
      (s : itree (hCallE +' pE +' eventE) R) (k : R -> itree (hCallE +' pE +' eventE) S)
      o
  :
    (interp_hCallE_mid stb o (s >>= k))
    =
    ((interp_hCallE_mid stb o s) >>= (fun r => interp_hCallE_mid stb o (k r))).
Proof.
  unfold interp_hCallE_mid in *. grind.
Qed.

Lemma interp_mid_tau o
      (U: Type)
      (t : itree _ U)
  :
    (interp_hCallE_mid stb o (Tau t))
    =
    (Tau (interp_hCallE_mid stb o t)).
Proof.
  unfold interp_hCallE_mid in *. grind.
Qed.

Lemma interp_mid_ret o
      (U: Type)
      (t: U)
  :
    ((interp_hCallE_mid stb o (Ret t)))
    =
    Ret t.
Proof.
  unfold interp_hCallE_mid in *. grind.
Qed.

Lemma interp_mid_triggerp o
      (R: Type)
      (i: pE R)
  :
    (interp_hCallE_mid stb o (trigger i))
    =
    (trigger i >>= (fun r => tau;; Ret r)).
Proof.
  unfold interp_hCallE_mid in *.
  repeat rewrite interp_trigger. grind.
Qed.

Lemma interp_mid_triggere o
      (R: Type)
      (i: eventE R)
  :
    (interp_hCallE_mid stb o (trigger i))
    =
    (trigger i >>= (fun r => tau;; Ret r)).
Proof.
  unfold interp_hCallE_mid in *.
  repeat rewrite interp_trigger. grind.
Qed.

Lemma interp_mid_hcall o
      (R: Type)
      (i: hCallE R)
  :
    (interp_hCallE_mid stb o (trigger i))
    =
    ((handle_hCallE_mid stb o i) >>= (fun r => tau;; Ret r)).
Proof.
  unfold interp_hCallE_mid in *.
  repeat rewrite interp_trigger. grind.
Qed.

Lemma interp_mid_triggerUB o
      (R: Type)
  :
    (interp_hCallE_mid stb o (triggerUB))
    =
    triggerUB (A:=R).
Proof.
  unfold interp_hCallE_mid, triggerUB in *. rewrite unfold_interp. cbn. grind.
Qed.

Lemma interp_mid_triggerNB o
      (R: Type)
  :
    (interp_hCallE_mid stb o (triggerNB))
    =
    triggerNB (A:=R).
Proof.
  unfold interp_hCallE_mid, triggerNB in *. rewrite unfold_interp. cbn. grind.
Qed.

Lemma interp_mid_unwrapU o
      (R: Type)
      (i: option R)
  :
    (interp_hCallE_mid stb o (@unwrapU (hCallE +' pE +' eventE) _ _ i))
    =
    (unwrapU i).
Proof.
  unfold interp_hCallE_mid, unwrapU in *. des_ifs.
  { etrans.
    { eapply interp_mid_ret. }
    { grind. }
  }
  { etrans.
    { eapply interp_mid_triggerUB. }
    { unfold triggerUB. grind. }
  }
Qed.

Lemma interp_mid_unwrapN o
      (R: Type)
      (i: option R)
  :
    (interp_hCallE_mid stb o (@unwrapN (hCallE +' pE +' eventE) _ _ i))
    =
    (unwrapN i).
Proof.
  unfold interp_hCallE_mid, unwrapN in *. des_ifs.
  { etrans.
    { eapply interp_mid_ret. }
    { grind. }
  }
  { etrans.
    { eapply interp_mid_triggerNB. }
    { unfold triggerNB. grind. }
  }
Qed.

Lemma interp_mid_assume o
      P
  :
    (interp_hCallE_mid stb o (assume P))
    =
    (assume P;;; tau;; Ret tt)
.
Proof.
  unfold assume. rewrite interp_mid_bind. rewrite interp_mid_triggere. grind. eapply interp_mid_ret.
Qed.

Lemma interp_mid_guarantee o
      P
  :
    (interp_hCallE_mid stb o (guarantee P))
    =
    (guarantee P;;; tau;; Ret tt).
Proof.
  unfold guarantee. rewrite interp_mid_bind. rewrite interp_mid_triggere. grind. eapply interp_mid_ret.
Qed.

Lemma interp_mid_ext o
      R (itr0 itr1: itree _ R)
      (EQ: itr0 = itr1)
  :
    (interp_hCallE_mid stb o itr0)
    =
    (interp_hCallE_mid stb o itr1)
.
Proof. subst; et. Qed.

End AUX.

Global Program Instance interp_hCallE_mid_rdb `{Σ: GRA.t}: red_database (mk_box (@interp_hCallE_mid)) :=
  mk_rdb
    0
    (mk_box interp_mid_bind)
    (mk_box interp_mid_tau)
    (mk_box interp_mid_ret)
    (mk_box interp_mid_hcall)
    (mk_box interp_mid_triggere)
    (mk_box interp_mid_triggerp)
    (mk_box interp_mid_triggerp)
    (mk_box interp_mid_triggerUB)
    (mk_box interp_mid_triggerNB)
    (mk_box interp_mid_unwrapU)
    (mk_box interp_mid_unwrapN)
    (mk_box interp_mid_assume)
    (mk_box interp_mid_guarantee)
    (mk_box interp_mid_ext)
.

Section AUX.

Context `{Σ: GRA.t}.
Variable stb: gname -> option fspec.
(* itree reduction *)
Lemma interp_mid2_bind
      (R S: Type)
      (s : itree (hCallE +' pE +' eventE) R) (k : R -> itree (hCallE +' pE +' eventE) S)
  :
    (interp_hCallE_mid2 (s >>= k))
    =
    ((interp_hCallE_mid2 s) >>= (fun r => interp_hCallE_mid2 (k r))).
Proof.
  unfold interp_hCallE_mid2 in *. grind.
Qed.

Lemma interp_mid2_tau
      (U: Type)
      (t : itree _ U)
  :
    (interp_hCallE_mid2 (Tau t))
    =
    (Tau (interp_hCallE_mid2 t)).
Proof.
  unfold interp_hCallE_mid2 in *. grind.
Qed.

Lemma interp_mid2_ret
      (U: Type)
      (t: U)
  :
    ((interp_hCallE_mid2 (Ret t)))
    =
    Ret t.
Proof.
  unfold interp_hCallE_mid2 in *. grind.
Qed.

Lemma interp_mid2_triggerp
      (R: Type)
      (i: pE R)
  :
    (interp_hCallE_mid2 (trigger i))
    =
    (trigger i >>= (fun r => tau;; Ret r)).
Proof.
  unfold interp_hCallE_mid2 in *.
  repeat rewrite interp_trigger. grind.
Qed.

Lemma interp_mid2_triggere
      (R: Type)
      (i: eventE R)
  :
    (interp_hCallE_mid2 (trigger i))
    =
    (trigger i >>= (fun r => tau;; Ret r)).
Proof.
  unfold interp_hCallE_mid2 in *.
  repeat rewrite interp_trigger. grind.
Qed.

Lemma interp_mid2_hcall
      (R: Type)
      (i: hCallE R)
  :
    (interp_hCallE_mid2 (trigger i))
    =
    ((handle_hCallE_mid2 i) >>= (fun r => tau;; Ret r)).
Proof.
  unfold interp_hCallE_mid2 in *.
  repeat rewrite interp_trigger. grind.
Qed.

Lemma interp_mid2_triggerUB
      (R: Type)
  :
    (interp_hCallE_mid2 (triggerUB))
    =
    triggerUB (A:=R).
Proof.
  unfold interp_hCallE_mid2, triggerUB in *. rewrite unfold_interp. cbn. grind.
Qed.

Lemma interp_mid2_triggerNB
      (R: Type)
  :
    (interp_hCallE_mid2 (triggerNB))
    =
    triggerNB (A:=R).
Proof.
  unfold interp_hCallE_mid2, triggerNB in *. rewrite unfold_interp. cbn. grind.
Qed.

Lemma interp_mid2_unwrapU
      (R: Type)
      (i: option R)
  :
    (interp_hCallE_mid2 (@unwrapU (hCallE +' pE +' eventE) _ _ i))
    =
    (unwrapU i).
Proof.
  unfold interp_hCallE_mid2, unwrapU in *. des_ifs.
  { etrans.
    { eapply interp_mid2_ret. }
    { grind. }
  }
  { etrans.
    { eapply interp_mid2_triggerUB. }
    { unfold triggerUB. grind. }
  }
Qed.

Lemma interp_mid2_unwrapN
      (R: Type)
      (i: option R)
  :
    (interp_hCallE_mid2 (@unwrapN (hCallE +' pE +' eventE) _ _ i))
    =
    (unwrapN i).
Proof.
  unfold interp_hCallE_mid2, unwrapN in *. des_ifs.
  { etrans.
    { eapply interp_mid2_ret. }
    { grind. }
  }
  { etrans.
    { eapply interp_mid2_triggerNB. }
    { unfold triggerNB. grind. }
  }
Qed.

Lemma interp_mid2_assume
      P
  :
    (interp_hCallE_mid2 (assume P))
    =
    (assume P;;; tau;; Ret tt)
.
Proof.
  unfold assume. rewrite interp_mid2_bind. rewrite interp_mid2_triggere. grind. eapply interp_mid2_ret.
Qed.

Lemma interp_mid2_guarantee
      P
  :
    (interp_hCallE_mid2 (guarantee P))
    =
    (guarantee P;;; tau;; Ret tt).
Proof.
  unfold guarantee. rewrite interp_mid2_bind. rewrite interp_mid2_triggere. grind. eapply interp_mid2_ret.
Qed.

Lemma interp_mid2_ext
      R (itr0 itr1: itree _ R)
      (EQ: itr0 = itr1)
  :
    (interp_hCallE_mid2 itr0)
    =
    (interp_hCallE_mid2 itr1)
.
Proof. subst; et. Qed.

End AUX.

Global Program Instance interp_hCallE_mid2_rdb `{Σ: GRA.t}: red_database (mk_box (@interp_hCallE_mid2)) :=
  mk_rdb
    0
    (mk_box interp_mid2_bind)
    (mk_box interp_mid2_tau)
    (mk_box interp_mid2_ret)
    (mk_box interp_mid2_hcall)
    (mk_box interp_mid2_triggere)
    (mk_box interp_mid2_triggerp)
    (mk_box interp_mid2_triggerp)
    (mk_box interp_mid2_triggerUB)
    (mk_box interp_mid2_triggerNB)
    (mk_box interp_mid2_unwrapU)
    (mk_box interp_mid2_unwrapN)
    (mk_box interp_mid2_assume)
    (mk_box interp_mid2_guarantee)
    (mk_box interp_mid2_ext)
.

Section AUX.

Context `{Σ: GRA.t}.
(* itree reduction *)
Lemma interp_src_bind
      (R S: Type)
      (s : itree hEs R) (k : R -> itree hEs S)
  :
    (interp_hEs_src (s >>= k))
    =
    ((interp_hEs_src s) >>= (fun r => interp_hEs_src (k r))).
Proof.
  unfold interp_hEs_src in *. grind.
Qed.

Lemma interp_src_tau
      (U: Type)
      (t : itree _ U)
  :
    (interp_hEs_src (Tau t))
    =
    (Tau (interp_hEs_src t)).
Proof.
  unfold interp_hEs_src in *. grind.
Qed.

Lemma interp_src_ret
      (U: Type)
      (t: U)
  :
    ((interp_hEs_src (Ret t)))
    =
    Ret t.
Proof.
  unfold interp_hEs_src in *. grind.
Qed.

Lemma interp_src_triggerp
      (R: Type)
      (i: pE R)
  :
    (interp_hEs_src (trigger i))
    =
    (trigger i >>= (fun r => tau;; Ret r)).
Proof.
  unfold interp_hEs_src in *.
  repeat rewrite interp_trigger. grind.
Qed.

Lemma interp_src_triggere
      (R: Type)
      (i: eventE R)
  :
    (interp_hEs_src (trigger i))
    =
    (trigger i >>= (fun r => tau;; Ret r)).
Proof.
  unfold interp_hEs_src in *.
  repeat rewrite interp_trigger. grind.
Qed.

Lemma interp_src_call
      (R: Type)
      (i: callE R)
  :
    (interp_hEs_src (trigger i))
    =
    (trigger i >>= (fun r => tau;; Ret r)).
Proof.
  unfold interp_hEs_src in *.
  repeat rewrite interp_trigger. grind.
Qed.

Lemma interp_src_hapc
      (R: Type)
      (i: hAPCE R)
  :
    (interp_hEs_src (trigger i))
    =
    ((handle_hAPCE_src i) >>= (fun r => tau;; Ret r)).
Proof.
  unfold interp_hEs_src in *.
  repeat rewrite interp_trigger. grind.
Qed.

Lemma interp_src_triggerUB
      (R: Type)
  :
    (interp_hEs_src (triggerUB))
    =
    triggerUB (A:=R).
Proof.
  unfold interp_hEs_src, triggerUB in *. rewrite unfold_interp. cbn. grind.
Qed.

Lemma interp_src_triggerNB
      (R: Type)
  :
    (interp_hEs_src (triggerNB))
    =
    triggerNB (A:=R).
Proof.
  unfold interp_hEs_src, triggerNB in *. rewrite unfold_interp. cbn. grind.
Qed.

Lemma interp_src_unwrapU
      (R: Type)
      (i: option R)
  :
    (interp_hEs_src (@unwrapU hEs _ _ i))
    =
    (unwrapU i).
Proof.
  unfold interp_hEs_src, unwrapU in *. des_ifs.
  { etrans.
    { eapply interp_src_ret. }
    { grind. }
  }
  { etrans.
    { eapply interp_src_triggerUB. }
    { unfold triggerUB. grind. }
  }
Qed.

Lemma interp_src_unwrapN
      (R: Type)
      (i: option R)
  :
    (interp_hEs_src (@unwrapN hEs _ _ i))
    =
    (unwrapN i).
Proof.
  unfold interp_hEs_src, unwrapN in *. des_ifs.
  { etrans.
    { eapply interp_src_ret. }
    { grind. }
  }
  { etrans.
    { eapply interp_src_triggerNB. }
    { unfold triggerNB. grind. }
  }
Qed.

Lemma interp_src_assume
      P
  :
    (interp_hEs_src (assume P))
    =
    (assume P;;; tau;; Ret tt)
.
Proof.
  unfold assume. rewrite interp_src_bind. rewrite interp_src_triggere. grind. eapply interp_src_ret.
Qed.

Lemma interp_src_guarantee
      P
  :
    (interp_hEs_src (guarantee P))
    =
    (guarantee P;;; tau;; Ret tt).
Proof.
  unfold guarantee. rewrite interp_src_bind. rewrite interp_src_triggere. grind. eapply interp_src_ret.
Qed.

Lemma interp_src_ext
      R (itr0 itr1: itree _ R)
      (EQ: itr0 = itr1)
  :
    (interp_hEs_src itr0)
    =
    (interp_hEs_src itr1)
.
Proof. subst; et. Qed.

Global Program Instance interp_hEs_src_rdb: red_database (mk_box (@interp_hEs_src)) :=
  mk_rdb
    0
    (mk_box interp_src_bind)
    (mk_box interp_src_tau)
    (mk_box interp_src_ret)
    (mk_box interp_src_call)
    (mk_box interp_src_triggere)
    (mk_box interp_src_triggerp)
    (mk_box interp_src_hapc)
    (mk_box interp_src_triggerUB)
    (mk_box interp_src_triggerNB)
    (mk_box interp_src_unwrapU)
    (mk_box interp_src_unwrapN)
    (mk_box interp_src_assume)
    (mk_box interp_src_guarantee)
    (mk_box interp_src_ext)
.

End AUX.

Section AUX.

Context `{Σ: GRA.t}.
(* itree reduction *)
Lemma interp_hEs_tgt_bind
      (R S: Type)
      (s : itree hEs R) (k : R -> itree hEs S)
  :
    (interp_hEs_tgt (s >>= k))
    =
    ((interp_hEs_tgt s) >>= (fun r => interp_hEs_tgt (k r))).
Proof.
  unfold interp_hEs_tgt in *. grind.
Qed.

Lemma interp_hEs_tgt_tau
      (U: Type)
      (t : itree _ U)
  :
    (interp_hEs_tgt (Tau t))
    =
    (Tau (interp_hEs_tgt t)).
Proof.
  unfold interp_hEs_tgt in *. grind.
Qed.

Lemma interp_hEs_tgt_ret
      (U: Type)
      (t: U)
  :
    ((interp_hEs_tgt (Ret t)))
    =
    Ret t.
Proof.
  unfold interp_hEs_tgt in *. grind.
Qed.

Lemma interp_hEs_tgt_triggerp
      (R: Type)
      (i: pE R)
  :
    (interp_hEs_tgt (trigger i))
    =
    (trigger i >>= (fun r => tau;; Ret r)).
Proof.
  unfold interp_hEs_tgt in *.
  repeat rewrite interp_trigger. grind.
Qed.

Lemma interp_hEs_tgt_triggere
      (R: Type)
      (i: eventE R)
  :
    (interp_hEs_tgt (trigger i))
    =
    (trigger i >>= (fun r => tau;; Ret r)).
Proof.
  unfold interp_hEs_tgt in *.
  repeat rewrite interp_trigger. grind.
Qed.

Lemma interp_hEs_tgt_call
      (R: Type)
      (i: callE R)
  :
    (interp_hEs_tgt (trigger i))
    =
    (handle_callE_hEs i >>= (fun r => tau;; Ret r)).
Proof.
  unfold interp_hEs_tgt in *.
  repeat rewrite interp_trigger. grind.
Qed.

Lemma interp_hEs_tgt_hapc
      (R: Type)
      (i: hAPCE R)
  :
    (interp_hEs_tgt (trigger i))
    =
    ((handle_hAPCE_tgt i) >>= (fun r => tau;; Ret r)).
Proof.
  unfold interp_hEs_tgt in *.
  repeat rewrite interp_trigger. grind.
Qed.

Lemma interp_hEs_tgt_triggerUB
      (R: Type)
  :
    (interp_hEs_tgt (triggerUB))
    =
    triggerUB (A:=R).
Proof.
  unfold interp_hEs_tgt, triggerUB in *. rewrite unfold_interp. cbn. grind.
Qed.

Lemma interp_hEs_tgt_triggerNB
      (R: Type)
  :
    (interp_hEs_tgt (triggerNB))
    =
    triggerNB (A:=R).
Proof.
  unfold interp_hEs_tgt, triggerNB in *. rewrite unfold_interp. cbn. grind.
Qed.

Lemma interp_hEs_tgt_unwrapU
      (R: Type)
      (i: option R)
  :
    (interp_hEs_tgt (@unwrapU hEs _ _ i))
    =
    (unwrapU i).
Proof.
  unfold interp_hEs_tgt, unwrapU in *. des_ifs.
  { etrans.
    { eapply interp_hEs_tgt_ret. }
    { grind. }
  }
  { etrans.
    { eapply interp_hEs_tgt_triggerUB. }
    { unfold triggerUB. grind. }
  }
Qed.

Lemma interp_hEs_tgt_unwrapN
      (R: Type)
      (i: option R)
  :
    (interp_hEs_tgt (@unwrapN hEs _ _ i))
    =
    (unwrapN i).
Proof.
  unfold interp_hEs_tgt, unwrapN in *. des_ifs.
  { etrans.
    { eapply interp_hEs_tgt_ret. }
    { grind. }
  }
  { etrans.
    { eapply interp_hEs_tgt_triggerNB. }
    { unfold triggerNB. grind. }
  }
Qed.

Lemma interp_hEs_tgt_assume
      P
  :
    (interp_hEs_tgt (assume P))
    =
    (assume P;;; tau;; Ret tt)
.
Proof.
  unfold assume. rewrite interp_hEs_tgt_bind. rewrite interp_hEs_tgt_triggere. grind. eapply interp_hEs_tgt_ret.
Qed.

Lemma interp_hEs_tgt_guarantee
      P
  :
    (interp_hEs_tgt (guarantee P))
    =
    (guarantee P;;; tau;; Ret tt).
Proof.
  unfold guarantee. rewrite interp_hEs_tgt_bind. rewrite interp_hEs_tgt_triggere. grind. eapply interp_hEs_tgt_ret.
Qed.

Lemma interp_hEs_tgt_ext
      R (itr0 itr1: itree _ R)
      (EQ: itr0 = itr1)
  :
    (interp_hEs_tgt itr0)
    =
    (interp_hEs_tgt itr1)
.
Proof. subst; et. Qed.

Global Program Instance interp_hEs_tgt_rdb: red_database (mk_box (@interp_hEs_tgt)) :=
  mk_rdb
    0
    (mk_box interp_hEs_tgt_bind)
    (mk_box interp_hEs_tgt_tau)
    (mk_box interp_hEs_tgt_ret)
    (mk_box interp_hEs_tgt_call)
    (mk_box interp_hEs_tgt_triggere)
    (mk_box interp_hEs_tgt_triggerp)
    (mk_box interp_hEs_tgt_hapc)
    (mk_box interp_hEs_tgt_triggerUB)
    (mk_box interp_hEs_tgt_triggerNB)
    (mk_box interp_hEs_tgt_unwrapU)
    (mk_box interp_hEs_tgt_unwrapN)
    (mk_box interp_hEs_tgt_assume)
    (mk_box interp_hEs_tgt_guarantee)
    (mk_box interp_hEs_tgt_ext)
.

End AUX.

(*** TODO: move to ITreeLib ***)
Lemma bind_eta E X Y itr0 itr1 (ktr: ktree E X Y): itr0 = itr1 -> itr0 >>= ktr = itr1 >>= ktr. i; subst; refl. Qed.

Ltac ired_l := try (prw _red_gen 2 0).
Ltac ired_r := try (prw _red_gen 1 0).

Ltac ired_both := ired_l; ired_r.

  Ltac mred := repeat (cbn; ired_both).
  Ltac Esred :=
            try rewrite ! EventsL.interp_Es_pE;
            try rewrite ! EventsL.interp_Es_eventE; try rewrite ! EventsL.interp_Es_callE;
            try rewrite ! EventsL.interp_Es_triggerNB; try rewrite ! EventsL.interp_Es_triggerUB (*** igo ***).
  (*** step and some post-processing ***)
  Ltac _step :=
    match goal with
    (*** terminal cases ***)
    | [ |- gpaco6 _ _ _ _ _ _ _ _ (triggerUB >>= _) _ ] =>
      unfold triggerUB; mred; _step; ss; fail
    | [ |- gpaco6 _ _ _ _ _ _ _ _ _ (triggerNB >>= _) ] =>
      unfold triggerNB; mred; _step; ss; fail
    | [ |- gpaco6 _ _ _ _ _ _ _ _ (triggerNB >>= _) _ ] =>
      exfalso
    | [ |- gpaco6 _ _ _ _ _ _ _ _ _ (triggerUB >>= _) ] =>
      exfalso

    (*** assume/guarantee ***)
    | [ |- gpaco6 _ _ _ _ _ _ _ _ (assume ?P ;;; _) _ ] =>
      let tvar := fresh "tmp" in
      let thyp := fresh "TMP" in
      remember (assume P) as tvar eqn:thyp; unfold assume in thyp; subst tvar
    | [ |- gpaco6 _ _ _ _ _ _ _ _ (guarantee ?P ;;; _) _ ] =>
      let tvar := fresh "tmp" in
      let thyp := fresh "TMP" in
      remember (guarantee P) as tvar eqn:thyp; unfold guarantee in thyp; subst tvar
    | [ |- gpaco6 _ _ _ _ _ _ _ _ _ (assume ?P ;;; _) ] =>
      let tvar := fresh "tmp" in
      let thyp := fresh "TMP" in
      remember (assume P) as tvar eqn:thyp; unfold assume in thyp; subst tvar
    | [ |- gpaco6 _ _ _ _ _ _ _ _ _ (guarantee ?P ;;; _) ] =>
      let tvar := fresh "tmp" in
      let thyp := fresh "TMP" in
      remember (guarantee P) as tvar eqn:thyp; unfold guarantee in thyp; subst tvar

    (*** default cases ***)
    | _ =>
      (gstep; econs; eauto; try (by eapply OrdArith.lt_from_nat; ss);
       (*** some post-processing ***)
       i;
       try match goal with
           | [ |- (eq ==> _)%signature _ _ ] =>
             let v_src := fresh "v_src" in
             let v_tgt := fresh "v_tgt" in
             intros v_src v_tgt ?; subst v_tgt
           end)
    end
  .
  Ltac steps := repeat (mred; try _step; des_ifs_safe).
  Ltac seal_left :=
    match goal with
    | [ |- gpaco6 _ _ _ _ _ _ _ _ ?i_src ?i_tgt ] => seal i_src
    end.
  Ltac seal_right :=
    match goal with
    | [ |- gpaco6 _ _ _ _ _ _ _ _ ?i_src ?i_tgt ] => seal i_tgt
    end.
  Ltac unseal_left :=
    match goal with
    | [ |- gpaco6 _ _ _ _ _ _ _ _ (@Seal.sealing _ _ ?i_src) ?i_tgt ] => unseal i_src
    end.
  Ltac unseal_right :=
    match goal with
    | [ |- gpaco6 _ _ _ _ _ _ _ _ ?i_src (@Seal.sealing _ _ ?i_tgt) ] => unseal i_tgt
    end.
  Ltac force_l := seal_right; _step; unseal_right.
  Ltac force_r := seal_left; _step; unseal_left.
  (* Ltac mstep := gstep; econs; eauto; [eapply from_nat_lt; ss|]. *)

  From ExtLib Require Import
       Data.Map.FMapAList.

  Hint Resolve cpn3_wcompat: paco.
  Ltac init :=
    split; ss; ii; clarify; rename y into varg; eexists 100%nat; ss; des; clarify;
    ginit; []; unfold alist_add, alist_remove; ss;
    unfold fun_to_tgt, cfunN; ss.

Notation Es' := (hCallE +' pE +' eventE).

Module IPCNotations.
  Notation ";;; t2" :=
    (ITree.bind (trigger hAPC) (fun _ => t2))
      (at level 63, t2 at next level, right associativity) : itree_scope.
  Notation "` x : t <- t1 ;;; t2" :=
    (ITree.bind t1 (fun x : t => ;;; t2))
      (at level 62, t at next level, t1 at next level, x ident, right associativity) : itree_scope.
  Notation "x <- t1 ;;; t2" :=
    (ITree.bind t1 (fun x => ;;; t2))
      (at level 62, t1 at next level, right associativity) : itree_scope.
  Notation "' p <- t1 ;;; t2" :=
    (ITree.bind t1 (fun x_ => match x_ with p => ;;; t2 end))
      (at level 62, t1 at next level, p pattern, right associativity) : itree_scope.
End IPCNotations.

Export IPCNotations.