(* -*- mode: coq -*- *)
(* Time-stamp: <2014/8/15 20:57:12> *)
(*
  monad.v
  - mathink : Author
 *)

(* SSReflect libraries *)
Require Import
  Ssreflect.ssreflect
  Ssreflect.ssrbool
  Ssreflect.ssrfun
  Ssreflect.eqtype
  Ssreflect.ssrnat
  Ssreflect.seq
  Ssreflect.fintype.

(* Mathematical Components libraries *)

(* Implicity *)
Set Implicit Arguments.
Unset Strict Implicit.
Generalizable All Variables.

Reserved Notation "m >>= f" (at level 57, left associativity).
Class eqMonad (m: eqType -> eqType) :=
  { emb {X: eqType}: X -> m X;
    bind {X Y: eqType}(f: X -> m Y): m X -> m Y
    where "m >>= f" := (bind f m);

    emb_bind {X Y: eqType}(f: X -> m Y)(x: X):
      (emb x >>= f) == f x;
    bind_emb {X: eqType} (mx: m X):
      (mx >>= emb) == mx;
    bind_assoc {X Y Z: eqType}(f: X -> m Y)(g: Y -> m Z)(mx: m X):
      mx >>= f >>= g == mx >>= (bind g \o f) }.
Notation "m >>= f" := (bind f m) (at level 57, left associativity).
Notation "x <- m ; p" := (m >>= fun x => p) (at level 65, right associativity).

Program Instance eqMaybe: eqMonad option_eqType :=
  { emb X x := Some x;
    bind X Y f mx := if mx is Some x then f x else None }.
Next Obligation.
  case: mx => //=.
Qed.
Next Obligation.
  case: mx => //=.
Qed.

Class eqMonad_F `(monad: eqMonad m) :=
  { failure {X: eqType}: m X;
    handle {X: eqType}: m X -> m X -> m X;

    failure_end {X Y: eqType}(f: X -> m Y):
      failure >>= f == failure;
    handle_failure {X: eqType}(mx: m X):
      handle failure mx == mx }.

Program Instance eqMaybe_F: eqMonad_F eqMaybe :=
  { failure X := None (A:=X);
    handle X mx1 mx2 := if mx1 is None then mx2 else mx1 }.


(** This file proves the basic laws of the HeapLang program logic by applying
the Iris lifting lemmas. *)

From iris.proofmode Require Import tactics.
From iris.bi.lib Require Import fractional.
From iris.base_logic.lib Require Export gen_heap proph_map gen_inv_heap.
From iris.program_logic Require Export weakestpre total_weakestpre.
From iris.program_logic Require Import ectx_lifting total_ectx_lifting.
From iris.heap_lang Require Export class_instances.
From iris.heap_lang Require Import tactics notation.
From iris.prelude Require Import options.

Class heapG Σ := HeapG {
  heapG_invG : invG Σ;
  heapG_gen_heapG :> gen_heapG loc (option val) Σ;
  heapG_inv_heapG :> inv_heapG loc (option val) Σ;
  heapG_proph_mapG :> proph_mapG proph_id (val * val) Σ;
}.

Global Instance heapG_irisG `{!heapG Σ} : irisG heap_lang Σ := {
  iris_invG := heapG_invG;
  state_interp σ κs _ :=
    (gen_heap_interp σ.(heap) ∗ proph_map_interp κs σ.(used_proph_id))%I;
  fork_post _ := True%I;
}.

(** Since we use an [option val] instance of [gen_heap], we need to overwrite
the notations.  That also helps for scopes and coercions. *)
(** FIXME: Refactor these notations using custom entries once Coq bug #13654
has been fixed. *)
Notation "l ↦{ dq } v" := (mapsto (L:=loc) (V:=option val) l dq (Some v%V))
  (at level 20, format "l  ↦{ dq }  v") : bi_scope.
Notation "l ↦□ v" := (mapsto (L:=loc) (V:=option val) l DfracDiscarded (Some v%V))
  (at level 20, format "l  ↦□  v") : bi_scope.
Notation "l ↦{# q } v" := (mapsto (L:=loc) (V:=option val) l (DfracOwn q) (Some v%V))
  (at level 20, format "l  ↦{# q }  v") : bi_scope.
Notation "l ↦ v" := (mapsto (L:=loc) (V:=option val) l (DfracOwn 1) (Some v%V))
  (at level 20, format "l  ↦  v") : bi_scope.

(** Same for [gen_inv_heap], except that these are higher-order notations so to
make setoid rewriting in the predicate [I] work we need actual definitions
here. *)
Section definitions.
  Context `{!heapG Σ}.
  Definition inv_mapsto_own (l : loc) (v : val) (I : val → Prop) : iProp Σ :=
    inv_mapsto_own l (Some v) (from_option I False).
  Definition inv_mapsto (l : loc) (I : val → Prop) : iProp Σ :=
    inv_mapsto l (from_option I False).
End definitions.

Global Instance: Params (@inv_mapsto_own) 4 := {}.
Global Instance: Params (@inv_mapsto) 3 := {}.

Notation inv_heap_inv := (inv_heap_inv loc (option val)).
Notation "l '↦_' I □" := (inv_mapsto l I%stdpp%type)
  (at level 20, I at level 9, format "l  '↦_' I  '□'") : bi_scope.
Notation "l ↦_ I v" := (inv_mapsto_own l v I%stdpp%type)
  (at level 20, I at level 9, format "l  ↦_ I  v") : bi_scope.

Section lifting.
Context `{!heapG Σ}.
Implicit Types P Q : iProp Σ.
Implicit Types Φ Ψ : val → iProp Σ.
Implicit Types efs : list expr.
Implicit Types σ : state.
Implicit Types v : val.
Implicit Types l : loc.

(** Recursive functions: we do not use this lemmas as it is easier to use Löb
induction directly, but this demonstrates that we can state the expected
reasoning principle for recursive functions, without any visible ▷. *)
Lemma wp_rec_löb s E f x e Φ Ψ :
  □ ( □ (∀ v, Ψ v -∗ WP (rec: f x := e)%V v @ s; E {{ Φ }}) -∗
     ∀ v, Ψ v -∗ WP (subst' x v (subst' f (rec: f x := e) e)) @ s; E {{ Φ }}) -∗
  ∀ v, Ψ v -∗ WP (rec: f x := e)%V v @ s; E {{ Φ }}.
Proof.
  iIntros "#Hrec". iLöb as "IH". iIntros (v) "HΨ".
  iApply lifting.wp_pure_step_later; first done.
  iNext. iApply ("Hrec" with "[] HΨ"). iIntros "!>" (w) "HΨ".
  iApply ("IH" with "HΨ").
Qed.

(** Fork: Not using Texan triples to avoid some unnecessary [True] *)
Lemma wp_fork s E e Φ :
  ▷ WP e @ s; ⊤ {{ _, True }} -∗ ▷ Φ (LitV LitUnit) -∗ WP Fork e @ s; E {{ Φ }}.
Proof.
  iIntros "He HΦ". iApply wp_lift_atomic_head_step; [done|].
  iIntros (σ1 κ κs n) "Hσ !>"; iSplit; first by eauto with head_step.
  iIntros "!>" (v2 σ2 efs Hstep); inv_head_step. by iFrame.
Qed.

Lemma twp_fork s E e Φ :
  WP e @ s; ⊤ [{ _, True }] -∗ Φ (LitV LitUnit) -∗ WP Fork e @ s; E [{ Φ }].
Proof.
  iIntros "He HΦ". iApply twp_lift_atomic_head_step; [done|].
  iIntros (σ1 κs n) "Hσ !>"; iSplit; first by eauto with head_step.
  iIntros (κ v2 σ2 efs Hstep); inv_head_step. by iFrame.
Qed.

(** Heap *)

(** We need to adjust the [gen_heap] and [gen_inv_heap] lemmas because of our
value type being [option val]. *)

Lemma mapsto_valid l dq v : l ↦{dq} v -∗ ⌜✓ dq⌝.
Proof. apply mapsto_valid. Qed.
Lemma mapsto_valid_2 l dq1 dq2 v1 v2 :
  l ↦{dq1} v1 -∗ l ↦{dq2} v2 -∗ ⌜✓ (dq1 ⋅ dq2) ∧ v1 = v2⌝.
Proof.
  iIntros "H1 H2". iDestruct (mapsto_valid_2 with "H1 H2") as %[? [=?]]. done.
Qed.
Lemma mapsto_agree l dq1 dq2 v1 v2 : l ↦{dq1} v1 -∗ l ↦{dq2} v2 -∗ ⌜v1 = v2⌝.
Proof. iIntros "H1 H2". iDestruct (mapsto_agree with "H1 H2") as %[=?]. done. Qed.

Lemma mapsto_combine l dq1 dq2 v1 v2 :
  l ↦{dq1} v1 -∗ l ↦{dq2} v2 -∗ l ↦{dq1 ⋅ dq2} v1 ∗ ⌜v1 = v2⌝.
Proof.
  iIntros "Hl1 Hl2". iDestruct (mapsto_combine with "Hl1 Hl2") as "[$ Heq]".
  by iDestruct "Heq" as %[= ->].
Qed.

Lemma mapsto_frac_ne l1 l2 dq1 dq2 v1 v2 :
  ¬ ✓(dq1 ⋅ dq2) → l1 ↦{dq1} v1 -∗ l2 ↦{dq2} v2 -∗ ⌜l1 ≠ l2⌝.
Proof. apply mapsto_frac_ne. Qed.
Lemma mapsto_ne l1 l2 dq2 v1 v2 : l1 ↦ v1 -∗ l2 ↦{dq2} v2 -∗ ⌜l1 ≠ l2⌝.
Proof. apply mapsto_ne. Qed.

Lemma mapsto_persist l dq v : l ↦{dq} v ==∗ l ↦□ v.
Proof. apply mapsto_persist. Qed.

Global Instance inv_mapsto_own_proper l v :
  Proper (pointwise_relation _ iff ==> (≡)) (inv_mapsto_own l v).
Proof.
  intros I1 I2 HI. rewrite /inv_mapsto_own. f_equiv=>-[w|]; last done.
  simpl. apply HI.
Qed.
Global Instance inv_mapsto_proper l :
  Proper (pointwise_relation _ iff ==> (≡)) (inv_mapsto l).
Proof.
  intros I1 I2 HI. rewrite /inv_mapsto. f_equiv=>-[w|]; last done.
  simpl. apply HI.
Qed.

Lemma make_inv_mapsto l v (I : val → Prop) E :
  ↑inv_heapN ⊆ E →
  I v →
  inv_heap_inv -∗ l ↦ v ={E}=∗ l ↦_I v.
Proof. iIntros (??) "#HI Hl". iApply make_inv_mapsto; done. Qed.
Lemma inv_mapsto_own_inv l v I : l ↦_I v -∗ l ↦_I □.
Proof. apply inv_mapsto_own_inv. Qed.

Lemma inv_mapsto_own_acc_strong E :
  ↑inv_heapN ⊆ E →
  inv_heap_inv ={E, E ∖ ↑inv_heapN}=∗ ∀ l v I, l ↦_I v -∗
    (⌜I v⌝ ∗ l ↦ v ∗ (∀ w, ⌜I w ⌝ -∗ l ↦ w ==∗
      inv_mapsto_own l w I ∗ |={E ∖ ↑inv_heapN, E}=> True)).
Proof.
  iIntros (?) "#Hinv".
  iMod (inv_mapsto_own_acc_strong with "Hinv") as "Hacc"; first done.
  iIntros "!>" (l v I) "Hl". iDestruct ("Hacc" with "Hl") as "(% & Hl & Hclose)".
  iFrame "%∗". iIntros (w) "% Hl". iApply "Hclose"; done.
Qed.

Lemma inv_mapsto_own_acc E l v I:
  ↑inv_heapN ⊆ E →
  inv_heap_inv -∗ l ↦_I v ={E, E ∖ ↑inv_heapN}=∗
    (⌜I v⌝ ∗ l ↦ v ∗ (∀ w, ⌜I w ⌝ -∗ l ↦ w ={E ∖ ↑inv_heapN, E}=∗ l ↦_I w)).
Proof.
  iIntros (?) "#Hinv Hl".
  iMod (inv_mapsto_own_acc with "Hinv Hl") as "(% & Hl & Hclose)"; first done.
  iFrame "%∗". iIntros "!>" (w) "% Hl". iApply "Hclose"; done.
Qed.

Lemma inv_mapsto_acc l I E :
  ↑inv_heapN ⊆ E →
  inv_heap_inv -∗ l ↦_I □ ={E, E ∖ ↑inv_heapN}=∗
    ∃ v, ⌜I v⌝ ∗ l ↦ v ∗ (l ↦ v ={E ∖ ↑inv_heapN, E}=∗ ⌜True⌝).
Proof.
  iIntros (?) "#Hinv Hl".
  iMod (inv_mapsto_acc with "Hinv Hl") as ([v|]) "(% & Hl & Hclose)"; [done| |done].
  iIntros "!>". iExists (v). iFrame "%∗".
Qed.

(** The usable rules for [allocN] stated in terms of the [array] proposition
are derived in te file [array]. *)
Lemma heap_array_to_seq_meta l vs (n : nat) :
  length vs = n →
  ([∗ map] l' ↦ _ ∈ heap_array l vs, meta_token l' ⊤) -∗
  [∗ list] i ∈ seq 0 n, meta_token (l +ₗ (i : nat)) ⊤.
