From RecordUpdate Require Import RecordSet.
Import RecordSetNotations.

From Perennial.algebra Require Import log_heap liftable.
From Perennial.base_logic Require Import lib.mono_nat.
From Perennial.Helpers Require Import Transitions.
From Perennial.program_proof Require Import disk_prelude.

From Goose.github_com.mit_pdos.go_journal Require Import addr jrnl.
From Perennial.program_proof Require Import wal.specs wal.heapspec obj.obj_proof buf.bufmap_proof addr.addr_proof.

From Perennial.program_logic Require Import invariants_mutable.
From Perennial.program_proof Require wp_to_wpc.

Definition mkVersioned {K:bufDataKind} (c m: bufDataT K) : versioned_object :=
  existT K (c, m).

#[global]
Instance object_eq_dec : EqDecision object.
Proof.
  intros o1 o2.
  destruct o1 as [K1 x1], o2 as [K2 x2].
  destruct (decide (K1 = K2)).
  - destruct e.
    destruct (decide (x1 = x2)); subst.
    + left; auto.
    + right.
      intro H.
      apply Eqdep_dec.inj_pair2_eq_dec in H; auto.
      intros. apply bufDataKind_eq_dec.
  - right; intros H%eq_sigT_fst; auto.
Qed.

#[global]
Instance versioned_object_eq_dec : EqDecision versioned_object.
Proof.
  intros o1 o2.
  destruct o1 as [K1 cm1], o2 as [K2 cm2].
  destruct (decide (K1 = K2)); subst.
  - destruct (decide (cm1 = cm2)); subst.
    + left; auto.
    + right.
      intro H.
      apply Eqdep_dec.inj_pair2_eq_dec in H; auto.
      intros. apply bufDataKind_eq_dec.
  - right; intros H%eq_sigT_fst; auto.
Qed.

Definition committed (v : versioned_object) : object :=
  existT _ (fst (projT2 v)).

Definition modified (v : versioned_object) : object :=
  existT _ (snd (projT2 v)).

Lemma committed_mkVersioned {K} c m : committed (@mkVersioned K c m) = existT K c.
Proof. reflexivity. Qed.

Lemma modified_mkVersioned {K} c m : modified (@mkVersioned K c m) = existT K m.
Proof. reflexivity. Qed.

Class jrnlG Σ :=
  { jrnl_txn   :> txnG Σ;
  }.

Definition jrnlΣ : gFunctors :=
  #[ txnΣ ].

#[global]
Instance subG_jrnlΣ Σ : subG jrnlΣ Σ → jrnlG Σ.
Proof. solve_inG. Qed.

Section heap.
Context `{!jrnlG Σ}.
Context `{!heapGS Σ}.

Implicit Types s : Slice.t.
Implicit Types (stk:stuckness) (E: coPset).
Implicit Types (mT : gmap addr versioned_object).

Definition is_jrnl (buftx : loc)
                     mT
                     γUnified
                     dinit anydirty : iProp Σ :=
  (
    ∃ (l : loc) (bufmap : loc) (gBufmap : gmap addr buf),
      "Hbuftx.l" ∷ buftx ↦[jrnl.Op :: "log"] #l ∗
      "Hbuftx.map" ∷ buftx ↦[jrnl.Op :: "bufs"] #bufmap ∗
      "#Histxn" ∷ is_txn l γUnified dinit ∗
      "Hbufmap" ∷ is_bufmap bufmap gBufmap ∗
      "%Hbufmapelem" ∷ ⌜ (λ b, existT _ (bufData b)) <$> gBufmap ⊆ modified <$> mT ⌝ ∗
      "#Hctxvalid" ∷ ( [∗ map] a ↦ v ∈ mT,
        ⌜ valid_addr a ∧ valid_off (projT1 v) a.(addrOff) ⌝ ) ∗
      "Hctxelem" ∷ ( [∗ map] a ↦ v ∈ mT,
        mapsto_txn γUnified a (committed v) ∗
        let dirty := match gBufmap !! a with
                     | None => false
                     | Some buf => bufDirty buf
                     end in
        ⌜dirty=true ∨ committed v = modified v⌝ ) ∗
      "%Hanydirty" ∷ ⌜anydirty=false <-> filter (λ b, (snd b).(bufDirty) = true) gBufmap = ∅⌝
  )%I.

Lemma is_jrnl_to_committed_mapsto_txn buftx mT γUnified dinit anydirty :
  is_jrnl buftx mT γUnified dinit anydirty -∗
  [∗ map] a ↦ v ∈ committed <$> mT, mapsto_txn γUnified a v.
Proof.
  iNamed 1.
  rewrite big_sepM_fmap.
  iApply (big_sepM_mono with "Hctxelem").
  iIntros (a obj Hlookup) "[Ha _]". iFrame.
Qed.

Lemma is_jrnl_not_in_map buftx mT γUnified dinit anydirty a v0 :
  is_jrnl buftx mT γUnified dinit anydirty -∗
  mapsto_txn γUnified a v0 -∗
  ⌜mT !! a = None⌝.
