From stdpp Require Export list gmap.
From iris.algebra Require Export list cmra.
From iris.algebra Require Import gset.
From iris.algebra Require Import updates local_updates proofmode_classes big_op.
From iris.prelude Require Import options.

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

Local 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).
  - intros n m m1 m2 ? ? k. eauto using dist_le with si_solver.
Qed.
Canonical Structure gmapO : ofe := Ofe (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 (M := gmap K A) 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.

Global Instance gmap_dom_ne n :
  Proper ((≡{n}@{gmap K A}≡) ==> (=)) dom.
Proof. intros m1 m2 Hm. apply set_eq=> k. by rewrite !elem_of_dom Hm. Qed.
End ofe.

Global Instance map_seq_ne {A : ofe} start :
  NonExpansive (map_seq (M:=gmap nat A) start).
Proof.
  intros n l1 l2 Hl. revert start.
  induction Hl; intros; simpl; repeat (done || f_equiv).
Qed.

Global Arguments gmapO _ {_ _} _.

(** Non-expansiveness of higher-order map functions and big-ops *)
Global Instance merge_ne `{Countable K} {A B C : ofe} n :
  Proper (((dist (A:=option A) n) ==> (dist (A:=option B) n) ==> (dist (A:=option C) n)) ==>
   (dist n) ==> (dist n) ==> (dist n)) (merge (M:=gmap K)).
Proof.
  intros ?? Hf ?? Hm1 ?? Hm2 i. rewrite !lookup_merge.
  destruct (Hm1 i), (Hm2 i); try apply Hf; by constructor.
Qed.
Global Instance union_with_proper `{Countable K} {A : ofe} 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.
Global Instance map_fmap_proper `{Countable K} {A B : ofe} (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.
Global Instance map_zip_with_proper `{Countable K} {A B C : ofe} (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 : ofe} (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.

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

Local Instance gmap_unit_instance : Unit (gmap K A) := (∅ : gmap K A).
Local Instance gmap_op_instance : Op (gmap K A) := merge op.
Local Instance gmap_pcore_instance : PCore (gmap K A) := λ m, Some (omap pcore m).
Local Instance gmap_valid_instance : Valid (gmap K A) := λ m, ∀ i, ✓ (m !! i).
Local Instance gmap_validN_instance : ValidN (gmap K A) := λ n m, ∀ i, ✓{n} (m !! i).

Lemma gmap_op m1 m2 : m1 ⋅ m2 = merge op m1 m2.
Proof. done. Qed.
Lemma lookup_op m1 m2 i : (m1 ⋅ m2) !! i = m1 !! i ⋅ m2 !! i.
Proof. rewrite lookup_merge. by destruct (m1 !! i), (m2 !! i). 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 := Cmra (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 := Ucmra (gmap K A) gmap_ucmra_mixin.

End cmra.

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

Section properties.
Context `{Countable K} {A : cmra}.
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; first 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_Some. Qed.
Lemma singleton_core' (i : K) (x : A) cx :
  pcore x ≡ Some cx → core {[ i := x ]} ≡@{gmap K A} {[ i := cx ]}.
Proof.
  intros (cx'&?&<-)%Some_equiv_eq. 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.

Lemma gmap_core_id m : (∀ i x, m !! i = Some x → CoreId x) → CoreId m.
Proof.
  intros Hcore; apply core_id_total=> i.
  rewrite lookup_core. destruct (m !! i) as [x|] eqn:Hix; rewrite Hix; [|done].
  by eapply Hcore.
Qed.
Global Instance gmap_core_id' m : (∀ x : A, CoreId x) → CoreId m.
Proof. auto using gmap_core_id. 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; first 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; first 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.
Lemma singleton_mono i x y :
  x ≼ y → {[ i := x ]} ≼ ({[ i := y ]} : gmap K A).
Proof. intros Hincl. apply singleton_included. right. done. 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 (m1 ⋅ m2) = dom m1 ∪ dom m2.
Proof.
  apply set_eq=> 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 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 (m ⋅ mf))) as [i [Hi1 Hi2]].
    assert (m !! i = None).
    { eapply not_elem_of_dom. 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.
    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 _ _ _ (λ _, 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 _ (λ _, 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 : cmra} (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.

Lemma big_opM_singletons m :
  ([^op map] k ↦ x ∈ m, {[ k := x ]}) = m.
Proof.
  (* We are breaking the big_opM abstraction here. The reason is that [map_ind]
     is too weak: we need an induction principle that visits all the keys in the
     right order, namely the order in which they appear in map_to_list.  Here,
     we achieve this by unfolding [big_opM] and doing induction over that list
     instead. *)
  rewrite big_op.big_opM_unseal /big_op.big_opM_def -{2}(list_to_map_to_list m).
  assert (NoDup (map_to_list m).*1) as Hnodup by apply NoDup_fst_map_to_list.
  revert Hnodup. induction (map_to_list m) as [|[k x] l IH]; csimpl; first done.
  intros [??]%NoDup_cons. rewrite IH //.
  rewrite insert_singleton_op ?not_elem_of_list_to_map_1 //.
Qed.

End properties.

Section unital_properties.
Context `{Countable K} {A : ucmra}.
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 *)
Global Instance gmap_fmap_ne `{Countable K} {A B : ofe} (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.
Lemma gmap_fmap_ne_ext `{Countable K}
  {A : Type} {B : ofe} (f1 f2 : A → B) (m : gmap K A) n :
  (∀ i x, m !! i = Some x → f1 x ≡{n}≡ f2 x) →
  f1 <$> m ≡{n}≡ f2 <$> m.
Proof.
  move => Hf i.
  rewrite !lookup_fmap.
  destruct (m !! i) eqn:?; constructor; by eauto.
Qed.
Global Instance gmap_fmap_cmra_morphism `{Countable K} {A B : cmra} (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).
Global 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.
Global 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.
Global 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.

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


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D Aprime Bprime Cprime Dprime X Y E Z Eprime : Universe, ((wd_ X A /\ (wd_ X Aprime /\ (wd_ X C /\ (wd_ X Cprime /\ (wd_ Y B /\ (wd_ Y Bprime /\ (wd_ Y D /\ (wd_ Y Dprime /\ (wd_ A C /\ (wd_ B D /\ (wd_ A Aprime /\ (wd_ E Z /\ (wd_ A D /\ (wd_ D E /\ (wd_ A E /\ (wd_ X Y /\ (wd_ X B /\ (wd_ A Y /\ (wd_ A B /\ (wd_ B C /\ (wd_ Bprime Cprime /\ (wd_ Aprime Dprime /\ (wd_ Aprime Bprime /\ (col_ X A C /\ (col_ X A Aprime /\ (col_ X A Cprime /\ (col_ Y B D /\ (col_ Y B Bprime /\ (col_ Y B Dprime /\ (col_ E A B /\ (col_ E C D /\ (col_ X E Z /\ (col_ A E Z /\ (col_ Eprime Aprime Bprime /\ col_ Eprime E Z)))))))))))))))))))))))))))))))))) -> col_ E X A)).
Proof.
  time tac.
Qed.

End FOFProblem.


From lrust.lifetime Require Export primitive.
From lrust.lifetime Require Import faking.
From iris.algebra Require Import csum auth frac gmap agree gset numbers.
From iris.base_logic.lib Require Import boxes.
From iris.proofmode Require Import proofmode.
From iris.prelude Require Import options.

Section creation.
Context `{!invGS Σ, !lftGS Σ userE}.
Implicit Types κ : lft.

Lemma lft_kill (I : gmap lft lft_names) (K K' : gset lft) (κ : lft) :
  let Iinv := (
    own_ilft_auth I ∗
    ([∗ set] κ' ∈ K, lft_inv_dead κ') ∗
    ([∗ set] κ' ∈ K', lft_inv_alive κ'))%I in
  (∀ κ', is_Some (I !! κ') → κ ⊂ κ' → κ' ∈ K) →
  (∀ κ', is_Some (I !! κ') → κ' ⊂ κ → κ' ∈ K') →
  Iinv -∗ lft_inv_alive κ -∗ [†κ] ={userE ∪ ↑borN ∪ ↑inhN}=∗ Iinv ∗ lft_inv_dead κ.
Proof.
  iIntros (Iinv HK HK') "(HI & Hdead & Halive) Hlalive Hκ".
  rewrite lft_inv_alive_unfold;
    iDestruct "Hlalive" as (P Q) "(Hbor & Hvs & Hinh)".
  rewrite /lft_bor_alive; iDestruct "Hbor" as (B) "(Hbox & Hbor & HB)".
  iAssert ⌜∀ i s, B !! i = Some s → s = Bor_in⌝%I with "[#]" as %HB.
  { iIntros (i s HBI).
    iDestruct (big_sepM_lookup _ B with "HB") as "HB"=> //.
    destruct s as [|q|κ']; rewrite /bor_cnt //.
    { iDestruct (lft_tok_dead with "HB Hκ") as "[]". }
    iDestruct "HB" as "[% Hcnt]".
    iDestruct (own_cnt_auth with "HI Hcnt") as %?.
    iDestruct (@big_sepS_elem_of with "Hdead") as "Hdead"; first by eauto.
    rewrite /lft_inv_dead; iDestruct "Hdead" as (R) "(_ & Hcnt' & _)".
    iDestruct (own_cnt_valid_2 with "Hcnt' Hcnt")
      as %[?%nat_included _]%auth_both_valid_discrete; lia. }
  iMod (box_empty with "Hbox") as "[HP Hbox]"=>//; first by solve_ndisj.
  { intros i s. by rewrite lookup_fmap fmap_Some=> -[? [/HB -> ->]]. }
  rewrite lft_vs_unfold; iDestruct "Hvs" as (n) "[Hcnt Hvs]".
  iDestruct (big_sepS_filter_acc (.⊂ κ) _ _ (dom I) with "Halive")
    as "[Halive Halive']".
  { intros κ'. rewrite elem_of_dom. eauto. }
  iApply fupd_trans. iApply fupd_mask_mono; last
  iMod ("Hvs" $! I with "[HI Halive] HP Hκ") as "(Hinv & HQ & Hcnt')".
  { set_solver+. }
  { rewrite lft_vs_inv_unfold. iFrame. }
  rewrite lft_vs_inv_unfold; iDestruct "Hinv" as "(HI&Halive)".
  iSpecialize ("Halive'" with "Halive").
  iMod (own_cnt_update_2 with "Hcnt Hcnt'") as "?".
  { apply auth_update_dealloc, (nat_local_update _ _ 0 0); lia. }
  rewrite /Iinv. iFrame "Hdead Halive' HI".
  iModIntro. iMod (lft_inh_kill with "[$Hinh $HQ]"); first set_solver+.
  iModIntro. rewrite /lft_inv_dead. iExists Q. iFrame.
  rewrite /lft_bor_dead. iExists (dom B), P.
  rewrite !gset_to_gmap_dom -map_fmap_compose.
  rewrite (map_fmap_ext _ ((1%Qp,.) ∘ to_agree) B); last naive_solver.
  iFrame.
Qed.

Lemma lfts_kill (A : gmap atomic_lft _) (I : gmap lft lft_names) (K K' : gset lft) :
  let Iinv K' := (own_ilft_auth I ∗ [∗ set] κ' ∈ K', lft_inv_alive κ')%I in
  K ## K' →
  (∀ κ κ', κ ∈ K → is_Some (I !! κ') → κ ⊆ κ' → κ' ∈ K) →
  (∀ κ, lft_alive_in A κ → is_Some (I !! κ) → κ ∉ K → κ ∈ K') →
  Iinv K' -∗ ([∗ set] κ ∈ K, lft_inv A κ ∗ [†κ])
    ={userE ∪ ↑borN ∪ ↑inhN}=∗ Iinv K' ∗ [∗ set] κ ∈ K, lft_inv_dead κ.
Proof.
  intros Iinv. revert K'.
  induction (set_wf K) as [K _ IH]=> K' HKK' HK HK'.
  iIntros "[HI Halive] HK".
  pose (Kalive := filter (lft_alive_in A) K).
  destruct (decide (Kalive = ∅)) as [HKalive|].
  { iModIntro. rewrite /Iinv. iFrame.
    iApply (@big_sepS_impl with "[$HK]"); iModIntro.
    rewrite /lft_inv. iIntros (κ Hκ) "[[[_ %]|[$ _]] _]". set_solver. }
  destruct (minimal_exists_L (⊂) Kalive)
    as (κ & [Hκalive HκK]%elem_of_filter & Hκmin); first done.
  iDestruct (@big_sepS_delete with "HK") as "[[Hκinv Hκ] HK]"; first done.
  iDestruct (lft_inv_alive_in with "Hκinv") as "Hκalive"; first done.
  assert (κ ∉ K') as HκK' by set_solver +HκK HKK'.
  specialize (IH (K ∖ {[ κ ]})). feed specialize IH; [set_solver +HκK|].
  iMod (IH ({[ κ ]} ∪ K') with "[HI Halive Hκalive] HK") as "[[HI Halive] Hdead]".
  { set_solver +HKK'. }
  { intros κ' κ''.
    rewrite !elem_of_difference !elem_of_singleton=> -[? Hneq] ??.
    split; [by eauto|]; intros ->.
    eapply (minimal_strict_1 _ _ κ' Hκmin), strict_spec_alt; eauto.
    apply elem_of_filter; eauto using lft_alive_in_subseteq. }
  { intros κ' Hκ'. destruct (decide (κ' = κ)) as [->|Hκκ']; [set_solver +|].
    specialize (HK' _ Hκ'). set_solver +Hκκ' HK'. }
  { rewrite /Iinv big_sepS_insert //. iFrame. }
  iDestruct (@big_sepS_insert with "Halive") as "[Hκalive Halive]"; first done.
  iMod (lft_kill with "[$HI $Halive $Hdead] Hκalive Hκ")
    as "[(HI&Halive&Hdead) Hκdead]".
  { intros κ' ? [??]%strict_spec_alt.
    rewrite elem_of_difference elem_of_singleton; eauto. }
  { intros κ' ??. eapply HK'; [|done|].
    - by eapply lft_alive_in_subseteq, gmultiset_subset_subseteq.
    - intros ?. eapply (minimal_strict_1 _ _ _ Hκmin); eauto.
      apply elem_of_filter; split; last done.
      eapply lft_alive_in_subseteq, gmultiset_subset_subseteq; eauto. }
  iModIntro. rewrite /Iinv (big_sepS_delete _ K) //. iFrame.
Qed.

Definition kill_set (I : gmap lft lft_names) (Λ : atomic_lft) : gset lft :=
  filter (Λ ∈.) (dom I).

Lemma elem_of_kill_set I Λ κ : κ ∈ kill_set I Λ ↔ Λ ∈ κ ∧ is_Some (I !! κ).
Proof. by rewrite /kill_set elem_of_filter elem_of_dom. Qed.

Lemma lft_create_strong P E :
  pred_infinite P → ↑lftN ⊆ E →
  lft_ctx ={E}=∗
  ∃ p : positive, let κ := positive_to_lft p in ⌜P p⌝ ∗
       (1).[κ] ∗ □ ((1).[κ] ={↑lftN ∪ userE}[userE]▷=∗ [†κ]).
Proof.
  assert (userE_lftN_disj:=userE_lftN_disj). iIntros (HP ?) "#LFT".
  iInv mgmtN as (A I) "(>HA & >HI & Hinv)" "Hclose".
  rewrite ->(pred_infinite_set (C:=gset _)) in HP.
  destruct (HP (dom A)) as [Λ [HPx HΛ%not_elem_of_dom]].
  iMod (own_update with "HA") as "[HA HΛ]".
  { apply auth_update_alloc, (alloc_singleton_local_update _ Λ (Cinl 1%Qp))=>//.
    by rewrite lookup_fmap HΛ. }
  iMod ("Hclose" with "[HA HI Hinv]") as "_".
  { iNext. rewrite /lfts_inv /own_alft_auth.
    iExists (<[Λ:=true]>A), I. rewrite /to_alftUR fmap_insert; iFrame.
    iApply (@big_sepS_impl with "[$Hinv]").
    iModIntro. rewrite /lft_inv. iIntros (κ ?) "[[Hκ %]|[Hκ %]]".
    - iLeft. iFrame "Hκ". iPureIntro. by apply lft_alive_in_insert.
    - iRight. iFrame "Hκ". iPureIntro. by apply lft_dead_in_insert. }
  iModIntro; iExists Λ.
  rewrite {1}/lft_tok big_sepMS_singleton. iSplit; first done. iFrame "HΛ".
  clear I A HΛ. iIntros "!> HΛ".
  iApply (step_fupd_mask_mono (↑lftN ∪ userE) _ ((↑lftN ∪ userE)∖↑mgmtN)); [solve_ndisj..|].
  iInv mgmtN as (A I) "(>HA & >HI & Hinv)" "Hclose".
  rewrite /lft_tok big_sepMS_singleton.
  iDestruct (own_valid_2 with "HA HΛ")
    as %[[s [?%leibniz_equiv ?]]%singleton_included_l _]%auth_both_valid_discrete.
  iMod (own_update_2 with "HA HΛ") as "[HA HΛ]".
  { by eapply auth_update, singleton_local_update,
      (exclusive_local_update _ (Cinr ())). }
  iDestruct "HΛ" as "#HΛ". iModIntro; iNext.
  pose (K := kill_set I Λ).
  pose (K' := filter (lft_alive_in A) (dom I) ∖ K).
  destruct (proj1 (subseteq_disjoint_union_L (K ∪ K') (dom I))) as (K''&HI&HK'').
  { set_solver+. }
  assert (K ## K') by set_solver+.
  rewrite HI !big_sepS_union //. iDestruct "Hinv" as "[[HinvK HinvD] Hinv]".
  iAssert ([∗ set] κ ∈ K', lft_inv_alive κ)%I with "[HinvD]" as "HinvD".
  { iApply (@big_sepS_impl with "[$HinvD]"); iIntros "!>".
    iIntros (κ [[Hκ _]%elem_of_filter _]%elem_of_difference) "?".
    by iApply lft_inv_alive_in. }
  iAssert ([∗ set] κ ∈ K, lft_inv A κ ∗ [† κ])%I with "[HinvK]" as "HinvK".
  { iApply (@big_sepS_impl with "[$HinvK]"); iIntros "!>".
    iIntros (κ [? _]%elem_of_kill_set) "$". rewrite /lft_dead. eauto. }
  iApply fupd_trans.
  iApply (fupd_mask_mono (userE ∪ ↑borN ∪ ↑inhN)); first solve_ndisj.
  iMod (lfts_kill A I K K' with "[$HI $HinvD] HinvK") as "[[HI HinvD] HinvK]".
  { done. }
  { intros κ κ' [??]%elem_of_kill_set ??. apply elem_of_kill_set.
    split; last done. by eapply gmultiset_elem_of_subseteq. }
  { intros κ ???. rewrite elem_of_difference elem_of_filter elem_of_dom. auto. }
  iModIntro. iMod ("Hclose" with "[-]") as "_"; last first.
  { iModIntro. rewrite /lft_dead. iExists Λ.
    rewrite gmultiset_elem_of_singleton. auto. }
  iNext. iExists (<[Λ:=false]>A), I.
  rewrite /own_alft_auth /to_alftUR fmap_insert. iFrame "HA HI".
  rewrite HI !big_sepS_union //.
  iSplitL "HinvK HinvD"; first iSplitL "HinvK".
  - iApply (@big_sepS_impl with "[$HinvK]"); iIntros "!>".
    iIntros (κ [? _]%elem_of_kill_set) "Hdead". rewrite /lft_inv.
    iRight. iFrame. iPureIntro. by apply lft_dead_in_insert_false'.
  - iApply (@big_sepS_impl with "[$HinvD]"); iIntros "!>".
    iIntros (κ [[Hκ HκI]%elem_of_filter HκK]%elem_of_difference) "Halive".
    rewrite /lft_inv. iLeft. iFrame "Halive". iPureIntro.
    apply lft_alive_in_insert_false; last done.
    move: HκK. rewrite elem_of_kill_set -(elem_of_dom (D:=gset lft)). set_solver +HκI.
  - iApply (@big_sepS_impl with "[$Hinv]"); iIntros "!>".
    rewrite /lft_inv. iIntros (κ Hκ) "[[? %]|[? %]]".
    + iLeft. iFrame. iPureIntro.
      apply lft_alive_in_insert_false; last done. intros ?.
      assert (κ ∈ K) by (rewrite elem_of_kill_set -(elem_of_dom (D:=gset lft)) HI elem_of_union; auto).
      eapply HK'', Hκ. rewrite elem_of_union. auto.
    + iRight. iFrame. iPureIntro. by apply lft_dead_in_insert_false.
Qed.
End creation.


From iris.proofmode Require Import tactics.
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang.
From iris.heap_lang Require Import proofmode notation.
Set Default Proof Using "Type".

Fixpoint val_of_list (vs : list (val * val)) : val :=
  match vs with
  | []          => #()
  | (_, v) :: _ => v
  end.

(** Specification for one-shot prophecy variables. *)

Section one_shot.
  Context `{!heapG Σ}.

  Definition proph1 (p : proph_id) (v : val) :=
    (∃ vs, proph p vs ∗ ⌜match vs with [] => True | (_,w) :: _ => v = w end⌝)%I.

  Lemma proph1_exclusive (p : proph_id) (v1 v2 : val) :
    proph1 p v1 -∗ proph1 p v2 -∗ False.
  Proof.
    iIntros "H1 H2".
    iDestruct "H1" as (vs1) "[Hp1 _]".
    iDestruct "H2" as (vs2) "[Hp2 _]".
    iApply (proph_exclusive with "Hp1 Hp2").
  Qed.

  Lemma wp_new_proph1 s E :
    {{{ True }}}
      NewProph @ s; E
    {{{ p v, RET (LitV (LitProphecy p)); proph1 p v }}}.
  Proof.
    iIntros (Φ) "_ HΦ". wp_apply wp_new_proph; first done.
    iIntros (vs p) "Hp". iApply ("HΦ" $! p (val_of_list vs)).
    iExists _. iFrame "Hp". iPureIntro. by case vs as [|[v w] vs].
  Qed.

  Lemma wp_resolve1 s E e Φ (p : proph_id) (v w : val) :
    Atomic StronglyAtomic e →
    to_val e = None →
    proph1 p v -∗
    WP e @ s; E {{ r, ⌜v = w⌝ -∗ Φ r }} -∗
    WP Resolve e (Val $ LitV $ LitProphecy p) (Val w) @ s; E {{ Φ }}.
  Proof.
    iIntros (A He) "Hp Wpe". iDestruct "Hp" as (vs) "[Hp HEq]".
    iDestruct "HEq" as %HEq. wp_apply (wp_resolve with "Hp"); try done.
    iApply wp_mono; last done. iIntros (v0) "H". iIntros (pvs ->) "Hp".
    by iApply "H".
  Qed.
End one_shot.

(** Alternative specification. *)

Section one_shot'.
  Context `{!heapG Σ}.

  Definition proph1' (p : proph_id) (v : val) :=
    (∃ vs, proph p vs ∗ ⌜val_of_list vs = v⌝)%I.

  Lemma proph1'_exclusive (p : proph_id) (v1 v2 : val) :
    proph1' p v1 -∗ proph1' p v2 -∗ False.
  Proof.
    iIntros "H1 H2".
    iDestruct "H1" as (vs1) "[Hp1 _]".
    iDestruct "H2" as (vs2) "[Hp2 _]".
    iApply (proph_exclusive with "Hp1 Hp2").
  Qed.

  Lemma wp_new_proph1' s E :
    {{{ True }}}
      NewProph @ s; E
    {{{ p v, RET (LitV (LitProphecy p)); proph1' p v }}}.
  Proof.
    iIntros (Φ) "_ HΦ". wp_apply wp_new_proph; first done.
    iIntros (pvs p) "Hp". iApply "HΦ". iExists _. by iFrame.
  Qed.

  Lemma wp_resolve1' s E e Φ (p : proph_id) (v w : val) :
    Atomic StronglyAtomic e →
    to_val e = None →
    proph1' p v -∗
    WP e @ s; E {{ r, ⌜v = w⌝ -∗ Φ r }} -∗
    WP Resolve e (Val $ LitV $ LitProphecy p) (Val w) @ s; E {{ Φ }}.
  Proof.
    iIntros (A He) "Hp Wpe". iDestruct "Hp" as (vs) "[Hp <-]".
    wp_apply (wp_resolve with "Hp"); try done. iApply wp_mono; last done.
    iIntros (v) "H". iIntros (pvs ->) "Hp". by iApply "H".
  Qed.
End one_shot'.


Require Import String.
Require Import Ascii.
Require Import Arith.
Require Import additional_tools.

Local Open Scope string_scope.

(* -------------------------------
   ------Basics-------------------
   -------------------------------*)
(*
   This function takes in two strings, sub and s.
   it looks to see if sub is a substring of s,
   if sub is a substring of s then it returns the
   index of the substring otherwise it will return
   the length of the string s.

   This function ASSUMES that sub is not a the EmptyString,
     if sub is the EmptyString then length s will be the
     desired ansewer.
*)
Fixpoint indexOfSubstring (sub s: string): nat :=
  if (prefix sub s)
  then 0
  else match s with
         | EmptyString => 0
         | String a s' => S (indexOfSubstring sub s')
       end.

(*
    This function takes in a string, s, and
    returns the string with trailing white
    space removed.

    White space is definied as either a 'space'
    or a 'new line'
*)
Fixpoint removeTrailingWhiteSpace (s: string) (n: nat): string :=
  let lastChar := option2ascii (get n s) in
    match n with
      | 0 => EmptyString
      | S n' => if (beq_ascii lastChar " ")
                then removeTrailingWhiteSpace (substring 0 n s) n'
                else if (beq_ascii lastChar "
")
                     then removeTrailingWhiteSpace (substring 0 n s) n'
                     else s
    end.

(*
    This function takes in a string, s, and
    returns the string with leading white
    space removed.

    White space is definied as either a 'space'
    or a 'new line'
*)
Fixpoint removeLeadingWhiteSpace (s: string): string :=
  match s with
    | String " " s1 => removeLeadingWhiteSpace s1
    | String "
" s2 => removeLeadingWhiteSpace s2
    | s' => s'
  end.

(*
    This function takes in a string, s, and
    returns the string with leading and trailing
    white space removed.

    White space is defined as either a 'space'
    or a 'new line'.
*)
Definition trimWhiteSpace (s: string): string :=
  removeLeadingWhiteSpace (removeTrailingWhiteSpace s ((length s) - 1)).

(* ------ tests -------- *)
Compute prefix "bob" "bobby". (*returns true*)
Compute prefix "bobby" "bob". (*returns false*)
Compute removeLeadingWhiteSpace "
  sup". (* should return "sup"*)
Compute option2ascii (get 2 "sup"). (*should return "p"*)
Compute removeTrailingWhiteSpace "sup
  " 7. (*should return "sup"*)
Compute trimWhiteSpace "
 sup
 ". (*should return "sup"*)

(* -------------------------------
   ------Recipe Name--------------
   -------------------------------*)

(*
   This function takes in a string, s, and returns
   the index of the name of the recipe. If s has no
   recognizable name, then the function will return 0.
*)
Definition getNameIndex (s: string): nat :=
  let x := "itemprop=""name"">" in
    let index := indexOfSubstring x s in
      if (beq_nat index (length s))
      then 0
      else plus index 16
(*16 is the lenth of x, thus the name starts 16 spaces from the begining of x*).

(*
    This function takes in a string, s, and returns
    the length of the name in the string s.
*)
Definition getNameLength (s: string): nat :=
  let startIndex := getNameIndex s in
    let post := substring startIndex ((length s) - startIndex) s in
      indexOfSubstring "<" post.

(*
    This function takes in a string, s, and returns
    the name held within that string. If no name exists
    within the string then it returns the EmptyString.
*)
Definition getName (s: string): string :=
  let start_index := getNameIndex s in
    let name_length := getNameLength s in
      if (beq_nat start_index 0)
      then EmptyString
      else trimWhiteSpace (substring start_index name_length s).

(* ------ tests -------- *)
Compute getNameIndex "sup". (*Should return 0*)
Example bChicken : string := "
Bourbon Chicken
".
Example ssfChicken : string :=
        "

Savory Southern Fried Chicken

            ...

".
Compute getNameIndex bChicken. (*should return 31*)
Compute getNameLength bChicken. (*should return 15*)
Compute getName bChicken. (*should return Bourbon Chicken*)
Compute getName ssfChicken. (*should return Savory Southern Fried Chicken*)
Compute getName "sup<". (*should be EmptyString*)

(* -------------------------------
   ------Recipe Ingredients-------
   -------------------------------*)

(*
    This function takes in a string, s, and outputs
    the first index where an instance of an ingredient
    appears, the index which is returned is the index
    after "" and thus has
    a minimum value of 25, thus, if no instance of
    the above string is found, then the function will
    output 0.
*)
Definition getIngredientIndex (s: string): nat:=
  let x := "" in
    let index := indexOfSubstring x s in
      if (beq_nat index (length s))
      then 0
      else plus index 19
(*19 is the length of x, thus the ingredient starts 19 spaces from the begining of x*).

(*
    This function takes in a string, s, and returns
    all characters in the string s that occur after
    the first instance of ""
    within that string. If no such instance exists
    it returns the empty string.
*)
Definition getPostIngredientSpan (s: string): string:=
  let start := getIngredientIndex s in
    let post_length := minus (length s) start in
      let output := substring start post_length s in
        if (beq_nat (length output) (length s))
        then EmptyString
        else output.

(*
    This function takes in a string, s, and returns
    the first instance of a close tag of type
    or of type . This helps us to find the
    end index of an ingredient.
*)
Definition getIngredientEndIndex (s: string): nat :=
  let candidate_a := indexOfSubstring "" s in
    let candidate_span := indexOfSubstring "" s in
      if (blt_nat candidate_a candidate_span)
      then candidate_a
      else candidate_span.

(*
   This function takes in a string, s, and
   returns true if the first instance of an
    close tag in s appears before the
   first instance of a  close tag
   in s. This is used to determine if a
   given ingredient includes a link or not
*)
Definition includesLink (s: string): bool :=
  let candidate_a := indexOfSubstring "" s in
    let end_index := getIngredientEndIndex s in
      if (beq_nat candidate_a end_index)
      then true
      else false.

(*
    This function takes in a string, s, and returns
    the first instance of an ingredient.

    If no ingredient is found it will return the
    EmptyString.

    This function assumes all ingredients have
    associated  tags as wrappers
*)
Definition getNextIngredient (s: string): string:=
  let post := getPostIngredientSpan s in
    let start_index := if (includesLink post)
                       then (indexOfSubstring ">" post) + 1
                       else 0
                       in
      let end_index := getIngredientEndIndex post in
        let ingredient_length := end_index - start_index in
          trimWhiteSpace (substring start_index ingredient_length post).

(*
    This function takes in a string, s, and a nat, n,
    and returns the list of ingredients. This function
    uses n as its decreasing argument for a proof of
    termination. n should be the length of the string
    it is assumed that n is greater than or equal to
    the number of ingredients in s.
*)
Fixpoint getIngredientsInternal (s: string) (n: nat): list string := (*n is used to show termination*)
  match n with
    | 0 => nil
    | S n' =>
        match getNextIngredient s with
          | EmptyString => nil
          | s' => let start_index := (indexOfSubstring s' s) + (length s') in
                    let post_length := (length s) - start_index in
                      let post := substring start_index post_length s in
                        cons s' (getIngredientsInternal post n')
        end
  end.
(*
    This function takes in a string, s, and returns
    the list of ingredients found within s. if no
    ingredients are present in s, then it returns
    the empty list, nil.
*)
Definition getIngredients (s: string): list string :=
  getIngredientsInternal s (length s).

(* ------ tests -------- *)
Example ssfChicken2: string :=
        "

                    2
                    quarts

                    cold water

                    2
                    tablespoons

                    fine sea salt

".
Compute getIngredientIndex ssfChicken2. (*should return 285*)
Compute getIngredientIndex "sup". (*should return 0*)
Compute getPostIngredientSpan ssfChicken2. (*should start with "<a href=..." and include both cold water and fine sea salt*)
Compute getPostIngredientSpan "sup". (*should return the EmptyString*)
Compute getNextIngredient ssfChicken2. (*should return "cold water"*)
Compute getNextIngredient "sup". (*should return the EmptyString*)
Compute getIngredients ssfChicken2. (*should return ["cold water"; "fine sea salt"; nil]*)
Compute getIngredients "sup". (*should return [nil]*)
Example bChicken2: string := "

                            1/4 cup

                            apple juice

                            1/3 cup

                                light brown sugar

".
Compute getNextIngredient bChicken2. (*should be "apple juice", however leading and trailing whitespace is included*)
Compute getIngredients bChicken2. (*should be [apple juice; light brown sugar; nil], however it includes additional leading whitespace*)

(* -------------------------------
   ------Recipe Instructions------
   -------------------------------*)

(*
   This function takes in a string, s, and returns
   the index of the first instruction of the recipe.
   If s has no recognizable instructions, then the
   function will return 0.
*)
Definition getInstructionIndex (s: string): nat :=
  let x := "div class=""txt"">" in
    let index := indexOfSubstring x s in
      if (beq_nat index (length s))
      then 0
      else index + 16
(*16 is the length of x, thus the ingredient starts 16 spaces from the begining of x*).

(*
    This function takes in a string, s, and returns
    the length of the first instruction in the string s.
*)
Definition getInstructionLength (s: string): nat :=
  let start_index := getInstructionIndex s in
    let post_length := (length s) - start_index in
      let post := substring start_index post_length s in
        indexOfSubstring "
" post.

(*
    This function takes in a string, s, and returns
    the first instance of an instruction.

    If no instruction is found it will return the
    EmptyString.

    This function assumes all instructions have
    associated

 tags as wrappers
*)
Definition getNextInstruction (s: string): string :=
  let start_index := getInstructionIndex s in
    let instruction_length := getInstructionLength s in
      let instruction := substring start_index instruction_length s in
        if (beq_nat start_index 0)
        then EmptyString
        else trimWhiteSpace instruction.
(*
    This function takes in a string, s, and a nat, n,
    and returns the list of instructions. This function
    uses n as its decreasing argument for a proof of
    termination. n should be the length of the string
    it is assumed that n is greater than or equal to
    the number of instructions in s.
*)
Fixpoint getInstructionsInternal (s: string) (n: nat): list string :=
  match n with
    | 0 => nil
    | S n' => match getNextInstruction s with
                | EmptyString => nil
                | s' => let start_index := (indexOfSubstring s' s) + (length s') in
                          let post_length := (length s) - start_index in
                            let post := substring start_index post_length s in
                              cons s' (getInstructionsInternal post n')
              end
  end.

(*
    This function takes in a string, s, and returns
    the list of instructions found within s. if no
    ingredients are present in s, then it returns
    the empty list, nil.
*)
Definition getInstructions (s: string): list string :=
  getInstructionsInternal s (length s).

Example ssfChicken3 :=
"

Directions:

1

Editor's Note:  Named Bourbon Chicken because it was supposedly created by a Chinese cook who worked in a restaurant on Bourbon Street.

2

Heat oil in a large skillet.

3

Add chicken pieces and cook until lightly browned.

4

Remove chicken.

5

Add remaining ingredients, heating over medium Heat until well mixed and dissolved.

6

Add chicken and bring to a hard boil.

7

Reduce heat and simmer for 20 minutes.

8

Serve over hot rice and ENJOY.

".

Compute getInstructions ssfChicken3. (*should return ["Editor's Note:...";...;"...and ENJOY.";nil]*)
Compute getInstructions "sup
". (*should return [nil]*)


Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Maps.
Require Import compcert.lib.Integers.

Require Import compcert.common.AST.
Require Import compcert.common.Values.
Require Import compcert.common.Globalenvs.
Require Import compcert.common.Memory.
Require Import compcert.common.Events.
Require Import compcert.common.Errors.
Require Import compcert.common.Switch.
Require Import compcert.common.Smallstep.

Require Import List.
Import ListNotations.
Require Import Arith.
Require Import Ring.

Require Import StructTact.StructTactics.
Require Import StructTact.Util.

Require Import oeuf.EricTact.

Require Import oeuf.HList.

Require oeuf.SourceValues.
Require oeuf.HighestValues.
Require oeuf.HigherValue.
Require oeuf.HighValues.

Require Import oeuf.OpaqueTypes.

Close Scope Z.

(* UntypedComp1 *)

Definition compile_member {A : Type} {x : A} {l} :=
    let fix go {x l} (mb : member x l)  :=
        match mb with
        | Here => 0
        | There mb' => S (go mb')
        end in @go x l.

Definition compile_highest {G ty} :=
    let fix go {ty} (v : SourceValues.value G ty) :=
        let fix go_list {tys} (vs : hlist (SourceValues.value G) tys) :=
            match vs with
            | hnil => []
            | hcons v vs => go v :: go_list vs
            end in
        match v with
        | @SourceValues.VConstr _ _ ctor _ _ args =>
                HighestValues.Constr ctor (go_list args)
        | @SourceValues.VClose _ _ _ _ mb free =>
                HighestValues.Close (compile_member mb) (go_list free)
        | @SourceValues.VOpaque _ _ v =>
                HighestValues.Opaque _ v
        end in @go ty.

Definition compile_highest_list {G tys} :=
    let go {ty} := @compile_highest G ty in
    let fix go_list {tys} (vs : hlist (SourceValues.value G) tys) :=
        match vs with
        | hnil => []
        | hcons v vs => go v :: go_list vs
        end in @go_list tys.

(* TaggedComp *)

Inductive mv_higher : HighestValues.value -> HigherValue.value -> Prop :=
| HrConstr : forall ctor aargs tag bargs,
        Utopia.constructor_index ctor = tag ->
        Forall2 mv_higher aargs bargs ->
        mv_higher (HighestValues.Constr ctor aargs)
                  (HigherValue.Constr tag bargs)
| HrClose : forall fname aargs bargs,
        Forall2 mv_higher aargs bargs ->
        mv_higher (HighestValues.Close fname aargs)
                  (HigherValue.Close fname bargs)
| HrOpaque : forall oty ov,
        mv_higher (HighestValues.Opaque oty ov)
                  (HigherValue.Opaque oty ov)
.

(* FlatIntTagComp *)

Inductive mv_high : HigherValue.value -> HighValues.value -> Prop :=
| HgConstr : forall atag aargs btag bargs,
        Z.of_nat atag = Int.unsigned btag ->
        Forall2 mv_high aargs bargs ->
        mv_high (HigherValue.Constr atag aargs)
                (HighValues.Constr btag bargs)
| HgClose : forall afname afree bfname bfree,
        Pos.of_succ_nat afname = bfname ->
        Forall2 mv_high afree bfree ->
        mv_high (HigherValue.Close afname afree)
                (HighValues.Close bfname bfree)
| HgOpaque : forall oty ov,
        mv_high (HigherValue.Opaque oty ov)
                (HighValues.Opaque oty ov)
.

(* FmajorComp *)

Inductive id_key :=
| IkArg
| IkSelf
| IkSwitchTarget
| IkVar (l : nat)
| IkFunc (fname : nat)
| IkRuntime (name : String.string)
| IkMalloc
| IkScratch (n : nat)
.

Definition id_key_eq_dec (a b : id_key) : { a = b } + { a <> b }.
decide equality; eauto using eq_nat_dec, String.string_dec.
Defined.

Definition id_key_assoc {V} := assoc id_key_eq_dec (V := V).

Definition id_map := list (id_key * ident).

Definition I_id (M : id_map) k i := id_key_assoc M k = Some i.
Hint Unfold I_id.

Inductive mv_fmajor (M : id_map) : HighValues.value -> HighValues.value -> Prop :=
| FmConstr : forall tag aargs bargs,
        Forall2 (mv_fmajor M) aargs bargs ->
        mv_fmajor M (HighValues.Constr tag aargs)
                    (HighValues.Constr tag bargs)
| FmClose : forall afname afree bfname bfree,
        I_id M (IkFunc (pred (Pos.to_nat afname))) bfname ->
        Forall2 (mv_fmajor M) afree bfree ->
        mv_fmajor M (HighValues.Close afname afree)
                    (HighValues.Close bfname bfree)
| FmOpaque : forall oty ov,
        mv_fmajor M (HighValues.Opaque oty ov)
                    (HighValues.Opaque oty ov)
.


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.CommonTheorems.

Require Import VerdiRaft.TermSanityInterface.

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

  Theorem no_entries_past_current_term_nw_packets_unchanged :
    forall net ps' st',
      no_entries_past_current_term_nw net ->
      (forall p, In p ps' -> In p (nwPackets net) \/ False) ->
      no_entries_past_current_term_nw (mkNetwork ps' st').
  Proof using.
    unfold no_entries_past_current_term_nw in *. intros.
    simpl in *. find_apply_hyp_hyp. intuition eauto.
  Qed.

  Theorem no_entries_past_current_term_nw_only_new_packets_matter :
    forall net ps' l st',
      no_entries_past_current_term_nw net ->
      (forall p, In p ps' -> In p (nwPackets net) \/ In p l) ->
      no_entries_past_current_term_nw (mkNetwork l st') ->
      no_entries_past_current_term_nw (mkNetwork ps' st').
  Proof using.
    unfold no_entries_past_current_term_nw. intros. simpl in *.
    find_apply_hyp_hyp. intuition eauto.
  Qed.

  Theorem no_entries_past_current_term_nw_no_append_entries :
    forall net ps' h l st',
      no_entries_past_current_term_nw net ->
      (forall p, In p ps' -> In p (nwPackets net) \/ In p (send_packets h l)) ->
      (forall m, In m l -> ~ is_append_entries (snd m)) ->
      no_entries_past_current_term_nw (mkNetwork ps' st').
  Proof using.
    intros. eapply no_entries_past_current_term_nw_only_new_packets_matter; eauto.
    unfold no_entries_past_current_term_nw. intros. simpl in *.
    do_in_map. subst. simpl in *.
    find_apply_hyp_hyp.
    exfalso. match goal with H : _ |- _ => apply H end.
    repeat eexists; eauto.
  Qed.

  Theorem no_entries_past_current_term_nw_not_append_entries :
    forall net ps' p' st',
      no_entries_past_current_term_nw net ->
      (forall p, In p ps' -> In p (nwPackets net) \/ p = p') ->
      ~ is_append_entries (pBody p') ->
      no_entries_past_current_term_nw (mkNetwork ps' st').
  Proof using.
    intros.
    unfold no_entries_past_current_term_nw. intros. simpl in *. find_apply_hyp_hyp.
    intuition.
    - unfold no_entries_past_current_term_nw in *. eauto.
    - subst. exfalso. match goal with H : _ |- _ => apply H end.
      repeat eexists; eauto.
  Qed.

  Theorem no_entries_past_current_term_init :
    raft_net_invariant_init (no_entries_past_current_term).
  Proof using.
    unfold raft_net_invariant_init, no_entries_past_current_term.
    intuition.
    - unfold no_entries_past_current_term_host.
      intros. simpl in *. intuition.
    - unfold no_entries_past_current_term_nw.
      intros. simpl in *. intuition.
  Qed.

  Lemma doLeader_spec :
    forall h st os st' ps,
      doLeader st h = (os, st', ps) ->
      log st' = log st /\ currentTerm st' = currentTerm st.
  Proof using.
    intros. unfold doLeader in *.
    repeat break_match; find_inversion; subst; auto.
  Qed.

  Theorem no_entries_past_current_term_do_leader :
    raft_net_invariant_do_leader (no_entries_past_current_term).
  Proof using.
    unfold raft_net_invariant_do_leader, no_entries_past_current_term.
    intuition.
    - unfold no_entries_past_current_term_host in *.
      intros. simpl in *.
      find_apply_lem_hyp doLeader_spec.
      find_higher_order_rewrite.
      break_if;
        subst; intuition;
        repeat find_rewrite;
        eauto.
    - unfold no_entries_past_current_term_nw in *. intros; simpl in *.
      find_apply_hyp_hyp. intuition eauto.
      unfold doLeader in *.
      repeat break_match; repeat find_inversion; try solve_by_inversion.
      repeat do_in_map; subst; simpl in *; find_inversion.
      find_apply_lem_hyp findGtIndex_in. eauto.
  Qed.

  Lemma doGenericServer_spec :
    forall h d os d' ms,
      doGenericServer h d = (os, d', ms) ->
      (log d' = log d /\ currentTerm d' = currentTerm d /\
       (forall m, In m ms -> ~ is_append_entries (snd m))).
  Proof using.
    intros. unfold doGenericServer in *.
    repeat break_match; find_inversion; subst; intuition;
    use_applyEntries_spec; subst; simpl in *; auto.
  Qed.

  Lemma no_entries_past_current_term_do_generic_server :
    raft_net_invariant_do_generic_server no_entries_past_current_term.
  Proof using.
    unfold raft_net_invariant_do_generic_server, no_entries_past_current_term. intros.
    find_apply_lem_hyp doGenericServer_spec. intuition.
    - unfold no_entries_past_current_term_host in *.
      intros. simpl in *.
      find_higher_order_rewrite; break_match; eauto.
      subst; repeat find_rewrite; eauto.
    - eauto using no_entries_past_current_term_nw_no_append_entries.
  Qed.

  Lemma handleClientRequest_messages :
    forall h d client id c os d' ms,
      handleClientRequest h d client id c = (os, d', ms) ->
      (forall m, In m ms -> ~ is_append_entries (snd m)).
  Proof using.
    intros. unfold handleClientRequest in *.
    break_match; find_inversion; subst; intuition.
  Qed.

  Lemma no_entries_past_current_term_client_request :
    raft_net_invariant_client_request (no_entries_past_current_term).
  Proof using.
    unfold raft_net_invariant_client_request, no_entries_past_current_term.
    intuition.
    - unfold no_entries_past_current_term_host in *.
      intros. simpl in *.
      find_higher_order_rewrite; break_if; eauto.
      unfold handleClientRequest in *.
      subst.
      break_match; find_inversion; eauto.
      simpl in *. intuition. subst; simpl in *; auto.
    - eauto using no_entries_past_current_term_nw_no_append_entries,
                  handleClientRequest_messages.
  Qed.

  Lemma handleTimeout_spec :
    forall h d os d' ms,
      handleTimeout h d = (os, d', ms) ->
      log d' = log d /\ currentTerm d <= currentTerm d' /\
      ( forall m, In m ms -> ~ is_append_entries (snd m)).
  Proof using.
    intros. unfold handleTimeout, tryToBecomeLeader in *.
    repeat break_match; find_inversion; subst; intuition;
    do_in_map; subst; simpl in *; congruence.
  Qed.

  Lemma no_entries_past_current_term_timeout :
    raft_net_invariant_timeout no_entries_past_current_term.
  Proof using.
    unfold raft_net_invariant_timeout, no_entries_past_current_term.
    intros. find_apply_lem_hyp handleTimeout_spec.
    intuition.
    - unfold no_entries_past_current_term_host in *.
      intros. simpl in *.
      find_higher_order_rewrite; break_if; eauto.
      subst; repeat find_rewrite.
      eapply Nat.le_trans; [|eauto]; eauto.
    - eauto using no_entries_past_current_term_nw_no_append_entries.
  Qed.

  Lemma handleAppendEntries_spec :
    forall h st t n pli plt es ci st' m,
      handleAppendEntries h st t n pli plt es ci = (st', m) ->
      (currentTerm st <= currentTerm st' /\
       (forall e,
          In e (log st') ->
          In e (log st) \/
          In e es /\ currentTerm st' = t) /\
       ~ is_append_entries m).
  Proof using.
    intros.
    unfold handleAppendEntries, advanceCurrentTerm in *.
    repeat break_match; try find_inversion; subst; simpl in *; intuition;
    do_bool; intuition; try solve [break_exists; congruence];
    in_crush; eauto using removeAfterIndex_in.
  Qed.

  Lemma no_entries_past_current_term_append_entries :
    raft_net_invariant_append_entries no_entries_past_current_term.
  Proof using.
    unfold raft_net_invariant_append_entries, no_entries_past_current_term.
    intros. find_apply_lem_hyp handleAppendEntries_spec.
    intuition.
    - unfold no_entries_past_current_term_host in *.
      intros. simpl in *. find_higher_order_rewrite.
      break_if; eauto. subst.
      find_apply_hyp_hyp. intuition.
      + eapply Nat.le_trans; [|eauto]; eauto.
      + subst.
        eapply_prop no_entries_past_current_term_nw; eauto.
    - match goal with
        | _ : context [{| pSrc := ?ps; pDst := ?pd; pBody := ?pb |}] |- _ =>
          eapply no_entries_past_current_term_nw_not_append_entries
          with (p' := {| pSrc := ps; pDst := pd; pBody := pb |})
      end; eauto.
     intros. find_apply_hyp_hyp. find_rewrite. in_crush.
  Qed.

  Lemma no_entries_past_current_term_unaffected :
    forall net st' ps' xs p ys d ms,
      nwPackets net = xs ++ p :: ys ->
      no_entries_past_current_term net ->
      (forall h : Net.name, st' h = update name_eq_dec (nwState net) (pDst p) d h) ->
      (forall p' : packet,
       In p' ps' ->
       In p' (xs ++ ys) \/ In p' (send_packets (pDst p) ms)) ->
      currentTerm (nwState net (pDst p)) <= currentTerm d ->
      log d = log (nwState net (pDst p)) ->
      (forall m, In m ms -> ~ is_append_entries (snd m)) ->
      no_entries_past_current_term {| nwPackets := ps'; nwState := st' |}.
  Proof using.
    intros. unfold no_entries_past_current_term in *. intuition.
    - unfold no_entries_past_current_term_host in *.
      intros. simpl in *. find_higher_order_rewrite.
      break_if; eauto. subst.
      repeat find_rewrite. eapply Nat.le_trans; [|eauto].
      eauto.
    - unfold no_entries_past_current_term_nw.
      intros. simpl in *.
      find_apply_hyp_hyp. intuition.
      + intros.
        match goal with
          | _ : In ?p _ |- _ =>
            assert (In p (nwPackets net)) by (find_rewrite; in_crush)
        end.
        eapply_prop no_entries_past_current_term_nw; eauto.
      + exfalso.
        do_in_map. subst.
        simpl in *.
        find_apply_hyp_hyp. find_rewrite. repeat eexists; eauto.
  Qed.

  Lemma no_entries_past_current_term_unaffected_1 :
    forall net st' ps' xs p ys d m,
      nwPackets net = xs ++ p :: ys ->
      no_entries_past_current_term net ->
      (forall h : Net.name, st' h = update name_eq_dec (nwState net) (pDst p) d h) ->
      (forall p' : packet,
       In p' ps' ->
       In p' (xs ++ ys) \/ p' = m) ->
      currentTerm (nwState net (pDst p)) <= currentTerm d ->
      log d = log (nwState net (pDst p)) ->
      ~ is_append_entries (pBody m) ->
      no_entries_past_current_term {| nwPackets := ps'; nwState := st' |}.
  Proof using.
    intros. unfold no_entries_past_current_term in *. intuition.
    - unfold no_entries_past_current_term_host in *.
      intros. simpl in *. find_higher_order_rewrite.
      break_if; eauto. subst.
      repeat find_rewrite. eapply Nat.le_trans; [|eauto].
      eauto.
    - unfold no_entries_past_current_term_nw.
      intros. simpl in *.
      find_apply_hyp_hyp. intuition.
      + intros.
        match goal with
          | _ : In ?p _ |- _ =>
            assert (In p (nwPackets net)) by (find_rewrite; in_crush)
        end.
        eapply_prop no_entries_past_current_term_nw; eauto.
      + exfalso. subst. repeat find_rewrite.
        forwards; intuition.
        repeat eexists; eauto.
  Qed.

  Lemma no_entries_past_current_term_unaffected_0 :
    forall net st' ps' xs p ys d,
      nwPackets net = xs ++ p :: ys ->
      no_entries_past_current_term net ->
      (forall h : Net.name, st' h = update name_eq_dec (nwState net) (pDst p) d h) ->
      (forall p' : packet,
       In p' ps' ->
       In p' (xs ++ ys)) ->
      currentTerm (nwState net (pDst p)) <= currentTerm d ->
      log d = log (nwState net (pDst p)) ->
      no_entries_past_current_term {| nwPackets := ps'; nwState := st' |}.
  Proof using.
    intros. unfold no_entries_past_current_term in *. intuition.
    - unfold no_entries_past_current_term_host in *.
      intros. simpl in *. find_higher_order_rewrite.
      break_if; eauto. subst.
      repeat find_rewrite. eapply Nat.le_trans; [|eauto].
      eauto.
    - unfold no_entries_past_current_term_nw.
      intros. simpl in *.
      find_apply_hyp_hyp.
      match goal with
        | _ : In ?p _ |- _ =>
          assert (In p (nwPackets net)) by (find_rewrite; in_crush)
      end.
      eapply_prop no_entries_past_current_term_nw; eauto.
  Qed.

  Lemma handleAppendEntriesReply_spec :
    forall h st h' t es r st' ms,
      handleAppendEntriesReply h st h' t es r = (st', ms) ->
      (currentTerm st <= currentTerm st' /\
       log st' = log st /\
       (forall m, In m ms -> ~ is_append_entries (snd m))).
  Proof using.
    intros.
    unfold handleAppendEntriesReply, advanceCurrentTerm in *.
    repeat break_match; try find_inversion; subst; simpl in *; intuition;
    do_bool; intuition; try solve [break_exists; congruence];
    in_crush; eauto using removeAfterIndex_in.
  Qed.

  Lemma no_entries_past_current_term_append_entries_reply :
    raft_net_invariant_append_entries_reply no_entries_past_current_term.
  Proof using.
    unfold raft_net_invariant_append_entries_reply.
    intros. find_apply_lem_hyp handleAppendEntriesReply_spec.
    intuition eauto using no_entries_past_current_term_unaffected.
  Qed.

  Lemma handleRequestVote_spec :
    forall h st t h' pli plt st' m,
      handleRequestVote h st t h' pli plt = (st', m) ->
      (currentTerm st <= currentTerm st' /\
       log st' = log st /\
       ~ is_append_entries m).
  Proof using.
    intros.
    unfold handleRequestVote, advanceCurrentTerm in *.
    repeat break_match; try find_inversion; subst; simpl in *; intuition;
    do_bool; intuition; try solve [break_exists; congruence];
    in_crush; eauto using removeAfterIndex_in.
  Qed.

  Lemma no_entries_past_current_term_request_vote :
    raft_net_invariant_request_vote no_entries_past_current_term.
  Proof using.
    unfold raft_net_invariant_request_vote.
    intros. find_apply_lem_hyp handleRequestVote_spec.
    intuition eauto using no_entries_past_current_term_unaffected_1.
  Qed.

  Lemma handleRequestVoteReply_spec :
    forall h st h' t v st',
      handleRequestVoteReply h st h' t v = st' ->
      (currentTerm st <= currentTerm st' /\
       log st' = log st).
  Proof using.
    intros.
    unfold handleRequestVoteReply, advanceCurrentTerm in *.
    repeat break_match; try find_inversion; subst; simpl in *; intuition;
    do_bool; intuition.
  Qed.

  Lemma no_entries_past_current_term_request_vote_reply :
    raft_net_invariant_request_vote_reply no_entries_past_current_term.
  Proof using.
    unfold raft_net_invariant_request_vote_reply.
    intros. find_apply_lem_hyp handleRequestVoteReply_spec.
    intuition eauto using no_entries_past_current_term_unaffected_0.
  Qed.

  Lemma no_entries_past_current_term_state_same_packet_subset :
    raft_net_invariant_state_same_packet_subset no_entries_past_current_term.
  Proof using.
    unfold raft_net_invariant_state_same_packet_subset,
    no_entries_past_current_term, no_entries_past_current_term_host,
    no_entries_past_current_term_nw.
    intros. intuition.
    - repeat find_reverse_higher_order_rewrite. eauto.
    - find_apply_hyp_hyp. eauto.
  Qed.

  Lemma no_entries_past_current_term_reboot :
    raft_net_invariant_reboot no_entries_past_current_term.
  Proof using.
    unfold raft_net_invariant_reboot,
    no_entries_past_current_term, no_entries_past_current_term_host,
    no_entries_past_current_term_nw, reboot.
    intuition.
    - repeat find_higher_order_rewrite. simpl in *.
      subst. break_if; simpl in *; intuition.
     - find_reverse_rewrite. eauto.
  Qed.

  Theorem no_entries_past_current_term_invariant :
    forall net,
      raft_intermediate_reachable net ->
      no_entries_past_current_term net.
  Proof using.
    intros.
    eapply raft_net_invariant; eauto.
    - apply no_entries_past_current_term_init.
    - apply no_entries_past_current_term_client_request.
    - apply no_entries_past_current_term_timeout.
    - apply no_entries_past_current_term_append_entries.
    - apply no_entries_past_current_term_append_entries_reply.
    - apply no_entries_past_current_term_request_vote.
    - apply no_entries_past_current_term_request_vote_reply.
    - apply no_entries_past_current_term_do_leader.
    - apply no_entries_past_current_term_do_generic_server.
    - apply no_entries_past_current_term_state_same_packet_subset.
    - apply no_entries_past_current_term_reboot.
  Qed.

  Instance tsi : term_sanity_interface.
  Proof.
    split.
    auto using no_entries_past_current_term_invariant.
  Qed.
End TermSanityProof.


Set Implicit Arguments.
Set Maximal Implicit Insertion.
Set Contextual Implicit.

From Coq Require Import
     Relation_Definitions
     RelationClasses
.

Require Import Fix.
Require Import GHC.Base.

Require Import ClassesOfFunctors.FunctorPlus.
Require Import Adverb.Composable.Nondeterministically.

Section RefinesFplusLaws.

    Variable D : (Set -> Set) -> Set -> Set.
    Context `{ReifiedPlus -≪ D} `{Functor1 D}.
    Context `{Functor (Fix1 D)}.

    Variant RefinesFplusLaws
            (Kr : forall (A : Set), relation (Fix1 D A))
            {A : Set} : relation (Fix1 D A) :=
    | RefinesFplusL : forall (a b : Fix1 D A),
        RefinesFplusLaws Kr a (fplus a b)
    | RefinesFplusR : forall (a b : Fix1 D A),
        RefinesFplusLaws Kr b (fplus a b)
    | RefinesFplus : forall (a b c : Fix1 D A),
        Kr _ a c ->
        Kr _ b c ->
        RefinesFplusLaws Kr (fplus a b) c.

    Global Instance FunctorRel__RefinesFplusLaws :
      FunctorRel (F:=Fix1 D) RefinesFplusLaws.
    constructor. intros.
    destruct H3; constructor; auto.
    Qed.

End RefinesFplusLaws.

Section RefinesFplusLaws_SmartConstructors.

  Variable D : (Set -> Set) -> Set -> Set.
  Context `{ReifiedPlus -≪ D} `{Functor1 D}.
  Context `{Functor (Fix1 D)}.

  Variable R : (forall (A : Set), relation (Fix1 D A)) ->
               forall (A : Set), relation (Fix1 D A).
  Context `{FunctorRel _ R} `{RefinesFplusLaws -⋘ R}.

  Lemma refinesFplusL :
    forall {A : Set} (a b : Fix1 D A),
      FixRel R _ a (fplus a b).
  Proof.
    intros. apply inFRel, injRel.
    constructor; assumption.
  Qed.

  Lemma refinesFplusR :
    forall {A : Set} (a b : Fix1 D A),
      FixRel R _ b (fplus a b).
  Proof.
    intros. apply inFRel, injRel.
    constructor; assumption.
  Qed.

  Lemma refinesFplus :
    forall {A : Set} (a b c : Fix1 D A),
      FixRel R _ a c ->
      FixRel R _ b c ->
      FixRel R _ (fplus a b) c.
  Proof.
    intros. apply inFRel, injRel.
    constructor; assumption.
  Qed.

End RefinesFplusLaws_SmartConstructors.