From iris.algebra Require Import excl auth cmra gmap agree gset numbers.
From iris.algebra.lib Require Import frac_agree.
From iris.heap_lang Require Export notation locations lang.
From iris.base_logic.lib Require Export invariants.
From iris.program_logic Require Export atomic.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import proofmode par.
From iris.bi.lib Require Import fractional.
Set Default Proof Using "All".
Require Export multicopy multicopy_util auth_ext.

(** Multicopy operations *)

Parameter search : val.
Parameter upsert : val.

(** \overline{search} in the paper *)
Definition search' : val :=
  λ: "k",
    let: "t_id" := NewProph in
    let: "p" := NewProph in
    let: "v" := search "k" in
    resolve_proph: "p" to: "v";;
    "v".

Section multicopy_client_level.
  Context {Σ} `{heapG Σ, !multicopyG Σ}.
  Notation iProp := (iProp Σ).

  (** Low-level specs of multicopy operations *)

  Parameter search_recency: ∀ N γ_te γ_he γ_s Prot Inv_tpl k v0 t0,
    ⊢ ⌜k ∈ KS⌝ -∗
        mcs_inv N γ_te γ_he γ_s Prot Inv_tpl -∗
          SR γ_s (k, (v0, t0)) -∗
              <<< True >>>
                  search #k @ ⊤ ∖ ↑(mcsN N)
              <<< ∃ (v: V) (t: T), SR γ_s (k, (v, t)) ∗ ⌜t0 ≤ t⌝ , RET #v >>>.

  Parameter upsert_spec: ∀ N γ_te γ_he γ_s Prot Inv_tpl k (v: V),
    ⊢ ⌜k ∈ KS⌝ -∗
        (ghost_update_protocol N γ_te γ_he Prot k) -∗
          mcs_inv N γ_te γ_he γ_s Prot Inv_tpl -∗
              <<< ∀ t H, MCS γ_te γ_he t H >>>
                     upsert #k #v @ ⊤ ∖ (↑(mcsN N))
              <<< MCS γ_te γ_he (t + 1) (H ∪ {[(k, (v, t))]}), RET #() >>>.

  (** Proof of high-level specs for multicopy opeartions *)

  Lemma search_spec_intermediate N γ_te γ_he γ_s Inv_tpl γ_td γ_ght (k: K) :
  ⊢ ⌜k ∈ KS⌝ -∗
      mcs_inv N γ_te γ_he γ_s (Prot_help N γ_te γ_he γ_td γ_ght) Inv_tpl -∗
          <<< ∀ t H, MCS γ_te γ_he t H >>>
                search' #k @ ⊤ ∖ (↑(mcsN N) ∪ ↑(threadN N))
          <<<  ∃ (v': V) (t': T), MCS γ_te γ_he t H
                            ∗ ⌜map_of_set H !!! k = (v', t')⌝, RET #v' >>>.
  Proof.
    iIntros "% #HInv" (Φ) "AU". wp_lam.
    rename H0 into k_in_KS.
    wp_apply wp_new_proph1; try done.
    iIntros (tid vtid)"Htid". wp_pures.
    wp_apply (typed_proph_wp_new_proph1 IntTypedProph); first done.
    iIntros (vp p)"Hproph". wp_pures.
    iApply fupd_wp.
    iInv "HInv" as (T0 H0) "(mcs_high & Htpl)".
    iDestruct "mcs_high" as "(>MCS_auth & >HH & >HInit & >HClock & >HUniq & Prot)".
    iAssert (⌜∃ v0 t0, ((k, (v0, t0)) ∈ H0 ∧ (∀ v t, (k, (v, t)) ∈ H0 → t ≤ t0)
                ∧ map_of_set H0 !! k = Some (v0, t0))⌝)%I as "%".
    { pose proof (map_of_set_lookup_cases H0 k) as H'.
      destruct H' as [H' | H']; try done.
      iDestruct "HInit" as %HInit.
      destruct H' as [H' _].
      pose proof H' bot 0 as H'.
      pose proof HInit k k_in_KS as HInit.
      contradiction. }

    destruct H1 as [v0 [t0 [kt0_in_H [Max_t0 H_k]]]].
    iMod (own_update γ_s (● H0) (● H0 ⋅ ◯ {[(k, (v0, t0))]}) with "[$HH]") as "HH".
    { apply (auth_update_frac_alloc _ H0 ({[(k, (v0, t0))]})).
      apply gset_included. clear -kt0_in_H. set_solver. }
    iDestruct "HH" as "(HH & #SR0)".

    destruct (decide (v0 = vp)) as [v0_eq_vp | v0_neq_vp].
    - iMod "AU" as (T' H') "[MCS [_ Hcomm]]"; first by set_solver.
      iAssert (⌜T' = T0 ∧ H' = H0⌝)%I as "%".
      { iPoseProof (MCS_agree with "[$MCS_auth] [$MCS]") as "(% & %)".
        by iPureIntro. }
      destruct H1 as [H'' H''']. subst T' H'.
      assert (map_of_set H0 !!! k = (v0, t0)) as M_k.
      { rewrite lookup_total_alt. rewrite H_k.
        by simpl. }
      iSpecialize ("Hcomm" $! v0 t0).
      iMod ("Hcomm" with "[MCS]") as "HΦ".
      { iFrame. by iPureIntro. }
      iModIntro. iSplitR "HΦ Hproph".
      iNext; iExists T0, H0; iFrame.
      iModIntro.
      awp_apply search_recency without "HΦ"; try done.
      iAaccIntro with ""; try done.
      { iIntros "_". iModIntro; try eauto with iFrame. }
      iIntros (v t) "(#SR & %)". rename H1 into t0_le_t.
      iModIntro. iIntros "HΦ". wp_pures.
      wp_apply (typed_proph_wp_resolve1 IntTypedProph with "Hproph"); try done.
      wp_pures. iModIntro. iIntros "%". rename H1 into vp_eq_v.
      wp_pures. iModIntro.
      by subst v vp.
    - iDestruct "Prot" as (R hγt)"(>HR & >Hγt
                                      & >Domm_hγt & Hstar_reg)".
      iAssert (▷ (⌜tid ∉ R⌝
                ∗ ([∗ set] t_id ∈ R, Reg N γ_te γ_he γ_ght H0 t_id)
                ∗ proph1 tid vtid))%I with "[Hstar_reg Htid]"
                as "(>% & Hstar_reg & Htid)".
      { destruct (decide (tid ∈ R)); try done.
        - iEval (rewrite (big_sepS_elem_of_acc _ (R) tid);
                                last by eauto) in "Hstar_reg".
          iDestruct "Hstar_reg" as "(Hreg & Hstar_reg')".
          iDestruct "Hreg" as (? ? ? ? ? ? ? ?)"(H' & _)".
          iAssert (▷ False)%I with "[H' Htid]" as "HF".
          iApply (proph1_exclusive tid with "[Htid]"); try done.
          iNext. iExFalso; try done.
        - iFrame. iNext. by iPureIntro. }
      rename H1 into tid_notin_R.
      iMod (own_update γ_td (● R) (● (R ∪ {[tid]})) with "[$HR]") as "HR".
      { apply (auth_update_auth _ _ (R ∪ {[tid]})).
        apply gset_local_update. set_solver. }
      iMod (own_update γ_td (● (R ∪ {[tid]})) (● (R ∪ {[tid]}) ⋅ ◯ {[tid]})
                with "[$HR]") as "(HR & #FP_t)".
      { apply (auth_update_frac_alloc _ (R ∪ {[tid]}) ({[tid]})).
        apply gset_included. clear; set_solver. }

      iMod (own_alloc (to_frac_agree (1) (H0)))
              as (γ_sy)"Hfr_t". { try done. }
      iEval (rewrite <-Qp_half_half) in "Hfr_t".
      iEval (rewrite (frac_agree_op (1/2) (1/2) _)) in "Hfr_t".
      iDestruct "Hfr_t" as "(Hreg_sy1 & Hreg_sy2)".

      iDestruct "Domm_hγt" as %Domm_hγt.
      set (<[ tid := to_agree γ_sy ]> hγt) as hγt'.
      iDestruct (own_update _ _
        (● hγt' ⋅ ◯ {[ tid := to_agree γ_sy ]})
               with "Hγt") as ">Hγt".
      { apply auth_update_alloc.
        rewrite /hγt'.
        apply alloc_local_update; last done.
        rewrite <-Domm_hγt in tid_notin_R.
        by rewrite not_elem_of_dom in tid_notin_R*;
        intros tid_notin_R. }
      iDestruct "Hγt" as "(Hγt & #Hreg_gh)".

      iDestruct (laterable with "AU") as (AU_later) "[AU #AU_back]".
      iMod (own_alloc (Excl ())) as (γ_tk') "Token"; first try done.
      iAssert (⌜(∀ t', (k, (vp, t')) ∈ H0 → t' < t0)⌝)%I as %HPending.
      { iDestruct "HUniq" as %HUniq. iPureIntro.
        intros t' kvpt'_in_H. pose proof Max_t0 vp t' kvpt'_in_H as Max_t0.
        destruct (decide (t0 = t')).
        - subst t'. pose proof HUniq k t0 v0 vp kt0_in_H kvpt'_in_H as HUniq.
          done.
        - clear - Max_t0 n. lia. }
      iMod (inv_alloc (threadN N) _
              (∃ H, State γ_sy tid γ_tk' AU_later (Φ) H k vp t0)
                                    with "[AU Hreg_sy1]") as "#HthInv".
      { iNext. iExists H0. iFrame "Hreg_sy1". iLeft.
        unfold Pending. iFrame. by iPureIntro. }

      iModIntro. iSplitR "Hproph Token". iNext.
      iExists T0, H0. iFrame "Htpl". iFrame.
      iExists (R ∪ {[tid]}), hγt'. iFrame.
      iSplitR. iPureIntro. subst hγt'.
      apply leibniz_equiv. rewrite dom_insert.
      rewrite Domm_hγt. clear; set_solver.
      rewrite (big_sepS_delete _ (R ∪ {[tid]}) tid); last by set_solver.
      iSplitR "Hstar_reg". unfold Reg.
      iExists AU_later, Φ, k, vp, t0, vtid, γ_tk', γ_sy. iFrame "∗#".
      assert ((R ∪ {[tid]}) ∖ {[tid]} = R) as H'
                  by (clear -tid_notin_R; set_solver).
      by rewrite H'.

      iModIntro. awp_apply search_recency; try done.
      iAaccIntro with ""; try done.
      { iIntros "_". iModIntro; try eauto with iFrame. }
      iIntros (v t) "(#SR & %)". rename H1 into t0_le_t.
      iModIntro. wp_pures.
      wp_apply (typed_proph_wp_resolve1 IntTypedProph with "Hproph"); try done.
      wp_pures. iModIntro. iIntros "%". subst v. (* rename H1 into vp_eq_v. *)
      iApply fupd_wp.
      iInv "HthInv" as (H1)"(>Hth_sy & Hth_or)".
      iInv "HInv" as (T1 H1') "(mcs_high & Htpl)".
      iDestruct "mcs_high" as "(>MCS_auth & >HH & >Hist & >MaxTS & >Uniq & Prot)".
      iDestruct "Prot" as (R1 hγt1)"(>HR & >Hγt
                                      & >Domm_hγt & Hstar_reg)".
      iAssert (⌜tid ∈ R1⌝)%I as "%".
      { iPoseProof (own_valid_2 _ _ _ with "[$HR] [$FP_t]") as "H'".
        iDestruct "H'" as %H'.
        apply auth_both_valid_discrete in H'.
        destruct H' as [H' _].
        apply gset_included in H'.
        iPureIntro. set_solver. }

      iAssert (▷ (⌜H1' = H1⌝
               ∗ ([∗ set] t_id ∈ R1, Reg N γ_te γ_he γ_ght H1' t_id)
               ∗ own (γ_sy) (to_frac_agree (1 / 2) H1) ))%I
                with "[Hstar_reg Hth_sy]" as "(>% & Hstar_reg & >Hth_sy)".
      { iEval (rewrite (big_sepS_elem_of_acc _ (R1) tid);
                                last by eauto) in "Hstar_reg".
        iDestruct "Hstar_reg" as "(Hreg_t & Hstar_reg')".
        iDestruct "Hreg_t" as (P' Q' k' vp' t0' vtid' γ_tk'' γ_sy')
                          "(Hreg_proph & >Hreg_gh' & >Hreg_sy & Ht_reg')".

        iCombine "Hreg_gh" "Hreg_gh'" as "H".
        iPoseProof (own_valid with "H") as "Valid".
        iDestruct "Valid" as %Valid.
        rewrite auth_frag_valid in Valid *; intros Valid.
        apply singleton_valid in Valid.
        apply to_agree_op_inv in Valid.
        apply leibniz_equiv in Valid.
        subst γ_sy'.

        iAssert (⌜H1' = H1⌝)%I as "%".
        { iPoseProof (own_valid_2 _ _ _ with "[$Hth_sy] [$Hreg_sy]") as "V_H".
          iDestruct "V_H" as %V_H.
          apply frac_agree_op_valid in V_H. destruct V_H as [_ V_H].
          apply leibniz_equiv_iff in V_H.
          by iPureIntro. } subst H1'.
        iSplitR. iNext; by iPureIntro.
        iSplitR "Hth_sy". iApply "Hstar_reg'".
        iNext. iExists P', Q', k', vp', t0', vtid', γ_tk'', γ_sy.
        iFrame "∗#". by iNext. } subst H1'.
      iAssert (⌜(k, (v0, t0)) ∈ H1⌝)%I as %kv0t0_in_H1.
      { iPoseProof (own_valid_2 _ _ _ with "[$HH] [$SR0]") as "H'".
        iDestruct "H'" as %H''.
        apply auth_both_valid_discrete in H''.
        destruct H'' as [H'' _].
        apply gset_included in H''.
        iPureIntro. clear -H''; by set_solver. }
      iAssert (⌜(k, (vp, t)) ∈ H1⌝)%I as %kvpt_in_H1.
      { iPoseProof (own_valid_2 _ _ _ with "[$HH] [$SR]") as "H'".
        iDestruct "H'" as %H''.
        apply auth_both_valid_discrete in H''.
        destruct H'' as [H'' _].
        apply gset_included in H''.
        iPureIntro. clear -H''; by set_solver. }
      iAssert (⌜¬ (∀ t' : nat, (k, (vp, t')) ∈ H1 → t' < t0)⌝)%I as "%".
      { iDestruct "Uniq" as %Uniq.
        iPureIntro. intros H'.
        pose proof H' t kvpt_in_H1 as H'.
        destruct (decide (t = t0)).
        - subst t.
          pose proof Uniq k t0 vp v0 kvpt_in_H1 kv0t0_in_H1 as Uniq.
          apply v0_neq_vp. done.
        - clear -t0_le_t n H'. lia. }
      iDestruct "Hth_or" as "[Hth_or | Hth_or]".
      { iDestruct "Hth_or" as "(? & >%)".
        exfalso. try done. }
      iDestruct "Hth_or" as "(Hth_or & >%)".
      iDestruct "Hth_or" as "[Hth_or | >Hth_or]"; last first.
      { iPoseProof (own_valid_2 _ _ _ with "[$Token] [$Hth_or]") as "%".
        exfalso; try done. }

      iModIntro. iSplitR "Hth_or Hth_sy Token".
      iExists T1, H1; iFrame.
      iNext. iExists R1, hγt1; iFrame.

      iModIntro. iSplitL "Token Hth_sy".
      iNext. iExists H1. iFrame "Hth_sy".
      iRight. iFrame "∗%".

      iModIntro. wp_pures. by iModIntro.
  Qed.

  Lemma search_spec_high N γ_te γ_he γ_s Inv_tpl γ_td γ_ght (k: K) :
  ⊢ ⌜k ∈ KS⌝ -∗
      <<< ∀ M, MCS_high N γ_te γ_he γ_s Inv_tpl γ_td γ_ght M >>>
            search' #k @ ⊤ ∖ (↑(mcsN N) ∪ ↑(threadN N))
      <<<  ∃ (v: V), MCS_high N γ_te γ_he γ_s Inv_tpl γ_td γ_ght M
                        ∗ ⌜M !!! k = v⌝, RET #v >>>.
  Proof.
    iIntros "%" (Φ) "AU". rename H0 into k_in_KS.
    iApply fupd_wp.
    iMod "AU" as (M0)"[H [Hab _]]".
    iDestruct "H" as (T0 H0)"(MCS & M_eq_H & #HInv)".
    iMod ("Hab" with "[MCS M_eq_H]") as "AU".
    iExists T0, H0. iFrame "∗#". iModIntro.
    awp_apply search_spec_intermediate; try done.
    rewrite /atomic_acc /=. iMod "AU" as (M1)"[H HAU]".
    iDestruct "H" as (T1 H1)"(MCS & M_eq_H & _)".
    iModIntro. iExists T1, H1. iFrame "MCS". iSplit.
    { iIntros "MCS". iDestruct "HAU" as "[Hab _]".
      iMod ("Hab" with "[MCS M_eq_H]") as "AU".
      iExists T1, H1. iFrame "∗#". by iModIntro. }
    iIntros (vr tr)"(MCS & %)". rename H2 into H_k.
    iDestruct "M_eq_H" as %M_eq_H.
    iAssert (⌜M1 !!! k = vr⌝)%I as "M_k".
    { iPureIntro. rewrite <-M_eq_H. rewrite chop_ts_lookup_total.
      rewrite H_k. by simpl. }
    iDestruct "HAU" as "[_ Hcomm]".
    iSpecialize ("Hcomm" $! vr).
    iMod ("Hcomm" with "[MCS]") as "HΦ".
    iFrame "M_k". iExists T1, H1. iFrame "∗#%".
    by iModIntro.
  Qed.

  Lemma ghost_update_registered (k: K) (v: V) (t: T) (N: namespace)
                (γ_te γ_he γ_ght: gname)
                (H1: gset KVT) (R: gset proph_id)  :
        ⌜map_of_set (H1 ∪ {[k, (v, t)]}) !!! k = (v, t)⌝ -∗
           MCS_auth γ_te γ_he (t+1) (H1 ∪ {[(k, (v, t))]}) -∗
      ([∗ set] t_id ∈ R, Reg N γ_te γ_he γ_ght H1 t_id)
        ={⊤ ∖ ↑(mcsN N)}=∗
      ([∗ set] t_id ∈ R, Reg N γ_te γ_he γ_ght
                                      (H1 ∪ {[(k, (v, t))]}) t_id)
       ∗ MCS_auth γ_te γ_he (t+1) (H1 ∪ {[(k, (v, t))]}).
  Proof.
    iIntros "H1_k MCS_auth".
    iDestruct "H1_k" as %H1_k.
    iInduction R as [|tid R' tid_notin_R IH] "HInd" using set_ind_L;
      auto using big_sepS_empty'.
    rewrite (big_sepS_delete _ ({[tid]} ∪ R') tid); last by set_solver.
    rewrite (big_sepS_delete _ ({[tid]} ∪ R') tid); last by set_solver.
    assert (({[tid]} ∪ R') ∖ {[tid]} = R') as HR'. set_solver.
    rewrite HR'.
    iIntros "(Htid & Hbigstar)".
    iMod ("HInd" with "[$MCS_auth] Hbigstar") as "(H' & MCS_auth)".
    iFrame "H'".
    iDestruct "Htid" as (P Q k' vp t0 vtid γ_tk γ_sy)
              "(Hreg_proph & Hreg_gh & Hreg_sy & #Pau & #Hthinv)".
    iInv "Hthinv" as (H1')"Hstate".
    iDestruct "Hstate" as "(>Hth_sy & Hstate)".
    iAssert (⌜H1' = H1⌝)%I as "%".
    { iPoseProof (own_valid_2 _ _ _ with "[$Hth_sy] [$Hreg_sy]") as "V_H".
      iDestruct "V_H" as %V_H.
      apply frac_agree_op_valid in V_H. destruct V_H as [_ V_H].
      apply leibniz_equiv_iff in V_H.
      by iPureIntro. } subst H1'.

    iCombine "Hreg_sy Hth_sy" as "H'".
    iEval (rewrite <-frac_agree_op) in "H'".
    iEval (rewrite Qp_half_half) in "H'".
    iMod ((own_update (γ_sy) (to_frac_agree 1 H1)
                  (to_frac_agree 1 (H1 ∪ {[(k, (v, t))]}))) with "[$H']") as "H'".
    { apply cmra_update_exclusive.
      unfold valid, cmra_valid. simpl. unfold prod_valid_instance.
      split; simpl; try done. }
    iEval (rewrite <-Qp_half_half) in "H'".
    iEval (rewrite frac_agree_op) in "H'".
    iDestruct "H'" as "(Hreg_sy & Hth_sy)".

    iDestruct "Hstate" as "[Hpending | Hdone]".
    - iDestruct "Hpending" as "(P & >%)".
      rename H0 into HPending.
      destruct (decide (k' = k)).
      + subst k'. destruct (decide (vp = v)).
        * subst vp.
          assert (t0 ≤ t ∨ t < t0) as H'.
          { clear; lia. }
          destruct H' as [H' | H'].
          ** iDestruct ("Pau" with "P") as ">AU".
             iMod "AU" as (t' H1')"[MCS [_ Hclose]]". set_solver.
             iAssert (⌜H1' = H1 ∪ {[(k, (v, t))]}⌝)%I as "%".
             { iPoseProof (MCS_agree with "[$MCS_auth] [$MCS]") as "(% & %)".
               by iPureIntro. } subst H1'.
             iSpecialize ("Hclose" $! v t).
             iMod ("Hclose" with "[MCS]") as "HQ".
             { iFrame "%∗". }
             iModIntro. iSplitL "Hth_sy HQ".
             *** iNext. iExists (H1 ∪ {[(k, (v, t))]}).
                 iFrame. iRight. unfold Done. iSplitL.
                 iLeft. iFrame.
                 iPureIntro. exists t.
                 split. clear; set_solver. lia.
             *** iModIntro. iFrame.
                 iExists P, Q, k, v, t0, vtid, γ_tk, γ_sy.
                 iFrame "∗#".
          ** iModIntro. iSplitL "Hth_sy P".
             *** iNext. iExists (H1 ∪ {[(k, (v, t))]}).
                 iFrame. iLeft. iFrame.
                 iPureIntro. intros t'.
                 rewrite elem_of_union.
                 intros [H'' | H''].
                 by apply HPending.
                 assert (t' = t) by set_solver.
                 subst t'. done.
             *** iModIntro. iFrame.
                 iExists P, Q, k, v, t0, vtid, γ_tk, γ_sy.
                 iFrame "∗#".
        * iModIntro. iSplitL "Hth_sy P".
          ** iNext. iExists (H1 ∪ {[(k, (v, t))]}).
             iFrame. iLeft. iFrame.
             iPureIntro. intros t'.
             rewrite elem_of_union.
             intros [H'' | H''].
             by apply HPending.
             assert (vp = v) by set_solver.
             done.
          ** iModIntro. iFrame.
             iExists P, Q, k, vp, t0, vtid, γ_tk, γ_sy.
             iFrame "∗#".
      + iModIntro. iSplitL "Hth_sy P".
        * iNext. iExists (H1 ∪ {[(k, (v, t))]}).
          iFrame. iLeft. iFrame.
          iPureIntro. intros t'.
          rewrite elem_of_union.
          intros [H'' | H''].
          by apply HPending.
          assert (k' = k) by set_solver.
          done.
        * iModIntro. iFrame.
          iExists P, Q, k', vp, t0, vtid, γ_tk, γ_sy.
          iFrame "∗#".
    - iModIntro.
      iSplitR "Hreg_proph Hreg_sy Hreg_gh MCS_auth".
      iNext. iExists (H1 ∪ {[(k, (v, t))]}). iFrame.
      iRight. iDestruct "Hdone" as "(HQ & %)".
      iFrame "HQ". iPureIntro. set_solver.
      iModIntro. iFrame.
      iExists P, Q, k', vp, t0, vtid, γ_tk, γ_sy.
      iFrame "∗#".
  Qed.

  Lemma upsert_spec_high N γ_te γ_he γ_s Inv_tpl γ_td γ_ght (k: K) (v: V):
    ⊢ ⌜k ∈ KS⌝ -∗
       <<< ∀ M, MCS_high N γ_te γ_he γ_s Inv_tpl γ_td γ_ght M >>>
             upsert #k #v @ ⊤ ∖ (↑(mcsN N) ∪ ↑(threadN N))
       <<< MCS_high N γ_te γ_he γ_s Inv_tpl γ_td γ_ght (<[k := v]> M), RET #() >>>.
  Proof.
    iIntros "%" (Φ) "AU". rename H0 into k_in_KS.
    iApply fupd_wp.
    iMod "AU" as (M0)"[H [Hab _]]".
    iDestruct "H" as (T0 H0)"(MCS & M_eq_H & #HInv)".
    iMod ("Hab" with "[MCS M_eq_H]") as "AU".
    iExists T0, H0. iFrame "∗#". iModIntro.
    iAssert (ghost_update_protocol N γ_te γ_he
                (Prot_help N γ_te γ_he γ_td γ_ght) k)%I
                  as "Ghost_updP".
    { iIntros (v' T' H')"H1_k MCS_auth".
      iDestruct "H1_k" as %H1_k.
      iIntros "Prot".
      iDestruct "Prot" as (R hγt)"(HR & Hγt & Domm_hγt & Hstar_reg)".
      iMod (ghost_update_registered k v' T' with
              "[] [MCS_auth] [$Hstar_reg]")
                 as "(Hstar_reg & MCS_auth)"; try done.
      iModIntro. iFrame "MCS_auth".
      iExists R, hγt. iFrame. }
    awp_apply upsert_spec; try done.
    iApply (aacc_aupd_commit with "AU"). set_solver.
    iIntros (M1)"MCS_high".
    iDestruct "MCS_high" as (T1 H1)"(MCS & M_eq_H & _)".
    iDestruct "M_eq_H" as %M_eq_H.
    iAssert (⌜HClock T1 H1⌝)%I as %HClock.
    { by iDestruct "MCS" as "(_ & _ & % & _)". }
    iAssert (⌜HUnique H1⌝)%I as %HUniq.
    { by iDestruct "MCS" as "(_ & _ & _ & %)". }
    iAaccIntro with "MCS".
    { iIntros "MCS". iModIntro.
      iSplitL; try eauto with iFrame.
      iExists T1, H1; iFrame "∗#%". }
    iIntros "MCS".
    iModIntro. iSplitL.
    iExists (T1 + 1), (H1 ∪ {[(k, (v, T1))]}). iFrame "∗#".
    { iPureIntro. apply symmetry.
      pose proof map_of_set_insert_eq k v T1 H1 HUniq HClock as H'.
      apply symmetry in H'. rewrite H'. rewrite <-M_eq_H.
      by rewrite chop_ts_insert. }
    iIntros "HΦ"; iModIntro; try done.
  Qed.

End multicopy_client_level.


Require Import ModelProperties.
Require Import AuxiliaryLemmas.

Section closeIsSecure.

Lemma ClosePSS :
 forall (s t : SFSstate) (u : SUBJECT),
 FuncPre5 s -> SecureState s -> TransFunc u s Close t -> SecureState t.
intros s t Sub FP5 SS TF; inversion TF.
inversion H.
unfold SecureState in |- *.
BreakSS.
split.
unfold DACSecureState in |- *; intros; simpl in |- *.
elim (OBJeq_dec o o0); intro y0.
rewrite <- y0.
elim (SUBeq_dec Sub u0); intro y1.
rewrite <- y1.
cut
 match fsecmat (close_sm s Sub o) o with
 | None => True
 | Some y => ~ set_In Sub (ActReaders y) /\ ~ set_In Sub (ActWriters y)
 end.
elim (fsecmat (close_sm s Sub o) o).
intros; split; intro; tauto.

auto.

apply Close_smCorr; auto.

cut
 match fsecmat (close_sm s Sub o) o, fsecmat (secmat s) o with
 | _, None => False
 | None, Some z => True
 | Some y, Some z =>
     (set_In u0 (ActReaders y) -> set_In u0 (ActReaders z)) /\
     (set_In u0 (ActWriters y) -> set_In u0 (ActWriters z))
 end.
cut
 match fsecmat (secmat s) o with
 | None => True
 | Some y =>
     (set_In u0 (ActReaders y) -> PreDACRead s u0 o) /\
     (set_In u0 (ActWriters y) -> PreDACWrite s u0 o)
 end.
unfold close_sm at 3 4, PreDACRead, PreDACWrite in |- *; simpl in |- *;
 elim (fsecmat (secmat s) o); elim (fsecmat (close_sm s Sub o) o).
intros.
elim H6; elim H5; intros.
split; intro.
apply H7; apply H9; auto.

apply H8; apply H10; auto.

auto.

tauto.

auto.

unfold DACSecureState in DAC; apply DAC.

apply Close_smCorr2; auto.

replace (fsecmat (close_sm s Sub o) o0) with (fsecmat (secmat s) o0).
unfold close_sm, PreDACRead, PreDACWrite in |- *; simpl in |- *;
 unfold DACSecureState, PreDACRead, PreDACWrite in DAC;
 apply DAC.

auto.

unfold MACSecureState in |- *; intros; simpl in |- *.
elim (OBJeq_dec o o0); intro y0.
rewrite <- y0.
cut
 match fsecmat (close_sm s Sub o) o, fsecmat (secmat s) o with
 | _, None => False
 | None, Some z => True
 | Some y, Some z =>
     (set_In u0 (ActReaders y) -> set_In u0 (ActReaders z)) /\
     (set_In u0 (ActWriters y) -> set_In u0 (ActWriters z))
 end.
cut
 match fsecmat (secmat s) o, fOSC (objectSC s) o, fSSC (subjectSC s) u0 with
 | None, _, _ => True
 | _, None, _ => True
 | _, _, None => True
 | Some x, Some y, Some z =>
     set_In u0 (ActReaders x) \/ set_In u0 (ActWriters x) -> le_sc y z
 end.
elim (fsecmat (secmat s) o); elim (fsecmat (close_sm s Sub o) o);
 elim (fOSC (objectSC s) o); elim (fSSC (subjectSC s) u0);
 contradiction || trivial.
tauto.

unfold MACSecureState in MAC; apply MAC.

apply Close_smCorr2; auto.

replace (fsecmat (close_sm s Sub o) o0) with (fsecmat (secmat s) o0).
unfold MACSecureState in MAC; apply MAC.

auto.

Qed.

Lemma ClosePSP :
 forall (s t : SFSstate) (u : SUBJECT),
 FuncPre5 s -> StarProperty s -> TransFunc u s Close t -> StarProperty t.
intros s t Sub FP5 SP TF; inversion TF.
inversion H.
unfold StarProperty in |- *; simpl in |- *; intros.
cut
 match
   fsecmat (secmat s) o1, fsecmat (secmat s) o2, fOSC (objectSC s) o2,
   fOSC (objectSC s) o1
 with
 | None, _, _, _ => True
 | _, None, _, _ => True
 | _, _, None, _ => True
 | _, _, _, None => True
 | Some w, Some x, Some y, Some z =>
     set_In u0 (ActWriters w) -> set_In u0 (ActReaders x) -> le_sc y z
 end.
cut
 match fsecmat (close_sm s Sub o) o, fsecmat (secmat s) o with
 | _, None => False
 | None, Some z => True
 | Some y, Some z =>
     (set_In u0 (ActReaders y) -> set_In u0 (ActReaders z)) /\
     (set_In u0 (ActWriters y) -> set_In u0 (ActWriters z))
 end.
elim (OBJeq_dec o o1); elim (OBJeq_dec o o2); intros EQ2 EQ1.
rewrite <- EQ1; rewrite <- EQ2.
elim (fsecmat (secmat s) o); elim (fOSC (objectSC s) o);
 elim (fsecmat (close_sm s Sub o) o); intros; auto.

replace (fsecmat (close_sm s Sub o) o2) with (fsecmat (secmat s) o2).
rewrite <- EQ1.
elim (fsecmat (secmat s) o2); elim (fOSC (objectSC s) o);
 elim (fOSC (objectSC s) o2); elim (fsecmat (secmat s) o);
 elim (fsecmat (close_sm s Sub o) o); intros; contradiction || auto.
tauto.

auto.

replace (fsecmat (close_sm s Sub o) o1) with (fsecmat (secmat s) o1).
rewrite <- EQ2.
elim (fsecmat (secmat s) o1); elim (fOSC (objectSC s) o);
 elim (fOSC (objectSC s) o1); elim (fsecmat (secmat s) o);
 elim (fsecmat (close_sm s Sub o) o); intros; contradiction || auto.
tauto.

auto.

replace (fsecmat (close_sm s Sub o) o2) with (fsecmat (secmat s) o2).
replace (fsecmat (close_sm s Sub o) o1) with (fsecmat (secmat s) o1).
auto.

auto.

auto.

apply Close_smCorr2; auto.

unfold StarProperty in SP; apply SP.

Qed.

Lemma ClosePCP : forall s t : SFSstate, PreservesControlProp s Close t.
intros; unfold PreservesControlProp in |- *; intros Sub TF; inversion TF;
 unfold ControlProperty in |- *.
inversion H.
split.
intros.
split.
intros;
 absurd
  (DACCtrlAttrHaveChanged s
     (mkSFS (groups s) (primaryGrp s) (subjectSC s)
        (AllGrp s) (RootGrp s) (SecAdmGrp s) (objectSC s)
        (acl s) (close_sm s Sub o) (files s) (directories s)) o0);
 auto.

intros;
 absurd
  (MACObjCtrlAttrHaveChanged s
     (mkSFS (groups s) (primaryGrp s) (subjectSC s)
        (AllGrp s) (RootGrp s) (SecAdmGrp s) (objectSC s)
        (acl s) (close_sm s Sub o) (files s) (directories s)) o0);
 auto.

intros;
 absurd
  (MACSubCtrlAttrHaveChanged s
     (mkSFS (groups s) (primaryGrp s) (subjectSC s)
        (AllGrp s) (RootGrp s) (SecAdmGrp s) (objectSC s)
        (acl s) (close_sm s Sub o) (files s) (directories s)) u0);
 auto.

Qed.

End closeIsSecure.

Hint Resolve ClosePSS ClosePSP ClosePCP.


(** * LogRel.LogicalRelation.ShapeView: relating reducibility witnesses of reducibly convertible types.*)
From LogRel.AutoSubst Require Import core unscoped Ast Extra.
From LogRel Require Import Utils BasicAst Context Notations NormalForms UntypedReduction GenericTyping LogicalRelation DeclarativeInstance.
From LogRel.LogicalRelation Require Import Induction Reflexivity.

Set Universe Polymorphism.

Section ShapeViews.
  Context `{GenericTypingProperties}.

