(* modified from iris.base_logic.lib.own *)

From iris.algebra Require Import functions gmap proofmode_classes.
From iris.base_logic Require Import algebra.
From iris.proofmode Require Import classes.
From iris_ora.algebra Require Import functions gmap.
From iris_ora.logic Require Export iprop derived.
Import bi oupred.ouPred ouPred.
From iris.bi Require Export updates.
From iris.prelude Require Import options.

Section ora_transport.
  Context {A B : ora} (H : A = B).
  Notation T := (ora_transport H).
  Lemma ora_transport_updateP (P : A → Prop) (Q : B → Prop) x :
    x ~~>: P → (∀ y, P y → Q (T y)) → T x ~~>: Q.
  Proof. destruct H; eauto using cmra_updateP_weaken. Qed.
  Lemma ora_transport_updateP' (P : A → Prop) x :
    x ~~>: P → T x ~~>: λ y, ∃ y', y = ora_transport H y' ∧ P y'.
  Proof. eauto using ora_transport_updateP. Qed.
End ora_transport.

(** The class [inG Σ A] expresses that the ORA [A] is in the list of functors
[Σ]. This class is similar to the [subG] class, but written down in terms of
individual ORAs instead of (lists of) ORA *functors*. This additional class is
needed because Coq is otherwise unable to solve type class constraints due to
higher-order unification problems. *)
Class inG (Σ : gFunctors) (A : ora) := InG {
  inG_id : gid Σ;
  inG_apply := OrarFunctor_apply (gFunctors_lookup Σ inG_id);
  inG_prf : A = inG_apply (iPropO Σ) _;
}.
Global Arguments inG_id {_ _} _.
Global Arguments inG_apply {_ _} _ _ {_}.

(** We use the mode [-] for [Σ] since there is always a unique [Σ]. We use the
mode [!] for [A] since we can have multiple [inG]s for different [A]s, so we do
not want Coq to pick one arbitrarily. *)
Global Hint Mode inG - ! : typeclass_instances.

Lemma subG_inG Σ (F : gFunctor) : subG F Σ → inG Σ (OrarFunctor_apply F (iPropO Σ)).
Proof. move=> /(_ 0%fin) /= [j ->]. by exists j. Qed.

(** This tactic solves the usual obligations "subG ? Σ → {in,?}G ? Σ" *)
Ltac solve_inG :=
  (* Get all assumptions *)
  intros;
  (* Unfold the top-level xΣ. We need to support this to be a function. *)
  lazymatch goal with
  | H : subG (?xΣ _ _ _ _) _ |- _ => try unfold xΣ in H
  | H : subG (?xΣ _ _ _) _ |- _ => try unfold xΣ in H
  | H : subG (?xΣ _ _) _ |- _ => try unfold xΣ in H
  | H : subG (?xΣ _) _ |- _ => try unfold xΣ in H
  | H : subG ?xΣ _ |- _ => try unfold xΣ in H
  end;
  (* Take apart subG for non-"atomic" lists *)
  repeat match goal with
         | H : subG (gFunctors.app _ _) _ |- _ => apply subG_inv in H; destruct H
         end;
  (* Try to turn singleton subG into inG; but also keep the subG for typeclass
     resolution -- to keep them, we put them onto the goal. *)
  repeat match goal with
         | H : subG _ _ |- _ => move:(H); (apply subG_inG in H || clear H)
         end;
  (* Again get all assumptions and simplify the functors *)
  intros; simpl in *;
  (* We support two kinds of goals: Things convertible to inG;
     and records with inG and typeclass fields. Try to solve the
     first case. *)
  try assumption;
  (* That didn't work, now we're in for the second case. *)
  split; (assumption || by apply _).

(** * Definition of the connective [own] *)
Local Definition inG_unfold {Σ A} {i : inG Σ A} :
    inG_apply i (iPropO Σ) -n> inG_apply i (iPrePropO Σ) :=
  orarFunctor_map _ (iProp_fold, iProp_unfold).
Local Definition inG_fold {Σ A} {i : inG Σ A} :
    inG_apply i (iPrePropO Σ) -n> inG_apply i (iPropO Σ) :=
  orarFunctor_map _ (iProp_unfold, iProp_fold).

Local Definition iRes_singleton {Σ A} {i : inG Σ A} (γ : gname) (a : A) : iResUR Σ :=
  discrete_fun_singleton (inG_id i)
    {[ γ := inG_unfold (ora_transport inG_prf a) ]}.
Global Instance: Params (@iRes_singleton) 4 := {}.

Local Definition own_def `{!inG Σ A} (γ : gname) (a : A) : iProp Σ :=
  ouPred_ownM (iRes_singleton γ a).
Local Definition own_aux : seal (@own_def). Proof. by eexists. Qed.
Definition own := own_aux.(unseal).
Global Arguments own {Σ A _} γ a.
Local Definition own_eq : @own = @own_def := own_aux.(seal_eq).
Local Instance: Params (@own) 4 := {}.

(** * Properties about ghost ownership *)
Section global.
Context `{i : !inG Σ A}.
Implicit Types a : A.

(** ** Properties of [iRes_singleton] *)
Local Lemma inG_unfold_fold (x : inG_apply i (iPrePropO Σ)) :
  inG_unfold (inG_fold x) ≡ x.
Proof.
  rewrite /inG_unfold /inG_fold -orarFunctor_map_compose -{2}[x]orarFunctor_map_id.
  apply (ne_proper (orarFunctor_map _)); split=> ?; apply iProp_unfold_fold.
Qed.
Local Lemma inG_fold_unfold (x : inG_apply i (iPropO Σ)) :
  inG_fold (inG_unfold x) ≡ x.
Proof.
  rewrite /inG_unfold /inG_fold -orarFunctor_map_compose -{2}[x]orarFunctor_map_id.
  apply (ne_proper (orarFunctor_map _)); split=> ?; apply iProp_fold_unfold.
Qed.
Local Lemma inG_unfold_validN n (x : inG_apply i (iPropO Σ)) :
  ✓{n} (inG_unfold x) ↔ ✓{n} x.
Proof.
  split; [|apply (ora_morphism_validN _)].
  move=> /(ora_morphism_validN inG_fold). by rewrite inG_fold_unfold.
Qed.

Local Instance iRes_singleton_ne γ : NonExpansive (@iRes_singleton Σ A _ γ).
Proof. by intros n a a' Ha; apply discrete_fun_singleton_ne; rewrite Ha. Qed.
Local Lemma iRes_singleton_validI γ a : ✓ (iRes_singleton γ a) ⊢@{iPropI Σ} ✓ a.
Proof.
  rewrite /iRes_singleton.
  rewrite discrete_fun_validI (forall_elim (inG_id i)) discrete_fun_lookup_singleton.
  rewrite singleton_validI.
  trans (✓ ora_transport inG_prf a : iProp Σ)%I; last by destruct inG_prf.
  apply valid_entails=> n. apply inG_unfold_validN.
Qed.
Local Lemma iRes_singleton_op γ a1 a2 :
  iRes_singleton γ (a1 ⋅ a2) ≡ iRes_singleton γ a1 ⋅ iRes_singleton γ a2.
Proof.
  rewrite /iRes_singleton discrete_fun_singleton_op singleton_op ora_transport_op.
  f_equiv. apply: singletonM_proper. by rewrite (ora_morphism_op _).
Qed.

Local Instance iRes_singleton_discrete γ a :
  Discrete a → Discrete (iRes_singleton γ a).
Proof.
  intros ?. rewrite /iRes_singleton.
  apply (discrete_fun_singleton_discrete(B := λ x, uora_ucmraR _)), gmap_singleton_discrete; [apply _|].
  intros x Hx. assert (ora_transport inG_prf a ≡ inG_fold x) as Ha.
  { apply (discrete _). by rewrite -Hx inG_fold_unfold. }
  by rewrite Ha inG_unfold_fold.
Qed.
Local Instance iRes_singleton_core_id γ a :
  OraCoreId a → OraCoreId (iRes_singleton γ a).
Proof.
  intros. apply discrete_fun_singleton_core_id, gmap_singleton_core_id.
  by rewrite /OraCoreId -ora_morphism_pcore oracore_id.
Qed.

Local Lemma later_internal_eq_iRes_singleton γ a r :
  ▷ (r ≡ iRes_singleton γ a) ⊢@{iPropI Σ}
  ◇ ∃ b r', r ≡ iRes_singleton γ b ⋅ r' ∧ ▷ (a ≡ b).