Proof.
  iIntros (<-) "Hvs". iInduction vs as [|v vs] "IH" forall (l)=> //=.
  rewrite big_opM_union; last first.
  { apply map_disjoint_spec=> l' v1 v2 /lookup_singleton_Some [-> _].
    intros (j&w&?&Hjl&?&?)%heap_array_lookup.
    rewrite loc_add_assoc -{1}[l']loc_add_0 in Hjl. simplify_eq; lia. }
  rewrite loc_add_0 -fmap_S_seq big_sepL_fmap.
  setoid_rewrite Nat2Z.inj_succ. setoid_rewrite <-Z.add_1_l.
  setoid_rewrite <-loc_add_assoc.
  rewrite big_opM_singleton; iDestruct "Hvs" as "[$ Hvs]". by iApply "IH".
Qed.

Lemma heap_array_to_seq_mapsto l v (n : nat) :
  ([∗ map] l' ↦ ov ∈ heap_array l (replicate n v), gen_heap.mapsto l' (DfracOwn 1) ov) -∗
  [∗ list] i ∈ seq 0 n, (l +ₗ (i : nat)) ↦ v.
Proof.
  iIntros "Hvs". iInduction n as [|n] "IH" forall (l); simpl.
  { done. }
  rewrite big_opM_union; last first.
  { apply map_disjoint_spec=> l' v1 v2 /lookup_singleton_Some [-> _].
    intros (j&w&?&Hjl&_)%heap_array_lookup.
    rewrite loc_add_assoc -{1}[l']loc_add_0 in Hjl. simplify_eq; lia. }
  rewrite loc_add_0 -fmap_S_seq big_sepL_fmap.
  setoid_rewrite Nat2Z.inj_succ. setoid_rewrite <-Z.add_1_l.
  setoid_rewrite <-loc_add_assoc.
  rewrite big_opM_singleton; iDestruct "Hvs" as "[$ Hvs]". by iApply "IH".
Qed.

Lemma twp_allocN_seq s E v n :
  (0 < n)%Z →
  [[{ True }]] AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E
  [[{ l, RET LitV (LitLoc l); [∗ list] i ∈ seq 0 (Z.to_nat n),
      (l +ₗ (i : nat)) ↦ v ∗ meta_token (l +ₗ (i : nat)) ⊤ }]].
Proof.
  iIntros (Hn Φ) "_ HΦ". iApply twp_lift_atomic_head_step_no_fork; first done.
  iIntros (σ1 κs k) "[Hσ Hκs] !>"; iSplit; first by destruct n; auto with lia head_step.
  iIntros (κ v2 σ2 efs Hstep); inv_head_step.
  iMod (gen_heap_alloc_big _ (heap_array _ (replicate (Z.to_nat n) v)) with "Hσ")
    as "(Hσ & Hl & Hm)".
  { apply heap_array_map_disjoint.
    rewrite replicate_length Z2Nat.id; auto with lia. }
  iModIntro; do 2 (iSplit; first done). iFrame "Hσ Hκs". iApply "HΦ".
  iApply big_sepL_sep. iSplitL "Hl".
  - by iApply heap_array_to_seq_mapsto.
  - iApply (heap_array_to_seq_meta with "Hm"). by rewrite replicate_length.
Qed.
Lemma wp_allocN_seq s E v n :
  (0 < n)%Z →
  {{{ True }}} AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E
  {{{ l, RET LitV (LitLoc l); [∗ list] i ∈ seq 0 (Z.to_nat n),
      (l +ₗ (i : nat)) ↦ v ∗ meta_token (l +ₗ (i : nat)) ⊤ }}}.
Proof.
  iIntros (Hn Φ) "_ HΦ". iApply (twp_wp_step with "HΦ").
  iApply twp_allocN_seq; [by auto..|]; iIntros (l) "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_alloc s E v :
  [[{ True }]] Alloc (Val v) @ s; E [[{ l, RET LitV (LitLoc l); l ↦ v ∗ meta_token l ⊤ }]].
Proof.
  iIntros (Φ) "_ HΦ". iApply twp_allocN_seq; [auto with lia..|].
  iIntros (l) "/= (? & _)". rewrite loc_add_0. iApply "HΦ"; iFrame.
Qed.
Lemma wp_alloc s E v :
  {{{ True }}} Alloc (Val v) @ s; E {{{ l, RET LitV (LitLoc l); l ↦ v ∗ meta_token l ⊤ }}}.
Proof.
  iIntros (Φ) "_ HΦ". iApply (twp_wp_step with "HΦ").
  iApply twp_alloc; [by auto..|]; iIntros (l) "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_free s E l v :
  [[{ l ↦ v }]] Free (Val $ LitV $ LitLoc l) @ s; E
  [[{ RET LitV LitUnit; True }]].
Proof.
  iIntros (Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; first done.
  iIntros (σ1 κs n) "[Hσ Hκs] !>". iDestruct (gen_heap_valid with "Hσ Hl") as %?.
  iSplit; first by eauto with head_step.
  iIntros (κ v2 σ2 efs Hstep); inv_head_step.
  iMod (gen_heap_update with "Hσ Hl") as "[$ Hl]".
  iModIntro. iSplit; first done. iSplit; first done. iFrame. by iApply "HΦ".
Qed.
Lemma wp_free s E l v :
  {{{ ▷ l ↦ v }}} Free (Val $ LitV (LitLoc l)) @ s; E
  {{{ RET LitV LitUnit; True }}}.
Proof.
  iIntros (Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_free with "H"); [by auto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_load s E l dq v :
  [[{ l ↦{dq} v }]] Load (Val $ LitV $ LitLoc l) @ s; E [[{ RET v; l ↦{dq} v }]].
Proof.
  iIntros (Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; first done.
  iIntros (σ1 κs n) "[Hσ Hκs] !>". iDestruct (gen_heap_valid with "Hσ Hl") as %?.
  iSplit; first by eauto with head_step.
  iIntros (κ v2 σ2 efs Hstep); inv_head_step.
  iModIntro; iSplit=> //. iSplit; first done. iFrame. by iApply "HΦ".
Qed.
Lemma wp_load s E l dq v :
  {{{ ▷ l ↦{dq} v }}} Load (Val $ LitV $ LitLoc l) @ s; E {{{ RET v; l ↦{dq} v }}}.
Proof.
  iIntros (Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_load with "H"). iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_store s E l v' v :
  [[{ l ↦ v' }]] Store (Val $ LitV $ LitLoc l) (Val v) @ s; E
  [[{ RET LitV LitUnit; l ↦ v }]].
Proof.
  iIntros (Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; first done.
  iIntros (σ1 κs n) "[Hσ Hκs] !>". iDestruct (gen_heap_valid with "Hσ Hl") as %?.
  iSplit; first by eauto with head_step.
  iIntros (κ v2 σ2 efs Hstep); inv_head_step.
  iMod (gen_heap_update with "Hσ Hl") as "[$ Hl]".
  iModIntro. iSplit; first done. iSplit; first done. iFrame. by iApply "HΦ".
Qed.
Lemma wp_store s E l v' v :
  {{{ ▷ l ↦ v' }}} Store (Val $ LitV (LitLoc l)) (Val v) @ s; E
  {{{ RET LitV LitUnit; l ↦ v }}}.
Proof.
  iIntros (Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_store with "H"); [by auto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_cmpxchg_fail s E l dq v' v1 v2 :
  v' ≠ v1 → vals_compare_safe v' v1 →
  [[{ l ↦{dq} v' }]] CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) @ s; E
  [[{ RET PairV v' (LitV $ LitBool false); l ↦{dq} v' }]].
Proof.
  iIntros (?? Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; first done.
  iIntros (σ1 κs n) "[Hσ Hκs] !>". iDestruct (gen_heap_valid with "Hσ Hl") as %?.
  iSplit; first by eauto with head_step.
  iIntros (κ v2' σ2 efs Hstep); inv_head_step.
  rewrite bool_decide_false //.
  iModIntro; iSplit; first done. iSplit; first done. iFrame. by iApply "HΦ".
Qed.
Lemma wp_cmpxchg_fail s E l dq v' v1 v2 :
  v' ≠ v1 → vals_compare_safe v' v1 →
  {{{ ▷ l ↦{dq} v' }}} CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) @ s; E
  {{{ RET PairV v' (LitV $ LitBool false); l ↦{dq} v' }}}.
Proof.
  iIntros (?? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_cmpxchg_fail with "H"); [by auto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_cmpxchg_suc s E l v1 v2 v' :
  v' = v1 → vals_compare_safe v' v1 →
  [[{ l ↦ v' }]] CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) @ s; E
  [[{ RET PairV v' (LitV $ LitBool true); l ↦ v2 }]].
Proof.
  iIntros (?? Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; first done.
  iIntros (σ1 κs n) "[Hσ Hκs] !>". iDestruct (gen_heap_valid with "Hσ Hl") as %?.
  iSplit; first by eauto with head_step.
  iIntros (κ v2' σ2 efs Hstep); inv_head_step.
  rewrite bool_decide_true //.
  iMod (gen_heap_update with "Hσ Hl") as "[$ Hl]".
  iModIntro. iSplit; first done. iSplit; first done. iFrame. by iApply "HΦ".
Qed.
Lemma wp_cmpxchg_suc s E l v1 v2 v' :
  v' = v1 → vals_compare_safe v' v1 →
  {{{ ▷ l ↦ v' }}} CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) @ s; E
  {{{ RET PairV v' (LitV $ LitBool true); l ↦ v2 }}}.
Proof.
  iIntros (?? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_cmpxchg_suc with "H"); [by auto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_faa s E l i1 i2 :
  [[{ l ↦ LitV (LitInt i1) }]] FAA (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt i2) @ s; E
  [[{ RET LitV (LitInt i1); l ↦ LitV (LitInt (i1 + i2)) }]].
Proof.
  iIntros (Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; first done.
  iIntros (σ1 κs n) "[Hσ Hκs] !>". iDestruct (gen_heap_valid with "Hσ Hl") as %?.
  iSplit; first by eauto with head_step.
  iIntros (κ e2 σ2 efs Hstep); inv_head_step.
  iMod (gen_heap_update with "Hσ Hl") as "[$ Hl]".
  iModIntro. do 2 (iSplit; first done). iFrame. by iApply "HΦ".
Qed.
Lemma wp_faa s E l i1 i2 :
  {{{ ▷ l ↦ LitV (LitInt i1) }}} FAA (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt i2) @ s; E
  {{{ RET LitV (LitInt i1); l ↦ LitV (LitInt (i1 + i2)) }}}.
Proof.
  iIntros (Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_faa with "H"); [by auto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma wp_new_proph s E :
  {{{ True }}}
    NewProph @ s; E
  {{{ pvs p, RET (LitV (LitProphecy p)); proph p pvs }}}.
Proof.
  iIntros (Φ) "_ HΦ". iApply wp_lift_atomic_head_step_no_fork; first done.
  iIntros (σ1 κ κs n) "[Hσ HR] !>". iSplit; first by eauto with head_step.
  iIntros "!>" (v2 σ2 efs Hstep). inv_head_step.
  rename select proph_id into p.
  iMod (proph_map_new_proph p with "HR") as "[HR Hp]"; first done.
  iModIntro; iSplit; first done. iFrame. by iApply "HΦ".
Qed.

(* In the following, strong atomicity is required due to the fact that [e] must
be able to make a head step for [Resolve e _ _] not to be (head) stuck. *)

Lemma resolve_reducible e σ (p : proph_id) v :
  Atomic StronglyAtomic e → reducible e σ →
  reducible (Resolve e (Val (LitV (LitProphecy p))) (Val v)) σ.
Proof.
  intros A (κ & e' & σ' & efs & H).
  exists (κ ++ [(p, (default v (to_val e'), v))]), e', σ', efs.
  eapply (Ectx_step []); try done.
  assert (∃w, Val w = e') as [w <-].
  { unfold Atomic in A. apply (A σ e' κ σ' efs) in H. unfold is_Some in H.
    destruct H as [w H]. exists w. simpl in H. by apply (of_to_val _ _ H). }
  simpl. constructor. by apply prim_step_to_val_is_head_step.
Qed.

Lemma step_resolve e vp vt σ1 κ e2 σ2 efs :
  Atomic StronglyAtomic e →
  prim_step (Resolve e (Val vp) (Val vt)) σ1 κ e2 σ2 efs →
  head_step (Resolve e (Val vp) (Val vt)) σ1 κ e2 σ2 efs.
Proof.
  intros A [Ks e1' e2' Hfill -> step]. simpl in *.
  induction Ks as [|K Ks _] using rev_ind.
  + simpl in *. subst. inv_head_step. by constructor.
  + rewrite fill_app /= in Hfill. destruct K; inversion Hfill; subst; clear Hfill.
    - rename select ectx_item into Ki.
      assert (fill_item Ki (fill Ks e1') = fill (Ks ++ [Ki]) e1') as Eq1;
        first by rewrite fill_app.
      assert (fill_item Ki (fill Ks e2') = fill (Ks ++ [Ki]) e2') as Eq2;
        first by rewrite fill_app.
      rewrite fill_app /=. rewrite Eq1 in A.
      assert (is_Some (to_val (fill (Ks ++ [Ki]) e2'))) as H.
      { apply (A σ1 _ κ σ2 efs). eapply (Ectx_step (Ks ++ [Ki])); done. }
      destruct H as [v H]. apply to_val_fill_some in H. by destruct H, Ks.
    - rename select (of_val vp = _) into Hvp.
      assert (to_val (fill Ks e1') = Some vp) as Hfillvp by rewrite -Hvp //.
      apply to_val_fill_some in Hfillvp as [-> ->]. inv_head_step.
    - rename select (of_val vt = _) into Hvt.
      assert (to_val (fill Ks e1') = Some vt) as Hfillvt by rewrite -Hvt //.
      apply to_val_fill_some in Hfillvt as [-> ->]. inv_head_step.
Qed.

Lemma wp_resolve s E e Φ (p : proph_id) v (pvs : list (val * val)) :
  Atomic StronglyAtomic e →
  to_val e = None →
  proph p pvs -∗
  WP e @ s; E {{ r, ∀ pvs', ⌜pvs = (r, v)::pvs'⌝ -∗ proph p pvs' -∗ Φ r }} -∗
  WP Resolve e (Val $ LitV $ LitProphecy p) (Val v) @ s; E {{ Φ }}.
Proof.
  (* TODO we should try to use a generic lifting lemma (and avoid [wp_unfold])
     here, since this breaks the WP abstraction. *)
  iIntros (A He) "Hp WPe". rewrite !wp_unfold /wp_pre /= He. simpl in *.
  iIntros (σ1 κ κs n) "[Hσ Hκ]". destruct κ as [|[p' [w' v']] κ' _] using rev_ind.
  - iMod ("WPe" $! σ1 [] κs n with "[$Hσ $Hκ]") as "[Hs WPe]". iModIntro. iSplit.
    { iDestruct "Hs" as "%". iPureIntro. destruct s; [ by apply resolve_reducible | done]. }
    iIntros (e2 σ2 efs step). exfalso. apply step_resolve in step; last done.
    inv_head_step. match goal with H: ?κs ++ [_] = [] |- _ => by destruct κs end.
  - rewrite -assoc.
    iMod ("WPe" $! σ1 _ _ n with "[$Hσ $Hκ]") as "[Hs WPe]". iModIntro. iSplit.
    { iDestruct "Hs" as %?. iPureIntro. destruct s; [ by apply resolve_reducible | done]. }
    iIntros (e2 σ2 efs step). apply step_resolve in step; last done.
    inv_head_step; simplify_list_eq.
    iMod ("WPe" $! (Val w') σ2 efs with "[%]") as "WPe".
    { by eexists [] _ _. }
    iModIntro. iNext. iMod "WPe" as "[[$ Hκ] WPe]".
    iMod (proph_map_resolve_proph p' (w',v') κs with "[$Hκ $Hp]") as (vs' ->) "[$ HPost]".
    iModIntro. rewrite !wp_unfold /wp_pre /=. iDestruct "WPe" as "[HΦ $]".
    iMod "HΦ". iModIntro. by iApply "HΦ".
Qed.

End lifting.


From Undecidability.L.Tactics Require Import LTactics.
From Undecidability.L Require Import UpToC.
From Undecidability.L.Datatypes Require Export List_enc List_in List_basics LBool LNat.

Set Default Proof Using "Type".

Definition lengthEq A :=
  fix f (t:list A) n :=
    match n,t with
      0,nil => true
    | (S n), _::t => f t n
    | _,_ => false
    end.
Lemma lengthEq_spec A (t:list A) n:
| t | =? n = lengthEq t n.
Proof.
  induction n in t|-*;destruct t;now cbn.
Qed.
Definition lengthEq_time k := k * 15 + 9.
Instance term_lengthEq A `{registered A} : computableTime' (lengthEq (A:=A)) (fun l _ => (5, fun n _ => (lengthEq_time (min (length l) n),tt))).
Proof.
  extract. unfold lengthEq_time. solverec.
Qed.

(* seq *)
Definition c__seq := 20.
Definition seq_time (len : nat) := (len + 1) * c__seq.
Instance term_seq : computableTime' seq (fun start _ => (5, fun len _ => (seq_time len, tt))).
Proof.
  extract. solverec.
  all: unfold seq_time, c__seq; solverec.
Qed.

(* prodLists *)
Section fixprodLists.
  Variable (X Y : Type).
  Context `{Xint : registered X} `{Yint : registered Y}.

  Definition c__prodLists1 := 22 + c__map + c__app.
  Definition c__prodLists2 := 2 * c__map + 39 + c__app.
  Definition prodLists_time (l1 : list X) (l2 : list Y) := (|l1|) * (|l2| + 1) * c__prodLists2 + c__prodLists1.
  Global Instance term_prodLists : computableTime' (@list_prod X Y) (fun l1 _ => (5, fun l2 _ => (prodLists_time l1 l2, tt))).
  Proof.
    apply computableTimeExt with (x := fix rec (A : list X) (B : list Y) : list (X * Y) :=
      match A with
      | [] => []
      | x :: A' => map (@pair X Y x) B ++ rec A' B
      end).
    1: { unfold list_prod. change (fun x => ?h x) with h. intros l1 l2. induction l1; easy. }
    extract. solverec.
    all: unfold prodLists_time, c__prodLists1, c__prodLists2; solverec.
    rewrite map_length, map_time_const. leq_crossout.
  Qed.
End fixprodLists.


Require Import VST.floyd.proofauto.
Local Open Scope logic.
Require Import List. Import ListNotations.
Require Import tweetnacl20140427.Snuffle.
Require Import tweetnacl20140427.Salsa20.
Require Import ZArith.

Require Import tweetnacl20140427.tweetnaclVerifiableC.
Require Import tweetnacl20140427.spec_salsa.
Require Import tweetnacl20140427.verif_salsa_base.
Opaque Snuffle20. Opaque prepare_data. Opaque Snuffle.Snuffle.

Lemma crypto_core_salsa20_ok: semax_body SalsaVarSpecs SalsaFunSpecs
      f_crypto_core_salsa20_tweet crypto_core_salsa20_spec.
Proof. unfold crypto_core_salsa20_spec.
start_function.
abbreviate_semax.
assert_PROP (field_compatible (tarray tuchar 64) [] out /\ isptr out) as HH by entailer!.
destruct HH as [FCout isptrout].
Time forward_call (c, k, Z0, nonce, out, default_val (tarray tuchar 64), data). (*1.8*)
  unfold data_at_, field_at_. rewrite field_at_data_at.
  rewrite field_address_offset by auto with field_compatible.
  rewrite isptr_offset_val_zero; trivial. cancel.
Intros ret.
Time forward. (*1.7*)
unfold fcore_result in H.
  remember (Snuffle20 (prepare_data data)) as d; symmetry in Heqd.
  destruct d. 2: inv H. rewrite Int.eq_true in H.
Exists l.
Time entailer!. apply derives_refl.
Time Qed. (*4.3*)

Lemma Snuffle_sub_simpl data x:
    Snuffle20 (prepare_data data) = Some x ->
    exists s, Snuffle 20 (prepare_data data) = Some s /\
    forall i (I:0 <= i < 16) v,
      Znth i (prepare_data data) = v ->
      littleendian_invert (Int.sub (Znth i x) v) =
      littleendian_invert (Znth i s).
Proof. intros.
Transparent Snuffle20. unfold Snuffle20 in H. Opaque Snuffle20.
remember (Snuffle 20 (prepare_data data)) as sn.
destruct sn; simpl in H. 2: inv H. clear Heqsn.
exists l; split; trivial.
intros. rewrite (sumlist_char_Znth _ _ _ H).
  rewrite Int.add_commut, Int.sub_add_l, H0, Int.sub_idem, Int.add_zero_l. trivial.
symmetry in H; apply sumlist_length in H.
rewrite Zlength_correct, H, prepare_data_length; trivial.
Qed.

Lemma crypto_core_hsalsa20_ok: semax_body SalsaVarSpecs SalsaFunSpecs
      f_crypto_core_hsalsa20_tweet crypto_core_hsalsa20_spec.
Proof. unfold crypto_core_hsalsa20_spec.
start_function.
Time forward_call (c, k, 1, nonce, out, OUT, data). (*1.4*)
Intros res.
Time forward. (*1.6*)
unfold fcore_result in H.
  remember (Snuffle20 (prepare_data data)) as d; symmetry in Heqd.
  destruct d. 2: inv H. rewrite Int.eq_false in H.
destruct (Snuffle_sub_simpl _ _ Heqd) as [x [X1 X2]].
Exists x.
Time entailer!. (*0.6*)
2: apply Int.one_not_zero.
unfold fcorePOST_SEP; cancel.
  destruct data as[[Nonce C] [K L]].
  destruct C as [[[C1 C2] C3] C4].
  destruct Nonce as [[[N1 N2] N3] N4].
  destruct K as [[[K1 K2] K3] K4].
  destruct L as [[[L1 L2] L3] L4].
apply derives_refl'. f_equal.
  do 8 rewrite X2 in H by (try omega; reflexivity).
  apply H.
Time Qed. (*2.8*)


Require Import Coq.ZArith.ZArith. Local Open Scope Z_scope.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List. Import ListNotations.
Require Import coqutil.Tactics.Tactics.
Require Import riscv.Spec.Machine.
Require Import riscv.Platform.Memory.
Require Import riscv.Spec.CSRFile.
Require Import riscv.Utility.Utility.
Require Import riscv.Utility.RecordSetters.
Require Import coqutil.Z.Lia.
Require Import coqutil.Map.Interface.
Require Import riscv.Platform.MaterializeRiscvProgram.

Module map.
  (* Swap argument order to enable usage of partially applied `map.set k v` as an updater *)
  Definition set{key value}{map: map.map key value}(k: key)(v: value)(m: map): map :=
    map.put m k v.
End map.

Section Riscv.
  Context {width: Z} {BW: Bitwidth width} {word: word width} {word_ok: word.ok word}.
  Context {Mem: map.map word byte}.
  Context {Registers: map.map Z word}.

  (* (memory before call, call name, arg values) and (memory after call, return values) *)
  Definition LogItem: Type := (Mem * string * list word) * (Mem * list word).

  Record State := mkState {
    regs: Registers;
    pc: word;
    nextPc: word;
    mem: Mem;
    log: list LogItem;
    csrs: CSRFile
  }.

  (* TODO: add XAddrs tracking so that executing an instruction written in a previous cycle
     (which potentially is already in the pipeline) is not allowed *)

  Definition store(n: nat)(ctxid: SourceType)(a: word) v (mach: State)(post: State -> Prop) :=
    match Memory.store_bytes n mach.(mem) a v with
    | Some m => post { mach with mem := m }
    | None => False
    end.

  Definition load(n: nat)(ctxid: SourceType)(a: word)(mach: State)(post: _ -> _ -> Prop) :=
    match Memory.load_bytes n mach.(mem) a with
    | Some v => post v mach
    | None => False
    end.

  Definition updatePc(mach: State): State :=
    { mach with pc := mach.(nextPc); nextPc ::= word.add (word.of_Z 4) }.

  Definition getReg(regs: Registers)(reg: Z): word :=
    if ((0 <? reg) && (reg <? 32))%bool then
      match map.get regs reg with
      | Some x => x
      | None => word.of_Z 0
      end
    else word.of_Z 0.

  Definition setReg(reg: Z)(v: word)(regs: Registers): Registers :=
    if ((0 <? reg) && (reg <? 32))%bool then map.put regs reg v else regs.

  Definition run_primitive(a: riscv_primitive)(mach: State):
             (primitive_result a -> State -> Prop) -> (State -> Prop) -> Prop :=
    match a with
    | GetRegister reg => fun postF postA => postF (getReg mach.(regs) reg) mach
    | SetRegister reg v => fun postF postA => postF tt { mach with regs ::= setReg reg v }
    | GetPC => fun postF postA => postF mach.(pc) mach
    | SetPC newPC => fun postF postA => postF tt { mach with nextPc := newPC }
    | LoadByte ctxid a => fun postF postA => load 1 ctxid a mach postF
    | LoadHalf ctxid a => fun postF postA => load 2 ctxid a mach postF
    | LoadWord ctxid a => fun postF postA => load 4 ctxid a mach postF
    | LoadDouble ctxid a => fun postF postA => load 8 ctxid a mach postF
    | StoreByte ctxid a v => fun postF postA => store 1 ctxid a v mach (postF tt)
    | StoreHalf ctxid a v => fun postF postA => store 2 ctxid a v mach (postF tt)
    | StoreWord ctxid a v => fun postF postA => store 4 ctxid a v mach (postF tt)
    | StoreDouble ctxid a v => fun postF postA => store 8 ctxid a v mach (postF tt)
    | StartCycle => fun postF postA =>
        postF tt { mach with nextPc := word.add mach.(pc) (word.of_Z 4) }
    | EndCycleNormal => fun postF postA => postF tt (updatePc mach)
    | EndCycleEarly _ => fun postF postA => postA (updatePc mach) (* ignores postF containing the continuation *)
    | GetCSRField f => fun postF postA =>
                         match map.get mach.(csrs) f with
                         | Some v => postF v mach
                         | None => False
                         end
    | SetCSRField f v => fun postF postA =>
                           (* only allow setting CSR fields that are supported (not None) on this machine *)
                           match map.get mach.(csrs) f with
                           | Some _ => postF tt { mach with csrs ::= map.set f v }
                           | None => False
                           end
    | GetPrivMode => fun postF postA => postF Machine mach
    | SetPrivMode mode => fun postF postA =>
                            match mode with
                            | Machine => postF tt mach
                            | User | Supervisor => False
                            end
    | MakeReservation _
    | ClearReservation _
    | CheckReservation _
    | Fence _ _
        => fun postF postA => False
    end.

  Lemma weaken_load: forall n c a m (post1 post2:_->_->Prop),
      (forall r s, post1 r s -> post2 r s) ->
      load n c a m post1 -> load n c a m post2.
  Proof.
    unfold load. intros. destruct (load_bytes n m.(mem) a); intuition eauto.
  Qed.

  Lemma weaken_store: forall n c a v m (post1 post2:_->Prop),
      (forall s, post1 s -> post2 s) ->
      store n c a v m post1 -> store n c a v m post2.
  Proof.
    unfold store. intros. destruct (store_bytes n m.(mem) a v); intuition eauto.
  Qed.

  Lemma weaken_run_primitive: forall a (postF1 postF2: _ -> _ -> Prop) (postA1 postA2: _ -> Prop),
    (forall r s, postF1 r s -> postF2 r s) ->
    (forall s, postA1 s -> postA2 s) ->
    forall s, run_primitive a s postF1 postA1 -> run_primitive a s postF2 postA2.
  Proof.
    destruct a; cbn; intros; try solve [intuition eauto using weaken_load, weaken_store];
      destruct_one_match; eauto.
  Qed.

End Riscv.


Require Import Bmc.Forward.
Require Import Bmc.Example.

Require Import SMTC.Tactic.
Require Import SMTC.Integers.

Set SMT Solver "z3".
Set SMT Debug.

Axiom by_smt : forall P : Prop, P.

Goal forward_post_conj ex1_I ex1_T ex1_P 4.
Proof.
  unfold ex1_I, ex1_T, ex1_P.
  unfold forward_post_conj.
  unfold lasso_fwd_conj.
  unfold safety_nth_conj.
  unfold prop_nth_init_conj.
  unfold loop_free.
  unfold path.
  unfold no_loop.
  unfold no_loop'.
  unfold sseq.
  unfold nth.
  unfold state.
  repeat rewrite -> Nat.add_0_l.
  repeat rewrite -> Nat.add_0_r.

  split.
  - intros.
    smt solve; apply by_smt.

  - repeat split.
    + intros.
      smt solve; apply by_smt.
    + intros.
      smt solve; apply by_smt.
    + intros.
      smt solve; apply by_smt.
    + intros.
      smt solve; apply by_smt.
    + intros.
      smt solve; apply by_smt.
Qed.

Goal forward_post_conj ex2_I ex2_T ex2_P 2.
Proof.
  unfold ex2_I, ex2_T, ex2_P.
  unfold forward_post_conj, lasso_fwd_conj, safety_nth_conj, prop_nth_init_conj, loop_free, path, no_loop, no_loop', sseq, nth, state.
  repeat rewrite -> Nat.add_0_l;
  repeat rewrite -> Nat.add_0_r.
  split.
  intros; smt solve; apply by_smt.
  repeat split; intros; smt solve; apply by_smt.
Qed.

Goal forward_post_conj ex3_I ex3_T ex3_P 6.
Proof.
  unfold ex3_I, ex3_T, ex3_P.
  unfold forward_post_conj, lasso_fwd_conj, safety_nth_conj, prop_nth_init_conj, loop_free, path, no_loop, no_loop', sseq, nth, state.
  repeat rewrite -> Nat.add_0_l;
  repeat rewrite -> Nat.add_0_r.
  split.
  intros; smt solve; apply by_smt.
  repeat split; intros; smt solve; apply by_smt.
Qed.

(* eof *)


Require Import NArith.
Require Import Arith.
Require Import Bool.
Require Import List.
Require Import Bag.
Require Import Dict.
Require Import Misc.
Require Import SpaceSearch.CpdtTactics.
Require Import JamesTactics.
Require Import Coq.Program.Basics.
Require Import SpaceSearch.EqDec.
Require Import Enumerable.
Require Import BGPSpec.
Require Import Reachable.
Require Import Tracking.
Require Import KonneTactics.
Require Import Equality.
Require Import BGPSpecFacts.
Require Import Policy.
Import EqNotations.
Import ListNotations.

Section FastPolicy.
  Variable plainPrefix : PrefixClass.
  Variable plainTopology : TopologyClass.
  Variable plainAttributes : PathAttributesClass.
  Variable plainConfiguration : forall r, ConfigurationClass r.

  Definition trackingAttributes' := @trackingAttributes _ plainAttributes.
  Definition trackingConfiguration' := @trackingConfiguration _ _ plainAttributes plainConfiguration.
  Existing Instance trackingAttributes' | 0.
  Existing Instance trackingConfiguration' | 0.
  Typeclasses Transparent trackingAttributes'.
  Typeclasses Transparent trackingConfiguration'.
  Existing Instance enumerableIncoming.
  Existing Instance eqDecIncoming.

  Definition fastPolicy (P:forall r, incoming r -> outgoing r -> Prefix ->
                       RoutingInformation -> RoutingInformation ->
                       RoutingInformation -> RoutingInformation -> bool) : Prop :=
    forall r s d p s' ai ai',
      trackingOk r s p ai ->
      trackingOk r s' p ai' ->
      let al' := @import' _ trackingAttributes' _ r _ s  p ai in
      let al  := @import' _ trackingAttributes' _ r _ s' p ai' in
      let ao  := @export' _ trackingAttributes' _ r _ s' d p al in
        leDecRoutingInformation al' al = true -> P r s d p ai al' al ao = true.

  Theorem fastPolicyImpliesPolicy : forall P, fastPolicy P -> (@policy _ _ trackingAttributes' trackingConfiguration' P).
    intros P Q. unfold policy, fastPolicy in *.
    intros r s d p ns R.
    specialize (routerStateOk r s d p ns R); intro S.
    destruct S as [s' S].
    destruct S as [S S']. destruct S' as [S' S''].
    unfold build, lookup in *.
    unfold trackingAttributes' in *.
    rewrite S'. rewrite S''.
    pose (in_ := adjRIBsIn (lookup (routerState ns) r)).
    pose (ai  := lookup in_ (s, p)).
    pose (ai' := lookup in_ (s', p)).
    specialize (reachableImpliesTrackingOk ns R); intros F. destruct F as [F _].
    refine ((fun F' => _) F).
    specialize (F r s p).
    specialize (F' r s' p).
    specialize (Q r s d p s' ai ai' F F' S).
    inline_all.
    unfold build, lookup in *.
    trivial.
  Qed.
End FastPolicy.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import List.
Require Import ListSet.
Require Import String.
Require Import ZArith.
Require Import Permutation.
Require Import Equivalence.
Require Import Morphisms.
Require Import Program.
Require Import EquivDec.
Require Import Bool.
Require Import Utils.
Require Import ForeignData.
Require Import Data.
Require Import DataLift.

Section RecOperators.
  Context {fdata:foreign_data}.

  Section RecConcat.
    (** Semantics of the [rec_concat] operator. *)
    Definition recconcat (r1 r2:list (string*data)) :=
      rec_concat_sort r1 r2.

    Inductive rec_concat_sem: data -> data -> data -> Prop :=
    | sem_rec_concat:
        forall r1 r2,
          rec_concat_sem (drec r1) (drec r2)
                         (drec (recconcat r1 r2)).

    (* [orecconcat] is correct and complete wrt. the [rec_concat_sem]
       semantics. *)

    Definition orecconcat (a:data) (x:data) :=
      match a with
      | drec r2 =>
        match x with
        | drec r1 => Some (drec (rec_concat_sort r2 r1))
        | _ => None
        end
      | _ => None
      end.

    Lemma orecconcat_correct : forall d d1 d2,
        orecconcat d d1 = Some d2 ->
        rec_concat_sem d d1 d2.
    Proof.
      intros.
      destruct d; destruct d1; simpl in *; try congruence.
      inversion H; econstructor; reflexivity.
    Qed.

    Lemma orecconcat_complete : forall d d1 d2,
        rec_concat_sem d d1 d2 ->
        orecconcat d d1 = Some d2.
    Proof.
      intros.
      inversion H; subst.
      reflexivity.
    Qed.

    Lemma orecconcat_correct_and_complete : forall d d1 d2,
        orecconcat d d1 = Some d2 <->
        rec_concat_sem d d1 d2.
    Proof.
      split.
      apply orecconcat_correct.
      apply orecconcat_complete.
    Qed.
  End RecConcat.

  Section SRProject.
    Definition sorted_vector (s:list string) : list string :=
      insertion_sort ODT_lt_dec s.

    Lemma sorted_vector_sorted (s:list string) :
      is_list_sorted ODT_lt_dec (sorted_vector s) = true.
    Proof.
      rewrite is_list_sorted_Sorted_iff.
      apply insertion_sort_Sorted.
    Qed.

    Definition projected_subset (s1 s2:list string) : list string :=
      filter (fun x => if in_dec string_dec x s2 then true else false) s1.

    Lemma projected_subst_sorted (s1 s2:list string) :
      is_list_sorted ODT_lt_dec s1 = true ->
      is_list_sorted ODT_lt_dec (projected_subset s1 s2) = true.
    Proof.
      intros.
      rewrite sorted_StronglySorted.
      apply StronglySorted_filter.
      rewrite <- sorted_StronglySorted.
      eauto.
      apply StrictOrder_Transitive.
      apply StrictOrder_Transitive.
    Qed.

    Lemma sorted_projected_subset_is_sublist (s1 s2:list string):
      is_list_sorted ODT_lt_dec s1 = true ->
      is_list_sorted ODT_lt_dec s2 = true ->
      sublist (projected_subset s1 s2) s2.
    Proof.
      intros.
      apply StronglySorted_incl_sublist.
      rewrite <- sorted_StronglySorted.
      eapply projected_subst_sorted; assumption.
      apply StrictOrder_Transitive.
      rewrite <- sorted_StronglySorted.
      eauto.
      apply StrictOrder_Transitive.
      intros.
      unfold projected_subset in *.
      induction s1; simpl in H1.
      contradiction.
      assert (is_list_sorted ODT_lt_dec s1 = true).
      apply (@is_list_sorted_cons_inv string _ _ a s1); assumption.
      specialize (IHs1 H2); clear H.
      destruct (in_dec string_dec a s2); simpl in *.
      - elim H1; clear H1; intros.
        subst.
        assumption.
        apply (IHs1 H).
      - apply (IHs1 H1).
    Qed.

    (* This is a form of projection that guarantees that the projection
       list is first sorted then pruned to the domain of its input. *)

    Definition srproject {A} (l:list (string*A)) (s:list string) : list (string*A) :=
      let ps := (projected_subset (sorted_vector s) (domain l)) in
      rproject l ps.

    Lemma insertion_sort_insert_equiv_vec (x a:string) (l:list string) :
      In x
         (SortingAdd.insertion_sort_insert ODT_lt_dec a l) <->
      a = x \/ In x l.
    Proof.
      induction l; simpl; [intuition|].
      destruct a; destruct a0; simpl in *.
      split; intros.
      intuition.
      intuition.
      split; intros.
      intuition.
      intuition.
      split; intros.
      intuition.
      intuition.
      destruct (StringOrder.lt_dec (String a a1) (String a0 a2)); simpl; [intuition|].
      destruct (StringOrder.lt_dec (String a0 a2) (String a a1)); simpl; [intuition|].
      split; intros.
      intuition.
      intuition.
      subst; clear H0.
      revert n n0 H1 H3.
      generalize (String a a1), (String a0 a2); intros.
      left.
      destruct (trichotemy s s0); intuition.
    Qed.

    Lemma sorted_vector_equivlist l :
      equivlist (sorted_vector l) l.
    Proof.
      unfold equivlist.
      induction l; simpl; [intuition|]; intros x.
      rewrite <- IHl. apply insertion_sort_insert_equiv_vec.
    Qed.

    Lemma equivlist_in_dec (x:string) (s1 s2:list string) :
      (equivlist s1 s2) ->
      (if (in_dec string_dec x s1) then true else false) =
      (if (in_dec string_dec x s2) then true else false).
    Proof.
      intros.
      destruct (in_dec string_dec x s1); destruct (in_dec string_dec x s2); try reflexivity.
      assert (In x s2). rewrite <- H; assumption. congruence.
      assert (In x s1). rewrite H; assumption. congruence.
    Qed.

    Lemma sorted_vector_in_dec (x:string) (s1:list string):
      (if (in_dec string_dec x s1) then true else false) =
      (if (in_dec string_dec x (sorted_vector s1)) then true else false).
    Proof.
      rewrite (equivlist_in_dec x s1 (sorted_vector s1)).
      reflexivity.
      rewrite sorted_vector_equivlist.
      reflexivity.
    Qed.

    Lemma in_intersection_projected (x:string) (s1 s2:list string) :
      In x s1 /\ In x s2 -> In x (projected_subset s1 s2).
    Proof.
      intros.
      elim H; clear H; intros.
      induction s1.
      simpl in *. contradiction.
      simpl in *.
      elim H; clear H; intros.
      subst.
      destruct (in_dec string_dec x s2); try congruence.
      simpl; left; reflexivity.
      specialize (IHs1 H); clear H0 H.
      destruct (in_dec string_dec a s2); auto.
      simpl; right; assumption.
    Qed.

    Lemma in_projected (x:string) (s1 s2:list string) :
      In x (projected_subset s1 s2) -> In x s1.
    Proof.
      intros.
      induction s1; simpl in *; [contradiction|].
      destruct (in_dec string_dec a s2); simpl in *.
      elim H; clear H; intros.
      left; assumption.
      right; apply (IHs1 H).
      right; apply (IHs1 H).
    Qed.

    Lemma sproject_in_dec {A} (x:string) (s1:list string) (l:list (string*A)) :
      In x (domain l) ->
      (if (in_dec string_dec x s1) then true else false) =
      (if (in_dec string_dec x (projected_subset s1 (domain l))) then true else false).
    Proof.
      intros.
      destruct (in_dec string_dec x s1); destruct (in_dec string_dec x (projected_subset s1 (domain l))); try reflexivity.
      - assert (In x (projected_subset s1 (domain l))) by
            (apply in_intersection_projected; auto).
        congruence.
      - assert (In x s1) by (apply (in_projected x s1 (domain l)); assumption).
        congruence.
    Qed.

    Lemma rproject_sproject {A} (l:list (string*A)) (s:list string) :
      is_list_sorted ODT_lt_dec (domain l) = true ->
      rproject l s = srproject l s.
    Proof.
      intros.
      unfold srproject.
      unfold rproject.
      assert (filter
                (fun x : string * A =>
                   if in_dec string_dec (fst x) s then true else false) l =
              filter
                (fun x : string * A =>
                   if in_dec string_dec (fst x) (sorted_vector s) then true else false) l).
      apply filter_eq; intros.
      rewrite sorted_vector_in_dec; reflexivity.
      rewrite H0; clear H0;
        generalize (sorted_vector s) as ss; intros.
      apply filter_ext; intros.
      apply sproject_in_dec.
      destruct x; simpl in *.
      induction l; try auto.
      assert (is_list_sorted StringOrder.lt_dec (domain l) = true).
      apply (@is_list_sorted_cons_inv string _ _ (fst a0) (domain l)); assumption.
      specialize (IHl H1); clear H1 H.
      simpl in *.
      elim H0; clear H0; intros.
      subst; simpl; left; reflexivity.
      right; apply (IHl H).
    Qed.

  End SRProject.
End RecOperators.


From stdpp Require Export list gmap.
From iris.algebra Require Export cmra.
From iris.algebra Require Import updates local_updates proofmode_classes.
From iris.base_logic Require Import base_logic.
From iris Require Import options.

Section cofe.
Context `{Countable K} {A : ofeT}.
Implicit Types m : gmap K A.
Implicit Types i : K.

Instance gmap_dist : Dist (gmap K A) := λ n m1 m2,
  ∀ i, m1 !! i ≡{n}≡ m2 !! i.
Definition gmap_ofe_mixin : OfeMixin (gmap K A).
Proof.
  split.
  - intros m1 m2; split.
    + by intros Hm n k; apply equiv_dist.
    + intros Hm k; apply equiv_dist; intros n; apply Hm.
  - intros n; split.
    + by intros m k.
    + by intros m1 m2 ? k.
    + by intros m1 m2 m3 ?? k; trans (m2 !! k).
  - by intros n m1 m2 ? k; apply dist_S.
Qed.
Canonical Structure gmapO : ofeT := OfeT (gmap K A) gmap_ofe_mixin.

Program Definition gmap_chain (c : chain gmapO)
  (k : K) : chain (optionO A) := {| chain_car n := c n !! k |}.
Next Obligation. by intros c k n i ?; apply (chain_cauchy c). Qed.
Definition gmap_compl `{Cofe A} : Compl gmapO := λ c,
  map_imap (λ i _, compl (gmap_chain c i)) (c 0).
Global Program Instance gmap_cofe `{Cofe A} : Cofe gmapO :=
  {| compl := gmap_compl |}.
Next Obligation.
  intros ? n c k. rewrite /compl /gmap_compl map_lookup_imap.
  feed inversion (λ H, chain_cauchy c 0 n H k);simplify_option_eq;auto with lia.
  by rewrite conv_compl /=; apply reflexive_eq.
Qed.

Global Instance gmap_ofe_discrete : OfeDiscrete A → OfeDiscrete gmapO.
Proof. intros ? m m' ? i. by apply (discrete _). Qed.
(* why doesn't this go automatic? *)
Global Instance gmapO_leibniz: LeibnizEquiv A → LeibnizEquiv gmapO.
Proof. intros; change (LeibnizEquiv (gmap K A)); apply _. Qed.

Global Instance lookup_ne k : NonExpansive (lookup k : gmap K A → option A).
Proof. by intros n m1 m2. Qed.
Global Instance lookup_total_ne `{!Inhabited A} k :
  NonExpansive (lookup_total k : gmap K A → A).
Proof. intros n m1 m2. rewrite !lookup_total_alt. by intros ->. Qed.
Global Instance partial_alter_ne n :
  Proper ((dist n ==> dist n) ==> (=) ==> dist n ==> dist n)
         (partial_alter (M:=gmap K A)).
Proof.
  by intros f1 f2 Hf i ? <- m1 m2 Hm j; destruct (decide (i = j)) as [->|];
    rewrite ?lookup_partial_alter ?lookup_partial_alter_ne //;
    try apply Hf; apply lookup_ne.
Qed.
Global Instance insert_ne i : NonExpansive2 (insert (M:=gmap K A) i).
Proof. intros n x y ? m m' ? j; apply partial_alter_ne; by try constructor. Qed.
Global Instance singleton_ne i : NonExpansive (singletonM i : A → gmap K A).
Proof. by intros ????; apply insert_ne. Qed.
Global Instance delete_ne i : NonExpansive (delete (M:=gmap K A) i).
Proof.
  intros n m m' ? j; destruct (decide (i = j)); simplify_map_eq;
    [by constructor|by apply lookup_ne].
Qed.
Global Instance alter_ne (f : A → A) (k : K) n :
  Proper (dist n ==> dist n) f → Proper (dist n ==> dist n) (alter f k).
Proof. intros ? m m' Hm k'. by apply partial_alter_ne; [solve_proper|..]. Qed.

Global Instance gmap_empty_discrete : Discrete (∅ : gmap K A).
Proof.
  intros m Hm i; specialize (Hm i); rewrite lookup_empty in Hm |- *.
  inversion_clear Hm; constructor.
Qed.
Global Instance gmap_lookup_discrete m i : Discrete m → Discrete (m !! i).
Proof.
  intros ? [x|] Hx; [|by symmetry; apply: discrete].
  assert (m ≡{0}≡ <[i:=x]> m)
    by (by symmetry in Hx; inversion Hx; ofe_subst; rewrite insert_id).
  by rewrite (discrete m (<[i:=x]>m)) // lookup_insert.
Qed.
Global Instance gmap_insert_discrete m i x :
  Discrete x → Discrete m → Discrete (<[i:=x]>m).
Proof.
  intros ?? m' Hm j; destruct (decide (i = j)); simplify_map_eq.
  { by apply: discrete; rewrite -Hm lookup_insert. }
  by apply: discrete; rewrite -Hm lookup_insert_ne.
Qed.
Global Instance gmap_singleton_discrete i x :
  Discrete x → Discrete ({[ i := x ]} : gmap K A) := _.
Lemma insert_idN n m i x :
  m !! i ≡{n}≡ Some x → <[i:=x]>m ≡{n}≡ m.
Proof. intros (y'&?&->)%dist_Some_inv_r'. by rewrite insert_id. Qed.

(** Internalized properties *)
Lemma gmap_equivI {M} m1 m2 : m1 ≡ m2 ⊣⊢@{uPredI M} ∀ i, m1 !! i ≡ m2 !! i.
Proof. by uPred.unseal. Qed.
End cofe.

Arguments gmapO _ {_ _} _.

(** Non-expansiveness of higher-order map functions and big-ops *)
Lemma merge_ne `{Countable K} {A B C : ofeT} (f g : option A → option B → option C)
    `{!DiagNone f, !DiagNone g} n :
  ((dist n) ==> (dist n) ==> (dist n))%signature f g →
  ((dist n) ==> (dist n) ==> (dist n))%signature (merge (M:=gmap K) f) (merge g).
Proof. by intros Hf ?? Hm1 ?? Hm2 i; rewrite !lookup_merge //; apply Hf. Qed.
Instance union_with_proper `{Countable K} {A : ofeT} n :
  Proper (((dist n) ==> (dist n) ==> (dist n)) ==>
          (dist n) ==> (dist n) ==>(dist n)) (union_with (M:=gmap K A)).
Proof.
  intros ?? Hf ?? Hm1 ?? Hm2 i; apply (merge_ne _ _); auto.
  by do 2 destruct 1; first [apply Hf | constructor].
Qed.
Instance map_fmap_proper `{Countable K} {A B : ofeT} (f : A → B) n :
  Proper (dist n ==> dist n) f → Proper (dist n ==> dist n) (fmap (M:=gmap K) f).
Proof. intros ? m m' ? k; rewrite !lookup_fmap. by repeat f_equiv. Qed.
Instance map_zip_with_proper `{Countable K} {A B C : ofeT} (f : A → B → C) n :
  Proper (dist n ==> dist n ==> dist n) f →
  Proper (dist n ==> dist n ==> dist n) (map_zip_with (M:=gmap K) f).
Proof.
  intros Hf m1 m1' Hm1 m2 m2' Hm2. apply merge_ne; try done.
  destruct 1; destruct 1; repeat f_equiv; constructor || done.
Qed.

Lemma big_opM_ne_2 `{Monoid M o} `{Countable K} {A : ofeT} (f g : K → A → M) m1 m2 n :
  m1 ≡{n}≡ m2 →
  (∀ k y1 y2,
    m1 !! k = Some y1 → m2 !! k = Some y2 → y1 ≡{n}≡ y2 → f k y1 ≡{n}≡ g k y2) →
  ([^o map] k ↦ y ∈ m1, f k y) ≡{n}≡ ([^o map] k ↦ y ∈ m2, g k y).
Proof.
  intros Hl Hf. apply big_opM_gen_proper_2; try (apply _ || done).
  { by intros ?? ->. }
  { apply monoid_ne. }
  intros k. assert (m1 !! k ≡{n}≡ m2 !! k) as Hlk by (by f_equiv).
  destruct (m1 !! k) eqn:?, (m2 !! k) eqn:?; inversion Hlk; naive_solver.
Qed.

Lemma big_sepM2_ne_2 {PROP : bi} `{Countable K} (A B : ofeT)
    (Φ Ψ : K → A → B → PROP) m1 m2 m1' m2' n :
  m1 ≡{n}≡ m1' → m2 ≡{n}≡ m2' →
  (∀ k y1 y1' y2 y2',
    m1 !! k = Some y1 → m1' !! k = Some y1' → y1 ≡{n}≡ y1' →
    m2 !! k = Some y2 → m2' !! k = Some y2' → y2 ≡{n}≡ y2' →
    Φ k y1 y2 ≡{n}≡ Ψ k y1' y2') →
  ([∗ map] k ↦ y1;y2 ∈ m1;m2, Φ k y1 y2)%I ≡{n}≡ ([∗ map] k ↦ y1;y2 ∈ m1';m2', Ψ k y1 y2)%I.
Proof.
  intros Hm1 Hm2 Hf. rewrite big_sepM2_eq /big_sepM2_def. f_equiv.
  { f_equiv; split; intros Hm k.
    - trans (is_Some (m1 !! k)); [symmetry; apply: is_Some_ne; by f_equiv|].
      rewrite Hm. apply: is_Some_ne; by f_equiv.
    - trans (is_Some (m1' !! k)); [apply: is_Some_ne; by f_equiv|].
      rewrite Hm. symmetry. apply: is_Some_ne; by f_equiv. }
  apply big_opM_ne_2; [by f_equiv|].
  intros k [x1 y1] [x2 y2] (?&?&[=<- <-]&?&?)%map_lookup_zip_with_Some
    (?&?&[=<- <-]&?&?)%map_lookup_zip_with_Some [??]; naive_solver.
Qed.

(* CMRA *)
Section cmra.
Context `{Countable K} {A : cmraT}.
Implicit Types m : gmap K A.

Instance gmap_unit : Unit (gmap K A) := (∅ : gmap K A).
Instance gmap_op : Op (gmap K A) := merge op.
Instance gmap_pcore : PCore (gmap K A) := λ m, Some (omap pcore m).
Instance gmap_valid : Valid (gmap K A) := λ m, ∀ i, ✓ (m !! i).
Instance gmap_validN : ValidN (gmap K A) := λ n m, ∀ i, ✓{n} (m !! i).

Lemma lookup_op m1 m2 i : (m1 ⋅ m2) !! i = m1 !! i ⋅ m2 !! i.
Proof. by apply lookup_merge. Qed.
Lemma lookup_core m i : core m !! i = core (m !! i).
Proof. by apply lookup_omap. Qed.

Lemma lookup_includedN n (m1 m2 : gmap K A) : m1 ≼{n} m2 ↔ ∀ i, m1 !! i ≼{n} m2 !! i.
Proof.
  split; [by intros [m Hm] i; exists (m !! i); rewrite -lookup_op Hm|].
  revert m2. induction m1 as [|i x m Hi IH] using map_ind=> m2 Hm.
  { exists m2. by rewrite left_id. }
  destruct (IH (delete i m2)) as [m2' Hm2'].
  { intros j. move: (Hm j); destruct (decide (i = j)) as [->|].
    - intros _. rewrite Hi. apply: ucmra_unit_leastN.
    - rewrite lookup_insert_ne // lookup_delete_ne //. }
  destruct (Hm i) as [my Hi']; simplify_map_eq.
  exists (partial_alter (λ _, my) i m2')=>j; destruct (decide (i = j)) as [->|].
  - by rewrite Hi' lookup_op lookup_insert lookup_partial_alter.
  - move: (Hm2' j). by rewrite !lookup_op lookup_delete_ne //
      lookup_insert_ne // lookup_partial_alter_ne.
Qed.

(* [m1 ≼ m2] is not equivalent to [∀ n, m1 ≼{n} m2],
so there is no good way to reuse the above proof. *)
Lemma lookup_included (m1 m2 : gmap K A) : m1 ≼ m2 ↔ ∀ i, m1 !! i ≼ m2 !! i.
Proof.
  split; [by intros [m Hm] i; exists (m !! i); rewrite -lookup_op Hm|].
  revert m2. induction m1 as [|i x m Hi IH] using map_ind=> m2 Hm.
  { exists m2. by rewrite left_id. }
  destruct (IH (delete i m2)) as [m2' Hm2'].
  { intros j. move: (Hm j); destruct (decide (i = j)) as [->|].
    - intros _. rewrite Hi. apply: ucmra_unit_least.
    - rewrite lookup_insert_ne // lookup_delete_ne //. }
  destruct (Hm i) as [my Hi']; simplify_map_eq.
  exists (partial_alter (λ _, my) i m2')=>j; destruct (decide (i = j)) as [->|].
  - by rewrite Hi' lookup_op lookup_insert lookup_partial_alter.
  - move: (Hm2' j). by rewrite !lookup_op lookup_delete_ne //
      lookup_insert_ne // lookup_partial_alter_ne.
Qed.

Lemma gmap_cmra_mixin : CmraMixin (gmap K A).
Proof.
  apply cmra_total_mixin.
  - eauto.
  - intros n m1 m2 m3 Hm i; by rewrite !lookup_op (Hm i).
  - intros n m1 m2 Hm i; by rewrite !lookup_core (Hm i).
  - intros n m1 m2 Hm ? i; by rewrite -(Hm i).
  - intros m; split.
    + by intros ? n i; apply cmra_valid_validN.
    + intros Hm i; apply cmra_valid_validN=> n; apply Hm.
  - intros n m Hm i; apply cmra_validN_S, Hm.
  - by intros m1 m2 m3 i; rewrite !lookup_op assoc.
  - by intros m1 m2 i; rewrite !lookup_op comm.
  - intros m i. by rewrite lookup_op lookup_core cmra_core_l.
  - intros m i. by rewrite !lookup_core cmra_core_idemp.
  - intros m1 m2; rewrite !lookup_included=> Hm i.
    rewrite !lookup_core. by apply cmra_core_mono.
  - intros n m1 m2 Hm i; apply cmra_validN_op_l with (m2 !! i).
    by rewrite -lookup_op.
  - intros n m y1 y2 Hm Heq.
    refine ((λ FUN, _) (λ i, cmra_extend n (m !! i) (y1 !! i) (y2 !! i) (Hm i) _));
      last by rewrite -lookup_op.
    exists (map_imap (λ i _, projT1 (FUN i)) y1).
    exists (map_imap (λ i _, proj1_sig (projT2 (FUN i))) y2).
    split; [|split]=>i; rewrite ?lookup_op !map_lookup_imap;
    destruct (FUN i) as (z1i&z2i&Hmi&Hz1i&Hz2i)=>/=.
    + destruct (y1 !! i), (y2 !! i); inversion Hz1i; inversion Hz2i; subst=>//.
    + revert Hz1i. case: (y1!!i)=>[?|] //.
    + revert Hz2i. case: (y2!!i)=>[?|] //.
Qed.
Canonical Structure gmapR := CmraT (gmap K A) gmap_cmra_mixin.

Global Instance gmap_cmra_discrete : CmraDiscrete A → CmraDiscrete gmapR.
Proof. split; [apply _|]. intros m ? i. by apply: cmra_discrete_valid. Qed.

Lemma gmap_ucmra_mixin : UcmraMixin (gmap K A).
Proof.
  split.
  - by intros i; rewrite lookup_empty.
  - by intros m i; rewrite /= lookup_op lookup_empty (left_id_L None _).
  - constructor=> i. by rewrite lookup_omap lookup_empty.
Qed.
Canonical Structure gmapUR := UcmraT (gmap K A) gmap_ucmra_mixin.

(** Internalized properties *)
Lemma gmap_validI {M} m : ✓ m ⊣⊢@{uPredI M} ∀ i, ✓ (m !! i).
Proof. by uPred.unseal. Qed.
Lemma singleton_validI {M} i x : ✓ {[ i := x ]} ⊣⊢@{uPredI M} ✓ x.
Proof.
  rewrite gmap_validI. apply: anti_symm.
  - rewrite (bi.forall_elim i) lookup_singleton uPred.option_validI. done.
  - apply bi.forall_intro=>j. destruct (decide (i = j)) as [<-|Hne].
    + rewrite lookup_singleton uPred.option_validI. done.
    + rewrite lookup_singleton_ne // uPred.option_validI.
      apply bi.True_intro.
Qed.
End cmra.

Arguments gmapR _ {_ _} _.
Arguments gmapUR _ {_ _} _.

Section properties.
Context `{Countable K} {A : cmraT}.
Implicit Types m : gmap K A.
Implicit Types i : K.
Implicit Types x y : A.

Global Instance lookup_op_homomorphism {i} :
  MonoidHomomorphism op op (≡) (lookup i : gmap K A → option A).
Proof. split; [split|]; try apply _. intros m1 m2; by rewrite lookup_op. done. Qed.

Lemma lookup_opM m1 mm2 i : (m1 ⋅? mm2) !! i = m1 !! i ⋅ (mm2 ≫= (.!! i)).
Proof. destruct mm2; by rewrite /= ?lookup_op ?right_id_L. Qed.

Lemma lookup_validN_Some n m i x : ✓{n} m → m !! i ≡{n}≡ Some x → ✓{n} x.
Proof. by move=> /(_ i) Hm Hi; move:Hm; rewrite Hi. Qed.
Lemma lookup_valid_Some m i x : ✓ m → m !! i ≡ Some x → ✓ x.
Proof. move=> Hm Hi. move:(Hm i). by rewrite Hi. Qed.

Lemma insert_validN n m i x : ✓{n} x → ✓{n} m → ✓{n} <[i:=x]>m.
Proof. by intros ?? j; destruct (decide (i = j)); simplify_map_eq. Qed.
Lemma insert_valid m i x : ✓ x → ✓ m → ✓ <[i:=x]>m.
Proof. by intros ?? j; destruct (decide (i = j)); simplify_map_eq. Qed.
Lemma singleton_validN n i x : ✓{n} ({[ i := x ]} : gmap K A) ↔ ✓{n} x.
Proof.
  split.
  - move=>/(_ i); by simplify_map_eq.
  - intros. apply insert_validN. done. apply: ucmra_unit_validN.
Qed.
Lemma singleton_valid i x : ✓ ({[ i := x ]} : gmap K A) ↔ ✓ x.
Proof. rewrite !cmra_valid_validN. by setoid_rewrite singleton_validN. Qed.

Lemma delete_validN n m i : ✓{n} m → ✓{n} (delete i m).
Proof. intros Hm j; destruct (decide (i = j)); by simplify_map_eq. Qed.
Lemma delete_valid m i : ✓ m → ✓ (delete i m).
Proof. intros Hm j; destruct (decide (i = j)); by simplify_map_eq. Qed.

Lemma insert_singleton_op m i x : m !! i = None → <[i:=x]> m = {[ i := x ]} ⋅ m.
Proof.
  intros Hi; apply map_eq=> j; destruct (decide (i = j)) as [->|].
  - by rewrite lookup_op lookup_insert lookup_singleton Hi right_id_L.
  - by rewrite lookup_op lookup_insert_ne // lookup_singleton_ne // left_id_L.
Qed.

Lemma singleton_core (i : K) (x : A) cx :
  pcore x = Some cx → core {[ i := x ]} =@{gmap K A} {[ i := cx ]}.
Proof. apply omap_singleton. Qed.
Lemma singleton_core' (i : K) (x : A) cx :
  pcore x ≡ Some cx → core {[ i := x ]} ≡@{gmap K A} {[ i := cx ]}.
Proof.
  intros (cx'&?&->)%equiv_Some_inv_r'. by rewrite (singleton_core _ _ cx').
Qed.
Lemma singleton_core_total `{!CmraTotal A} (i : K) (x : A) :
  core {[ i := x ]} =@{gmap K A} {[ i := core x ]}.
Proof. apply singleton_core. rewrite cmra_pcore_core //. Qed.
Lemma singleton_op (i : K) (x y : A) :
  {[ i := x ]} ⋅ {[ i := y ]} =@{gmap K A} {[ i := x ⋅ y ]}.
Proof. by apply (merge_singleton _ _ _ x y). Qed.
Global Instance singleton_is_op i a a1 a2 :
  IsOp a a1 a2 → IsOp' ({[ i := a ]} : gmap K A) {[ i := a1 ]} {[ i := a2 ]}.
Proof. rewrite /IsOp' /IsOp=> ->. by rewrite -singleton_op. Qed.

Global Instance gmap_core_id m : (∀ x : A, CoreId x) → CoreId m.
Proof.
  intros; apply core_id_total=> i.
  rewrite lookup_core. apply (core_id_core _).
Qed.
Global Instance gmap_singleton_core_id i (x : A) :
  CoreId x → CoreId {[ i := x ]}.
Proof. intros. by apply core_id_total, singleton_core'. Qed.

Lemma singleton_includedN_l n m i x :
  {[ i := x ]} ≼{n} m ↔ ∃ y, m !! i ≡{n}≡ Some y ∧ Some x ≼{n} Some y.
Proof.
  split.
  - move=> [m' /(_ i)]; rewrite lookup_op lookup_singleton=> Hi.
    exists (x ⋅? m' !! i). rewrite -Some_op_opM.
    split. done. apply cmra_includedN_l.
  - intros (y&Hi&[mz Hy]). exists (partial_alter (λ _, mz) i m).
    intros j; destruct (decide (i = j)) as [->|].
    + by rewrite lookup_op lookup_singleton lookup_partial_alter Hi.
    + by rewrite lookup_op lookup_singleton_ne// lookup_partial_alter_ne// left_id.
Qed.
(* We do not have [x ≼ y ↔ ∀ n, x ≼{n} y], so we cannot use the previous lemma *)
Lemma singleton_included_l m i x :
  {[ i := x ]} ≼ m ↔ ∃ y, m !! i ≡ Some y ∧ Some x ≼ Some y.
Proof.
  split.
  - move=> [m' /(_ i)]; rewrite lookup_op lookup_singleton.
    exists (x ⋅? m' !! i). rewrite -Some_op_opM.
    split. done. apply cmra_included_l.
  - intros (y&Hi&[mz Hy]). exists (partial_alter (λ _, mz) i m).
    intros j; destruct (decide (i = j)) as [->|].
    + by rewrite lookup_op lookup_singleton lookup_partial_alter Hi.
    + by rewrite lookup_op lookup_singleton_ne// lookup_partial_alter_ne// left_id.
Qed.
Lemma singleton_included_exclusive_l m i x :
  Exclusive x → ✓ m →
  {[ i := x ]} ≼ m ↔ m !! i ≡ Some x.
Proof.
  intros ? Hm. rewrite singleton_included_l. split; last by eauto.
  intros (y&?&->%(Some_included_exclusive _)); eauto using lookup_valid_Some.
Qed.
Lemma singleton_included i x y :
  {[ i := x ]} ≼ ({[ i := y ]} : gmap K A) ↔ x ≡ y ∨ x ≼ y.
Proof.
  rewrite singleton_included_l. split.
  - intros (y'&Hi&?). rewrite lookup_insert in Hi.
    apply Some_included. by rewrite Hi.
  - intros ?. exists y. by rewrite lookup_insert Some_included.
Qed.

Global Instance singleton_cancelable i x :
  Cancelable (Some x) → Cancelable {[ i := x ]}.
Proof.
  intros ? n m1 m2 Hv EQ j. move: (Hv j) (EQ j). rewrite !lookup_op.
  destruct (decide (i = j)) as [->|].
  - rewrite lookup_singleton. by apply cancelableN.
  - by rewrite lookup_singleton_ne // !(left_id None _).
Qed.

Global Instance gmap_cancelable (m : gmap K A) :
  (∀ x : A, IdFree x) → (∀ x : A, Cancelable x) → Cancelable m.
Proof.
  intros ?? n m1 m2 ?? i. apply (cancelableN (m !! i)); by rewrite -!lookup_op.
Qed.

Lemma insert_op m1 m2 i x y :
  <[i:=x ⋅ y]>(m1 ⋅ m2) =  <[i:=x]>m1 ⋅ <[i:=y]>m2.
Proof. by rewrite (insert_merge (⋅) m1 m2 i (x ⋅ y) x y). Qed.

Lemma insert_updateP (P : A → Prop) (Q : gmap K A → Prop) m i x :
  x ~~>: P →
  (∀ y, P y → Q (<[i:=y]>m)) →
  <[i:=x]>m ~~>: Q.
Proof.
  intros Hx%option_updateP' HP; apply cmra_total_updateP=> n mf Hm.
  destruct (Hx n (Some (mf !! i))) as ([y|]&?&?); try done.
  { by generalize (Hm i); rewrite lookup_op; simplify_map_eq. }
  exists (<[i:=y]> m); split; first by auto.
  intros j; move: (Hm j)=>{Hm}; rewrite !lookup_op=>Hm.
  destruct (decide (i = j)); simplify_map_eq/=; auto.
Qed.
Lemma insert_updateP' (P : A → Prop) m i x :
  x ~~>: P → <[i:=x]>m ~~>: λ m', ∃ y, m' = <[i:=y]>m ∧ P y.
Proof. eauto using insert_updateP. Qed.
Lemma insert_update m i x y : x ~~> y → <[i:=x]>m ~~> <[i:=y]>m.
Proof. rewrite !cmra_update_updateP; eauto using insert_updateP with subst. Qed.

Lemma singleton_updateP (P : A → Prop) (Q : gmap K A → Prop) i x :
  x ~~>: P → (∀ y, P y → Q {[ i := y ]}) → {[ i := x ]} ~~>: Q.
Proof. apply insert_updateP. Qed.
Lemma singleton_updateP' (P : A → Prop) i x :
  x ~~>: P → {[ i := x ]} ~~>: λ m, ∃ y, m = {[ i := y ]} ∧ P y.
Proof. apply insert_updateP'. Qed.
Lemma singleton_update i (x y : A) : x ~~> y → {[ i := x ]} ~~> {[ i := y ]}.
Proof. apply insert_update. Qed.

Lemma delete_update m i : m ~~> delete i m.
Proof.
  apply cmra_total_update=> n mf Hm j; destruct (decide (i = j)); subst.
  - move: (Hm j). rewrite !lookup_op lookup_delete left_id.
    apply cmra_validN_op_r.
  - move: (Hm j). by rewrite !lookup_op lookup_delete_ne.
Qed.

Lemma dom_op m1 m2 : dom (gset K) (m1 ⋅ m2) = dom _ m1 ∪ dom _ m2.
Proof.
  apply elem_of_equiv_L=> i; rewrite elem_of_union !elem_of_dom.
  unfold is_Some; setoid_rewrite lookup_op.
  destruct (m1 !! i), (m2 !! i); naive_solver.
Qed.
Lemma dom_included m1 m2 : m1 ≼ m2 → dom (gset K) m1 ⊆ dom _ m2.
Proof.
  rewrite lookup_included=>? i; rewrite !elem_of_dom. by apply is_Some_included.
Qed.

Section freshness.
  Local Set Default Proof Using "Type*".
  Context `{!Infinite K}.
  Lemma alloc_updateP_strong_dep (Q : gmap K A → Prop) (I : K → Prop) m (f : K → A) :
    pred_infinite I →
    (∀ i, m !! i = None → I i → ✓ (f i)) →
    (∀ i, m !! i = None → I i → Q (<[i:=f i]>m)) → m ~~>: Q.
  Proof.
    move=> /(pred_infinite_set I (C:=gset K)) HP ? HQ.
    apply cmra_total_updateP. intros n mf Hm.
    destruct (HP (dom (gset K) (m ⋅ mf))) as [i [Hi1 Hi2]].
    assert (m !! i = None).
    { eapply (not_elem_of_dom (D:=gset K)). revert Hi2.
      rewrite dom_op not_elem_of_union. naive_solver. }
    exists (<[i:=f i]>m); split.
    - by apply HQ.
    - rewrite insert_singleton_op //.
      rewrite -assoc -insert_singleton_op;
        last by eapply (not_elem_of_dom (D:=gset K)).
    apply insert_validN; [apply cmra_valid_validN|]; auto.
  Qed.
  Lemma alloc_updateP_strong (Q : gmap K A → Prop) (I : K → Prop) m x :
    pred_infinite I →
    ✓ x → (∀ i, m !! i = None → I i → Q (<[i:=x]>m)) → m ~~>: Q.
  Proof.
    move=> HP ? HQ. eapply alloc_updateP_strong_dep with (f := λ _, x); eauto.
  Qed.
  Lemma alloc_updateP (Q : gmap K A → Prop) m x :
    ✓ x → (∀ i, m !! i = None → Q (<[i:=x]>m)) → m ~~>: Q.
  Proof.
    move=>??.
    eapply alloc_updateP_strong with (I:=λ _, True);
    eauto using pred_infinite_True.
  Qed.
  Lemma alloc_updateP_cofinite (Q : gmap K A → Prop) (J : gset K) m x :
    ✓ x → (∀ i, m !! i = None → i ∉ J → Q (<[i:=x]>m)) → m ~~>: Q.
  Proof.
    eapply alloc_updateP_strong.
    apply (pred_infinite_set (C:=gset K)).
    intros E. exists (fresh (J ∪ E)).
    apply not_elem_of_union, is_fresh.
  Qed.

  (* Variants without the universally quantified Q, for use in case that is an evar. *)
  Lemma alloc_updateP_strong_dep' m (f : K → A) (I : K → Prop) :
    pred_infinite I →
    (∀ i, m !! i = None → I i → ✓ (f i)) →
    m ~~>: λ m', ∃ i, I i ∧ m' = <[i:=f i]>m ∧ m !! i = None.
  Proof. eauto using alloc_updateP_strong_dep. Qed.
  Lemma alloc_updateP_strong' m x (I : K → Prop) :
    pred_infinite I →
    ✓ x → m ~~>: λ m', ∃ i, I i ∧ m' = <[i:=x]>m ∧ m !! i = None.
  Proof. eauto using alloc_updateP_strong. Qed.
  Lemma alloc_updateP' m x :
    ✓ x → m ~~>: λ m', ∃ i, m' = <[i:=x]>m ∧ m !! i = None.
  Proof. eauto using alloc_updateP. Qed.
  Lemma alloc_updateP_cofinite' m x (J : gset K) :
    ✓ x → m ~~>: λ m', ∃ i, i ∉ J ∧ m' = <[i:=x]>m ∧ m !! i = None.
  Proof. eauto using alloc_updateP_cofinite. Qed.
End freshness.

Lemma alloc_unit_singleton_updateP (P : A → Prop) (Q : gmap K A → Prop) u i :
  ✓ u → LeftId (≡) u (⋅) →
  u ~~>: P → (∀ y, P y → Q {[ i := y ]}) → ∅ ~~>: Q.
Proof.
  intros ?? Hx HQ. apply cmra_total_updateP=> n gf Hg.
  destruct (Hx n (gf !! i)) as (y&?&Hy).
  { move:(Hg i). rewrite !left_id.
    case: (gf !! i)=>[x|]; rewrite /= ?left_id //.
    intros; by apply cmra_valid_validN. }
  exists {[ i := y ]}; split; first by auto.
  intros i'; destruct (decide (i' = i)) as [->|].
  - rewrite lookup_op lookup_singleton.
    move:Hy; case: (gf !! i)=>[x|]; rewrite /= ?right_id //.
  - move:(Hg i'). by rewrite !lookup_op lookup_singleton_ne // !left_id.
Qed.
Lemma alloc_unit_singleton_updateP' (P: A → Prop) u i :
  ✓ u → LeftId (≡) u (⋅) →
  u ~~>: P → ∅ ~~>: λ m, ∃ y, m = {[ i := y ]} ∧ P y.
Proof. eauto using alloc_unit_singleton_updateP. Qed.
Lemma alloc_unit_singleton_update (u : A) i (y : A) :
  ✓ u → LeftId (≡) u (⋅) → u ~~> y → (∅:gmap K A) ~~> {[ i := y ]}.
Proof.
  rewrite !cmra_update_updateP;
    eauto using alloc_unit_singleton_updateP with subst.
Qed.

Lemma alloc_local_update m1 m2 i x :
  m1 !! i = None → ✓ x → (m1,m2) ~l~> (<[i:=x]>m1, <[i:=x]>m2).
Proof.
  rewrite cmra_valid_validN=> Hi ?.
  apply local_update_unital=> n mf Hmv Hm; simpl in *.
  split; auto using insert_validN.
  intros j; destruct (decide (i = j)) as [->|].
  - move: (Hm j); rewrite Hi symmetry_iff dist_None lookup_op op_None=>-[_ Hj].
    by rewrite lookup_op !lookup_insert Hj.
  - rewrite Hm lookup_insert_ne // !lookup_op lookup_insert_ne //.
Qed.

Lemma alloc_singleton_local_update m i x :
  m !! i = None → ✓ x → (m,∅) ~l~> (<[i:=x]>m, {[ i:=x ]}).
Proof. apply alloc_local_update. Qed.

Lemma insert_local_update m1 m2 i x y x' y' :
  m1 !! i = Some x → m2 !! i = Some y →
  (x, y) ~l~> (x', y') →
  (m1, m2) ~l~> (<[i:=x']>m1, <[i:=y']>m2).
Proof.
  intros Hi1 Hi2 Hup; apply local_update_unital=> n mf Hmv Hm; simpl in *.
  destruct (Hup n (mf !! i)) as [? Hx']; simpl in *.
  { move: (Hmv i). by rewrite Hi1. }
  { move: (Hm i). by rewrite lookup_op Hi1 Hi2 Some_op_opM (inj_iff Some). }
  split; auto using insert_validN.
  rewrite Hm Hx'=> j; destruct (decide (i = j)) as [->|].
  - by rewrite lookup_insert lookup_op lookup_insert Some_op_opM.
  - by rewrite lookup_insert_ne // !lookup_op lookup_insert_ne.
Qed.

Lemma singleton_local_update_any m i y x' y' :
  (∀ x, m !! i = Some x → (x, y) ~l~> (x', y')) →
  (m, {[ i := y ]}) ~l~> (<[i:=x']>m, {[ i := y' ]}).
Proof.
  intros. rewrite /singletonM /map_singleton -(insert_insert ∅ i y' y).
  apply local_update_total_valid0=>_ _ /singleton_includedN_l [x0 [/dist_Some_inv_r Hlk0 _]].
  edestruct Hlk0 as [x [Hlk _]]; [done..|].
  eapply insert_local_update; [|eapply lookup_insert|]; eauto.
Qed.

Lemma singleton_local_update m i x y x' y' :
  m !! i = Some x →
  (x, y) ~l~> (x', y') →
  (m, {[ i := y ]}) ~l~> (<[i:=x']>m, {[ i := y' ]}).
Proof.
  intros Hmi ?. apply singleton_local_update_any.
  intros x2. rewrite Hmi=>[=<-]. done.
Qed.

Lemma delete_local_update m1 m2 i x `{!Exclusive x} :
  m2 !! i = Some x → (m1, m2) ~l~> (delete i m1, delete i m2).
Proof.
  intros Hi. apply local_update_unital=> n mf Hmv Hm; simpl in *.
  split; auto using delete_validN.
  rewrite Hm=> j; destruct (decide (i = j)) as [<-|].
  - rewrite lookup_op !lookup_delete left_id symmetry_iff dist_None.
    apply eq_None_not_Some=> -[y Hi'].
    move: (Hmv i). rewrite Hm lookup_op Hi Hi' -Some_op. by apply exclusiveN_l.
  - by rewrite lookup_op !lookup_delete_ne // lookup_op.
Qed.

Lemma delete_singleton_local_update m i x `{!Exclusive x} :
  (m, {[ i := x ]}) ~l~> (delete i m, ∅).
Proof.
  rewrite -(delete_singleton i x).
  by eapply delete_local_update, lookup_singleton.
Qed.

Lemma delete_local_update_cancelable m1 m2 i mx `{!Cancelable mx} :
  m1 !! i ≡ mx → m2 !! i ≡ mx →
  (m1, m2) ~l~> (delete i m1, delete i m2).
Proof.
  intros Hm1i Hm2i. apply local_update_unital=> n mf Hmv Hm; simpl in *.
  split; [eauto using delete_validN|].
  intros j. destruct (decide (i = j)) as [->|].
  - move: (Hm j). rewrite !lookup_op Hm1i Hm2i !lookup_delete. intros Hmx.
    rewrite (cancelableN mx n (mf !! j) None) ?right_id // -Hmx -Hm1i. apply Hmv.
  - by rewrite lookup_op !lookup_delete_ne // Hm lookup_op.
Qed.

Lemma delete_singleton_local_update_cancelable m i x `{!Cancelable (Some x)} :
  m !! i ≡ Some x → (m, {[ i := x ]}) ~l~> (delete i m, ∅).
Proof.
  intros. rewrite -(delete_singleton i x).
  apply (delete_local_update_cancelable m _ i (Some x));
    [done|by rewrite lookup_singleton].
Qed.

Lemma gmap_fmap_mono {B : cmraT} (f : A → B) m1 m2 :
  Proper ((≡) ==> (≡)) f →
  (∀ x y, x ≼ y → f x ≼ f y) → m1 ≼ m2 → fmap f m1 ≼ fmap f m2.
Proof.
  intros ??. rewrite !lookup_included=> Hm i.
  rewrite !lookup_fmap. by apply option_fmap_mono.
Qed.
End properties.

Section unital_properties.
Context `{Countable K} {A : ucmraT}.
Implicit Types m : gmap K A.
Implicit Types i : K.
Implicit Types x y : A.

Lemma insert_alloc_local_update m1 m2 i x x' y' :
  m1 !! i = Some x → m2 !! i = None →
  (x, ε) ~l~> (x', y') →
  (m1, m2) ~l~> (<[i:=x']>m1, <[i:=y']>m2).
Proof.
  intros Hi1 Hi2 Hup. apply local_update_unital=> n mf Hm1v Hm.
  assert (mf !! i ≡{n}≡ Some x) as Hif.
  { move: (Hm i). by rewrite lookup_op Hi1 Hi2 left_id. }
  destruct (Hup n (mf !! i)) as [Hx'v Hx'eq].
  { move: (Hm1v i). by rewrite Hi1. }
  { by rewrite Hif -(inj_iff Some) -Some_op_opM -Some_op left_id. }
  split.
  - by apply insert_validN.
  - simpl in Hx'eq. by rewrite -(insert_idN n mf i x) // -insert_op -Hm Hx'eq Hif.
Qed.
End unital_properties.

(** Functor *)
Instance gmap_fmap_ne `{Countable K} {A B : ofeT} (f : A → B) n :
  Proper (dist n ==> dist n) f → Proper (dist n ==>dist n) (fmap (M:=gmap K) f).
Proof. by intros ? m m' Hm k; rewrite !lookup_fmap; apply option_fmap_ne. Qed.
Instance gmap_fmap_cmra_morphism `{Countable K} {A B : cmraT} (f : A → B)
  `{!CmraMorphism f} : CmraMorphism (fmap f : gmap K A → gmap K B).
Proof.
  split; try apply _.
  - by intros n m ? i; rewrite lookup_fmap; apply (cmra_morphism_validN _).
  - intros m. apply Some_proper=>i. rewrite lookup_fmap !lookup_omap lookup_fmap.
    case: (m!!i)=>//= ?. apply cmra_morphism_pcore, _.
  - intros m1 m2 i. by rewrite lookup_op !lookup_fmap lookup_op cmra_morphism_op.
Qed.
Definition gmapO_map `{Countable K} {A B} (f: A -n> B) :
  gmapO K A -n> gmapO K B := OfeMor (fmap f : gmapO K A → gmapO K B).
Instance gmapO_map_ne `{Countable K} {A B} :
  NonExpansive (@gmapO_map K _ _ A B).
Proof.
  intros n f g Hf m k; rewrite /= !lookup_fmap.
  destruct (_ !! k) eqn:?; simpl; constructor; apply Hf.
Qed.

Program Definition gmapOF K `{Countable K} (F : oFunctor) : oFunctor := {|
  oFunctor_car A _ B _ := gmapO K (oFunctor_car F A B);
  oFunctor_map A1 _ A2 _ B1 _ B2 _ fg := gmapO_map (oFunctor_map F fg)
|}.
Next Obligation.
  by intros K ?? F A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply gmapO_map_ne, oFunctor_map_ne.
Qed.
Next Obligation.
  intros K ?? F A ? B ? x. rewrite /= -{2}(map_fmap_id x).
  apply map_fmap_equiv_ext=>y ??; apply oFunctor_map_id.
Qed.
Next Obligation.
  intros K ?? F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x. rewrite /= -map_fmap_compose.
  apply map_fmap_equiv_ext=>y ??; apply oFunctor_map_compose.
Qed.
Instance gmapOF_contractive K `{Countable K} F :
  oFunctorContractive F → oFunctorContractive (gmapOF K F).
Proof.
  by intros ? A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply gmapO_map_ne, oFunctor_map_contractive.
Qed.

Program Definition gmapURF K `{Countable K} (F : rFunctor) : urFunctor := {|
  urFunctor_car A _ B _ := gmapUR K (rFunctor_car F A B);
  urFunctor_map A1 _ A2 _ B1 _ B2 _ fg := gmapO_map (rFunctor_map F fg)
|}.
Next Obligation.
  by intros K ?? F A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply gmapO_map_ne, rFunctor_map_ne.
Qed.
Next Obligation.
  intros K ?? F A ? B ? x. rewrite /= -{2}(map_fmap_id x).
  apply map_fmap_equiv_ext=>y ??; apply rFunctor_map_id.
Qed.
Next Obligation.
  intros K ?? F A1 ? A2 ? A3 ? B1 ? B2 ? B3 ? f g f' g' x. rewrite /= -map_fmap_compose.
  apply map_fmap_equiv_ext=>y ??; apply rFunctor_map_compose.
Qed.
Instance gmapURF_contractive K `{Countable K} F :
  rFunctorContractive F → urFunctorContractive (gmapURF K F).
Proof.
  by intros ? A1 ? A2 ? B1 ? B2 ? n f g Hfg; apply gmapO_map_ne, rFunctor_map_contractive.
Qed.

Program Definition gmapRF K `{Countable K} (F : rFunctor) : rFunctor := {|
  rFunctor_car A _ B _ := gmapR K (rFunctor_car F A B);
  rFunctor_map A1 _ A2 _ B1 _ B2 _ fg := gmapO_map (rFunctor_map F fg)
|}.
Solve Obligations with apply gmapURF.

Instance gmapRF_contractive K `{Countable K} F :
  rFunctorContractive F → rFunctorContractive (gmapRF K F).
Proof. apply gmapURF_contractive. Qed.


From sflib Require Import sflib.
From Paco Require Import paco.
Require Import Program.
Require Import Arith.
Require Import Permutation.
Require Import SetoidList.
Require Import SetoidPermutation.
Require Import Lists.List.
Require Import Lia.
From Fairness Require Import
  Mod
  FairSim
  Concurrency
  FIFOSched
  SchedSim.
From ExtLib Require Import FMapAList.

Section SIM.

  Context {_Ident : ID}.
  Variable E : Type -> Type.

  Let eventE1 := @eventE _Ident.
  Let eventE2 := @eventE (sum_tid _Ident).

  Variable wf : WF.
  Variable State : Type.
  Variable R : Type.

  Let thread R := thread _Ident (sE State) R.
  Import Th.

  Theorem ssim_nondet_fifo
    p_src p_tgt tid ths_src ths_tgt
    (THREADS : Permutation (TIdSet.elements ths_src) ths_tgt)
    (TID : ~ NatMap.In tid ths_src)
    : forall m_tgt, exists m_src, @ssim nat_wf nat_wf R R R eq p_src m_src p_tgt m_tgt
                          (sched_nondet R (tid, ths_src))
                          (sched_fifo R (tid, ths_tgt)).
  Proof.
    i.

    remember (fun (i : thread_id) => List.length ths_tgt + 1) as m_src.
    assert (M_SRC0 : m_src tid > List.length ths_tgt) by (subst; lia).
    assert (M_SRC1 : forall i tid, nth_error ths_tgt i = Some tid -> m_src tid > i).
    { subst. i. eapply nth_error_Some' in H. lia. }
    clear Heqm_src.
    exists m_src.

    revert p_src p_tgt m_src m_tgt tid ths_src ths_tgt THREADS TID M_SRC0 M_SRC1.
    pcofix CIH. i.

    rewrite unfold_sched_nondet.
    rewrite unfold_sched_fifo.
    rewrite ! bind_trigger.
    pfold. econs. intros [].
    - left.
      destruct (NatMap.is_empty ths_src) eqn: H.
      + eapply NatMap.is_empty_2 in H.
        eapply Empty_nil in H.
        rewrite H in THREADS.
        eapply Permutation_nil in THREADS.
        subst ths_tgt.
        pfold. econs; ss.
      + assert (~ TIdSet.Empty ths_src).
        { ii. eapply NatMap.is_empty_1 in H0. rewrite H in H0; ss. }
        clear H. eapply Empty_nil_neg in H0.
        destruct ths_tgt as [| tid' ths_tgt' ].
        { symmetry in THREADS. eapply Permutation_nil in THREADS. ss. }
        pfold. eapply ssim_chooseL. exists tid'. unfold nm_pop.
        replace (NatMap.find tid' ths_src) with (Some tt); cycle 1.
        { symmetry. eapply find_1. eapply NatSet_In_MapsTo. eapply In_NatSetIn.
          rewrite THREADS. econs; ss.
        }
        rewrite bind_trigger.
        eapply ssim_fairL.
        remember (fun i => if Nat.eq_dec i tid'
                        then List.length ths_tgt' + 1
                        else if NatMapP.F.In_dec (NatMap.remove tid' ths_src) i
                             then m_src i - 1
                             else m_src i) as m_src'.
        exists m_src'. splits.
        { ii. unfold tids_fmap; ss. des_ifs.
          assert (List.In i (TIdSet.elements ths_src)).
          { eapply NatSetIn_In. eapply NatMapP.F.remove_neq_in_iff with (x := tid'). eauto. ss. }
          rewrite THREADS in H. eapply In_nth_error in H. destruct H as [i' H].
          enough (m_src i > i') by lia. eapply M_SRC1; eauto.
        }
        do 3 econs; eauto. right. eapply CIH.
        * eapply NatSet_Permutation_remove. eapply THREADS.
        * eapply NatMap.remove_1; ss.
        * subst. des_if; ss. lia.
        * subst. i. des_if.
          -- eapply nth_error_Some' in H. lia.
          -- enough (m_src tid0 > 1 + i) by (des_if; lia). eapply M_SRC1. eauto.
    - left.
      match goal with
      | [ |- paco10 _ _ _ _ _ _ _ _ _ _ _ (match ?x with
                                          | [] => _
                                          | t' :: ts' => _
                                          end)] => destruct x as [| tid' ths_tgt'] eqn: E_ths_tgt
      end.
      { eapply app_eq_nil in E_ths_tgt. des. ss. }
      pfold. eapply ssim_chooseL. exists tid'. unfold nm_pop.
      replace (NatMap.find tid' (TIdSet.add tid ths_src)) with (Some tt); cycle 1.
      { symmetry. eapply find_1.
        destruct ths_tgt; ss; inversion E_ths_tgt; subst.
        - eapply NatMap.add_1; ss.
        - eapply NatMap.add_2.
          + intro. subst. eapply TID. eapply In_NatSetIn. rewrite THREADS. econs; ss.
          + eapply NatSet_In_MapsTo. eapply In_NatSetIn. rewrite THREADS. econs; ss.
      }
      rewrite bind_trigger. eapply ssim_fairL.
      remember (fun i => if Nat.eq_dec i tid'
                      then List.length ths_tgt' + 1
                      else if NatMapP.F.In_dec (NatMap.remove tid' (NatSet.add tid ths_src)) i
                           then m_src i - 1
                           else m_src i) as m_src'.
      exists m_src'. splits.
      { ii. unfold tids_fmap; ss. des_ifs.
        assert (i = tid \/ i <> tid) by lia. destruct H; try (subst; lia).
        assert (List.In i (TIdSet.elements ths_src)).
        { eapply NatSetIn_In. exists tt. eapply NatSet_In_MapsTo, NatMap.remove_3, NatMap.add_3 in i0; eauto. }
        rewrite THREADS in H0. eapply In_nth_error in H0. destruct H0 as [i' H0].
        enough (m_src i > i') by lia. eapply M_SRC1; eauto.
      }
      do 3 econs; ss. right. unfold NatMap.key in *. eapply CIH.
      + eapply NatSet_Permutation_remove.
        rewrite NatSet_Permutation_add.
        * eapply Permutation_refl' in E_ths_tgt. rewrite Permutation_app_comm in E_ths_tgt. eapply E_ths_tgt.
        * intro H. eapply TID. eapply H.
        * ss.
      + eapply NatMap.remove_1; ss.
      + subst. des_if; ss. lia.
      + subst. i. des_if.
        * eapply nth_error_Some' in H. lia.
        * enough (m_src tid0 > 1 + i) by (des_if; lia).
          assert (nth_error (ths_tgt ++ [tid]) (1 + i) = Some tid0) by (rewrite E_ths_tgt; ss).
          assert (1 + i < List.length ths_tgt \/ 1 + i >= List.length ths_tgt) by lia.
          destruct H1.
          -- rewrite nth_error_app1 in H0 by ss. eapply M_SRC1; eauto.
          -- rewrite nth_error_app2 in H0 by ss.
             assert (1 + i - List.length ths_tgt = 0)
               by (destruct (1 + i - List.length ths_tgt) as [|[]] in *; ss).
             rewrite H2 in H0. inversion H0. subst. lia.
  Qed.

  Theorem gsim_nondet_fifo tid st (ths : @threads _Ident (sE State) R)
    : gsim nat_wf nat_wf eq
           (interp_all st ths tid)
           (interp_all_fifo st ths tid).
  Proof.
    eapply ssim_implies_gsim.
    { instantiate (1 := fun x => x). ss. }
    eapply ssim_nondet_fifo; ss.
    eapply NatMap.remove_1; ss.
    Unshelve. all: exact true.
  Qed.

End SIM.


(******************************)
(*                            *)
(*          CONTENTS          *)
(*                            *)
(* is_from          line  20  *)
(* int_or_ptr       line 280  *)
(*                            *)
(******************************)

Require Import compcert.common.Events compcert.common.Memory.
Require Import compcert.common.Values compcert.common.AST.
Require Import compcert.x86_32.Archi compcert.lib.Integers.
Require Import Coq.ZArith.BinInt Coq.Lists.List Coq.micromega.Lia.
Import ListNotations.
Local Open Scope Z_scope. Local Open Scope list_scope.

(* Verification of the function Is_from *)

Definition valid_block (m : mem) (b : block) (o : ptrofs) (n : Z) : Prop :=
  0 < n /\
  Ptrofs.unsigned o + n <= Int.modulus /\
  forall i : Z, 0 <= i < n ->
                common.Memory.Mem.valid_pointer m b (Ptrofs.unsigned o + i) = true.

Definition Is_from_sem : extcall_sem :=
  fun _ args m1 trc ret m2 =>
    m1 = m2 /\ trc = nil /\
    match args with
    | (Vptr b1 o1) :: (Vptr b2 o2) :: (Vptr b3 o3) :: nil =>
      exists n : Z, 0 < n /\
                    Ptrofs.unsigned o1 + n < Int.modulus /\
                    b1 = b2 /\
                    Ptrofs.unsigned o1 + n = Ptrofs.unsigned o2 /\
                    valid_block m1 b1 o1 n /\
                    common.Memory.Mem.valid_pointer m1 b3 (Ptrofs.unsigned o3) = true /\
                    ((b1 = b3 /\
                      Ptrofs.unsigned o1 <= Ptrofs.unsigned o3 < Ptrofs.unsigned o2 /\
                      ret = Vone) \/
                     ((b1 <> b3 \/
                       (b1 = b3 /\
                        (Ptrofs.unsigned o3 < Ptrofs.unsigned o1 \/
                         Ptrofs.unsigned o3 >= Ptrofs.unsigned o2)))
                      /\ ret = Vzero))
    | _ => False
    end.

Definition Is_from_sig : signature :=
  mksignature (AST.Tint :: AST.Tint :: AST.Tint :: nil) (Tret AST.Tint) cc_default.

Ltac split3 := split; [|split ].

Lemma lt_ptr_mod: forall n1 n2,
    n1 <= n2 <= Ptrofs.max_unsigned -> n1 <= n2 < Ptrofs.modulus.
Proof.
  intros.
  replace Ptrofs.max_unsigned with (Z.pred Ptrofs.modulus) in * by
      (unfold Ptrofs.max_unsigned; lia).
  now rewrite <- Z.lt_le_pred in *.
Qed.

Lemma Is_from_extcall: extcall_properties Is_from_sem Is_from_sig.
Proof.
  constructor; intros.
  - destruct H as [_ [_ ?]].
    do 4 (destruct vargs; try destruct v; try contradiction).
    destruct H as [_ [_ [_ [_ [_ [_ [_ ?]]]]]]].
    destruct H as [[_ [_ ?]] | [_ ?]]; subst; apply I.
  - apply H0.
  - destruct H as [? _]. subst m1. trivial.
  - destruct H as [? _]. subst m1. trivial.
  - destruct H as [? _]. subst m1. trivial.
  - exists vres, m1'.
    destruct H as [? [? ?]]; subst m2 t.
    split.
    2: split3; [apply Val.lessdef_refl | trivial | apply Mem.unchanged_on_refl].
    split3; trivial.
    do 4 (destruct vargs; try destruct v; try contradiction).
    inversion H1; inversion H4; inversion H6; inversion H11;
      inversion H13; inversion H18; inversion H20; subst.
    clear H4 H11 H18 H20 H13 H6 H1.
    destruct H3 as [n [? [? [? [? ?]]]]].
    exists n. do 4 (split; trivial).
    clear -H0 H4. destruct H4 as [? [? ?]].
    split3; [|eapply Mem.valid_pointer_extends; eauto | tauto].
    destruct H as [? [? ?]].
    do 2 (split; trivial).
    intros. specialize (H4 i2 H5).
    eapply Mem.valid_pointer_extends; eauto.
  - intros. exists f, vres, m1'. destruct H0 as [? [? ?]]. split.
    2: {
      split. 2: repeat (split; [now subst|]); congruence.
      clear -H4.
      do 4 (destruct vargs; try destruct v; try contradiction).
      destruct H4 as [_ [_ [_ [_ [_ [_ [_ H]]]]]]].
      destruct vres; auto. now destruct H.
    }
    split3; trivial.
    do 4 (destruct vargs; try destruct v; try contradiction).
    inversion H2; inversion H7; inversion H9;
      inversion H17; inversion H19; inversion H27; inversion H29; subst.
    clear H2 H7 H9 H17 H19 H27 H29.
    destruct H4 as [n [? [? [? [? [? [? ?]]]]]]].
    exists n. rewrite H3 in  H12; rewrite H22 in H12; inversion H12.
    subst; clear H12.
    assert (Hf: 0 <= Ptrofs.unsigned i + n < Ptrofs.modulus) by
        (rewrite H4; apply Ptrofs.unsigned_range).
    assert (Ha: Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr delta)) + n < Int.modulus). {
      replace Int.modulus with Ptrofs.modulus by
          (unfold Int.modulus, Ptrofs.modulus; f_equal).
      destruct H1 as [_ _ _ _ rep _].
      destruct (rep b0 b3 delta
                      (Ptrofs.add i (Ptrofs.repr n)) H22) as [Hx Hy].
      { right. apply Mem.perm_cur_max, Mem.valid_pointer_nonempty_perm.
        destruct H5 as [_ [_ H5]].
        assert (Hm: 0 <= n - 1 < n) by lia; rewrite <- (H5 _ Hm).
        f_equal; unfold Ptrofs.add; repeat rewrite Ptrofs.unsigned_repr_eq.
        rewrite Z.add_mod_idemp_r, Z.mod_small by easy. lia.
      }
      clear -Hx Hy Hf H0.
      apply lt_ptr_mod in Hy. unfold Ptrofs.add in *.
      repeat rewrite Ptrofs.unsigned_repr_eq in *.
      rewrite Z.add_mod_idemp_r, Z.mod_small in * by easy.
      rewrite Z.mod_small; [lia|].
      destruct i. unfold Ptrofs.unsigned in *; simpl in *. lia.
    }
    split3; [| |split3; [| |split3]]; trivial.
    + destruct H1 as [_ _ _ _ rep _].
      destruct (rep _ _ delta
                   (Ptrofs.add i (Ptrofs.repr n)) H22) as [Hd' Hd]. {
        right. apply Mem.perm_cur_max, Mem.valid_pointer_nonempty_perm.
        destruct H5 as [_ [_ H5]]. assert (0 <= n - 1 < n) by lia.
        rewrite <- (H5 _ H1). f_equal.
        unfold Ptrofs.add; repeat rewrite Ptrofs.unsigned_repr_eq.
        rewrite Z.add_mod_idemp_r, Z.mod_small by easy. lia.
      }
      unfold Ptrofs.add. rewrite <- H4.
      destruct (Ptrofs.unsigned_range i) as [? _].
      repeat rewrite Ptrofs.unsigned_repr_eq.
      repeat rewrite Z.add_mod_idemp_r by easy.
      replace Int.modulus with Ptrofs.modulus in Ha by
          (unfold Int.modulus, Ptrofs.modulus; f_equal).
      unfold Ptrofs.add in Hd.
      repeat rewrite Ptrofs.unsigned_repr_eq in Hd.
      rewrite Z.add_mod_idemp_r, Z.mod_small in Hd by easy.
      apply lt_ptr_mod in Hd.
      repeat rewrite Z.mod_small; [lia | trivial | lia].
    + split3; [easy | lia|]. intros.
      destruct H5 as [_ [_ H5]].
      rewrite <- (Mem.valid_pointer_inject _ _ _ _ _ _ _ H22 H1 (H5 i2 H3)).
      f_equal. unfold Ptrofs.add; repeat rewrite Ptrofs.unsigned_repr_eq.
      destruct H1 as [_ _ _ _ rep _].
      destruct (rep _ _ delta i H22) as [_ Hd]. {
        left. apply Mem.perm_cur_max, Mem.valid_pointer_nonempty_perm.
        assert (0 <= 0 < n) by lia; rewrite <- (H5 0 H1); f_equal; lia.
      }
      apply lt_ptr_mod in Hd.
      rewrite Z.add_mod_idemp_r, Z.mod_small by easy. lia.
    + rewrite <- (Mem.valid_pointer_inject _ _ _ _ _ _ _ H32 H1 H6).
      f_equal. unfold Ptrofs.add. repeat rewrite Ptrofs.unsigned_repr_eq.
      destruct H1 as [_ _ _ _ rep _].
      destruct (rep _ _ delta1 i1 H32) as [_ Hd]. {
        left; now apply Mem.perm_cur_max,
              Mem.valid_pointer_nonempty_perm.
      }
      apply lt_ptr_mod in Hd.
      rewrite Z.add_mod_idemp_r, Z.mod_small by easy. lia.
    + destruct H7.
      * destruct H3 as [? [? ?]]; subst b1 vres.
        destruct H1 as [_ _ _ _ rep _].
        destruct (rep b0 b3 delta i H22) as [_ Hp]. {
          left; apply Mem.perm_cur_max, Mem.valid_pointer_nonempty_perm.
          destruct H5 as [_ [_ H5]]; assert (0 <= 0 < n) by lia.
          specialize (H5 0 H1).
          now replace (Ptrofs.unsigned i + 0) with (Ptrofs.unsigned i) in H5 by lia.
        }
        destruct (rep b0 b3 delta i1 H22) as [_ Hq]. {
          left; apply Mem.perm_cur_max, Mem.valid_pointer_nonempty_perm;
            destruct H5 as [_ [_ ?]]; assert (0 <= 0 < n) by lia.
          specialize (H1 0 H3); now rewrite H6.
        }
        destruct (rep b0 b3 delta i0 H22) as [_ Hr]. {
          destruct H5 as [_ [_ H5]]. rewrite <- H4.
          assert (Hm: 0 <= n - 1 < n) by lia.
          right. apply Mem.perm_cur_max, Mem.valid_pointer_nonempty_perm.
          rewrite <- (H5 _ Hm); f_equal; lia.
        }
        rewrite H22 in H32; inversion H32.
        left. split3; trivial.
        subst delta1. clear -H7 Hp Hq Hr.
        unfold Ptrofs.add; repeat rewrite Ptrofs.unsigned_repr_eq.
        apply lt_ptr_mod in Hp; apply lt_ptr_mod in Hq; apply lt_ptr_mod in Hr.
        repeat rewrite Z.add_mod_idemp_r, Z.mod_small by easy.
        lia.
      * destruct H3. right. split; trivial.
        rename m2 into m; rename m1' into m'.
        destruct H1 as [_ _ _ lap rep _].
        destruct H3.
        -- destruct (eq_block b3 b7); [|now left].
           subst b3. right. split; trivial.
           unfold Ptrofs.add; repeat rewrite Ptrofs.unsigned_repr_eq.
           repeat rewrite Z.add_mod_idemp_r by easy.
           destruct H5 as [_ [_ H5]].
           assert (0 <= 0 < n) by lia.
           pose proof (H5 _ H3).
           apply Mem.valid_pointer_nonempty_perm, Mem.perm_cur_max in H6.
           apply Mem.valid_pointer_nonempty_perm, Mem.perm_cur_max in H8.
           replace (Ptrofs.unsigned i + 0) with (Ptrofs.unsigned i) in H8 by lia.
           destruct (rep _ _ delta1 i1 H32) as [_ Hp]; [left; easy|].
           destruct (rep _ _ delta i H22) as [_ Hq]; [left; easy|].
           destruct (rep _ _ delta i0 H22) as [_ Hr]. {
             rewrite <- H4.
             assert (Hm: 0 <= n - 1 < n) by lia.
             specialize (H5 _ Hm).
             replace (Ptrofs.unsigned i + (n - 1)) with (Ptrofs.unsigned i + n - 1) in H5 by lia.
             apply Mem.valid_pointer_nonempty_perm, Mem.perm_cur_max in H5. now right.
           }
           replace Ptrofs.max_unsigned with (Z.pred Ptrofs.modulus) in * by
               (unfold Ptrofs.max_unsigned; lia).
           rewrite <- Z.lt_le_pred in *.
           repeat rewrite Z.mod_small by easy.
           destruct (lap _ _ _ _ _ _ _ _ H1 H22 H32 H8 H6); [contradiction|].
           clear rep Hp Hq Hr.
           replace (Ptrofs.unsigned i) with ((Ptrofs.unsigned i - delta) + delta) in H5 by lia.
           assert ((Ptrofs.unsigned i1 + delta1 < Ptrofs.unsigned i + delta) \/
                   (Ptrofs.unsigned i1 + delta1 >= Ptrofs.unsigned i0 + delta) \/
                   ((Ptrofs.unsigned i1 + delta1 >= Ptrofs.unsigned i + delta) /\
                    Ptrofs.unsigned i1 + delta1 < Ptrofs.unsigned i0 + delta)) by lia.
           destruct H10; [auto | destruct H10; [auto|]].
           exfalso.
           destruct H10. rewrite <- H4 in H11.
           assert (0 <= Ptrofs.unsigned i1 + delta1 - Ptrofs.unsigned i - delta < n) by lia.
           specialize (H5 (Ptrofs.unsigned i1 + delta1 - Ptrofs.unsigned i - delta) H12).
           apply Mem.valid_pointer_nonempty_perm, Mem.perm_cur_max in H5.
           destruct (lap b0 b7 delta b1 b7 delta1 _ (Ptrofs.unsigned i1) H1 H22 H32 H5 H6); [auto | apply H13; lia].
        -- destruct H1. subst b0 vres.
           right. rewrite H22 in H32; inversion H32.
           clear H32.
           split; trivial.
           unfold Ptrofs.add; repeat rewrite Ptrofs.unsigned_repr_eq.
           repeat rewrite Z.add_mod_idemp_r by easy.
           subst delta1.
           destruct (rep b1 b3 delta i H22) as [_ Hp]. {
             left; apply Mem.perm_cur_max, Mem.valid_pointer_nonempty_perm.
             destruct H5 as [_ [_ H5]]; assert (H1: 0 <= 0 < n) by lia.
             specialize (H5 0 H1).
             now replace (Ptrofs.unsigned i + 0) with (Ptrofs.unsigned i) in H5 by lia.
           }
           destruct (rep b1 b3 delta i1 H22) as [_ Hq].
           1:  now left; apply Mem.perm_cur_max, Mem.valid_pointer_nonempty_perm.
           destruct (rep b1 b3 delta i0 H22) as [_ Hr]. {
             destruct H5 as [_ [_ H5]]. rewrite <- H4.
             assert (Hm: 0 <= n - 1 < n) by lia.
             right. apply Mem.perm_cur_max, Mem.valid_pointer_nonempty_perm.
             rewrite <- (H5 _ Hm); f_equal; lia.
           }
           clear - H3 Hp Hq Hr.
           apply lt_ptr_mod in Hp; apply lt_ptr_mod in Hq; apply lt_ptr_mod in Hr.
           repeat rewrite Z.mod_small by easy.
           destruct H3; [left | right]; lia.
  - intros. destruct H as [_ [? _]]. subst t. simpl. lia.
  - intros. generalize H. destruct H as [_ [? _]]. subst t1.
    inversion H0. subst t2. clear H0. intro H.
    exists vres1, m1. apply H.
  - intros. destruct H as [? [? ?]]. destruct H0 as [? [? ?]].
    subst m1 m2 t1 t2. split; [constructor|].
    intros _. split; trivial.
    do 4 (destruct vargs; try destruct v; try contradiction).
    destruct H2 as [_ [_ [_ [_ [_ [_ [_ ?]]]]]]].
    destruct H4 as [_ [_ [_ [_ [_ [_ [_ ?]]]]]]].
    intuition; congruence.
Qed.

(* Verification of int_or_ptr *)

Definition valid_b_o_So (m : mem) (b : block) (o : ptrofs) : Prop :=
  Mem.range_perm m b (Ptrofs.unsigned o) (Ptrofs.unsigned o + 2) Cur Nonempty.

Lemma valid_b_o_So_dec: forall m b o, {valid_b_o_So m b o} + {~ valid_b_o_So m b o}.
Proof. intros. unfold valid_b_o_So. apply Mem.range_perm_dec. Qed.

Definition test_iop_sem : extcall_sem :=
  fun _ args m1 trc ret m2 =>
    m1 = m2 /\ trc = nil /\
    match args with
    | [Vint i] =>
      if (Int.eq Int.one (Int.modu i (Int.repr 2)))
      then ret = Vone
      else False
    | [Vptr b ofs] =>
      if (Ptrofs.eq Ptrofs.one (Ptrofs.modu ofs (Ptrofs.repr 2)))
      then False
      else if valid_b_o_So_dec m1 b ofs
           then ret = Vzero
           else False
    | _ => False
    end.

Definition test_iop_sig : signature :=
  mksignature (AST.Tint :: nil) (Tret AST.Tint) cc_default.

Lemma test_iop__extcall: extcall_properties test_iop_sem test_iop_sig.
Proof.
  constructor; intros.
  - destruct H as [_ [_ ?]].
    destruct vargs; try destruct v; try contradiction; destruct vargs; try contradiction.
    1: destruct (Int.eq Int.one (Int.modu i (Int.repr 2))); subst; easy.
    destruct (Ptrofs.eq Ptrofs.one (Ptrofs.modu i (Ptrofs.repr 2))).
    1: contradiction.
    destruct (valid_b_o_So_dec m1 b i); subst; easy.
  - trivial.
  - destruct H as [? _]. subst m1. trivial.
  - destruct H as [? _]. subst m1. trivial.
  - destruct H as [? _]. subst m1. trivial.
  - destruct H as [? [? ?]]; subst m2 t.
    exists vres, m1'. split.
    2: split3; [apply Val.lessdef_refl | trivial | apply Mem.unchanged_on_refl].
    split3; trivial.
    do 2 (try destruct vargs; try destruct v); try contradiction;
      inversion H1; inversion H4; inversion H6; auto.
    clear -H0 H3.
    destruct (Ptrofs.eq Ptrofs.one (Ptrofs.modu i (Ptrofs.repr 2))); auto.
    destruct (valid_b_o_So_dec m1 b i);
      destruct (valid_b_o_So_dec m1' b i); [trivial| | contradiction..].
    clear H3; destruct n.
    destruct H0 as [_ [? _ _] _].
    unfold valid_b_o_So in *.
    unfold Mem.range_perm in *. intros.
    specialize (v ofs H).
    assert (inject_id b = Some (b, 0)) by now unfold inject_id.
    specialize (mi_perm _ _ _ ofs Cur Nonempty H0).
    replace (ofs + 0) with ofs in mi_perm by lia.
    apply (mi_perm v).
  - intros. exists f, vres, m1'.
    destruct H0 as [? [? ?]]. subst.
    split.
    2: {
      split.
      - destruct vres; auto.
        do 2 (destruct vargs; try destruct v; try contradiction).
        + destruct (Int.eq Int.one (Int.modu i0 (Int.repr 2))); [inversion H4 | easy].
        + destruct (Ptrofs.eq Ptrofs.one (Ptrofs.modu i0 (Ptrofs.repr 2))); try contradiction.
          destruct (valid_b_o_So_dec m2 b0 i0); [inversion H4 | easy].
      - split; [trivial|].
        split; [apply Mem.unchanged_on_refl|].
        split; [apply Mem.unchanged_on_refl|].
        split; [apply inject_incr_refl | congruence].
    }
    split3; trivial.
    do 2 (destruct vargs; try destruct v; try contradiction).
    + inversion H2. inversion H5. inversion H7. auto.
    + inversion H2. inversion H5. inversion H7.
      subst. clear H7 H2.
      destruct (Ptrofs.eq Ptrofs.one (Ptrofs.modu i (Ptrofs.repr 2))) eqn:parity1; [contradiction|].
      destruct (valid_b_o_So_dec m2 b i); [|contradiction].
      assert (OF: Ptrofs.unsigned (Ptrofs.add i (Ptrofs.repr delta)) = Ptrofs.unsigned i + delta).
        { eapply Mem.address_inject; eauto. apply v. lia. }
        assert (AL: (2 | delta)).
        { change 2 with (align_chunk Mint16unsigned).
          clear - H10 v H1.
          eauto using Mem.mi_align, Mem.mi_inj, Mem.range_perm_max. }
        destruct (Ptrofs.eq Ptrofs.one
                          (Ptrofs.modu (Ptrofs.add i (Ptrofs.repr delta)) (Ptrofs.repr 2))) eqn:parity2.
      * assert (0 <= Ptrofs.unsigned i + delta < Ptrofs.modulus). {
          destruct H1 as [_ _ _ _ rep _].
          specialize (rep _ _ _ i H10) as [_ rep].
          left. unfold valid_b_o_So in v.
          unfold Mem.range_perm in v.
          specialize (v (Ptrofs.unsigned i)).
          apply Mem.perm_cur_max in v. auto.
          lia. apply lt_ptr_mod in rep. assumption.
        }
        clear - parity1 parity2 AL H0.
        rewrite <- Bool.not_false_iff_true in parity2.
        unfold not in *.
        destruct parity2.
        unfold Ptrofs.modu in *.
        rewrite Ptrofs.unsigned_repr_eq in *.
        rewrite (Z.mod_small 2 _) in * by easy.
        unfold Ptrofs.add; repeat rewrite Ptrofs.unsigned_repr_eq.
        rewrite Z.add_mod_idemp_r, (Z.mod_small (Ptrofs.unsigned i + delta) _) by easy.
        rewrite <- parity1. do 2 f_equal.
        rewrite <- Z.add_mod_idemp_r, (Znumtheory.Zdivide_mod delta 2) by easy.
        now replace (Ptrofs.unsigned i + 0) with (Ptrofs.unsigned i) by lia.
      * destruct (valid_b_o_So_dec m1' b2 (Ptrofs.add i (Ptrofs.repr delta))); auto.
        destruct n.
        assert (inj := H1).
        destruct H1 as [[? _ _] _ _ _ rep _].
        unfold valid_b_o_So in *.
        rewrite OF. replace (Ptrofs.unsigned i + delta + 2) with ((Ptrofs.unsigned i + 2) + delta) by lia.
  eapply Mem.range_perm_inject; eauto.
  - destruct H as [_ [? _]]. subst t. simpl; lia.
  - generalize H. destruct H as [_ [? _]].
    subst t1; inversion H0; subst t2.
    intro H; exists vres1, m1; apply H.
  - destruct H as [? [? ?]]. destruct H0 as [? [? ?]].
    subst m1 m2 t1 t2.
    split; [constructor|]. intros _. split; trivial.
    do 2 (try destruct vargs; try destruct v; try contradiction).
    + destruct (Int.eq Int.one (Int.modu i (Int.repr 2))); subst; [trivial | contradiction].
    + destruct (Ptrofs.eq Ptrofs.one (Ptrofs.modu i (Ptrofs.repr 2))); [contradiction|].
      destruct (valid_b_o_So_dec m b i); [|contradiction].
      subst; trivial.
Qed.