(** ** Definition *)

(** A shape view is inhabited exactly on the diagonal, ie when the two types are reducible
  in the same way. *)

  Definition ShapeView@{i j k l i' j' k' l'} Γ
    A {lA eqTyA redTmA redTyA} B {lB eqTyB redTmB redTyB}
    (lrA : LogRel@{i j k l} lA Γ A eqTyA redTmA redTyA) (lrB : LogRel@{i' j' k' l'} lB Γ B eqTyB redTmB redTyB) : Set :=
    match lrA, lrB with
      | LRU _ _, LRU _ _ => True
      | LRne _ _, LRne _ _ => True
      | LRPi _ _ _, LRPi _ _ _ => True
      | LRNat _ _, LRNat _ _ => True
      | LREmpty _ _, LREmpty _ _ => True
      | _, _ => False
    end.

  Arguments ShapeView Γ A {lA eqTyA redTmA redTyA} B {lB eqTyB redTmB redTyB}
  !lrA !lrB.

(** ** The main property *)

(** We show that two reducibly convertible types must have the same shape view. Said otherwise,
if two reducible types are reducibly convertible, then they must be reducible in the same way.
This lets us relate different reducibility proofs when we have multiple such proofs, typically
when showing symmetry or transitivity of the logical relation. *)

  Arguments ShapeView Γ A {lA eqTyA redTmA redTyA} B {lB eqTyB redTmB redTyB}
  !lrA !lrB.

  Lemma red_whnf@{i j k l} {Γ A lA eqTyA redTmA eqTmA}
    (lrA : LogRel@{i j k l} lA Γ A eqTyA redTmA eqTmA) :
    ∑ nf, [Γ |- A :⇒*: nf] × whnf nf.
  Proof.
    destruct lrA as [?? []| ??[] | ??[]| ??[] | ??[]]; eexists; split; tea; constructor; tea.
    now eapply ty_ne_whne.
  Defined.

  Lemma eqTy_red_whnf@{i j k l} {Γ A lA eqTyA redTmA eqTmA B}
    (lrA : LogRel@{i j k l} lA Γ A eqTyA redTmA eqTmA) :
    eqTyA B -> ∑ nf, [Γ |- B :⇒*: nf] × whnf nf.
  Proof.
    destruct lrA as [?? []| ??[] | ??[]| ??[] | ??[]] ; intros []; eexists; split; tea; constructor; tea.
    now eapply ty_ne_whne.
  Defined.

  Lemma ShapeViewConv@{i j k l i' j' k' l'} {Γ A lA eqTyA redTmA eqTmA B lB eqTyB redTmB eqTmB}
    (lrA : LogRel@{i j k l} lA Γ A eqTyA redTmA eqTmA) (lrB : LogRel@{i' j' k' l'} lB Γ B eqTyB redTmB eqTmB) :
    eqTyA B ->
    ShapeView@{i j k l i' j' k' l'} Γ A B lrA lrB.
  Proof.
    intros eqAB.
    pose (x := eqTy_red_whnf lrA eqAB).
    pose (y:= red_whnf lrB).
    pose proof (h := redtywf_det _ _ _ _ (snd x.π2) (snd y.π2) (fst x.π2) (fst y.π2)).
    revert eqAB x y h.
    destruct lrA; destruct lrB; intros []; cbn; try easy; try discriminate.
    all: try now (intros e; rewrite e in ne; apply ty_ne_whne in ne; inversion ne).
    all: try now (intros e; destruct neA as [? ? ne]; rewrite <- e in ne; apply ty_ne_whne in ne; inversion ne).
  Qed.

