From Perennial.program_proof Require Import grove_prelude.
From iris.bi.lib Require Import fractional.
From iris.algebra Require Import gmap cmra dfrac_agree.
From iris.algebra Require Import mono_list.
From iris.base_logic Require Import mono_nat.
From iris.proofmode Require Import proofmode.

Section ghost_proof.

(* A configuration is known by its write quorums *)
Record ConfigC :=
{
  is_quorum : (gset chan) → Prop
}.

Record LogEntry :=
{
  config:ConfigC ;
  val:list u8 ;
}.

Class reconfG Σ :=
{
  acc_inG:> inG Σ (gmapR (u64 * u64) (mono_listR (leibnizO LogEntry)));
  commit_inG:> inG Σ (mono_listR (leibnizO LogEntry));
  proposal_inG:> inG Σ (gmapR u64 (mono_listR (leibnizO LogEntry)));
}.

Record reconf_names :=
{
  acc_gn:gname ;
  commit_gn:gname ;
  prop_gn:gname ;
}.

Implicit Type γ:reconf_names.
Implicit Type srv:u64.

Context `{!heapGS Σ}.
Context `{!reconfG Σ}.

Definition conf_eq (config1 config2:ConfigC) :=
  ∀ W, config1.(is_quorum) W ↔ config2.(is_quorum) W.

Implicit Type mval : (list (leibnizO LogEntry)).

Definition mval_le mval mval' := prefix mval mval'.

Definition mval_lt mval mval' := prefix mval mval' ∧ mval ≠ mval'.

Implicit Type term:u64.

(* This is just ownership of raw ghost resources. *)

Definition def_config : ConfigC.
Admitted.

Definition get_config mval : ConfigC :=
  match (last mval) with
  | Some e => e.(config)
  | _ => def_config
end
.

Definition accepted γ srv term mval : iProp Σ :=
  own γ.(acc_gn) {[ (term,srv) := ●ML mval ]}.

Definition accepted_ro γ srv term mval : iProp Σ :=
  own γ.(acc_gn) {[ (term,srv) := ●ML□ mval ]}.

Definition accepted_ro_none γ srv term : iProp Σ :=
  own γ.(acc_gn) {[ (term,srv) := ●ML□ [] ]}. (* XXX: not sure if empty list is good enough here*)

Definition accepted_lb γ srv term mval : iProp Σ :=
  own γ.(acc_gn) {[ (term,srv) := ◯ML mval ]}.

Definition commit γ mval : iProp Σ :=
  own γ.(commit_gn) (●ML mval).

Definition commit_lb γ mval : iProp Σ :=
  own γ.(commit_gn) (◯ML mval).

Definition proposed γ term mval : iProp Σ :=
  own γ.(acc_gn) {[ term := ●ML mval ]}.

Definition proposed_lb γ term mval : iProp Σ :=
  own γ.(acc_gn) {[ term := ◯ML mval ]}.

(* This is more complicated stuff, beyond raw ghost resource ownership. *)

Definition committed_at_term γ term mval: iProp Σ :=
  ∃ W, ⌜(get_config mval).(is_quorum) W⌝ ∗
  ([∗ set] srv ∈ W, accepted_lb γ srv term mval)
.

Definition overlapping_quorums (config1 config2:ConfigC) :=
  ∀ W1 W2, (config1.(is_quorum) W1) → (config2.(is_quorum) W2) → W1 ∩ W2 ≠ ∅.

(* Maybe this should say
   either the config of mval' intersects with the config of mval OR
   every quorum in mval' contains a server that accepted something bigger than
   mval'.
*)
(*
  FIXME: should we take term'' = term here?
  If we do, then it's not clear how to prove (old_conf_max γ term mval -∗
  old_conf_max γ (term + 1) mval) anymore.
  If we don't, then when we want to use old_conf_max, it's possible that term''
  < term, in which case we would want to use old_term_max, but we can't use
  old_term_max, because it requires old_conf_max.

  There isn't a real circularity, it's just that we want to recursive invoke
  old_conf and old_term. But, that'll result in later problems.
 *)
From iris.bi.lib Require Import fixpoint.