Proof.
  rewrite is_jrnl_to_committed_mapsto_txn.
  iIntros "Hm Ha".
  destruct (mT !! a) eqn:Helem; eauto.
  iExFalso.
  iDestruct (big_sepM_lookup _ _ a with "Hm") as "Ha2".
  { rewrite lookup_fmap Helem //. }
  iDestruct (mapsto_txn_2 with "Ha Ha2") as %[].
Qed.

Theorem wp_jrnl_Begin l γUnified dinit:
  {{{ is_txn l γUnified dinit
  }}}
    jrnl.Begin #l
  {{{ (buftx : loc), RET #buftx;
      is_jrnl buftx ∅ γUnified dinit false
  }}}.
Proof.
  iIntros (Φ) "#Htxn HΦ".

  wp_call.
  wp_apply (wp_MkBufMap with "[$]").
  iIntros (bufmap) "Hbufmap".
  wp_apply wp_allocStruct; first val_ty.
  iIntros (buftx) "Hbuftx".
  iDestruct (struct_fields_split with "Hbuftx") as "(Hbuftx.txn & Hbuftx.bufs & %)".
  wp_apply util_proof.wp_DPrintf.
  wp_pures.
  iApply "HΦ".
  iExists _, _, _.
  iFrame. iModIntro.
  rewrite big_sepM_empty. iFrame "Htxn ∗".
  iSplit; first by done.
  rewrite left_id.
  rewrite big_sepM_empty //.
Qed.

Theorem wp_Op__ReadBuf buftx mT γUnified dinit anydirty a (sz : u64) v :
  {{{
    is_jrnl buftx mT γUnified dinit anydirty ∗
    ⌜ mT !! a = Some v ⌝ ∗
    ⌜ sz = bufSz (projT1 v) ⌝
  }}}
    Op__ReadBuf #buftx (addr2val a) #sz
  {{{
    (bufptr : loc) dirty, RET #bufptr;
    is_buf bufptr a (Build_buf (projT1 v) (snd (projT2 v)) dirty) ∗
    ( ∀ v' dirty',
      ( ⌜ dirty' = true ∨ (dirty' = dirty ∧ snd (projT2 v) = v') ⌝ ∗
        is_buf bufptr a (Build_buf (projT1 v) v' dirty') ) ==∗
      ( is_jrnl buftx (<[a := existT _ (fst (projT2 v), v')]> mT) γUnified dinit (orb anydirty dirty') ) )
  }}}.
Proof.
  iIntros (Φ) "(Htxn & %Ha & ->) HΦ".
  iNamed "Htxn".
  iDestruct (big_sepM_lookup with "Hctxvalid") as "%"; eauto.
  wp_call.
  wp_loadField.
  wp_apply (wp_BufMap__Lookup with "[$Hbufmap]"); first intuition.
  iIntros (bufptr) "Hbufptr".
  wp_pures.
  wp_if_destruct.
  - destruct (gBufmap !! a) eqn:Hbufmap_a.
    {
      iDestruct "Hbufptr" as "[Hbufptr Hisbufmap]".
      iDestruct (is_buf_not_null with "Hbufptr") as %Hbufptr_not_null. congruence.
    }

    iDestruct "Hbufptr" as "[_ Hbufptr]".

    wp_loadField.
    iDestruct (big_sepM_lookup_acc with "Hctxelem") as "[[Hma %Hma] Hctxelem]"; eauto.
    rewrite Hbufmap_a /= in Hma. intuition try congruence.

    wp_apply (wp_txn_Load with "[$Histxn $Hma]").
    iIntros (bufptr b) "(Hbuf & % & % & Hma)".
    wp_pures.
    iDestruct ("Hctxelem" with "[Hma]") as "Hctxelem".
    { iFrame. rewrite Hbufmap_a. iPureIntro. intuition. }

    wp_loadField.
    wp_apply (wp_BufMap__Insert with "[$Hbufptr $Hbuf]").
    iIntros "Hbufptr".

    wp_loadField.
    wp_apply (wp_BufMap__Lookup with "[$Hbufptr]"); intuition.
    iIntros (bufptr2) "Hbufptr2".

    rewrite lookup_insert.
    iDestruct "Hbufptr2" as "[Hbufptr2 Hisbufmap]".

    destruct b, v, p. simpl in *. subst.
    unfold committed, modified in *. simpl in *.

    apply eq_sigT_eq_dep in H3.
    apply Eqdep_dec.eq_dep_eq_dec in H3.
    2: apply bufDataKind_eq_dec.

    inversion H5; clear H5; subst.
    apply eq_sigT_eq_dep in H7.
    apply Eqdep_dec.eq_dep_eq_dec in H7.
    2: apply bufDataKind_eq_dec.

    subst.

    iApply "HΦ".
    iFrame "Hbufptr2".

    iIntros (v' dirty') "[% Hbufptr]".
    iDestruct ("Hisbufmap" with "Hbufptr") as "Hisbufmap".

    rewrite insert_insert.
    iDestruct (big_sepM_delete with "Hctxvalid") as "[Ha Hctxvalid2]"; eauto.
    iDestruct (big_sepM_delete with "Hctxelem") as "[[He %He] Hctxelem]"; eauto. rewrite Hbufmap_a /= in He.

    intuition try congruence; subst.
    + iModIntro.
      iExists _, _, _.
      iFrame. iFrame "#".
      iSplit.
      { iPureIntro.
        rewrite ?fmap_insert /modified /=.
        eapply insert_mono; eauto.
      }
      iSplit.
      { iApply big_sepM_insert_delete; iFrame "#". }
      iSplit.
      {
        iApply big_sepM_insert_delete.
        rewrite lookup_insert /=.
        iSplitL "He". { iFrame. iPureIntro; eauto. }
        iApply big_sepM_mono; try iFrame.
        iIntros (xa xb Hb) "H".
        destruct (decide (a = xa)); subst.
        { rewrite lookup_delete in Hb. congruence. }
        rewrite lookup_insert_ne; eauto.
      }
      iPureIntro.
      split; intro Hx.
      { destruct anydirty; simpl in *; congruence. }
      rewrite map_filter_insert_True in Hx; last eauto.
      eapply insert_non_empty in Hx. exfalso; eauto.

    + iModIntro.
      iExists _, _, _.
      iFrame. iFrame "#".

      iSplit.
      { iPureIntro.
        rewrite ?fmap_insert /=.
        eapply insert_mono; eauto.
      }
      iSplit.
      { iApply big_sepM_insert_delete; iFrame "#". }
      iSplit.
      {
        iApply big_sepM_insert_delete.
        rewrite lookup_insert /=.
        iSplitL "He". { iFrame. iPureIntro. intuition congruence. }
        iApply big_sepM_mono; try iFrame.
        iIntros (xa xb Hb) "H".
        destruct (decide (a = xa)); subst.
        { rewrite lookup_delete in Hb. congruence. }
        rewrite lookup_insert_ne; eauto.
      }
      iPureIntro.
      split; intro Hx.
      { destruct anydirty; simpl in *; try congruence.
        rewrite map_filter_insert_not'; eauto.
        simpl; intros y Hy Htrue.
        assert (filter (λ (b : addr * buf), (b.2).(bufDirty) = true) gBufmap !! a = Some y) as Hz.
        { eapply map_filter_lookup_Some_2; eauto. }
        rewrite H in Hz; eauto. congruence. }
      destruct anydirty; simpl; try reflexivity.
      rewrite map_filter_insert_False in Hx; last eauto.
      rewrite delete_notin in Hx; eauto.

  - destruct (gBufmap !! a) eqn:Hbufmap_a.
    2: {
      iDestruct "Hbufptr" as "[% _]". congruence.
    }

    eapply map_subseteq_spec in Hbufmapelem as Ha'.
    2: {
      rewrite lookup_fmap. erewrite Hbufmap_a. rewrite /=. reflexivity.
    }
    rewrite lookup_fmap Ha in Ha'. inversion Ha'; clear Ha'; subst.
    destruct b; simpl in *; subst.

    apply eq_sigT_eq_dep in H2.
    apply Eqdep_dec.eq_dep_eq_dec in H2.
    2: apply bufDataKind_eq_dec.
    subst.

    iDestruct "Hbufptr" as "[Hbufptr Hisbufmap]".
    iApply "HΦ". iModIntro.
    iFrame "Hbufptr".

    iIntros (v' dirty') "[% Hbufptr]".
    iDestruct ("Hisbufmap" with "Hbufptr") as "Hisbufmap".

    iDestruct (big_sepM_delete with "Hctxvalid") as "[Ha Hctxvalid2]"; eauto.
    iDestruct (big_sepM_delete with "Hctxelem") as "[[He #Hepure] Hctxelem]"; eauto.

    intuition idtac; subst.
    + iModIntro.
      iExists _, _, _.
      iFrame "# ∗".

      iSplit.
      { iPureIntro.
        rewrite ?fmap_insert /modified /=.
        eapply insert_mono; eauto.
      }
      iSplit.
      { iApply big_sepM_insert_delete; iFrame "#". }
      iSplit.
      {
        iApply big_sepM_insert_delete.
        rewrite lookup_insert /=.
        iSplitL "He". { iFrame. iPureIntro. rewrite /committed /modified /=. intuition eauto. }
        iApply big_sepM_mono; try iFrame.
        iIntros (xa xb Hb) "H".
        destruct (decide (a = xa)); subst.
        { rewrite lookup_delete in Hb. congruence. }
        rewrite lookup_insert_ne; eauto.
      }
      iPureIntro.
      split; intro Hx.
      { destruct anydirty; simpl in *; congruence. }
      rewrite map_filter_insert_True in Hx; last eauto.
      eapply insert_non_empty in Hx. exfalso; eauto.

    + iModIntro.
      iExists _, _, _.
      iFrame "# ∗".

      iSplit.
      { iPureIntro.
        rewrite ?fmap_insert /=.
        eapply insert_mono; eauto.
      }
      iSplit.
      { iApply big_sepM_insert_delete; iFrame "#". }
      iSplit.
      {
        iApply big_sepM_insert_delete.
        rewrite lookup_insert /=.
        iSplitL "He". { iFrame. iDestruct "Hepure" as %He. rewrite Hbufmap_a /= in He. iPureIntro. rewrite /committed /modified /=. intuition idtac. }
        iApply big_sepM_mono; try iFrame.
        iIntros (xa xb Hb) "H".
        destruct (decide (a = xa)); subst.
        { rewrite lookup_delete in Hb. congruence. }
        rewrite lookup_insert_ne; eauto.
      }
      iPureIntro.
      split; intro Hx.
      { destruct anydirty; simpl in *; try congruence. subst.
        rewrite map_filter_insert_not'; eauto.
        simpl; intros y Hy Htrue.
        assert (filter (λ (b : addr * buf), (b.2).(bufDirty) = true) gBufmap !! a = Some y) as Hz.
        { eapply map_filter_lookup_Some_2; eauto. }
        rewrite H in Hz; eauto. inversion Hz. }
      destruct anydirty; simpl.
      {
        exfalso.
        destruct bufDirty.
        {
          rewrite map_filter_insert_True in Hx; eauto.
          eapply insert_non_empty in Hx; eauto.
        }
        rewrite map_filter_insert_not' in Hx; eauto.
        { eapply H3 in Hx; congruence. }
        intros y Hy. rewrite Hbufmap_a in Hy. inversion Hy; subst. eauto.
      }
      destruct bufDirty; try reflexivity. exfalso.
      rewrite map_filter_insert_True in Hx; eauto.
      eapply insert_non_empty in Hx; eauto.
Qed.

Theorem wp_Op__OverWrite buftx mt γUnified dinit a v0 (v : {K & (bufDataT K * bufDataT K)%type}) (sz : u64) (vslice : Slice.t) anydirty :
  {{{
    is_jrnl buftx mt γUnified dinit anydirty ∗
    ⌜ mt !! a = Some v0 ⌝ ∗
    is_buf_data vslice (snd (projT2 v)) a ∗
    ⌜ sz = bufSz (projT1 v) ⌝ ∗
    ⌜ existT (projT1 v) (fst (projT2 v)) = existT (projT1 v0) (fst (projT2 v0)) ⌝
  }}}
    Op__OverWrite #buftx (addr2val a) #sz (slice_val vslice)
  {{{
    RET #();
    is_jrnl buftx (<[a := v]> mt) γUnified dinit true
  }}}.
Proof using.
  iIntros (Φ) "(Htxn & %Ha & Hvslice & -> & %) HΦ".
Opaque struct.t.
  wp_call.
  iNamed "Htxn".
  iDestruct (big_sepM_lookup with "Hctxvalid") as "%"; eauto.

  wp_loadField.
  wp_apply (wp_BufMap__Lookup with "[$Hbufmap]"); intuition.
  iIntros (bufptr) "Hbufmapptr".

  wp_apply wp_ref_to; first by eauto.
  iIntros (b) "Hb".
  wp_pures.

  destruct v, p.
  inversion H; subst.
  apply eq_sigT_eq_dep in H6.
  apply Eqdep_dec.eq_dep_eq_dec in H6.
  2: apply bufDataKind_eq_dec.
  subst.

  destruct (gBufmap !! a) eqn:Hbufmap_a.
  - iDestruct "Hbufmapptr" as "[Hisbuf Hisbufmap]".
    iDestruct (is_buf_not_null with "Hisbuf") as "%".
    wp_load.
    wp_pures.
    destruct (bool_decide (#bufptr = #null)) eqn:Hbooldec.
    { apply bool_decide_eq_true_1 in Hbooldec; congruence. }
    wp_pures.
    wp_load.
    wp_apply (wp_buf_loadField_sz with "Hisbuf"); iIntros "Hisbuf".

    eapply map_subseteq_spec in Hbufmapelem as Ha'.
    2: {
      rewrite lookup_fmap. erewrite Hbufmap_a. rewrite /=. reflexivity.
    }
    rewrite lookup_fmap Ha in Ha'. inversion Ha'; clear Ha'; subst.
    destruct b0; simpl in *.

    wp_pures.
    destruct (bool_decide (#(bufSz (projT1 v0)) = #(bufSz (projT1 v0)))) eqn:He.
    2: { apply bool_decide_eq_false_1 in He; congruence. }
    wp_pures.
    wp_load.
    wp_apply (wp_buf_storeField_data with "[$Hisbuf $Hvslice]"); eauto.
    iIntros "Hisbuf".

    wp_pures.
    wp_load.
    wp_apply (wp_Buf__SetDirty with "Hisbuf"); iIntros "Hisbuf".
    wp_pures. iModIntro. iApply "HΦ".
    iFrame.

    iDestruct ("Hisbufmap" with "Hisbuf") as "Hisbufmap".

    iDestruct (big_sepM_delete with "Hctxvalid") as "[%Ha2 Hctxvalid2]"; eauto.
    iDestruct (big_sepM_delete with "Hctxelem") as "[[He %Hedirty] Hctxelem]"; eauto. rewrite Hbufmap_a /= in Hedirty.

    iExists _, _, _.
    simpl.
    iFrame. iFrame "#".

    iSplit.
    { iPureIntro.
      rewrite ?fmap_insert /modified /=.
      eapply insert_mono; eauto.
    }
    iSplit.
    { iApply big_sepM_insert_delete; iFrame "#".
      iPureIntro; intuition. }
    iSplit.
    {
      iApply big_sepM_insert_delete.
      rewrite lookup_insert /=.
      iSplitL "He". { iFrame. intuition. }
      iApply big_sepM_mono; try iFrame.
      iIntros (xa xb Hb) "H".
      destruct (decide (a = xa)); subst.
      { rewrite lookup_delete in Hb. congruence. }
      rewrite lookup_insert_ne; eauto.
    }
    iPureIntro. split; intros Hx; try congruence.
    rewrite -> map_filter_insert_True in Hx by eauto.
    eapply insert_non_empty in Hx. exfalso; eauto.

  - iDestruct "Hbufmapptr" as "[-> Hisbufmap]".
    wp_load.
    wp_pures.
    wp_apply (wp_MkBuf with "[$Hvslice]").
    { intuition. }
    iIntros (bufptr) "Hisbuf".
    wp_pures.
    wp_store.
    wp_pures.
    wp_load.
    wp_apply (wp_Buf__SetDirty with "Hisbuf"); iIntros "Hisbuf".
    wp_load.
    wp_loadField.

    wp_apply (wp_BufMap__Insert with "[$Hisbufmap $Hisbuf]").
    iIntros "Hisbufmap".
    wp_pures. iModIntro. iApply "HΦ".

    iDestruct (big_sepM_delete with "Hctxvalid") as "[%Ha2 Hctxvalid2]"; eauto.
    iDestruct (big_sepM_delete with "Hctxelem") as "[[He %Hedirty] Hctxelem]"; eauto. rewrite Hbufmap_a /= in Hedirty.

    iExists _, _, _.
    simpl.
    iFrame. iFrame "#".

    iSplit.
    { iPureIntro.
      rewrite ?fmap_insert /=.
      eapply insert_mono; eauto.
    }
    iSplit.
    { iApply big_sepM_insert_delete; iFrame "#".
      iPureIntro; intuition. }
    iSplit.
    {
      iApply big_sepM_insert_delete.
      rewrite lookup_insert /=.
      iSplitL "He". { iFrame. intuition. }
      iApply big_sepM_mono; try iFrame.
      iIntros (xa xb Hb) "H".
      destruct (decide (a = xa)); subst.
      { rewrite lookup_delete in Hb. congruence. }
      rewrite lookup_insert_ne; eauto.
    }
    iPureIntro. split; intros Hx; try congruence.
    rewrite -> map_filter_insert_True in Hx by eauto.
    eapply insert_non_empty in Hx. exfalso; eauto.
Qed.

Theorem wp_Op__NDirty buftx mt γUnified dinit anydirty :
  {{{
    is_jrnl buftx mt γUnified dinit anydirty
  }}}
    Op__NDirty #buftx
  {{{
    (n:u64), RET #n;
    is_jrnl buftx mt γUnified dinit anydirty
  }}}.
Proof.
  iIntros (Φ) "Htxn HΦ".
  iNamed "Htxn".
  wp_call.
  wp_loadField.
  wp_apply (wp_BufMap__Ndirty with "Hbufmap").
  iIntros (n) "[%Hnval Hbufmap]".
  iApply "HΦ".
  iExists _, _, _. iFrameNamed.
Qed.

Theorem Op_lift_one buftx mt γUnified dinit a v E anydirty :
  ↑invN ⊆ E ->
  (
    is_jrnl buftx mt γUnified dinit anydirty ∗
    mapsto_txn γUnified a v
  )
    -∗ |NC={E}=>
  (
    is_jrnl buftx (<[a := (existT (projT1 v) (projT2 v, projT2 v))]> mt) γUnified dinit anydirty
  ).
Proof.
  iIntros (HNE) "[Htxn Ha]".
  iNamed "Htxn".

  iAssert (⌜ mt !! a = None ⌝)%I as %Hnone.
  {
    destruct (mt !! a) eqn:He; eauto.
    iDestruct (big_sepM_lookup with "Hctxelem") as "[Ha2 %]"; eauto.
    destruct (gBufmap !! a); rewrite /=.
    { iDestruct (mapsto_txn_2 with "Ha Ha2") as %[]. }
    { iDestruct (mapsto_txn_2 with "Ha Ha2") as %[]. }
  }

  iAssert (⌜ gBufmap !! a = None ⌝)%I as %Hgnone.
  {
    destruct (gBufmap !! a) eqn:He; eauto.
    eapply map_subseteq_spec in Hbufmapelem as Ha'.
    { erewrite lookup_fmap in Ha'. erewrite Hnone in Ha'. simpl in Ha'. congruence. }
    rewrite lookup_fmap. erewrite He. rewrite /=. reflexivity.
  }

  iPoseProof "Histxn" as "Histxn0".
  iNamed "Histxn".
  iMod (mapsto_txn_valid with "Histxna [Ha Histxna]") as "[Ha %Havalid]"; eauto.

  iModIntro.
  iExists _, _, _.
  iFrame. iFrame "#%".

  iSplit.
  { iPureIntro. rewrite ?fmap_insert /=. destruct v.
    etransitivity. 2: apply insert_subseteq; rewrite lookup_fmap Hnone; done.
    eauto.
  }
  iSplit.
  { iApply big_sepM_insert; eauto. iFrame "#". intuition. }
  iApply big_sepM_insert; eauto. iFrame.
  rewrite /committed Hgnone /=. destruct v. iFrame.
  rewrite /modified /=. intuition.
Qed.

Global Instance mapsto_txn_conflicting γUnified : Conflicting (mapsto_txn γUnified).
Proof.
  rewrite /Conflicting /ConflictsWith.
  iIntros (a0 v0 a1 v1).
  iIntros "Hm1 Hm2".
  destruct (decide (a0 = a1)); eauto; subst.
  iDestruct (mapsto_txn_2 with "Hm1 Hm2") as %[].
Qed.

Global Instance mapsto_txn_conflicts_with γUnified : ConflictsWith (mapsto_txn γUnified) (mapsto_txn γUnified).
Proof.
  apply mapsto_txn_conflicting.
Qed.

Lemma gmap_fmap_disjoint {L} `{Countable L} V1 V2 (m1 m2 : gmap L V1) (f: V1 -> V2) :
  m1 ##ₘ m2 ->
  f <$> m1 ##ₘ f <$> m2.
Proof.
  rewrite !map_disjoint_dom !dom_fmap_L //.
Qed.

Theorem Op_lift buftx mt γUnified dinit (m : gmap addr {K & _}) E anydirty :
  ↑invN ⊆ E ->
  (
    is_jrnl buftx mt γUnified dinit anydirty ∗
    [∗ map] a ↦ v ∈ m, mapsto_txn γUnified a v
  )
    -∗ |NC={E}=>
  (
    is_jrnl buftx (((λ v, existT (projT1 v) (projT2 v, projT2 v)) <$> m) ∪ mt) γUnified dinit anydirty
  ).
Proof.
  iIntros (HNE) "[Htxn Ha]".
  iNamed "Htxn".

  iAssert ([∗ map] a↦v ∈ ((λ (v : {K & bufDataT K}), @existT bufDataKind (λ k, (bufDataT k * bufDataT k)%type) (projT1 v) (projT2 v, projT2 v)) <$> m),
           mapsto_txn γUnified a (@existT bufDataKind (λ k, bufDataT k) (projT1 v) (fst (projT2 (v : {K & (bufDataT K * bufDataT K)%type})))) )%I with "[Ha]" as "Ha".
  {
    rewrite big_sepM_fmap. iApply (big_sepM_mono with "Ha").
    iIntros (k x Hkx) "H". destruct x. iFrame.
  }

  iDestruct (big_sepM_disjoint_pred with "Hctxelem Ha") as %Hd.

  iMod (big_sepM_mono_ncfupd _ (fun a (v : {K : bufDataKind & (bufDataT K * bufDataT K)%type}) => mapsto_txn γUnified a (existT (projT1 v) (projT2 v).1) ∗ ⌜ valid_addr a ∧ valid_off (projT1 v) a.(addrOff) ⌝)%I _ emp%I with "[] [$Ha]") as "[_ Ha]".
  { iModIntro. iIntros (???) "[_ H]".
    iNamed "Histxn".
    iMod (mapsto_txn_valid with "Histxna [H Histxna]") as "[H %Havalid]"; eauto.
    iModIntro. iFrame. intuition eauto. }
  iDestruct (big_sepM_sep with "Ha") as "[Ha Havalid]".

  iModIntro.
  iExists _, _, _.
  iFrame. iFrame "#%".

  iSplit.
  { iPureIntro.
    etrans; [eauto|].
    rewrite map_fmap_union.
    rewrite -map_fmap_compose.
    replace ((modified ∘ (λ v : object, existT (projT1 v) (projT2 v, projT2 v)) <$> m) ∪ (modified <$> mt))
      with ((modified <$> mt) ∪ (modified ∘ (λ v : object, existT (projT1 v) (projT2 v, projT2 v)) <$> m)).
    1: apply map_union_subseteq_l.
    rewrite map_union_comm //.
    rewrite map_fmap_compose.
    eapply gmap_fmap_disjoint.
    eauto.
  }
  iSplit.
  { iApply big_sepM_union; eauto. }
  iApply big_sepM_union; eauto. iFrame.
  iApply big_sepM_mono; last iFrame "Ha".
  iIntros (???) "Hm". rewrite /committed. iFrame.
  rewrite /modified /=.
  rewrite lookup_fmap in H. destruct (m !! k); simpl in H; try congruence.
  inversion H; subst; simpl in *.
  destruct (gBufmap !! k); simpl; intuition.

Unshelve.
  rewrite /ConflictsWith.
  intros.
  iIntros "[H1 _] H2".
  destruct (gBufmap !! a0).
  2: { iApply (mapsto_txn_conflicts_with with "H1 H2"). }
  destruct b.(bufDirty).
  2: { iApply (mapsto_txn_conflicts_with with "H1 H2"). }
  iApply (mapsto_txn_conflicts_with with "H1 H2").
Qed.

Lemma map_filter_elem_of_dom {L} `{Countable L} {V} (m: gmap L V) P `{∀ x, Decision (P x)} (k: L) :
  k ∈ dom (filter P m) ↔
  ∃ v, m !! k = Some v ∧ P (k, v).
Proof.
  rewrite !elem_of_dom.
  split.
  - destruct 1 as [x [Hlookup HP]%map_filter_lookup_Some].
    eauto.
  - destruct 1 as [v [Hlookup HP]].
    eexists.
    apply map_filter_lookup_Some; eauto.
Qed.

Theorem wp_Op__CommitWait (PreQ: iProp Σ) buftx mt γUnified dinit (wait : bool) E  (Q : nat -> iProp Σ) anydirty :
  {{{
    is_jrnl buftx mt γUnified dinit anydirty ∗
    (|NC={⊤ ∖ ↑walN ∖ ↑ invN}=> PreQ) ∧ (|NC={⊤ ∖ ↑walN ∖ ↑invN, E}=> ∃ (σl : async (gmap addr {K & bufDataT K})),
        "Hcrashstates_frag" ∷ ghost_var γUnified.(txn_crashstates) (3/4) σl ∗
        "Hcrashstates_fupd" ∷ (
          let σ := (modified <$> mt) ∪ latest σl in
          ghost_var γUnified.(txn_crashstates) (3/4) (async_put σ σl)
          -∗ |NC={E, ⊤ ∖ ↑walN ∖ ↑invN}=> Q (length (possible σl)) ))
  }}}
    Op__CommitWait #buftx #wait
  {{{
    (ok : bool), RET #ok;
    if ok then
      ((⌜anydirty=true⌝ ∗ ∃ txnid,
      Q txnid ∗
      ([∗ map] a ↦ v ∈ modified <$> mt, mapsto_txn γUnified a v) ∗
      (⌜wait = true⌝ -∗ mono_nat_lb_own γUnified.(txn_walnames).(wal_heap_durable_lb) txnid)) ∨
      (⌜anydirty=false⌝ ∗ PreQ ∗
      [∗ map] a ↦ v ∈ modified <$> mt, mapsto_txn γUnified a v))
    else
      PreQ ∗
      [∗ map] a ↦ v ∈ committed <$> mt, mapsto_txn γUnified a v
  }}}.
Proof.
  iIntros (Φ) "(Htxn & Hfupd) HΦ".
  iNamed "Htxn".

  wp_call.
  wp_apply util_proof.wp_DPrintf.
  wp_loadField.
  wp_apply (wp_BufMap__DirtyBufs with "Hbufmap").
  iIntros (dirtyslice bufptrlist) "(Hdirtyslice & Hdirtylist)".
  wp_loadField.

  pose proof (map_filter_union_complement
              (λ x, bufDirty <$> (gBufmap !! fst x) = Some true)
              mt) as Hmt.
  rewrite <- Hmt at 2.
  iDestruct (big_sepM_union with "Hctxelem") as "[Hctxelem0 Hctxelem1]".
  { apply map_disjoint_filter_complement. }

  iAssert (⌜ dom (filter (λ x, bufDirty <$> (gBufmap !! fst x) = Some true) mt) =
             dom (filter (λ x, (snd x).(bufDirty) = true) gBufmap) ⌝)%I as "%Hdom".
  { iPureIntro.
   apply dom_filter_L; intros a.
   rewrite map_filter_elem_of_dom /=.
   split.
   - intros [v [Hlookup Hdirty]].
     rewrite Hlookup /=.
     simplify_eq/=.
     eapply (f_equal (fmap _)) in Hlookup.
     rewrite -lookup_fmap in Hlookup.
     eapply lookup_weaken in Hlookup; [|apply Hbufmapelem].
     fmap_Some in Hlookup as vo.
     rewrite Hlookup.
     eexists; split; eauto.
     congruence.
   - intros [vo [Hlookup Hdirty]].
     fmap_Some in Hdirty; eauto. }

  iDestruct (big_sepM_mono with "Hctxelem1") as "Hctxelem1".
  { iIntros (k x Hkx) "H".
    eapply map_filter_lookup_Some in Hkx; simpl in Hkx; destruct Hkx.
    destruct (gBufmap !! k).
    2: iExact "H".
    simpl in H0.
    destruct b.(bufDirty); try congruence.
    iFrame. }

  iDestruct (big_sepM_mono with "Hctxelem0") as "Hctxelem0".
  { iIntros (k x Hkx) "H".
    eapply map_filter_lookup_Some in Hkx; simpl in Hkx; destruct Hkx.
    destruct (gBufmap !! k).
    { simpl in *. destruct b.(bufDirty); try congruence.
      iDestruct "H" as "[H _]". iExact "H". }
    simpl in *. congruence. }
  simpl.

  wp_apply (wp_txn_CommitWait _ _ _ _ _ _
    ((λ (o : versioned_object),
            Build_buf_and_prev_data
           (Build_buf (projT1 o) (snd (projT2 o)) true)
           (fst (projT2 o))
      ) <$>
      (filter (λ v : addr * versioned_object, bufDirty <$> gBufmap !! v.1 = Some true) mt))
    _
    E
    ((|NC={⊤ ∖ ↑walN ∖ ↑invN}=> PreQ) ∗
      ( [∗ map] k↦x ∈ filter (λ v, bufDirty <$> gBufmap !! v.1 ≠ Some true) mt,
        mapsto_txn γUnified k (committed x) ∗ ⌜false = true ∨ committed x = modified x⌝ ))%I
    (λ txn_id,
      Q txn_id ∗
      ( [∗ map] k↦x ∈ filter (λ v, bufDirty <$> gBufmap !! v.1 ≠ Some true) mt,
        mapsto_txn γUnified k (committed x) ∗ ⌜false = true ∨ committed x = modified x⌝ ))%I
    with "[$Histxn $Hdirtyslice Hdirtylist Hctxelem0 Hctxelem1 Hfupd]"); eauto.
  {
    iSplitR "Hfupd Hctxelem1".
    {
      assert (filter (λ x, (x.2).(bufDirty) = true) gBufmap =
              (λ o : versioned_object, {| bufKind := projT1 o;
                                          bufData := (projT2 o).2;
                                          bufDirty := true |}) <$>
              filter (λ v, bufDirty <$> gBufmap !! v.1 = Some true) mt) as Hgmt.
      {
        eapply map_eq; intros a.
        destruct (filter (λ x : addr * buf, (x.2).(bufDirty) = true) gBufmap !! a) eqn:Heq.
        2: {
          rewrite lookup_fmap.
          rewrite map_filter_lookup_None_2; eauto.
          eapply map_filter_lookup_None_1 in Heq. intuition.
          { right; intros; simpl. rewrite H1 in H3. done. }
          right; intros; simpl.
          eapply fmap_Some_1 in H3. destruct H3; intuition; subst.
          eapply H1; eauto.
        }
        eapply map_filter_lookup_Some in Heq; destruct Heq; simpl in *; subst.
        eapply lookup_weaken in Hbufmapelem.
        2: { rewrite lookup_fmap. erewrite H. done. }
        rewrite lookup_fmap in Hbufmapelem.
        eapply fmap_Some_1 in Hbufmapelem. destruct Hbufmapelem; intuition; subst.
        rewrite lookup_fmap.
        erewrite map_filter_lookup_Some_2; eauto.
        2: { simpl. rewrite H. simpl. congruence. }
        simpl. f_equal.
        destruct b. simpl in *.
        rewrite /modified /= in H3. inversion H3; subst.
        done.
      }
      rewrite Hgmt.

      rewrite !big_sepML_fmap.
      iDestruct (big_sepML_sepM with "[$Hdirtylist $Hctxelem0]") as "Hdirtylist".
      iApply (big_sepML_mono with "Hdirtylist").
      iPureIntro.
      iIntros (k v lv) "[Hbuf Hmapsto]".
      rewrite /is_txn_buf_pre. iFrame.
    }
    {
      iSplit.
      { iDestruct "Hfupd" as "[$ _]". iFrame. }
      iIntros "%Hempty".
      iDestruct "Hfupd" as "[_ Hfupd]".
      iMod "Hfupd" as (σl) "Hfupd". iNamed "Hfupd".
      iModIntro.
      iIntros (CP) "[Hunify HCP]".

      iDestruct (big_sepM_mono_with_inv' with "[Hunify HCP Hcrashstates_frag $Hctxelem1]")
        as "[Hx Hctxelem1]".
      3: iDestruct (big_sepM_sep with "Hctxelem1") as "[Hctxelem1 Hctxelem1']".
      2: iAccu.
      {
        iIntros (k x Hkx) "[(#Hunify & HCP & Hcrashstates_frag) [Hmapsto Hextra]]".
        intuition try congruence.
        iDestruct ("Hunify" with "[$HCP $Hcrashstates_frag $Hmapsto]") as "#Hu".
        iSplitL "HCP Hcrashstates_frag". 1: iFrame "#∗".
        iAssert (⌜committed x = modified x⌝)%I as %Heq.
        { iDestruct "Hextra" as %Hextra. intuition eauto. }
        iSplitL "Hmapsto Hextra".
        { iAccu. }
        rewrite Heq. iExact "Hu".
      }
      iDestruct "Hx" as "(_ & HCP & Hcrashstates_frag)".
      simpl.

      iAssert (⌜modified <$> filter (λ v, bufDirty <$> gBufmap !! v.1 ≠ Some true) mt ⊆ σl.(latest)⌝)%I as %Hmt_latest.
      {
        iDestruct "Hctxelem1'" as %Hx.
        iPureIntro.
        eapply map_subseteq_spec.
        intros a o Ha. rewrite lookup_fmap in Ha.
        eapply fmap_Some_1 in Ha. destruct Ha as [vo [Ha Heq]]. subst.
        eapply Hx in Ha. eauto.
      }

      iModIntro. iFrame. iExists _. iFrame.
      iIntros "H".
      iMod ("Hcrashstates_fupd" with "[H]") as "$"; last done.

      replace (modified <$> mt) with (modified <$> (filter (λ v, bufDirty <$> gBufmap !! v.1 = Some true) mt ∪
                                                    filter (λ v, bufDirty <$> gBufmap !! v.1 ≠ Some true) mt)).
      2: { rewrite map_filter_union_complement; eauto. }
      rewrite map_fmap_union.
      rewrite -assoc.
      iExactEq "H". f_equal. f_equal. f_equal.
      { rewrite -map_fmap_compose. reflexivity. }
      rewrite map_subseteq_union; eauto.
    }
  }
  iIntros (ok) "Hunifiedtxns".
  iApply wp_ncfupd.
  wp_pures.

  iApply "HΦ".
  destruct ok.
  - iDestruct "Hunifiedtxns" as "[[Hq Hpreq] Hmapsto0]".
    destruct anydirty.
    {
      iLeft.
      iDestruct ("Hq" with "[]") as (txnid) "[Hq Hflush]".
      {
        iPureIntro. intro Hempty. apply fmap_empty_iff in Hempty.
        assert (filter (λ b, (b.2).(bufDirty) = true) gBufmap = ∅); intuition try congruence.
        eapply map_empty; intros a.
        eapply map_filter_lookup_None.
        destruct (gBufmap !! a) eqn:He; intuition eauto. right.
        simpl. intros bb Hx Hbb. inversion Hx; clear Hx; subst.
        eapply lookup_weaken in Hbufmapelem.
        2: { rewrite lookup_fmap. erewrite He. eauto. }
        rewrite lookup_fmap /modified in Hbufmapelem.
        eapply fmap_Some_1 in Hbufmapelem; destruct Hbufmapelem as [mb [Hbufmapelem He2]].
        destruct bb; simpl in *. inversion He2; subst.
        apply eq_sigT_eq_dep in He2. apply Eqdep_dec.eq_dep_eq_dec in He2; last apply bufDataKind_eq_dec.
        subst.
        eapply map_filter_lookup_Some_2 in Hbufmapelem.
        { erewrite Hempty in Hbufmapelem. inversion Hbufmapelem. }
        simpl. rewrite He. simpl. eauto.
      }
      iDestruct "Hq" as "[Hq Hctxelem1]".
      iSplitL ""; first by done.
      iExists _.
      iFrame "Hq". iFrame "Hflush".

      rewrite big_sepM_fmap.
      iDestruct (big_sepM_union (λ k x, mapsto_txn γUnified k (modified x)) with "[Hmapsto0 Hctxelem1]") as "Hmapsto".
      2: {
        iSplitL "Hmapsto0".
        { iApply (big_sepM_mono with "Hmapsto0").
          iIntros (k x Hkx) "H".
          destruct x; rewrite /modified /=. iFrame. }
        iApply (big_sepM_mono with "Hctxelem1").
        iIntros (k x Hkx) "[H %Heq]".
        destruct Heq as [Heq | Heq]; first congruence.
        rewrite Heq; iFrame.
      }
      { eapply map_disjoint_filter_complement. }
      rewrite map_filter_union_complement.
      rewrite big_sepM_fmap.
      iFrame.
      eauto.
    }
    {
      iRight.
      iSplitL ""; first by done.
      iDestruct ("Hpreq" with "[]") as "[Hpreq Hctxelem1]".
      1: {
        iPureIntro.
        assert (filter (λ v : addr * versioned_object, bufDirty <$> gBufmap !! v.1 = Some true) mt = ∅) as Hz.
        {
          eapply map_empty; intros a.
          eapply map_filter_lookup_None.
          destruct (mt !! a) eqn:He; intuition eauto. right.
          simpl. intros vo Hx Hvo. inversion Hx; clear Hx; subst.
          eapply fmap_Some_1 in Hvo. destruct Hvo as [bb [Hvo He2]].
          eapply map_filter_lookup_Some_2 in Hvo.
          { erewrite H1 in Hvo. inversion Hvo. }
          simpl. eauto.
        }
        rewrite Hz. rewrite fmap_empty; auto.
      }

      rewrite big_sepM_fmap.
      iDestruct (big_sepM_union (λ k x, mapsto_txn γUnified k (modified x)) with "[Hmapsto0 Hctxelem1]") as "Hmapsto".
      2: {
        iSplitL "Hmapsto0".
        { iApply (big_sepM_mono with "Hmapsto0").
          iIntros (k x Hkx) "H".
          destruct x; rewrite /modified /=. iFrame. }
        iApply (big_sepM_mono with "Hctxelem1").
        iIntros (k x Hkx) "[H %Heq]".
        destruct Heq as [Heq | Heq]; first congruence.
        rewrite Heq; iFrame.
      }
      { eapply map_disjoint_filter_complement. }
      rewrite map_filter_union_complement.
      rewrite big_sepM_fmap.
      iFrame.
      iMod (ncfupd_mask_mono with "Hpreq"); auto.
    }

  - iDestruct "Hunifiedtxns" as "[Hpreq Hmapsto0]".
    iDestruct "Hpreq" as "[Hpreq Hctxelem1]".
    iMod (ncfupd_mask_mono with "Hpreq") as "Hpreq"; first auto.
    iModIntro.
    iFrame "Hpreq".

    rewrite big_sepM_fmap.
    iDestruct (big_sepM_union (λ k x, mapsto_txn γUnified k (committed x)) with "[Hmapsto0 Hctxelem1]") as "Hmapsto".
    2: {
      iSplitL "Hmapsto0".
      { iApply (big_sepM_mono with "Hmapsto0").
        iIntros (k x Hkx) "H".
        destruct x; rewrite /committed /=. iFrame. }
      iApply (big_sepM_mono with "Hctxelem1").
      iIntros (k x Hkx) "[H _]". iFrame.
    }
    { eapply map_disjoint_filter_complement. }
    rewrite map_filter_union_complement.
    rewrite big_sepM_fmap.
    iFrame.
Qed.

Context `{!stagedG Σ}.

Definition wpwpcN := nroot.@"temp".

Theorem wpc_Op__CommitWait (PreQ: iProp Σ) buftx mt γUnified dinit (wait : bool) E  (Q Qc : nat -> iProp Σ) {HT1: Timeless PreQ} {HT2: ∀ n, Timeless (Qc n)} anydirty :
  {{{
    is_jrnl buftx mt γUnified dinit anydirty ∗
    <disc> PreQ ∧ ( |NC={⊤ ∖ ↑walN ∖ ↑invN ∖ ↑ wpwpcN, E}=> ∃ (σl : async (gmap addr {K & bufDataT K})),
        "Hcrashstates_frag" ∷ ghost_var γUnified.(txn_crashstates) (3/4) σl ∗
        "Hcrashstates_fupd" ∷ (
          let σ := (modified <$> mt) ∪ latest σl in
          ghost_var γUnified.(txn_crashstates) (3/4) (async_put σ σl)
          -∗ |NC={E, ⊤ ∖ ↑walN ∖ ↑invN ∖ ↑ wpwpcN}=> <disc> (▷ Qc (length (possible σl))) ∧ Q (length (possible σl)) ))
  }}}
    Op__CommitWait #buftx #wait @ ⊤
  {{{
    (ok : bool), RET #ok;
    if ok then
      ((⌜anydirty=true⌝ ∗ ∃ txnid,
      Q txnid ∗
      ([∗ map] a ↦ v ∈ modified <$> mt, mapsto_txn γUnified a v) ∗
      (⌜wait = true⌝ -∗ mono_nat_lb_own γUnified.(txn_walnames).(wal_heap_durable_lb) txnid)) ∨
      (⌜anydirty=false⌝ ∗ PreQ ∗
      [∗ map] a ↦ v ∈ modified <$> mt, mapsto_txn γUnified a v))
    else
      PreQ ∗
      [∗ map] a ↦ v ∈ committed <$> mt, mapsto_txn γUnified a v
  }}}
  {{{ (∃ txnid, Qc txnid) ∨ PreQ }}}.
Proof using stagedG0.
  iIntros (Φ Φc) "(His_jrnl&Hfupd) HΦc".
  rewrite bi.and_comm.
  rewrite own_discrete_fupd_eq /own_discrete_fupd_def.
  iDestruct (own_discrete_elim_conj with "Hfupd") as (Q_keep Q_inv) "(HQ_keep&HQ_inv&#Hwand1&#Hwand2)".
  iMod (pending_alloc) as (γpending) "Hpending".
  iMod (inv_mut_alloc (S 0) wpwpcN _ wp_to_wpc.mysch ([
   (∃ txnid, Qc txnid) ∨ PreQ; staged_done γpending; C; staged_pending (3/4)%Qp γpending])%I [Q_inv] with "[HQ_inv]") as "(#Hinv&Hfull)".
  { rewrite wp_to_wpc.mysch_interp_strong. iLeft. iSplit; first auto.
    iMod ("Hwand1" with "[$]") as "H".
    iModIntro. iMod (fupd_level_split_level with "H") as "$".
    { lia. }
    eauto.
  }
  iDestruct (pending_split34 with "Hpending") as "(Hpend34&Hpend14)".
  iAssert (WPC _ @ ⊤ {{ v, ∃ (ok: bool), ⌜ v = #ok ⌝ ∗ (staged_pending (3 / 4)%Qp γpending -∗ |NC={⊤}=>
                 (if ok
                  then
                   ⌜anydirty = true⌝
                   ∗ (∃ txnid : nat,
                        Q txnid
                        ∗ ([∗ map] a↦v ∈ (modified <$> mt), mapsto_txn γUnified a v)
                          ∗ (⌜wait = true⌝ -∗ mono_nat_lb_own γUnified.(txn_walnames).(wal_heap_durable_lb) txnid))
                   ∨ ⌜anydirty = false⌝ ∗ PreQ ∗ ([∗ map] a↦v ∈ (modified <$> mt), mapsto_txn γUnified a v)
                  else PreQ ∗ ([∗ map] a↦v ∈ (committed <$> mt), mapsto_txn γUnified a v)))}} {{ True }})%I with "[His_jrnl HQ_keep Hpend14 Hfull]" as "Hwpc";
    last first.
  {
    iApply wpc_ncfupd.
    iApply (wpc_step_strong_mono with "Hwpc"); auto.
    iSplit.
    * iNext. iIntros (?) "Hwand". iDestruct "Hwand" as (ok ->) "Hwand". iModIntro. iRight in "HΦc".
      iApply "HΦc". iApply "Hwand". by iFrame.
    * iLeft in "HΦc". iIntros "_". iIntros "HC".
      {
        iApply (fupd_level_fupd _ _ _ (S 0)).
        iMod (fupd_level_mask_mono with "HΦc") as "HΦc"; first by set_solver+.
        iMod (inv_mut_acc with "Hinv") as (Qs) "(H&Hclo)"; first auto.
        rewrite wp_to_wpc.mysch_interp_weak /=.
        iDestruct "H" as "[(_&>H)|[Hfalse1|Hfalse2]]".
        * iEval (rewrite uPred_fupd_level_eq /uPred_fupd_level_def).
          iMod (fupd_split_level_intro_mask' _ ∅) as "Hclo''"; first by set_solver+.
          iMod (fupd_split_level_le with "H") as ">H"; first lia.
          iMod "Hclo''".
          iSpecialize ("Hclo" with "[HC Hpend34]").
          { iRight. iLeft. iFrame. }
          iEval (rewrite uPred_fupd_level_eq /uPred_fupd_level_def) in "Hclo".
          iMod "Hclo". iModIntro. iApply "HΦc". iApply "H".
        * iDestruct "Hfalse1" as "(>_&>?)". iDestruct (pending34_pending34 with "[$] [$]") as "[]".
        * iDestruct "Hfalse2" as ">?". iDestruct (pending_done with "[$] [$]") as "[]".
      }
  }
  iApply (wp_wpc).
  iApply wp_ncfupd.
  wp_apply (wp_Op__CommitWait (staged_pending (3/4) γpending -∗ |NC={⊤}=> PreQ) _ _ _ _ _ E
                                  (λ n, staged_pending (3/4) γpending -∗ |NC={⊤}=> Q n)%I
              with "[$His_jrnl Hfull Hpend14 HQ_keep]").
  { iSplit.
    - rewrite ncfupd_eq /ncfupd_def. iIntros (q) "HNC".
      iMod (inv_mut_full_acc with "Hfull") as "(H&Hclo)"; first auto.
      { solve_ndisj. }
      rewrite ?mysch_interp_strong.
      iDestruct "H" as "[HQ|Hfalse]"; last first.
      { iDestruct "Hfalse" as "[(>Hfalse&_)|>Hfalse]".
        * iDestruct (NC_C with "[$] [$]") as "[]".
        * iDestruct (pending_done with "[$] [$]") as "[]".
      }
      iDestruct "HQ" as "(HQ&_)".
      iMod ("Hwand2" with "[$]") as "Hfupd".
      iRight in "Hfupd".

      iEval (rewrite -(and_idem (<bdisc> _)%I)) in "Hfupd".
      iClear "Hwand1 Hwand2".
      iDestruct (own_discrete_elim_conj with "Hfupd") as (Q_keep' Q_inv')
                                                                  "(HQ_keep&HQ_inv&#Hwand1&#Hwand2)".
      iMod ("Hclo" $! [Q_inv'] with "[HQ_inv]") as "Hfull".
      { rewrite ?wp_to_wpc.mysch_interp_strong. iLeft. iSplit; first auto.
        iMod ("Hwand1" with "[$]") as "H".
        iModIntro. iMod (fupd_level_split_level with "H") as "HQc".
        { lia. }
        iModIntro. eauto.
      }
      iFrame. iModIntro.
      iIntros "Hpend34" (q1) "HNC".
      iMod (inv_mut_full_acc with "Hfull") as "(H&Hclo)"; first auto.
      rewrite ?mysch_interp_strong.
      iDestruct "H" as "[HQ|Hfalse]"; last first.
      { iDestruct "Hfalse" as "[(>Hfalse&_)|>Hfalse]".
        * iDestruct (NC_C with "[$] [$]") as "[]".
        * iDestruct (pending_done with "[$] [$]") as "[]".
      }
      iDestruct "HQ" as "(HQ&_)".
      iMod ("Hwand2" with "[$]") as "(HΦ&_)".
      iDestruct (pending_join34 with "[$]") as "Hpend".
      iMod (pending_upd_done with "Hpend") as "Hdone".
      iMod ("Hclo" $! [True]%I with "[Hdone]").
      { rewrite ?mysch_interp_strong. iRight. by iRight. }
      iFrame. eauto.
      iEval (rewrite own_discrete_elim) in "HΦ".
      iPoseProof (fupd_level_fupd with "HΦ") as "HΦ".
      iMod (fupd_mask_mono with "HΦ") as "$"; first by set_solver+.
      eauto.
    - rewrite ncfupd_eq /ncfupd_def. iIntros (q) "HNC".
      iMod (inv_mut_full_acc with "Hfull") as "(H&Hclo)"; first auto.
      { solve_ndisj. }
      rewrite ?mysch_interp_strong.
      iDestruct "H" as "[HQ|Hfalse]"; last first.
      { iDestruct "Hfalse" as "[(>Hfalse&_)|>Hfalse]".
        * iDestruct (NC_C with "[$] [$]") as "[]".
        * iDestruct (pending_done with "[$] [$]") as "[]".
      }
      iDestruct "HQ" as "(HQ&_)".
      iMod ("Hwand2" with "[$]") as "Hfupd".
      iLeft in "Hfupd".
      iMod ("Hfupd" with "[$]") as "(Hfupd&HNC)".
      iDestruct "Hfupd" as (σl) "Hfupd".
      iEval (setoid_rewrite bi.and_comm) in "Hfupd".
      iModIntro. iFrame.
      iExists _. iNamed "Hfupd". iFrame. iIntros "?".

      iIntros (q') "HNC". iMod ("Hcrashstates_fupd" with "[$] [$]") as "(Hcrashstates&HNC)".
      iClear "Hwand1 Hwand2".
      iDestruct (own_discrete_elim_conj with "Hcrashstates") as (Q_keep' Q_inv')
                                                                  "(HQ_keep&HQ_inv&#Hwand1&#Hwand2)".
      iMod ("Hclo" $! [Q_inv'] with "[HQ_inv]") as "Hfull".
      { rewrite ?wp_to_wpc.mysch_interp_strong. iLeft. iSplit; first auto.
        iMod ("Hwand1" with "[$]") as "H".
        iModIntro. iMod (fupd_level_split_level with "H") as "HQc".
        { lia. }
        iModIntro. eauto.
      }
      iFrame. iModIntro.
      iIntros "Hpend34" (q1) "HNC".
      iMod (inv_mut_full_acc with "Hfull") as "(H&Hclo)"; first auto.
      rewrite ?mysch_interp_strong.
      iDestruct "H" as "[HQ|Hfalse]"; last first.
      { iDestruct "Hfalse" as "[(>Hfalse&_)|>Hfalse]".
        * iDestruct (NC_C with "[$] [$]") as "[]".
        * iDestruct (pending_done with "[$] [$]") as "[]".
      }
      iDestruct "HQ" as "(HQ&_)".
      iMod ("Hwand2" with "[$]") as "(HΦ&_)".
      iDestruct (pending_join34 with "[$]") as "Hpend".
      iMod (pending_upd_done with "Hpend") as "Hdone".
      iMod ("Hclo" $! [True]%I with "[Hdone]").
      { rewrite ?mysch_interp_strong. iRight. by iRight. }
      iFrame. eauto.
  }

  iIntros (ok) "H".
  iIntros "!>". iExists ok; iSplit; first done. iIntros "Hpending34".
  destruct ok.
  - iDestruct "H" as "[(Hp&H)|H]".
    * iLeft. iFrame. iDestruct "H" as (txid) "(HQ&H1&H2)". iExists _; iFrame.
      by iApply "HQ".
    * iRight. iFrame. iDestruct "H" as "($&H&$)".
      by iApply "H".
  - iDestruct "H" as "(H&$)". by iApply "H".
Qed.

End heap.


Require Export Db.Inst.
Require Export Db.Lemmas.
Require Export Db.WellScoping.

Require Export RecTypes.SpecTypes.

#[export]
#[refine] Instance vrTy : Vr Ty := {| vr := tvar |}.
Proof. inversion 1; auto. Defined.

Local Ltac crush :=
  intros; cbn in * |-;
  repeat
    (cbn;
     repeat crushRecTypesMatchH;
     repeat crushDbSyntaxMatchH;
     repeat crushDbLemmasMatchH;
     rewrite ?comp_up, ?up_liftSub, ?up_comp_lift
    );
  auto.

Module TyKit <: Kit.

  Definition TM := Ty.
  Definition inst_vr := vrTy.

  Section Application.

    Context {Y : Type}.
    Context {vrY : Vr Y}.
    Context {wkY: Wk Y}.
    Context {liftY: Lift Y Ty}.

    #[refine] Global Instance inst_ap : Ap Ty Y := {| ap := apTy |}.
    Proof.
      induction x; crush.
    Defined.

    #[refine] Global Instance inst_ap_vr : LemApVr Ty Y := {}.
    Proof. reflexivity. Qed.

  End Application.

  #[export]
  #[refine] Instance inst_ap_inj: LemApInj Ty Ix := {}.
  Proof.
    intros m Inj_m x. revert m Inj_m.
    induction x; destruct y; simpl; try discriminate;
    inversion 1; subst; f_equal; eauto using InjSubIxUp.
  Qed.

  #[export]
  #[refine] Instance inst_ap_comp (Y Z: Type)
    {vrY: Vr Y} {wkY: Wk Y} {liftY: Lift Y Ty}
    {vrZ: Vr Z} {wkZ: Wk Z} {liftZ: Lift Z Ty}
    {apYZ: Ap Y Z} {compUpYZ: LemCompUp Y Z}
    {apLiftYTmZ: LemApLift Y Z Ty} :
    LemApComp Ty Y Z := {}.
  Proof. induction x; crush. Qed.

  #[export]
  #[refine] Instance inst_ap_liftSub (Y: Type)
    {vrY: Vr Y} {wkY: Wk Y} {liftY: Lift Y Ty} :
    LemApLiftSub Ty Y := {}.
  Proof. induction t; crush. Qed.

  Lemma inst_ap_ixComp (τ: Ty) :
    ∀ (ξ: Sub Ix) (ζ: Sub Ty), τ[ξ][ζ] = τ[⌈ξ⌉ >=> ζ].
  Proof. pose proof up_comp_lift. induction τ; crush. Qed.

End TyKit.

Module InstTy := Inst TyKit.
Export InstTy. (* Export for shorter names. *)

#[export]
Instance wsVrTy: WsVr Ty.
Proof.
  constructor.
  - now constructor.
  - now inversion 1.
Qed.

Section ApplicationTy.

  Context {Y: Type}.
  Context {vrY : Vr Y}.
  Context {wkY: Wk Y}.
  Context {liftY: Lift Y Ty}.
  Context {wsY: Ws Y}.
  Context {wsVrY: WsVr Y}.
  Context {wsWkY: WsWk Y}.
  Context {wsLiftY: WsLift Y Ty}.

  Hint Resolve wsLift : ws.
  Hint Resolve wsSub_up : ws.

  Global Instance wsApTy : WsAp Ty Y.
  Proof.
    constructor.
    - intros ξ γ δ t wξ wt; revert ξ δ wξ.
      induction wt; intros ξ δ wξ; crush;
      try econstructor;
      try match goal with
            | |- wsTy ?δ ?t =>
              change (wsTy δ t) with ⟨ δ ⊢ t ⟩
          end; eauto with ws.
    - intros γ t wt.
      induction wt; crush.
      + apply IHwt; inversion 1; crush.
  Qed.
End ApplicationTy.

#[export]
Instance wsWkTy : WsWk Ty.
Proof.
  constructor; crush.
  - refine (wsAp _ H); eauto.
    constructor; eauto.
Qed.


Require Import compcert.lib.Axioms.
Require Import compcert.lib.Maps.
(* Require Export compcert.lib.Coqlib. *)

Require Import VST.concurrency.common.sepcomp. Import SepComp.

Require Import VST.concurrency.common.pos.
Require Import VST.concurrency.common.scheduler.
Require Import VST.concurrency.common.konig.
Require Import VST.concurrency.common.addressFiniteMap. (*The finite maps*)
Require Import VST.concurrency.common.pos.
Require Import VST.concurrency.common.lksize.
Require Import VST.concurrency.common.permjoin_def.
Require Import Coq.Program.Program.
From mathcomp.ssreflect Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype finfun.
Set Implicit Arguments.

Require Import VST.concurrency.common.ssromega. (*omega in ssrnat *)

Require Import Coq.ZArith.ZArith.

Require Import VST.concurrency.common.permissions.
Require Import VST.concurrency.common.threadPool.

Require Import compcert.common.Memory. (*for Mem.perm_order'' *)
Set Bullet Behavior "Strict Subproofs".

Definition map_leq {A B} (m1: PTree.t A)(m2: PTree.t B): Prop :=
  forall p, m1 ! p -> m2 ! p.

Lemma map_leq_apply:
  forall {A B} (m1: PTree.t A)(m2: PTree.t B) p f1,
    map_leq m1 m2 ->
    m1 ! p = Some f1 -> exists f2, m2 ! p = Some f2.
Proof.
  move => A B m1 m2 p f1.
  rewrite /map_leq => /(_ p) Mle AA.
  rewrite AA in Mle. specialize (Mle ltac:(auto)).
  destruct (m2 ! p) as [f2|]; try solve[inversion Mle].
  exists f2; auto.
Qed.

Lemma treemap_sub_map: forall {A B} (f: positive -> B -> A) m2,
    map_leq (PTree.map f m2) m2.
Proof.
  move => A B f m2 p.
  rewrite PTree.gmap.
  destruct (m2 ! p) eqn:m2p; auto; intros HH; inversion HH.
Qed.

Definition map_empty_def {A} (m1: PMap.t (Z -> option A)):=
  m1.1 = fun _ => None.

Definition fun_leq' {A B} (f1: Z -> option A) (f2: Z -> option B): Prop :=
  forall p, f1 p -> f2 p.

Definition fun_leq {A B} (o1: option (Z -> option A)) (o2: option (Z -> option B)): Prop :=
  match o1, o2 with
  | Some f1, Some f2 => fun_leq' f1 f2
  | None, None => True
  | _, _ => False
  end.

Definition option_eq {A B} (a:option A) (b: option B): Prop :=
  match a, b with
  | Some _ , Some _ => True
  | None, None => True
  | _, _ => False
  end.

Definition bounded_nat_func_aux {A} (f: nat -> option A) hi: Prop :=
  (forall p, (p >= hi )%nat -> f p = None).

Definition bounded_nat_func' {A} (f: nat -> option A) hi: Prop :=
  (forall p, (p > hi )%nat -> f p = None).

Definition bounded_func' {A} (f: Z -> option A) hi lo: Prop :=
  (forall p, (p > hi )%Z -> f p = None) /\
  (forall p, (p < lo)%Z -> f p = None).

Definition bounded_func_op {A} (f: option (Z -> option A)) hi lo: Prop :=
  match f with
  | Some f' => bounded_func' f' hi lo
  | None => True
  end.

Definition bounded_func {A} (f: Z -> option A): Prop :=
  exists hi lo,
  bounded_func' f hi lo.

Definition bounded_map {A} (m: PTree.t (Z -> option A)):=
  forall p f, m ! p = Some f -> bounded_func f.

Fixpoint strong_tree_leq {A B}
         (t1: PTree.t A) (t2: PTree.t B)
         (leq: option A -> option B -> Prop):=
  match t1, t2 with
  | PTree.Leaf, PTree.Leaf => True
  | PTree.Node l1 o1 r1, PTree.Node l2 o2 r2 =>
    leq o1 o2 /\
    strong_tree_leq l1 l2 leq /\
    strong_tree_leq r1 r2 leq
  | _, _ => False
  end.

Definition same_shape {A B} (m1: PTree.t (Z -> option A))(m2: PTree.t (Z -> option B)):=
  strong_tree_leq m1 m2 option_eq.

Definition sub_map' {A B} (m1: PTree.t (Z -> option A))(m2: PTree.t (Z -> option B)):=
  forall p f1, m1 ! p = Some f1 ->
          exists f2, m2 ! p = Some f2 /\ fun_leq' f1 f2.

Definition sub_map {A B} (m1: PTree.t (Z -> option A))(m2: PTree.t (Z -> option B)):=
  strong_tree_leq m1 m2 fun_leq.

Lemma sub_map_and_shape:
  forall { A B} m1 m2,
  @same_shape A B m1 m2 ->
  sub_map' m1 m2 ->
  sub_map m1 m2.
Proof.
  induction m1.
  - intros.
    destruct m2; inversion H.
    auto.
  - intros.
    rewrite /sub_map /=.
    destruct m2; try inversion H.
    split; [|split].
    + destruct o as [o|].
      2: destruct o0; inversion H1; auto.
      specialize (H0 1%positive o ltac:(auto)).
      destruct o0; try solve [inversion H1].
      destruct H0 as [f [ISo LEQ]].
      inversion ISo.
      auto.
    + destruct H as [AA [BB CC]].
      eapply IHm1_1; eauto.
      move => b f HH.
      move: H0 => /(_  (b~0)%positive f HH) //.
    + destruct H as [AA [BB CC]].
      eapply IHm1_2; eauto.
      move => b f HH.
      move: H0 => /(_  (b~1)%positive f HH) //.
Qed.

Definition nat_to_perm (i:nat) :=
  (match i with
  | 0 => Some None
  | 1 => Some (Some Nonempty)
  | 2 => Some (Some Readable)
  | 3 => Some (Some Writable)
  | 4 => Some (Some Freeable)
  | _ => None
  end)%nat.

Definition perm_to_nat (p: option (option permission)) :=
  match p with
  | Some (None) => 0
  | Some (Some Nonempty) => 1
  | Some (Some Readable) => 2
  | Some (Some Writable) => 3
  | Some (Some Freeable) => 4
  | None => 5
  end.

Definition nat_to_perm_simpl (i:nat) :=
  (match i with
  | 0 => None
  | 1 => Some Nonempty
  | 2 => Some Readable
  | 3 => Some Writable
  | 4 => Some Freeable
  | _ => None
  end)%nat.

Definition perm_to_nat_simpl (p: option permission) :=
  match p with
  | None => 0
  | Some Nonempty => 1
  | Some Readable => 2
  | Some Writable => 3
  | Some Freeable => 4
  end.
Lemma perm_to_nat_bound:
  forall p,
    perm_to_nat p < 6.
Proof.
  intros p.
  destruct p as [p|];
    try destruct p as [p|]; try destruct p; compute; auto.
Qed.

Lemma perm_to_nat_bound_simpl:
  forall p,
    perm_to_nat_simpl p < 5.
Proof.
  intros p.
  destruct p as [p|];
    try destruct p; compute; auto.
Qed.

Lemma nat_to_perm_perm_to_nat:
  forall p,
    nat_to_perm (perm_to_nat p) = p.
Proof.
  intros p.
  destruct p as [p|];
    try destruct p as [p|];
    try destruct p;
    reflexivity.
Qed.

Lemma nat_to_perm_perm_to_nat_simpl:
  forall p,
    nat_to_perm_simpl (perm_to_nat_simpl p) = p.
Proof.
  intros p.
  destruct p as [p|];
    try destruct p;
    reflexivity.
Qed.

Lemma finite_bounded_nat_aux_func:
  forall hi ,
    konig.finite
      ( fun f:nat -> option (option permission) => bounded_nat_func_aux f hi).
Proof.

   intros hi.
   pose (K:= perm_to_nat).
   induction hi.
   - exists 1%nat.
     exists (fun x _ => None).
     intros.
     exists 0%nat.
     split; auto.

     extensionality b.
     symmetry.
     apply H.
     apply /leP. omega.

   - destruct IHhi as [N [FN H]].
     exists (6*N)%nat.
     exists (fun x i => if (Nat.eq_dec i hi) then
                       nat_to_perm (Nat.modulo x 6)
                else FN (Nat.div x 6) i).
     move=> f HH.
     specialize (H (fun n => if (Nat.eq_dec n hi) then
                            None
                          else f n) ).
     destruct H as [i [ineq f_spec]].
     + intros pp pphi.
       destruct (Nat.eq_dec pp hi).
       * auto.
       * simpl; eapply HH.
         move: pphi=> /leP pphi.
         apply /ltP.
         omega.

     + exists ((6 * i) + (perm_to_nat (f hi))).
       split.
       * replace (6 * N) with
         (6 * (N - 1) + 6 ).
         { eapply (NPeano.Nat.lt_le_trans _ (6 * i  + 6)).
           - apply /leP.
             rewrite ltn_add2l.
             destruct (f hi) as [p|];
               [destruct p; try destruct p|]; simpl; apply /leP; try omega.
           - apply /leP.
             rewrite leq_add2r.
             rewrite leq_pmul2l.
             + apply / leP. clear -ineq.
               replace N with (S (N - 1)) in ineq.
               apply /leP.
               by rewrite - ltnS; apply /leP.
               rewrite -addn1.
               apply subnK.
               destruct N; apply /ltP; try omega.
             + compute; auto.
         }
         rewrite - mulnSr.
         replace (N -1).+1 with N; auto.
         rewrite -addn1.
         symmetry; apply subnK.
         destruct N; apply /ltP; try omega.
       * { extensionality i0.
           destruct (Nat.eq_dec i0 hi).
           - subst.
             rewrite addnC.
             rewrite mulnC.
             rewrite NPeano.Nat.mod_add; try omega.
             rewrite NPeano.Nat.mod_small;
               try (apply /ltP; eapply perm_to_nat_bound).
             rewrite nat_to_perm_perm_to_nat.
             reflexivity.

           - replace ((6 * i + perm_to_nat (f hi)) / 6) with i.
             + rewrite f_spec.
               simpl.
               destruct (Nat.eq_dec i0 hi);
                 try solve [exfalso; apply n; auto].
               reflexivity.
             + eapply NPeano.Nat.div_unique;
               try (apply /ltP; eapply perm_to_nat_bound).
               reflexivity.
         }
Qed.

Lemma finite_bounded_nat_aux_func_simpl:
  forall hi ,
    konig.finite
      ( fun f:nat -> option permission => bounded_nat_func_aux f hi).
Proof.

   intros hi.
   pose (K:= perm_to_nat_simpl).
   induction hi.
   - exists 1%nat.
     exists (fun x _ => None).
     intros.
     exists 0%nat.
     split; auto.

     extensionality b.
     symmetry.
     apply H.
     apply /leP. omega.

   - destruct IHhi as [N [FN H]].
     exists (5*N)%nat.
     exists (fun x i => if (Nat.eq_dec i hi) then
                       nat_to_perm_simpl (Nat.modulo x 5)
                else FN (Nat.div x 5) i).
     move=> f HH.
     specialize (H (fun n => if (Nat.eq_dec n hi) then
                            None
                          else f n) ).
     destruct H as [i [ineq f_spec]].
     + intros pp pphi.
       destruct (Nat.eq_dec pp hi).
       * auto.
       * simpl; eapply HH.
         move: pphi=> /leP pphi.
         apply /ltP.
         omega.

     + exists ((5 * i) + (perm_to_nat_simpl (f hi))).
       split.
       * replace (5 * N) with
         (5 * (N - 1) + 5 ).
         { eapply (NPeano.Nat.lt_le_trans _ (5 * i  + 5)).
           - apply /leP.
             rewrite ltn_add2l.
             destruct (f hi) as [p|]; [destruct p|]; simpl; apply /leP; try omega.
           - apply /leP.
             rewrite leq_add2r.
             rewrite leq_pmul2l.
             + apply / leP. clear -ineq.
               replace N with (S (N - 1)) in ineq.
               apply /leP.
               by rewrite - ltnS; apply /leP.
               rewrite -addn1.
               apply subnK.
               destruct N; apply /ltP; try omega.
             + compute; auto.
         }
         rewrite - mulnSr.
         replace (N -1).+1 with N; auto.
         rewrite -addn1.
         symmetry; apply subnK.
         destruct N; apply /ltP; try omega.
       * { extensionality i0.
           destruct (Nat.eq_dec i0 hi).
           - subst.
             rewrite addnC.
             rewrite mulnC.
             rewrite NPeano.Nat.mod_add; try omega.
             rewrite NPeano.Nat.mod_small;
               try (apply /ltP; eapply perm_to_nat_bound_simpl).
             rewrite nat_to_perm_perm_to_nat_simpl.
             reflexivity.

           - replace ((5 * i + perm_to_nat_simpl (f hi)) / 5) with i.
             + rewrite f_spec.
               simpl.
               destruct (Nat.eq_dec i0 hi);
                 try solve [exfalso; apply n; auto].
               reflexivity.
             + eapply NPeano.Nat.div_unique;
               try (apply /ltP; eapply perm_to_nat_bound_simpl).
               reflexivity.
         }
Qed.

Lemma finite_bounded_nat_func:
  forall hi ,
    konig.finite
      ( fun f:nat -> option (option permission) => bounded_nat_func' f hi).
Proof.
  intros.
  destruct (finite_bounded_nat_aux_func (S hi)) as [x [f HH]].
  exists x, f.
  move=> x0 BND.
  cut (bounded_nat_func_aux x0 hi.+1).
  2:{ intros b ineq; eapply BND; auto. }
  move=> /HH [] i [] A B.
  exists i; split; eauto.
Qed.

Lemma finite_bounded_nat_func_simpl:
  forall hi ,
    konig.finite
      ( fun f:nat -> option permission => bounded_nat_func' f hi).
Proof.
  intros.
  destruct (finite_bounded_nat_aux_func_simpl (S hi)) as [x [f HH]].
  exists x, f.
  move=> x0 BND.
  cut (bounded_nat_func_aux x0 hi.+1).
  2:{ intros b ineq; eapply BND; auto. }
  move=> /HH [] i [] A B.
  exists i; split; eauto.
Qed.

Lemma finite_bounded_func:
  forall hi lo,
    konig.finite
      ( fun f:Z -> option (option permission) => bounded_func' f hi lo).
Proof.
  intros hi lo.
  destruct (Coqlib.zlt hi lo).
  - exists 1%N.
    exists (fun _ _ => None).
    intros.
    exists 0%nat; split; auto.
    extensionality b.
    destruct H as[H1 H2].
    symmetry.
    destruct (Coqlib.zle b hi).
    + eapply H2.
      eapply Z.le_lt_trans; eauto.
    + eapply H1; assumption.
  - assert (0 <= hi - lo)%Z by omega.
    pose (n:= Z.to_nat (hi - lo)).
    destruct (finite_bounded_nat_func n) as [N [FN HN]].
    exists N.
    exists (fun n z => (if (Z_lt_ge_dec z lo)
                then None
                else FN n (Z.to_nat (z-lo)))).
    intros f [BOUND1 BOUND2].
    pose (f':= fun n => f (Z.of_nat n + lo)%Z).
    assert (bounded_nat_func' f' n).
    { intros b ineq.
      unfold f'.
      eapply BOUND1.
      unfold n in ineq.
      cut (Z.of_nat b > hi - lo)%Z.
      omega.
      move: ineq => /ltP /inj_lt /Z.gt_lt_iff.
      rewrite Z2Nat.id => //.
    }
    apply HN in H0.
    destruct H0 as [i [ineq FN_spec]].
    exists i; split; auto.
    extensionality z.
    rewrite FN_spec.
    unfold f'.
    destruct (Z_lt_ge_dec z lo).
    + simpl.
      symmetry.
        by apply BOUND2.
    + simpl.
      rewrite Z2Nat.id.
      * f_equal; omega.
      * omega.
Qed.

Lemma finite_bounded_func_simpl:
  forall hi lo,
    konig.finite
      ( fun f:Z -> option permission => bounded_func' f hi lo).
Proof.
  intros hi lo.
  destruct (Coqlib.zlt hi lo).
  - exists 1%N.
    exists (fun _ _ => None).
    intros.
    exists 0%nat; split; auto.
    extensionality b.
    destruct H as[H1 H2].
    symmetry.
    destruct (Coqlib.zle b hi).
    + eapply H2.
      eapply Z.le_lt_trans; eauto.
    + eapply H1; assumption.
  - assert (0 <= hi - lo)%Z by omega.
    pose (n:= Z.to_nat (hi - lo)).
    destruct (finite_bounded_nat_func_simpl n) as [N [FN HN]].
    exists N.
    exists (fun n z => (if (Z_lt_ge_dec z lo)
                then None
                else FN n (Z.to_nat (z-lo)))).
    intros f [BOUND1 BOUND2].
    pose (f':= fun n => f (Z.of_nat n + lo)%Z).
    assert (bounded_nat_func' f' n).
    { intros b ineq.
      unfold f'.
      eapply BOUND1.
      unfold n in ineq.
      cut (Z.of_nat b > hi - lo)%Z.
      omega.
      move: ineq => /ltP /inj_lt /Z.gt_lt_iff.
      rewrite Z2Nat.id => //.
    }
    apply HN in H0.
    destruct H0 as [i [ineq FN_spec]].
    exists i; split; auto.
    extensionality z.
    rewrite FN_spec.
    unfold f'.
    destruct (Z_lt_ge_dec z lo).
    + simpl.
      symmetry.
        by apply BOUND2.
    + simpl.
      rewrite Z2Nat.id.
      * f_equal; omega.
      * omega.
Qed.

Lemma finite_bounded_op_func_simpl:
  forall hi lo,
    konig.finite
      ( fun f: option (Z -> option permission) => bounded_func_op f hi lo).
Proof.
  move => hi lo.
  move: (finite_bounded_func_simpl hi lo) => [] N [] FN FN_spec.

  exists (S N).
  exists (fun n => if n == 0 then None
           else Some (FN (n -1)) ).
  move => f H.
  destruct f.
  - move: FN_spec => /(_ _ H) [] i [] ineqi speci.
    exists (S i); split.
    + omega.
    + rewrite - speci.
      simpl; repeat f_equal.
      rewrite - addn1 - addnBA=> //.
  - exists 0; split; auto.
    + omega.
Qed.

Lemma finite_bounded_op_func:
  forall hi lo,
    konig.finite
      ( fun f: option (Z -> option (option permission)) => bounded_func_op f hi lo).
Proof.
  move => hi lo.
  move: (finite_bounded_func hi lo) => [] N [] FN FN_spec.

  exists (S N).
  exists (fun n => if n == 0 then None
           else Some (FN (n -1)) ).
  move => f H.
  destruct f.
  - move: FN_spec => /(_ _ H) [] i [] ineqi speci.
    exists (S i); split.
    + omega.
    + rewrite - speci.
      simpl; repeat f_equal.
      rewrite - addn1 - addnBA=> //.
  - exists 0; split; auto.
    + omega.
Qed.

Lemma finite_sub_maps:
  forall m2,
    @bounded_map permission m2 ->
    konig.finite
      (fun m1 => @sub_map (option permission) permission m1 m2).
Proof.
  induction m2.
  - move => _.
    exists 1%nat.
    exists (fun _ => PTree.Leaf).
    intros .
    exists 0%nat.
    split; auto.
    destruct x; auto.
    unfold strong_tree_leq in H;
      simpl in H.
    destruct o; inversion H.
  - move => H.
    assert (HH1:
              forall (p : positive) (f : Z -> option permission),
                m2_1 ! p = Some f ->
                exists hi lo : Z,
                  (forall p0 : Z, (p0 > hi)%Z -> f p0 = None) /\
                  (forall p0 : Z, (p0 < lo)%Z -> f p0 = None)).
    { clear - H.
      move=> p f Hget.
      move : H => /(_ (p~0)%positive f ltac:(simpl;auto)) [] hi [] lo BOUND.
      exists hi, lo; assumption.
    }
    move: IHm2_1=> /(_ HH1) [] N1 [] F1 spec_F1.
    assert (HH2:
              forall (p : positive) (f : Z -> option permission),
                m2_2 ! p = Some f ->
                exists hi lo : Z,
                  (forall p0 : Z, (p0 > hi)%Z -> f p0 = None) /\
                  (forall p0 : Z, (p0 < lo)%Z -> f p0 = None)).
    { clear - H.
      move=> p f Hget.
      move : H => /(_ (p~1)%positive f ltac:(simpl;auto)) [] hi [] lo BOUND.
      exists hi, lo; assumption.
    }
    move: IHm2_2=> /(_ HH2) [] N2 [] F2 spec_F2.
    destruct o as [f1|].
    + move : H => /(_ 1%positive f1 ltac:(reflexivity)) [] hi [] lo BNDD.
      move : (finite_bounded_op_func hi lo) => [] N [] F F_spec.
      exists (S( N * N1 * N2)).
      exists (fun n => if n == 0
               then PTree.Leaf
               else
                 PTree.Node
                   (F1 ( (n-1) mod N1))
                   (F ((n-1) / (N1 * N2)))
                   (F2 (((n-1) / N1 ) mod N2))).
      intros x spec.
      destruct x.
      * exists 0%nat; split; auto.
        omega.
      * move: spec .
        rewrite /sub_map /= => [] [] FUN_lq [] tree1 tree2.
        assert (bounded_func_op o hi lo).
        { Lemma fun_le_bounded_func_op:
            forall {A} o f hi lo,
              @bounded_func' A f hi lo ->
              fun_leq o (Some f) ->
              @bounded_func_op (option A) o hi lo.
          Proof.
            intros.
            destruct o; [|constructor].
            simpl.
            simpl in H0.
            split; intros p.
            - intros HH. apply H in HH.
              unfold fun_leq' in H0.
              specialize (H0 p).
              destruct (o p); try solve [auto].
              specialize (H0 ltac:(auto)).
              rewrite HH in H0; inversion H0.
            - intros HH. apply H in HH.
              unfold fun_leq' in H0.
              specialize (H0 p).
              destruct (o p); try solve [auto].
              specialize (H0 ltac:(auto)).
              rewrite HH in H0; inversion H0.
          Qed.
          eapply fun_le_bounded_func_op ; eauto.
          }
        move: F_spec => /(_ _ H) []i [] ineq fi.
        move : spec_F1 => /(_ _ tree1) [] i1 [] ineq1 fi1.
        move : spec_F2 => /(_ _ tree2) [] i2 [] ineq2 fi2.
        exists (S(i1 + (i2 * N1) + (i * N1 * N2))); split.
        { apply lt_n_S.
          replace (N * N1 * N2) with
          (N1 + N1 * (N2 * N -1)).
          - eapply (NPeano.Nat.lt_le_trans).
            + instantiate (1:= (N1 + i2 * N1 + i * N1 * N2)).
              apply /ltP.
              rewrite ltn_add2r;
                rewrite ltn_add2r;
                apply /ltP; auto.
            + apply /leP.
              rewrite -addnA.
              rewrite leq_add2l.
              apply /leP.
              replace (i * N1 * N2) with
              ((i * N2) * N1).
              *
                rewrite -mulnDl.
                rewrite mulnC.
                apply /leP.
                rewrite leq_pmul2l; try (apply /ltP; omega).
                apply /leP.
                eapply lt_n_Sm_le.
                rewrite - addn1.
                rewrite subnK.
                2:
                  rewrite muln_gt0;
                  apply /andP; split;
                  try (apply /ltP; omega).
                eapply (NPeano.Nat.lt_le_trans).
                -- instantiate (1:= N2 + i * N2).
                   apply /ltP.
                   rewrite ltn_add2r.
                   apply /leP; auto.
                -- replace (N2 + i * N2) with
                   (N2 * (1 + i)).
                   apply /leP.
                   rewrite leq_pmul2l.
                   rewrite add1n.
                   apply /ltP; auto.
                   apply /ltP; omega.
                   rewrite mulnDr.
                   rewrite mulnC.
                   f_equal.
                   compute; auto.
                   rewrite mulnC; auto.
              * do 2 rewrite - mulnA.
                f_equal. rewrite mulnC; auto.
          - replace (N1 + N1 * (N2 * N - 1))
            with (N1 * 1 + N1 * (N2 * N - 1)).
            + rewrite -mulnDr.
              rewrite addnC.
              rewrite subnK.

              2:
                rewrite muln_gt0;
                apply /andP; split;
                try (apply /ltP; omega).
              rewrite -mulnA.
              rewrite mulnA.
              rewrite mulnC; auto.
            + f_equal.
              rewrite mulnC.
              compute; auto. }
      -- simpl; f_equal.
         ++ rewrite - fi1.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2 + (1 - 1)) with
            (i1 + i2 * N1 + i * N1 * N2) by ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2) with
            (i1 + (i2  + i *  N2) * N1).
            2:
            rewrite mulnDl addnA; f_equal;
            do 2 rewrite -mulnA; f_equal; rewrite mulnC; auto.
            rewrite NPeano.Nat.mod_add.
            apply NPeano.Nat.mod_small; auto.
            destruct N1; omega.
         ++ rewrite - fi.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2 + (1 - 1)) with
            (i1 + i2 * N1 + i * N1 * N2) by ssromega.
            assert (i1 + i2 * N1 + i * N1 * N2 =
                    ((N1 * N2) * i) + (i1 + i2 * N1)).
            { rewrite addnC. f_equal.
              rewrite - mulnA mulnC; auto. }
            eapply NPeano.Nat.div_unique in H0; auto.
            eapply (NPeano.Nat.lt_le_trans).
            ** instantiate (1:= N1 + i2 * N1).
               apply /ltP; rewrite ltn_add2r.
               apply /ltP; auto.
            ** replace (N1 + i2 * N1) with ( (1 + i2) * N1).
               rewrite add1n.
               rewrite mulnC.
               apply /leP; rewrite leq_pmul2l.
               apply /ltP; auto.
               destruct N1; ssromega.
               rewrite mulnDl; f_equal.
               ssromega.

         ++ rewrite - fi2.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2 + (1 - 1)) with
            (i1 + i2 * N1 + i * N1 * N2) by ssromega.
            assert (i1 + i2 * N1 + i * N1 * N2 =
                    (N1 * (i2 + i * N2)) + i1).
            { rewrite -addnA.
              replace (i * N1 * N2) with
              (i  * N2 * N1).
              rewrite - mulnDl.
              rewrite mulnC addnC; auto.
              do 2 rewrite -mulnA; f_equal.
              rewrite mulnC. auto. }
            eapply NPeano.Nat.div_unique in H0; auto.
            rewrite - H0.
            rewrite NPeano.Nat.mod_add.
            apply NPeano.Nat.mod_small; auto.
            destruct N2; omega.
    + exists (S( N1 * N2)).
      exists (fun n => if n == 0
               then PTree.Leaf
               else
                 PTree.Node
                   (F1 ( (n-1) mod N1))
                   (None )
                   (F2 (((n-1) / N1 ) mod N2))).
      intros x spec.
      destruct x.
      * exists 0%nat; split; auto.
        omega.
      * move: spec .
        rewrite /sub_map /= => [] [] FUN_lq [] tree1 tree2.
        move : spec_F1 => /(_ _ tree1) [] i1 [] ineq1 fi1.
        move : spec_F2 => /(_ _ tree2) [] i2 [] ineq2 fi2.
        exists (S(i1 + (i2 * N1))); split.
        { apply lt_n_S.
          replace (N1 * N2) with
          (N1 + N1 * (N2 -1)).
          - eapply (NPeano.Nat.lt_le_trans).
            + instantiate (1:= (N1 + i2 * N1)).
              apply /ltP.
              rewrite ltn_add2r;
                apply /ltP; auto.
            + apply /leP.
              rewrite leq_add2l.
              apply /leP.
              rewrite mulnC.
              apply /leP.
              rewrite leq_pmul2l; try (apply /ltP; omega).
              apply /leP.
              eapply lt_n_Sm_le.
              rewrite - addn1.
              rewrite subnK; auto.
              destruct N2; ssromega.

          - replace (N1 + N1 * (N2 - 1))
            with (N1 * 1 + N1 * (N2 - 1)).
            + rewrite -mulnDr.
              rewrite addnC.
              rewrite subnK.
              2: ssromega.
              rewrite mulnC; auto.
            + f_equal.
              rewrite mulnC.
              compute; auto. }
      -- simpl; f_equal.
         ++ rewrite - fi1.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + (1 - 1)) with
            (i1 + i2 * N1) by ssromega.
            rewrite NPeano.Nat.mod_add.
            apply NPeano.Nat.mod_small; auto.
            destruct N1; omega.
         ++ destruct o; auto; inversion FUN_lq.
         ++ rewrite - fi2.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + (1 - 1)) with
            (i1 + i2 * N1 ) by ssromega.
            assert (i1 + i2 * N1 =
                    (N1 * (i2) + i1)).
            { rewrite mulnC addnC; auto. }
            eapply NPeano.Nat.div_unique in H0; auto.
            rewrite - H0.
            apply NPeano.Nat.mod_small; auto.
Qed.

Lemma finite_sub_maps_simpl:
  forall m2,
    @bounded_map permission m2 ->
    konig.finite
      (fun m1 => @sub_map permission permission m1 m2).
Proof.

  induction m2.
  - move => _.
    exists 1%nat.
    exists (fun _ => PTree.Leaf).
    intros .
    exists 0%nat.
    split; auto.
    destruct x; auto.
    unfold strong_tree_leq in H;
      simpl in H.
    destruct o; inversion H.
  - move => H.
    assert (HH1:
              forall (p : positive) (f : Z -> option permission),
                m2_1 ! p = Some f ->
                exists hi lo : Z,
                  (forall p0 : Z, (p0 > hi)%Z -> f p0 = None) /\
                  (forall p0 : Z, (p0 < lo)%Z -> f p0 = None)).
    { clear - H.
      move=> p f Hget.
      move : H => /(_ (p~0)%positive f ltac:(simpl;auto)) [] hi [] lo BOUND.
      exists hi, lo; assumption.
    }
    move: IHm2_1=> /(_ HH1) [] N1 [] F1 spec_F1.
    assert (HH2:
              forall (p : positive) (f : Z -> option permission),
                m2_2 ! p = Some f ->
                exists hi lo : Z,
                  (forall p0 : Z, (p0 > hi)%Z -> f p0 = None) /\
                  (forall p0 : Z, (p0 < lo)%Z -> f p0 = None)).
    { clear - H.
      move=> p f Hget.
      move : H => /(_ (p~1)%positive f ltac:(simpl;auto)) [] hi [] lo BOUND.
      exists hi, lo; assumption.
    }
    move: IHm2_2=> /(_ HH2) [] N2 [] F2 spec_F2.
    destruct o as [f1|].
    + move : H => /(_ 1%positive f1 ltac:(reflexivity)) [] hi [] lo BNDD.
      move : (finite_bounded_op_func_simpl hi lo) => [] N [] F F_spec.
      exists (S( N * N1 * N2)).
      exists (fun n => if n == 0
               then PTree.Leaf
               else
                 PTree.Node
                   (F1 ( (n-1) mod N1))
                   (F ((n-1) / (N1 * N2)))
                   (F2 (((n-1) / N1 ) mod N2))).
      intros x spec.
      destruct x.
      * exists 0%nat; split; auto.
        omega.
      * move: spec .
        rewrite /sub_map /= => [] [] FUN_lq [] tree1 tree2.
        assert (bounded_func_op o hi lo).
        { Lemma fun_le_bounded_func_op_simpl:
            forall {A} o f hi lo,
              @bounded_func' A f hi lo ->
              fun_leq o (Some f) ->
              @bounded_func_op A o hi lo.
          Proof.
            intros.
            destruct o; [|constructor].
            simpl.
            simpl in H0.
            split; intros p.
            - intros HH. apply H in HH.
              unfold fun_leq' in H0.
              specialize (H0 p).
              destruct (o p); try solve [auto].
              specialize (H0 ltac:(auto)).
              rewrite HH in H0; inversion H0.
            - intros HH. apply H in HH.
              unfold fun_leq' in H0.
              specialize (H0 p).
              destruct (o p); try solve [auto].
              specialize (H0 ltac:(auto)).
              rewrite HH in H0; inversion H0.
          Qed.
          eapply fun_le_bounded_func_op_simpl ; eauto.
          }
        move: F_spec => /(_ _ H) []i [] ineq fi.
        move : spec_F1 => /(_ _ tree1) [] i1 [] ineq1 fi1.
        move : spec_F2 => /(_ _ tree2) [] i2 [] ineq2 fi2.
        exists (S(i1 + (i2 * N1) + (i * N1 * N2))); split.
        { apply lt_n_S.
          replace (N * N1 * N2) with
          (N1 + N1 * (N2 * N -1)).
          - eapply (NPeano.Nat.lt_le_trans).
            + instantiate (1:= (N1 + i2 * N1 + i * N1 * N2)).
              apply /ltP.
              rewrite ltn_add2r;
                rewrite ltn_add2r;
                apply /ltP; auto.
            + apply /leP.
              rewrite -addnA.
              rewrite leq_add2l.
              apply /leP.
              replace (i * N1 * N2) with
              ((i * N2) * N1).
              *
                rewrite -mulnDl.
                rewrite mulnC.
                apply /leP.
                rewrite leq_pmul2l; try (apply /ltP; omega).
                apply /leP.
                eapply lt_n_Sm_le.
                rewrite - addn1.
                rewrite subnK.
                2:
                  rewrite muln_gt0;
                  apply /andP; split;
                  try (apply /ltP; omega).
                eapply (NPeano.Nat.lt_le_trans).
                -- instantiate (1:= N2 + i * N2).
                   apply /ltP.
                   rewrite ltn_add2r.
                   apply /leP; auto.
                -- replace (N2 + i * N2) with
                   (N2 * (1 + i)).
                   apply /leP.
                   rewrite leq_pmul2l.
                   rewrite add1n.
                   apply /ltP; auto.
                   apply /ltP; omega.
                   rewrite mulnDr.
                   rewrite mulnC.
                   f_equal.
                   compute; auto.
                   rewrite mulnC; auto.
              * do 2 rewrite - mulnA.
                f_equal. rewrite mulnC; auto.
          - replace (N1 + N1 * (N2 * N - 1))
            with (N1 * 1 + N1 * (N2 * N - 1)).
            + rewrite -mulnDr.
              rewrite addnC.
              rewrite subnK.

              2:
                rewrite muln_gt0;
                apply /andP; split;
                try (apply /ltP; omega).
              rewrite -mulnA.
              rewrite mulnA.
              rewrite mulnC; auto.
            + f_equal.
              rewrite mulnC.
              compute; auto. }
      -- simpl; f_equal.
         ++ rewrite - fi1.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2 + (1 - 1)) with
            (i1 + i2 * N1 + i * N1 * N2) by ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2) with
            (i1 + (i2  + i *  N2) * N1).
            2:
            rewrite mulnDl addnA; f_equal;
            do 2 rewrite -mulnA; f_equal; rewrite mulnC; auto.
            rewrite NPeano.Nat.mod_add.
            apply NPeano.Nat.mod_small; auto.
            destruct N1; omega.
         ++ rewrite - fi.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2 + (1 - 1)) with
            (i1 + i2 * N1 + i * N1 * N2) by ssromega.
            assert (i1 + i2 * N1 + i * N1 * N2 =
                    ((N1 * N2) * i) + (i1 + i2 * N1)).
            { rewrite addnC. f_equal.
              rewrite - mulnA mulnC; auto. }
            eapply NPeano.Nat.div_unique in H0; auto.
            eapply (NPeano.Nat.lt_le_trans).
            ** instantiate (1:= N1 + i2 * N1).
               apply /ltP; rewrite ltn_add2r.
               apply /ltP; auto.
            ** replace (N1 + i2 * N1) with ( (1 + i2) * N1).
               rewrite add1n.
               rewrite mulnC.
               apply /leP; rewrite leq_pmul2l.
               apply /ltP; auto.
               destruct N1; ssromega.
               rewrite mulnDl; f_equal.
               ssromega.

         ++ rewrite - fi2.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2 + (1 - 1)) with
            (i1 + i2 * N1 + i * N1 * N2) by ssromega.
            assert (i1 + i2 * N1 + i * N1 * N2 =
                    (N1 * (i2 + i * N2)) + i1).
            { rewrite -addnA.
              replace (i * N1 * N2) with
              (i  * N2 * N1).
              rewrite - mulnDl.
              rewrite mulnC addnC; auto.
              do 2 rewrite -mulnA; f_equal.
              rewrite mulnC. auto. }
            eapply NPeano.Nat.div_unique in H0; auto.
            rewrite - H0.
            rewrite NPeano.Nat.mod_add.
            apply NPeano.Nat.mod_small; auto.
            destruct N2; omega.
    + exists (S( N1 * N2)).
      exists (fun n => if n == 0
               then PTree.Leaf
               else
                 PTree.Node
                   (F1 ( (n-1) mod N1))
                   (None )
                   (F2 (((n-1) / N1 ) mod N2))).
      intros x spec.
      destruct x.
      * exists 0%nat; split; auto.
        omega.
      * move: spec .
        rewrite /sub_map /= => [] [] FUN_lq [] tree1 tree2.
        move : spec_F1 => /(_ _ tree1) [] i1 [] ineq1 fi1.
        move : spec_F2 => /(_ _ tree2) [] i2 [] ineq2 fi2.
        exists (S(i1 + (i2 * N1))); split.
        { apply lt_n_S.
          replace (N1 * N2) with
          (N1 + N1 * (N2 -1)).
          - eapply (NPeano.Nat.lt_le_trans).
            + instantiate (1:= (N1 + i2 * N1)).
              apply /ltP.
              rewrite ltn_add2r;
                apply /ltP; auto.
            + apply /leP.
              rewrite leq_add2l.
              apply /leP.
              rewrite mulnC.
              apply /leP.
              rewrite leq_pmul2l; try (apply /ltP; omega).
              apply /leP.
              eapply lt_n_Sm_le.
              rewrite - addn1.
              rewrite subnK; auto.
              destruct N2; ssromega.

          - replace (N1 + N1 * (N2 - 1))
            with (N1 * 1 + N1 * (N2 - 1)).
            + rewrite -mulnDr.
              rewrite addnC.
              rewrite subnK.
              2: ssromega.
              rewrite mulnC; auto.
            + f_equal.
              rewrite mulnC.
              compute; auto. }
      -- simpl; f_equal.
         ++ rewrite - fi1.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + (1 - 1)) with
            (i1 + i2 * N1) by ssromega.
            rewrite NPeano.Nat.mod_add.
            apply NPeano.Nat.mod_small; auto.
            destruct N1; omega.
         ++ destruct o; auto; inversion FUN_lq.
         ++ rewrite - fi2.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + (1 - 1)) with
            (i1 + i2 * N1 ) by ssromega.
            assert (i1 + i2 * N1 =
                    (N1 * (i2) + i1)).
            { rewrite mulnC addnC; auto. }
            eapply NPeano.Nat.div_unique in H0; auto.
            rewrite - H0.
            apply NPeano.Nat.mod_small; auto.
Qed.

Lemma fun_leq_trans: forall {A B C} f1 f2 f3, @fun_leq A B f1 f2 -> @fun_leq B C f2 f3 ->
  @fun_leq A C f1 f3.
Proof.
  unfold fun_leq, fun_leq'; destruct f1, f2, f3; auto.
Qed.

Lemma sub_map_trans: forall {A B C} m1 m2 m3, @sub_map A B m1 m2 -> @sub_map B C m2 m3 ->
  @sub_map A C m1 m3.
Proof.
  unfold sub_map; induction m1; destruct m2; intros; inversion H; destruct m3; inversion H0;
    auto; simpl in *.
  repeat split.
  - eapply fun_leq_trans; eauto.
  - apply (IHm1_1 m2_1); tauto.
  - apply (IHm1_2 m2_2); tauto.
Qed.

Lemma same_shape_map:
  forall {A B} m f,
    @same_shape A B (PTree.map f m) m.
Proof.
  intros until m.
  unfold PTree.map.
  pose (i:=1%positive); fold i.
  generalize i; clear i.
  induction m.
  - intros;
      unfold same_shape;
      simpl; auto.
  - intros;
      unfold same_shape;
      split; [| split].
    + destruct o; simpl; auto.
    + eapply IHm1.
    + eapply IHm2.
Qed.


Require Export Iron.Language.SystemF2Cap.Step.Frame.
Require Export Iron.Language.SystemF2Cap.Store.Bind.
Require Export Iron.Language.SystemF2Cap.Store.TypeB.
Require Export Iron.Language.SystemF2Cap.Store.StoreT.
Require Export Iron.Language.SystemF2Cap.Store.StoreM.
Require Export Iron.Language.SystemF2Cap.Store.StoreP.

(*******************************************************************)
(* Well formed store. *)
Inductive WfS   : stenv -> stprops -> store -> Prop :=
 | WfS_
   :  forall se sp ss
   ,  Forall ClosedT se
   -> StoreM se    ss
   -> StoreT se sp ss
   -> WfS se sp ss.
Hint Constructors WfS.

(* Well formed store and frame stack. *)
Inductive WfFS : stenv -> stprops -> store -> stack -> Prop :=
 | WfFS_
   :  forall se sp ss fs
   ,  Forall ClosedT se
   -> StoreM se ss
   -> StoreT se sp ss
   -> StoreP sp fs
   -> WfFS se sp ss fs.
Hint Constructors WfFS.

(*******************************************************************)
(* If a well formed frame stack and store is well formed,
   then the store is also well formed by itself. *)
Lemma wfFS_wfS
 :  forall se sp ss fs
 ,  WfFS   se sp ss fs
 -> WfS    se sp ss.
Proof. intros. inverts H. eauto. Qed.
Hint Resolve wfFS_wfS.

Lemma wfFS_closedT
 :  forall se sp ss fs
 ,  WfFS   se sp ss fs
 -> Forall ClosedT se.
Proof. intros. inverts H. eauto. Qed.
Hint Resolve wfFS_closedT.

Lemma wfFS_typeb
 :  forall se sp ss fs b
 ,  WfFS se sp ss fs
 -> In b ss
 -> (exists t, TypeB nil nil se sp b t).
Proof.
 intros.
 inverts H.
 eapply Forall2_exists_left; eauto.
Qed.
Hint Resolve wfFS_typeb.

(* The region handles of private regions are present in the
   store properties. *)
Lemma wfFS_fpriv_sregion
 :  forall se sp ss fs m1 p2 ts
 ,  WfFS se sp ss fs
 -> In (FPriv   m1 p2 ts) fs
 -> In (SRegion p2)    sp.
Proof. intros. inverts H. firstorder. Qed.
Hint Resolve wfFS_fpriv_sregion.

(* The length of the store enviroment is the same as the length
   of the store. We have one entry in the store environment for
   each binding in the store. *)
Lemma wfFS_storem_length
 :  forall se sp ss fs
 ,  WfFS   se sp ss fs
 -> length se = length ss.
Proof. intros. inverts H. auto. Qed.
Hint Resolve wfFS_storem_length.

(* Creating a top level private region preserves well-formedness
   of the store. *)
Lemma wfFS_push_priv_top
 :  forall se sp ss fs p2 ts
 ,  WfFS se sp ss fs
 -> WfFS se (SRegion p2 <: sp) ss (fs :> FPriv None p2 ts).
Proof. intros. inverts H. auto. Qed.
Hint Resolve wfFS_push_priv_top.

(* Creating an extension region preserves well-formedness
   of the store. *)
Lemma wfFS_push_priv_ext
 :  forall se sp ss fs p1 p2 ts
 ,  In (SRegion p1) sp
 -> WfFS  se  sp ss fs
 -> WfFS  se  (SRegion p2 <: sp) ss (fs :> FPriv (Some p1) p2 ts).
Proof.
 intros.
 inverts H0. eapply WfFS_; rip.
 unfold StoreP in *. rip.
 - inverts H0; eauto.
   inverts H4. eauto.
 - inverts H0; eauto.
   inverts H4; eauto.
Qed.
Hint Resolve wfFS_push_priv_ext.

(* Deallocating a region preserves well-formedness of the store. *)
Lemma typeB_deallocate
 :  forall ke te se sp p b t
 ,  TypeB  ke te se sp b t
 -> TypeB  ke te se sp (deallocRegion p b) t.
Proof.
 intros.
 destruct b.
 - snorm. subst.
   inverts H. eauto.
 - snorm.
Qed.

(* Deallocating bindings preserves the well typedness of the store. *)
Lemma storeT_deallocate
 :  forall se sp ss p
 ,  StoreT se sp ss
 -> StoreT se sp (map (deallocRegion p) ss).
Proof.
 intros.
 unfold StoreT in *.
 eapply Forall2_map_left.
 eapply Forall2_impl.
 - intros.
    eapply typeB_deallocate. eauto.
 - auto.
Qed.

(* Deallocating top-level region on the top of the frame stack
   preserves the well formedness of the store. *)
Lemma wfFS_region_deallocate
 :  forall se sp ss fs p ts
 ,  WfFS se sp ss (fs :> FPriv None p ts)
 -> WfFS se sp (map (deallocRegion p) ss) fs.
Proof.
 intros.
 inverts H. eapply WfFS_; rip.
 - unfold StoreM in *.
   rewrite map_length; auto.
 - eapply storeT_deallocate; auto.
 - unfold StoreP in *; snorm; eauto.
Qed.

Lemma wfFS_pop_priv_ext
 :  forall se sp ss fs p1 p2 ts
 ,  In (SRegion p1) sp
 -> WfFS se sp ss (fs :> FPriv (Some p1) p2 ts)
 -> WfFS (mergeTE p1 p2 se) sp (mergeBs p1 p2 ss) fs.
Proof.
 intros.
 inverts H0. split.
 - eapply Forall_map.
   eapply Forall_impl with (P := ClosedT).
   + intros. eapply mergeT_wfT; eauto.
   + auto.

 - unfold StoreM in *.
   unfold mergeTE.
   unfold mergeBs.
   repeat (rewrite map_length). auto.

 - unfold StoreT.
   eapply storeT_mergeB; auto.

 - eapply storeP_pop; eauto.
Qed.

(* Appending a closed store binding to the store preserves its
   well formedness. *)
Lemma wfFS_stbind_snoc
 :  forall se sp ss fs p v t
 ,  In (SRegion p) sp
 -> TypeV  nil nil se sp v t
 -> WfFS           se sp ss fs
 -> WfFS   (TRef (TRgn p) t <: se) sp
           (StValue p v <: ss) fs.
Proof.
 intros.
 inverts H1.
 eapply WfFS_; rip.
 eapply Forall_snoc; eauto.
Qed.

(* Updating bindings preserves the well formedness of the store. *)
Lemma wfFS_stbind_update
 :  forall se sp ss fs l p v t
 ,  get l se = Some (TRef (TRgn p) t)
 -> In (SRegion p) sp
 -> TypeV nil nil se sp v t
 -> WfFS se sp ss fs
 -> WfFS se sp (update l (StValue p v) ss) fs.
Proof.
 intros se sp ss fs l p v t HG HK HV HWF1.
 inverts HWF1. eapply WfFS_; rip.
 - have (length se = length ss).
   unfold StoreM.
   rewritess.
   rewrite update_length. auto.
 - unfold StoreT.
   eapply Forall2_update_right; eauto.
Qed.


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 Σ, MonRef: MonRefG (leibnizO _) CapR_rtc Σ}.
  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 LoadU_failure (regs: Reg) (rdst rsrc: RegName) (offs: Z + RegName) (mem : PermMem):=
  | LoadU_fail_const z:
      regs !! rsrc = Some (inl z) ->
      LoadU_failure regs rdst rsrc offs mem
  | LoadU_fail_perm p g b e a:
      regs !! rsrc = Some (inr ((p, g), b, e, a)) ->
      isU p = false ->
      LoadU_failure regs rdst rsrc offs mem
  | LoadU_fail_offs_arg p g b e a:
      regs !! rsrc = Some (inr ((p, g), b, e, a)) ->
      isU p = true ->
      z_of_argument regs offs = None ->
      LoadU_failure regs rdst rsrc offs mem
  | LoadU_fail_verify_access p g b e a noffs:
      regs !! rsrc = Some (inr ((p, g), b, e, a)) ->
      isU p = true ->
      z_of_argument regs offs = Some noffs ->
      verify_access (LoadU_access b e a noffs) = None ->
      LoadU_failure regs rdst rsrc offs mem
  | LoadU_fail_incrementPC p g b e a noffs a' p' w:
      regs !! rsrc = Some (inr ((p, g), b, e, a)) ->
      isU p = true ->
      z_of_argument regs offs = Some noffs ->
      verify_access (LoadU_access b e a noffs) = Some a' ->
      mem !! a' = Some(p', w) →
      incrementPC (<[ rdst := w ]> regs) = None ->
      LoadU_failure regs rdst rsrc offs mem.

  Inductive LoadU_spec
    (regs: Reg) (rdst rsrc: RegName) (offs: Z + RegName)
    (regs': Reg) (mem : PermMem) : cap_lang.val → Prop
  :=
  | LoadU_spec_success p p' g b e a a' noffs w :
      regs !! rsrc = Some (inr ((p, g), b, e, a)) ->
      isU p = true ->
      z_of_argument regs offs = Some noffs ->
      verify_access (LoadU_access b e a noffs) = Some a' ->
      mem !! a' = Some(p', w) →
      incrementPC (<[ rdst := w ]> regs) = Some regs' ->
      LoadU_spec regs rdst rsrc offs regs' mem NextIV
  | LoadU_spec_failure :
    LoadU_failure regs rdst rsrc offs mem ->
    LoadU_spec regs rdst rsrc offs regs' mem FailedV.

  Lemma wp_loadU Ep
     pc_p pc_g pc_b pc_e pc_a pc_p'
     rdst rsrc offs w mem regs :
   decodeInstrW w = LoadU rdst rsrc offs →
   pc_p' ≠ O →
   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 (LoadU rdst rsrc offs) ⊆ dom _ regs →
   mem !! pc_a = Some (pc_p', w) →
   match regs !! rsrc with
   | None => True
   | Some (inl _) => True
   | Some (inr (p, g, b, e, a)) =>
     if isU p then
       match z_of_argument regs offs with
       | None => True
       | Some zoffs => match verify_access (LoadU_access b e a zoffs) with
                      | None => True
                      | Some a' => match mem !! a' with
                                  | None => False
                                  | Some (p', w) => p' <> O
                                  end
                      end
       end
     else True
   end ->

   {{{ (▷ [∗ map] a↦pw ∈ mem, ∃ p w, ⌜pw = (p,w)⌝ ∗ a ↦ₐ[p] w) ∗
       ▷ [∗ map] k↦y ∈ regs, k ↦ᵣ y }}}
     Instr Executable @ Ep
   {{{ regs' retv, RET retv;
       ⌜ LoadU_spec regs rdst rsrc offs regs' mem retv⌝ ∗
         ([∗ map] a↦pw ∈ mem, ∃ p w, ⌜pw = (p,w)⌝ ∗ a ↦ₐ[p] w) ∗
         [∗ map] k↦y ∈ regs', k ↦ᵣ y }}}.
   Proof.
     iIntros (Hinstr Hfl Hvpc HPC Dregs Hmem_pc HaLoad φ) "(>Hmem & >Hmap) Hφ".
     iApply wp_lift_atomic_head_step_no_fork; auto.
     iIntros (σ1 l1 l2 n) "[Hr Hm] /=". destruct σ1; simpl.
     iDestruct (gen_heap_valid_inclSepM with "Hr Hmap") as %Hregs.

     (* Derive necessary register values in r *)
     pose proof (lookup_weaken _ _ _ _ HPC Hregs).
     specialize (indom_regs_incl _ _ _ Dregs Hregs) as Hri. unfold regs_of in Hri.
     feed destruct (Hri rsrc) as [rsrcv [Hrsrc' Hrsrc]]. by set_solver+.
     feed destruct (Hri rdst) as [rdstv [Hrdst' _]]. by set_solver+.
     pose proof (regs_lookup_eq _ _ _ Hrsrc') as Hrsrc''.
     pose proof (regs_lookup_eq _ _ _ Hrdst') as Hrdst''.
     (* Derive the PC in memory *)
     iDestruct (gen_mem_valid_inSepM pc_a _ _ _ _ mem _ m with "Hm Hmem") as %Hma; eauto.

     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.

     option_locate_mr m r.
     rewrite /exec in Hstep. rewrite Hrrsrc in Hstep.

     destruct rsrcv as [| [[[[p g] b] e] a] ].
     { inv Hstep. iFailWP "Hφ" LoadU_fail_const. }

     destruct (isU p) eqn:HisU; cycle 1.
     { inv Hstep. iFailWP "Hφ" LoadU_fail_perm. }

     assert (Hzofargeq: z_of_argument r offs = z_of_argument regs offs).
     { rewrite /z_of_argument; destruct offs; auto.
       feed destruct (Hri r0) as [? [?]]. by set_solver+.
       rewrite H2 H3; auto. }
     rewrite Hzofargeq in Hstep.

     destruct (z_of_argument regs offs) as [zoffs|] eqn:Hoffs; cycle 1.
     { inv Hstep. iFailWP "Hφ" LoadU_fail_offs_arg. }

     destruct (verify_access (LoadU_access b e a zoffs)) as [a'|] eqn:Hverify; cycle 1.
     { inv Hstep. iFailWP "Hφ" LoadU_fail_verify_access. }
     simpl in Hstep. rewrite Hrsrc' HisU Hverify in HaLoad.
     rewrite /MemLocate in Hstep. destruct (mem !! a') as [(p', wa)|] eqn:Ha'; cycle 1.
     { inv HaLoad. }
     iDestruct (gen_mem_valid_inSepM a' _ _ _ _ mem _ m with "Hm Hmem") as %Hma'; eauto.
     rewrite Hma' in Hstep. destruct (incrementPC (<[rdst:=wa]> regs)) eqn:Hincr; cycle 1.
     { assert _ as Hincr' by (eapply (incrementPC_overflow_mono (<[rdst:=wa]> regs) (<[rdst:=wa]> r) _ _ _)).
       rewrite incrementPC_fail_updatePC in Hstep; eauto.
       inv Hstep. simpl.
       iMod ((gen_heap_update_inSepM _ _ rdst) with "Hr Hmap") as "[Hr Hmap]"; eauto.
       iFailWP "Hφ" LoadU_fail_incrementPC. }

     destruct (incrementPC_success_updatePC _ m _ Hincr) as (p1 & g1 & b1 & e1 & a1 & a_pc1 & HPC'' & Ha_pc' & HuPC & ->).
     eapply updatePC_success_incl in HuPC. 2: by eapply insert_mono.
     rewrite HuPC in Hstep; clear HuPC; inversion Hstep; clear Hstep; subst c σ2. cbn.
     iMod ((gen_heap_update_inSepM _ _ rdst) 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.
     Unshelve. all: eauto.
     { destruct (reg_eq_dec PC rdst).
       - subst rdst. rewrite lookup_insert. eauto.
       - rewrite lookup_insert_ne; eauto. }
     { eapply insert_mono; eauto. }
   Qed.

End cap_lang_rules.