(** ** More properties *)

  Corollary ShapeViewRefl@{i j k l i' j' k' l'} {Γ A lA eqTyA redTmA eqTmA lA' eqTyA' redTmA' eqTmA'}
    (lrA : LogRel@{i j k l} lA Γ A eqTyA redTmA eqTmA) (lrA' : LogRel@{i' j' k' l'} lA' Γ A eqTyA' redTmA' eqTmA') :
    ShapeView@{i j k l i' j' k' l'} Γ A A lrA lrA'.
  Proof.
    now eapply ShapeViewConv, LRTyEqRefl.
  Qed.

  Definition ShapeView3 Γ
    A {lA eqTyA redTmA redTyA}
    B {lB eqTyB redTmB redTyB}
    C {lC eqTyC redTmC redTyC}
    (lrA : LogRel lA Γ A eqTyA redTmA redTyA)
    (lrB : LogRel lB Γ B eqTyB redTmB redTyB)
    (lrC : LogRel lC Γ C eqTyC redTmC redTyC)
    : Set :=
    match lrA, lrB, lrC with
      | LRU _ _, LRU _ _, LRU _ _ => True
      | LRne _ _, LRne _ _, LRne _ _ => True
      | LRPi _ _ _, LRPi _ _ _, LRPi _ _ _ => True
      | LRNat _ _, LRNat _ _, LRNat _ _ => True
      | LREmpty _ _, LREmpty _ _, LREmpty _ _ => True
      | _, _, _ => False
    end.

  Arguments ShapeView3 Γ A {lA eqTyA redTmA redTyA} B {lB eqTyB redTmB redTyB} C {lC eqTyC redTmC redTyC}
  !lrA !lrB !lrC.

  Lemma combine Γ
    A {lA eqTyA redTmA redTyA}
    B {lB eqTyB redTmB redTyB}
    C {lC eqTyC redTmC redTyC}
    (lrA : LogRel lA Γ A eqTyA redTmA redTyA)
    (lrB : LogRel lB Γ B eqTyB redTmB redTyB)
    (lrC : LogRel lC Γ C eqTyC redTmC redTyC) :
    ShapeView Γ A B lrA lrB -> ShapeView Γ B C lrB lrC -> ShapeView3 Γ A B C lrA lrB lrC.
  Proof.  destruct lrA, lrB, lrC; easy. Qed.

End ShapeViews.


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

(** This file provide the flat memory model (the high memory [from 1G to 3G]) definition and its operations.*)

Require Import Coqlib.
Require Import Maps.
Require Import Integers.
Require Export Memdata.
Require Import AST.
Require Import Values.
Require Import AuxStateDataType.
Require Import Constant.

(* To avoid useless definitions of inductors in extracted code. *)
Local Unset Elimination Schemes.
Local Unset Case Analysis Schemes.

Local Notation "a # b" := (ZMap.get b a) (at level 1).

Module FlatMem.

  (** * Flatmem definition and operations*)
  Inductive flatmem_val :=
  | HUndef
  | HByte: byte -> flatmem_val.

  Definition flatmem := ZMap.t flatmem_val.

  (** empty flatmem*)
  Definition empty_flatmem : flatmem := ZMap.init HUndef.

  (** ** Memory reads. *)
  (** Convert the flatmem_val to mem_val*)
  Definition FlatMem2MemVal (hv: flatmem_val): memval :=
    match hv with
      | HUndef => Undef
      | HByte b => Byte b
    end.

  (** Reading N adjacent bytes in the flatmem start from address [p]. *)
  Fixpoint getN (n: nat) (p: Z) (c: flatmem) {struct n}: list memval :=
    match n with
      | O => nil
      | S n' => (FlatMem2MemVal c#p) :: getN n' (p + 1) c
    end.

  (** [load chunk h addr] perform a read in flatmem state [h], at address
  [addr].  It returns the value of the memory chunk
  at that address. [None] is returned if the accessed bytes
  are not readable. *)
  Definition load (chunk: memory_chunk) (h: flatmem) (addr: Z): val :=
    (decode_val chunk (getN (size_chunk_nat chunk) addr h)).

  (** [loadv chunk h addr] is similar, but the address [addr] must be a pure address (int value). *)
  Definition loadv (chunk: memory_chunk) (h: flatmem) (addr: val) : option val :=
    match addr with
      | Vint n => Some (load chunk h (Int.unsigned n))
      | _ => None
    end.

  (** [loadbytes h addr n] reads [n] consecutive bytes starting at
  location [addr].  Returns [None] if the accessed locations are
  not readable. *)
  Definition loadbytes (h: flatmem) (addr n: Z): (list memval) :=
    (getN (nat_of_Z n) addr h).

  (** ** Memory stores. *)
  (** Convert the mem_val to flatmem_val*)
  Definition Mem2FlatMemVal (mv: memval): flatmem_val :=
    match mv with
      | Byte b => (HByte b)
      | _ => HUndef
    end.

  (** Writing N adjacent bytes in the flatmem start from address [p]. *)
  Fixpoint setN (vl: list memval) (p: Z) (c: flatmem) {struct vl}: flatmem :=
    match vl with
      | nil => c
      | v :: vl' => setN vl' (p + 1) (ZMap.set p (Mem2FlatMemVal v) c)
    end.

  (** [store chunk h addr v] perform a write in flatmem state [h].
  Value [v] is stored at address [addr].
  Return the updated memory store, or [None] if the accessed bytes
  are not writable. *)
  Definition store (chunk: memory_chunk) (h: flatmem) (addr: Z) (v: val): flatmem :=
    setN (encode_val chunk v) addr h.

  (** [storev chunk h addr v] is similar, but the address [addr] must be a pure address (int vaule). *)
  Definition storev (chunk: memory_chunk) (h: flatmem) (addr v: val) : option flatmem :=
    match addr with
      | Vint n => Some (store chunk h (Int.unsigned n) v)
      | _ => None
    end.

  (** [storebytes h addr bytes] stores the given list of bytes [bytes]
  starting at location [addr].  Returns updated memory state
  or [None] if the accessed locations are not writable. *)
  Definition storebytes (h: flatmem) (addr: Z) (bytes: list memval) : flatmem :=
    (setN bytes addr h).

  (** ** Properties related to [load] *)
  Lemma load_result:
    forall chunk h addr v,
      load chunk h addr = v ->
      v = decode_val chunk (getN (size_chunk_nat chunk) addr h).
  Proof.
    intros until v. unfold load.
    intros.
    congruence.
  Qed.

  Theorem load_type:
    forall h chunk addr v,
      load chunk h addr = v ->
      Val.has_type v (type_of_chunk chunk).
  Proof.
    intros. exploit load_result; eauto; intros. rewrite H0.
    apply decode_val_type.
  Qed.

  Theorem load_cast:
    forall h chunk addr v,
      load chunk h addr = v ->
      match chunk with
        | Mint8signed => v = Val.sign_ext 8 v
        | Mint8unsigned => v = Val.zero_ext 8 v
        | Mint16signed => v = Val.sign_ext 16 v
        | Mint16unsigned => v = Val.zero_ext 16 v
        | Mfloat32 => v = Val.singleoffloat v
        | _ => True
      end.
  Proof.
    intros. exploit load_result; eauto.
    set (l := getN (size_chunk_nat chunk) addr h).
    intros. subst v. apply decode_val_cast.
  Qed.

  Theorem load_int8_signed_unsigned:
    forall h addr,
      load Mint8signed h addr = (Val.sign_ext 8) (load Mint8unsigned h addr).
  Proof.
    intros. unfold load.
    change (size_chunk_nat Mint8signed) with (size_chunk_nat Mint8unsigned).
    set (cl := getN (size_chunk_nat Mint8unsigned) addr h).
    unfold decode_val.
    destruct (proj_bytes cl); auto.
    simpl. decEq.
    rewrite Int.sign_ext_zero_ext.
    trivial.
    omega.
  Qed.

  Theorem load_int16_signed_unsigned:
    forall m ofs,
      load Mint16signed m ofs = (Val.sign_ext 16) (load Mint16unsigned m ofs).
  Proof.
    intros. unfold load.
    change (size_chunk_nat Mint16signed) with (size_chunk_nat Mint16unsigned).
    set (cl := getN (size_chunk_nat Mint16unsigned) ofs m).
    unfold decode_val.
    destruct (proj_bytes cl); auto.
    simpl. decEq.  rewrite Int.sign_ext_zero_ext. auto.
    omega.
  Qed.

(*
  Theorem load_float64al32:
    forall m ofs v,
      load Mfloat64 m ofs = v -> load Mfloat64al32 m ofs = v.
  Proof.
    unfold load; intros.
    unfold decode_val in *.
    change  (size_chunk_nat Mfloat64al32) with (size_chunk_nat Mfloat64).
    set (cl:= (getN (size_chunk_nat Mfloat64) ofs m)) in *.
    destruct (proj_bytes cl); auto.
  Qed.

  Theorem loadv_float64al32:
    forall m a v,
      loadv Mfloat64 m a = Some v -> loadv Mfloat64al32 m a = Some v.
  Proof.
    unfold loadv; intros. destruct a; auto.
  Qed.
*)

  (** ** Properties related to [loadbytes] *)
  Theorem loadbytes_load:
    forall chunk m  ofs bytes,
      loadbytes m ofs (size_chunk chunk) = bytes ->
      (align_chunk chunk | ofs) ->
      load chunk m ofs = (decode_val chunk bytes).
  Proof.
    unfold loadbytes, load; intros.
    auto.

    unfold size_chunk.
    unfold size_chunk_nat.
    rewrite H.
    trivial.
  Qed.

  Theorem load_loadbytes:
    forall chunk m ofs v,
      load chunk m ofs = v ->
      exists bytes, loadbytes m ofs (size_chunk chunk) = bytes
                    /\ v = decode_val chunk bytes.
  Proof.
    intros.
    unfold load in H.
    exists (getN (size_chunk_nat chunk) ofs m); split.
    unfold loadbytes.
    unfold size_chunk_nat.
    trivial.
    auto.
  Qed.

  Lemma getN_length:
    forall c n p, length (getN n p c) = n.
  Proof.
    induction n; simpl; intros. auto. decEq; auto.
  Qed.

  Theorem loadbytes_length:
    forall m ofs n bytes,
      loadbytes m ofs n = bytes ->
      length bytes = nat_of_Z n.
  Proof.
    unfold loadbytes; intros.
    inv H.
    apply getN_length.
  Qed.

  Theorem loadbytes_empty:
    forall m ofs n,
      n <= 0 -> loadbytes m ofs n = nil.
  Proof.
    intros. unfold loadbytes.  rewrite nat_of_Z_neg; auto.
  Qed.

  Lemma getN_emptymem:
    forall n ofs,
      getN n ofs empty_flatmem = list_repeat n Undef.
  Proof.
    induction n; intros; simpl.
    - reflexivity.
    - decEq.
      + unfold empty_flatmem.
        rewrite ZMap.gi. reflexivity.
      + eauto.
  Qed.

  Lemma loadbytes_emptymem:
    forall ofs len,
      loadbytes empty_flatmem ofs len = (list_repeat (nat_of_Z len) Undef).
  Proof.
    intros.
    unfold loadbytes.
    eapply getN_emptymem.
  Qed.

  Lemma getN_concat:
    forall c n1 n2 p,
      getN (n1 + n2)%nat p c = getN n1 p c ++ getN n2 (p + Z_of_nat n1) c.
  Proof.
    induction n1; intros.
    simpl. decEq. omega.
    rewrite inj_S. simpl. decEq.
    replace (p + Zsucc (Z_of_nat n1)) with ((p + 1) + Z_of_nat n1) by omega.
    auto.
  Qed.

  Theorem loadbytes_concat:
    forall m ofs n1 n2 bytes1 bytes2,
      loadbytes m ofs n1 = bytes1 ->
      loadbytes m (ofs + n1) n2 = bytes2 ->
      n1 >= 0 -> n2 >= 0 ->
      loadbytes m ofs (n1 + n2) = (bytes1 ++ bytes2).
  Proof.
    unfold loadbytes; intros.
    inv H.
    rewrite Z2Nat.inj_add; try omega.
    rewrite getN_concat. rewrite nat_of_Z_eq; auto.
  Qed.

  Theorem loadbytes_split:
    forall m ofs n1 n2 bytes,
      loadbytes m ofs (n1 + n2) = bytes ->
      n1 >= 0 -> n2 >= 0 ->
      exists bytes1, exists bytes2,
                       loadbytes m ofs n1 = bytes1
                       /\ loadbytes m (ofs + n1) n2 = bytes2
                       /\ bytes = bytes1 ++ bytes2.
  Proof.
    unfold loadbytes; intros.
    rewrite nat_of_Z_plus in H; auto. rewrite getN_concat in H.
    rewrite nat_of_Z_eq in H; auto.
    econstructor; econstructor.
    split. reflexivity. split. reflexivity. congruence.
  Qed.

  Theorem load_rep:
    forall ch m1 m2 ofs v1 v2,
      (forall z, 0 <= z < size_chunk ch -> m1#(ofs+z) = m2#(ofs+z)) ->
      load ch m1 ofs = v1 ->
      load ch m2 ofs = v2 ->
      v1 = v2.
  Proof.
    intros.
    apply load_result in H0.
    apply load_result in H1.
    subst.
    f_equal.
    rewrite size_chunk_conv in H.
    remember (size_chunk_nat ch) as n; clear Heqn.
    revert ofs H; induction n; intros; simpl; auto.
    f_equal.
    rewrite inj_S in H.
    replace ofs with (ofs+0) by omega.
    rewrite  H; try omega.
    trivial.
    apply IHn.
    intros.
    rewrite <- Zplus_assoc.
    apply H.
    rewrite inj_S. omega.
  Qed.

  Theorem load_rep':
    forall ch m1 m2 ofs1 ofs2 v1 v2,
      (forall z, 0 <= z < size_chunk ch -> m1#(ofs1+z) = m2#(ofs2+z)) ->
      load ch m1 ofs1 = v1 ->
      load ch m2 ofs2 = v2 ->
      v1 = v2.
  Proof.
    intros.
    apply load_result in H0.
    apply load_result in H1.
    subst.
    f_equal.
    rewrite size_chunk_conv in H.
    remember (size_chunk_nat ch) as n; clear Heqn.
    revert ofs1 ofs2 H; induction n; intros; simpl; auto.
    f_equal.
    rewrite inj_S in H.
    replace ofs1 with (ofs1+0) by omega.
    replace ofs2 with (ofs2+0) by omega.
    rewrite H; try omega.
    trivial.
    apply IHn.
    intros.
    repeat rewrite <- Zplus_assoc.
    apply H.
    rewrite inj_S. omega.
  Qed.

  Lemma proj_pointer_undef:
    forall n addr h,
      proj_pointer (getN n addr h) = Vundef.
  Proof.
    intros.
    unfold proj_pointer.
    destruct n.
    simpl.
    trivial.

    unfold getN.
    unfold FlatMem2MemVal.
    destruct (ZMap.get addr h); trivial.
  Qed.

  Lemma load_valid:
    forall h t addr b ofs,
      (load t h addr) = Vptr b ofs
      -> False.
  Proof.
    intros.
    unfold load in H.
    unfold decode_val in H.
    rewrite proj_pointer_undef in H.
    destruct (proj_bytes (getN (size_chunk_nat t) addr h)).
    destruct t; inv H.
    destruct t; inv H.
  Qed.

  Lemma load_inject:
    forall j chunk h l,
      val_inject j (load chunk h l) (load chunk h l).
  Proof.
    intros.
    destruct (load chunk h l) as [] eqn:VAL; auto.
    exfalso; eapply load_valid; eauto.
  Qed.

  Remark setN_other:
    forall vl c p q,
      (forall r, p <= r < p + Z_of_nat (length vl) -> r <> q) ->
      ZMap.get q (setN vl p c) = ZMap.get q c.
  Proof.
    induction vl; intros; simpl.
    auto.
    simpl length in H. rewrite inj_S in H.
    transitivity (ZMap.get q (ZMap.set p (Mem2FlatMemVal a) c)).
    apply IHvl. intros. apply H. omega.
    apply ZMap.gso. apply not_eq_sym. apply H. omega.
  Qed.

  Remark setN_outside:
    forall vl c p q,
      q < p \/ q >= p + Z_of_nat (length vl) ->
      ZMap.get q (setN vl p c) = ZMap.get q c.
  Proof.
    intros. apply setN_other.
    intros. omega.
  Qed.

  (*Remark FlatMem_correct:
    forall a,
      FlatMem2MemVal (Mem2FlatMemVal a) = a.
  Proof.
    unfold FlatMem2MemVal, Mem2FlatMemVal.
    destruct a.*)

  Lemma getN_setN_list_undef:
    forall n p c,
      getN (length (list_repeat n Undef)) p
           (setN (list_repeat n Undef) p c) =
      list_repeat (length (list_repeat n Undef)) Undef.
  Proof.
    induction n.
    - simpl. reflexivity.
    - simpl. intros.
      decEq.
      + rewrite setN_outside.
        * rewrite ZMap.gss. reflexivity.
        * left. omega.
      + apply IHn.
  Qed.

  Lemma getN_setN_list_bytes:
    forall vl p c,
      getN (length (inj_bytes vl)) p
      (setN (inj_bytes vl) p c) = inj_bytes vl.
  Proof.
    induction vl.
    - simpl. reflexivity.
    - simpl. intros.
      decEq.
      + rewrite setN_outside.
        * rewrite ZMap.gss. reflexivity.
        * left. omega.
      + apply IHvl.
  Qed.

  Lemma getN_setN_list_pointer:
    forall n b i p c,
      getN (length (inj_pointer n b i)) p (setN (inj_pointer n b i) p c) =
      list_repeat (length (inj_pointer n b i)) Undef.
  Proof.
    induction n.
    - simpl. reflexivity.
    - simpl. intros.
      decEq.
      + rewrite setN_outside.
        * rewrite ZMap.gss. reflexivity.
        * left. omega.
      + apply IHn.
  Qed.

  Remark getN_setN_same:
    forall v p c chunk,
      getN (length (encode_val chunk v)) p (setN (encode_val chunk v) p c) = (encode_val chunk v) \/
      getN (length (encode_val chunk v)) p (setN (encode_val chunk v) p c) = list_repeat (length (encode_val chunk v)) Undef.
  Proof.
    Opaque list_repeat inj_pointer inj_bytes.
    destruct chunk; destruct v; simpl;
    try (right; apply getN_setN_list_undef);
    try (left; apply getN_setN_list_bytes).
    right. apply getN_setN_list_pointer.
  Qed.

  (*Remark getN_setN_disjoint:
    forall vl q c n p,
      Intv.disjoint (p, p + Z_of_nat n) (q, q + Z_of_nat (length vl)) ->
      getN n p (setN vl q c) = getN n p c.
  Proof.
    intros. apply getN_exten. intros. apply setN_other.
    intros; red; intros; subst r. eelim H; eauto.
  Qed.*)

  Remark getN_exten:
    forall c1 c2 n p,
      (forall i, p <= i < p + Z_of_nat n -> ZMap.get i c1 = ZMap.get i c2) ->
      getN n p c1 = getN n p c2.
  Proof.
    induction n; intros.
    - auto.
    - rewrite inj_S in H. simpl. decEq.
      + assert (HW: c1 # p = c2 # p).
        {
          apply H. omega.
        }
        rewrite HW. reflexivity.
      + apply IHn. intros. apply H. omega.
  Qed.

  Remark getN_setN_outside:
    forall vl q c n p,
      p + Z_of_nat n <= q \/ q + Z_of_nat (length vl) <= p ->
      getN n p (setN vl q c) = getN n p c.
  Proof.
    intros. apply getN_exten.
    intros. apply setN_other.
    red; intros; subst.
    eelim H; intros; omega.
  Qed.

  Remark getN_setN_same_int:
    forall v p c chunk,
      getN (length (encode_val chunk (Vint v))) p (setN (encode_val chunk (Vint v)) p c) =
      (encode_val chunk (Vint v)).
  Proof.
    Opaque list_repeat inj_pointer inj_bytes.
    destruct chunk; simpl;
    try (apply getN_setN_list_bytes);
    try (apply getN_setN_list_undef).
  Qed.

  (** ** Properties related to [store] *)
  Section STORE.

    Variable chunk: memory_chunk.
    Variable m1: flatmem.
    Variable ofs: Z.
    Variable v: val.
    Variable m2: flatmem.
    Hypothesis STORE: store chunk m1 ofs v = m2.

    Lemma store_flatmem_contents:
      m2 = (setN (encode_val chunk v) ofs m1).
    Proof.
      unfold store in STORE.
      auto.
    Qed.

    Lemma loadbytes_store_same:
      loadbytes m2 ofs (size_chunk chunk) = encode_val chunk v
      \/ loadbytes m2 ofs (size_chunk chunk) = list_repeat (length (encode_val chunk v)) Undef.
    Proof.
      intros.
      unfold loadbytes. rewrite store_flatmem_contents; simpl.
      replace (nat_of_Z (size_chunk chunk)) with (length (encode_val chunk v)).
      - eapply getN_setN_same.
      - rewrite encode_val_length. auto.
    Qed.

    Lemma loadbytes_store_other:
      forall ofs' n,
        n <= 0 \/ ofs' + n <= ofs \/ ofs + size_chunk chunk <= ofs' ->
        loadbytes m2 ofs' n = loadbytes m1 ofs' n.
    Proof.
      intros. unfold loadbytes.
      rewrite store_flatmem_contents; simpl.
      destruct (zle n 0).
      - rewrite (nat_of_Z_neg _ l). auto.
      - destruct H.
        + omega.
        + apply getN_setN_outside. rewrite encode_val_length.
          rewrite <- size_chunk_conv.
          rewrite nat_of_Z_eq. assumption.
          omega.
    Qed.

    Lemma load_store_same:
      forall h ofs i,
        load Mint32 (store Mint32 h ofs (Vint i)) ofs = Vint i.
    Proof.
      intros. unfold load, store.
      replace (size_chunk_nat Mint32) with (length (encode_val Mint32 (Vint i))).
      - rewrite getN_setN_same_int.
        specialize (decode_encode_val_general (Vint i) Mint32 Mint32).
        simpl. trivial.
      - rewrite encode_val_length. reflexivity.
    Qed.

    Lemma load_store_other:
      forall chunk m1 m2 ofs v chunk' ofs',
        store chunk m1 ofs v = m2 ->
        ofs' + (size_chunk chunk') <= ofs \/ ofs + size_chunk chunk <= ofs' ->
        load chunk' m2 ofs' = load chunk' m1 ofs'.
    Proof.
      unfold load, store. intros. rewrite <- H.
      rewrite getN_setN_outside. reflexivity.
      rewrite encode_val_length. repeat rewrite <- size_chunk_conv.
      assumption.
    Qed.

  End STORE.

  (** * Flatmem injection *)
  Inductive flatmem_val_inject  : flatmem_val -> flatmem_val -> Prop :=
    flatmemval_inject_byte : forall n : byte, flatmem_val_inject (HByte n) (HByte n)
  | flatmemval_inject_undef : forall mv : flatmem_val, flatmem_val_inject HUndef mv.

  Definition flatmem_inj (h1 h2: flatmem) :=
    forall addr, flatmem_val_inject h1#addr h2#addr.

  (*Definition flatmem_pperm_inj (p: PPermT) (h1 h2: flatmem) :=
    forall addr,
      (forall o, ZMap.get (PageI addr) p <> PGHide o) ->
      FlatMem.flatmem_val_inject h1#addr h2#addr.*)

  Lemma getN_inj:
    forall f m1 m2,
      flatmem_inj m1 m2 ->
      forall n ofs,
        list_forall2 (memval_inject f)
                     (getN n ofs m1)
                     (getN n ofs m2).
  Proof.
    induction n; intros; simpl.
    constructor.
    constructor.
    unfold flatmem_inj in H.
    specialize (H ofs).
    destruct (m1 # ofs).
    constructor.
    inv H.
    constructor.
    specialize (IHn (ofs +1)).
    trivial.
  Qed.

  (*Lemma getN_pperm_inj:
    forall f m1 m2 p,
      flatmem_pperm_inj p m1 m2 ->
      forall n ofs,
        (forall ofs',
           ofs <= ofs' < ofs + (Z_of_nat n) ->
           forall o,
             ZMap.get (PageI ofs') p <> PGHide o) ->
        list_forall2 (memval_inject f)
                     (getN n ofs m1)
                     (getN n ofs m2).
  Proof.
    induction n; intros; simpl.
    - constructor.
    - constructor.
      + unfold flatmem_pperm_inj in H.
        assert (HOS: ofs <= ofs < ofs + Z.of_nat (S n)).
        {
          rewrite Nat2Z.inj_succ. omega.
        }
        specialize (H0 _ HOS).
        specialize (H _ H0).
        destruct (m1 # ofs).
        * constructor.
        * inv H. constructor.
      + eapply IHn. intros. eapply H0.
        rewrite Nat2Z.inj_succ. omega.
  Qed.*)

  Lemma load_inj:
    forall m1 m2 chunk ofs v1 f,
      flatmem_inj  m1 m2 ->
      load chunk m1 ofs = v1 ->
      exists v2, load chunk m2 ofs = v2 /\ val_inject f v1 v2.
  Proof.
    intros.
    unfold load in *.
    exists (decode_val chunk (getN (size_chunk_nat chunk) ofs m2)).
    split; trivial.
    rewrite <- H0.
    apply decode_val_inject. apply getN_inj; auto.
  Qed.

  (*Lemma load_pperm_inj:
    forall m1 m2 chunk ofs v1 f p,
      flatmem_pperm_inj p m1 m2 ->
      load chunk m1 ofs = v1 ->
      (forall ofs',
         ofs <= ofs' < ofs + (size_chunk chunk) ->
         forall o,
           ZMap.get (PageI ofs') p <> PGHide o) ->
      exists v2, load chunk m2 ofs = v2 /\ val_inject f v1 v2.
  Proof.
    intros.
    unfold load in *.
    exists (decode_val chunk (getN (size_chunk_nat chunk) ofs m2)).
    split; trivial.
    rewrite <- H0.
    apply decode_val_inject. eapply getN_pperm_inj; eauto.
    rewrite <- size_chunk_conv. assumption.
  Qed.*)

  Lemma setN_inj:
    forall f vl1 vl2,
      list_forall2 (memval_inject f) vl1 vl2 ->
      forall p c1 c2,
        (forall q, flatmem_val_inject (c1#q) (c2#(q))) ->
        (forall q, flatmem_val_inject ((setN vl1 p c1)#q)
                                     ((setN vl2 (p) c2)#(q))).
  Proof.
    induction 1; intros; simpl.
    auto.
    apply IHlist_forall2; auto.
    intros. rewrite ZMap.gsspec at 1. destruct (ZIndexed.eq q0 p). subst q0.
    rewrite ZMap.gss.
    destruct a1.
    constructor.
    inv H.
    constructor.
    constructor.
    rewrite ZMap.gso. auto.
    trivial.
  Qed.

  Lemma store_mapped_inj:
    forall f chunk m1 ofs v1 n1 n2 m2 v2,
      flatmem_inj m1 m2 ->
      store chunk m1 ofs v1 = n1 ->
      val_inject f v1 v2 ->
      store chunk m2 (ofs) v2 = n2 ->
      flatmem_inj n1 n2.
  Proof.
    intros.
    unfold store in *.
    rewrite <- H0.
    rewrite <- H2.
    unfold flatmem_inj in *.

    apply setN_inj with f; trivial.
    apply encode_val_inject; auto.
  Qed.

  (*Lemma setN_pperm_inj:
    forall f vl1 vl2,
      list_forall2 (memval_inject f) vl1 vl2 ->
      forall p c1 c2 pp,
        (forall q,
           (forall o, ZMap.get (PageI q) pp <> PGHide o) ->
           flatmem_val_inject (c1#q) (c2#(q))) ->
        (forall q,
           (forall o, ZMap.get (PageI q) pp <> PGHide o) ->
           flatmem_val_inject ((setN vl1 p c1)#q)
                              ((setN vl2 (p) c2)#(q))).
  Proof.
    induction 1; intros; simpl.
    auto.
    eapply IHlist_forall2; eauto.
    intros. rewrite ZMap.gsspec at 1. destruct (ZIndexed.eq q0 p). subst q0.
    rewrite ZMap.gss.
    destruct a1.
    constructor.
    inv H.
    constructor.
    constructor.
    rewrite ZMap.gso. auto.
    trivial.
  Qed.

  Lemma store_mapped_pperm_inj:
    forall f chunk m1 ofs v1 n1 n2 m2 v2 p,
      flatmem_pperm_inj p m1 m2 ->
      store chunk m1 ofs v1 = n1 ->
      val_inject f v1 v2 ->
      store chunk m2 (ofs) v2 = n2 ->
      flatmem_pperm_inj p n1 n2.
  Proof.
    intros.
    unfold store in *.
    rewrite <- H0.
    rewrite <- H2.
    unfold flatmem_pperm_inj in *.
    intros.
    apply setN_pperm_inj with f p; auto.
    apply encode_val_inject; auto.
  Qed.

  Lemma setN_pperm_unmapped_inj:
    forall vl2,
      forall p c1 c2 pp,
        (forall ofs',
           p <= ofs' < p + Z.of_nat (length vl2) ->
           exists o, ZMap.get (PageI ofs') pp = PGHide o) ->
        (forall q,
           (forall o, ZMap.get (PageI q) pp <> PGHide o) ->
           flatmem_val_inject (c1#q) (c2#(q))) ->
        (forall q,
           (forall o, ZMap.get (PageI q) pp <> PGHide o) ->
           flatmem_val_inject (c1#q)
                              ((setN vl2 p c2)#(q))).
  Proof.
    induction vl2; intros; simpl.
    - eauto.
    - eapply IHvl2; eauto.
      + intros. eapply H. Local Opaque Z.of_nat. simpl.
        rewrite Nat2Z.inj_succ. omega.
      + intros.
        destruct (zeq q0 p); subst.
        * rewrite ZMap.gss.
          exploit (H p). simpl.
          rewrite Nat2Z.inj_succ. omega.
          intros (o & HF). specialize (H2 o). congruence.
        * rewrite ZMap.gso; auto.
  Qed.

  Lemma store_unmapped_pperm_inj:
    forall chunk m1 ofs n2 m2 v2 p,
      flatmem_pperm_inj p m1 m2 ->
      store chunk m2 (ofs) v2 = n2 ->
      (forall ofs',
         ofs <= ofs' < ofs + size_chunk chunk ->
         exists o, ZMap.get (PageI ofs') p = PGHide o) ->
      flatmem_pperm_inj p m1 n2.
  Proof.
    intros.
    unfold store in *.
    rewrite <- H0.
    unfold flatmem_pperm_inj in *.
    intros.
    apply setN_pperm_unmapped_inj with p; auto.
    rewrite encode_val_length.
    rewrite <- size_chunk_conv. assumption.
  Qed.*)

  Lemma flatmem_empty_inj: flatmem_inj empty_flatmem empty_flatmem.
  Proof.
    unfold flatmem_inj.
    intros.
    unfold empty_flatmem.
    rewrite ZMap.gi.
    constructor.
  Qed.

  (*Lemma flatmem_empty_pperm_inj: forall p, flatmem_pperm_inj p empty_flatmem empty_flatmem.
  Proof.
    unfold flatmem_pperm_inj.
    intros.
    unfold empty_flatmem.
    rewrite ZMap.gi.
    constructor.
  Qed.*)

  Definition free_page (i: Z) (c: flatmem) :=
    setN (list_repeat (Z.to_nat PgSize) Undef) (i * PgSize) c.

  Lemma setN_free_get:
    forall n i ofs c,
      i <= ofs < i + (Z.of_nat n) ->
      (setN (list_repeat n Undef) i c) # ofs = HUndef.
  Proof.
    induction n; intros.
    - Local Transparent Z.of_nat.
      simpl in H. omega.
    - Local Opaque Z.of_nat.
      rewrite Nat2Z.inj_succ in *.
      Local Transparent list_repeat. simpl.
      destruct (zeq ofs i); subst.
      + rewrite setN_other.
        * rewrite ZMap.gss. reflexivity.
        * intros. red; intros HF; subst. omega.
      + eapply IHn. omega.
  Qed.

  Lemma free_page_gss:
    forall addr h,
      ZMap.get addr (free_page (PageI addr) h) = HUndef.
  Proof.
    unfold free_page. intros.
    eapply setN_free_get.
    rewrite Z2Nat.id; [|omega].
    unfold PageI.
    exploit (Z_div_mod_eq addr PgSize). omega.
    rewrite Zmult_comm.
    intros Hrange.
    exploit (Z_mod_lt addr PgSize). omega.
    intros Hrange'. omega.
  Qed.

  Lemma free_page_gso:
    forall addr i h,
      i <> PageI addr ->
      ZMap.get addr (free_page i h) = ZMap.get addr h.
  Proof.
    unfold free_page. intros.
    apply setN_other.
    rewrite length_list_repeat.
    rewrite Z2Nat.id; [|omega].
    red; intros; subst. elim H. clear H.
    unfold PageI.
    assert (HP: exists a, addr = i * PgSize + a /\ 0 <= a < PgSize).
    {
      exists (addr - i * PgSize).
      split; omega.
    }
    clear H0. destruct HP as (a & Heq & Hrange).
    rewrite Heq. clear Heq.
    rewrite Z_div_plus_full_l; [| omega].
    rewrite Zdiv_small; trivial. omega.
  Qed.

  (*Lemma free_page_pperm_inj:
    forall pp h h',
    flatmem_pperm_inj pp h h' ->
    forall i p,
      flatmem_pperm_inj (ZMap.set i p pp) (free_page i h) h'.
  Proof.
    intros. unfold flatmem_pperm_inj in *.
    intros. destruct (zeq i (PageI addr)); subst.
    - rewrite free_page_gss.
      constructor.
    - rewrite ZMap.gso in H0; auto.
      rewrite free_page_gso; auto.
  Qed.*)

  Lemma free_page_inj:
    forall h h',
      flatmem_inj h h' ->
      forall i,
        flatmem_inj (free_page i h) h'.
  Proof.
    intros. unfold flatmem_inj in *.
    intros. destruct (zeq i (PageI addr)); subst.
    - rewrite free_page_gss.
      constructor.
    - rewrite free_page_gso; auto.
  Qed.

  Lemma free_page_inj':
    forall h h',
      flatmem_inj h h' ->
      forall i,
        flatmem_inj (free_page i h) (free_page i h').
  Proof.
    intros. unfold flatmem_inj in *.
    intros. destruct (zeq i (PageI addr)); subst.
    - rewrite free_page_gss.
      constructor.
    - repeat rewrite free_page_gso; auto.
  Qed.

  Lemma store_unmapped_inj:
    forall chunk m1 ofs n2 m2 v2 i,
      flatmem_inj m1 m2 ->
      store chunk m2 ofs v2 = n2 ->
      i * PgSize <= ofs <= i * PgSize + PgSize - (size_chunk chunk) ->
      flatmem_inj (free_page i m1) n2.
  Proof.
    intros. unfold flatmem_inj in *. intros.
    unfold store in *.
    rewrite <- H0.
    destruct (zeq i (PageI addr)); subst.
    - rewrite free_page_gss. constructor.
    - rewrite free_page_gso; auto.
      rewrite setN_other; auto.
      intros. red; intros; subst. elim n.
      revert H0 H1. clear; intros.
      assert (HW: exists a, addr = i * PgSize + a
                            /\ 0 <= a < PgSize).
      {
        exists (addr - i * PgSize).
        specialize (size_chunk_range chunk); intros.
        rewrite encode_val_length in H0.
        rewrite <- size_chunk_conv in H0.
        unfold ZIndexed.t in *.
        split; omega.
      }
      revert HW; clear; intros.
      destruct HW as (a & Heq & Hrange). subst.
      unfold PageI.
      rewrite Z_div_plus_full_l; [|omega].
      rewrite Zdiv_small. omega. assumption.
  Qed.

End FlatMem.

Notation flatmem := FlatMem.flatmem.

Section DirtyPPage.

Definition dirty_ppage (pperm: PPermT) (hp: flatmem) :=
  forall i o, ZMap.get i pperm = PGHide o ->
              forall adr,
                ZMap.get adr hp = ZMap.get adr (FlatMem.free_page i hp).

Lemma dirty_ppage_init:
  forall h,
    dirty_ppage (ZMap.init PGUndef) h.
Proof.
  unfold dirty_ppage. intros.
  rewrite ZMap.gi in H. congruence.
Qed.

Lemma dirty_ppage_gso:
  forall pp h,
    dirty_ppage pp h ->
    forall p,
      (forall o, p <> PGHide o) ->
      forall n,
        dirty_ppage (ZMap.set n p pp) h.
Proof.
  unfold dirty_ppage; intros.
  destruct (zeq i n); subst.
  - rewrite ZMap.gss in H1. subst.
    elim (H0 o). reflexivity.
  - rewrite ZMap.gso in H1; eauto 2.
Qed.

Lemma dirty_ppage_store_unmaped':
  forall pp h,
    dirty_ppage pp h ->
    forall i,
      ZMap.get (PageI i) pp = PGAlloc (*o*) ->
      forall v h' chunk,
        FlatMem.store chunk h i v = h' ->
        i mod PgSize <= PgSize - size_chunk chunk ->
        dirty_ppage pp h'.
Proof.
  unfold dirty_ppage in *. intros. subst.
  destruct (zeq i0 (PageI adr)); subst.
  - rewrite FlatMem.free_page_gss.
    unfold FlatMem.store.
    erewrite FlatMem.setN_other.
    + erewrite H; try apply H3.
      rewrite FlatMem.free_page_gss.
      reflexivity.
    + rewrite encode_val_length. rewrite <- size_chunk_conv.
      red; intros; subst.
      assert (HW: PageI adr = PageI i).
      {
        unfold PageI.
        assert (HW: exists a, adr = i + a
                              /\ 0 <= a < size_chunk chunk).
        {
          exists (adr - i).
          unfold ZIndexed.t in *.
          split; omega.
        }
        destruct HW as (a & Heq & Hrange); subst.
        assert (HW: exists b c, i = b * PgSize + c
                                /\ 0 <= c <= PgSize - size_chunk chunk).
        {
          rewrite (Z_div_mod_eq i PgSize); [|omega].
          rewrite (Zmult_comm PgSize (i/ PgSize)).
          esplit; esplit; split. reflexivity.
          exploit  (Z_mod_lt i PgSize). omega.
          intros (HP & _).
          split; try assumption.
        }
        destruct HW as (b & c & Heq & Hrange'). rewrite Heq.
        replace (b * PgSize + c + a) with (b * PgSize + (c + a)) by omega.
        repeat rewrite Z_div_plus_full_l; try omega.
        repeat rewrite Zdiv_small; omega.
      }
      congruence.
  - rewrite FlatMem.free_page_gso; trivial.
Qed.

Lemma dirty_ppage_store_unmaped:
  forall pp h,
    dirty_ppage pp h ->
    forall i,
      ZMap.get (PageI (i * 4)) pp = PGAlloc ->
      forall v h',
        FlatMem.store Mint32 h (i * 4) v = h' ->
        dirty_ppage pp h'.
Proof.
  intros. eapply dirty_ppage_store_unmaped'; try eassumption.
  clear. simpl.
  change 4096 with (1024 * 4).
  rewrite Zmult_mod_distr_r.
  apply mod_chunk.
Qed.

Lemma dirty_ppage_gss:
  forall pp h,
    dirty_ppage pp h ->
    forall o n,
      dirty_ppage (ZMap.set n (PGHide o) pp) (FlatMem.free_page n h).
Proof.
  unfold dirty_ppage; intros.
  destruct (zeq i n); subst.
  - destruct (zeq n (PageI adr)); subst.
    + repeat rewrite FlatMem.free_page_gss.
      reflexivity.
    + repeat rewrite FlatMem.free_page_gso; auto.
  - rewrite ZMap.gso in H0; [|assumption].
    destruct (zeq n (PageI adr)); subst.
    + repeat rewrite FlatMem.free_page_gss.
      rewrite FlatMem.free_page_gso; auto.
      rewrite FlatMem.free_page_gss.
      reflexivity.
    + destruct (zeq i (PageI adr)); subst.
      * rewrite FlatMem.free_page_gso.
        rewrite FlatMem.free_page_gss.
        erewrite H; [| eassumption].
        rewrite FlatMem.free_page_gss.
        reflexivity. auto.
      * repeat rewrite FlatMem.free_page_gso; auto.
Qed.

End DirtyPPage.

Section DirtyPPage'.

Definition dirty_ppage' (pperm: PPermT) (hp: flatmem) :=
  forall i, ZMap.get i pperm <> PGAlloc ->
              forall adr,
                ZMap.get adr hp = ZMap.get adr (FlatMem.free_page i hp).

Lemma dirty_ppage'_init:
  dirty_ppage' (ZMap.init PGUndef) FlatMem.empty_flatmem.
Proof.
  unfold dirty_ppage'; intros; unfold FlatMem.empty_flatmem.
  destruct (zeq (PageI adr) i); subst.
  rewrite ZMap.gi; rewrite FlatMem.free_page_gss; auto.
  rewrite FlatMem.free_page_gso; auto.
Qed.

Lemma dirty_ppage'_gso:
  forall pp h,
    dirty_ppage' pp h ->
      forall n,
        dirty_ppage' (ZMap.set n PGAlloc pp) h.
Proof.
  unfold dirty_ppage'; intros.
  destruct (zeq i n); subst.
  - rewrite ZMap.gss in H0. contradict H0; auto.
  - rewrite ZMap.gso in H0; auto.
Qed.

Lemma dirty_ppage'_store_unmapped':
  forall pp h,
    dirty_ppage' pp h ->
    forall i,
      ZMap.get (PageI i) pp = PGAlloc ->
      forall v h' chunk,
        FlatMem.store chunk h i v = h' ->
        i mod PgSize <= PgSize - size_chunk chunk ->
        dirty_ppage' pp h'.
Proof.
  unfold dirty_ppage' in *. intros. subst.
  destruct (zeq i0 (PageI adr)); subst.
  - rewrite FlatMem.free_page_gss.
    unfold FlatMem.store.
    erewrite FlatMem.setN_other.
    + erewrite H; try apply H3.
      rewrite FlatMem.free_page_gss.
      reflexivity.
    + rewrite encode_val_length. rewrite <- size_chunk_conv.
      red; intros; subst.
      assert (HW: PageI adr = PageI i).
      {
        unfold PageI.
        assert (HW: exists a, adr = i + a
                              /\ 0 <= a < size_chunk chunk).
        {
          exists (adr - i).
          unfold ZIndexed.t in *.
          split; omega.
        }
        destruct HW as (a & Heq & Hrange); subst.
        assert (HW: exists b c, i = b * PgSize + c
                                /\ 0 <= c <= PgSize - size_chunk chunk).
        {
          rewrite (Z_div_mod_eq i PgSize); [|omega].
          rewrite (Zmult_comm PgSize (i/ PgSize)).
          esplit; esplit; split. reflexivity.
          exploit  (Z_mod_lt i PgSize). omega.
          intros (HP & _).
          split; try assumption.
        }
        destruct HW as (b & c & Heq & Hrange'). rewrite Heq.
        replace (b * PgSize + c + a) with (b * PgSize + (c + a)) by omega.
        repeat rewrite Z_div_plus_full_l; try omega.
        repeat rewrite Zdiv_small; omega.
      }
      congruence.
  - rewrite FlatMem.free_page_gso; trivial.
Qed.

Lemma dirty_ppage'_store_unmapped:
  forall pp h,
    dirty_ppage' pp h ->
    forall i,
      ZMap.get (PageI (i * 4)) pp = PGAlloc ->
      forall v h',
        FlatMem.store Mint32 h (i * 4) v = h' ->
        dirty_ppage' pp h'.
Proof.
  intros. eapply dirty_ppage'_store_unmapped'; try eassumption.
  clear. simpl.
  change 4096 with (1024 * 4).
  rewrite Zmult_mod_distr_r.
  apply mod_chunk.
Qed.

Lemma dirty_ppage'_gss:
  forall pp h,
    dirty_ppage' pp h ->
    forall p n,
      dirty_ppage' (ZMap.set n p pp) (FlatMem.free_page n h).
Proof.
  unfold dirty_ppage'; intros.
  destruct (zeq i n); subst.
  - destruct (zeq n (PageI adr)); subst.
    + repeat rewrite FlatMem.free_page_gss.
      reflexivity.
    + repeat rewrite FlatMem.free_page_gso; auto.
  - rewrite ZMap.gso in H0; [|assumption].
    destruct (zeq n (PageI adr)); subst.
    + repeat rewrite FlatMem.free_page_gss.
      rewrite FlatMem.free_page_gso; auto.
      rewrite FlatMem.free_page_gss.
      reflexivity.
    + destruct (zeq i (PageI adr)); subst.
      * rewrite FlatMem.free_page_gso.
        rewrite FlatMem.free_page_gss.
        erewrite H; [| eassumption].
        rewrite FlatMem.free_page_gss.
        reflexivity. auto.
      * repeat rewrite FlatMem.free_page_gso; auto.
Qed.

Lemma dirty_ppage_strengthen:
  forall pp h, dirty_ppage' pp h -> dirty_ppage pp h.
Proof.
  unfold dirty_ppage', dirty_ppage; intros.
  apply H; rewrite H0; discriminate.
Qed.

End DirtyPPage'.