Definition old_conf_max_pre (Φ:(reconf_names -d> u64 -d> (list (leibnizO LogEntry)) -d> iPropO Σ)): (reconf_names -d> u64 -d> (list (leibnizO LogEntry)) -d> iPropO Σ) :=
  λ γ term mval,
    (∀ mval', ⌜mval_lt mval' mval⌝ → □(
        (⌜overlapping_quorums (get_config mval') (get_config mval)⌝ ∨
         (∃ mval'' term'',
             ⌜mval_lt mval' mval''⌝ ∗
             ⌜mval_le mval'' mval⌝ ∗
             ⌜int.nat term'' ≤ int.nat term⌝ ∗
             committed_at_term γ term'' mval'' ∗
             Φ γ term mval'' ∗
             ⌜overlapping_quorums (get_config mval') (get_config mval'')⌝
         )
        )
     ))%I
.

Definition old_conf_max_pre_least γ Φ (p:leibnizO(u64 * list (leibnizO LogEntry))): iProp Σ :=
  ∀ mval', ⌜mval_lt mval' p.2⌝ → □(
        (⌜overlapping_quorums (get_config mval') (get_config p.2)⌝ ∨
         (∃ mval'' term'',
             ⌜mval_lt p.2 mval''⌝ ∗
             ⌜int.nat term'' ≤ int.nat p.1⌝ ∗
             committed_at_term γ term'' mval'' ∗
             Φ ((term'', mval''):leibnizO _) ∗
             ⌜overlapping_quorums (get_config mval') (get_config mval'')⌝
         )
        )
     )
.

(* Definition old_conf_max γ term mval : iProp Σ := (bi_least_fixpoint (old_conf_max_pre_least γ) (term, mval)).

Instance old_conf_max_pre_contr : Contractive old_conf_max_pre.
Admitted.

Program Definition old_conf_max_2 γ term mval : iProp Σ := □ (fixpoint (old_conf_max_pre) γ term mval). *)

Definition old_conf_max_orig γ term mval: iProp Σ :=
  ∀ mval', ⌜mval_lt mval' mval⌝ → □(
        (⌜overlapping_quorums (get_config mval') (get_config mval)⌝ ∨
         (∃ mval'' term'',
             ⌜mval_lt mval' mval''⌝ ∗
             ⌜int.nat term'' ≤ int.nat term⌝ ∗
             committed_at_term γ term'' mval'' ∗
             (* FIXME: want to be able to put another old_conf_max here *)
             ⌜overlapping_quorums (get_config mval') (get_config mval'')⌝
         )
        )
     )
.

(* This says:
   If mval gets committed in this term, then all smaller mval' will be "sealed".
 *)
Definition old_conf_max_single γ mval: iProp Σ :=
  ∀ term mval', committed_at_term γ term mval -∗ ⌜mval_lt mval' mval⌝ →
      □(∃ mval'' term'',
           ⌜mval_lt mval' mval''⌝ ∗
           ⌜int.nat term'' ≤ int.nat term⌝ ∗
           committed_at_term γ term'' mval'' ∗
           ⌜overlapping_quorums (get_config mval') (get_config mval'')⌝
      )
.

Definition old_conf_max γ mval : iProp Σ :=
  □(∀ mval_pfx, ⌜mval_le mval_pfx mval⌝ -∗ old_conf_max_single γ mval).

Definition old_term_max γ term mval : iProp Σ :=
  ∀ term' mval', □(⌜int.nat term' < int.nat term⌝ →
  proposed_lb γ term' mval' -∗
  committed_at_term γ term' mval' -∗
  old_conf_max γ mval' -∗
  ⌜mval_le mval' mval⌝
  )
.

Definition sysN := nroot .@ "sys".

Definition sys_inv γ : iProp Σ :=
  inv sysN (
        ∃ term mval,
          commit γ mval ∗
          (committed_at_term γ term mval) ∗
          proposed_lb γ term mval ∗
          old_term_max γ term mval ∗ (* XXX: could make a accepted_lb_fancy, and put this
                              in there, and add requirement that quorum is
                              non-empty. *)
          old_conf_max γ mval
  ).

Definition no_concurrent_reconfigs_and_overlapping_quorums γ term mval : iProp Σ :=
  ∃ mval',
    commit_lb γ mval' ∗ □(
      ∀ mval'', ⌜mval_lt mval'' mval⌝ →
                ⌜mval_le mval' mval''⌝ →
                proposed_lb γ term mval'' →
                ⌜conf_eq (get_config mval') (get_config mval'')⌝
    ) ∗
    ⌜overlapping_quorums (get_config mval) (get_config mval')⌝
.

Lemma mono_list_included': ∀ (A : ofe) (dq : dfrac) (l l': list A),
    l `prefix_of` l' →
    ◯ML l ≼ ●ML{dq} l'.
Proof.
  intros.
  assert (◯ML l' ≼ ●ML{dq} l').
  { apply mono_list_included. }
  assert (◯ML l ≼ ◯ML l').
  { apply mono_list_lb_mono. done. }
  apply (transitivity H1 H0).
Qed.

Lemma ghost_commit γ term mval :
  sys_inv γ -∗
  committed_at_term γ term mval -∗
  proposed_lb γ term mval -∗
  old_term_max γ term mval -∗ (* XXX: could make a accepted_lb_fancy, and put this
                              in there, and add requirement that quorum is
                              non-empty. *)
  old_conf_max γ mval -∗
  |={↑sysN,∅}=> ▷ |={∅,↑sysN}=>
  commit_lb γ mval
.
Proof.
  iIntros "#Hinv #HcommitAt #Hproposed #Hold #Hconf".
  iInv "Hinv" as "Hi" "Hclose".
  iDestruct "Hi" as (commitTerm commitVal) "Hi".
  iEval (unfold old_conf_max) in "Hi".
  iDestruct "Hi" as "(>Hcommit & #>HcommitAcc & #>HproposedCommit & #>HoldCommit & #HconfCommit)".
  replace (_ ∖ _) with (∅: coPset); last first.
  { set_solver. }
  iModIntro.
  iModIntro.
  iAssert (⌜mval_le mval commitVal ∨ mval_le commitVal mval⌝)%I as "%Hcomparable".
  {
    destruct (decide (int.nat term < int.nat commitTerm)).
    { (* case: term < commitTerm *)
      iDestruct ("HoldCommit" with "[] Hproposed HcommitAt Hconf") as "%HvalLe".
      { done. }
      eauto.
    }
    destruct (decide (int.nat term = int.nat commitTerm)).
    { (* case: term == commitTerm *)
      replace (commitTerm) with (term) by word.
      iDestruct (own_valid_2 with "Hproposed HproposedCommit") as %Hvalid.
      rewrite singleton_op in Hvalid.
      apply singleton_valid in Hvalid.
      apply mono_list_lb_op_valid_1_L in Hvalid.
      done.
    }
    (* case: term > commitTerm *)
    assert (int.nat term > int.nat commitTerm) by word.
    iDestruct ("Hold" with "[] HproposedCommit HcommitAcc HconfCommit") as "%HvalLe".
    { done. }
    eauto.
  }

  destruct Hcomparable.
  { (* committed value is bigger than mval *)
    iDestruct (own_mono _ _ (◯ML mval) with "Hcommit") as "#HH".
    {
      by apply mono_list_included'.
    }
    iFrame "#".
    iMod ("Hclose" with "[Hcommit]").
    {
      iNext.
      iExists _, _; iFrame.
      iFrame "#".
    }
    done.
  }
  { (* mval is bigger than committed value; in this case, we commit something new *)
    iMod (own_update with "Hcommit") as "Hcommit".
    {
      apply mono_list_update.
      exact H.
    }
    iDestruct (own_mono _ _ (◯ML mval) with "Hcommit") as "#HH".
    {
      apply mono_list_included.
    }
    iFrame "#".
    iMod ("Hclose" with "[Hcommit]").
    {
      iNext.
      iExists _, _; iFrame.
      iFrame "HcommitAt #".
    }
    done.
  }
Qed.

Lemma become_leader γ term highestVal highestTerm W:
    int.nat highestTerm < int.nat term →
    (get_config highestVal).(is_quorum) W →
    sys_inv γ -∗
    proposed_lb γ highestTerm highestVal -∗
    old_term_max γ highestTerm highestVal -∗
    old_conf_max γ highestVal -∗
    □(
      [∗ set] srv ∈ W,
        (∃ srvVal, ⌜mval_le srvVal highestVal⌝ ∗ accepted_ro γ srv highestTerm srvVal) ∗
        (∀ term', ⌜int.nat highestTerm < int.nat term'⌝ → ⌜int.nat term' < int.nat term⌝ → accepted_ro_none γ srv term')
    ) -∗
    old_term_max γ term highestVal.
Proof.
  intros HtermIneq Hquorum.
  iIntros "#Hsys #Hproposed #Hold #Hconf #HoldInfo".
  iIntros (term' mval').
  iModIntro.
  iIntros "%Hterm'Ineq".
  iIntros "#Hproposed'".
  iIntros "#Hcommit' #Hconf'".
  destruct (decide (int.nat term' < int.nat highestTerm)).
  { (* term' < highestTerm, so we can just use the old_term_max of (highestTerm,highestVal) *)
    iApply "Hold"; try done.
  }
  destruct (decide (int.nat term' = int.nat highestTerm)).
  { (* for term' == highestTerm, we have the first part of "oldInfo" *)
    replace (term') with (highestTerm); last first.
    { (* FIXME: why doesn't word work? *)
      clear -e.
      rewrite Z2Nat.inj_iff in e; first last.
      { word. }
      { word. }
      {
        apply word.unsigned_inj in e.
        done.
      }
    }
    iDestruct (own_valid_2 with "Hproposed' Hproposed") as %Hvalid.
    rewrite singleton_op in Hvalid.
    rewrite singleton_valid in Hvalid.
    apply mono_list_lb_op_valid_1_L in Hvalid.
    destruct Hvalid as [Hdone|HlogLe].
    { done. }
    destruct (decide (length mval' = length highestVal)).
    { (* If the two are equal, then no problem *)
      assert (mval' = highestVal).
      {
        symmetry.
        apply list_prefix_eq.
        {
          done.
        }
        word.
      }
      rewrite H.
      done.
    }
    (* case: mval_lt highestVal mval'. Here, we're gonna derive a contradiction. *)
    iExFalso.
    (* now, apply old_conf_max highestTerm mval'' *)
    iDestruct ("Hconf'" $! mval' with "[% //]") as "Hconf2".
    iDestruct ("Hconf2" $! _ highestVal with "Hcommit' [%]") as "#Hconf3".
    {
      enough (mval' ≠ highestVal) by done.
      admit. (* TODO: pure fact that if lists have different lengths, they are not equal *)
    }
    (* In this case, some highest value mval'' was committed, and has
         overlapping quorums with highestVal. *)

    iDestruct "Hconf3" as (mval'' term'') "(%Hmval''lt & %Hterm''Ineq & #Hcommit'' & %Hoverlap)".
      (* if term'' < highestTerm, then (old_term_max highestTerm highestVal) takes care of it *)
      destruct (decide (int.nat term'' < int.nat highestTerm)).
      { (* if term'' < highestTerm, we use old_term_max *)
        unfold old_term_max.
        iDestruct ("Hold" $! term'' mval'' with "[] [] Hcommit'' [Hconf'']") as "%HlogLe2".
        { done. }
        { admit. } (* TODO: add this to old_conf_max. *)
        {
          rewrite /old_conf_max.
          iFrame "#".
        }
        (* XXX: we need old_conf_max to finish instantiating the old_term_max.
           So, going to use old_conf_max for the term'' and mval'' that we
           destructed from the old_conf_max for mval'.
         *)
        iPureIntro.
        simpl in Hmval''lt.
        (* pure proof: mval'' ≤ highestVal ≤ mval' < mval''. Contradiction *)
        assert (prefix mval'' mval').
        {
          transitivity (highestVal); done.
        }
        clear -H Hmval''lt.
        destruct Hmval''lt as [H1 H2].
        assert (mval'' = mval').
        {
          apply (anti_symm prefix); done.
        }
        done.
      }
      (* if term'' = highestTerm, we use overlapping quorum with highestVal to get contradiction *)
      simpl in Hterm''Ineq.
      assert (term'' = highestTerm) as -> by word.

      iDestruct ("Hcommit''") as (W2) "[%Hw2quorum #Hcommit'']".
      specialize (Hoverlap W W2).
      assert (exists srv, srv ∈ W ∩ W2) as [srv HsrvIn].
      {
        apply set_choose.
        rewrite leibniz_equiv_iff.
        apply Hoverlap; done.
      }

      iDestruct (big_sepS_elem_of_acc _ _ srv with "Hcommit''") as "[Hacc'' _]".
      { set_solver. }
      iDestruct (big_sepS_elem_of_acc _ _ srv with "HoldInfo") as "[Hacc _]".
      { set_solver. }
      iDestruct "Hacc" as "[Hacc _]".
      iDestruct "Hacc" as (?) "[%HsrvValLe Hacc]".
      iDestruct (own_valid_2 with "Hacc Hacc''") as %Hvalid.
      rewrite singleton_op in Hvalid.
      rewrite singleton_valid in Hvalid.
      apply mono_list_both_dfrac_valid_L in Hvalid.
      destruct Hvalid as [_ HsrvValLe2].
      simpl in Hmval''lt.
      exfalso.
      (* pure proof: mval' < mval'' ≤ srvVal ≤ highestVal ≤ mval'. Contradiction *)
      admit.
    }
  }
  {
    exfalso.
    admit.
  }

End ghost_proof.


(*
 * Copyright (c) 2021 BedRock Systems, Inc.
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *
 *
 * Some of the following code is derived from code original to the
 * Iris project. That original code is
 *
 *	Copyright Iris developers and contributors
 *
 * and used according to the following license.
 *
 *	SPDX-License-Identifier: BSD-3-Clause
 *
 * Original Code:
 * https://gitlab.mpi-sws.org/iris/iris/-/blob/5bb93f57729a8cc7d0ffeaab769cd24728e51a38/iris/bi/lib/atomic.v
 *
 * Original Iris License:
 * https://gitlab.mpi-sws.org/iris/iris/-/blob/5bb93f57729a8cc7d0ffeaab769cd24728e51a38/LICENSE-CODE
 *)

From stdpp Require Import coPset namespaces.
From iris.bi.lib Require Import fixpoint.
From iris.proofmode Require Import coq_tactics proofmode reduction.
From iris.prelude Require Import options.
From iris.bi.lib Require Import atomic.

Require Export bedrock.lang.bi.laterable.
Require Import bedrock.lang.bi.telescopes.

(** Conveniently split a conjunction on both assumption and conclusion. *)
Local Tactic Notation "iSplitWith" constr(H) :=
  iApply (bi.and_parallel with H); iSplit; iIntros H.

Section definition.
  Context `{BiFUpd PROP} {TA TB : tele}.
  Implicit Types
    (Eo Ei : coPset) (* outer/inner masks *)
    (α : TA → PROP) (* atomic pre-condition *)
    (P : PROP) (* abortion condition *)
    (β : TA → TB → PROP) (* atomic post-condition *)
    (Φ : TA → TB → PROP) (* post-condition *)
  .

  (** atomic1_acc as the "introduction form" of atomic updates: An accessor
      that can be aborted back to [P]. *)
  (** Main extension compared to [atomic_acc]:
    This one can make a step---having a later---for the COMMIT case,i.e.
      ▷ (∀.. y, β x y ={Ei, Eo}=∗ Φ x y)

    This means that the client of this spec can make a step before applying the
    closing COMMIT [fupd], and the prover the spec needs to take an actual step
    when COMMITing.
    Consider the example of an AU1 (atomic update) that takes a step.
    - As a client of an AU spec, which has the form `AU1 ⊢ wp`, the client
      applies the spec and has to prove the `AU1`. In proving those, the client
      has a later in the goal of the COMMIT [fupd], which allows them to strip
      later from resources in the context, including resources that were
      obtained by opening the invariants around the AU.
      This stripping of laters is done before actually COMMITing.
    - As the prover of the same AU spec `AU1 ⊢ wp`, the prover assumes the
      AU1 and proves the `wp`. Then the prover needs to apply the COMMIT [fupd]
      to finish. But the COMMIT [fupd] is under a later, so the prover needs to
      have the `wp` takes an actual step to strip that later before COMMITing.
      This also demonstrates one you cannot prove an AU1 spec for a `wp` that
      does not take a step.

    Note that we can also add a later to the ABORT case:
      ▷ (α x ={Ei, Eo}=∗ P)

    But that means the the prover has to show the implementation takes at least
    a step every time the abort is used. While this is not unreasonable, it
    restricts the set of implementations that can be proven with this spec. We
    therefore choose not to support it here. *)
  Definition atomic1_acc Eo Ei α P β Φ : PROP :=
    (|={Eo, Ei}=> ∃.. x, α x ∗
          ((α x ={Ei, Eo}=∗ P) ∧ ▷ (∀.. y, β x y ={Ei, Eo}=∗ Φ x y))
    )%I.

  (* atomic1_acc is more restricted than atomic_acc : ACCC ⊢ ACCC1.
    The direction of implication may look perplexing, but this really gives us
    what we want: a AU1 spec implies a AU spec, that is
      (AU1 -∗ wp) ⊢ (AU -∗ wp)
  *)
  Lemma atomic_acc_atomic1_acc Eo Ei α P β Φ :
    atomic_acc Eo Ei α P β Φ -∗ atomic1_acc Eo Ei α P β Φ.
  Proof.
    rewrite /atomic1_acc /atomic_acc.
    iIntros "AS". iMod "AS" as (x) "[Hα Hclose]".
    iModIntro. iExists x. iFrame "Hα". iSplit.
    - iIntros "Hα". iDestruct "Hclose" as "[Hclose _]".
      iApply "Hclose". done.
    - iIntros "!>" (y) "Hβ". iDestruct "Hclose" as "[_ Hclose]".
      iApply "Hclose". done.
  Qed.

  Lemma atomic1_acc_wand Eo Ei α P1 P2 β Φ1 Φ2 :
    ((P1 -∗ P2) ∧ ▷ (∀.. x y, Φ1 x y -∗ Φ2 x y)) -∗
    (atomic1_acc Eo Ei α P1 β Φ1 -∗ atomic1_acc Eo Ei α P2 β Φ2).
  Proof.
    iIntros "HP12 AS". iMod "AS" as (x) "[Hα Hclose]".
    iModIntro. iExists x. iFrame "Hα". iSplit.
    - iIntros "Hα". iDestruct "Hclose" as "[Hclose _]".
      iApply "HP12". iApply "Hclose". done.
    - iIntros "!>" (y) "Hβ". iDestruct "Hclose" as "[_ Hclose]".
      iApply "HP12". iApply "Hclose". done.
  Qed.

  Lemma atomic1_acc_mask Eo Ed α P β Φ :
    atomic1_acc Eo (Eo∖Ed) α P β Φ ⊣⊢ ∀ E, ⌜Eo ⊆ E⌝ → atomic1_acc E (E∖Ed) α P β Φ.
  Proof.
    iSplit; last first.
    { iIntros "Hstep". iApply ("Hstep" with "[% //]"). }
    iIntros "Hstep" (E HE).
    iApply (fupd_mask_frame_acc with "Hstep"); first done.
    iIntros "Hstep". iDestruct "Hstep" as (x) "[Hα Hclose]".
    iIntros "!> Hclose'".
    iExists x. iFrame. iSplitWith "Hclose".
    - iIntros "Hα". iApply "Hclose'". iApply "Hclose". done.
    - iIntros "!>" (y) "Hβ". iApply "Hclose'". iApply "Hclose". done.
  Qed.

  Lemma atomic1_acc_mask_weaken Eo1 Eo2 Ei α P β Φ :
    Eo1 ⊆ Eo2 →
    atomic1_acc Eo1 Ei α P β Φ -∗ atomic1_acc Eo2 Ei α P β Φ.
  Proof.
    iIntros (HE) "Hstep".
    iMod fupd_mask_subseteq as "Hclose1"; first done.
    iMod "Hstep" as (x) "[Hα Hclose2]". iIntros "!>". iExists x.
    iFrame. iSplitWith "Hclose2".
    - iIntros "Hα". iMod ("Hclose2" with "Hα") as "$". done.
    - iIntros "!>" (y) "Hβ". iMod ("Hclose2" with "Hβ") as "$". done.
  Qed.

  (** atomic1_update as a fixed-point of the equation
   AU = atomic1_acc α AU β Q
  *)
  Context Eo Ei α β Φ.

  Definition atomic1_update_pre (Ψ : () → PROP) (_ : ()) : PROP :=
    atomic1_acc Eo Ei α (Ψ ()) β Φ.

  Local Instance atomic1_update_pre_mono : BiMonoPred atomic1_update_pre.
  Proof.
    constructor.
    - iIntros (P1 P2 ??) "#HP12". iIntros ([]) "AU".
      iApply (atomic1_acc_wand with "[HP12] AU").
      iSplit; last by eauto. iApply "HP12".
    - intros ??. solve_proper.
  Qed.

  Definition atomic1_update_def :=
    bi_greatest_fixpoint atomic1_update_pre ().

End definition.

(** Seal it *)
Definition atomic1_update_aux : seal (@atomic1_update_def). Proof. by eexists. Qed.
Definition atomic1_update := atomic1_update_aux.(unseal).
Global Arguments atomic1_update {PROP _ TA TB}.
Definition atomic1_update_eq : @atomic1_update = _ := atomic1_update_aux.(seal_eq).

Global Arguments atomic1_acc {PROP _ TA TB} Eo Ei _ _ _ _ : simpl never.
Global Arguments atomic1_update {PROP _ TA TB} Eo Ei _ _ _ : simpl never.

(** Notation: Atomic updates *)
Notation "'AU1' '<<' ∀ x1 .. xn , α '>>' @ Eo , Ei '<<' ∃ y1 .. yn , β , 'COMM' Φ '>>'" :=
  (atomic1_update (TA:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. ))
                 (TB:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
                 Eo Ei
                 (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
                       λ x1, .. (λ xn, α%I) ..)
                 (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
                       λ x1, .. (λ xn,
                         tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
                         (λ y1, .. (λ yn, β%I) .. )
                        ) .. )
                 (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
                       λ x1, .. (λ xn,
                         tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
                         (λ y1, .. (λ yn, Φ%I) .. )
                        ) .. )
  )
  (at level 20, Eo, Ei, α, β, Φ at level 200, x1 binder, xn binder, y1 binder, yn binder,
   format "'[   ' 'AU1'  '<<'  ∀  x1  ..  xn ,  α  '>>'  '/' @  Eo ,  Ei  '/' '[   ' '<<'  ∃  y1  ..  yn ,  β ,  '/' COMM  Φ  '>>' ']' ']'") : bi_scope.

Notation "'AU1' '<<' ∀ x1 .. xn , α '>>' @ Eo , Ei '<<' β , 'COMM' Φ '>>'" :=
  (atomic1_update (TA:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. ))
                 (TB:=TeleO)
                 Eo Ei
                 (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
                       λ x1, .. (λ xn, α%I) ..)
                 (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
                       λ x1, .. (λ xn, tele_app (TT:=TeleO) β%I) .. )
                 (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
                       λ x1, .. (λ xn, tele_app (TT:=TeleO) Φ%I) .. )
  )
  (at level 20, Eo, Ei, α, β, Φ at level 200, x1 binder, xn binder,
   format "'[   ' 'AU1'  '<<'  ∀  x1  ..  xn ,  α  '>>'  '/' @  Eo ,  Ei  '/' '[   ' '<<'  β ,  '/' COMM  Φ  '>>' ']' ']'") : bi_scope.

Notation "'AU1' '<<' α '>>' @ Eo , Ei '<<' ∃ y1 .. yn , β , 'COMM' Φ '>>'" :=
  (atomic1_update (TA:=TeleO)
                 (TB:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
                 Eo Ei
                 (tele_app (TT:=TeleO) α%I)
                 (tele_app (TT:=TeleO) $
                       tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
                                (λ y1, .. (λ yn, β%I) ..))
                 (tele_app (TT:=TeleO) $
                       tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
                                (λ y1, .. (λ yn, Φ%I) ..))
  )
  (at level 20, Eo, Ei, α, β, Φ at level 200, y1 binder, yn binder,
   format "'[   ' 'AU1'  '<<'  α  '>>'  '/' @  Eo ,  Ei  '/' '[   ' '<<'  ∃  y1  ..  yn ,  β ,  '/' COMM  Φ  '>>' ']' ']'") : bi_scope.

Notation "'AU1' '<<' α '>>' @ Eo , Ei '<<' β , 'COMM' Φ '>>'" :=
  (atomic1_update (TA:=TeleO) (TB:=TeleO) Eo Ei
                 (tele_app (TT:=TeleO) α%I)
                 (tele_app (TT:=TeleO) $ tele_app (TT:=TeleO) β%I)
                 (tele_app (TT:=TeleO) $ tele_app (TT:=TeleO) Φ%I)
  )
  (at level 20, Eo, Ei, α, β, Φ at level 200,
   format "'[   ' 'AU1'  '<<'  α  '>>'  '/' @  Eo ,  Ei  '/' '[   ' '<<'  β ,  '/' COMM  Φ  '>>' ']' ']'") : bi_scope.

(** Notation: Atomic accessors *)
Notation "'AACC1' '<<' ∀ x1 .. xn , α 'ABORT' P '>>' @ Eo , Ei '<<' ∃ y1 .. yn , β , 'COMM' Φ '>>'" :=
  (atomic1_acc (TA:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. ))
              (TB:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
              Eo Ei
              (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
                    λ x1, .. (λ xn, α%I) ..)
              P%I
              (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
                    λ x1, .. (λ xn,
                      tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
                      (λ y1, .. (λ yn, β%I) .. )
                     ) .. )
              (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
                    λ x1, .. (λ xn,
                      tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
                      (λ y1, .. (λ yn, Φ%I) .. )
                     ) .. )
  )
  (at level 20, Eo, Ei, α, P, β, Φ at level 200, x1 binder, xn binder, y1 binder, yn binder,
   format "'[     ' 'AACC1'  '[   ' '<<'  ∀  x1  ..  xn ,  α  '/' ABORT  P  '>>'  ']' '/' @  Eo ,  Ei  '/' '[   ' '<<'  ∃  y1  ..  yn ,  β ,  '/' COMM  Φ  '>>' ']' ']'") : bi_scope.

Notation "'AACC1' '<<' ∀ x1 .. xn , α 'ABORT' P '>>' @ Eo , Ei '<<' β , 'COMM' Φ '>>'" :=
  (atomic1_acc (TA:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. ))
              (TB:=TeleO)
              Eo Ei
              (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
                        λ x1, .. (λ xn, α%I) ..)
              P%I
              (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
                        λ x1, .. (λ xn, tele_app (TT:=TeleO) β%I) .. )
              (tele_app (TT:=TeleS (λ x1, .. (TeleS (λ xn, TeleO)) .. )) $
                        λ x1, .. (λ xn, tele_app (TT:=TeleO) Φ%I) .. )
  )
  (at level 20, Eo, Ei, α, P, β, Φ at level 200, x1 binder, xn binder,
   format "'[     ' 'AACC1'  '[   ' '<<'  ∀  x1  ..  xn ,  α  '/' ABORT  P  '>>'  ']' '/' @  Eo ,  Ei  '/' '[   ' '<<'  β ,  '/' COMM  Φ  '>>' ']' ']'") : bi_scope.

Notation "'AACC1' '<<' α 'ABORT' P '>>' @ Eo , Ei '<<' ∃ y1 .. yn , β , 'COMM' Φ '>>'" :=
  (atomic1_acc (TA:=TeleO)
              (TB:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
              Eo Ei
              (tele_app (TT:=TeleO) α%I)
              P%I
              (tele_app (TT:=TeleO) $
                        tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
                        (λ y1, .. (λ yn, β%I) ..))
              (tele_app (TT:=TeleO) $
                        tele_app (TT:=TeleS (λ y1, .. (TeleS (λ yn, TeleO)) .. ))
                        (λ y1, .. (λ yn, Φ%I) ..))
  )
  (at level 20, Eo, Ei, α, P, β, Φ at level 200, y1 binder, yn binder,
   format "'[     ' 'AACC1'  '[   ' '<<'  α  '/' ABORT  P  '>>'  ']' '/' @  Eo ,  Ei  '/' '[   ' '<<'  ∃  y1  ..  yn ,  β ,  '/' COMM  Φ  '>>' ']' ']'") : bi_scope.

Notation "'AACC1' '<<' α 'ABORT' P '>>' @ Eo , Ei '<<' β , 'COMM' Φ '>>'" :=
  (atomic1_acc (TA:=TeleO)
              (TB:=TeleO)
              Eo Ei
              (tele_app (TT:=TeleO) α%I)
              P%I
                 (tele_app (TT:=TeleO) $ tele_app (TT:=TeleO) β%I)
                 (tele_app (TT:=TeleO) $ tele_app (TT:=TeleO) Φ%I)
  )
  (at level 20, Eo, Ei, α, P, β, Φ at level 200,
   format "'[     ' 'AACC1'  '[   ' '<<'  α  '/' ABORT  P  '>>'  ']' '/' @  Eo ,  Ei  '/' '[   ' '<<'  β ,  '/' COMM  Φ  '>>' ']' ']'") : bi_scope.

(** Lemmas about AU *)
Section lemmas.
  Context `{BiFUpd PROP} {TA TB : tele}.
  Implicit Types (α : TA → PROP) (β Φ : TA → TB → PROP) (P : PROP).

  Local Existing Instances atomic1_update_pre_mono atomic_update_pre_mono.

  (* Can't be in the section above as that fixes the parameters *)
  Global Instance atomic1_acc_ne Eo Ei n :
    Proper (
        pointwise_relation TA (dist n) ==>
        dist n ==>
        pointwise_relation TA (pointwise_relation TB (dist n)) ==>
        pointwise_relation TA (pointwise_relation TB (dist n)) ==>
        dist n
    ) (atomic1_acc (PROP:=PROP) Eo Ei).
  Proof. solve_proper. Qed.

  Global Instance atomic1_update_ne Eo Ei n :
    Proper (
        pointwise_relation TA (dist n) ==>
        pointwise_relation TA (pointwise_relation TB (dist n)) ==>
        pointwise_relation TA (pointwise_relation TB (dist n)) ==>
        dist n
    ) (atomic1_update (PROP:=PROP) Eo Ei).
  Proof.
    rewrite atomic1_update_eq /atomic1_update_def /atomic1_update_pre. solve_proper.
  Qed.

  (* AU implies AU1 *)
  Lemma atomic_update_atomic1_update Eo Ei α β Φ :
    atomic_update Eo Ei α β Φ -∗ atomic1_update Eo Ei α β Φ.
  Proof.
    rewrite atomic.atomic_update_unseal atomic1_update_eq /atomic1_update_def /=.
    iIntros "HAU".
    iApply (greatest_fixpoint_coiter _ (λ _, atomic.atomic_update_def Eo Ei α β Φ)); last done.
    iIntros "!> *". rewrite {1}/atomic.atomic_update_def /= greatest_fixpoint_unfold.
    by iApply atomic_acc_atomic1_acc.
  Qed.

  Lemma atomic1_update_mask_weaken Eo1 Eo2 Ei α β Φ :
    Eo1 ⊆ Eo2 →
    atomic1_update Eo1 Ei α β Φ -∗ atomic1_update Eo2 Ei α β Φ.
  Proof.
    rewrite atomic1_update_eq {2}/atomic1_update_def /=.
    iIntros (Heo) "HAU".
    iApply (greatest_fixpoint_coiter _ (λ _, atomic1_update_def Eo1 Ei α β Φ)); last done.
    iIntros "!> *". rewrite {1}/atomic1_update_def /= greatest_fixpoint_unfold.
    iApply atomic1_acc_mask_weaken. done.
  Qed.

  (** The elimination form: an atomic accessor *)
  Lemma aupd1_aacc Eo Ei α β Φ :
    atomic1_update Eo Ei α β Φ -∗
    atomic1_acc Eo Ei α (atomic1_update Eo Ei α β Φ) β Φ.
  Proof using Type*.
    rewrite atomic1_update_eq {1}/atomic1_update_def /=. iIntros "HUpd".
    iPoseProof (greatest_fixpoint_unfold_1 with "HUpd") as "HUpd". done.
  Qed.

  (* This lets you eliminate atomic updates with iMod. *)
  Global Instance elim_mod_aupd1 φ Eo Ei E α β Φ Q Q' :
    (∀ R, ElimModal φ false false (|={E,Ei}=> R) R Q Q') →
    ElimModal (φ ∧ Eo ⊆ E) false false
              (atomic1_update Eo Ei α β Φ)
              (∃.. x, α x ∗
                       (α x ={Ei,E}=∗ atomic1_update Eo Ei α β Φ) ∧
                       ▷ (∀.. y, β x y ={Ei,E}=∗ Φ x y))
              Q Q'.
  Proof.
    intros ?. rewrite /ElimModal /= =>-[??]. iIntros "[AU Hcont]".
    iPoseProof (aupd1_aacc with "AU") as "AC".
    iMod (atomic1_acc_mask_weaken with "AC"); first done.
    iApply "Hcont". done.
  Qed.

  Lemma aupd1_intro P Q α β Eo Ei Φ :
    Affine P → Persistent P →
    (P ∗ Q -∗ atomic1_acc Eo Ei α Q β Φ) →
    P ∗ Q -∗ atomic1_update Eo Ei α β Φ.
  Proof.
    rewrite atomic1_update_eq {1}/atomic1_update_def /=.
    iIntros (?? HAU) "[#HP HQ]".
    iApply (greatest_fixpoint_coiter _ (λ _, Q)); last done. iIntros "!>" ([]) "HQ".
    iApply HAU. by iFrame.
  Qed.

  Lemma aacc1_intro Eo Ei α P β Φ :
    Ei ⊆ Eo → ⊢ (∀.. x, α x -∗
    ((α x ={Eo}=∗ P) ∧ ▷ (∀.. y, β x y ={Eo}=∗ Φ x y)) -∗
    atomic1_acc Eo Ei α P β Φ).
  Proof.
    iIntros (? x) "Hα Hclose".
    iMod fupd_mask_subseteq as "Hclose'"; last iModIntro; first set_solver.
    iExists x. iFrame. iSplitWith "Hclose".
    - iIntros "Hα". iMod "Hclose'" as "_". iApply "Hclose". done.
    - iIntros "!>" (y) "Hβ". iMod "Hclose'" as "_". iApply "Hclose". done.
  Qed.

  (* This lets you open invariants etc. when the goal is an atomic accessor. *)
  Global Instance elim_acc_aacc1 {X} E1 E2 Ei (α' β' : X → PROP) γ' α β Pas Φ :
    ElimAcc (X:=X) True (fupd E1 E2) (fupd E2 E1) α' β' γ'
            (atomic1_acc E1 Ei α Pas β Φ)
            (λ x', atomic1_acc E2 Ei α (β' x' ∗ (γ' x' -∗? Pas))%I β
                (λ.. x y, β' x' ∗ (γ' x' -∗? Φ x y))
            )%I.
  Proof.
    (* FIXME: Is there any way to prevent maybe_wand from unfolding?
       It gets unfolded by env_cbv in the proofmode, ideally we'd like that
       to happen only if one argument is a constructor. *)
    iIntros (_) "Hinner >Hacc". iDestruct "Hacc" as (x') "[Hα' Hclose]".
    iMod ("Hinner" with "Hα'") as (x) "[Hα Hclose']".
    iMod (fupd_mask_subseteq) as "Hclose''"; last iModIntro; first done.
    iExists x. iFrame. iSplitWith "Hclose'".
    - iIntros "Hα". iMod "Hclose''" as "_".
      iMod ("Hclose'" with "Hα") as "[Hβ' HPas]".
      iMod ("Hclose" with "Hβ'") as "Hγ'".
      iModIntro. destruct (γ' x'); iApply "HPas"; done.
    - iIntros "!>" (y) "Hβ". iMod "Hclose''" as "_".
      iMod ("Hclose'" with "Hβ") as "Hβ'".
      (* FIXME: Using ssreflect rewrite does not work, see Coq bug #7773. *)
      rewrite ->!tele_app_bind. iDestruct "Hβ'" as "[Hβ' HΦ]".
      iMod ("Hclose" with "Hβ'") as "Hγ'".
      iModIntro. destruct (γ' x'); iApply "HΦ"; done.
  Qed.

  (* Everything that fancy updates can eliminate without changing, atomic
  accessors can eliminate as well.  This is a forwarding instance needed becuase
  atomic1_acc is becoming opaque. *)
  Global Instance elim_modal_acc p q φ P P' Eo Ei α Pas β Φ :
    (∀ Q, ElimModal φ p q P P' (|={Eo,Ei}=> Q) (|={Eo,Ei}=> Q)) →
    ElimModal φ p q P P'
              (atomic1_acc Eo Ei α Pas β Φ)
              (atomic1_acc Eo Ei α Pas β Φ).
  Proof. intros Helim. apply Helim. Qed.

  Lemma aacc1_aacc {TA' TB' : tele} E1 E1' E2 E3
        α P β Φ
        (α' : TA' → PROP) P' (β' Φ' : TA' → TB' → PROP) :
    E1' ⊆ E1 →
    atomic1_acc E1' E2 α P β Φ -∗
    (∀.. x, α x -∗ atomic1_acc E2 E3 α' (α x ∗ (P ={E1}=∗ P')) β'
            (λ.. x' y', (α x ∗ (P ={E1}=∗ Φ' x' y'))
                    ∨ ∃.. y, β x y ∗ (Φ x y ={E1}=∗ Φ' x' y'))) -∗
    atomic1_acc E1 E3 α' P' β' Φ'.
  Proof.
    iIntros (?) "Hupd Hstep".
    iMod (atomic1_acc_mask_weaken with "Hupd") as (x) "[Hα Hclose]"; first done.
    iMod ("Hstep" with "Hα") as (x') "[Hα' Hclose']".
    iModIntro. iExists x'. iFrame "Hα'". iSplit.
    - iIntros "Hα'". iDestruct "Hclose'" as "[Hclose' _]".
      iMod ("Hclose'" with "Hα'") as "[Hα Hupd]".
      iDestruct "Hclose" as "[Hclose _]".
      iMod ("Hclose" with "Hα"). iApply "Hupd". auto.
    - iIntros "!>" (y') "Hβ'". iDestruct "Hclose'" as "[_ Hclose']".
      iMod ("Hclose'" with "Hβ'") as "Hres".
      (* FIXME: Using ssreflect rewrite does not work, see Coq bug #7773. *)
      rewrite ->!tele_app_bind. iDestruct "Hres" as "[[Hα HΦ']|Hcont]".
      + (* Abort the step we are eliminating *)
        iDestruct "Hclose" as "[Hclose _]".
        iMod ("Hclose" with "Hα") as "HP".
        iApply "HΦ'". done.
      + (* Complete the step we are eliminating *)
        iDestruct "Hclose" as "[_ Hclose]".
        iDestruct "Hcont" as (y) "[Hβ HΦ']".
        iMod ("Hclose" with "Hβ") as "HΦ".
        iApply "HΦ'". done.
  Qed.

  Lemma aacc1_aupd {TA' TB' : tele} E1 E1' E2 E3
        α β Φ
        (α' : TA' → PROP) P' (β' Φ' : TA' → TB' → PROP) :
    E1' ⊆ E1 →
    atomic1_update E1' E2 α β Φ -∗
    (∀.. x, α x -∗ atomic1_acc E2 E3 α' (α x ∗ (atomic1_update E1' E2 α β Φ ={E1}=∗ P')) β'
            (λ.. x' y', (α x ∗ (atomic1_update E1' E2 α β Φ ={E1}=∗ Φ' x' y'))
                    ∨ ∃.. y, β x y ∗ (Φ x y ={E1}=∗ Φ' x' y'))) -∗
    atomic1_acc E1 E3 α' P' β' Φ'.
  Proof.
    iIntros (?) "Hupd Hstep". iApply (aacc1_aacc with "[Hupd] Hstep"); first done.
    iApply aupd1_aacc; done.
  Qed.

  Lemma aacc1_aupd_commit {TA' TB' : tele} E1 E1' E2 E3
        α β Φ
        (α' : TA' → PROP) P' (β' Φ' : TA' → TB' → PROP) :
    E1' ⊆ E1 →
    atomic1_update E1' E2 α β Φ -∗
    (∀.. x, α x -∗ atomic1_acc E2 E3 α' (α x ∗ (atomic1_update E1' E2 α β Φ ={E1}=∗ P')) β'
            (λ.. x' y', ∃.. y, β x y ∗ (Φ x y ={E1}=∗ Φ' x' y'))) -∗
    atomic1_acc E1 E3 α' P' β' Φ'.
  Proof.
    iIntros (?) "Hupd Hstep". iApply (aacc1_aupd with "Hupd"); first done.
    iIntros (x) "Hα". iApply atomic1_acc_wand; last first.
    { iApply "Hstep". done. }
    (* FIXME: Using ssreflect rewrite does not work, see Coq bug #7773. *)
    iSplit; first by eauto. iIntros "!>" (??) "?". rewrite ->!tele_app_bind. by iRight.
  Qed.

  Lemma aacc1_aupd_abort {TA' TB' : tele} E1 E1' E2 E3
        α β Φ
        (α' : TA' → PROP) P' (β' Φ' : TA' → TB' → PROP) :
    E1' ⊆ E1 →
    atomic1_update E1' E2 α β Φ -∗
    (∀.. x, α x -∗ atomic1_acc E2 E3 α' (α x ∗ (atomic1_update E1' E2 α β Φ ={E1}=∗ P')) β'
            (λ.. x' y', α x ∗ (atomic1_update E1' E2 α β Φ ={E1}=∗ Φ' x' y'))) -∗
    atomic1_acc E1 E3 α' P' β' Φ'.
  Proof.
    iIntros (?) "Hupd Hstep". iApply (aacc1_aupd with "Hupd"); first done.
    iIntros (x) "Hα". iApply atomic1_acc_wand; last first.
    { iApply "Hstep". done. }
    (* FIXME: Using ssreflect rewrite does not work, see Coq bug #7773. *)
    iSplit; first by eauto. iIntros "!>" (??) "?". rewrite ->!tele_app_bind. by iLeft.
  Qed.

End lemmas.

(** This adds a few TC instances that are not automatically inferred. *)
  Section atomic.
  Context `{BiFUpd PROP} {TA TB : tele}.
  Implicit Types (α : TA → PROP).
  Implicit Types (β Φ : TA → TB → PROP).

  Global Instance aacc1_proper Eo Ei :
    Proper (
      pointwise_relation TA (≡) ==>
      (≡) ==>
      pointwise_relation TA (pointwise_relation TB (≡)) ==>
      pointwise_relation TA (pointwise_relation TB (≡)) ==>
      (≡)
    ) (atomic1_acc (PROP:=PROP) Eo Ei).
  Proof. solve_proper. Qed.

  Global Instance aacc1_mono' Eo Ei :
    Proper (
      pointwise_relation TA (≡) ==>
      (⊢) ==>
      pointwise_relation TA (pointwise_relation TB (flip (⊢))) ==>
      pointwise_relation TA (pointwise_relation TB (⊢)) ==>
      (⊢)
    ) (atomic1_acc (PROP:=PROP) Eo Ei).
  Proof.
    intros α1 α2 Hα P1 P2 HP β1 β2 Hβ Φ1 Φ2 HΦ. rewrite/atomic1_acc.
    repeat f_equiv; by rewrite ?Hα ?HP.
  Qed.

  Global Instance aacc1_flip_mono' Eo Ei :
    Proper (
      pointwise_relation TA (≡) ==>
      flip (⊢) ==>
      pointwise_relation TA (pointwise_relation TB (⊢)) ==>
      pointwise_relation TA (pointwise_relation TB (flip (⊢))) ==>
      flip (⊢)
    ) (atomic1_acc (PROP:=PROP) Eo Ei).
  Proof. repeat intro. by rewrite -aacc1_mono'. Qed.

  Global Instance aupd1_proper Eo Ei :
    Proper (
      pointwise_relation TA (≡) ==>
      pointwise_relation TA (pointwise_relation TB (≡)) ==>
      pointwise_relation TA (pointwise_relation TB (≡)) ==>
      (≡)
    ) (atomic1_update (PROP:=PROP) Eo Ei).
  Proof.
    rewrite atomic1_update_eq /atomic1_update_def /atomic1_update_pre.
    solve_proper.
  Qed.

  Global Instance aupd1_mono' Eo Ei :
    Proper (
      pointwise_relation TA (≡) ==>
      pointwise_relation TA (pointwise_relation TB (flip (⊢))) ==>
      pointwise_relation TA (pointwise_relation TB (⊢)) ==>
      (⊢)
    ) (atomic1_update (PROP:=PROP) Eo Ei).
  Proof.
    rewrite atomic1_update_eq /atomic1_update_def /atomic1_update_pre.
    solve_proper.
  Qed.

  Global Instance aupd1_flip_mono' Eo Ei :
    Proper (
      pointwise_relation TA (≡) ==>
      pointwise_relation TA (pointwise_relation TB (⊢)) ==>
      pointwise_relation TA (pointwise_relation TB (flip (⊢))) ==>
      flip (⊢)
    ) (atomic1_update (PROP:=PROP) Eo Ei).
  Proof. repeat intro. by rewrite -aupd1_mono'. Qed.

  (* TODO: this is duplicated from bedrock.lib.aupd. This should be cleaned up
    once we unify AU/AC with AU1/AC1. *)
  (** Learn from an atomic precondition. (To use the bound variables
    [x], pick [P := ∃ x, P' x].) *)
  Lemma aupd1_obs_fupd P Eo Ei α β Φ :
    atomic1_update Eo Ei α β Φ ⊢
    (∀.. x, α x ={Ei}=∗ α x ∗ P) ={Eo}=∗ atomic1_update Eo Ei α β Φ ∗ P.
  Proof.
    iIntros "AU Obs". iMod "AU" as (x) "[Hα Close]".
    iMod ("Obs" with "Hα") as "[Hα $]". by iMod ("Close" with "Hα") as "$".
  Qed.
  Lemma aupd1_obs_wand P Eo Ei α β Φ :
    atomic1_update Eo Ei α β Φ ⊢
    (∀.. x, α x -∗ α x ∗ P) ={Eo}=∗ atomic1_update Eo Ei α β Φ ∗ P.
  Proof.
    iIntros "AU Obs". iApply (aupd1_obs_fupd with "AU [Obs]").
    iIntros (x) "Hα !>". by iApply "Obs".
  Qed.
  Lemma aupd1_obs P Eo Ei α β Φ :
    (∀.. x, α x ⊢ α x ∗ P) →
    atomic1_update Eo Ei α β Φ ⊢ |={Eo}=> atomic1_update Eo Ei α β Φ ∗ P.
  Proof.
    rewrite tforall_forall. iIntros (Hobs) "AU".
    iMod (aupd1_obs_wand P with "AU []") as "$"; auto.
    iIntros (x). iApply Hobs.
  Qed.
End atomic.

Theorem of_envs_alt' {PROP : bi} (Δ : envs PROP) :
  of_envs Δ ⊣⊢ (⌜envs_wf Δ⌝ ∧ □ [∧] env_intuitionistic Δ) ∗ [∗] env_spatial Δ.
Proof.
  rewrite of_envs_alt. iSplit; [iIntros "[$[$$]]" | iIntros "[[$$]$]"].
Qed.

(** The tactic [iAuIntro1] applies lemma [aupd1_aacc] to change an Iris
    proof mode goal [P := atomic1_update Eo Ei α β Φ] into [atomic1_acc Eo
    Ei α P β Φ]. *)
Section coq_tactic.
  Import coq_tactics.
  Context `{BiFUpd PROP} {TA TB : tele}.
  Implicit Types (α : TA → PROP).
  Implicit Types (β Φ : TA → TB → PROP).

  Lemma tac_aupd1_intro Γp Γs n α β Eo Ei Φ P :
    P = env_to_prop Γs →
    envs_entails (Envs Γp Γs n) (atomic1_acc Eo Ei α P β Φ) →
    envs_entails (Envs Γp Γs n) (atomic1_update Eo Ei α β Φ).
  Proof.
    intros ->. rewrite envs_entails_unseal of_envs_eq /=.
    setoid_rewrite env_to_prop_sound =>HAU.
    iIntros "[#P [#Q R]]". iStopProof. apply: aupd1_intro.
    iIntros "[#P Q]". iApply HAU.
    iSplit; first iDestruct "P" as "[$ _]".
    iSplit; last done.
    iDestruct "P" as "[_ $]".
  Qed.
End coq_tactic.

Lemma test_before `{BiFUpd PROP} {TA TB : tele} Eo Ei α (β Φ : TA → TB → PROP) :
  atomic1_update Eo Ei α β Φ ⊢ atomic1_update Eo Ei α β Φ.
Proof. iIntros "AU". Fail iAuIntro. Abort.

Tactic Notation "iAuIntro1" :=
  iStartProof; eapply tac_aupd1_intro; [
    (* P = ...: make the P pretty *) reduction.pm_reflexivity
  | (* the new proof mode goal *) ].
Lemma test_after `{BiFUpd PROP} {TA TB : tele} Eo Ei α (β Φ : TA → TB → PROP) :
  atomic1_update Eo Ei α β Φ ⊢ atomic1_update Eo Ei α β Φ.
Proof. iIntros "AU". iAuIntro1. Abort.

Tactic Notation "iAaccIntro1" "with" constr(sel) :=
  iStartProof; lazymatch goal with
  | |- environments.envs_entails _ (@atomic1_acc ?PROP ?H ?TA ?TB ?Eo ?Ei ?α ?P ?β ?Φ) =>
    iApply (@aacc1_intro PROP H TA TB Eo Ei α P β Φ with sel);
    first try solve_ndisj; last iSplit
  | _ => fail "iAaccIntro1: Goal is not an atomic accessor"
  end.

(* From here on, prevent TC search from implicitly unfolding these. *)
#[global] Typeclasses Opaque atomic1_acc atomic1_update.

Section derived.
  Context `{BiFUpd PROP} {TA TB : tele}.
  Implicit Types (α : TA → PROP) (β Φ : TA → TB → PROP).

  Lemma atomic_update1_ppost_wand Eo Ei α β Φ1 Φ2 :
    atomic1_update Eo Ei α β Φ1 ⊢
    ▷ (∀.. x y, Φ1 x y -∗ Φ2 x y) -∗
    atomic1_update Eo Ei α β Φ2.
  Proof.
    iIntros "AU1 W". iAuIntro1; rewrite /atomic1_acc.
    iMod "AU1" as (x) "[A Cl]"; iExists _; iFrame "A"; iIntros "!>".
    iSplit. { iFrame "W". iIntros "A". iDestruct "Cl" as "[H _]". iApply ("H" with "A"). }
    iIntros "!> % B". iApply ("W" with "(Cl B)").
  Qed.

  (* Strictly weaker, but proven for consistency. *)
  Lemma atomic_update1_weak_ppost_wand Eo Ei α β Φ1 Φ2 :
    atomic1_update Eo Ei α β Φ1 ⊢
    (∀.. x y, Φ1 x y -∗ Φ2 x y) -∗
    atomic1_update Eo Ei α β Φ2.
  Proof. iIntros "AU1 W". iApply (atomic_update1_ppost_wand with "AU1 W"). Qed.
End derived.


Require Import Hoare.
Require Import Prog ProgMonad.
Require Import Pred PredCrash.
Require Import SepAuto.
Require Import AsyncDisk.
Require Import Hashmap.

Lemma step_hashmap_subset : forall T m vm hm p m' vm' hm' (v: T),
    step m vm hm p m' vm' hm' v ->
    exists l, hashmap_subset l hm hm'.
Proof.
  inversion 1; eauto.
Qed.

Hint Resolve step_hashmap_subset.

Lemma hashmap_subset_some_list_trans : forall hm hm' hm'',
    (exists l, hashmap_subset l hm hm') ->
    (exists l, hashmap_subset l hm' hm'') ->
    exists l, hashmap_subset l hm hm''.
Proof.
  eauto.
Qed.

Lemma finished_val_eq : forall T m vm hm (v:T),
    exists v', Finished m vm hm v = Finished m vm hm v'.
Proof. eauto. Qed.

Hint Resolve finished_val_eq.

Lemma exec_crashed_hashmap_subset' : forall T m m' vm vm' hm hm' p out,
  exec m vm hm p out
  -> (out = Crashed T m' hm' \/ exists v, out = Finished m' vm' hm' v)
  -> exists l, hashmap_subset l hm hm'.
Proof.
  intros.
  generalize dependent vm'.
  generalize dependent hm'.
  generalize dependent m'.
  induction H; subst; intuition; repeat deex; try congruence;
    try match goal with
        | [ H: @eq (outcome _) _ _ |- _ ] =>
          inversion H; subst
        end;
    eauto.

  eauto 7 using hashmap_subset_some_list_trans.
  eauto 7 using hashmap_subset_some_list_trans.

Unshelve.
  all: eauto.
Qed.

Lemma exec_crashed_hashmap_subset : forall T m m' vm hm hm' p out,
  exec m vm hm p out
  -> out = Crashed T m' hm'
  -> exists l, hashmap_subset l hm hm'.
Proof.
  intros.
  eapply exec_crashed_hashmap_subset'; eauto.

Unshelve.
  all: eauto.
Qed.

Ltac solve_hashmap_subset' :=
  match goal with
  | [ H: exec _ _ _ _ (Crashed _ _ _), Hpre: forall (_ : hashmap), _ =p=> ?pre _ _ _
      |- forall (_ : hashmap), _ =p=> ?pre _ _ _ ]
    => eapply exec_crashed_hashmap_subset in H as H'; eauto;
        intros;
        eapply pimpl_trans; try apply Hpre;
        autorewrite with crash_xform; cancel
  | [ |- context[hashmap_subset] ]
        => pred_apply; cancel
  end; try solve [
    repeat match goal with
    | [ H: forall (_ : hashmap), _ =p=> _ |- _ ] => clear H
    end; solve_hashmap_subset
  ].

Lemma corr3_from_corr2_failed:
  forall (TF TR: Type) m mr vmr hmr (p: prog TF) (r: prog TR) out
         (crash: hashmap -> pred) ppre rpre crashdone_p crashdone_r,
  exec_recover mr vmr hmr p r out
  -> TF = TR
  -> possible_crash m mr
  -> crash hmr m
  -> (forall hm', crash_xform (crash hm'
      * [[ exists l, hashmap_subset l hmr hm' ]])
      =p=> ppre vmr hm' crashdone_p crash)
  -> (forall hm', crash_xform (crash hm'
      * [[ exists l, hashmap_subset l hmr hm' ]])
      =p=> rpre Mem.empty_mem hm' crashdone_r crash)
  -> {{ ppre }} p
  -> {{ rpre }} r
  -> out <> RFailed TF TR.
Proof.
  intros.
  generalize dependent m.
  induction H; intros; try congruence.
  - edestruct H5; eauto.
    apply H3. eapply crash_xform_apply; eauto.
    pred_apply; cancel.
    repeat (destruct H7; try congruence).
    repeat (destruct H7; try congruence).
  - rewrite H0. eapply IHexec_recover; eauto.
    + eapply exec_crashed_hashmap_subset with (hm':=hm') in H as H'.
      intros.
      eapply pimpl_trans; try apply H4.
      autorewrite with crash_xform; cancel.
      eauto.
    + solve_hashmap_subset'.
    + edestruct H5; eauto.
      apply H3. eapply crash_xform_apply; eauto.
      solve_hashmap_subset'.
      repeat (destruct H9; try congruence).
      repeat (destruct H9; try congruence).
Qed.

Lemma corr3_from_corr2_finished:
  forall (TF TR: Type) m mr vmr hmr (p: prog TF) (r: prog TR) out
         (crash: hashmap -> pred) ppre rpre crashdone_p crashdone_r m' vm' hm' v,
  exec_recover mr vmr hmr p r out
  -> TF = TR
  -> possible_crash m mr
  -> crash hmr m
  -> (forall hm', crash_xform (crash hm'
      * [[ exists l, hashmap_subset l hmr hm' ]])
      =p=> ppre vmr hm' crashdone_p crash)
  -> (forall hm', crash_xform (crash hm'
      * [[ exists l, hashmap_subset l hmr hm' ]])
      =p=> rpre Mem.empty_mem hm' crashdone_r crash)
  -> {{ ppre }} p
  -> {{ rpre }} r
  -> out = RFinished TR m' vm' hm' v
  -> crashdone_p vm' hm' v m'.
Proof.
  intros.
  induction H; try congruence.
  edestruct H5; eauto.
  - apply H3. eapply crash_xform_apply; eauto.
    pred_apply; cancel.
  - destruct H8. destruct H8. destruct H8. destruct H8.
    inversion H8. congruence.
  - repeat (destruct H8; try congruence).
Qed.

Lemma corr3_from_corr2_recovered:
  forall (TF TR: Type) m mr vmr hmr (p: prog TF) (r: prog TR) out
         (crash: hashmap -> pred) ppre rpre crashdone_p crashdone_r m' vm' hm' v,
  exec_recover mr vmr hmr p r out
  -> TF = TR
  -> possible_crash m mr
  -> crash hmr m
  -> (forall hm', crash_xform (crash hm'
      * [[ exists l, hashmap_subset l hmr hm' ]])
      =p=> ppre vmr hm' crashdone_p crash)
  -> (forall hm', crash_xform (crash hm'
      * [[ exists l, hashmap_subset l hmr hm' ]])
      =p=> rpre Mem.empty_mem hm' crashdone_r crash)
  -> {{ ppre }} p
  -> {{ rpre }} r
  -> out = RRecovered TF m' vm' hm' v
  -> crashdone_r vm' hm' v m'.
Proof.
  intros.
  generalize dependent m.
  induction H; intros; try congruence.
  - eapply corr3_from_corr2_finished; eauto.
    clear IHexec_recover H2.
    edestruct H5; eauto.
    + apply H3. eapply crash_xform_apply; eauto.
      pred_apply; cancel.
    + repeat (destruct H2; try congruence).
    + destruct H2. destruct H2. destruct H2.
      inversion H2. eauto.
    + solve_hashmap_subset'.
    + solve_hashmap_subset'.
    + congruence.
  - eapply IHexec_recover; eauto; clear IHexec_recover H2.
    + solve_hashmap_subset'.
    + solve_hashmap_subset'.
    + inversion H7. auto.
    + edestruct H5; eauto.
      * apply H3. eapply crash_xform_apply; eauto.
        solve_hashmap_subset'.
      * repeat (destruct H2; try congruence).
      * repeat (destruct H2; try congruence).
Qed.

Theorem corr3_from_corr2: forall TF TR (p: prog TF) (r: prog TR) ppre rpre, {{ ppre }} p
  -> {{ rpre }} r
  -> {{ fun vm hm done crashdone => exists crash,
        ppre vm hm done crash
        * [[ forall hm',
          crash_xform (crash hm'
          * [[ exists l, hashmap_subset l hm hm' ]])
          =p=> rpre Mem.empty_mem hm' crashdone crash ]] }} p >> r.
Proof.
  unfold corr3; intros.
  destruct H1 as [crash H1].
  destruct_lift H1.
  inversion H2; subst.
  - exfalso.
    edestruct H; eauto; repeat deex; try congruence.
  - left.
    repeat eexists.
    edestruct H; eauto; repeat deex; try congruence.
  - exfalso.
    edestruct H; eauto; repeat deex; try congruence.
    inversion H8; clear H8; subst.
    eapply corr3_from_corr2_failed; eauto.
    solve_hashmap_subset'.
    solve_hashmap_subset'.
  - edestruct H; eauto; repeat deex; try congruence.
    inversion H8; clear H8; subst.
    clear H H1 H2 ppre.
    right. repeat eexists.
    eapply corr3_from_corr2_finished; eauto.
    solve_hashmap_subset'.
    solve_hashmap_subset'.
  - edestruct H; eauto; repeat deex; try congruence.
    inversion H8; clear H8; subst.
    clear H H1 H2 ppre.
    right. repeat eexists.
    eapply corr3_from_corr2_recovered; eauto.
    solve_hashmap_subset'.
    solve_hashmap_subset'.
Qed.

Theorem corr3_from_corr2_rx :
  forall TF TR RF RR (p: prog TF) (r:  prog TR)
         (rxp : TF -> prog RF) (rxr : TR -> prog RR)
         ppre rpre,
  {{ ppre }} Bind p rxp
  -> {{ rpre }} Bind r rxr
  -> {{ fun vm hm done crashdone => exists crash,
        ppre vm hm done crash
        * [[ forall hm',
          crash_xform (crash hm'
          * [[ exists l, hashmap_subset l hm hm' ]])
          =p=> rpre Mem.empty_mem hm' crashdone crash ]] }} Bind p rxp >> Bind r rxr.
Proof.
  intros.
  apply corr3_from_corr2; eauto.
Qed.

Ltac eassign_idempred :=
  match goal with
  | [ H : crash_xform ?realcrash =p=> crash_xform ?body |- ?realcrash =p=> (_ ?hm') ] =>
    let t := eval pattern hm' in body in
    match eval pattern hm' in body with
    | ?bodyf hm' =>
      instantiate (1 := (fun hm => (exists p, p * [[ crash_xform p =p=> crash_xform (bodyf hm) ]])%pred))
    end
  | [ |- ?body =p=> (_ ?hm) ] =>
    let t := eval pattern hm in body in
    match eval pattern hm in body with
    | ?bodyf hm =>
      instantiate (1 := (fun hm' => (exists p, p * [[ crash_xform p =p=> crash_xform (bodyf hm') ]])%pred));
      try (cancel; xform_norm; cancel)
    end
  end.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import path.
Require Import Eqdep.
Require Import Relation_Operators.
From fcsl
Require Import axioms pred prelude ordtype finmap pcm unionmap heap.
From DiSeL
Require Import Freshness State EqTypeX Protocols Worlds NetworkSem Rely.
From DiSeL
Require Import Actions Injection Process Always HoareTriples InferenceRules.
From DiSeL
Require Import InductiveInv While.
From DiSeL
Require Import CalculatorProtocol CalculatorInvariant.
From DiSeL
Require Import SeqLib.

Section CalculatorRecieve.

Variable l : Label.

Variable f : input -> option nat.
Variable prec : input -> bool.

Variable cs: seq nid.
Variable cls : seq nid.
(* All nodes *)
Notation nodes := (cs ++ cls).
(* All nodes are unique *)
Hypothesis Huniq : uniq nodes.

(* Protocol and its transitions *)

Notation cal := (cal_with_inv l f prec cs cls).
Notation sts := (snd_trans cal).
Notation rts := (rcv_trans cal).

Notation W := (mkWorld cal).

(* Variable d : dstatelet. *)
(* Hypothesis C : coh cal d. *)
(* Check proj2 C. *)
(* Check cal_inv_resp _ _ _ _ _ _ _ _ _ _ _ _ (proj1 C)(proj2 C). *)

Variable cl : nid.
Hypothesis  Hc : cl \in cls.

Program Definition tryrecv_resp_act := act (@tryrecv_action_wrapper W cl
      (fun k _ t b => (k == l) && (t == resp)) _).
Next Obligation. by case/andP:H=>/eqP->; rewrite domPt inE/=. Qed.

Notation loc i := (getLocal cl (getStatelet i l)).
Notation st := (ptr_nat 1).

Export CalculatorProtocol.

(* The following spec relates outstanding requests in
   pre/postconditions and also ensures that we've got the right
   answer. *)
Program Definition tryrecv_resp :
  {rs : reqs}, DHT [cl, W]
  (fun i => loc i = st :-> rs,
   fun (r : option perm) m =>
     match r with
     | Some (from, _, ms) =>
       let v := head 0 ms in
       let args := behead ms in
       exists rs' : reqs,
       [/\ loc m = st :-> rs',
        perm_eq rs ((cl, from, args) :: rs') &
        f args = Some v]
     | None => loc m = st :-> rs
     end)
  := Do tryrecv_resp_act.
Next Obligation.
apply: ghC=>i1 rs L1 C.
apply: act_rule=>i2 R1/=; split; first by case: (rely_coh R1).
move=>r i3 i4[Sf]S R3/=; rewrite -(rely_loc' l R1) in L1.
case: Sf=>_ _ _ _ /(_ l); clear C=>C.
case: S=>C2[|[l'][mid][tms][from][rt][pf][][E]Hin E1 Hw/=].
- by case=>?->Z; subst i3; rewrite (rely_loc' _ R3).
case/andP=>/eqP Z G; subst l'; set d := (getStatelet i2 l) in C E pf Hw *.
move=>Z->{r}; subst i3.
move: rt pf (coh_s l C2) Hin E1 Hw R3 C G.
rewrite prEq=>rt pf cohs Hin E1 Hw R3 C G.
case: Hin=>/=Z; do?[subst rt|case: Z]=>//Z; subst rt.
simpl in E1, Hw, R3; clear G.
rewrite /cr_wf/= in Hw.
case: tms E E1 R3 Hw=>t tms/= E E1 R3 Hw; subst t.
have A1: exists s', dsoup d = mid \\-> (Msg (TMsg resp tms) from cl true) \+ s'.
+ by move/esym/um_eta2: E=>->; exists (free mid (dsoup d)).
case: A1=>s' Es.

(* Some auxiliary facts *)
have Y : tms = head 0 tms :: behead tms.
- suff M: exists x xs, tms = x::xs by case:M=>x [xs]E'; subst tms.
  by case/andP: Hw=>_; case: (tms)=>//x xs _; exists x, xs.
have Y' : from \in cs.
- case: (proj1 C)=>Cs _ _ _. case: Cs=>Vs/(_ mid)Cs.
  rewrite Es in Vs Cs; move: (findPtUn Vs)=>Ez.
  by move: (Cs _ Ez)=>/=; rewrite/cohMsg/==>H; case: H.

(* Using the invariant *)
move: ((proj2 C) (proj1 C) cl from (head 0 tms) (behead tms) mid s' Hc Y')=>//=.
rewrite -!Y; move/(_ Es)=>F.
rewrite Y in Hw.

(* Proving the change in permissions *)
have X: (cl, from, (behead tms)) \in rs.
- by case/andP: Hw; rewrite (getStK (proj1 cohs) L1).
have P1: valid (dstate d) by apply: (cohVl C).
have P2: valid i2 by apply: (cohS (proj2 (rely_coh R1))).
have P3: l \in dom i2 by rewrite -(cohD(proj2(rely_coh R1)))domPt inE/=.
rewrite (rely_loc' _ R3)/= locE// /cr_step (getStK (proj1 cohs) L1)/=.
clear R3 Hw P1 P2 P3; exists (remove_elem rs (cl, from, (behead tms))).
move: (remove_elem_in rs (cl, from, (behead tms))); rewrite X.
by rewrite perm_eq_sym=>H.
Qed.

Definition receive_loop_cond (res : option nat) := res == None .

Definition receive_loop_inv (rs : reqs) :=
  fun r i =>
    match r with
     | Some v =>
       exists (rs' : reqs) from args ,
       [/\ loc i = st :-> rs',
        perm_eq rs ((cl, from, args) :: rs') &
        f args = r]
     | None => loc i = st :-> rs
    end.

Program Definition receive_loop' :
  {(rs : reqs)}, DHT [cl, W]
  (fun i => loc i = st :-> rs,
   fun (res : option nat) m =>
     exists (rs' : reqs) v from args ,
       [/\ res = Some v, loc m = st :-> rs',
        perm_eq rs ((cl, from, args) :: rs') &
        f args = res]) :=
  Do _ (@while cl W _ _ receive_loop_cond receive_loop_inv _
        (fun r => Do _ (
           r <-- tryrecv_resp;
           match r with
           | Some (_, _, msg) => ret _ _ (Some (head 0 msg))
           | None => ret _ _ None
           end)) None).

Next Obligation. by apply: with_spec x. Defined.
Next Obligation.
by move:H; rewrite /receive_loop_inv (rely_loc' _ H0).
Qed.
Next Obligation.
apply:ghC=>i1 rs[];rewrite /receive_loop_cond.
move/eqP=>->/=E1 C1; apply: step; apply: (gh_ex (g:=rs)).
apply: call_rule=>//={r}res i2; case: res; last first.
- move=>E2 C; apply:ret_rule=>i3 R2.
  by rewrite /receive_loop_inv (rely_loc' _ R2).
case; case=>from v msg[rs'][E2]P F C2.
apply:ret_rule=>i3 R2; rewrite /receive_loop_inv (rely_loc' _ R2).
by exists rs', from, (behead msg).
Qed.

Next Obligation.
apply: ghC=>i rs E1 C1; apply: (gh_ex (g:=rs)).
apply: call_rule=>//res m[].
rewrite /receive_loop_cond; case: res=>//=v _.
move=>[rs'][from][args][E2]Hp F C2.
by exists rs', v, from, args.
Qed.

(* Blocking receive-loop that always returns a result (but may not
   terminate) *)
Program Definition blocking_receive_resp :
  {(rs : reqs)}, DHT [cl, W]
  (fun i => loc i = st :-> rs,
   fun (res :  nat) m =>
     exists (rs': reqs) from args ,
       [/\ loc m = st :-> rs',
        perm_eq rs ((cl, from, args) :: rs') &
        f args = Some res]) :=
  Do _ (r <-- receive_loop';
        match r with
        | Some res => ret _ _ res
        | None => ret _ _ 0
        end).
Next Obligation.
apply: ghC=>i rs E1 C1; apply: step; apply: (gh_ex (g:=rs)).
apply: call_rule=>//res i2[rs'][v][from][args][Z]E2 H1 H2.
subst res=>C2; apply: ret_rule=>i3 R2.
by exists rs', from, args; rewrite (rely_loc' _ R2).
Qed.

(* Simple send_transition *)

Definition client_send_trans :=
  ProtocolWithInvariant.snd_transI (s2 l f prec cs cls).

Program Definition send_request server args :=
  act (@send_action_wrapper W cal cl l (prEq cal) client_send_trans _
                            args server).
Next Obligation. by rewrite InE; right; rewrite InE. Qed.

Program Definition compute_f (server : nid) (args: seq nat) :
  DHT [cl, W]
  (fun i =>
     [/\ loc i = st :-> ([::] : reqs),
      prec args & server \in cs],
   fun (res : nat) m => loc m = st :-> ([::] : reqs) /\
                        f args = Some res) :=
  Do _ (send_request server args;;
        blocking_receive_resp).
Next Obligation.
move=>i1/=[E1 H2 H3].
apply: step; apply: act_rule=>i2 R1.
case: (rely_coh R1)=>_ C2.
have C': coh cal (getStatelet i2 l) by case: C2=>_ _ _ _/(_ l);rewrite prEq.
split=>//=.
- split=>//=.
  + by split=>//; case: C'.
  + rewrite/Actions.can_send -(cohD C2)/=domPt inE/= eqxx.
    by rewrite mem_cat Hc orbC.
  + rewrite/Actions.filter_hooks umfilt0=>???.
    move => F.
    apply sym_eq in F.
    move: F.
    by move/find_some; rewrite dom0.
move=>y i3 i4[S]/=;case=>Z[b]/=[F]E3 R3; subst y.
case: F=>/=F; subst b i3=>/=.
rewrite -(rely_loc' _ R1) in E1.
rewrite (getStK _ E1) in R3.
apply: (gh_ex (g:=[:: (cl, server, args)])).
apply: call_rule=>//.
- move=>C4; rewrite (rely_loc' _ R3) locE//; last by apply: (cohVl C').
  + by rewrite -(cohD C2) domPt inE/=.
  by apply: (cohS C2).
clear R3=>v i5[rs'][from][args'][E5]P5 R C.
suff X: args = args' /\ rs' = [::] by case: X=>Z X; subst args' rs'.
suff X': rs' = [::].
- subst rs'; split=>//; move/perm_eq_mem: P5=>P5.
  move/P5: (cl, server, args).
  by rewrite inE eqxx inE/==>/esym/eqP; case=>_->.
by case/perm_eq_size: P5=>/esym/size0nil.
Qed.

(**************************************************)
(*
Overall Implementation effort:

5 person-hours

*)
(**************************************************)

(* More elaborated client program, compting a list of values *)

Definition compute_list_spec server ys :=
  forall (xs_acc : (seq input) * (seq (input * nat))),
  DHT [cl, W]
   (fun i =>
     let: (xs, acc) := xs_acc in
     [/\ loc i = st :-> ([::] : reqs),
      all prec xs,
      all (fun e => f e.1 == Some e.2) acc,
      ys = map fst acc ++ xs &
      server \in cs],
   fun (res : seq (input * nat)) m =>
     [/\ loc m = st :-> ([::] : reqs),
      all (fun e => f e.1 == Some e.2) res &
      ys = map fst res]).

Program Definition compute_list_f server (xs : seq input) :
  DHT [cl, W]
   (fun i =>
     [/\ loc i = st :-> ([::] : reqs),
      all prec xs &
      server \in cs],
   fun (res : seq (input * nat)) m =>
     [/\ loc m = st :-> ([::] : reqs),
      all (fun e => f e.1 == Some e.2) res &
      xs = map fst res])
  :=
  Do (ffix (fun (rec : compute_list_spec server xs) xsa =>
    Do _ (let: (xs, acc) := xsa in
          if xs is x :: xs'
          then r <-- compute_f server x;
               let: acc' := rcons acc (x, r) in
               rec (xs', acc')
          else ret _ _ acc)) (xs, [::])).

Next Obligation.
move=>i1/=[L1]; move:l0 l4=>zs acc H1 H2 H3 H4.
case: zs H1 H3=>//=[_|z zs/andP[H1]H5] H3.
- by rewrite cats0 in H3;
  apply: ret_rule=>i2 R1; split=>//; rewrite ?(rely_loc' _ R1)//.
apply: step; apply: call_rule=>//r i2[L2]F C2.
apply: call_rule=>//_; split=>//; first by rewrite all_rcons/= F eqxx.
by rewrite map_rcons/= -cats1 -catA cat_cons/=.
Qed.

Next Obligation.
by move=>i1/=[L1]??; apply: call_rule=>//; rewrite cats0.
Qed.

End CalculatorRecieve.


Require Import Verdi.GhostSimulations.
Require Import VerdiRaft.Raft.
Require Import VerdiRaft.CommonTheorems.
Require Import VerdiRaft.SpecLemmas.
Require Import VerdiRaft.RaftRefinementInterface.
Require Import VerdiRaft.RefinementCommonDefinitions.

Require Import VerdiRaft.PrevLogCandidateEntriesTermInterface.
Require Import VerdiRaft.VotesCorrectInterface.
Require Import VerdiRaft.CroniesCorrectInterface.
Require Import VerdiRaft.LeaderSublogInterface.

Require Import VerdiRaft.PrevLogLeaderSublogInterface.

#[global]
Hint Extern 4 (@BaseParams) => apply base_params : typeclass_instances.
#[global]
Hint Extern 4 (@MultiParams _) => apply multi_params : typeclass_instances.
#[global]
Hint Extern 4 (@FailureParams _ _) => apply failure_params : typeclass_instances.

Section PrevLogLeaderSublogProof.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Context {rri : raft_refinement_interface}.

  Context {vci : votes_correct_interface}.
  Context {cci : cronies_correct_interface}.

  Context {lsi : leader_sublog_interface}.

  Context {plceti : prevLog_candidateEntriesTerm_interface}.

  Lemma prevLog_leader_sublog_init :
   raft_net_invariant_init prevLog_leader_sublog.
  Proof using.
    unfold raft_net_invariant_init, prevLog_leader_sublog.
    simpl. intuition.
  Qed.

  Lemma handleClientRequest_log_In :
    forall h st client id c out st' ps e,
      handleClientRequest h st client id c = (out, st', ps) ->
      In e (log st) -> In e (log st').
  Proof using.
    intros.
    find_apply_lem_hyp handleClientRequest_log.
    intuition.
    - find_rewrite. auto.
    - break_exists. intuition. find_rewrite. intuition.
  Qed.

  Lemma prevLog_leader_sublog_client_request :
    raft_net_invariant_client_request prevLog_leader_sublog.
  Proof using.
    unfold raft_net_invariant_client_request, prevLog_leader_sublog.
    intros. simpl in *.
    repeat find_higher_order_rewrite.
    find_apply_hyp_hyp. break_or_hyp.
    - break_if; eauto.
      find_copy_apply_lem_hyp handleClientRequest_type. break_and.
      repeat find_rewrite.
      eapply_prop_hyp In In; eauto.
      break_exists_exists. intuition.
      eauto using handleClientRequest_log_In.
    - find_apply_lem_hyp in_map_iff. break_exists. break_and.
      exfalso. eapply handleClientRequest_no_append_entries; eauto.
      subst. simpl in *. find_rewrite. eauto 10.
  Qed.

  Lemma prevLog_leader_sublog_timeout :
    raft_net_invariant_timeout prevLog_leader_sublog.
  Proof using.
    unfold raft_net_invariant_timeout, prevLog_leader_sublog.
    intros. simpl in *.
    repeat find_higher_order_rewrite.
    find_apply_hyp_hyp. break_or_hyp.
    - break_if; eauto.
      find_copy_apply_lem_hyp handleTimeout_type.
      intuition; repeat find_rewrite; try discriminate.
      eapply_prop_hyp In In; eauto.
      break_exists_exists. intuition.
      erewrite handleTimeout_log_same by eauto.
      eauto.
    - find_apply_lem_hyp in_map_iff. break_exists. break_and.
      exfalso. subst. simpl in *.
      eapply handleTimeout_packets; eauto.
      find_rewrite. eauto 10.
  Qed.

  Lemma handleAppendEntries_type_log :
    forall h st t n pli plt es ci st' ps,
      handleAppendEntries h st t n pli plt es ci = (st', ps) ->
      type st' = Follower \/ (type st' = type st /\ log st' = log st /\ currentTerm st' = currentTerm st).
  Proof using.
    unfold handleAppendEntries.
    intros.
    repeat break_match; repeat find_inversion; simpl in *; auto.
  Qed.

  Lemma prevLog_leader_sublog_append_entries :
    raft_net_invariant_append_entries prevLog_leader_sublog.
  Proof using.
    unfold raft_net_invariant_append_entries, prevLog_leader_sublog.
    intros. simpl in *.
    repeat find_higher_order_rewrite.
    find_apply_hyp_hyp. break_or_hyp.
    - find_eapply_lem_hyp app_cons_in_rest; [|solve[eauto]].
      find_rewrite. break_if; eauto.
      find_copy_apply_lem_hyp handleAppendEntries_type_log.
      intuition.
      + congruence.
      + repeat find_rewrite.
        eapply_prop_hyp In In; eauto.
    - find_apply_lem_hyp handleAppendEntries_not_append_entries.
      simpl in *. subst. exfalso. eauto 10.
  Qed.

  Lemma prevLog_leader_sublog_append_entries_reply :
    raft_net_invariant_append_entries_reply prevLog_leader_sublog.
  Proof using.
    unfold raft_net_invariant_append_entries_reply, prevLog_leader_sublog.
    intros. simpl in *.
    repeat find_higher_order_rewrite.
    find_apply_hyp_hyp. break_or_hyp.
    - find_eapply_lem_hyp app_cons_in_rest; [|solve[eauto]].
      find_rewrite. break_if; eauto.
      find_copy_apply_lem_hyp handleAppendEntriesReply_log.
      find_rewrite.
      find_copy_apply_lem_hyp handleAppendEntriesReply_type.
      intuition; repeat find_rewrite; try discriminate.
      eauto.
    - find_apply_lem_hyp in_map_iff. break_exists. break_and.
      exfalso. subst. simpl in *.
      find_apply_lem_hyp handleAppendEntriesReply_packets.
      subst. simpl in *. intuition.
  Qed.

  Lemma prevLog_leader_sublog_request_vote :
    raft_net_invariant_request_vote prevLog_leader_sublog.
  Proof using.
    unfold raft_net_invariant_request_vote, prevLog_leader_sublog.
    intros. simpl in *.
    repeat find_higher_order_rewrite.
    find_apply_hyp_hyp. break_or_hyp.
    - find_eapply_lem_hyp app_cons_in_rest; [|solve[eauto]].
      find_rewrite. break_if; eauto.
      find_copy_apply_lem_hyp handleRequestVote_log.
      find_copy_apply_lem_hyp handleRequestVote_type.
      intuition; repeat find_rewrite; try discriminate.
      eauto.
    - find_apply_lem_hyp handleRequestVote_no_append_entries.
      simpl in *. subst. exfalso. eauto 10.
  Qed.

  Definition candidateEntriesTerm_lowered (net : network) t p : Prop :=
    In p (nwPackets net) ->
    pBody p = RequestVoteReply t true ->
    currentTerm (nwState net (pDst p)) = t ->
    wonElection (dedup name_eq_dec (pSrc p :: votesReceived (nwState net (pDst p)))) = true ->
    type (nwState net (pDst p)) <> Candidate.

  Lemma deghost_packet_exists :
    forall net p,
      In p (nwPackets (deghost net)) ->
      exists (q : packet (params := raft_refined_multi_params (raft_params := raft_params))),
        In q (nwPackets net) /\ p = deghost_packet q.
  Proof using.
    unfold deghost.
    simpl.
    intros.
    do_in_map.
    eauto.
  Qed.

  Lemma prevLog_candidateEntriesTerm_lowered' :
    forall net,
      prevLog_candidateEntriesTerm net ->
      votes_correct net ->
      cronies_correct net ->
      forall p p' t leaderId prevLogIndex prevLogTerm entries leaderCommit,
        In p (nwPackets (deghost net)) ->
        pBody p = AppendEntries t leaderId prevLogIndex prevLogTerm
                                entries leaderCommit ->
        0 < prevLogTerm ->
        candidateEntriesTerm_lowered (deghost net) prevLogTerm p'.
  Proof using rri.
    unfold candidateEntriesTerm_lowered,
           cronies_correct, votes_correct.
    intros. break_and.
    rewrite deghost_spec.

    find_apply_lem_hyp deghost_packet_exists.
    find_apply_lem_hyp deghost_packet_exists.
    break_exists.  break_and. subst.
    eapply_prop_hyp votes_nw pBody. concludes.
    eapply_prop_hyp prevLog_candidateEntriesTerm pBody; auto.

    concludes.
    unfold candidateEntriesTerm in *. break_exists. break_and.

    match goal with
    | H : wonElection _ = _ |- _ =>
      eapply wonElection_one_in_common in H; [|clear H; eauto]
    end.
    break_exists. break_and.
    repeat match goal with
           | [ H : _ |- _ ] => rewrite deghost_spec in H
           end.

    simpl in *.
    break_or_hyp.
    - apply_prop_hyp cronies_votes In.
      assert (pDst x = x1) by (eapply_prop one_vote_per_term; eauto).
      subst. auto.
    - intro.
      assert (pDst x = x1).
      { eapply_prop one_vote_per_term;
        eapply_prop cronies_votes.
        - eapply_prop votes_received_cronies; eauto.
        - repeat find_reverse_rewrite. auto.
      }
      subst.
      concludes. contradiction.
  Qed.

  Lemma prevLog_candidateEntriesTerm_lowered :
    forall net,
      raft_intermediate_reachable net ->
      forall p p' t leaderId prevLogIndex prevLogTerm entries leaderCommit,
        In p (nwPackets net) ->
        pBody p = AppendEntries t leaderId prevLogIndex prevLogTerm
                                entries leaderCommit ->
        0 < prevLogTerm ->
        candidateEntriesTerm_lowered net prevLogTerm p'.
  Proof using plceti cci vci rri.
    intros net H.
    pattern net.
    apply lower_prop; auto.
    clear H net.
    intros.

    eapply prevLog_candidateEntriesTerm_lowered';
      eauto using prevLog_candidateEntriesTerm_invariant, votes_correct_invariant,
      cronies_correct_invariant.
  Qed.

  Lemma handleRequestVoteReply_type_term_won :
    forall h st src t v st',
      handleRequestVoteReply h st src t v = st' ->
      type st' = type st \/
      type st' = Follower \/
      (v = true /\
       wonElection (dedup name_eq_dec (src :: votesReceived st)) = true /\
       currentTerm st' = t).
  Proof using.
    unfold handleRequestVoteReply.
    intros.
    repeat break_match; repeat find_inversion; subst; simpl in *; auto; do_bool; intuition.
  Qed.

  Lemma prevLog_leader_sublog_request_vote_reply :
    raft_net_invariant_request_vote_reply prevLog_leader_sublog.
  Proof using plceti cci vci rri.
    unfold raft_net_invariant_request_vote_reply, prevLog_leader_sublog.
    intros. simpl in *.
    repeat find_higher_order_rewrite.
    find_apply_hyp_hyp.
    find_eapply_lem_hyp app_cons_in_rest; [|solve[eauto]].
    find_rewrite. break_if; eauto.
    find_copy_apply_lem_hyp handleRequestVoteReply_type.
    find_copy_apply_lem_hyp handleRequestVoteReply_log.
    intuition; repeat find_rewrite.
    - eauto.
    - discriminate.
    - exfalso.
      find_apply_lem_hyp handleRequestVoteReply_type_term_won.
      intuition; try congruence.
      eapply prevLog_candidateEntriesTerm_lowered with (p := p0) ; eauto.
      + congruence.
      + congruence.
  Qed.

  Lemma prevLog_leader_sublog_do_leader :
    raft_net_invariant_do_leader prevLog_leader_sublog.
  Proof using lsi.
    unfold raft_net_invariant_do_leader, prevLog_leader_sublog.
    intros. simpl in *.
    repeat find_higher_order_rewrite.
    find_apply_hyp_hyp. break_or_hyp.
    - break_if; eauto.
      find_copy_apply_lem_hyp doLeader_type. break_and.
      find_copy_apply_lem_hyp doLeader_log.
      repeat find_rewrite. eauto.
    - find_apply_lem_hyp in_map_iff. break_exists. break_and. subst.
      simpl in *.
      find_copy_eapply_lem_hyp doLeader_messages; eauto.
      intuition.
      + lia.
      + break_exists. break_and. subst.
        exists x0. find_apply_lem_hyp findAtIndex_elim. intuition.
        break_if.
        * congruence.
        * pose proof (leader_sublog_invariant_invariant _ ltac:(eauto)).
          unfold leader_sublog_invariant, leader_sublog_host_invariant in *. break_and.
          eauto.
  Qed.

  Lemma prevLog_leader_sublog_do_generic_server :
    raft_net_invariant_do_generic_server prevLog_leader_sublog.
  Proof using.
    unfold raft_net_invariant_do_generic_server, prevLog_leader_sublog.
    intros. simpl in *.
    repeat find_higher_order_rewrite.
    find_apply_hyp_hyp. break_or_hyp.
    - break_if; eauto.
      find_copy_eapply_lem_hyp doGenericServer_type. break_and.
      find_copy_eapply_lem_hyp doGenericServer_log.
      repeat find_rewrite.
      eauto.
    - find_copy_eapply_lem_hyp doGenericServer_packets.
      subst. simpl in *. intuition.
  Qed.

  Lemma prevLog_leader_sublog_state_same_packet_subset :
    raft_net_invariant_state_same_packet_subset prevLog_leader_sublog.
  Proof using.
    unfold raft_net_invariant_state_same_packet_subset, prevLog_leader_sublog.
    intros.
    find_apply_hyp_hyp.
    repeat find_reverse_higher_order_rewrite.
    eauto.
  Qed.

  Lemma prevLog_leader_sublog_reboot :
    raft_net_invariant_reboot prevLog_leader_sublog.
  Proof using.
    unfold raft_net_invariant_reboot, prevLog_leader_sublog, reboot.
    intros.  subst. simpl in *.
    repeat find_reverse_higher_order_rewrite.

    match goal with
    | [ H : context [In _ _], H' : In _ _ |- _ ] =>
      eapply (H leader) in H'; eauto
    end.
    - break_exists_exists. intuition.
      repeat find_higher_order_rewrite.
      break_if; subst; simpl in *; auto.
    - repeat find_higher_order_rewrite.
      break_if; subst; simpl in *; auto.
      discriminate.
    - repeat find_higher_order_rewrite.
      break_if; subst; simpl in *; auto.
  Qed.

  Lemma prevLog_leader_sublog_invariant :
    forall net,
      raft_intermediate_reachable net ->
      prevLog_leader_sublog net.
  Proof using plceti lsi cci vci rri.
    intros.
    apply raft_net_invariant; auto.
    - apply prevLog_leader_sublog_init.
    - apply prevLog_leader_sublog_client_request.
    - apply prevLog_leader_sublog_timeout.
    - apply prevLog_leader_sublog_append_entries.
    - apply prevLog_leader_sublog_append_entries_reply.
    - apply prevLog_leader_sublog_request_vote.
    - apply prevLog_leader_sublog_request_vote_reply.
    - apply prevLog_leader_sublog_do_leader.
    - apply prevLog_leader_sublog_do_generic_server.
    - apply prevLog_leader_sublog_state_same_packet_subset.
    - apply prevLog_leader_sublog_reboot.
  Qed.

  Instance pllsi : prevLog_leader_sublog_interface.
  Proof.
    constructor.
    apply prevLog_leader_sublog_invariant.
  Qed.
End PrevLogLeaderSublogProof.


From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq fintype finfun.
From extructures Require Import ord fmap.
From CoqUtils Require Import hseq word.
From MicroPolicies
Require Import lib.utils common.types symbolic.symbolic symbolic.exec
ifc.labels ifc.common.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import DoNotation.

Section Dev.

Local Open Scope label_scope.

Variable L : labType.
Variable mt : machine_types.
Variable mops : machine_ops mt.
Context {sregs : syscall_regs mt}.
Context {addrs : ifc_addrs mt}.

Inductive mem_tag :=
| MemInstr
| MemData of L.

Definition option_of_mem_tag t :=
  match t with
  | MemInstr => None
  | MemData l => Some l
  end.

Definition mem_tag_of_option t :=
  match t with
  | None => MemInstr
  | Some l => MemData l
  end.

Lemma option_of_mem_tagK : cancel option_of_mem_tag mem_tag_of_option.
Proof. by case. Qed.

Definition mem_tag_eqMixin := CanEqMixin option_of_mem_tagK.
Canonical mem_tag_eqType := EqType mem_tag mem_tag_eqMixin.

Import Symbolic.

Definition ifc_tags := {|
  pc_tag_type    := [eqType of L];
  reg_tag_type   := [eqType of L];
  mem_tag_type   := mem_tag_eqType;
  entry_tag_type := unit_eqType
|}.

(** Tag propagation rules. *)

Definition instr_rules
  (op : opcode) (tpc : L) (ts : hseq (tag_type ifc_tags) (inputs op)) :
  option (ovec ifc_tags op) :=
  let ret := fun rtpc (rt : type_of_result ifc_tags (outputs op)) => Some (@OVec ifc_tags op rtpc rt) in
  match op, ts, ret with
  | NOP, _, ret                             => ret tpc tt
  | CONST, [hseq lold], ret                 => ret tpc ⊥
  | MOV, [hseq l; lold], ret                => ret tpc l
  | BINOP b, [hseq l1; l2; lold], ret       => ret tpc (l1 ⊔ l2)
  | LOAD, [hseq l1; MemData l2; lold], ret  => ret tpc (l1 ⊔ l2)
  | STORE, [hseq l1; l2; MemData lold], ret => if l1 ⊔ tpc ⊑ lold then
                                                 ret tpc (MemData (l1 ⊔ l2 ⊔ tpc))
                                               else None
  | JUMP, [hseq l], ret                     => ret (l ⊔ tpc) tt
  | BNZ, [hseq l], ret                      => ret (l ⊔ tpc) tt
  | JAL, [hseq l1; lold], ret               => ret (l1 ⊔ tpc) ⊥
  | _, _, _                                 => None
  end.

Definition transfer (iv : ivec ifc_tags) : option (vovec ifc_tags (op iv)) :=
  match iv with
  | IVec (OP op) tpc ti ts =>
    match ti with
    | MemInstr => @instr_rules op tpc ts
    | MemData _ => None
    end
  | IVec SERVICE tpc _ _ => Some tt
  end.

(** The internal state for the IFC policy is simply a sequence of atoms that has
    been output during execution. *)

Record int_ifc := IntIFC {
  outputs : seq (atom (mword mt) L);
  call_stack : seq (call_frame mt L)
}.

Definition tuple_of_int_ifc x :=
  (outputs x, call_stack x).

Definition int_ifc_of_tuple x :=
  IntIFC x.1 x.2.

Lemma tuple_of_int_ifcK : cancel tuple_of_int_ifc int_ifc_of_tuple.
Proof. by case. Qed.

Definition int_ifc_eqMixin := CanEqMixin tuple_of_int_ifcK.
Canonical int_ifc_eqType := Eval hnf in EqType int_ifc int_ifc_eqMixin.

Global Instance sym_ifc : params := {
  ttypes := ifc_tags;

  transfer := transfer;

  internal_state := int_ifc_eqType
}.

Local Notation state := (@Symbolic.state mt sym_ifc).

Implicit Types st : state.

(* Note that we often need to adjust the tag on the caller pc because it may be
   lower than the one on the current pc; for example, if we jump to the service
   via BNZ instead of JAL. *)

Definition return_fun st : option state :=
  if call_stack (internal st) is cf :: stk then
    do! retv <- regs st syscall_ret;
    do! rs' <- updm (cf_regs cf) syscall_ret (vala retv)@(taga (pc st) ⊔ taga retv);
    Some (State (mem st) rs' (cf_pc cf)
                {| outputs := outputs (internal st);
                   call_stack := stk |})
  else None.

Definition call_fun st : option state :=
  do! caller_pc <- regs st ra;
  let caller_pc := (vala caller_pc)@(taga caller_pc ⊔ taga (pc st)) in
  do! called_pc <- regs st syscall_arg1;
  Some (State (mem st) (regs st)
              (vala called_pc)@(taga called_pc ⊔ taga caller_pc)
              {| outputs := outputs (internal st);
                 call_stack :=
                   CallFrame caller_pc (regs st)
                   :: call_stack (internal st)
              |}).

Definition output_fun st : option state :=
  do! raddr <- regs st ra;
  let r_pc  := taga raddr ⊔ taga (pc st) in
  let raddr := (vala raddr)@r_pc in
  do! out   <- regs st syscall_arg1;
  let r_out := taga out in
  Some (State (mem st) (regs st) raddr
              {| outputs := rcons (outputs (internal st))
                                  (vala out)@(taga (pc st) ⊔ r_out);
                 call_stack := call_stack (internal st)
              |}).

Definition ifc_syscalls : syscall_table mt :=
  [fmap
     (return_addr, (Syscall tt return_fun));
     (call_addr, (Syscall tt call_fun));
     (output_addr, (Syscall tt output_fun))
  ].

Definition trace n st :=
  let st' := iter n (fun st' => odflt st' (stepf ifc_syscalls st')) st in
  drop (size (outputs (internal st))) (outputs (internal st')).

Local Notation step  := (@Symbolic.step mt mops sym_ifc ifc_syscalls).
Local Notation ratom := (atom (mword mt) (tag_type ifc_tags R)).
Local Notation matom := (atom (mword mt) (tag_type ifc_tags M)).

Hint Unfold stepf.
Hint Unfold next_state_pc.
Hint Unfold next_state_reg.
Hint Unfold next_state_reg_and_pc.
Hint Unfold next_state.

Ltac step_event_cat :=
  simpl in *; repeat autounfold;
  intros; subst; simpl in *;
  repeat match goal with
  | t : (_ * _)%type |- _ => destruct t; simpl in *
  end;
  match_inv; simpl; exists [::]; rewrite cats0.

Lemma step_event_cat s s' :
  step s s' ->
  exists t, outputs (internal s') = outputs (internal s) ++ t.
Proof.
  case; try by step_event_cat.
  move=> /= m rs pc sc rl [t stk] -> {s} _.
  rewrite /ifc_syscalls /run_syscall mkfmapE //=.
  case: ifP=> [_ [<-] {sc}|_] /=.
    rewrite /return_fun /= => e; match_inv=> /=.
    by exists [::]; rewrite cats0.
  case: ifP=> [_ [<-] {sc}|_] /=.
    rewrite /call_fun /= => e; match_inv=> /=.
    by exists [::]; rewrite cats0.
  case: ifP=> [_ [<-] {sc}|_] //=.
  rewrite /output_fun /= => e; match_inv=> /=.
  by rewrite -cats1; eexists; eauto.
Qed.

End Dev.


From machine_program_logic.program_logic Require Import weakestpre.
From HypVeri.algebra Require Import base base_extra reg mem pagetable mailbox.
From HypVeri Require Import machine_extra lifting rules.rules_base.
From HypVeri.lang Require Import lang_extra reg_extra.

Section nop.

Context `{hypparams: HypervisorParameters}.
Context `{vmG: !gen_VMG Σ}.

Lemma nop {E i w1 q s p_tx} a :
  decode_instruction w1 = Some Nop ->
  (tpa a) ∈ s ->
  (tpa a) ≠ p_tx ->
  {SS{{ ▷ (PC @@ i ->r a)
        ∗ ▷ (a ->a w1)
        ∗ ▷ (i -@{ q }A> s)
        ∗ ▷ (TX@ i := p_tx)}}}
    ExecI @ i ; E
  {{{ RET (false, ExecI); PC @@ i ->r (a ^+ 1)%f
                  ∗ a ->a w1
                  ∗ i -@{ q }A> s
                  ∗ TX@ i := p_tx}}}.
Proof.
  iIntros (Hdecode Hin Hnottx ϕ) "(>Hpc & >Hapc & >Hacc & >tx) Hϕ".
  iApply (sswp_lift_atomic_step ExecI);[done|].
  iIntros (n σ1) "%Hsche Hσ".
  rewrite /scheduled in Hsche.
  simpl in Hsche.
  rewrite /scheduler in Hsche.
  apply bool_decide_unpack in Hsche as Hcur.
  clear Hsche.
  apply fin_to_nat_inj in Hcur.
  iModIntro.
  iDestruct "Hσ" as "(H1 & Hmem & Hreg & Hmb & ? & ? & Haccess & H2)".
  pose proof (decode_instruction_valid w1 _ Hdecode) as Hvalidinstr.
  inversion Hvalidinstr as [| | | | | | | | | | |].
  (* valid regs *)
  iDestruct ((gen_reg_valid1 PC i a Hcur) with "Hreg Hpc") as "%HPC".
  (* valid pt *)
  iDestruct (access_agree_check_true with "Haccess Hacc") as %Hacc;first exact Hin.
  iDestruct (mb_valid_tx with "Hmb tx") as %Htx.
  subst p_tx.
  (* valid mem *)
  iDestruct (gen_mem_valid a w1 with "Hmem Hapc") as "%Hmem".
  iSplit.
  - (* reducible *)
    iPureIntro.
    eapply (reducible_normal i _ a w1); eauto.
  - (* step *)
    iModIntro.
    iIntros (m2 σ2) "[%P PAuth] %HstepP".
    eapply (step_ExecI_normal i _ a w1) in HstepP;eauto.
    remember (exec _ σ1) as c2 eqn:Heqc2.
    rewrite /exec /nop /update_incr_PC in Heqc2.
    destruct HstepP; subst m2 σ2; subst c2; simpl.
    rewrite /gen_vm_interp.
    (* unchanged part *)
    rewrite (preserve_get_mb_gmap σ1).
    rewrite (preserve_get_rx_gmap σ1).
    rewrite (preserve_get_own_gmap σ1).
    rewrite (preserve_get_access_gmap σ1).
    rewrite (preserve_get_excl_gmap σ1).
    rewrite (preserve_get_trans_gmap σ1).
    rewrite (preserve_get_hpool_gset σ1).
    rewrite (preserve_get_retri_gmap σ1).
    rewrite (preserve_inv_trans_pgt_consistent σ1).
    rewrite (preserve_inv_trans_wellformed σ1).
    rewrite (preserve_inv_trans_ps_disj σ1).
    rewrite p_upd_pc_mem.
    all: try rewrite p_upd_pc_pgt //.
    all: try rewrite p_upd_pc_trans //.
    all: try rewrite p_upd_pc_mb //.
    iFrame.
    (* updated part *)
    rewrite -> (u_upd_pc_regs _ i a 1); eauto.
    + iDestruct ((gen_reg_update1_global PC i a (a ^+ 1)%f) with "Hreg Hpc") as ">[Hσ Hreg]"; eauto.
      iModIntro.
      iFrame "Hσ".
      iSplitL "PAuth".
      * by iExists P.
      * iSplitL "".
        rewrite /just_scheduled_vms /just_scheduled.
        assert (filter
                  (λ id : vmid,
                          base.negb (scheduled σ1 id) &&
                          scheduled (update_offset_PC σ1 1) id = true)
                  (seq 0 n) = []) as ->.
        {
          rewrite /scheduled /machine.scheduler //= /scheduler Hcur.
          rewrite p_upd_pc_current_vm.
          rewrite Hcur.
          induction n.
          - simpl.
            rewrite filter_nil //=.
          - rewrite seq_S.
            rewrite filter_app.
            rewrite IHn.
            simpl.
            rewrite filter_cons_False //=.
            rewrite andb_negb_l.
            done.
        }
        by iSimpl.
        assert ((scheduled (update_offset_PC σ1 1) i) = true) as ->.
        {
          rewrite /scheduled /machine.scheduler //= /scheduler.
          rewrite p_upd_pc_current_vm.
          rewrite Hcur.
          by case_bool_decide.
        }
        simpl.
        iApply "Hϕ".
        iFrame.
    + solve_reg_lookup.
Qed.

End nop.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import Bool.
Require Import Sumbool.
Require Import Arith.
Require Import ZArith NArith Nnat Ndec Ndigits.
From IntMap Require Import Map.
From IntMap Require Import Allmaps.
Require Import List.
Require Import Wf_nat.

Require Import misc.
Require Import bool_fun.
Require Import myMap.
Require Import config.
Require Import alloc.

Section BDD_make.

Variable gc : BDDconfig -> list ad -> BDDconfig.
Hypothesis gc_is_OK : gc_OK gc.

(* The arguments for the make function *)
Variable cfg : BDDconfig.
Variable x : BDDvar.
Variable l r : ad.
Variable ul : list ad.

(* Conditions on the arguments for the make function *)
Hypothesis cfg_OK : BDDconfig_OK cfg.
Hypothesis ul_OK : used_list_OK cfg ul.
Hypothesis l_used' : used_node' cfg ul l.
Hypothesis r_used' : used_node' cfg ul r.
Hypothesis
  xl_lt_x :
    forall (xl : BDDvar) (ll rl : ad),
    MapGet _ (bs_of_cfg cfg) l = Some (xl, (ll, rl)) ->
    BDDcompare xl x = Datatypes.Lt.
Hypothesis
  xr_lt_x :
    forall (xr : BDDvar) (lr rr : ad),
    MapGet _ (bs_of_cfg cfg) r = Some (xr, (lr, rr)) ->
    BDDcompare xr x = Datatypes.Lt.

Lemma no_dup :
 MapGet3 ad (fst (snd cfg)) l r x = None ->
 forall (x' : BDDvar) (l' r' a : ad),
 MapGet (BDDvar * (ad * ad)) (bs_of_cfg cfg) a =
 Some (x', (l', r')) -> (x, (l, r)) <> (x', (l', r')).
Proof.
  unfold not in |- *.  intros.  injection H1.  intros.  rewrite <- H2 in H0.
  rewrite <- H3 in H0.  rewrite <- H4 in H0.
  rewrite (proj2 (proj1 (proj2 cfg_OK) x l r a) H0) in H.
  discriminate.
Qed.

Definition BDDmake :=
  if Neqb l r
  then (cfg, l)
  else
   match MapGet3 _ (fst (snd cfg)) l r x with
   | Some y => (cfg, y)
   | None => BDDalloc gc cfg x l r ul
   end.

Lemma BDDmake_keeps_config_OK : BDDconfig_OK (fst BDDmake).
Proof.
  unfold BDDmake in |- *.  elim (sumbool_of_bool (Neqb l r)).  intro y.  rewrite y.
  assumption.  intro y.  rewrite y.
  elim (option_sum _ (MapGet3 ad (fst (snd cfg)) l r x)).  intro y0.  elim y0.
  clear y0.  intros node y0.  rewrite y0.  assumption.  intro y0.  rewrite y0.
  apply BDDalloc_keeps_config_OK.  assumption.  assumption.  assumption.
  assumption.  assumption.  assumption.  assumption.  assumption.  intros.
  apply no_dup with (a := a).  assumption.  assumption.
Qed.

Lemma BDDmake_preserves_used_nodes :
 used_nodes_preserved cfg (fst BDDmake) ul.
Proof.
  unfold BDDmake in |- *.  elim (sumbool_of_bool (Neqb l r)).  intro y.  rewrite y.
  apply used_nodes_preserved_refl.  intro y.  rewrite y.
  elim (option_sum _ (MapGet3 ad (fst (snd cfg)) l r x)).  intro y0.  elim y0.
  clear y0.  intros node y0.  rewrite y0.  apply used_nodes_preserved_refl.  intro y0.
  rewrite y0.  apply BDDalloc_preserves_used_nodes.  assumption.  assumption.
  assumption.
Qed.

Lemma BDDmake_node_OK : config_node_OK (fst BDDmake) (snd BDDmake).
Proof.
  unfold BDDmake in |- *.  elim (sumbool_of_bool (Neqb l r)).  intro y.  rewrite y.
  unfold config_node_OK in |- *.  apply used_node'_OK_bs with (ul := ul).
  exact (proj1 cfg_OK).  assumption.  assumption.  intro y.  rewrite y.
  elim (option_sum _ (MapGet3 ad (fst (snd cfg)) l r x)).  intro y0.  elim y0.
  clear y0.  intros x0 y0.  rewrite y0.  right.  right.  unfold in_dom in |- *.  simpl in |- *.
  rewrite (proj1 (proj1 (proj2 cfg_OK) x l r x0) y0).  reflexivity.
  intro y0.  rewrite y0.  apply BDDalloc_node_OK.  assumption.  assumption.
  assumption.  assumption.  assumption.  assumption.  assumption.  assumption.
Qed.

Lemma BDDmake_bool_fun :
 bool_fun_eq (bool_fun_of_BDD (fst BDDmake) (snd BDDmake))
   (bool_fun_if x (bool_fun_of_BDD cfg r) (bool_fun_of_BDD cfg l)).
Proof.
  unfold BDDmake in |- *.  elim (sumbool_of_bool (Neqb l r)).  intro y.  rewrite y.
  simpl in |- *.  apply bool_fun_eq_sym.  apply bool_fun_if_eq_2.
  rewrite (Neqb_complete _ _ y).  apply bool_fun_eq_refl.  intro y.  rewrite y.
  elim (option_sum _ (MapGet3 ad (fst (snd cfg)) l r x)).  intro y0.  elim y0.
  clear y0.  intros x0 y0.  rewrite y0.  unfold bool_fun_of_BDD in |- *.  simpl in |- *.
  apply bool_fun_of_BDD_bs_int.  exact (proj1 cfg_OK).
  exact (proj1 (proj1 (proj2 cfg_OK) x l r x0) y0).  intro y0.
  rewrite y0.  unfold bool_fun_of_BDD in |- *.  simpl in |- *.
  apply
   bool_fun_eq_trans
    with
      (bool_fun_if x
         (bool_fun_of_BDD_bs (fst (fst (BDDalloc gc cfg x l r ul))) r)
         (bool_fun_of_BDD_bs (fst (fst (BDDalloc gc cfg x l r ul))) l)).
  apply bool_fun_of_BDD_bs_int.  apply BDDalloc_keeps_state_OK.  assumption.
  assumption.  assumption.  assumption.  assumption.  assumption.  assumption.
  assumption.  apply BDDallocGet.  apply bool_fun_if_preserves_eq.
  apply used_nodes_preserved'_bs_bool_fun with (ul := ul).  exact (proj1 cfg_OK).
  apply BDDalloc_keeps_state_OK.  assumption.  assumption.  assumption.
  assumption.  assumption.  assumption.  assumption.  assumption.
  fold (used_nodes_preserved cfg (fst (BDDalloc gc cfg x l r ul)) ul) in |- *.
  apply BDDalloc_preserves_used_nodes.  assumption.  assumption.  assumption.
  assumption.  assumption.  apply used_nodes_preserved'_bs_bool_fun with (ul := ul).
  exact (proj1 cfg_OK).  apply BDDalloc_keeps_state_OK.  assumption.
  assumption.  assumption.  assumption.  assumption.  assumption.  assumption.
  assumption.
  fold (used_nodes_preserved cfg (fst (BDDalloc gc cfg x l r ul)) ul) in |- *.
  apply BDDalloc_preserves_used_nodes.  assumption.  assumption.  assumption.
  assumption.  assumption.
Qed.

Lemma BDDmake_node_height_eq :
 Neqb l r = false ->
 Neqb (node_height (fst BDDmake) (snd BDDmake)) (ad_S x) = true.
Proof.
  intro.  unfold BDDmake in |- *.  rewrite H.
  elim (option_sum _ (MapGet3 ad (fst (snd cfg)) l r x)).  intro y.  elim y.
  clear y.  intros x0 y.  rewrite y.  simpl in |- *.  unfold node_height in |- *.  unfold bs_node_height in |- *.
  rewrite (proj1 (proj1 (proj2 cfg_OK) x l r x0) y).
  apply Neqb_correct.  intro y.  rewrite y.  unfold node_height in |- *.  unfold bs_node_height in |- *.
  rewrite (BDDallocGet gc cfg x l r ul).  apply Neqb_correct.
Qed.

Lemma BDDmake_node_height_eq_1 :
 Neqb l r = true ->
 Neqb (node_height (fst BDDmake) (snd BDDmake)) (node_height cfg l) = true.
Proof.
  intro.  unfold BDDmake in |- *.  rewrite H.  apply Neqb_correct.
Qed.

Lemma BDDmake_node_height_le :
 Nleb (node_height (fst BDDmake) (snd BDDmake)) (ad_S x) = true.
Proof.
  elim (sumbool_of_bool (Neqb l r)).  intro y.
  rewrite
   (Neqb_complete (node_height (fst BDDmake) (snd BDDmake))
      (node_height cfg l)).
  unfold node_height in |- *.  unfold bs_node_height in |- *.  elim (option_sum _ (MapGet _ (fst cfg) l)).
  intro y0.  elim y0.  intro x0.  elim x0.  intro y1.  intro y2.  elim y2.  intros y3 y4 y5.
  rewrite y5.  unfold Nleb in |- *.  apply leb_correct.  apply lt_le_weak.
  apply BDDcompare_lt.  rewrite <- (ad_S_compare y1 x).
  apply xl_lt_x with (ll := y3) (rl := y4).  assumption.  intro y0.  rewrite y0.
  reflexivity.  apply BDDmake_node_height_eq_1.  assumption.  intro y.
  rewrite (Neqb_complete _ _ (BDDmake_node_height_eq y)).  apply Nleb_refl.
Qed.

End BDD_make.


Require Import TestSuite.admit.
Class Foo.
Definition bar `{Foo} (x : Set) := Set.
Instance: Foo.
Definition bar1 := bar nat.
Definition bar2 := bar ltac:(admit).