Proof.
  assert (NonExpansive (λ r : iResUR Σ, r (inG_id i) !! γ)).
  { intros n r1 r2 Hr. f_equiv. by specialize (Hr (inG_id i)). }
  rewrite (f_equivI (λ r : iResUR Σ, r (inG_id i) !! γ) r).
  rewrite {1}/iRes_singleton discrete_fun_lookup_singleton lookup_singleton.
  rewrite option_equivI. case Hb: (r (inG_id _) !! γ)=> [b|]; last first.
  { by rewrite /bi_except_0 -or_intro_l. }
  rewrite -except_0_intro.
  rewrite -(exist_intro (ora_transport (eq_sym inG_prf) (inG_fold b))).
  rewrite -(exist_intro (discrete_fun_insert (inG_id _) (delete γ (r (inG_id i))) r)).
  apply and_intro.
  - apply equiv_internal_eq. rewrite /iRes_singleton.
    rewrite ora_transport_trans eq_trans_sym_inv_l /=.
    intros i'. rewrite discrete_fun_lookup_op.
    destruct (decide (i' = inG_id i)) as [->|?].
    + rewrite discrete_fun_lookup_insert discrete_fun_lookup_singleton.
      intros γ'. rewrite lookup_op. destruct (decide (γ' = γ)) as [->|?].
      * by rewrite lookup_singleton lookup_delete Hb inG_unfold_fold.
      * by rewrite lookup_singleton_ne // lookup_delete_ne // left_id.
    + rewrite discrete_fun_lookup_insert_ne //.
      by rewrite discrete_fun_lookup_singleton_ne // left_id.
  - apply later_mono. rewrite (f_equivI inG_fold) inG_fold_unfold.
    apply: (internal_eq_rewrite' _ _ (λ b, a ≡ ora_transport (eq_sym inG_prf) b)%I);
      [solve_proper|apply internal_eq_sym|].
    rewrite ora_transport_trans eq_trans_sym_inv_r /=. apply internal_eq_refl.
Qed.

(** ** Properties of [own] *)
Global Instance own_ne γ : NonExpansive (@own Σ A _ γ).
Proof. rewrite !own_eq. solve_proper. Qed.
Global Instance own_proper γ :
  Proper ((≡) ==> (⊣⊢)) (@own Σ A _ γ) := ne_proper _.

Lemma own_op γ a1 a2 : own γ (a1 ⋅ a2) ⊣⊢ own γ a1 ∗ own γ a2.
Proof. by rewrite !own_eq /own_def -ownM_op iRes_singleton_op. Qed.
Lemma own_mono γ a1 a2 : a2 ≼ₒ a1 → own γ a1 ⊢ own γ a2.
Proof. rewrite !own_eq /own_def /iRes_singleton. intros; apply ownM_mono.
  intros ?. destruct (decide (x = inG_id i)); last by rewrite !discrete_fun_lookup_singleton_ne.
  subst; rewrite !discrete_fun_lookup_singleton.
  intros k; destruct (decide (γ = k)); last by rewrite !lookup_singleton_ne.
  subst; rewrite !lookup_singleton /=.
  apply ora_morphism_monotone; first by apply _.
  by destruct inG_prf.
Qed.

Global Instance own_mono' γ : Proper (flip (≼ₒ) ==> (⊢)) (@own Σ A _ γ).
Proof. intros a1 a2. apply own_mono. Qed.

Lemma own_valid γ a : own γ a ⊢ ✓ a.
Proof. by rewrite !own_eq /own_def ownM_valid iRes_singleton_validI. Qed.
Lemma own_valid_2 γ a1 a2 : own γ a1 -∗ own γ a2 -∗ ✓ (a1 ⋅ a2).
Proof. apply wand_intro_r. by rewrite -own_op own_valid. Qed.
Lemma own_valid_3 γ a1 a2 a3 : own γ a1 -∗ own γ a2 -∗ own γ a3 -∗ ✓ (a1 ⋅ a2 ⋅ a3).
Proof. do 2 apply wand_intro_r. by rewrite -!own_op own_valid. Qed.
Lemma own_valid_r γ a : own γ a ⊢ own γ a ∗ ✓ a.
Proof. apply: bi.persistent_entails_r. apply own_valid. Qed.
Lemma own_valid_l γ a : own γ a ⊢ ✓ a ∗ own γ a.
Proof. by rewrite comm -own_valid_r. Qed.

Global Instance own_timeless γ a : Discrete a → Timeless (own γ a).
Proof. rewrite !own_eq /own_def. apply _. Qed.
Global Instance own_core_persistent γ a : OraCoreId a → Persistent (own γ a).
Proof. rewrite !own_eq /own_def; apply _. Qed.
Global Instance own_core_affine γ a : OraCoreId a → Affine (own γ a).
Proof. rewrite /Affine !own_eq /own_def.
  intros. etrans; last apply ownM_unit_affine.
  apply ownM_mono.
  intros j k; simpl.
  rewrite lookup_empty /= /iRes_singleton.
  destruct (decide (j = inG_id i)); last by rewrite discrete_fun_lookup_singleton_ne.
  subst; rewrite discrete_fun_lookup_singleton.
  destruct (decide (γ = k)); last by rewrite !lookup_singleton_ne.
  subst; rewrite !lookup_singleton /=.
  apply ora_morphism_increasing; first by apply _.
  intros ?.
  destruct inG_prf; simpl.
  inversion H as [?? Heq Hcore|]; subst.
  rewrite -Heq; eapply ora_pcore_increasing; eauto.
Qed.

(*Lemma later_own γ a : ▷ own γ a -∗ ◇ ∃ b, own γ b ∧ ▷ (a ≡ b).
Proof.
  rewrite own_eq /own_def later_ownM. apply exist_elim=> r.
  assert (NonExpansive (λ r : iResUR Σ, r (inG_id i) !! γ)).
  { intros n r1 r2 Hr. f_equiv. by specialize (Hr (inG_id i)). }
  rewrite internal_eq_sym later_internal_eq_iRes_singleton.
  rewrite (except_0_intro (ouPred_ownM r)) -except_0_and. f_equiv.
  rewrite and_exist_l. f_equiv=> b. rewrite and_exist_l. apply exist_elim=> r'.
  rewrite assoc. apply and_mono_l.
  etrans; [|apply ownM_mono].
  -
  eapply (internal_eq_rewrite' _ _ ouPred_ownM _); [apply and_elim_r|].
  apply and_elim_l.
  - simpl. Search or
Qed.*)

(** ** Allocation *)
(* TODO: This also holds if we just have ✓ a at the current step-idx, as Iris
   assertion. However, the map_updateP_alloc does not suffice to show this. *)
Lemma own_alloc_strong_dep (f : gname → A) (P : gname → Prop) :
  pred_infinite P →
  (∀ γ, P γ → ✓ (f γ)) →
  ⊢ |==> ∃ γ, ⌜P γ⌝ ∧ own γ (f γ).
Proof.
  intros HPinf Hf.
  rewrite -(bupd_mono (∃ m, ⌜∃ γ, P γ ∧ m = iRes_singleton γ (f γ)⌝ ∧ ouPred_ownM m)%I).
  - rewrite /bi_emp_valid ownM_unit.
    apply bupd_ownM_updateP, (discrete_fun_singleton_updateP_empty(B := (λ i : fin (gFunctors_len Σ), gmapUR gname (gFunctors_lookup Σ i (iPrePropO Σ) iPreProp_cofe)))
      _ (λ m : _, ∃ γ, m = {[ γ := inG_unfold (ora_transport inG_prf (f γ)) ]} ∧ P γ));
      [|naive_solver].
    apply (alloc_updateP_strong_dep _ P _ (λ γ,
      inG_unfold (ora_transport inG_prf (f γ)))); [done| |naive_solver].
    intros γ _ ?.
    by apply (cmra_morphism_valid inG_unfold), ora_transport_valid, Hf.
  - apply exist_elim=>m; apply pure_elim_l=>-[γ [Hfresh ->]].
    by rewrite !own_eq /own_def -(exist_intro γ) pure_True // left_id.
Qed.
Lemma own_alloc_cofinite_dep (f : gname → A) (G : gset gname) :
  (∀ γ, γ ∉ G → ✓ (f γ)) → ⊢ |==> ∃ γ, ⌜γ ∉ G⌝ ∧ own γ (f γ).
Proof.
  intros Ha.
  apply (own_alloc_strong_dep f (λ γ, γ ∉ G))=> //.
  apply (pred_infinite_set (C:=gset gname)).
  intros E. set (γ := fresh (G ∪ E)).
  exists γ. apply not_elem_of_union, is_fresh.
Qed.
Lemma own_alloc_dep (f : gname → A) :
  (∀ γ, ✓ (f γ)) → ⊢ |==> ∃ γ, own γ (f γ).
Proof.
  intros Ha. rewrite /bi_emp_valid (own_alloc_cofinite_dep f ∅) //; [].
  apply bupd_mono, exist_mono=>?. apply: and_elim_r.
Qed.

Lemma own_alloc_strong a (P : gname → Prop) :
  pred_infinite P →
  ✓ a → ⊢ |==> ∃ γ, ⌜P γ⌝ ∧ own γ a.
Proof. intros HP Ha. eapply (own_alloc_strong_dep (λ _, a)); eauto. Qed.
Lemma own_alloc_cofinite a (G : gset gname) :
  ✓ a → ⊢ |==> ∃ γ, ⌜γ ∉ G⌝ ∧ own γ a.
Proof. intros Ha. eapply (own_alloc_cofinite_dep (λ _, a)); eauto. Qed.
Lemma own_alloc a : ✓ a → ⊢ |==> ∃ γ, own γ a.
Proof. intros Ha. eapply (own_alloc_dep (λ _, a)); eauto. Qed.

(** ** Frame preserving updates *)
Lemma own_updateP P γ a : a ~~>: P → own γ a ==∗ ∃ a', ⌜P a'⌝ ∧ own γ a'.
Proof.
  intros Hupd. rewrite !own_eq.
  rewrite -(bupd_mono (∃ m,
    ⌜ ∃ a', m = iRes_singleton γ a' ∧ P a' ⌝ ∧ ouPred_ownM m)%I).
  - apply bupd_ownM_updateP, (discrete_fun_singleton_updateP(B := (λ i : fin (gFunctors_len Σ), gmapUR gname (gFunctors_lookup Σ i (iPrePropO Σ) iPreProp_cofe)))
       _ (λ m, ∃ x, m = {[ γ := x ]} ∧ ∃ x',
      x = inG_unfold x' ∧ ∃ a',
      x' = ora_transport inG_prf a' ∧ P a')); [|naive_solver].
    apply singleton_updateP', (iso_cmra_updateP' inG_fold).
    { apply inG_unfold_fold. }
    { apply (cmra_morphism_op _). }
    { apply inG_unfold_validN. }
    by apply ora_transport_updateP'.
  - apply exist_elim=> m; apply pure_elim_l=> -[a' [-> HP]].
    rewrite -(exist_intro a').
    by apply and_intro; [apply pure_intro|].
Qed.

Lemma own_update γ a a' : a ~~> a' → own γ a ==∗ own γ a'.
Proof.
  intros; rewrite (own_updateP (a' =.)); last by apply cmra_update_updateP.
  apply bupd_mono, exist_elim=> a''. apply pure_elim_l=> -> //.
Qed.
Lemma own_update_2 γ a1 a2 a' :
  a1 ⋅ a2 ~~> a' → own γ a1 -∗ own γ a2 ==∗ own γ a'.
Proof. intros. apply wand_intro_r. rewrite -own_op. by apply own_update. Qed.
Lemma own_update_3 γ a1 a2 a3 a' :
  a1 ⋅ a2 ⋅ a3 ~~> a' → own γ a1 -∗ own γ a2 -∗ own γ a3 ==∗ own γ a'.
Proof. intros. do 2 apply wand_intro_r. rewrite -!own_op. by apply own_update. Qed.
End global.

Global Arguments own_valid {_ _} [_] _ _.
Global Arguments own_valid_2 {_ _} [_] _ _ _.
Global Arguments own_valid_3 {_ _} [_] _ _ _ _.
Global Arguments own_valid_l {_ _} [_] _ _.
Global Arguments own_valid_r {_ _} [_] _ _.
Global Arguments own_updateP {_ _} [_] _ _ _ _.
Global Arguments own_update {_ _} [_] _ _ _ _.
Global Arguments own_update_2 {_ _} [_] _ _ _ _ _.
Global Arguments own_update_3 {_ _} [_] _ _ _ _ _ _.

Lemma own_unit A `{i : !inG Σ (A:uora)} γ : ⊢ |==> own γ (ε:A).
Proof.
  rewrite /bi_emp_valid ownM_unit !own_eq /own_def.
  apply bupd_ownM_update, (discrete_fun_singleton_update_empty(B := (λ i : fin (gFunctors_len Σ), gmapUR gname (gFunctors_lookup Σ i (iPrePropO Σ) iPreProp_cofe)))).
  apply (alloc_unit_singleton_update (inG_unfold (ora_transport inG_prf ε))).
  - apply (cmra_morphism_valid _), ora_transport_valid, ucmra_unit_valid.
  - intros x. rewrite -(inG_unfold_fold x) -(cmra_morphism_op inG_unfold).
    f_equiv. generalize (inG_fold x)=> x'.
    destruct inG_prf=> /=. by rewrite left_id.
  - done.
Qed.

(* Global Instance own_unit_affine A `{i : !inG Σ (A:uora)} γ : Affine (own γ (ε:A)).
Proof. apply _. Qed. *)

(** Big op class instances *)
Section big_op_instances.
  Context `{!inG Σ (A:uora)}.

  Global Instance own_cmra_sep_homomorphism γ :
    WeakMonoidHomomorphism op ouPred_sep (≡) (own γ).
  Proof. split; try apply _. apply own_op. Qed.

  Lemma big_opL_own {B} γ (f : nat → B → A) (l : list B) :
    l ≠ [] →
    own γ ([^op list] k↦x ∈ l, f k x) ⊣⊢ [∗ list] k↦x ∈ l, own γ (f k x).
  Proof. apply (big_opL_commute1 _). Qed.
  Lemma big_opM_own `{Countable K} {B} γ (g : K → B → A) (m : gmap K B) :
    m ≠ ∅ →
    own γ ([^op map] k↦x ∈ m, g k x) ⊣⊢ [∗ map] k↦x ∈ m, own γ (g k x).
  Proof. apply (big_opM_commute1 _). Qed.
  Lemma big_opS_own `{Countable B} γ (g : B → A) (X : gset B) :
    X ≠ ∅ →
    own γ ([^op set] x ∈ X, g x) ⊣⊢ [∗ set] x ∈ X, own γ (g x).
  Proof. apply (big_opS_commute1 _). Qed.
  Lemma big_opMS_own `{Countable B} γ (g : B → A) (X : gmultiset B) :
    X ≠ ∅ →
    own γ ([^op mset] x ∈ X, g x) ⊣⊢ [∗ mset] x ∈ X, own γ (g x).
  Proof. apply (big_opMS_commute1 _). Qed.

  Global Instance own_ora_sep_entails_homomorphism γ :
    MonoidHomomorphism op ouPred_sep (⊢) (own γ).
  Proof.
    split; [split|]; try apply _.
    - intros. by rewrite own_op.
    - apply (affine _).
  Qed.

  Lemma big_opL_own_1 {B} γ (f : nat → B → A) (l : list B) :
    own γ ([^op list] k↦x ∈ l, f k x) ⊢ [∗ list] k↦x ∈ l, own γ (f k x).
  Proof. apply (big_opL_commute _). Qed.
  Lemma big_opM_own_1 `{Countable K} {B} γ (g : K → B → A) (m : gmap K B) :
    own γ ([^op map] k↦x ∈ m, g k x) ⊢ [∗ map] k↦x ∈ m, own γ (g k x).
  Proof. apply (big_opM_commute _). Qed.
  Lemma big_opS_own_1 `{Countable B} γ (g : B → A) (X : gset B) :
    own γ ([^op set] x ∈ X, g x) ⊢ [∗ set] x ∈ X, own γ (g x).
  Proof. apply (big_opS_commute _). Qed.
  Lemma big_opMS_own_1 `{Countable B} γ (g : B → A) (X : gmultiset B) :
    own γ ([^op mset] x ∈ X, g x) ⊢ [∗ mset] x ∈ X, own γ (g x).
  Proof. apply (big_opMS_commute _). Qed.
End big_op_instances.

(** Proofmode class instances *)
Section proofmode_instances.
  Context `{!inG Σ A}.
  Implicit Types a b : A.

  Global Instance into_sep_own γ a b1 b2 :
    IsOp a b1 b2 → IntoSep (own γ a) (own γ b1) (own γ b2).
  Proof. intros. by rewrite /IntoSep (is_op a) own_op. Qed.
(*  Global Instance into_and_own p γ a b1 b2 :
    IsOp a b1 b2 → IntoAnd p (own γ a) (own γ b1) (own γ b2).
  Proof. intros. by rewrite /IntoAnd (is_op a) own_op sep_and. Qed. *)

  Global Instance from_sep_own γ a b1 b2 :
    IsOp a b1 b2 → FromSep (own γ a) (own γ b1) (own γ b2).
  Proof. intros. by rewrite /FromSep -own_op -is_op. Qed.
(*  (* TODO: Improve this instance with generic own simplification machinery
  once https://gitlab.mpi-sws.org/iris/iris/-/issues/460 is fixed *)
  Global Instance combine_sep_as_own γ a b1 b2 :
    IsOp a b1 b2 → CombineSepAs (own γ b1) (own γ b2) (own γ a).
  Proof. intros. by rewrite /CombineSepAs -own_op -is_op. Qed.
  (* TODO: Improve this instance with generic own validity simplification
  machinery once https://gitlab.mpi-sws.org/iris/iris/-/issues/460 is fixed *)
  Global Instance combine_sep_gives_own γ b1 b2 :
    CombineSepGives (own γ b1) (own γ b2) (✓ (b1 ⋅ b2)).
  Proof.
    intros. rewrite /CombineSepGives -own_op own_valid.
    by apply: bi.persistently_intro.
  Qed.*)
(*  Global Instance from_and_own_persistent γ a b1 b2 :
    IsOp a b1 b2 → TCOr (OraCoreId b1) (OraCoreId b2) →
    FromAnd (own γ a) (own γ b1) (own γ b2).
  Proof.
    intros ? Hb. rewrite /FromAnd (is_op a) own_op.
    destruct Hb; by rewrite persistent_and_sep.
  Qed.*)
End proofmode_instances.


Require Import Platform.Cito.CompileStmtSpec.
Require Import Bedrock.StringSet.
Require Import Platform.Cito.FreeVars.
Require Import Platform.Cito.SynReqFactsUtil.

Local Infix ";;" := Syntax.Seq (right associativity, at level 95).

Require Platform.Cito.CompileExpr.

Lemma syn_req_Assign_e : forall vars temp_size x e k, syn_req vars temp_size (Syntax.Assign x e ;; k) -> CompileExpr.syn_req vars temp_size e 0.
  unfold syn_req, CompileExpr.syn_req, in_scope; simpl; intuition.
  apply Subset_union_left in H; intuition.
  apply Subset_union_left in H0; intuition.
  eauto using Max.max_lub_l.
Qed.


Require Import
  HoTT.Types.Universe
  HoTT.Basics.Decidable
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.integers
  HoTT.Classes.interfaces.naturals
  HoTT.Classes.interfaces.rationals
  HoTT.Classes.interfaces.orders
  HoTT.Classes.implementations.natpair_integers
  HoTT.Classes.theory.rings
  HoTT.Classes.theory.integers
  HoTT.Classes.theory.dec_fields
  HoTT.Classes.orders.dec_fields
  HoTT.Classes.theory.rationals
  HoTT.Classes.orders.lattices
  HoTT.Classes.theory.additional_operations
  HoTT.Classes.theory.premetric
  HoTT.Classes.implementations.assume_rationals
  HoTTClasses.cauchy_completion.

Require Export
  HoTTClasses.cauchy_reals.base
  HoTTClasses.cauchy_reals.abs
  HoTTClasses.cauchy_reals.order.

Local Set Universe Minimization ToSet.

Lemma equiv_0_metric' : forall e u, close e u 0 -> abs u < rat (' e).
Proof.
intros e u;revert u e;apply (C_ind0 _ (fun u => forall e, _ -> _)).
- intros q e E.
  rewrite (equiv_eta_eta_def _) in E. apply Qclose_alt in E.
  rewrite negate_0,plus_0_r in E.
  apply rat_lt_preserving. trivial.
- intros x IH e xi.
  apply rounded in xi. revert xi.
  apply (Trunc_ind _);intros [d [d' [He xi]]].
  rewrite (equiv_lim_eta_def _) in xi.
  revert xi;apply (Trunc_ind _);intros [n [n' [Hd E1]]].
  apply IH in E1.
  rewrite He,Hd.
  assert (Hrw : (' (n + n' + d')) = ' n' + ' (n + d'))
  by ring_tac.ring_with_nat.
  rewrite Hrw;clear Hrw.
  apply (Rlt_close_rat_plus _ _ E1).
  apply (non_expanding abs).
  rewrite qpos_plus_comm. apply (equiv_lim _).
Qed.

Definition equiv_0_metric@{}
  := equiv_0_metric'@{UQ UQ}.

Lemma equiv_to_metric@{} : forall e u v, close e u v -> abs (u - v) < rat (' e).
Proof.
intros e u v xi.
rewrite <-Rabs_idempotent.
apply equiv_0_metric.
rewrite <-(Rabs_of_0' (v - v));[|apply right_inverse].
apply (non_expanding (fun w => abs (w - v))). trivial.
Qed.

Lemma metric_to_equiv_rat_lim@{} (q : Q)
  (y : Approximation real)
  (IHy : forall e e0 : Q+, abs (rat q - y e) < rat (' e0) -> close e0 (rat q) (y e))
  (e : Q+)
  (E1 : abs (rat q - lim y) < rat (' e))
  : close e (rat q) (lim y).
Proof.
generalize (R_archimedean _ _ E1). apply (Trunc_ind _);intros [d [E2 E3]].
apply rat_lt_reflecting in E3.
pose proof (snd (flip_pos_minus _ _) E3) as E4.
assert (Hd : 0 < d).
{ revert E2;apply (Trunc_ind _).
  intros [s [s' [F1 [F2 F3]]]].
  apply rat_le_reflecting in F3.
  apply lt_le_trans with s';trivial.
  apply le_lt_trans with s;trivial.
  apply rat_le_reflecting.
  transitivity (abs (rat q - lim y));trivial.
  apply Rabs_nonneg.
}
pose (D := mkQpos d Hd).
pose (ED := mkQpos _ E4).
assert (Hrw : e = D + (ED / 4 + ED / 4) + (ED / 4 + ED / 4)).
{ path_via (D + ED).
  { apply pos_eq;unfold D, ED.
    abstract ring_tac.ring_with_integers (NatPair.Z nat).
  }
  path_via (D + 4 / 4 * ED).
  { rewrite pos_recip_r,Qpos_mult_1_l;trivial. }
  apply pos_eq;abstract ring_tac.ring_with_nat.
}
rewrite Hrw.
eapply (equiv_triangle _);[|apply (equiv_lim _)].
apply IHy. apply (Rlt_close_rat_plus _ _ E2).
apply (non_expanding (fun u => abs (rat q - u))).
apply (equiv_symm _),(equiv_lim _).
Qed.

Lemma metric_to_equiv_lim_lim@{} (x : Approximation real)
  (IHx : forall (e : Q+) (v : real) (e0 : Q+),
        abs (x e - v) < rat (' e0) -> close e0 (x e) v)
  (y : Approximation real)
  (IHy : forall e e0 : Q+, abs (lim x - y e) < rat (' e0) -> close e0 (lim x) (y e))
  (e : Q+)
  (E1 : abs (lim x - lim y) < rat (' e))
  : close e (lim x) (lim y).
Proof.
generalize (R_archimedean _ _ E1). apply (Trunc_ind _);intros [d [E2 E3]].
apply rat_lt_reflecting in E3.
pose proof (snd (flip_pos_minus _ _) E3) as E4.
assert (Hd : 0 < d).
{ revert E2;apply (Trunc_ind _).
  intros [s [s' [F1 [F2 F3]]]].
  apply rat_le_reflecting in F3.
  apply lt_le_trans with s';trivial.
  apply le_lt_trans with s;trivial.
  apply rat_le_reflecting.
  transitivity (abs (lim x - lim y));trivial.
  apply Rabs_nonneg.
}
pose (D := mkQpos d Hd).
pose (ED := mkQpos _ E4).
assert (Hrw : e = D + (ED / 4 + ED / 4) + (ED / 4 + ED / 4)).
{ path_via (D + ED).
  { apply pos_eq;unfold D, ED.
    abstract ring_tac.ring_with_integers (NatPair.Z nat).
  }
  path_via (D + 4 / 4 * ED).
  { rewrite pos_recip_r,Qpos_mult_1_l;trivial. }
  apply pos_eq;abstract ring_tac.ring_with_nat.
}
rewrite Hrw.
eapply (equiv_triangle _);[|apply (equiv_lim _)].
apply IHy. apply (Rlt_close_rat_plus _ _ E2).
apply (non_expanding (fun u => abs (lim x - u))).
apply (equiv_symm _),(equiv_lim _).
Qed.

Lemma metric_to_equiv@{} : forall e u v, abs (u - v) < rat (' e) -> close e u v.
Proof.
intros e u v;revert u v e;apply (C_ind0 _ (fun u => forall v e, _ -> _));
[intros q|intros x IHx];
(apply (C_ind0 _ (fun v => forall e, _ -> _));[intros r|intros y IHy]);
intros e E1.
- apply equiv_eta_eta. apply Qclose_alt.
  apply rat_lt_reflecting,E1.
- apply metric_to_equiv_rat_lim;auto.
- apply (equiv_symm _),metric_to_equiv_rat_lim.
  + intros n n' E;apply (equiv_symm _),IHx.
    rewrite Rabs_neg_flip. trivial.
  + rewrite Rabs_neg_flip. trivial.
- apply metric_to_equiv_lim_lim;auto.
Qed.

Lemma equiv_metric_applied_rw'
  : forall e u v, close e u v = (abs (u - v) < rat (' e)).
Proof.
intros. apply TruncType.path_iff_ishprop_uncurried.
split.
- apply equiv_to_metric.
- apply metric_to_equiv.
Qed.

Definition equiv_metric_applied_rw@{} := equiv_metric_applied_rw'@{Ularge}.

Lemma equiv_metric_rw' : close = fun e u v => abs (u - v) < rat (' e).
Proof.
repeat (apply path_forall;intro).
apply equiv_metric_applied_rw.
Qed.

Definition equiv_metric_rw@{} := equiv_metric_rw'.


(* Open Source License *)
(* Copyright (c) 2019 Nomadic Labs. <contact@nomadic-labs.com> *)

(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"), *)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)

(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)

(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)

(* Signed 64-bits integers: these are used to represent Tez amounts *)

Require Import Bvector.
Require Import ZArith.
Require Import Zdigits.

Definition int64 := Bvector 64.

Definition sign : int64 -> bool := Bsign 63.

Definition to_Z : int64 -> Z := two_compl_value 63.

Definition of_Z : Z -> int64 := Z_to_two_compl 63.

Definition int64_inversion (b : int64) : exists a v, b = Bcons a 63 v :=
  match b in Vector.t _ (S _) return exists a v, b = Bcons a _ v with
  | Vector.cons _ a _ v => ex_intro _ a (ex_intro _ v eq_refl)
  end.

Lemma of_Z_to_Z b : of_Z (to_Z b) = b.
Proof.
  destruct (int64_inversion b) as (a, (v, H)).
  rewrite H.
  apply two_compl_to_Z_to_two_compl.
Qed.

Definition compare (a b : int64) : comparison :=
  Z.compare (to_Z a) (to_Z b).

(* To avoid a name clash in OCaml extracted code. *)
Definition int64_compare (a b : int64) : comparison := compare a b.

Lemma compare_eq_iff (a b : int64) : compare a b = Eq <-> a = b.
Proof.
  unfold compare.
  rewrite Z.compare_eq_iff.
  split.
  - intro H.
    apply (f_equal of_Z) in H.
    rewrite of_Z_to_Z in H.
    rewrite of_Z_to_Z in H.
    assumption.
  - apply f_equal.
Qed.


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

(**********************************************************************)
(*                   Fieska_Tactics.v                                 *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith Omega Max Bool List.
Require Import IntensionalLib.Fieska_calculus.Test.
Require Import IntensionalLib.Fieska_calculus.General.
Require Import IntensionalLib.Fieska_calculus.Fieska_Terms.

Definition termred := Fieska -> Fieska -> Prop.

Definition preserve (R : termred) (P : Fieska -> Prop) :=
  forall x : Fieska, P x -> forall y : Fieska, R x y -> P y.

Inductive multi_step : termred -> termred :=
  | zero_red : forall red M, multi_step red M M
  | succ_red : forall (red: Fieska-> Fieska -> Prop) M N P,
                   red M N -> multi_step red N P -> multi_step red M P
.

Inductive sequential : termred -> termred -> termred :=
  | seq_red : forall (red1 red2 : termred) M N P,
                red1 M N -> red2 N P -> sequential red1 red2 M P.

Hint Resolve zero_red succ_red seq_red
.

Definition reflective red := forall (M: Fieska), red M M.

Lemma refl_multi_step : forall (red: termred), reflective (multi_step red).
Proof. red; split_all. Qed.

Lemma refl_seq : forall (red1 red2: termred),
                   reflective red1 -> reflective red2 -> reflective(sequential red1 red2).
Proof. red; split_all; eapply2 seq_red. Qed.

Ltac reflect := match goal with
| |- reflective (multi_step _) => eapply2 refl_multi_step
| |- multi_step _ _ _ => try (eapply2 refl_multi_step)
| |- reflective (sequential _) => eapply2 refl_seq; reflect
| |- sequential _ _ _ _ => try (eapply2 refl_seq)
| _ => split_all
end.

Ltac one_step :=
match goal with
| |- multi_step _ _ ?N => apply succ_red with N; auto; try red; try reflect
end.

Ltac seq_l :=
match goal with
| |- sequential _ _ ?M ?N => apply seq_red with N; auto; red; reflect
end.

Ltac seq_r :=
match goal with
| |- sequential _ _ ?M ?N => apply seq_red with M; auto; red; reflect
end.

Definition transitive red := forall (M N P: Fieska), red M N -> red N P -> red M P.

Lemma transitive_red : forall red, transitive (multi_step red).
Proof. red; induction 1; split_all.
apply succ_red with N; auto.
Qed.

Definition preserves_app (red : termred) :=
forall M M' N N', red M M' -> red N N' -> red (App M N) (App M' N').

Lemma preserves_app_multi_step : forall (red: termred), reflective red -> preserves_app red -> preserves_app (multi_step red).
Proof.
red. induction 3; split_all. generalize H0; induction 1.
reflect.
apply succ_red with (App M N); auto.
assert( transitive (multi_step red)) by eapply2 transitive_red.
apply X0 with (App N0 N); auto.
one_step.
Qed.

Lemma preserves_app_seq : forall (red1 red2: termred), preserves_app red1 -> preserves_app red2 -> preserves_app (sequential red1 red2).
Proof.
red; split_all.
inversion H1; inversion H2.
apply seq_red with (App N0 N1); auto.
Qed.

Hint Resolve preserves_app_multi_step preserves_app_seq .

Ltac inv1 prop :=
match goal with
| H: prop _ |- _ => inversion H; clear H; inv1 prop
| H: prop (App  _ _) |- _ => inversion H; clear H; inv1 prop
| H: prop Op _ |- _ => inversion H; clear H; inv1 prop
| _ => split_all
 end.

Definition implies_red (red1 red2: termred) := forall M N, red1 M N -> red2 M N.

Lemma implies_red_multi_step: forall red1 red2, implies_red red1  (multi_step red2) ->
                                                implies_red (multi_step red1) (multi_step red2).
Proof. red.
intros red1 red2 IR M N R; induction R; split_all.
apply transitive_red with N; auto.
Qed.
Lemma implies_red_seq:
 forall red1 red2 red3,
  implies_red red1  (multi_step red3)  ->
  implies_red red2 (multi_step red3) ->
  implies_red (sequential red1 red2) (multi_step red3) .
Proof.
red; split_all. inversion H1. apply transitive_red with N0; auto.
Qed.

Ltac inv red :=
match goal with
| H: multi_step red (App _ _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red (Ref _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red (Op _) _ |- _ => inversion H; clear H; inv red
| H: red (Ref _) _ |- _ => inversion H; clear H; inv red
| H: red (App _ _) _ |- _ => inversion H; clear H; inv red
| H: red (Op _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red _ (Ref _) |- _ => inversion H; clear H; inv red
| H: multi_step red _ (App _ _) |- _ => inversion H; clear H; inv red
| H: multi_step red _ (Op _) |- _ => inversion H; clear H; inv red
| H: red _ (Ref _) |- _ => inversion H; clear H; inv red
| H: red _ (App _ _) |- _ => inversion H; clear H; inv red
| H: red _ (Op _) |- _ => inversion H; clear H; inv red
| _ => subst; split_all
 end.

Definition diamond (red1 red2 : termred) :=
forall M N, red1 M N -> forall P, red2 M P -> exists Q, red2 N Q /\ red1 P Q.

Lemma diamond_flip: forall red1 red2, diamond red1 red2 -> diamond red2 red1.
Proof. unfold diamond; split_all. elim (H M P H1 N H0); split_all. inversion H2; exist x. Qed.

Lemma diamond_strip :
forall red1 red2, diamond red1 red2 -> diamond red1 (multi_step red2).
Proof. intros.
eapply2 diamond_flip.
red; induction 1; split_all.
exist P.
elim (H M P0 H2 N); split_all.
elim(IHmulti_step H x); split_all.
inversion H3; inversion H4; exist x0; split; auto.
apply succ_red with x; auto.
tauto.
Qed.

Definition diamond_star (red1 red2: termred) := forall  M N, red1 M N -> forall P, red2 M P ->
  exists Q, red1 P Q /\ multi_step red2 N Q.

Lemma diamond_star_strip: forall red1 red2, diamond_star red1 red2 -> diamond (multi_step red2) red1 .
Proof.
red. induction 2; split_all.
exist P.
elim(H M P0 H2 N H0); split_all.
elim(IHmulti_step H x); split_all.
inversion H3; inversion H4; exist x0; split; auto.
apply transitive_red with x; auto.
tauto.
Qed.

Lemma diamond_tiling :
forall red1 red2, diamond red1 red2 -> diamond (multi_step red1) (multi_step red2).
Proof.
red.  induction 2; split_all.
exist P.
elim(diamond_strip red red2 H M N H0 P0); split_all.
inversion H3.
elim(IHmulti_step H x H4); split_all.
inversion H6. exist x0. split; auto.
apply succ_red with x; auto.
Qed.

Hint Resolve diamond_tiling.

Lemma diamond_seq: forall red red1 red2, diamond red red1 -> diamond red red2 -> diamond red (sequential red1 red2).
Proof. unfold diamond; split_all.
inversion H2.
elim(H M N H1 N0); split_all.
inversion H9.
 elim(H0 N0 x H11 P); split_all.
inversion H12.
exist x0.
split. apply seq_red with x; auto. auto.
Qed.

Fixpoint rank (M: Fieska) :=
match M with
| Ref _ => 1
| Op _ => 1
| App M1 M2 => S((rank M1) + (rank M2))
end.

Lemma rank_positive: forall M, rank M > 0.
Proof.
induction M; split_all; try omega.
Qed.

(*

Ltac rank_tac := match goal with
| |- forall M, ?P  =>
  cut (forall p M, p >= rank M -> P )
; [ intros H M;  eapply2 H |
intro p; induction p; intro M;  [ assert(rank M >0) by eapply2 rank_positive; noway |]
]
end .

*)


From CoindSemWhile Require Import SsrExport Trace Language.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* big-step relational semantics *)
CoInductive exec: stmt -> state -> trace -> Prop :=
| exec_skip: forall st,
    exec Sskip st (Tnil st)
| exec_assign: forall id a st,
    exec (Sassign id a) st (Tcons st (Tnil (update id (a st) st)))
| exec_seq: forall s1 s2 st tr tr',
    exec s1 st tr ->
    execseq s2 tr tr' ->
    exec (Sseq s1 s2) st tr'
| exec_ifthenelse_true: forall a s1 s2 st tr,
    is_true (a st) = true ->
    execseq s1 (Tcons st (Tnil st)) tr ->
    exec (Sifthenelse a s1 s2) st tr
| exec_ifthenelse_false: forall a s1 s2 st tr,
    is_true (a st) = false ->
    execseq s2 (Tcons st (Tnil st)) tr ->
    exec (Sifthenelse a s1 s2) st tr
| exec_while_false: forall a s st,
    is_true (a st) = false ->
    exec (Swhile a s) st (Tcons st (Tnil st))
| exec_while_loop: forall a s st tr tr',
    is_true (a st) = true ->
    execseq s (Tcons st (Tnil st)) tr ->
    execseq (Swhile a s) tr tr' ->
    exec (Swhile a s) st tr'

with execseq: stmt -> trace -> trace -> Prop :=
| execseq_nil: forall st s tr,
  exec s st tr ->
  execseq s (Tnil st) tr
| execseq_cons: forall tr s tr' e,
  execseq s tr tr' ->
  execseq s (Tcons e tr) (Tcons e tr').

Lemma exec_nil: forall s st st',
exec s st (Tnil st') -> st = st'.
Proof.
move => s; induction s.
- move => st0 st1  h1. by inversion h1.
- move => st0 st1 h1. by inversion h1.
- move => st0 st1 h1. foo h1. foo H4.
  move: (IHs1 _ _ H1) => h; subst.
  move: (IHs2 _ _ H) => h; subst. done.
- move => st0 st1 h1. foo h1.  foo H5. foo H5.
- move => st0 st1 h1. foo h1. foo H2. foo H5.
Qed.

Lemma execseq_deterministic0: forall s,
(forall st tr1 tr2, exec s st tr1 -> exec s st tr2 -> bisim tr1 tr2) ->
forall tr1 tr2 tr3 tr4,
bisim tr1 tr2 -> execseq s tr1 tr3 -> execseq s tr2 tr4 -> bisim tr3 tr4.
Proof.
move => s hexec. cofix COINDHYP.
move => tr1 tr2 tr3 tr4 h1 h2 h3. foo h2.
- foo h3.
  - foo h1. have := hexec _ _ _ H H0; apply.
  - by inversion h1.
- foo h3.
  - by inversion h1.
  - foo h1. have := bisim_cons _ (COINDHYP _ _ _ _ H2 H H0); apply.
Qed.

Lemma exec_seq_deterministic0: forall s1 s2,
(forall st tr1 tr2, exec s1 st tr1 -> exec s1 st tr2 -> bisim tr1 tr2) ->
(forall st tr1 tr2, exec s2 st tr1 -> exec s2 st tr2 -> bisim tr1 tr2) ->
forall st tr1 tr2, exec (Sseq s1 s2) st tr1 ->
exec (Sseq s1 s2) st tr2 ->
bisim tr1 tr2.
Proof.
move => s1 s2 hexec1 hexec2 st tr1 tr2 h1 h2.
foo h1. foo h2. have h3 := hexec1 _ _ _ H1 H2.
by apply: (execseq_deterministic0 hexec2 h3 H4 H6).
Qed.

Lemma exec_while_deterministic0: forall a s,
(forall st tr1 tr2, exec s st tr1 -> exec s st tr2 -> bisim tr1 tr2) ->
forall st tr1 tr2, exec (Swhile a s) st  tr1 ->
exec (Swhile a s) st tr2 ->
bisim tr1 tr2.
Proof.
move => a s hwhile.  cofix COINDHYP.
have COINDHYP2: forall tr1 tr2 tr3 tr4, bisim tr1 tr2 ->
execseq (Swhile a s) tr1 tr3 -> execseq (Swhile a s) tr2 tr4 ->
bisim tr3 tr4.
* cofix COINDHYP2. move => tr1 tr2 tr3 tr4 h1 h2 h3. foo h2.
  - foo h3.
    - foo h1. foo H0.
      - foo H.
        - by apply bisim_reflexive.
        - rewrite H2 in H5. by inversion H5.
      - foo H.
        - rewrite H6 in H3. by inversion H3.
        - move => {H3 H2}. foo H5. foo H3. foo H4. foo H5. foo H7. foo H9.
          by apply: (bisim_cons _ (COINDHYP2 _ _ _ _ (hwhile _ _ _ H1 H2) H6 H5)).
    - by inversion h1.
  - foo h3.
    - by inversion h1.
    - foo h1. by apply: (bisim_cons _ (COINDHYP2 _ _ _ _ H2 H H0)).
* move =>  st tr1 tr2 h1 h2. foo h1.
  - foo h2.
    -  by apply bisim_reflexive.
    - rewrite H3 in H1. by inversion H1.
  - foo h2.
    - rewrite H1 in H6. by inversion H6.
    - foo H2. foo H9. foo H4. foo H9. foo H5. foo H8.
    have h3 := hwhile _ _ _ H2 H4.
    by have := bisim_cons _ (COINDHYP2 _ _ _ _ h3 H9 H7); apply.
Qed.

(* determinism *)
Lemma exec_deterministic: forall s st,
forall tr1 tr2, exec s st tr1 ->
exec s st tr2 -> bisim tr1 tr2.
Proof.
move => s; induction s.
- move => st tr1 tr2 h1 h2. foo h1. foo h2. by apply bisim_nil.
- move => st tr1 tr2 h1 h2. foo h1. foo h2. by apply bisim_reflexive.
- move => st tr1 tr2 h1 h2. by apply: (exec_seq_deterministic0 IHs1 IHs2 h1 h2).
- move => st tr1 tr2 h1 h2. foo h1.
  - foo h2.
    - foo H5. foo H3. foo H7. foo H5. apply bisim_cons. apply: (IHs1 _ _ _ H1 H2).
    - rewrite H4 in H6. by inversion H6.
  - foo h2.
    - rewrite H4 in H6. by inversion H6.
    - foo H5. foo H3. foo H7. foo H4. foo H5. apply: (bisim_cons _ (IHs2 _ _ _ H1 H3)).
- move => st tr1 tr2 h1 h2. apply: (exec_while_deterministic0 IHs h1 h2).
Qed.

Lemma execseq_insensitive0: forall s,
(forall st tr1 tr2, exec s st tr1 -> bisim tr1 tr2 -> exec s st tr2) ->
forall tr1 tr2 tr3 tr4,
bisim tr1 tr2 ->
execseq s tr1 tr3 -> bisim tr3 tr4 -> execseq s tr2 tr4.
Proof.
move => s hexec0. cofix COINDHYP.
move => tr1 tr2 tr3 tr4 h1 h2 h3. foo h2. foo h1.
  by apply (execseq_nil (hexec0 _ _ _ H h3)).
- foo h3. foo h1. by apply: (execseq_cons _ (COINDHYP _ _ _ _ H4 H H3)).
Qed.

Lemma exec_seq_insensitive0: forall s1 s2,
(forall st tr1 tr2, exec s1 st tr1 -> bisim tr1 tr2 -> exec s1 st tr2) ->
(forall st tr1 tr2, exec s2 st tr1 -> bisim tr1 tr2 -> exec s2 st tr2) ->
forall st tr1 tr2, exec (Sseq s1 s2) st tr1 ->
bisim tr1 tr2 ->
exec (Sseq s1 s2) st tr2.
Proof.
move => s1 s2 hs1 hs2 st tr1 tr2 h1 h2. foo h1.
apply: (exec_seq H1). foo H4.
- by apply (execseq_nil (hs2 _ _ _ H h2)).
- foo h2. apply execseq_cons. have h2 := bisim_reflexive tr0.
  by apply: (execseq_insensitive0 hs2 h2 H H4).
Qed.

Lemma exec_while_insensitive0: forall a s,
(forall st tr1 tr2, exec s st tr1 -> bisim tr1 tr2 -> exec s st tr2) ->
forall st tr1 tr2, exec (Swhile a s) st tr1 ->
bisim tr1 tr2 ->
exec (Swhile a s) st tr2.
Proof.
move => a s hwhile.  cofix COINDHYP.
have COINDHYP2: forall tr1 tr2 tr3 tr4, bisim tr1 tr2 ->
execseq (Swhile a s) tr1 tr3 -> bisim tr3 tr4 ->
execseq (Swhile a s) tr2 tr4.
* cofix COINDHYP2. move => tr1 tr2 tr3 tr4 h1 h2 h3. foo h2.
  - foo h1. by apply: (execseq_nil (COINDHYP _ _ _ H h3)).
  - foo h1. foo h3. by apply: (execseq_cons _ (COINDHYP2 _ _ _ _ H3 H H4)).
- move => st tr1 tr2 h1 h2. foo h1.
  - foo h2. foo H2. by apply: (exec_while_false _ H3).
  - foo H2. foo H6. foo H5. foo h2.
    apply: (exec_while_loop H1 (execseq_cons _ (execseq_nil H2))).
    by apply: (execseq_cons _ (COINDHYP2 _ _ _ _ (bisim_reflexive tr') H6 H4)).
Qed.

(* setoid *)
Lemma exec_insensitive: forall s st tr tr',
exec s st tr -> bisim tr tr' -> exec s st tr'.
Proof.
move => s; induction s.
- move => st tr tr' h1 h2. foo h1. foo h2. by apply exec_skip.
- move => st tr tr' h1 h2. foo h1. foo h2. foo H2. by apply exec_assign.
- move => st tr tr' h1 h2. apply: (exec_seq_insensitive0 IHs1 IHs2 h1 h2).
- move => st tr tr' h1 h2. foo h1.
  - foo H5. foo H3. foo h2. apply: (exec_ifthenelse_true _ H4).
    apply execseq_cons. apply execseq_nil. by apply: (IHs1 _ _ _ H1 H3).
  - foo H5. foo H3. foo h2. apply: (exec_ifthenelse_false _ H4).
    apply execseq_cons. apply execseq_nil. by apply: (IHs2 _ _ _ H1 H3).
- move => st tr tr7 h1 h2. by apply: (exec_while_insensitive0 IHs h1 h2).
Qed.

Lemma execseq_insensitive_pre: forall s tr1 tr2 tr3,
bisim tr1 tr2 -> execseq s tr1 tr3 -> execseq s tr2 tr3.
Proof.
cofix COINDHYP. move => s tr1 tr2 tr3 h1 h2. foo h2; foo h1.
- by apply: (execseq_nil H).
- apply: execseq_cons. by apply: (COINDHYP _ _ _ _ H3 H).
Qed.

Lemma exec_hd: forall s st tr,
exec s st tr -> hd tr = st.
Proof.
move => s; induction s.
- move => st tr h1. foo h1. by simpl.
- move => st tr h1. foo h1. by simpl.
- move => st tr h1. foo h1. have h1 := IHs1 _ _ H1. foo H4.
  - simpl. have := IHs2 _ _ H; apply.
  - by simpl.
- move => st tr h1. foo h1.
  - foo H5. by simpl.
  - foo H5. by simpl.
- move => st tr h1. foo h1.
  - by simpl.
  - foo H2. foo H6. foo H5. by simpl.
Qed.

Lemma execseq_hd: forall s tr tr',
execseq s tr tr' -> hd tr' = hd tr.
Proof.
move => s tr tr' h1. foo h1.
- simpl. have := exec_hd H; apply.
- by simpl.
Qed.


  (* on part d'un CTS confluent, avec un algo de whnf, ... *)

  Record subtype_dec_CTS : Set :=
    {scts_cr : church_rosser red_step;
     scts_hn_sort : forall (e : env) (s : sort), head_normal hdr e (Srt s);
     scts_hn_prod :
      forall (e : env) (A B : term), head_normal hdr e (Prod A B);
     scts_whnf :
      forall (e : env) (t : term),
      sn red_step e t -> {u : term | red hdr e t u &  head_normal hdr e u};
     scts_convert_hn :
      forall (e : env) (x y : term),
      sn red_step e x ->
      sn red_step e y -> decide (conv_hn_inv hd_rule e x y);
     scts_rt_univ_dec : forall s s' : sort, decide (rt_univ s s')}.

  Variable the_scts : subtype_dec_CTS.

  (* open it *)
  Let CR : church_rosser red_step := scts_cr the_scts.
  Let shn_sort := scts_hn_sort the_scts.
  Let shn_prod := scts_hn_prod the_scts.
  Let whnf :
    forall (e : env) (t : term),
    sn red_step e t -> {u : term | red hdr e t u &  head_normal hdr e u} :=
    scts_whnf the_scts.
  Let conv_hn_dec :
    forall (e : env) (x y : term),
    sn red_step e x -> sn red_step e y -> decide (conv_hn_inv hd_rule e x y) :=
    scts_convert_hn the_scts.
  Let rt_univ_dec : forall s s' : sort, decide (rt_univ s s') :=
    scts_rt_univ_dec the_scts.

  Hint Resolve shn_sort shn_prod: pts.

  Let inv_cumul_hn := equiv_inv_cumul_hn CR shn_sort shn_prod.

  Let f (tr : env * (term * term)) :=
    match tr with
    | (e, (t1, t2)) => (e, t1, (e, t2))
    end.

  Theorem CR_WHNF_inv_cumul_dec :
   forall (e : env) (x y : term),
   sn red_step e x -> sn red_step e y -> decide (cumul_hn_inv e x y).
intros e x y sn0 sn1.
generalize sn0 sn1.
pattern e, x, y in |- *.
apply
 Acc3_rec
  with (R := fun x y : env * (term * term) => ord_conv hdr (f x) (f y)).
unfold f in |- *.
clear sn0 sn1 e x y.
intros e u v.
case u.
case v; intros.
elim rt_univ_dec with s0 s; intros.
left.
auto with pts.

right; red in |- *; intros.
apply b.
inversion_clear H0; auto with pts.

right; red in |- *; intros.
inversion_clear H0.

right; red in |- *; intros.
inversion_clear H0.

right; red in |- *; intros.
inversion_clear H0.

right; red in |- *; intros.
inversion_clear H0.

intros.
elim conv_hn_dec with e (Ref n) v; intros; auto with pts.
left.
inversion_clear a; auto with pts.

right; red in |- *; intros.
apply b.
inversion_clear H0; auto with pts.

intros.
elim conv_hn_dec with e (Abs t t0) v; intros; auto with pts.
left.
inversion_clear a; auto with pts.

right; red in |- *; intros.
apply b.
inversion_clear H0; auto with pts.

intros.
elim conv_hn_dec with e (App t t0) v; intros; auto with pts.
left.
inversion_clear a; auto with pts.

right; red in |- *; intros.
apply b.
inversion_clear H0; auto with pts.

intros A B.
case v; intros.
right; red in |- *; intros.
inversion_clear H0.

right; red in |- *; intros.
inversion_clear H0.

right; red in |- *; intros.
inversion_clear H0.

right; red in |- *; intros.
inversion_clear H0.

cut (sn (ctxt hdr) e A).
cut (sn (ctxt hdr) e t).
intros sn2 sn3.
elim whnf with e A; intros; auto with pts.
elim whnf with e t; intros; auto with pts.
elim H with e x0 x; intros.
cut (rt_cumul e t A).
intros cv.
cut (sn (ctxt hdr) (Ax t :: e) B).
cut (sn (ctxt hdr) (Ax t :: e) t0).
intros sn4 sn5.
elim whnf with (Ax t :: e) B; intros; auto with pts.
elim whnf with (Ax t :: e) t0; intros; auto with pts.
elim H with (Ax t :: e) x1 x2; intros.
left.
apply cuhi_prod; auto with pts.
red in |- *; red in |- *.
apply rt_trans with x1; auto with pts.
apply rt_trans with x2; auto with pts.
change (rt_cumul (Ax t :: e) x1 x2) in |- *.
auto with pts.

right; red in |- *; intros.
apply b.
inversion_clear H0.
apply inv_cumul_hn with B t0; auto with pts.

apply ord_cv_no_swap with B t0; auto with pts.

apply sn_red_sn with B; auto with pts.

apply sn_red_sn with t0; auto with pts.

apply subterm_sn with e (Prod t t0); auto with pts.

apply subterm_sn with e (Prod A B); auto with pts.

apply cumul_trans with x0; auto 10 with pts.
apply cumul_trans with x; auto 10 with pts.

right; red in |- *; intros.
inversion_clear H0.
apply b.
apply inv_cumul_hn with t A; auto with pts.

apply ord_cv_swap with t A; auto with pts.

apply sn_red_sn with t; auto with pts.

apply sn_red_sn with A; auto with pts.

apply subterm_sn with e (Prod t t0); auto with pts.

apply subterm_sn with e (Prod A B); auto with pts.

apply Acc_Acc3.
apply (Acc_inverse_image (env * (term * term)) (value * value)).
simpl in |- *.
apply sn_acc_ord_conv; trivial with pts.
Qed.

  Theorem CR_WHNF_cumul_dec :
   forall (e : env) (x y : term),
   sn red_step e x -> sn red_step e y -> decide (rt_cumul e x y).
intros.
elim whnf with e x; intros; auto with pts.
elim whnf with e y; intros; auto with pts.
elim CR_WHNF_inv_cumul_dec with e x0 x1; intros.
left.
apply cumul_trans with x0; auto 10 with pts.
apply cumul_trans with x1; auto 10 with pts.

right; red in |- *; intros.
apply b.
apply inv_cumul_hn with x y; auto with pts.

apply sn_red_sn with x; auto with pts.

apply sn_red_sn with y; auto with pts.
Qed.

  Lemma cumul_inv_prod : product_inversion rt_cumul.
cut
 (forall (e : env) (A B C D : term),
  rt_cumul e (Prod A B) (Prod C D) ->
  rt_cumul e C A /\ rt_cumul (Ax C :: e) B D).
split; intros.
elim H with e A B C D; auto with pts.

elim H with e A B C D; auto with pts.

intros.
cut (cumul_hn_inv e (Prod A B) (Prod C D)); intros.
inversion_clear H0; auto with pts.

apply inv_cumul_hn with (Prod A B) (Prod C D); auto with pts.
Qed.


From sflib Require Import sflib.
From Paco Require Import paco.
From ITree Require Import ITree.
From Fairness Require Import
  ITreeLib WFLib Axioms pind PCM Mod ModSim ModSimAux ModSimNat AddWorld ModAddSim Linking.

Import Lia.
Import OMod.
Import Mod.
Import RelationClasses.

Section CLOSE_MONO_SIM.

  Context {M1: Mod.t} {M2_src M2_tgt : Mod.t}.
  Context {wf_src : WF}.
  Context `{world : URA.t}.

  Variable I : shared (state M2_src) (state M2_tgt) (ident M2_src) (ident M2_tgt) wf_src nat_wf -> world -> Prop.

  Definition lift_ma :=
    fun (x : @shared
            (OMod.close M1 M2_src).(state) (OMod.close M1 M2_tgt).(state)
            (OMod.close M1 M2_src).(ident) (OMod.close M1 M2_tgt).(ident)
            (sum_wf wf_src nat_wf) nat_wf)
      (r : URA.prod threadsRA world)
    => let '(ths, IM_SRC, IM_TGT, st_src, st_tgt) := x in
      exists im_src0 ths_ctx0 ths_usr0,
        let im_ctx0 := pick_ctx IM_TGT in
        let im_tgt0 := chop_ctx ths_usr0 IM_TGT in
        IM_SRC = add_ctx im_ctx0 im_src0
        /\ NatMapP.Partition ths ths_ctx0 ths_usr0
        /\ fst r = global_th ths_ctx0 ths_usr0
        /\ fst st_src = fst st_tgt
        /\ lifted I (ths_usr0, im_src0, im_tgt0, snd st_src, snd st_tgt) (snd r).

  Opaque lifted threadsRA URA.prod.

  Lemma lift_ma_local_sim_ub R_src R_tgt (RR : R_src -> R_tgt -> Prop) ktr_src itr_tgt
    : local_sim lift_ma RR (Vis (inl1 (inl1 (inl1 Undefined))) ktr_src) itr_tgt.
  Proof.
    (* treat as if tid ∈ ths_ctx *)
    intros ths IM_SRC0 IM_TGT0 st_src0 st_tgt0 [r_sha_th0 r_sha_w0] [r_ctx_th0 r_ctx_w0] INV0_0 tid ths0 THS0 VALID0_0 IM_TGT1 TID_TGT.
    simpl in INV0_0. des. subst r_sha_th0. unfold_prod VALID0_0.
    assert (CTX_TGT : pick_ctx IM_TGT0 = pick_ctx IM_TGT1).
    { extensionalities i. specialize (TID_TGT (inr (inl i))). ss. }
    assert (USR_TGT : chop_ctx ths_usr0 IM_TGT0 = chop_ctx ths_usr0 IM_TGT1).
    { extensionalities i. destruct i as [i|i].
      - specialize (TID_TGT (inl i)). unfold prism_fmap in *; ss. des_ifs. exfalso.
        eapply inv_add_new in THS0. des. eapply THS0.
        eapply Partition_In_right in INV0_1. eapply INV0_1.
        ss.
      - specialize (TID_TGT (inr (inr i))). ss.
    }
    exists (global_th (TIdSet.add tid ths_ctx0) ths_usr0, r_sha_w0), (local_th_context tid, URA.unit). splits.
    { exists im_src0, (TIdSet.add tid ths_ctx0), ths_usr0. splits; ss.
      - subst. rewrite CTX_TGT. ss.
      - eauto using NatMapP.Partition_sym, Partition_add.
      - rewrite USR_TGT in INV0_4. ss.
    }
    { unfold_prod. split.
      - eapply inv_add_new in THS0. des; subst. eapply global_th_alloc_context.
        + eauto.
        + eapply inv_add_new. split; ss.
          ii. eapply THS0. eapply (Partition_In_left INV0_1). ss.
        + ii. eapply THS0. eapply (Partition_In_right INV0_1). ss.
      - rewrite URA.unit_id. eauto.
    }
    i. pfold. eapply pind9_fold. rewrite <- bind_trigger. econs.
  Qed.

  Notation pind := (fun r => pind9 (__lsim _ _ r) top9).
  Notation cpn := (cpn9 _).
  Tactic Notation "muclo" uconstr(H) :=
    eapply gpaco9_uclo; [auto with paco|apply H|].

  Lemma lift_ma_local_sim_usr R_src R_tgt (RR : R_src -> R_tgt -> Prop) itr_src itr_tgt
        (SIM : local_sim (lifted I) RR itr_src itr_tgt)
    :
    forall ths0 im_src0
           im_tgt0 st_src0 st_tgt0
           (r_shared0 r_ctx0 : URA.prod threadsRA world)
           (INV: lift_ma (ths0, im_src0, im_tgt0, st_src0, st_tgt0) r_shared0)
           (tid : NatMap.key) (ths1 : NatMap.t unit)
           (THS: TIdSet.add_new tid ths0 ths1)
           (VALID: URA.wf (r_shared0 ⋅ r_ctx0)),
    forall im_tgt1
           (TID_TGT: fair_update im_tgt0 im_tgt1 (prism_fmap inlp (fun i : thread_id => if tid_dec i tid then Flag.success else Flag.emp))),
    exists r_shared1 r_own : URA.prod threadsRA world,
      (<<INV: lift_ma (ths1, im_src0, im_tgt1, st_src0, st_tgt0) r_shared1 >>) /\
        (<<VALID: URA.wf (r_shared1 ⋅ r_own ⋅ r_ctx0) >>) /\
        (forall ths im_src1 im_tgt2 st_src2 st_tgt2
                (r_shared2 r_ctx2 : URA.prod threadsRA world)
                (INV: lift_ma (ths, im_src1, im_tgt2, st_src2, st_tgt2) r_shared2)
                (VALID: URA.wf (r_shared2 ⋅ r_own ⋅ r_ctx2)),
          forall im_tgt3
                 (TGT: fair_update im_tgt2 im_tgt3 (prism_fmap inlp (tids_fmap tid ths))),
            (<<LSIM:
              forall fs ft : bool,
                lsim lift_ma tid (fun (r_src: R_src) (r_tgt: R_tgt) (r_ctx: URA.car) '(ths2, im_src1, im_tgt1, st_src1, st_tgt1) =>
                                    (exists ths3 r_own r_shared,
                                        (<<TIN: TIdSet.In tid ths2>>) /\
                                          (<<THS: NatMap.remove tid ths2 = ths3>>) /\
                                          (<<VALID: URA.wf (r_shared ⋅ r_own ⋅ r_ctx)>>) /\
                                          (<<INV: lift_ma (ths3, im_src1, im_tgt1, st_src1, st_tgt1) r_shared>>) /\
                                          (<<RET: RR r_src r_tgt>>))) fs ft r_ctx2 (map_event (emb_callee M1 M2_src) itr_src) (map_event (OMod.emb_callee M1 M2_tgt) itr_tgt)
                     (ths, im_src1, im_tgt3, st_src2, st_tgt2) >>))
  .
  Proof.
    (* tid ∈ ths_usr *)
    intros ths IM_SRC0 IM_TGT0 st_src0 st_tgt0 [r_sha_th0 r_sha_w0] [r_ctx_th0 r_ctx_w0] INV0_0 tid ths0 THS0 VALID0_0. i.
    simpl in INV0_0. des. subst r_sha_th0. unfold_prod VALID0_0.
    move SIM at bottom.
    assert (THS0' : TIdSet.add_new tid ths_usr0 (TIdSet.add tid ths_usr0)).
    { eapply inv_add_new. split; ss. eapply inv_add_new in THS0. des.
      eapply Partition_In_right in INV0_1. eauto.
    }
    assert (TID_TGT' : fair_update (chop_ctx ths_usr0 IM_TGT0) (chop_ctx (NatSet.add tid ths_usr0) im_tgt1) (prism_fmap inlp (fun i => if Nat.eq_dec i tid then Flag.success else Flag.emp))).
    { ii. destruct i as [i|i]; ss.
      - specialize (TID_TGT (inl i)). unfold prism_fmap in *; ss. destruct (Nat.eq_dec i tid); ss.
        assert (H : tid <> i) by lia.
        eapply NatMapP.F.add_neq_in_iff with (m := ths_usr0) (e := tt) in H.
        des_ifs; tauto.
      - specialize (TID_TGT (inr (inr i))). des_ifs.
    }
    specialize (SIM ths_usr0 im_src0 (chop_ctx ths_usr0 IM_TGT0) (snd st_src0) (snd st_tgt0) r_sha_w0 r_ctx_w0 INV0_4 tid (NatSet.add tid ths_usr0) THS0' VALID0_1 (chop_ctx (NatSet.add tid ths_usr0) im_tgt1) TID_TGT').
    destruct SIM as [r_sha_w1 [r_own_w1 [INV_USR [VALID_USR SIM]]]].
    exists (global_th ths_ctx0 (NatSet.add tid ths_usr0), r_sha_w1), (local_th_user tid, r_own_w1). splits.
    { eapply inv_add_new in THS0. des. subst.
      ss. esplits; ss.
      - instantiate (1 := im_src0). extensionalities i. destruct i; ss.
        specialize (TID_TGT (inr (inl i))). ss.
        unfold pick_ctx. f_equal. ss.
      - eapply Partition_add; eauto.
        eapply inv_add_new; eauto.
      - eapply INV_USR.
    }
    { unfold_prod. split.
      - eapply global_th_alloc_user; eauto.
        eapply inv_add_new in THS0. des. ii. eapply THS0.
        eapply Partition_In_left in INV0_1. eapply INV0_1. ss.
      - eauto.
    }
    intros ths2 IM_SRC2 IM_TGT2 st_src2 st_tgt2 [r_sha_th2 r_sha_w2] [r_ctx_th2 r_ctx_w2] INV2_0 VALID2_0 IM_TGT2' TGT fs ft.
    simpl in INV2_0. destruct INV2_0 as [im_src2 [ths_ctx2 [ths_usr2 INV2_0]]]. des. subst r_sha_th2. unfold_prod VALID2_0.
    assert (TGT' : @fair_update _ nat_wf (chop_ctx ths_usr2 IM_TGT2) (chop_ctx ths_usr2 IM_TGT2') (prism_fmap inlp (tids_fmap tid ths_usr2))).
    { eapply chop_ctx_fair_thread2.
      - eapply Partition_In_right in INV2_1. eapply INV2_1.
      - eauto.
    }
    specialize (SIM ths_usr2 im_src2 (chop_ctx ths_usr2 IM_TGT2) (snd st_src2) (snd st_tgt2) r_sha_w2 r_ctx_w2 INV2_4 VALID2_1 (chop_ctx ths_usr2 IM_TGT2') TGT' fs ft).
    unfold emb_l, emb_r.
    eapply pick_ctx_fair_thread in TGT. rewrite TGT in INV2_0.
    clear - INV2_0 INV2_1 INV2_3 VALID2_0 VALID2_1 SIM.
    move tid before I.
    rename
      ths2 into ths0, ths_ctx2 into ths_ctx0, ths_usr2 into ths_usr0,
      im_src2 into im_src0, IM_SRC2 into IM_SRC0, IM_TGT2' into IM_TGT0, st_src2 into st_src0, st_tgt2 into st_tgt0,
      r_sha_w2 into r_sha_w0, r_ctx_th2 into r_ctx_th0, r_ctx_w2 into r_ctx_w0, r_own_w1 into r_own_w0,
      INV2_0 into INV0, INV2_1 into INV1, INV2_3 into INV2, VALID2_0 into VALID_TH0, VALID2_1 into VALID_W0.
    revert_until tid. ginit. gcofix CIH. i. gstep. punfold SIM.
    match type of SIM with pind9 _ _ _ _ ?RR _ _ _ _ _ ?SHA => remember RR as RR_MEM; remember SHA as SHA_MEM end.
    revert RR ths0 ths_ctx0 ths_usr0 st_src0 st_tgt0 r_sha_w0 r_own_w0 r_ctx_th0 im_src0 IM_SRC0 IM_TGT0 INV0 INV1 INV2 VALID_TH0 VALID_W0 HeqRR_MEM HeqSHA_MEM.
    pattern R_src, R_tgt, RR_MEM, fs, ft, r_ctx_w0, itr_src, itr_tgt, SHA_MEM.
    revert R_src R_tgt RR_MEM fs ft r_ctx_w0 itr_src itr_tgt SHA_MEM SIM.
    eapply pind9_acc. intros rr DEC IH R_src R_tgt RR_MEM fs ft r_ctx_w0 itr_src itr_tgt SHA_MEM. i.
    clear DEC. subst RR_MEM SHA_MEM.
    eapply pind9_unfold in PR; eauto with paco. eapply pind9_fold. inv PR.
    - clear - LSIM VALID_TH0 VALID_W0 INV1 INV2.
      rewrite ! map_event_ret. econs.
      ss. des. subst. (* inversion INV2. clear INV2. subst ths_ctx1 ths_usr1 ths3 IM_SRC0. *)
      exists (NatMap.remove tid ths0), (URA.unit, r_own), (global_th ths_ctx0 (NatMap.remove tid ths_usr0), r_shared).
      splits; ss.
      + eapply Partition_In_right; eauto.
        eapply local_th_user_in_user in VALID_TH0. exact VALID_TH0.
      + unfold_prod. split.
        * eapply global_th_dealloc_user; eauto.
        * ss.
      + esplits; ss.
        * eapply local_th_user_in_user in VALID_TH0.
          eapply Partition_remove; eauto.
        * eapply lifted_drop_imap; eauto.
          { i. destruct i as [i|i]; ss.
            - assert (i = tid \/ tid <> i) by lia. destruct H.
              + pose proof NatMap.remove_1 H (m := ths_usr0). des_ifs; unfold le; ss; lia.
              + pose proof (@NatMapP.F.remove_neq_in_iff _ ths_usr0 tid i H). des_ifs; try tauto; reflexivity.
            - des_ifs. left. ss.
          }
    - rewrite map_event_tau. econs. split; ss.
      destruct LSIM. eapply IH; eauto.
    - rewrite map_event_trigger. econs.
      des. destruct LSIM. exists x. split; ss.
      eapply IH; eauto.
    - rewrite map_event_trigger. econs. split; ss.
      destruct st_src0; ss; subst.
      destruct LSIM. eapply IH; eauto.
    - rewrite map_event_trigger. econs. split; ss.
      destruct LSIM. eapply IH; eauto.
    - rewrite map_event_trigger. econs.
    - rewrite map_event_trigger. econs.
      des. destruct LSIM0. exists (add_ctx (pick_ctx IM_TGT0) im_src1). splits.
      { clear - FAIR. ii. destruct i as [i|i]; ss.
        unfold prism_fmap; ss. specialize (FAIR i). des_ifs.
        - econs. ss.
        - f_equal. ss.
      }
      split; ss. eapply IH; eauto.
    - rewrite map_event_tau. econs. split; ss.
      destruct LSIM. eapply IH; eauto.
    - rewrite map_event_trigger. econs. i. specialize (LSIM x). split; ss.
      destruct LSIM. eapply IH; eauto.
    - rewrite map_event_trigger. econs. split; ss.
      destruct st_tgt0; ss; subst.
      destruct LSIM. eapply IH; eauto.
    - rewrite map_event_trigger. econs. split; ss.
      destruct LSIM. eapply IH; eauto.
    - rewrite map_event_trigger. econs. intros IM_TGT1 FAIR. split; ss.
      assert (FAIR' : fair_update (chop_ctx ths_usr0 IM_TGT0) (chop_ctx ths_usr0 IM_TGT1) (prism_fmap inrp f)).
      { ii. destruct i as [i|i]; ss.
        - specialize (FAIR (inl i)). ss. des_ifs.
        - specialize (FAIR (inr (inr i))). ss.
      }
      specialize (LSIM (chop_ctx ths_usr0 IM_TGT1) FAIR').
      destruct LSIM. eapply IH; eauto.
      + extensionalities i. destruct i; ss. f_equal.
        specialize (FAIR (inr (inl i))). ss.
    - rewrite 2 map_event_trigger. econs. i. specialize (LSIM ret). pclearbot.
      gfinal. left. eapply CIH; eauto.
    - rewrite 2 map_event_trigger. apply lsim_call.
      i. specialize (LSIM ret). pclearbot.
      gfinal. left. eapply CIH; eauto.
    - match goal with [ |- __lsim _ _ _ _ _ _ _ _ _ (map_event ?EMB _) _ ] => set EMB as emb end.
      rewrite 2 map_event_trigger.
      eapply lsim_yieldL. split; ss.
      replace (trigger Yield) with (trigger (emb unit (subevent unit Yield))) by ss.
      rewrite <- map_event_trigger.
      destruct LSIM. eapply IH; eauto.
    - match goal with [ |- __lsim _ _ _ _ _ _ _ _ (map_event ?EMB _) _ _ ] => set EMB as emb end.
      rewrite 2 map_event_trigger.
      eapply lsim_yieldR.
      { instantiate (1 := (global_th ths_ctx0 ths_usr0, r_shared)).
        ss. exists im_src0, ths_ctx0, ths_usr0. splits; ss.
      }
      { instantiate (1 := (local_th_user tid, r_own)). unfold_prod. split; ss. }
      intros ths1 IM_SRC1 IM_TGT1 st_src1 st_tgt1 [r_sha_th1 r_sha_w1] [r_ctx_th1 r_ctx_w1] INV1_0 VALID1_0 IM_TGT2 TGT.
      split; ss. des. unfold_prod VALID1_0.
      assert (TGT' : fair_update (chop_ctx ths_usr1 IM_TGT1) (chop_ctx ths_usr1 IM_TGT2) (prism_fmap inlp (tids_fmap tid ths_usr1))).
      { ii. destruct i as [i|i]; ss.
        - eapply Partition_In_right in INV1_1. specialize (INV1_1 i). specialize (TGT (inl i)). unfold prism_fmap in *; ss.
          unfold tids_fmap in *. destruct (Nat.eq_dec i tid); ss. des_ifs.
          exfalso. tauto.
        - specialize (TGT (inr (inr i))). ss.
      }
      specialize (LSIM ths_usr1 im_src1 (chop_ctx ths_usr1 IM_TGT1) (snd st_src1) (snd st_tgt1) r_sha_w1 r_ctx_w1 INV1_4 VALID1_1 (chop_ctx ths_usr1 IM_TGT2) TGT').
      replace (trigger Yield) with (trigger (emb unit (subevent unit Yield))) by ss.
      rewrite <- map_event_trigger.
      destruct LSIM. eapply IH; eauto.
      + subst. extensionalities i. destruct i as [i|i]; ss. f_equal.
        specialize (TGT (inr (inl i))). ss.
      + subst. ss.
    - rewrite 2 map_event_trigger. eapply lsim_sync.
      { instantiate (1 := (global_th ths_ctx0 ths_usr0, r_shared)).
        ss. exists im_src0, ths_ctx0, ths_usr0. splits; ss.
      }
      { instantiate (1 := (local_th_user tid, r_own)). unfold_prod. split; ss. }
      intros ths1 IM_SRC1 IM_TGT1 st_src1 st_tgt1 [r_sha_th1 r_sha_w1] [r_ctx_th1 r_ctx_w1] INV1_0 VALID1_0 IM_TGT2 TGT.
      ss. des. unfold_prod VALID1_0.
      assert (TGT' : fair_update (chop_ctx ths_usr1 IM_TGT1) (chop_ctx ths_usr1 IM_TGT2) (prism_fmap inlp (tids_fmap tid ths_usr1))).
      { ii. destruct i as [i|i]; ss.
        - eapply Partition_In_right in INV1_1. specialize (INV1_1 i). specialize (TGT (inl i)). unfold prism_fmap in *; ss.
          unfold tids_fmap in *. destruct (Nat.eq_dec i tid); ss. des_ifs.
          exfalso. tauto.
        - specialize (TGT (inr (inr i))). ss.
      }
      specialize (LSIM ths_usr1 im_src1 (chop_ctx ths_usr1 IM_TGT1) (snd st_src1) (snd st_tgt1) r_sha_w1 r_ctx_w1 INV1_4 VALID1_1 (chop_ctx ths_usr1 IM_TGT2) TGT').
      pclearbot.
      gfinal. left. eapply CIH; eauto.
      + subst. extensionalities i. destruct i as [i|i]; ss. f_equal.
        specialize (TGT (inr (inl i))). ss.
      + subst. ss.
    - econs. pclearbot. gfinal. left. eapply CIH; eauto.
  Qed.

  Lemma lift_ma_local_sim_ctx
        (FSIM: forall (fn : string) (args : Any.t),
            match funs M2_src fn with
            | Some ktr_src =>
                match funs M2_tgt fn with
                | Some ktr_tgt => local_sim I eq (ktr_src args) (ktr_tgt args)
                | None => False
                end
            | None => match funs M2_tgt fn with
                      | Some _ => False
                      | None => True
                      end
            end)
    :
    forall R (itr: itree _ R),
      local_sim (lift_ma) eq (close_itree M1 M2_src itr) (close_itree M1 M2_tgt itr)
  .
  Proof.
    i.
    intros ths IM_SRC0 IM_TGT0 st_src0 st_tgt0 [r_sha_th0 r_sha_w0] [r_ctx_th0 r_ctx_w0] INV0_0 tid ths0 THS0 VALID0_0 IM_TGT1 TID_TGT.
    simpl in INV0_0. des. subst r_sha_th0. unfold_prod VALID0_0.
    assert (CTX_TGT : pick_ctx IM_TGT0 = pick_ctx IM_TGT1).
    { extensionalities i. specialize (TID_TGT (inr (inl i))). ss. }
    assert (USR_TGT : chop_ctx ths_usr0 IM_TGT0 = chop_ctx ths_usr0 IM_TGT1).
    { extensionalities i. destruct i as [i|i].
      - specialize (TID_TGT (inl i)). unfold prism_fmap in *; ss. des_ifs. exfalso.
        eapply inv_add_new in THS0. des. eapply THS0.
        eapply Partition_In_right in INV0_1. eapply INV0_1.
        ss.
      - specialize (TID_TGT (inr (inr i))). ss.
    }
    exists (global_th (TIdSet.add tid ths_ctx0) ths_usr0, r_sha_w0), (local_th_context tid, URA.unit). splits.
    { exists im_src0, (TIdSet.add tid ths_ctx0), ths_usr0. splits; ss.
      - subst. rewrite CTX_TGT. ss.
      - eauto using NatMapP.Partition_sym, Partition_add.
      - rewrite USR_TGT in INV0_4. ss.
    }
    { unfold_prod. split.
      - eapply inv_add_new in THS0. des; subst. eapply global_th_alloc_context.
        + eauto.
        + eapply inv_add_new. split; ss.
          ii. eapply THS0. eapply (Partition_In_left INV0_1). ss.
        + ii. eapply THS0. eapply (Partition_In_right INV0_1). ss.
      - rewrite URA.unit_id. eauto.
    }
    intros ths1 IM_SRC1 IM_TGT2 st_src1 st_tgt1 [r_sha_th1 r_sha_w1] [r_ctx_th1 r_ctx_w1] INV1_0 VALID1_0.
    intros IM_TGT2' TGT fs ft.
    simpl in INV1_0. des. subst r_sha_th1. unfold_prod VALID1_0.
    unfold emb_l, emb_r.
    assert (INV : lift_ma (ths1, IM_SRC1, IM_TGT2', st_src1, st_tgt1) (global_th ths_ctx1 ths_usr1, r_sha_w1)).
    { ss. exists im_src1, ths_ctx1, ths_usr1. splits; ss.
      - eapply pick_ctx_fair_thread in TGT. rewrite <- TGT. ss.
      - eapply shared_rel_wf_lifted; eauto.
        eapply chop_ctx_fair_thread1; eauto.
        eapply local_th_context_in_context; eauto.
    }
    clear - FSIM INV VALID1_0 VALID1_1. move itr after tid.
    rename
      ths1 into ths0, ths_ctx1 into ths_ctx0, ths_usr1 into ths_usr0,
      IM_SRC1 into IM_SRC0, IM_TGT2' into IM_TGT0, st_src1 into st_src0, st_tgt1 into st_tgt0,
      r_sha_w1 into r_sha_w0, r_ctx_th1 into r_ctx_th0, r_ctx_w1 into r_ctx_w0,
      INV into INV0, VALID1_0 into VALID_TH0, VALID1_1 into VALID_W0.
    revert_until tid. ginit. gcofix CIH. i.
    destruct_itree itr; [| | destruct e as [[[|]|]|] ].
    - rewrite 2 close_itree_ret.
      gstep. eapply pind9_fold. econs. ss.
      exists (NatSet.remove tid ths0), (URA.unit, URA.unit), (global_th (NatSet.remove tid ths_ctx0) ths_usr0, r_sha_w0).
      splits; ss.
      { unfold_prod. split.
        - eapply global_th_dealloc_context; eauto.
        - eauto.
      }
      { des. inversion INV2. subst ths_ctx1 ths_usr1. exists im_src0, (NatSet.remove tid ths_ctx0), ths_usr0. splits; ss.
        eapply local_th_context_in_context in VALID_TH0.
        eauto using NatMapP.Partition_sym, Partition_remove.
      }
    - rewrite 2 close_itree_tau.
      gstep.
      eapply pind9_fold. econs. split; ss.
      eapply pind9_fold. econs. split; ss.
      eapply pind9_fold. econs.
      gfinal. left. eapply CIH; eauto.
    - rewrite 2 close_itree_vis_eventE.
      rewrite <- 2 bind_trigger.
      gstep. destruct e; ss.
      + eapply pind9_fold. eapply lsim_chooseR. i. esplit; ss.
        eapply pind9_fold. eapply lsim_chooseL. exists x. esplit; ss.
        eapply pind9_fold. econs. split; ss.
        eapply pind9_fold. econs. split; ss.
        eapply pind9_fold. eapply lsim_progress.
        gfinal. left. eapply CIH; eauto.
      + eapply pind9_fold. eapply lsim_fairR. intros IM_TGT1 FAIR. esplit; ss.
        eapply pind9_fold. eapply lsim_fairL.
        des. inversion INV2. subst ths_ctx1 ths_usr1. exists (add_ctx (pick_ctx IM_TGT1) im_src0). split.
        { subst. ii. destruct i; ss.
          specialize (FAIR (inr (inl i))). unfold pick_ctx, prism_fmap in *; ss. des_ifs.
          + econs. ss.
          + f_equal. ss.
        }
        split; ss.
        eapply pind9_fold. econs. split; ss.
        eapply pind9_fold. econs. split; ss.
        eapply pind9_fold. eapply lsim_progress.
        gfinal. left. des. eapply CIH; eauto.
        { esplits; eauto. eapply chop_ctx_fair_ctx in FAIR. rewrite <- FAIR. ss. }
      + eapply pind9_fold. eapply lsim_observe. i.
        gstep.
        eapply pind9_fold. econs. split; ss.
        eapply pind9_fold. econs. split; ss.
        eapply pind9_fold. econs.
        gfinal. left. eapply CIH; eauto.
      + eapply pind9_fold. eapply lsim_UB.
    - rewrite 2 close_itree_vis_cE.
      rewrite <- 2 bind_trigger.
      gstep. destruct c.
      + eapply pind9_fold. eapply lsim_sync.
        { eapply INV0. }
        { instantiate (1 := (local_th_context tid, ε)). unfold_prod. split; ss. }
        intros ths1 IM_SRC1 IM_TGT1 st_src1 st_tgt1 [r_sha_th1 r_sha_w1] [r_ctx_th1 r_ctx_w1] INV1_0 VALID1_0 IM_TGT1' TGT.
        simpl in INV1_0. des. subst r_sha_th1. rename im_src0 into im_src1. unfold_prod VALID1_0.
        gstep.
        eapply pind9_fold. econs. split; ss.
        eapply pind9_fold. econs. split; ss.
        eapply pind9_fold. econs.
        gfinal. left. eapply CIH; eauto.
        { exists im_src1, ths_ctx1, ths_usr1. ss. splits; ss.
          - eapply pick_ctx_fair_thread in TGT. rewrite <- TGT. ss.
          - eapply shared_rel_wf_lifted; eauto.
            eapply chop_ctx_fair_thread1; eauto.
            eapply local_th_context_in_context; eauto.
        }
      + eapply pind9_fold. eapply lsim_tidR. esplit; ss.
        eapply pind9_fold. eapply lsim_tidL. esplit; ss.
        eapply pind9_fold. econs. split; ss.
        eapply pind9_fold. econs. split; ss.
        eapply pind9_fold. eapply lsim_progress.
        gfinal. left. eapply CIH; eauto.
    - destruct c. rewrite 2 close_itree_vis_call. simpl.
      specialize (FSIM fn arg).
      des_ifs.
      + rewrite <- 2 bind_trigger.
        gstep. eapply pind9_fold. eapply lsim_sync; eauto.
        { instantiate (1:=(local_th_context tid, ε)). unfold_prod; ss. }
        move FSIM at bottom.
        eapply local_sim_clos_trans in FSIM; [|econs; exact 0].
        eapply local_sim_wft_mono with (wft_lt := lt (wf_clos_trans nat_wf)) in FSIM; cycle 1.
        { i; econs; ss. eauto. }

        i.

        Set Nested Proofs Allowed.
        Lemma lift_ma_pop_push ths0 im_src im_tgt st_src st_tgt r0 r_ctx
              tid
              (INV: lift_ma (ths0, im_src, im_tgt, st_src, st_tgt) r0)
              (WF: URA.wf (r0 ⋅ (local_th_context tid, ε) ⋅ r_ctx))
          :
          exists ths1 r1,
            (<<INV: lift_ma (ths1, im_src, im_tgt, st_src, st_tgt) r1>>) /\
              (<<WF: URA.wf (r1 ⋅ r_ctx)>>) /\
              (<<ADD: TIdSet.add_new tid ths1 ths0>>).
        Proof.
          red in INV. des. subst. destruct r0, r_ctx. ss. subst.
          rewrite unfold_prod_wf in WF. rewrite unfold_prod_add in WF. ss. des.
          hexploit local_th_context_in_context; eauto. i.
          hexploit Partition_remove.
          { eapply NatMapP.Partition_sym. eauto. }
          { eauto. }
          intros PART. hexploit global_th_dealloc_context; eauto.
          intros WF1. eexists _, (_, _). esplits.
          { eauto. }
          { eapply NatMapP.Partition_sym. eauto. }
          { ss. }
          { eauto. }
          { eauto. }
          { rewrite URA.unit_id in WF1. rewrite URA.unit_id in WF0.
            rewrite unfold_prod_wf. rewrite unfold_prod_add. auto.
          }
          { rr. econs.
            { eapply nm_find_rm_eq. }
            { eapply nm_find_some_rm_add_eq.
              eapply Partition_In_left in H; eauto.
              eapply NatMapP.F.in_find_iff in H.
              destruct (NatMap.find tid ths0) as [[]|]; ss.
            }
          }
        Qed.

        Lemma lift_ma_push_pop ths im_src im_tgt st_src st_tgt r0 r_ctx
              tid r_own
              (INV: lift_ma (NatMap.remove tid ths, im_src, im_tgt, st_src, st_tgt) r0)
              (WF: URA.wf (r0 ⋅ r_own ⋅ r_ctx))
              (IN: TIdSet.In tid ths)
          :
          exists r1,
            (<<INV: lift_ma (ths, im_src, im_tgt, st_src, st_tgt) r1>>) /\
              (<<WF: URA.wf (r1 ⋅ (local_th_context tid, ε) ⋅ r_ctx)>>).
        Proof.
          red in INV. des. subst. destruct r0, r_own, r_ctx. ss. subst.
          rewrite unfold_prod_wf in WF. rewrite unfold_prod_add in WF. ss. des.
          hexploit global_th_alloc_context.
          { rewrite <- URA.add_assoc in WF. eapply WF. }
          { econs.
            { eapply NatMapP.F.not_find_in_iff. ii.
              eapply Partition_In_left in H; eauto.
              eapply NatMap.remove_1 in H; eauto.
            }
            { ss. }
          }
          { ii. eapply Partition_In_right in H; eauto.
            eapply NatMap.remove_1 in H; eauto.
          }
          i. eexists (_, _). esplits.
          { ss. }
          { eapply NatMapP.Partition_sym.
            eapply Partition_add.
            { eapply NatMapP.Partition_sym. eauto. }
            econs; eauto.
            { eapply NatMapP.F.not_find_in_iff.
              eapply NatMap.remove_1; eauto.
            }
            { eapply nm_find_some_rm_add_eq.
              instantiate (1:=tt). destruct (NatMap.find tid ths) as [[]|] eqn:EQ; ss.
              eapply NatMapP.F.not_find_in_iff in EQ; eauto. ss.
            }
          }
          { ss. }
          { ss. }
          { eauto. }
          rewrite unfold_prod_wf. rewrite unfold_prod_add. ss. split.
          { eapply URA.wf_mon. instantiate (1:=c1). r_wf H. }
          { eapply URA.wf_mon. instantiate (1:=c2). r_wf WF0. }
        Qed.

        hexploit lift_ma_pop_push; eauto. i. des.
        muclo lsim_bindC'_spec. cbn. econs; eauto.
        * hexploit lift_ma_local_sim_usr; eauto.
          { instantiate (1:=im_tgt1). ii. unfold prism_fmap; ss. des_ifs. }
          i. des. hexploit H1; eauto. i.
          gfinal. right. eapply paco9_mon; [eapply H|]; ss.
        * i. destruct r_ctx as [r_ctx0 r_ctx2]. destruct shr as [[[[shr0 shr1] shr2] shr3] shr4].
          muclo lsim_indC_spec. cbn. econs; eauto.
          muclo lsim_indC_spec. cbn. econs; eauto.
          des. subst.
          hexploit lift_ma_push_pop; eauto.
          i. des. destruct r0.
          rewrite unfold_prod_wf in WF0. rewrite unfold_prod_add in WF0. ss. des. subst.
          gbase. eapply CIH; eauto.
          esplits; eauto.
      + rewrite <- 2 bind_trigger.
        gstep. eapply pind9_fold. econs; eauto.
    - destruct s.
      rewrite ! close_itree_vis_rmw, <- ! bind_trigger.
      gstep.
      eapply pind9_fold. eapply lsim_rmwL. split; ss.
      eapply pind9_fold. eapply lsim_rmwR. split; ss.
      eapply pind9_fold. eapply lsim_tauL. split; ss.
      eapply pind9_fold. eapply lsim_tauR. split; ss.
      eapply pind9_fold. eapply lsim_progress.
      des. destruct st_src0, st_tgt0; ss; subst.
      gbase. eapply CIH; eauto. esplits; eauto.
  Qed.

End CLOSE_MONO_SIM.

Section MODADD_THEOREM.

  Theorem ModClose_mono M1 M2_src M2_tgt :
    ModSim.mod_sim M2_src M2_tgt ->
    ModSim.mod_sim (close M1 M2_src) (close M1 M2_tgt).
  Proof.
    i. eapply modsim_nat_modsim_exist in H. inv H.
    (* pose (I' := @lift_ma M1 M2_src M2_tgt _ _ I). *)
    econstructor 1 with (world:=URA.prod threadsRA world).
    (* constructor 1 with _ _ _ I'. *)
    { instantiate (1:=nat_wf). econs. exact 0. }
    { i. exists (S o0). ss. }
    intro IM_TGT. specialize (init (chop_ctx NatSet.empty IM_TGT)). des.
    pose (I' := @lift_ma M1 M2_src M2_tgt _ _ I). exists I'.
    pose (pick_ctx IM_TGT) as im_ctx.
    split.
    { exists (add_ctx im_ctx im_src), (global_th NatSet.empty NatSet.empty, r_shared). ss. split.
      - exists im_src. exists NatSet.empty, NatSet.empty. splits; ss.
        + eapply Partition_empty.
        + exists (chop_ctx NatSet.empty IM_TGT). split; ss. ii. left. ss.
      - unfold_prod. split; ss. rewrite URA.unfold_wf. econs; ss. eapply Disjoint_empty.
    }
    i. unfold close, closed_funs; ss. des_ifs.
    - eapply lift_ma_local_sim_ctx; eauto.
  Qed.

  Tactic Notation "muclo" uconstr(H) :=
    eapply gpaco9_uclo; [auto with paco|apply H|].

  Theorem ModClose_assoc M1 M2 M3 :
    ModSim.mod_sim (close M1 (close M2 M3)) (close (close M1 M2) M3).
  Proof.
    econstructor 1 with (world := Unit).
    { instantiate (1 := nat_wf). econs. exact 0. }
    { i. exists (S o0). ss. }
    intro IM_TGT.
    pose Unit_wf as VALID.
    pose (conv_im :=
            (fun im_tgt i =>
               match i with
               | inl i => im_tgt (inr (inl (inl i)))
               | inr (inl i) => im_tgt (inr (inl (inr i)))
               | inr (inr i) => im_tgt (inr (inr i))
               end)
            : @imap (ident_tgt (close (close M1 M2) M3).(ident)) nat_wf ->
              @imap (close M1 (close M2 M3)).(ident) nat_wf).
    pose (I := fun (x : @shared
                        (close M1 (close M2 M3)).(state) (close (close M1 M2) M3).(state)
                        (close M1 (close M2 M3)).(ident) (close (close M1 M2) M3).(ident)
                        nat_wf nat_wf)
                 (w : Unit)
               => let '(ths, im_src, im_tgt, st_src, st_tgt) := x in
                 (fst st_src : state M1) = fst (fst st_tgt)
                 /\ (fst (snd st_src) : state M2) = snd (fst st_tgt)
                 /\ (snd (snd st_src) : state M3) = snd st_tgt
                 /\ im_src = conv_im im_tgt
         ).
    exists I. split.
    { exists (conv_im IM_TGT), tt. splits; ss. }
    i. do 2 (ss; unfold closed_funs). destruct (funs M1 fn); ss.
    remember (k args) as itr; clear k args Heqitr.
    ii. exists tt, tt. splits; ss.
    { des. splits; ss.
      rewrite INV2. extensionalities i. destruct i as [|[|]].
      - specialize (TID_TGT (inr (inl (inl i)))); ss.
      - specialize (TID_TGT (inr (inl (inr i)))); ss.
      - specialize (TID_TGT (inr (inr i))); ss.
    }
    i.
    assert (INV_CIH : I (ths, im_src1, im_tgt3, st_src2, st_tgt2) tt).
    { des. ss. splits; ss.
      rewrite INV3. extensionalities i. destruct i as [|[|]].
      - specialize (TGT (inr (inl (inl i)))); ss.
      - specialize (TGT (inr (inl (inr i)))); ss.
      - specialize (TGT (inr (inr i))); ss.
    }
    clear - INV_CIH. move itr after tid. revert_until tid.
    pose proof Unit_wf as VALID.
    ginit. gcofix CIH. i. destruct_itree itr.
    - rewrite ! close_itree_ret.
      gstep. eapply pind9_fold. eapply lsim_ret.
      ss. eexists. exists tt, tt. des. splits; ss.
    - rewrite ! close_itree_tau.
      gstep.
      eapply pind9_fold. eapply lsim_tauL. split; ss.
      eapply pind9_fold. eapply lsim_tauR. split; ss.
      eapply pind9_fold. eapply lsim_progress.
      gfinal. left. eapply CIH. des. splits; ss.
    - destruct e as [[[e|ce]|cae]|s].
      + rewrite ! close_itree_vis_eventE.
        rewrite <- ! bind_trigger.
        destruct e.
        * gstep. eapply pind9_fold. eapply lsim_chooseR. i. split; ss.
          eapply pind9_fold. eapply lsim_chooseL. exists x. split; ss.
          eapply pind9_fold. eapply lsim_tauL. split; ss.
          rewrite close_itree_tau.
          eapply pind9_fold. eapply lsim_tauR. split; ss.
          eapply pind9_fold. eapply lsim_tauR. split; ss.
          eapply pind9_fold. eapply lsim_progress.
          gfinal. left. eapply CIH. des. splits; ss.
        * gstep. eapply pind9_fold. eapply lsim_fairR. i. split; ss.
          eapply pind9_fold. eapply lsim_fairL. exists (conv_im im_tgt1). split.
          { des. rewrite INV_CIH2. ii. destruct i as [|[|]].
            unfold prism_fmap in *. ss.
            - specialize (FAIR (inr (inl (inl i)))). ss.
            - specialize (FAIR (inr (inl (inr i)))). ss.
            - specialize (FAIR (inr (inr i))). ss.
          }
          split; ss.
          eapply pind9_fold. eapply lsim_tauL. split; ss.
          rewrite close_itree_tau.
          eapply pind9_fold. eapply lsim_tauR. split; ss.
          eapply pind9_fold. eapply lsim_tauR. split; ss.
          eapply pind9_fold. eapply lsim_progress.
          gfinal. left. eapply CIH. des. splits; ss.
        * gstep. eapply pind9_fold. eapply lsim_observe. i.
          gstep. eapply pind9_fold. eapply lsim_tauL. split; ss.
          rewrite close_itree_tau.
          eapply pind9_fold. eapply lsim_tauR. split; ss.
          eapply pind9_fold. eapply lsim_tauR. split; ss.
          eapply pind9_fold. eapply lsim_progress.
          gfinal. left. eapply CIH. des. splits; ss.
        * gstep. eapply pind9_fold. eapply lsim_UB.
      + rewrite ! close_itree_vis_cE.
        rewrite <- ! bind_trigger.
        destruct ce.
        * gstep. eapply pind9_fold. eapply lsim_sync; ss. i.
          gstep. eapply pind9_fold. eapply lsim_tauL. split; ss.
          rewrite close_itree_tau.
          eapply pind9_fold. eapply lsim_tauR. split; ss.
          eapply pind9_fold. eapply lsim_tauR. split; ss.
          eapply pind9_fold. eapply lsim_progress.
          gfinal. left. eapply CIH. des. splits; ss.
          { rewrite INV2. extensionalities i. destruct i as [|[|]].
            - specialize (TGT (inr (inl (inl i)))). ss.
            - specialize (TGT (inr (inl (inr i)))). ss.
            - specialize (TGT (inr (inr i))). ss.
          }
        * gstep. eapply pind9_fold. eapply lsim_tidR. split; ss.
          eapply pind9_fold. eapply lsim_tidL. split; ss.
          eapply pind9_fold. eapply lsim_tauL. split; ss.
          rewrite close_itree_tau.
          eapply pind9_fold. eapply lsim_tauR. split; ss.
          eapply pind9_fold. eapply lsim_tauR. split; ss.
          eapply pind9_fold. eapply lsim_progress.
          gfinal. left. eapply CIH. des. splits; ss.
      + destruct cae. rewrite ! close_itree_vis_call.
        ss. unfold closed_funs. destruct (funs M2 fn).
        * rewrite close_itree_vis_cE.
          rewrite <- ! bind_trigger.
          rewrite close_itree_bind.
          gstep. eapply pind9_fold. eapply lsim_sync; ss.
          i.
          assert (INV_CIH2 : I (ths1, im_src0, im_tgt2, st_src1, st_tgt1) tt).
          { des. ss. splits; ss.
            rewrite INV2.
            extensionalities i. destruct i as [|[|]].
            - specialize (TGT (inr (inl (inl i)))). ss.
            - specialize (TGT (inr (inl (inr i)))). ss.
            - specialize (TGT (inr (inr i))). ss.
          }
          clear - CIH INV_CIH2.
          gstep. eapply pind9_fold. eapply lsim_tauR. split; ss.
          eapply pind9_fold. eapply lsim_progress. split; ss.
          muclo lsim_bindC'_spec. econs.
          { instantiate (1 := fun r_src r_tgt r_ctx shr => r_src = r_tgt /\ I shr tt).
            remember (k0 arg) as itr; clear - INV_CIH2.
            revert_until r. gcofix CIH. i.
            pose Unit_wf as VALID.
            destruct_itree itr.
            - rewrite ! close_itree_ret.
              rewrite ! map_event_ret.
              rewrite ! close_itree_ret.
              gstep. eapply pind9_fold. eapply lsim_ret. esplits; ss.
            - rewrite ! close_itree_tau.
              rewrite ! map_event_tau.
              rewrite ! close_itree_tau.
              gstep. eapply pind9_fold. eapply lsim_tauL. split; ss.
              eapply pind9_fold. eapply lsim_tauR. split; ss.
              eapply pind9_fold. eapply lsim_progress.
              gfinal. left. eapply CIH; ss.
            - destruct e as [[[e|ce]|cae]|s].
              + rewrite ! close_itree_vis_eventE.
                rewrite ! map_event_vis. unfold emb_callee; ss.
                rewrite ! close_itree_vis_eventE.
                rewrite <- ! bind_trigger.
                destruct e.
                * gstep. eapply pind9_fold. eapply lsim_chooseR. i. split; ss.
                  eapply pind9_fold. eapply lsim_chooseL. exists x. split; ss.
                  rewrite map_event_tau.
                  eapply pind9_fold. eapply lsim_tauL. split; ss.
                  eapply pind9_fold. eapply lsim_tauR. split; ss.
                  eapply pind9_fold. eapply lsim_progress.
                  gfinal. left. eapply CIH; ss.
                * gstep. eapply pind9_fold. eapply lsim_fairR. i. split; ss.
                  eapply pind9_fold. eapply lsim_fairL. exists (conv_im im_tgt1). split.
                  { des. rewrite INV_CIH3. ii. destruct i as [|[|]].
                    unfold prism_fmap in *. ss.
                    - specialize (FAIR (inr (inl (inl i)))). ss.
                    - specialize (FAIR (inr (inl (inr i)))). ss.
                    - specialize (FAIR (inr (inr i))). ss.
                  }
                  split; ss.
                  rewrite map_event_tau.
                  eapply pind9_fold. eapply lsim_tauL. split; ss.
                  eapply pind9_fold. eapply lsim_tauR. split; ss.
                  eapply pind9_fold. eapply lsim_progress.
                  gfinal. left. eapply CIH; ss.
                * gstep. eapply pind9_fold. eapply lsim_observe. i.
                  rewrite map_event_tau.
                  gstep.
                  eapply pind9_fold. eapply lsim_tauL. split; ss.
                  eapply pind9_fold. eapply lsim_tauR. split; ss.
                  eapply pind9_fold. eapply lsim_progress.
                  gfinal. left. eapply CIH; ss.
                * gstep. eapply pind9_fold. eapply lsim_UB.
              + rewrite ! close_itree_vis_cE.
                rewrite ! map_event_vis. unfold emb_callee; ss.
                rewrite ! close_itree_vis_cE.
                rewrite <- ! bind_trigger.
                destruct ce.
                * gstep. eapply pind9_fold. eapply lsim_sync; ss. i.
                  rewrite map_event_tau.
                  gstep.
                  eapply pind9_fold. eapply lsim_tauL. split; ss.
                  eapply pind9_fold. eapply lsim_tauR. split; ss.
                  eapply pind9_fold. eapply lsim_progress.
                  gfinal. left. des. eapply CIH; ss.
                  { rewrite INV2. extensionalities i. destruct i as [|[|]].
                    - specialize (TGT (inr (inl (inl i)))). ss.
                    - specialize (TGT (inr (inl (inr i)))). ss.
                    - specialize (TGT (inr (inr i))). ss.
                  }
                * gstep. eapply pind9_fold. eapply lsim_tidR. split; ss.
                  eapply pind9_fold. eapply lsim_tidL. split; ss.
                  rewrite map_event_tau.
                  eapply pind9_fold. eapply lsim_tauL. split; ss.
                  eapply pind9_fold. eapply lsim_tauR. split; ss.
                  eapply pind9_fold. eapply lsim_progress.
                  gfinal. left. des. eapply CIH; ss.
              + destruct cae.
                rewrite ! map_event_vis. unfold emb_callee; ss.
                rewrite ! close_itree_vis_call.
                destruct (funs M3 fn).
                * rewrite map_event_vis.
                  rewrite <- ! bind_trigger.
                  gstep. eapply pind9_fold. eapply lsim_sync; ss. i.
                  assert (INV_CIH4 : I (ths0, im_src1, im_tgt0, st_src0, st_tgt0) tt).
                  { des. ss. splits; ss.
                    rewrite INV2.
                    extensionalities i. destruct i as [|[|]].
                    - specialize (TGT (inr (inl (inl i)))). ss.
                    - specialize (TGT (inr (inl (inr i)))). ss.
                    - specialize (TGT (inr (inr i))). ss.
                  }
                  clear - CIH INV_CIH4.
                  gstep. eapply pind9_fold. eapply lsim_progress.
                  rewrite map_event_bind.
                  muclo lsim_bindC'_spec. econs.
                  { instantiate (1 := fun r_src r_tgt r_ctx shr => r_src = r_tgt /\ I shr tt).
                    gfinal. right.
                    unfold emb_callee. rewrite <- map_event_compose, <- plmap_compose.
                    eapply paco9_mon. eapply lsim_refl.
                    - firstorder.
                      + destruct st_src as [? []], st_tgt as [[] ?]; ss.
                        unfold Lens.set in *; ss. subst; ss.
                      + destruct st_src as [? []], st_tgt as [[] ?]; ss.
                        unfold Lens.set in *; ss. subst; ss.
                      + destruct st_src as [? []], st_tgt as [[] ?]; ss.
                        unfold Lens.set in *; ss. subst; ss.
                    - firstorder.
                      + subst. ss.
                      + subst. extensionalities i. destruct i; ss. destruct i; ss.
                    - firstorder.
                      + subst. ss.
                    - firstorder.
                    - eauto.
                    - ss.
                  }
                  i. destruct shr as [[[[ths2 im_src] im_tgt] st_src] st_tgt]. destruct SAT. subst.
                  rewrite map_event_tau.
                  gstep.
                  eapply pind9_fold. eapply lsim_tauL. split; ss.
                  eapply pind9_fold. eapply lsim_tauR. split; ss.
                  eapply pind9_fold. eapply lsim_progress.
                  gfinal. left. des. eapply CIH; ss.
                * rewrite map_event_vis.
                  rewrite <- ! bind_trigger.
                  gstep. eapply pind9_fold. eapply lsim_UB.
              + destruct s.
                rewrite ! map_event_vis. unfold emb_callee; ss.
                rewrite ! close_itree_vis_rmw.
                rewrite ! map_event_vis.
                rewrite <- ! bind_trigger.
                gstep.
                eapply pind9_fold. eapply lsim_rmwL. split; ss.
                eapply pind9_fold. eapply lsim_rmwR. split; ss.
                rewrite ! map_event_tau.
                eapply pind9_fold. eapply lsim_tauL. split; ss.
                eapply pind9_fold. eapply lsim_tauR. split; ss.
                eapply pind9_fold. eapply lsim_progress.
                des. destruct st_src1 as [s0 []], st_tgt1 as [[] s2]; ss; subst.
                gbase. eapply CIH; ss.
          }
          i. destruct shr as [[[[ths2 im_src] im_tgt] st_src] st_tgt]. destruct SAT. subst.
          rewrite close_itree_tau.
          gstep. eapply pind9_fold. eapply lsim_tauR. split; ss.
          eapply pind9_fold. eapply lsim_tauL. split; ss.
          eapply pind9_fold. eapply lsim_progress.
          gfinal. left. eapply CIH. des. splits; ss.
        * rewrite ! close_itree_vis_eventE.
          rewrite <- ! bind_trigger.
          gstep. eapply pind9_fold. eapply lsim_UB.
      + destruct s.
        rewrite ! close_itree_vis_rmw, <- ! bind_trigger.
        gstep.
        eapply pind9_fold. eapply lsim_rmwL. split; ss.
        eapply pind9_fold. eapply lsim_rmwR. split; ss.
        rewrite ! close_itree_tau.
        eapply pind9_fold. eapply lsim_tauL. split; ss.
        eapply pind9_fold. eapply lsim_tauR. split; ss.
        eapply pind9_fold. eapply lsim_tauR. split; ss.
        eapply pind9_fold. eapply lsim_progress.
        des. destruct st_src2 as [s0 []], st_tgt2 as [[] s2]; ss; subst.
        gbase. eapply CIH; ss.
        Unshelve. all: exact tt.
  Qed.

End MODADD_THEOREM.