From sflib Require Import sflib.
From Paco Require Import paco.
From Fairness Require Import ITreeLib IProp IPM ModSim ModSimNat PCM.
From Fairness Require PCMLarge.
Require Import Program.

Set Implicit Arguments.

Section SIM.
  Context `{Σ: GRA.t}.

  Variable state_src: Type.
  Variable state_tgt: Type.

  Variable ident_src: ID.
  Variable ident_tgt: ID.

  Variable wf_src: WF.

  Let srcE := programE ident_src state_src.
  Let tgtE := programE ident_tgt state_tgt.

  Let shared_rel := TIdSet.t -> (@imap ident_src wf_src) -> (@imap (sum_tid ident_tgt) nat_wf) -> state_src -> state_tgt -> iProp.

  Definition liftI (R: shared_rel): (TIdSet.t *
                               (@imap ident_src wf_src) *
                               (@imap (sum_tid ident_tgt) nat_wf) *
                               state_src *
                               state_tgt) -> Σ -> Prop :=
        fun '(ths, im_src, im_tgt, st_src, st_tgt) r_shared =>
          R ths im_src im_tgt st_src st_tgt r_shared.

  Let liftRR R_src R_tgt (RR: R_src -> R_tgt -> shared_rel):
    R_src -> R_tgt -> Σ -> (TIdSet.t *
                              (@imap ident_src wf_src) *
                              (@imap (sum_tid ident_tgt) nat_wf) *
                              state_src *
                              state_tgt) -> Prop :=
        fun r_src r_tgt r_ctx '(ths, im_src, im_tgt, st_src, st_tgt) =>
          exists r,
            (<<WF: URA.wf (r ⋅ r_ctx)>>) /\
              RR r_src r_tgt ths im_src im_tgt st_src st_tgt r.

  Variable tid: thread_id.
  Variable I: shared_rel.

  Let rel := (forall R_src R_tgt (Q: R_src -> R_tgt -> shared_rel), bool -> bool -> itree srcE R_src -> itree tgtE R_tgt -> shared_rel).

  Let gf := (fun r => pind9 ((@__lsim (to_LURA Σ)) _ _ _ _ _ _ (liftI I) tid r) top9).
  Let gf_mon: monotone9 gf.
  Proof.
    eapply lsim_mon.
  Qed.
  Hint Resolve gf_mon: paco.

  Variant unlift (r: rel):
    forall R_src R_tgt (RR: R_src -> R_tgt -> Σ ->
                            (TIdSet.t *
                               (@imap ident_src wf_src) *
                               (@imap (sum_tid ident_tgt) nat_wf) *
                               state_src *
                               state_tgt) -> Prop),
      bool -> bool -> Σ -> itree srcE R_src -> itree tgtE R_tgt ->
      (TIdSet.t *
         (@imap ident_src wf_src) *
         (@imap (sum_tid ident_tgt) nat_wf) *
         state_src *
         state_tgt) -> Prop :=
    | unlift_intro
        R_src R_tgt Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt r_ctx r_own
        (REL: r R_src R_tgt Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt r_own)
        (WF: URA.wf (r_own ⋅ r_ctx))
      :
      unlift r (liftRR Q) ps pt r_ctx itr_src itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  .

  Program Definition isim: rel -> rel -> rel :=
    fun
      r g
      R_src R_tgt Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt =>
      iProp_intro
        (fun r_own =>
           forall r_ctx (WF: URA.wf (r_own ⋅ r_ctx)),
             gpaco9 gf (cpn9 gf) (@unlift r) (@unlift g) _ _ (liftRR Q) ps pt r_ctx itr_src itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)) _.
  Next Obligation.
  Proof.
    ii. ss. eapply H.
    eapply URA.wf_extends; eauto. eapply URA.extends_add; eauto.
  Qed.

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

  Lemma isim_upd r g R_src R_tgt
        (Q: R_src -> R_tgt -> shared_rel)
        ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt
    :
    bi_entails
      (#=> (isim r g Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt))
      (isim r g Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
  .
  Proof.
    rr. autorewrite with iprop. i.
    rr in H. autorewrite with iprop in H.
    ii. hexploit H; eauto. i. des. eauto.
  Qed.

  Global Instance isim_elim_upd
         r g R_src R_tgt
         (Q: R_src -> R_tgt -> shared_rel)
         ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt p
         P
    :
    ElimModal True p false (#=> P) P (isim r g Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt) (isim r g Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt).
  Proof.
    unfold ElimModal. rewrite bi.intuitionistically_if_elim.
    i. iIntros "[H0 H1]".
    iApply isim_upd. iMod "H0". iModIntro.
    iApply "H1". iFrame.
  Qed.

  Lemma Ladd (a b: Σ): @PCMLarge.URA.add (to_LURA Σ) a b = URA.add a b.
  Proof.
    unfold PCMLarge.URA.add. PCMLarge.unseal "ra". ur. auto.
  Qed.

  Lemma Lwf (a: Σ): @PCMLarge.URA.wf (to_LURA Σ) a = URA.wf a.
  Proof.
    unfold PCMLarge.URA.wf. PCMLarge.unseal "ra". ur. auto.
  Qed.

  Lemma Lunit: @PCMLarge.URA.unit (to_LURA Σ) = URA.unit.
  Proof.
    Local Transparent PCMLarge.URA.unit.
    unfold PCMLarge.URA.unit. PCMLarge.unseal "ra". ur. auto.
  Qed.

  Lemma isim_wand r g R_src R_tgt
        (Q0 Q1: R_src -> R_tgt -> shared_rel)
        ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt
    :
    bi_entails
      ((∀ r_src r_tgt ths im_src im_tgt st_src st_tgt,
           ((Q0 r_src r_tgt ths im_src im_tgt st_src st_tgt) -∗ #=> (Q1 r_src r_tgt ths im_src im_tgt st_src st_tgt))) ** (isim r g Q0 ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt))
      (isim r g Q1 ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
  .
  Proof.
    rr. autorewrite with iprop. i.
    rr in H. autorewrite with iprop in H. des. subst.
    ii. eapply gpaco9_uclo; [auto with paco|apply lsim_frameC_spec|].
    econs.
    instantiate (1:=a).
    eapply gpaco9_uclo; [auto with paco|apply lsim_monoC_spec|].
    econs.
    2:{ eapply H1. r_wf WF0. rewrite Ladd. r_solve. }
    unfold liftRR. i. subst. des_ifs. des.
    rr in H0. autorewrite with iprop in H0. specialize (H0 r_src).
    rr in H0. autorewrite with iprop in H0. specialize (H0 r_tgt).
    rr in H0. autorewrite with iprop in H0. specialize (H0 t).
    rr in H0. autorewrite with iprop in H0. specialize (H0 i0).
    rr in H0. autorewrite with iprop in H0. specialize (H0 i).
    rr in H0. autorewrite with iprop in H0. specialize (H0 s0).
    rr in H0. autorewrite with iprop in H0. specialize (H0 s).
    rr in H0. autorewrite with iprop in H0.
    hexploit (H0 r0); eauto.
    { eapply URA.wf_mon. instantiate (1:=r_ctx'). r_wf WF1. rewrite Ladd. r_solve. }
    i. rr in H. autorewrite with iprop in H.
    hexploit H.
    { instantiate (1:=r_ctx'). r_wf WF1. rewrite Ladd. r_solve. }
    i. des. esplits; eauto.
  Qed.

  Lemma isim_mono r g R_src R_tgt
        (Q0 Q1: R_src -> R_tgt -> shared_rel)
        (MONO: forall r_src r_tgt ths im_src im_tgt st_src st_tgt,
            bi_entails
              (Q0 r_src r_tgt ths im_src im_tgt st_src st_tgt)
              (#=> (Q1 r_src r_tgt ths im_src im_tgt st_src st_tgt)))
        ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt
    :
    bi_entails
      (isim r g Q0 ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
      (isim r g Q1 ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
  .
  Proof.
    iIntros. iApply isim_wand. iFrame.
    iIntros. iApply MONO. eauto.
  Qed.

  Lemma isim_frame r g R_src R_tgt
        P (Q: R_src -> R_tgt -> shared_rel)
        ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt
    :
    bi_entails
      (P ** isim r g Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
      (isim r g (fun r_src r_tgt ths im_src im_tgt st_src st_tgt =>
                   P ** Q r_src r_tgt ths im_src im_tgt st_src st_tgt)
            ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
  .
  Proof.
    iIntros "[H0 H1]". iApply isim_wand. iFrame.
    iIntros. iModIntro. iFrame.
  Qed.

  Lemma isim_bind r g R_src R_tgt S_src S_tgt
        (Q: R_src -> R_tgt -> shared_rel)
        ps pt
        (itr_src: itree srcE S_src) (itr_tgt: itree tgtE S_tgt)
        ktr_src ktr_tgt
        ths im_src im_tgt st_src st_tgt
    :
    bi_entails
      (isim r g (fun s_src s_tgt ths im_src im_tgt st_src st_tgt =>
                   isim r g Q false false (ktr_src s_src) (ktr_tgt s_tgt) ths im_src im_tgt st_src st_tgt) ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
      (isim r g Q ps pt (itr_src >>= ktr_src) (itr_tgt >>= ktr_tgt) ths im_src im_tgt st_src st_tgt)
  .
  Proof.
    rr. autorewrite with iprop. i.
    ii. eapply gpaco9_uclo; [auto with paco|apply lsim_bindC_spec|].
    econs.
    eapply gpaco9_uclo; [auto with paco|apply lsim_monoC_spec|].
    econs.
    2:{ eapply H; eauto. }
    unfold liftRR. i. des_ifs. des.
    eapply gpaco9_uclo; [auto with paco|apply lsim_monoC_spec|].
    econs.
    2:{ eapply RET0; eauto. }
    unfold liftRR. i. des_ifs.
  Qed.

  Lemma isim_ret r g R_src R_tgt
        (Q: R_src -> R_tgt -> shared_rel)
        ps pt
        r_src r_tgt ths im_src im_tgt st_src st_tgt
    :
    bi_entails
      (Q r_src r_tgt ths im_src im_tgt st_src st_tgt)
      (isim r g Q ps pt (Ret r_src) (Ret r_tgt) ths im_src im_tgt st_src st_tgt)
  .
  Proof.
    rr. autorewrite with iprop. i.
    ii. muclo lsim_indC_spec.
    eapply lsim_ret. unfold liftRR. esplits; eauto.
  Qed.

  Lemma isim_tauL r g R_src R_tgt
        (Q: R_src -> R_tgt -> shared_rel)
        ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt
    :
    bi_entails
      (isim r g Q true pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
      (isim r g Q ps pt (Tau itr_src) itr_tgt ths im_src im_tgt st_src st_tgt)
  .
  Proof.
    rr. autorewrite with iprop. i.
    ii. muclo lsim_indC_spec.
    eapply lsim_tauL. muclo lsim_resetC_spec. econs; eauto.
  Qed.

  Lemma isim_tauR r g R_src R_tgt
        (Q: R_src -> R_tgt -> shared_rel)
        ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt
    :
    bi_entails
      (isim r g Q ps true itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
      (isim r g Q ps pt itr_src (Tau itr_tgt) ths im_src im_tgt st_src st_tgt)
  .
  Proof.
    rr. autorewrite with iprop. i.
    ii. muclo lsim_indC_spec.
    eapply lsim_tauR. muclo lsim_resetC_spec. econs; eauto.
  Qed.

  Lemma isim_chooseL X r g R_src R_tgt
        (Q: R_src -> R_tgt -> shared_rel)
        ps pt ktr_src itr_tgt ths im_src im_tgt st_src st_tgt
    :
    bi_entails
      (∃ x, isim r g Q true pt (ktr_src x) itr_tgt ths im_src im_tgt st_src st_tgt)
      (isim r g Q ps pt (trigger (Choose X) >>= ktr_src) itr_tgt ths im_src im_tgt st_src st_tgt)
  .
  Proof.
    rr. autorewrite with iprop. i.
    ii. muclo lsim_indC_spec.
    eapply lsim_chooseL.
    rr in H. autorewrite with iprop in H. des.
    esplits; eauto.
  Qed.

  Lemma isim_chooseR X r g R_src R_tgt
        (Q: R_src -> R_tgt -> shared_rel)
        ps pt itr_src ktr_tgt ths im_src im_tgt st_src st_tgt
    :
    bi_entails
      (∀ x, isim r g Q ps true itr_src (ktr_tgt x) ths im_src im_tgt st_src st_tgt)
      (isim r g Q ps pt itr_src (trigger (Choose X) >>= ktr_tgt) ths im_src im_tgt st_src st_tgt)
  .
  Proof.
    rr. autorewrite with iprop. i.
    ii. muclo lsim_indC_spec.
    eapply lsim_chooseR.
    rr in H. autorewrite with iprop in H.
    i. econs; [eapply H|..]; eauto.
  Qed.

  Lemma isim_rmwL X rmw r g R_src R_tgt
    (Q : R_src -> R_tgt -> shared_rel)
    ps pt ktr_src itr_tgt ths im_src im_tgt st_src st_tgt
    : bi_entails
        (isim r g Q true pt (ktr_src (snd (rmw st_src) : X)) itr_tgt ths im_src im_tgt (fst (rmw st_src)) st_tgt)
        (isim r g Q ps pt (trigger (Rmw rmw) >>= ktr_src) itr_tgt ths im_src im_tgt st_src st_tgt).
  Proof.
    rr. autorewrite with iprop. i.
    ii. muclo lsim_indC_spec.
    eapply lsim_rmwL. muclo lsim_resetC_spec. econs; [eapply H|..]; eauto.
  Qed.

  Lemma isim_rmwR X rmw r g R_src R_tgt
    (Q : R_src -> R_tgt -> shared_rel)
    ps pt itr_src ktr_tgt ths im_src im_tgt st_src st_tgt
    : bi_entails
        (isim r g Q ps true itr_src (ktr_tgt (snd (rmw st_tgt) : X)) ths im_src im_tgt st_src (fst (rmw st_tgt)))
        (isim r g Q ps pt itr_src (trigger (Rmw rmw) >>= ktr_tgt) ths im_src im_tgt st_src st_tgt).
  Proof.
    rr. autorewrite with iprop. i.
    ii. muclo lsim_indC_spec.
    eapply lsim_rmwR. muclo lsim_resetC_spec. econs; [eapply H|..]; eauto.
  Qed.

  Lemma isim_tidL r g R_src R_tgt
        (Q: R_src -> R_tgt -> shared_rel)
        ps pt ktr_src itr_tgt ths im_src im_tgt st_src st_tgt
    :
    bi_entails
      (isim r g Q true pt (ktr_src tid) itr_tgt ths im_src im_tgt st_src st_tgt)
      (isim r g Q ps pt (trigger GetTid >>= ktr_src) itr_tgt ths im_src im_tgt st_src st_tgt)
  .
  Proof.
    rr. autorewrite with iprop. i.
    ii. muclo lsim_indC_spec.
    eapply lsim_tidL. muclo lsim_resetC_spec. econs; [eapply H|..]; eauto.
  Qed.

  Lemma isim_tidR r g R_src R_tgt
        (Q: R_src -> R_tgt -> shared_rel)
        ps pt itr_src ktr_tgt ths im_src im_tgt st_src st_tgt
    :
    bi_entails
      (isim r g Q ps true itr_src (ktr_tgt tid) ths im_src im_tgt st_src st_tgt)
      (isim r g Q ps pt itr_src (trigger GetTid >>= ktr_tgt) ths im_src im_tgt st_src st_tgt)
  .
  Proof.
    rr. autorewrite with iprop. i.
    ii. muclo lsim_indC_spec.
    eapply lsim_tidR. muclo lsim_resetC_spec. econs; [eapply H|..]; eauto.
  Qed.

  Lemma isim_fairL f r g R_src R_tgt
        (Q: R_src -> R_tgt -> shared_rel)
        ps pt ktr_src itr_tgt ths im_src0 im_tgt st_src st_tgt
    :
    bi_entails
      (∃ im_src1, ⌜fair_update im_src0 im_src1 f⌝ ∧ isim r g Q true pt (ktr_src tt) itr_tgt ths im_src1 im_tgt st_src st_tgt)
      (isim r g Q ps pt (trigger (Fair f) >>= ktr_src) itr_tgt ths im_src0 im_tgt st_src st_tgt)
  .
  Proof.
    rr. autorewrite with iprop. i.
    ii. muclo lsim_indC_spec.
    eapply lsim_fairL.
    rr in H. autorewrite with iprop in H. des.
    rr in H. autorewrite with iprop in H. des.
    rr in H. autorewrite with iprop in H.
    esplits; eauto.
  Qed.

  Lemma isim_fairR f r g R_src R_tgt
        (Q: R_src -> R_tgt -> shared_rel)
        ps pt itr_src ktr_tgt ths im_src im_tgt0 st_src st_tgt
    :
    bi_entails
      (∀ im_tgt1, ⌜fair_update im_tgt0 im_tgt1 (prism_fmap inrp f)⌝ -* isim r g Q ps true itr_src (ktr_tgt tt) ths im_src im_tgt1 st_src st_tgt)
      (isim r g Q ps pt itr_src (trigger (Fair f) >>= ktr_tgt) ths im_src im_tgt0 st_src st_tgt)
  .
  Proof.
    rr. autorewrite with iprop. i.
    ii. muclo lsim_indC_spec.
    eapply lsim_fairR. i.
    rr in H. autorewrite with iprop in H.
    hexploit H; eauto. i.
    rr in H0. autorewrite with iprop in H0.
    hexploit (H0 URA.unit); eauto.
    { rewrite URA.unit_id. eapply URA.wf_mon; eauto. }
    { rr. autorewrite with iprop. eauto. }
    i. muclo lsim_resetC_spec. econs; [eapply H1|..]; eauto. r_wf WF0.
  Qed.

  Lemma isim_UB r g R_src R_tgt
        (Q: R_src -> R_tgt -> shared_rel)
        ps pt ktr_src itr_tgt ths im_src im_tgt st_src st_tgt
    :
    bi_entails
      (True)
      (isim r g Q ps pt (trigger Undefined >>= ktr_src) itr_tgt ths im_src im_tgt st_src st_tgt)
  .
  Proof.
    rr. autorewrite with iprop. i.
    ii. muclo lsim_indC_spec.
    eapply lsim_UB.
  Qed.

  Lemma isim_observe fn args r g R_src R_tgt
        (Q: R_src -> R_tgt -> shared_rel)
        ps pt ktr_src ktr_tgt ths im_src im_tgt st_src st_tgt
    :
    bi_entails
      (∀ ret, isim g g Q true true (ktr_src ret) (ktr_tgt ret) ths im_src im_tgt st_src st_tgt)
      (isim r g Q ps pt (trigger (Observe fn args) >>= ktr_src) (trigger (Observe fn args) >>= ktr_tgt) ths im_src im_tgt st_src st_tgt)
  .
  Proof.
    rr. autorewrite with iprop. i.
    ii. gstep. rr. eapply pind9_fold.
    eapply lsim_observe; eauto.
    i. rr in H. autorewrite with iprop in H.
    muclo lsim_resetC_spec. econs; [eapply H|..]; eauto.
  Qed.

  Lemma isim_yieldL r g R_src R_tgt
        (Q: R_src -> R_tgt -> shared_rel)
        ps pt ktr_src ktr_tgt ths im_src im_tgt st_src st_tgt
    :
    bi_entails
      (isim r g Q true pt (ktr_src tt) (trigger (Yield) >>= ktr_tgt) ths im_src im_tgt st_src st_tgt)
      (isim r g Q ps pt (trigger (Yield) >>= ktr_src) (trigger (Yield) >>= ktr_tgt) ths im_src im_tgt st_src st_tgt)
  .
  Proof.
    rr. autorewrite with iprop. i.
    ii. muclo lsim_indC_spec.
    eapply lsim_yieldL. muclo lsim_resetC_spec. econs; [eapply H|..]; eauto.
  Qed.

  Lemma isim_yieldR r g R_src R_tgt
        (Q: R_src -> R_tgt -> shared_rel)
        ps pt ktr_src ktr_tgt ths0 im_src0 im_tgt0 st_src0 st_tgt0
    :
    bi_entails
      (I ths0 im_src0 im_tgt0 st_src0 st_tgt0 ** (∀ ths1 im_src1 im_tgt1 st_src1 st_tgt1 im_tgt2, I ths1 im_src1 im_tgt1 st_src1 st_tgt1 -* ⌜fair_update im_tgt1 im_tgt2 (prism_fmap inlp (tids_fmap tid ths1))⌝ -* isim r g Q ps true (trigger (Yield) >>= ktr_src) (ktr_tgt tt) ths1 im_src1 im_tgt2 st_src1 st_tgt1))
      (isim r g Q ps pt (trigger (Yield) >>= ktr_src) (trigger (Yield) >>= ktr_tgt) ths0 im_src0 im_tgt0 st_src0 st_tgt0)
  .
  Proof.
    rr. autorewrite with iprop. i.
    rr in H. autorewrite with iprop in H. des. subst.
    ii. muclo lsim_indC_spec.
    eapply lsim_yieldR; eauto.
    { rewrite Lwf. repeat rewrite Ladd. eauto. }
    i. rr in H1. autorewrite with iprop in H1. specialize (H1 ths1).
    rr in H1. autorewrite with iprop in H1. specialize (H1 im_src1).
    rr in H1. autorewrite with iprop in H1. specialize (H1 im_tgt1).
    rr in H1. autorewrite with iprop in H1. specialize (H1 st_src1).
    rr in H1. autorewrite with iprop in H1. specialize (H1 st_tgt1).
    rr in H1. autorewrite with iprop in H1. specialize (H1 im_tgt2).
    rr in H1. autorewrite with iprop in H1.
    hexploit (H1 r_shared1); eauto.
    { eapply URA.wf_mon. instantiate (1:=r_ctx1). rewrite Lwf in VALID. r_wf VALID.
      repeat rewrite Ladd. r_solve.
    }
    i. rr in H. autorewrite with iprop in H. hexploit (H URA.unit); eauto.
    { eapply URA.wf_mon. instantiate (1:=r_ctx1).
      rewrite Lwf in VALID. r_wf VALID.
      repeat rewrite Ladd. r_solve.
    }
    { rr. autorewrite with iprop. eauto. }
    i. muclo lsim_resetC_spec. econs; [eapply H2|..]; eauto.
    rewrite Lwf in VALID. r_wf VALID.
    repeat rewrite Ladd. r_solve.
  Qed.

  Lemma isim_sync r g R_src R_tgt
        (Q: R_src -> R_tgt -> shared_rel)
        ps pt ktr_src ktr_tgt ths0 im_src0 im_tgt0 st_src0 st_tgt0
    :
    bi_entails
      (I ths0 im_src0 im_tgt0 st_src0 st_tgt0 ** (∀ ths1 im_src1 im_tgt1 st_src1 st_tgt1 im_tgt2, I ths1 im_src1 im_tgt1 st_src1 st_tgt1 -* ⌜fair_update im_tgt1 im_tgt2 (prism_fmap inlp (tids_fmap tid ths1))⌝ -* isim g g Q true true (ktr_src tt) (ktr_tgt tt) ths1 im_src1 im_tgt2 st_src1 st_tgt1))
      (isim r g Q ps pt (trigger (Yield) >>= ktr_src) (trigger (Yield) >>= ktr_tgt) ths0 im_src0 im_tgt0 st_src0 st_tgt0)
  .
  Proof.
    rr. autorewrite with iprop. i.
    rr in H. autorewrite with iprop in H. des. subst.
    ii. gstep. eapply pind9_fold. eapply lsim_sync; eauto. i.
    { rewrite Lwf. repeat rewrite Ladd. eauto. }
    i.
    rr in H1. autorewrite with iprop in H1. specialize (H1 ths1).
    rr in H1. autorewrite with iprop in H1. specialize (H1 im_src1).
    rr in H1. autorewrite with iprop in H1. specialize (H1 im_tgt1).
    rr in H1. autorewrite with iprop in H1. specialize (H1 st_src1).
    rr in H1. autorewrite with iprop in H1. specialize (H1 st_tgt1).
    rr in H1. autorewrite with iprop in H1. specialize (H1 im_tgt2).
    rr in H1. autorewrite with iprop in H1.
    hexploit (H1 r_shared1); eauto.
    { eapply URA.wf_mon. instantiate (1:=r_ctx1).
      rewrite Lwf in VALID. r_wf VALID.
      repeat rewrite Ladd. r_solve.
    }
    i. rr in H. autorewrite with iprop in H. hexploit (H URA.unit); eauto.
    { eapply URA.wf_mon. instantiate (1:=r_ctx1).
      rewrite Lwf in VALID. r_wf VALID.
      repeat rewrite Ladd. r_solve.
    }
    { rr. autorewrite with iprop. eauto. }
    i. muclo lsim_resetC_spec. econs; [eapply H2|..]; eauto.
    rewrite Lwf in VALID. r_wf VALID.
    repeat rewrite Ladd. r_solve.
  Qed.

  Lemma isim_base r g R_src R_tgt
        (Q: R_src -> R_tgt -> shared_rel)
        ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt
    :
    bi_entails
      (@r _ _ Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
      (isim r g Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
  .
  Proof.
    rr. autorewrite with iprop.
    ii. gbase. econs; eauto.
  Qed.

  Lemma isim_reset r g R_src R_tgt
        (Q: R_src -> R_tgt -> shared_rel)
        ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt
    :
    bi_entails
      (isim r g Q false false itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
      (isim r g Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
  .
  Proof.
    rr. autorewrite with iprop. i.
    ii. rr in H. muclo lsim_resetC_spec. econs; [eapply H|..]; eauto.
  Qed.

  Lemma isim_progress r g R_src R_tgt
        (Q: R_src -> R_tgt -> shared_rel)
        itr_src itr_tgt ths im_src im_tgt st_src st_tgt
    :
    bi_entails
      (isim g g Q false false itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
      (isim r g Q true true itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
  .
  Proof.
    rr. autorewrite with iprop. i.
    ii. gstep. rr. eapply pind9_fold.
    eapply lsim_progress; eauto.
  Qed.

  Lemma unlift_mon (r0 r1: rel)
        (MON: forall R_src R_tgt (Q: R_src -> R_tgt -> shared_rel)
                     ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt,
            bi_entails
              (@r0 _ _ Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
              (#=> (@r1 _ _ Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt)))
    :
    unlift r0 <9= unlift r1.
  Proof.
    i. dependent destruction PR.
    hexploit MON; eauto. i.
    rr in H. autorewrite with iprop in H.
    hexploit H; [|eauto|..].
    { eapply URA.wf_mon. eauto. }
    i. rr in H0. autorewrite with iprop in H0.
    hexploit H0; eauto. i. des. econs; eauto.
  Qed.

  Lemma isim_mono_knowledge (r0 g0 r1 g1: rel) R_src R_tgt
        (Q: R_src -> R_tgt -> shared_rel)
        ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt
        (MON0: forall R_src R_tgt (Q: R_src -> R_tgt -> shared_rel)
                      ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt,
            bi_entails
              (@r0 _ _ Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
              (#=> (@r1 _ _ Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt)))
        (MON1: forall R_src R_tgt (Q: R_src -> R_tgt -> shared_rel)
                      ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt,
            bi_entails
              (@g0 _ _ Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
              (#=> (@g1 _ _ Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt)))
    :
    bi_entails
      (isim r0 g0 Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
      (isim r1 g1 Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
  .
  Proof.
    rr. autorewrite with iprop. i.
    ii. rr in H. hexploit H; eauto. i.
    eapply gpaco9_mon; eauto.
    { eapply unlift_mon; eauto. }
    { eapply unlift_mon; eauto. }
  Qed.

  Lemma isim_coind A
        (R_src: forall (a: A), Type)
        (R_tgt: forall (a: A), Type)
        (Q: forall (a: A), R_src a -> R_tgt a -> shared_rel)
        (ps pt: forall (a: A), bool)
        (itr_src : forall (a: A), itree srcE (R_src a))
        (itr_tgt : forall (a: A), itree tgtE (R_tgt a))
        (ths: forall (a: A), TIdSet.t)
        (im_src: forall (a: A), imap ident_src wf_src)
        (im_tgt: forall (a: A), imap (sum_tid ident_tgt) nat_wf)
        (st_src: forall (a: A), state_src)
        (st_tgt: forall (a: A), state_tgt)
        (P: forall (a: A), iProp)
        (r g0: rel)
        (COIND: forall (g1: rel) a, bi_entails (□((∀ R_src R_tgt (Q: R_src -> R_tgt -> shared_rel)
                                                     ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt,
                                                      @g0 R_src R_tgt Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt -* @g1 R_src R_tgt Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
                                                    **
                                                    (∀ a, P a -* @g1 (R_src a) (R_tgt a) (Q a) (ps a) (pt a) (itr_src a) (itr_tgt a) (ths a) (im_src a) (im_tgt a) (st_src a) (st_tgt a))) ** P a) (isim r g1 (Q a) (ps a) (pt a) (itr_src a) (itr_tgt a) (ths a) (im_src a) (im_tgt a) (st_src a) (st_tgt a)))
    :
    (forall a, bi_entails (P a) (isim r g0 (Q a) (ps a) (pt a) (itr_src a) (itr_tgt a) (ths a) (im_src a) (im_tgt a) (st_src a) (st_tgt a))).
  Proof.
    i. rr. autorewrite with iprop. ii. clear WF.
    revert a r0 H r_ctx WF0. gcofix CIH. i.
    epose (fun R_src R_tgt (Q: R_src -> R_tgt -> shared_rel)
               ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt =>
             @iProp_intro _ (fun r_own => forall r_ctx (WF: URA.wf (r_own ⋅ r_ctx)),
                                 gpaco9 gf (cpn9 gf) r0 r0 R_src R_tgt (liftRR Q) ps pt r_ctx itr_src itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)) _).
    hexploit (COIND i a). subst i. clear COIND. i.
    rr in H. autorewrite with iprop in H. hexploit H.
    { instantiate (1:=r1). eapply URA.wf_mon; eauto. }
    { rr. autorewrite with iprop.
      exists URA.unit, r1. splits; auto.
      { r_solve. }
      rr. autorewrite with iprop. esplits.
      { rr. autorewrite with iprop. ss. }
      rr. autorewrite with iprop.
      rr. autorewrite with iprop.
      exists URA.unit, URA.unit. splits.
      { rewrite URA.unit_core. r_solve. }
      { do 13 (rr; autorewrite with iprop; i).
        ss. i. gbase. eapply CIH0. econs; eauto. r_wf WF.
      }
      { do 2 (rr; autorewrite with iprop; i).
        ss. i. gbase. eapply CIH; eauto. r_wf WF.
      }
    }
    clear H. i. eapply gpaco9_gpaco.
    { auto. }
    eapply gpaco9_mon.
    { eapply H. eauto. }
    { i. gbase. eauto. }
    { i. dependent destruction PR. subst.
      rr in REL. eapply gpaco9_mon.
      { eapply REL; eauto. }
      { eauto. }
      { eauto. }
    }
    Unshelve.
    { i. ss. i. eapply H; eauto.
      eapply URA.wf_extends; eauto. eapply URA.extends_add; eauto.
    }
  Qed.

End SIM.

From Fairness Require Export NatMapRALarge StateRA FairRA MonotonePCM.
Require Import Coq.Sorting.Mergesort.

Section STATE.
  Context `{Σ: GRA.t}.

  Variable state_src: Type.
  Variable state_tgt: Type.

  Variable ident_src: ID.
  Variable ident_tgt: ID.

  Let srcE := programE ident_src state_src.
  Let tgtE := programE ident_tgt state_tgt.

  Let shared_rel := TIdSet.t -> (@imap ident_src owf) -> (@imap (sum_tid ident_tgt) nat_wf) -> state_src -> state_tgt -> iProp.

  Variable Invs: list iProp.

  Definition topset: mset := List.seq 0 (List.length Invs).

  Context `{MONORA: @GRA.inG monoRA Σ}.
  Context `{THDRA: @GRA.inG ThreadRA Σ}.
  Context `{STATESRC: @GRA.inG (stateSrcRA state_src) Σ}.
  Context `{STATETGT: @GRA.inG (stateTgtRA state_tgt) Σ}.
  Context `{IDENTSRC: @GRA.inG (identSrcRA ident_src) Σ}.
  Context `{IDENTTGT: @GRA.inG (identTgtRA ident_tgt) Σ}.
  Context `{OBLGRA: @GRA.inG ObligationRA.t Σ}.
  Context `{ARROWRA: @GRA.inG (ArrowRA ident_tgt) Σ}.
  Context `{EDGERA: @GRA.inG EdgeRA Σ}.
  Context `{ONESHOTRA: @GRA.inG (@FiniteMap.t (OneShot.t unit)) Σ}.

  Definition St_src (st_src: state_src): iProp :=
    OwnM (Auth.white (Excl.just (Some st_src): @Excl.t (option state_src)): stateSrcRA state_src).

  Definition St_tgt (st_tgt: state_tgt): iProp :=
    OwnM (Auth.white (Excl.just (Some st_tgt): @Excl.t (option state_tgt)): stateTgtRA state_tgt).

  Definition default_initial_res
    : Σ :=
    (@GRA.embed _ _ THDRA (Auth.black (Some (NatMap.empty unit): NatMapRALarge.t unit)))
      ⋅
      (@GRA.embed _ _ STATESRC (Auth.black (Excl.just None: @Excl.t (option state_src)) ⋅ (Auth.white (Excl.just None: @Excl.t (option state_src)): stateSrcRA state_src)))
      ⋅
      (@GRA.embed _ _ STATETGT (Auth.black (Excl.just None: @Excl.t (option state_tgt)) ⋅ (Auth.white (Excl.just None: @Excl.t (option state_tgt)): stateTgtRA state_tgt)))
      ⋅
      (@GRA.embed _ _ IDENTSRC (@FairRA.source_init_resource ident_src))
      ⋅
      (@GRA.embed _ _ IDENTTGT ((fun _ => Fuel.black 0 1%Qp): identTgtRA ident_tgt))
      ⋅
      (@GRA.embed _ _ ARROWRA ((fun _ => OneShot.pending _ 1%Qp): ArrowRA ident_tgt))
      ⋅
      (@GRA.embed _ _ EDGERA ((fun _ => OneShot.pending _ 1%Qp): EdgeRA))
  .

  Lemma duty_to_black
        (i: id_sum nat ident_tgt)
    :
    (ObligationRA.duty i [])
      -∗
      FairRA.black_ex i 1%Qp.
  Proof.
    iIntros "[% [% [[H0 [H1 %]] %]]]". destruct rs; ss. subst. auto.
  Qed.

  Lemma black_to_duty
        (i: id_sum nat ident_tgt)
    :
    (FairRA.black_ex i 1%Qp)
      -∗
      (ObligationRA.duty i []).
  Proof.
    iIntros "H". iExists _, _. iFrame. iSplit.
    { iSplit.
      { iApply list_prop_sum_nil. }
      { auto. }
    }
    { auto. }
  Qed.

  Lemma own_threads_init ths
    :
    (OwnM (Auth.black (Some (NatMap.empty unit): NatMapRALarge.t unit)))
      -∗
      (#=>
         ((OwnM (Auth.black (Some ths: NatMapRALarge.t unit)))
            **
            (natmap_prop_sum ths (fun tid _ => own_thread tid)))).
  Proof.
    pattern ths. revert ths. eapply nm_ind.
    { iIntros "OWN". iModIntro. iFrame. }
    i. iIntros "OWN".
    iPoseProof (IH with "OWN") as "> [OWN SUM]".
    iPoseProof (OwnM_Upd with "OWN") as "> [OWN0 OWN1]".
    { eapply Auth.auth_alloc. eapply (@NatMapRALarge.add_local_update unit m k v); eauto. }
    iModIntro. iFrame. destruct v. iApply (natmap_prop_sum_add with "SUM OWN1").
  Qed.

  Lemma default_initial_res_init
    :
    (Own (default_initial_res))
      -∗
      (∀ ths st_src st_tgt im_tgt o,
          #=> (∃ im_src,
                  (default_I ths im_src im_tgt st_src st_tgt)
                    **
                    (natmap_prop_sum ths (fun tid _ => ObligationRA.duty (inl tid) []))
                    **
                    (natmap_prop_sum ths (fun tid _ => own_thread tid))
                    **
                    (FairRA.whites (fun _ => True: Prop) o)
                    **
                    (FairRA.blacks (fun i => match i with | inr _ => True | _ => False end: Prop))
                    **
                    (St_src st_src)
                    **
                    (St_tgt st_tgt)
      )).
  Proof.
    iIntros "OWN" (? ? ? ? ?).
    iDestruct "OWN" as "[[[[[[OWN0 [OWN1 OWN2]] [OWN3 OWN4]] OWN5] OWN6] OWN7] OWN8]".
    iPoseProof (black_white_update with "OWN1 OWN2") as "> [OWN1 OWN2]".
    iPoseProof (black_white_update with "OWN3 OWN4") as "> [OWN3 OWN4]".
    iPoseProof (OwnM_Upd with "OWN6") as "> OWN6".
    { instantiate (1:=FairRA.target_init_resource im_tgt).
      unfold FairRA.target_init_resource.
      erewrite ! (@unfold_pointwise_add (id_sum nat ident_tgt) (Fuel.t nat)).
      apply pointwise_updatable. i.
      rewrite URA.add_comm. exact (@Fuel.success_update nat _ 0 (im_tgt a)).
    }
    iPoseProof (FairRA.target_init with "OWN6") as "[[H0 H1] H2]".
    iPoseProof (FairRA.source_init with "OWN5") as "> [% [H3 H4]]".
    iExists f. unfold default_I. iFrame.
    iPoseProof (own_threads_init with "OWN0") as "> [OWN0 H]". iFrame.
    iModIntro. iSplitR "H1"; [iSplitL "OWN8"|].
    { iExists _. iSplitL.
      { iApply (OwnM_extends with "OWN8"). instantiate (1:=[]).
        apply pointwise_extends. i. destruct a; ss; reflexivity.
      }
      { ss. }
    }
    { iExists _. iSplitL.
      { iApply (OwnM_extends with "OWN7"). instantiate (1:=[]).
        apply pointwise_extends. i. destruct a; ss; reflexivity.
      }
      { ss. }
    }
    { iApply natmap_prop_sum_impl; [|eauto]. i. ss. iApply black_to_duty. }
  Qed.

  Let I: shared_rel :=
        fun ths im_src im_tgt st_src st_tgt =>
          default_I ths im_src im_tgt st_src st_tgt ** mset_all (nth_default True%I Invs) topset.

  Let rel := (forall R_src R_tgt (Q: R_src -> R_tgt -> iProp), bool -> bool -> itree srcE R_src -> itree tgtE R_tgt -> iProp).

  Variable tid: thread_id.

  Let unlift_rel
      (r: forall R_src R_tgt (Q: R_src -> R_tgt -> shared_rel), bool -> bool -> itree srcE R_src -> itree tgtE R_tgt -> shared_rel): rel :=
        fun R_src R_tgt Q ps pt itr_src itr_tgt =>
          (∀ ths im_src im_tgt st_src st_tgt,
              (default_I_past tid ths im_src im_tgt st_src st_tgt ** mset_all (nth_default True%I Invs) topset)
                -*
                (@r R_src R_tgt (fun r_src r_tgt ths im_src im_tgt st_src st_tgt => (default_I_past tid ths im_src im_tgt st_src st_tgt ** mset_all (nth_default True%I Invs) topset) ** Q r_src r_tgt) ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt))%I.

  Let lift_rel (rr: rel):
    forall R_src R_tgt (QQ: R_src -> R_tgt -> shared_rel), bool -> bool -> itree srcE R_src -> itree tgtE R_tgt -> shared_rel :=
        fun R_src R_tgt QQ ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt =>
          (∃ (Q: R_src -> R_tgt -> iProp)
             (EQ: QQ = (fun r_src r_tgt ths im_src im_tgt st_src st_tgt =>
                          (default_I_past tid ths im_src im_tgt st_src st_tgt ** mset_all (nth_default True%I Invs) topset) ** Q r_src r_tgt)),
              rr R_src R_tgt Q ps pt itr_src itr_tgt ** (default_I_past tid ths im_src im_tgt st_src st_tgt ** mset_all (nth_default True%I Invs) topset))%I.

  Let unlift_rel_base r
    :
    forall R_src R_tgt Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt,
      (r R_src R_tgt Q ps pt itr_src itr_tgt)
        -∗
        (default_I_past tid ths im_src im_tgt st_src st_tgt ** mset_all (nth_default True%I Invs) topset)
        -∗
        (lift_rel
           r
           (fun r_src r_tgt ths im_src im_tgt st_src st_tgt => (default_I_past tid ths im_src im_tgt st_src st_tgt ** mset_all (nth_default True%I Invs) topset) ** Q r_src r_tgt)
           ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt).
  Proof.
    unfold lift_rel, unlift_rel. i.
    iIntros "H D". iExists _, _. Unshelve.
    { iFrame. }
    { auto. }
  Qed.

  Let unlift_lift r
    :
    forall R_src R_tgt Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt,
      (lift_rel (unlift_rel r) Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
        ⊢ (r R_src R_tgt Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt).
  Proof.
    unfold lift_rel, unlift_rel. i.
    iIntros "[% [% [H D]]]". subst.
    iApply ("H" with "D").
  Qed.

  Let lift_unlift (r0: rel) (r1: forall R_src R_tgt (Q: R_src -> R_tgt -> shared_rel), bool -> bool -> itree srcE R_src -> itree tgtE R_tgt -> shared_rel)
    :
    bi_entails
      (∀ R_src R_tgt (Q: R_src -> R_tgt -> shared_rel) ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt,
          @lift_rel r0 R_src R_tgt Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt -* r1 R_src R_tgt Q ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
      (∀ R_src R_tgt Q ps pt itr_src itr_tgt, r0 R_src R_tgt Q ps pt itr_src itr_tgt -* unlift_rel r1 Q ps pt itr_src itr_tgt).
  Proof.
    unfold lift_rel, unlift_rel.
    iIntros "IMPL" (? ? ? ? ? ? ?) "H". iIntros (? ? ? ? ?) "D".
    iApply "IMPL". iExists _, _. Unshelve.
    { iFrame. }
    { auto. }
  Qed.

  Let lift_rel_mon (rr0 rr1: rel)
      (MON: forall R_src R_tgt Q ps pt itr_src itr_tgt,
          bi_entails
            (rr0 R_src R_tgt Q ps pt itr_src itr_tgt)
            (#=> rr1 R_src R_tgt Q ps pt itr_src itr_tgt))
    :
    forall R_src R_tgt (QQ: R_src -> R_tgt -> shared_rel) ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt,
      bi_entails
        (lift_rel rr0 QQ ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt)
        (#=> lift_rel rr1 QQ ps pt itr_src itr_tgt ths im_src im_tgt st_src st_tgt).
  Proof.
    unfold lift_rel. i.
    iIntros "[% [% [H D]]]". subst.
    iPoseProof (MON with "H") as "> H".
    iModIntro. iExists _, _. Unshelve.
    { iFrame. }
    { auto. }
  Qed.

  Definition stsim (E: mset): rel -> rel -> rel :=
    fun r g
        R_src R_tgt Q ps pt itr_src itr_tgt =>
      (∀ ths im_src im_tgt st_src st_tgt,
          (default_I_past tid ths im_src im_tgt st_src st_tgt ** mset_all (nth_default True%I Invs) E)
            -*
            (isim
               tid
               I
               (lift_rel r)
               (lift_rel g)
               (fun r_src r_tgt ths im_src im_tgt st_src st_tgt => (default_I_past tid ths im_src im_tgt st_src st_tgt ** mset_all (nth_default True%I Invs) topset) ** Q r_src r_tgt)
               ps pt itr_src itr_tgt
               ths im_src im_tgt st_src st_tgt))%I
  .

  Record mytype
         (A: Type) :=
    mk_mytype {
        comp_a: A;
        comp_ths: TIdSet.t;
        comp_im_src: imap ident_src owf;
        comp_im_tgt: imap (sum_tid ident_tgt) nat_wf;
        comp_st_src: state_src;
        comp_st_tgt: state_tgt;
      }.

  Lemma stsim_discard E1 E0 r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt itr_src itr_tgt
        (TOP: mset_sub E0 E1)
    :
    (stsim E0 r g Q ps pt itr_src itr_tgt)
      -∗
      (stsim E1 r g Q ps pt itr_src itr_tgt)
  .
  Proof.
    unfold stsim. iIntros "H" (? ? ? ? ?) "[D I]".
    iPoseProof (mset_all_sub with "I") as "[I RESTORE]"; [eauto|].
    iPoseProof ("H" with "[D I]") as "H".
    { iFrame. }
    iApply isim_wand. iFrame.
    iIntros (? ? ? ? ? ? ?) "[[D I] Q]".
    iModIntro. iFrame.
  Qed.

  Lemma stsim_base E r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt itr_src itr_tgt
        (TOP: mset_sub topset E)
    :
    (@r _ _ Q ps pt itr_src itr_tgt)
      -∗
      (stsim E r g Q ps pt itr_src itr_tgt)
  .
  Proof.
    rewrite <- stsim_discard; [|eassumption].
    unfold stsim. iIntros "H" (? ? ? ? ?) "D".
    iApply isim_base.
    iApply (unlift_rel_base with "H D").
  Qed.

  Lemma stsim_mono_knowledge E (r0 g0 r1 g1: rel) R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt itr_src itr_tgt
        (MON0: forall R_src R_tgt (Q: R_src -> R_tgt -> iProp)
                      ps pt itr_src itr_tgt,
            (@r0 _ _ Q ps pt itr_src itr_tgt)
              -∗
              (#=> (@r1 _ _ Q ps pt itr_src itr_tgt)))
        (MON1: forall R_src R_tgt (Q: R_src -> R_tgt -> iProp)
                      ps pt itr_src itr_tgt,
            (@g0 _ _ Q ps pt itr_src itr_tgt)
              -∗
              (#=> (@g1 _ _ Q ps pt itr_src itr_tgt)))
    :
    bi_entails
      (stsim E r0 g0 Q ps pt itr_src itr_tgt)
      (stsim E r1 g1 Q ps pt itr_src itr_tgt)
  .
  Proof.
    unfold stsim. iIntros "H" (? ? ? ? ?) "D".
    iApply isim_mono_knowledge.
    { eapply lift_rel_mon. eauto. }
    { eapply lift_rel_mon. eauto. }
    iApply ("H" with "D").
  Qed.

  Lemma stsim_coind E A
        (R_src: forall (a: A), Type)
        (R_tgt: forall (a: A), Type)
        (Q: forall (a: A), R_src a -> R_tgt a -> iProp)
        (ps pt: forall (a: A), bool)
        (itr_src : forall (a: A), itree srcE (R_src a))
        (itr_tgt : forall (a: A), itree tgtE (R_tgt a))
        (P: forall (a: A), iProp)
        (r g0: rel)
        (TOP: mset_sub topset E)
        (COIND: forall (g1: rel) a,
            (□((∀ R_src R_tgt (Q: R_src -> R_tgt -> iProp)
                  ps pt itr_src itr_tgt,
                   @g0 R_src R_tgt Q ps pt itr_src itr_tgt -* @g1 R_src R_tgt Q ps pt itr_src itr_tgt)
                 **
                 (∀ a, P a -* @g1 (R_src a) (R_tgt a) (Q a) (ps a) (pt a) (itr_src a) (itr_tgt a))))
              -∗
              (P a)
              -∗
              (stsim topset r g1 (Q a) (ps a) (pt a) (itr_src a) (itr_tgt a)))
    :
    (forall a, bi_entails (P a) (stsim E r g0 (Q a) (ps a) (pt a) (itr_src a) (itr_tgt a))).
  Proof.
    cut (forall (m: mytype A),
            bi_entails
              ((fun m => P m.(comp_a) ** (default_I_past tid m.(comp_ths) m.(comp_im_src) m.(comp_im_tgt) m.(comp_st_src) m.(comp_st_tgt) ** mset_all (nth_default True%I Invs) topset)) m)
              (isim tid I (lift_rel r) (lift_rel g0) ((fun m => fun r_src r_tgt ths im_src im_tgt st_src st_tgt => (default_I_past tid ths im_src im_tgt st_src st_tgt ** mset_all (nth_default True%I Invs) topset) ** Q m.(comp_a) r_src r_tgt) m)
                    ((fun m => ps m.(comp_a)) m) ((fun m => pt m.(comp_a)) m) ((fun m => itr_src m.(comp_a)) m) ((fun m => itr_tgt m.(comp_a)) m) (comp_ths m) (comp_im_src m) (comp_im_tgt m) (comp_st_src m) (comp_st_tgt m))).
    { ss. i. rewrite <- stsim_discard; [|eassumption].
      unfold stsim. iIntros "H" (? ? ? ? ?) "D".
      specialize (H (mk_mytype a ths im_src im_tgt st_src st_tgt)). ss.
      iApply H. iFrame.
    }
    eapply isim_coind. i. iIntros "[# CIH [H D]]".
    unfold stsim in COIND.
    iAssert (□((∀ R_src R_tgt (Q: R_src -> R_tgt -> iProp)
                  ps pt itr_src itr_tgt,
                   @g0 R_src R_tgt Q ps pt itr_src itr_tgt -* @unlift_rel g1 R_src R_tgt Q ps pt itr_src itr_tgt)
                 **
                 (∀ a, P a -* @unlift_rel g1 (R_src a) (R_tgt a) (Q a) (ps a) (pt a) (itr_src a) (itr_tgt a))))%I with "[CIH]" as "CIH'".
    { iPoseProof "CIH" as "# [CIH0 CIH1]". iModIntro. iSplitL.
      { iApply (lift_unlift with "CIH0"). }
      { iIntros. unfold unlift_rel. iIntros.
        iSpecialize ("CIH1" $! (mk_mytype _ _ _ _ _ _)). ss.
        iApply "CIH1". iFrame.
      }
    }
    iPoseProof (COIND with "CIH' H D") as "H".
    iApply (isim_mono_knowledge with "H").
    { auto. }
    { i. iIntros "H". iModIntro. iApply unlift_lift. auto. }
  Qed.

  Lemma stsim_upd E r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt itr_src itr_tgt
    :
    (#=> (stsim E r g Q ps pt itr_src itr_tgt))
      -∗
      (stsim E r g Q ps pt itr_src itr_tgt)
  .
  Proof.
    unfold stsim. iIntros "H" (? ? ? ? ?) "D". iMod "H".
    iApply "H". auto.
  Qed.

  Global Instance stsim_elim_upd
         E r g R_src R_tgt
         (Q: R_src -> R_tgt -> iProp)
         ps pt itr_src itr_tgt p
         P
    :
    ElimModal True p false (#=> P) P (stsim E r g Q ps pt itr_src itr_tgt) (stsim E r g Q ps pt itr_src itr_tgt).
  Proof.
    typeclasses eauto.
  Qed.

  Lemma stsim_mupd E0 E1 r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt itr_src itr_tgt
    :
    (MUpd (nth_default True%I Invs) (fairI (ident_tgt:=ident_tgt)) E0 E1 (stsim E1 r g Q ps pt itr_src itr_tgt))
      -∗
      (stsim E0 r g Q ps pt itr_src itr_tgt)
  .
  Proof.
    unfold stsim. iIntros "H" (? ? ? ? ?) "[[% [% [[D X0] X1]]] C]".
    iAssert (fairI (ident_tgt:=ident_tgt) ** mset_all (nth_default True%I Invs) E0) with "[X0 X1 C]" as "C".
    { iFrame. }
    iMod ("H" with "C") as "[[[X0 X1] C] H]".
    iApply "H". iFrame. iExists _. iFrame. auto.
  Qed.

  Lemma stsim_mupd_weaken E0 E1 r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt itr_src itr_tgt
        (SUB: mset_sub E0 E1)
    :
    (MUpd (nth_default True%I Invs) (fairI (ident_tgt:=ident_tgt)) E0 E0 (stsim E1 r g Q ps pt itr_src itr_tgt))
      -∗
      (stsim E1 r g Q ps pt itr_src itr_tgt)
  .
  Proof.
    iIntros "H". iApply stsim_mupd. iApply MUpd_mask_mono; eauto.
  Qed.

  Global Instance stsim_elim_mupd_gen
         E0 E1 E2 r g R_src R_tgt
         (Q: R_src -> R_tgt -> iProp)
         ps pt itr_src itr_tgt p
         P
    :
    ElimModal (mset_sub E0 E2) p false (MUpd (nth_default True%I Invs) (fairI (ident_tgt:=ident_tgt)) E0 E1 P) P (stsim E2 r g Q ps pt itr_src itr_tgt) (stsim (NatSort.sort (E1 ++ mset_minus E2 E0)) r g Q ps pt itr_src itr_tgt).
  Proof.
    unfold ElimModal. rewrite bi.intuitionistically_if_elim.
    i. iIntros "[H0 H1]".
    iPoseProof (MUpd_mask_frame_r with "H0") as "H0".
    iPoseProof (MUpd_permutation with "H0") as "H0".
    { eapply mset_minus_add_eq; eauto. }
    { reflexivity. }
    iApply stsim_mupd. iMod "H0".
    iPoseProof ("H1" with "H0") as "H".
    iModIntro. iApply (stsim_discard with "H").
    rewrite <- NatSort.Permuted_sort. reflexivity.
  Qed.

  Global Instance stsim_elim_mupd_eq
         E1 E2 r g R_src R_tgt
         (Q: R_src -> R_tgt -> iProp)
         ps pt itr_src itr_tgt p
         P
    :
    ElimModal (mset_sub E1 E2) p false (MUpd (nth_default True%I Invs) (fairI (ident_tgt:=ident_tgt)) E1 E1 P) P (stsim E2 r g Q ps pt itr_src itr_tgt) (stsim E2 r g Q ps pt itr_src itr_tgt).
  Proof.
    unfold ElimModal. rewrite bi.intuitionistically_if_elim.
    i. iIntros "[H0 H1]".
    iApply stsim_mupd_weaken.
    { eauto. }
    iMod "H0". iModIntro. iApply ("H1" with "H0").
  Qed.

  Global Instance stsim_elim_mupd
         E1 E2 r g R_src R_tgt
         (Q: R_src -> R_tgt -> iProp)
         ps pt itr_src itr_tgt p
         P
    :
    ElimModal True p false (MUpd (nth_default True%I Invs) (fairI (ident_tgt:=ident_tgt)) E1 E2 P) P (stsim E1 r g Q ps pt itr_src itr_tgt) (stsim E2 r g Q ps pt itr_src itr_tgt).
  Proof.
    unfold ElimModal. rewrite bi.intuitionistically_if_elim.
    i. iIntros "[H0 H1]".
    iApply stsim_mupd. iMod "H0".
    iModIntro. iApply ("H1" with "H0").
  Qed.

  Global Instance stsim_add_modal_mupd
         E r g R_src R_tgt
         (Q: R_src -> R_tgt -> iProp)
         ps pt itr_src itr_tgt
         P
    :
    AddModal (MUpd (nth_default True%I Invs) (fairI (ident_tgt:=ident_tgt)) E E P) P (stsim E r g Q ps pt itr_src itr_tgt).
  Proof.
    unfold AddModal. iIntros "[> H0 H1]". iApply ("H1" with "H0").
  Qed.

  Global Instance stsim_elim_iupd_edge
         E r g R_src R_tgt
         (Q: R_src -> R_tgt -> iProp)
         ps pt itr_src itr_tgt p
         P
    :
    ElimModal True p false (#=(ObligationRA.edges_sat)=> P) P (stsim E r g Q ps pt itr_src itr_tgt) (stsim E r g Q ps pt itr_src itr_tgt).
  Proof.
    unfold ElimModal. rewrite bi.intuitionistically_if_elim.
    i. iIntros "[H0 H1]" (? ? ? ? ?) "[[% [% D]] C]".
    iPoseProof (IUpd_sub_mon with "[] H0 D") as "> [D P]"; auto.
    { iApply edges_sat_sub. }
    iApply ("H1" with "P"). iFrame. iExists _. eauto.
  Qed.

  Global Instance stsim_elim_iupd_arrow
         E r g R_src R_tgt
         (Q: R_src -> R_tgt -> iProp)
         ps pt itr_src itr_tgt p
         P
    :
    ElimModal True p false (#=(ObligationRA.arrows_sat (Id:=sum_tid ident_tgt))=> P) P (stsim E r g Q ps pt itr_src itr_tgt) (stsim E r g Q ps pt itr_src itr_tgt).
  Proof.
    unfold ElimModal. rewrite bi.intuitionistically_if_elim.
    i. iIntros "[H0 H1]" (? ? ? ? ?) "[[% [% D]] C]".
    iPoseProof (IUpd_sub_mon with "[] H0 D") as "> [D P]"; auto.
    { iApply arrows_sat_sub. }
    iApply ("H1" with "P"). iFrame. iExists _. eauto.
  Qed.

  Global Instance mupd_elim_iupd_edge
         P Q E1 E2 p Inv
    :
    ElimModal True p false (#=(ObligationRA.edges_sat)=> P) P (MUpd Inv (fairI (ident_tgt:=ident_tgt)) E1 E2 Q) (MUpd Inv (fairI (ident_tgt:=ident_tgt)) E1 E2 Q).
  Proof.
    unfold ElimModal. rewrite bi.intuitionistically_if_elim.
    i. iIntros "[H0 H1]".
    iPoseProof (IUpd_sub_mon with "[] H0") as "H0".
    { iApply SubIProp_sep_l. }
    iMod "H0". iApply ("H1" with "H0").
  Qed.

  Global Instance mupd_elim_iupd_arrow
         P Q E1 E2 p Inv
    :
    ElimModal True p false (#=(ObligationRA.arrows_sat (Id:=sum_tid ident_tgt))=> P) P (MUpd Inv (fairI (ident_tgt:=ident_tgt)) E1 E2 Q) (MUpd Inv (fairI (ident_tgt:=ident_tgt)) E1 E2 Q).
  Proof.
    unfold ElimModal. rewrite bi.intuitionistically_if_elim.
    i. iIntros "[H0 H1]".
    iPoseProof (IUpd_sub_mon with "[] H0") as "H0".
    { iApply SubIProp_sep_r. }
    iMod "H0". iApply ("H1" with "H0").
  Qed.

  Lemma stsim_wand E r g R_src R_tgt
        (Q0 Q1: R_src -> R_tgt -> iProp)
        ps pt itr_src itr_tgt
    :
    (stsim E r g Q0 ps pt itr_src itr_tgt)
      -∗
      (∀ r_src r_tgt,
          ((Q0 r_src r_tgt) -∗ #=> (Q1 r_src r_tgt)))
      -∗
      (stsim E r g Q1 ps pt itr_src itr_tgt)
  .
  Proof.
    unfold stsim. iIntros "H0 H1" (? ? ? ? ?) "D".
    iApply isim_wand.
    iPoseProof ("H0" $! _ _ _ _ _ with "D") as "H0".
    iSplitR "H0"; [|auto]. iIntros (? ? ? ? ? ? ?) "[D H0]".
    iPoseProof ("H1" $! _ _ with "H0") as "> H0". iModIntro. iFrame.
  Qed.

  Lemma stsim_mono E r g R_src R_tgt
        (Q0 Q1: R_src -> R_tgt -> iProp)
        (MONO: forall r_src r_tgt,
            (Q0 r_src r_tgt)
              -∗
              (#=> (Q1 r_src r_tgt)))
        ps pt itr_src itr_tgt
    :
    (stsim E r g Q0 ps pt itr_src itr_tgt)
      -∗
      (stsim E r g Q1 ps pt itr_src itr_tgt)
  .
  Proof.
    iIntros "H". iApply (stsim_wand with "H").
    iIntros. iApply MONO. auto.
  Qed.

  Lemma stsim_frame E r g R_src R_tgt
        P (Q: R_src -> R_tgt -> iProp)
        ps pt itr_src itr_tgt
    :
    (stsim E r g Q ps pt itr_src itr_tgt)
      -∗
      P
      -∗
      (stsim E r g (fun r_src r_tgt => P ** Q r_src r_tgt) ps pt itr_src itr_tgt)
  .
  Proof.
    iIntros "H0 H1". iApply (stsim_wand with "H0").
    iIntros. iModIntro. iFrame.
  Qed.

  Lemma stsim_bind_top E r g R_src R_tgt S_src S_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt (itr_src: itree srcE S_src) (itr_tgt: itree tgtE S_tgt)
        ktr_src ktr_tgt
    :
    (stsim E r g (fun s_src s_tgt => stsim topset r g Q false false (ktr_src s_src) (ktr_tgt s_tgt)) ps pt itr_src itr_tgt)
      -∗
      (stsim E r g Q ps pt (itr_src >>= ktr_src) (itr_tgt >>= ktr_tgt))
  .
  Proof.
    unfold stsim. iIntros "H" (? ? ? ? ?) "D".
    iPoseProof ("H" $! _ _ _ _ _ with "D") as "H".
    iApply isim_bind. iApply (isim_mono with "H").
    iIntros (? ? ? ? ? ? ?) "[[D I] H]".
    iApply ("H" $! _ _ _ _ _ with "[D I]"). iFrame.
  Qed.

  Lemma stsim_ret E r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt r_src r_tgt
    :
    (MUpd (nth_default True%I Invs) (fairI (ident_tgt:=ident_tgt)) E topset (Q r_src r_tgt))
      -∗
      (stsim E r g Q ps pt (Ret r_src) (Ret r_tgt))
  .
  Proof.
    iIntros "> H".
    unfold stsim. iIntros (? ? ? ? ?) "D".
    iApply isim_ret. iFrame.
  Qed.

  Lemma stsim_tauL E r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt itr_src itr_tgt
    :
    (stsim E r g Q true pt itr_src itr_tgt)
      -∗
      (stsim E r g Q ps pt (Tau itr_src) itr_tgt)
  .
  Proof.
    unfold stsim. iIntros "H" (? ? ? ? ?) "D".
    iPoseProof ("H" $! _ _ _ _ _ with "D") as "H".
    iApply isim_tauL. iFrame.
  Qed.

  Lemma stsim_tauR E r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt itr_src itr_tgt
    :
    (stsim E r g Q ps true itr_src itr_tgt)
      -∗
      (stsim E r g Q ps pt itr_src (Tau itr_tgt))
  .
  Proof.
    unfold stsim. iIntros "H" (? ? ? ? ?) "D".
    iPoseProof ("H" $! _ _ _ _ _ with "D") as "H".
    iApply isim_tauR. iFrame.
  Qed.

  Lemma stsim_chooseL E X r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt ktr_src itr_tgt
    :
    (∃ x, stsim E r g Q true pt (ktr_src x) itr_tgt)
      -∗
      (stsim E r g Q ps pt (trigger (Choose X) >>= ktr_src) itr_tgt)
  .
  Proof.
    unfold stsim. iIntros "[% H]" (? ? ? ? ?) "D".
    iPoseProof ("H" $! _ _ _ _ _ with "D") as "H".
    iApply isim_chooseL. iExists _. iFrame.
  Qed.

  Lemma stsim_chooseR E X r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt itr_src ktr_tgt
    :
    (∀ x, stsim E r g Q ps true itr_src (ktr_tgt x))
      -∗
      (stsim E r g Q ps pt itr_src (trigger (Choose X) >>= ktr_tgt))
  .
  Proof.
    unfold stsim. iIntros "H" (? ? ? ? ?) "D".
    iApply isim_chooseR. iIntros (?).
    iPoseProof ("H" $! _ _ _ _ _ _ with "D") as "H". iFrame.
  Qed.

  Lemma stsim_rmwL E X rmw r g R_src R_tgt
    (Q : R_src -> R_tgt -> iProp)
    ps pt ktr_src itr_tgt st_src
    :
    (St_src st_src)
    -∗ (St_src (fst (rmw st_src)) -∗ stsim E r g Q true pt (ktr_src (snd (rmw st_src) : X)) itr_tgt)
    -∗ stsim E r g Q ps pt (trigger (Rmw rmw) >>= ktr_src) itr_tgt.
  Proof.
    unfold stsim. iIntros "H0 H1" (? ? ? ? ?) "[D C]". iApply isim_rmwL.
    iAssert (⌜st_src0 = st_src⌝)%I as "%".
    { iApply (default_I_past_get_st_src with "D H0"); eauto. }
    subst.
    iPoseProof (default_I_past_update_st_src with "D H0") as "> [D H0]".
    iApply ("H1" with "D [H0 C]"). iFrame.
  Qed.

  Lemma stsim_rmwR E X rmw r g R_src R_tgt
    (Q : R_src -> R_tgt -> iProp)
    ps pt itr_src ktr_tgt st_tgt
    :
    (St_tgt st_tgt)
    -∗ (St_tgt (fst (rmw st_tgt)) -∗ stsim E r g Q ps true itr_src (ktr_tgt (snd (rmw st_tgt) : X)))
    -∗ stsim E r g Q ps pt itr_src (trigger (Rmw rmw) >>= ktr_tgt).
  Proof.
    unfold stsim. iIntros "H0 H1" (? ? ? ? ?) "[D C]". iApply isim_rmwR.
    iAssert (⌜st_tgt0 = st_tgt⌝)%I as "%".
    { iApply (default_I_past_get_st_tgt with "D H0"); eauto. }
    subst.
    iPoseProof (default_I_past_update_st_tgt with "D H0") as "> [D H0]".
    iApply ("H1" with "D [H0 C]"). iFrame.
  Qed.

  Lemma stsim_getL X (p : state_src -> X) E st r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt ktr_src itr_tgt
    :
    ((St_src st) ∧
       (stsim E r g Q true pt (ktr_src (p st)) itr_tgt))
      -∗
      (stsim E r g Q ps pt (trigger (Get p) >>= ktr_src) itr_tgt)
  .
  Proof.
    unfold stsim. iIntros "H" (? ? ? ? ?) "[D C]".
    rewrite get_rmw. iApply isim_rmwL.
    iAssert (⌜st_src = st⌝)%I as "%".
    { iDestruct "H" as "[H _]". iApply (default_I_past_get_st_src with "D"); eauto. }
    subst. iDestruct "H" as "[_ H]". iApply ("H" with "[D C]"). iFrame.
  Qed.

  Lemma stsim_getR X (p : state_tgt -> X) E st r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt itr_src ktr_tgt
    :
    ((St_tgt st) ∧
       (stsim E r g Q ps true itr_src (ktr_tgt (p st))))
      -∗
      (stsim E r g Q ps pt itr_src (trigger (Get p) >>= ktr_tgt))
  .
  Proof.
    unfold stsim. iIntros "H" (? ? ? ? ?) "[D C]".
    rewrite get_rmw. iApply isim_rmwR.
    iAssert (⌜st_tgt = st⌝)%I as "%".
    { iDestruct "H" as "[H _]". iApply (default_I_past_get_st_tgt with "D"); eauto. }
    subst. iDestruct "H" as "[_ H]". iApply ("H" with "[D C]"). iFrame.
  Qed.

  Lemma stsim_tidL E r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt ktr_src itr_tgt
    :
    (stsim E r g Q true pt (ktr_src tid) itr_tgt)
      -∗
      (stsim E r g Q ps pt (trigger GetTid >>= ktr_src) itr_tgt)
  .
  Proof.
    unfold stsim. iIntros "H" (? ? ? ? ?) "D".
    iApply isim_tidL. iApply ("H" with "D").
  Qed.

  Lemma stsim_tidR E r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt itr_src ktr_tgt
    :
    (stsim E r g Q ps true itr_src (ktr_tgt tid))
      -∗
      (stsim E r g Q ps pt itr_src (trigger GetTid >>= ktr_tgt))
  .
  Proof.
    unfold stsim. iIntros "H" (? ? ? ? ?) "D".
    iApply isim_tidR. iApply ("H" with "D").
  Qed.

  Lemma stsim_fairL o lf ls
        E fm r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt ktr_src itr_tgt
        (FAIL: forall i (IN: fm i = Flag.fail), List.In i lf)
        (SUCCESS: forall i (IN: List.In i ls), fm i = Flag.success)
    :
    (list_prop_sum (fun i => FairRA.white i Ord.one) lf)
      -∗
      ((list_prop_sum (fun i => FairRA.white i o) ls) -∗ (stsim E r g Q true pt (ktr_src tt) itr_tgt))
      -∗
      (stsim E r g Q ps pt (trigger (Fair fm) >>= ktr_src) itr_tgt).
  Proof.
    unfold stsim. iIntros "OWN H" (? ? ? ? ?) "[D C]".
    iPoseProof (default_I_past_update_ident_source with "D OWN") as "> [% [[% WHITES] D]]".
    { eauto. }
    { eauto. }
    iPoseProof ("H" with "WHITES [D C]") as "H".
    { iFrame. }
    iApply isim_fairL. iExists _. iSplit; eauto.
  Qed.

  Lemma stsim_fairR lf ls
        E fm r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt itr_src ktr_tgt
        (SUCCESS: forall i (IN: fm i = Flag.success), List.In i (List.map fst ls))
        (FAIL: forall i (IN: List.In i lf), fm i = Flag.fail)
        (NODUP: List.NoDup lf)
    :
    (list_prop_sum (fun '(i, l) => ObligationRA.duty (inr i) l ** ObligationRA.tax l) ls)
      -∗
      ((list_prop_sum (fun '(i, l) => ObligationRA.duty (inr i) l) ls)
         -*
         (list_prop_sum (fun i => FairRA.white (Id:=_) (inr i) 1) lf)
         -*
         stsim E r g Q ps true itr_src (ktr_tgt tt))
      -∗
      (stsim E r g Q ps pt itr_src (trigger (Fair fm) >>= ktr_tgt))
  .
  Proof.
    unfold stsim. iIntros "OWN H"  (? ? ? ? ?) "[D C]".
    iApply isim_fairR. iIntros (?) "%".
    iPoseProof (default_I_past_update_ident_target with "D OWN") as "> [[DUTY WHITE] D]".    { eauto. }
    { eauto. }
    { eauto. }
    { eauto. }
    iApply ("H" with "DUTY WHITE"). iFrame.
  Qed.

  Lemma stsim_fairR_simple lf ls
        E fm r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt itr_src ktr_tgt
        (SUCCESS: forall i (IN: fm i = Flag.success), List.In i ls)
        (FAIL: forall i (IN: List.In i lf), fm i = Flag.fail)
        (NODUP: List.NoDup lf)
    :
    (list_prop_sum (fun i => FairRA.black_ex (inr i) 1) ls)
      -∗
      ((list_prop_sum (fun i => FairRA.black_ex (inr i) 1) ls)
         -*
         (list_prop_sum (fun i => FairRA.white (Id:=_) (inr i) 1) lf)
         -*
         stsim E r g Q ps true itr_src (ktr_tgt tt))
      -∗
      (stsim E r g Q ps pt itr_src (trigger (Fair fm) >>= ktr_tgt))
  .
  Proof.
    iIntros "A B". iApply (stsim_fairR with "[A]"); eauto.
    { instantiate (1:= List.map (fun i => (i, [])) ls). i. specialize (SUCCESS _ IN). rewrite List.map_map. ss.
      replace (List.map (λ x : ident_tgt, x) ls) with ls; auto. clear. induction ls; ss; eauto. f_equal. auto.
    }
    { iApply list_prop_sum_map. 2: iFrame. i. ss. iIntros "BLK". iSplitL; auto. iApply black_to_duty. auto. }
    { iIntros "S F". iApply ("B" with "[S]"). 2: iFrame. iApply list_prop_sum_map_inv. 2: iFrame.
      i; ss. iIntros "D". iApply duty_to_black. iFrame.
    }
  Qed.

  Lemma stsim_UB E r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt ktr_src itr_tgt
    :
    ⊢ (stsim E r g Q ps pt (trigger Undefined >>= ktr_src) itr_tgt)
  .
  Proof.
    unfold stsim. iIntros (? ? ? ? ?) "D".
    iApply isim_UB. auto.
  Qed.

  Lemma stsim_observe E fn args r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt ktr_src ktr_tgt
    :
    (∀ ret, stsim E g g Q true true (ktr_src ret) (ktr_tgt ret))
      -∗
      (stsim E r g Q ps pt (trigger (Observe fn args) >>= ktr_src) (trigger (Observe fn args) >>= ktr_tgt))
  .
  Proof.
    unfold stsim. iIntros "H" (? ? ? ? ?) "D".
    iApply isim_observe. iIntros (?). iApply ("H" with "D").
  Qed.

  Lemma stsim_yieldL E r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt ktr_src ktr_tgt
    :
    (stsim E r g Q true pt (ktr_src tt) (trigger (Yield) >>= ktr_tgt))
      -∗
      (stsim E r g Q ps pt (trigger (Yield) >>= ktr_src) (trigger (Yield) >>= ktr_tgt))
  .
  Proof.
    unfold stsim. iIntros "H" (? ? ? ? ?) "D".
    iApply isim_yieldL. iApply ("H" with "D").
  Qed.

  Lemma stsim_yieldR_strong E r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt ktr_src ktr_tgt l
    :
    (ObligationRA.duty (inl tid) l ** ObligationRA.tax l)
      -∗
      ((ObligationRA.duty (inl tid) l)
         -*
         (FairRA.white_thread (_Id:=_))
         -*
         (MUpd (nth_default True%I Invs) (fairI (ident_tgt:=ident_tgt)) E topset
               (stsim topset r g Q ps true (trigger (Yield) >>= ktr_src) (ktr_tgt tt))))
      -∗
      (stsim E r g Q ps pt (trigger (Yield) >>= ktr_src) (trigger (Yield) >>= ktr_tgt))
  .
  Proof.
    iIntros "H K".
    unfold stsim. iIntros (? ? ? ? ?) "[D C]".
    iPoseProof (default_I_past_update_ident_thread with "D H") as "> [[B W] [[[[[[D0 D1] D2] D3] D4] D5] D6]]".
    iAssert ((fairI (ident_tgt:=ident_tgt)) ** mset_all (nth_default True%I Invs) E) with "[C D5 D6]" as "C".
    { iFrame. }
    iPoseProof ("K" with "B W C") as "> [[[D5 D6] C] K]".
    iApply isim_yieldR. unfold I. iFrame.
    iIntros (? ? ? ? ? ?) "[D C] %".
    iApply ("K" with "[D C]"). iFrame. iExists _. eauto.
  Qed.

  Lemma stsim_sync_strong E r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt ktr_src ktr_tgt l
    :
    (ObligationRA.duty (inl tid) l ** ObligationRA.tax l)
      -∗
      ((ObligationRA.duty (inl tid) l)
         -*
         (FairRA.white_thread (_Id:=_))
         -*
         (MUpd (nth_default True%I Invs) (fairI (ident_tgt:=ident_tgt)) E topset
               (stsim topset g g Q true true (ktr_src tt) (ktr_tgt tt))))
      -∗
      (stsim E r g Q ps pt (trigger (Yield) >>= ktr_src) (trigger (Yield) >>= ktr_tgt)).
  Proof.
    iIntros "H K".
    unfold stsim. iIntros (? ? ? ? ?) "[D C]".
    iPoseProof (default_I_past_update_ident_thread with "D H") as "> [[B W] [[[[[[D0 D1] D2] D3] D4] D5] D6]]".
    iAssert ((fairI (ident_tgt:=ident_tgt)) ** mset_all (nth_default True%I Invs) E) with "[C D5 D6]" as "C".
    { iFrame. }
    iPoseProof ("K" with "B W C") as "> [[[D5 D6] C] K]".
    iApply isim_sync. unfold I. iFrame.
    iIntros (? ? ? ? ? ?) "[D C] %".
    iApply ("K" with "[D C]"). iFrame. iExists _. eauto.
  Qed.

  Lemma stsim_yieldR E r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt ktr_src ktr_tgt l
        (TOP: mset_sub topset E)
    :
    (ObligationRA.duty (inl tid) l ** ObligationRA.tax l)
      -∗
      ((ObligationRA.duty (inl tid) l)
         -*
         (FairRA.white_thread (_Id:=_))
         -*
         stsim topset r g Q ps true (trigger (Yield) >>= ktr_src) (ktr_tgt tt))
      -∗
      (stsim E r g Q ps pt (trigger (Yield) >>= ktr_src) (trigger (Yield) >>= ktr_tgt))
  .
  Proof.
    iIntros "H K". iApply stsim_discard; [eassumption|].
    iApply (stsim_yieldR_strong with "H"). iIntros "DUTY WHITE".
    iModIntro. iApply ("K" with "DUTY WHITE").
  Qed.

  Lemma stsim_sync E r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt ktr_src ktr_tgt l
        (TOP: mset_sub topset E)
    :
    (ObligationRA.duty (inl tid) l ** ObligationRA.tax l)
      -∗
      ((ObligationRA.duty (inl tid) l)
         -*
         (FairRA.white_thread (_Id:=_))
         -*
         stsim topset g g Q true true (ktr_src tt) (ktr_tgt tt))
      -∗
      (stsim E r g Q ps pt (trigger (Yield) >>= ktr_src) (trigger (Yield) >>= ktr_tgt)).
  Proof.
    iIntros "H K". iApply stsim_discard; [eassumption|].
    iApply (stsim_sync_strong with "H"). iIntros "DUTY WHITE".
    iModIntro. iApply ("K" with "DUTY WHITE").
  Qed.

  (* Note:  *)
  (*   MUpd _ fairI topset topset P *)
  (*        is a generalized version of I * (I -* P) *)
  Lemma stsim_yieldR_simple E r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt ktr_src ktr_tgt
        (TOP: mset_sub topset E)
    :
    MUpd (nth_default True%I Invs) (fairI (ident_tgt:=ident_tgt)) topset topset
         ((FairRA.black_ex (inl tid) 1)
            **
            ((FairRA.black_ex (inl tid) 1)
               -*
               (FairRA.white_thread (_Id:=_))
               -*
               stsim topset r g Q ps true (trigger (Yield) >>= ktr_src) (ktr_tgt tt)))
         -∗
         (stsim E r g Q ps pt (trigger (Yield) >>= ktr_src) (trigger (Yield) >>= ktr_tgt))
  .
  Proof.
    iIntros "> [H K]". iApply (stsim_yieldR with "[H]").
    { auto. }
    { iPoseProof (black_to_duty with "H") as "H". iFrame. }
    iIntros "B W". iApply ("K" with "[B] [W]"); ss.
    { iApply duty_to_black. auto. }
  Qed.

  Lemma stsim_sync_simple E r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt ktr_src ktr_tgt
        (TOP: mset_sub topset E)
    :
    MUpd (nth_default True%I Invs) (fairI (ident_tgt:=ident_tgt)) topset topset
         ((FairRA.black_ex (inl tid) 1)
            **
            ((FairRA.black_ex (inl tid) 1)
               -*
               (FairRA.white_thread (_Id:=_))
               -*
               stsim topset g g Q true true (ktr_src tt) (ktr_tgt tt)))
      -∗
      (stsim E r g Q ps pt (trigger (Yield) >>= ktr_src) (trigger (Yield) >>= ktr_tgt)).
  Proof.
    iIntros "> [H K]". iApply (stsim_sync with "[H]").
    { auto. }
    { iPoseProof (black_to_duty with "H") as "H". iFrame. }
    iIntros "B W". iApply ("K" with "[B] [W]"); ss.
    { iApply duty_to_black. auto. }
  Qed.

  Lemma stsim_sort E r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt itr_src itr_tgt
    :
    (stsim (NatSort.sort E) r g Q ps pt itr_src itr_tgt)
      -∗
      (stsim E r g Q ps pt itr_src itr_tgt)
  .
  Proof.
    iApply stsim_discard.
    rewrite <- NatSort.Permuted_sort. reflexivity.
  Qed.

  Lemma stsim_reset E r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        ps pt itr_src itr_tgt
    :
    (stsim E r g Q false false itr_src itr_tgt)
      -∗
      (stsim E r g Q ps pt itr_src itr_tgt)
  .
  Proof.
    unfold stsim. iIntros "H" (? ? ? ? ?) "D".
    iApply isim_reset. iApply ("H" with "D").
  Qed.

  Lemma stsim_progress E r g R_src R_tgt
        (Q: R_src -> R_tgt -> iProp)
        itr_src itr_tgt
    :
    (stsim E g g Q false false itr_src itr_tgt)
      -∗
      (stsim E r g Q true true itr_src itr_tgt)
  .
  Proof.
    unfold stsim. iIntros "H" (? ? ? ? ?) "D".
    iApply isim_progress. iApply ("H" with "D").
  Qed.

  Definition ibot5 { T0 T1 T2 T3 T4} (x0: T0) (x1: T1 x0) (x2: T2 x0 x1) (x3: T3 x0 x1 x2) (x4: T4 x0 x1 x2 x3): iProp := False.
  Definition ibot7 { T0 T1 T2 T3 T4 T5 T6} (x0: T0) (x1: T1 x0) (x2: T2 x0 x1) (x3: T3 x0 x1 x2) (x4: T4 x0 x1 x2 x3) (x5: T5 x0 x1 x2 x3 x4) (x6: T6 x0 x1 x2 x3 x4 x5): iProp := False.

End STATE.

From Fairness Require Export Red IRed.

Ltac lred := repeat (prw _red_gen 1 2 0).
Ltac rred := repeat (prw _red_gen 1 1 0).


From Perennial.goose_lang Require Import prelude.
From Perennial.goose_lang Require Export ffi.grove_prelude.
From Perennial.program_proof Require Import proof_prelude.
From Perennial.goose_lang.ffi Require Export grove_ffi_time_axiom.
From Perennial.base_logic.lib Require Import ghost_var.
From Goose.github_com.mit_pdos.gokv Require Import minlease.
From iris.bi.lib Require Import fixpoint.
From Perennial.base_logic Require Import lib.saved_prop.
From Perennial.program_proof Require Import std_proof.

Section proof.

Context `{!heapGS Σ}.
Context `{!ghost_varG Σ u64}.
Context `{!ghost_varG Σ ()}.
Context `{!savedPropG Σ }.

Context {γtime:gname}.

Notation is_time_lb := (is_time_lb γtime).
Notation own_time := (own_time γtime).

(* Q is the lease obligation *)
Definition underLease (N:namespace) (leaseExpiration:u64) (P:iProp Σ) (Q:iProp Σ) : iProp Σ :=
  ∃ γprop γpostLeastTok,
  saved_prop_own γprop (DfracOwn (1/2)) P ∗
  inv N (∃ P',
    saved_prop_own γprop (DfracOwn (1/2)) P' ∗
    (P' ∗ (P' -∗ Q) ∨ is_time_lb leaseExpiration ∗ ghost_var γpostLeastTok 1 ())
  ).

(* Doesn't seem useful
Lemma underLease_mono P' P Q e N :
  (P -∗ P') -∗
  (P' -∗ Q) -∗
  underLease N e P Q -∗
  underLease N e P' Q
.
Proof.
Admitted. *)

Lemma lease_acc_update N e P Q :
  underLease N e P Q -∗
  £ 1 -∗
  £ 1 -∗
  ∀ (t:u64),
  ⌜int.nat t < int.nat e⌝ →
  own_time t ={↑N,∅}=∗
  (P ∗ (∀ P', P' -∗ (P' -∗ Q) ={∅,↑N}=∗ own_time t ∗ underLease N e P' Q))
.
Proof.
  iIntros "Hlease Hlc Hlc2".
  iIntros (?) "%Hineq Htime".
  iDestruct "Hlease" as (γprop ?) "[Hprop #Hinv]".
  iInv "Hinv" as "Hi" "Hclose".
  iMod (lc_fupd_elim_later with "Hlc Hi") as "Hi".
  iDestruct "Hi" as (?) "[Hprop2 Hi]".
  iDestruct (saved_prop_agree with "Hprop Hprop2") as "#Hagree1".
  iMod (lc_fupd_elim_later with "Hlc2 Hagree1") as "#Hagree".
  replace (↑N ∖ ↑N) with (∅:coPset) by set_solver.
  iModIntro.
  iDestruct "Hi" as "[[HP HQwand]|[Hbad HpostLeastTok]]"; last first.
  {
    iDestruct (mono_nat_lb_own_valid with "Htime Hbad") as %[_ Hbad].
    exfalso.
    word.
  }
  iSplitL "HP".
  {
    by iRewrite "Hagree".
  }
  iIntros (R) "HR HRwandQ".
  iMod (saved_prop_update_2 R with "Hprop Hprop2") as "[Hprop Hprop2]".
  { apply Qp.half_half. }
  iFrame "Htime".
  iMod ("Hclose" with "[HRwandQ HR Hprop2]").
  {
    iNext.
    iExists _; iFrame "Hprop2".
    iLeft.
    iFrame.
  }
  iModIntro.
  iExists _, _; iFrame "∗#".
Qed.

Definition postLease (N:namespace) (leaseExpiration:u64) (Q:iProp Σ) : iProp Σ :=
  is_time_lb leaseExpiration ={↑N}=∗ ▷ Q
.

Lemma lease_alloc e Q N P :
  P -∗ (P -∗ Q) ={↑N}=∗
  underLease N e P Q ∗
  postLease N e Q
.
Proof.
  iIntros "HP Hwand".
  iMod (saved_prop_alloc P (DfracOwn 1)) as (γprop) "[Hprop Hprop2]".
  { done. }
  iMod (ghost_var_alloc ()) as (γpostLeaseTok) "HpostLeaseTok".
  iAssert (|={↑N}=>
  inv N (∃ P',
    saved_prop_own γprop (DfracOwn (1/2)) P' ∗
    (P' ∗ (P' -∗ Q) ∨ is_time_lb e ∗ ghost_var γpostLeaseTok 1 ())
  ))%I with "[HP Hwand Hprop2]" as ">#Hinv".
  {
    iMod (inv_alloc with "[-]") as "$"; last done.
    iNext.
    iExists _; iFrame "Hprop2".
    iLeft. iFrame.
  }
  iModIntro.
  iSplitL "Hprop".
  {
    iExists _, _; iFrame "∗#".
  }
  iIntros "Hlb".
  iInv "Hinv" as "Hi" "Hclose".
  iDestruct "Hi" as (?) "[Hprop HP]".
  iDestruct "HP" as "[HP |[_ >Hbad]]"; last first.
  {
    iDestruct (ghost_var_valid_2 with "Hbad HpostLeaseTok") as %[Hbad _].
    exfalso.
    done.
  }
  iDestruct "HP" as "[HP HPwand]".
  iDestruct (later_wand with "HPwand") as "HPwand".
  iMod ("Hclose" with "[Hprop HpostLeaseTok Hlb]").
  {
    iExists _; iFrame.
    iRight.
    iFrame.
  }
  iApply "HPwand".
  done.
Qed.

(* P are resources you can access and modify at the moment you check that the
   lease is unexpired.
 *)

Definition own_Server s γ : iProp Σ :=
  ∃ (v:u64),
  "Hval" ∷ s ↦[Server :: "val"] #v ∗
  "Hauth" ∷ ghost_var γ (1/2) v
.

Definition LEASE_EXP := U64 10.

Definition minleaseN := nroot .@ "minlease".

Definition is_Server s γ : iProp Σ :=
  ∃ mu,
  "#Hmu" ∷ readonly (s ↦[Server :: "mu"] mu) ∗
  "#HleaseExpiration" ∷ readonly (s ↦[Server :: "leaseExpiration"] #LEASE_EXP) ∗
  "#HmuInv" ∷ is_lock minleaseN mu (own_Server s γ)
.

Lemma wp_Put s (v:u64) γ Φ :
is_Server s γ -∗
(|={⊤,∅}=> ∃ (oldv:u64), ghost_var γ (1/2) oldv ∗
(ghost_var γ (1/2) v ={∅,⊤}=∗ Φ #()) )-∗
  WP Server__Put #s #v {{ Φ }}
.
Proof.
  iIntros "Hsrv Hupd".
  iNamed "Hsrv".
  wp_lam.
  wp_pures.
  wp_loadField.
  wp_apply (acquire_spec with "HmuInv").
  iIntros "[Hlocked Hown]".
  iNamed "Hown".
  wp_pures.
  wp_storeField.
  wp_loadField.

  iApply fupd_wp.
  iMod "Hupd" as (?) "[Hval2 Hupd]".
  iMod (ghost_var_update_2 with "Hauth Hval2") as "[Hauth Hval2]".
  { apply Qp.half_half. }
  iMod ("Hupd" with "Hval2") as "HΦ".
  iModIntro.
  wp_apply (release_spec with "[-HΦ]").
  {
    iFrame "HmuInv Hlocked".
    iNext.
    repeat iExists _; iFrame "∗#%".
  }
  wp_pures.
  by iFrame.
Qed.

Lemma wp_Get s γ Φ :
is_Server s γ -∗
(|={⊤,∅}=> ∃ (v:u64), ghost_var γ (1/2) v ∗
(ghost_var γ (1/2) v ={∅,⊤}=∗ Φ #v) )-∗
  WP Server__Get #s {{ Φ }}
.
Proof.
  iIntros "Hsrv Hupd".
  iNamed "Hsrv".
  wp_lam.
  wp_pures.
  wp_loadField.
  wp_apply (acquire_spec with "HmuInv").
  iIntros "[Hlocked Hown]".
  iNamed "Hown".
  wp_pures.
  wp_loadField.
  wp_loadField.

  iApply fupd_wp.
  iMod "Hupd" as (?) "[Hval2 Hupd]".
  iDestruct (ghost_var_valid_2 with "Hauth Hval2") as %[_ ->].
  iMod ("Hupd" with "Hval2") as "HΦ".
  iModIntro.
  wp_apply (release_spec with "[-HΦ]").
  {
    iFrame "HmuInv Hlocked".
    iNext.
    repeat iExists _; iFrame "∗#%".
  }
  wp_pures.
  by iFrame.
Qed.

Lemma wp_StartServer γ :
  {{{
      "Hlease" ∷ underLease minleaseN LEASE_EXP (ghost_var γ (1/2) (U64 0)) (∃ (v:u64), (ghost_var γ (1/2) v)) ∗
      "Hauth" ∷ ghost_var γ (1/2) (U64 0)
  }}}
    StartServer #()
  {{{
        s, RET #s; is_Server s γ
  }}}
.
Proof.
  iIntros (Φ) "Hpre HΦ".
  iNamed "Hpre".
  wp_lam.
  wp_apply (wp_allocStruct).
  { repeat constructor. }
  iIntros (?) "Hl".
  iDestruct (struct_fields_split with "Hl") as "HH".
  iNamed "HH".
  wp_pures.
  wp_apply (wp_new_free_lock).
  iIntros (mu) "HmuInv".
  wp_storeField.
  wp_storeField.
  wp_storeField.
  iMod (readonly_alloc_1 with "mu") as "#Hmu".
  iMod (readonly_alloc_1 with "leaseExpiration") as "#HleaseExpiration".

  iAssert (|={⊤}=> is_Server l γ)%I with "[-HΦ Hlease]" as ">#Hsrv".
  {
    repeat iExists _.
    iFrame "∗#%".
    iDestruct (alloc_lock with "HmuInv [-]") as "$".
    iNext.
    repeat iExists _; iFrame "∗#%".
  }

  wp_apply (wp_fork with "[-HΦ]").
  {
    iNext.
    wp_pure1_credit "Hlc1".
    wp_pure1_credit "Hlc2".
    wp_pures.
    iAssert  ( ∃ v,
      "Hlease" ∷ underLease minleaseN LEASE_EXP (ghost_var γ (1 / 2) v%Z)
               (∃ v' : u64, ghost_var γ (1 / 2) v')
               )%I with "[Hlease]" as "HH" .
    { iExists _. iFrame. }
    wp_forBreak_cond.
    wp_pures.
    wp_lam.
    iClear "Hmu HleaseExpiration".
    iNamed "Hsrv".
    wp_loadField.
    wp_apply (acquire_spec with "HmuInv").
    iIntros "[Hlocked Hown]".
    wp_pures.
    wp_apply (wp_GetTimeRange γtime).
    iIntros (low high t) "%Hineq1 %Hineq2 Htime".
    iNamed "HH".

    destruct (decide (int.nat LEASE_EXP < int.nat high)).
    2:{ (* case: lease is not expired *)
      iDestruct (lease_acc_update with "Hlease Hlc1 Hlc2") as "HH".
      iDestruct ("HH" $! t with "[%] Htime") as "HH".
      { word. }
      iMod (fupd_mask_subseteq _) as "Hmask"; last iMod "HH".
      { set_solver. }
      iNamed "Hown".
      iDestruct "HH" as "[Hval2 HcloseLease]".
      iDestruct (ghost_var_valid_2 with "Hauth Hval2") as %[_ ->].
      iMod (ghost_var_update_2 (word.add v 1) with "Hauth Hval2") as "[Hauth Hval2]".
      { apply Qp.half_half. }

      iMod ("HcloseLease" $!_ with "Hval2 []") as "[Htime Hlease]".
      {
        iIntros. iExists _; iFrame.
      }
      iMod "Hmask".
      iModIntro.
      iFrame "Htime".
      wp_pure1_credit "Hlc1".
      wp_pure1_credit "Hlc2".
      wp_loadField.
      wp_pures.
      wp_bind (If (#(bool_decide _)) _ _).
      wp_if_destruct.
      1:{
        exfalso.
        word.
      }
      wp_loadField.
      wp_apply (wp_SumAssumeNoOverflow).
      iIntros "%Hoverflow".
      wp_storeField.
      wp_loadField.
      wp_apply (release_spec with "[-Hlease Hlc1 Hlc2]").
      {
        iFrame "HmuInv Hlocked".
        repeat iExists _; iFrame "∗#%".
      }
      wp_pures.
      iLeft.
      iModIntro.
      iSplitR; first done.
      iFrame.
      iExists _.
      iFrame.
    }
    (* Otherwise, lease has expired *)
    iModIntro.
    iFrame.
    wp_pures.
    wp_loadField.
    wp_pures.
    wp_bind (If (#(bool_decide _)) _ _).
    wp_if_destruct.
    2:{ exfalso. word. }
    wp_loadField.
    wp_apply (release_spec with "[-Hlease]").
    {
      iFrame "HmuInv Hlocked". iFrame.
    }
    wp_pures.
    iRight.
    iModIntro.
    done.
  }
  wp_pures.
  iModIntro.
  iApply "HΦ".
  done.
Qed.

Lemma wp_client s γ :
  {{{
      "#Hsrv" ∷ is_Server s γ ∗
      "HpostLease" ∷ postLease minleaseN LEASE_EXP (∃ (v':u64), ghost_var γ (1/2) v')
  }}}
    client #s
  {{{
      RET #(); True
  }}}
.
Proof.
  iIntros (Φ) "Hpre HΦ".
  iNamed "Hpre".
  wp_call.
  wp_forBreak.
  wp_pures.
  wp_apply (wp_GetTimeRange γtime).
  iIntros (low high t Hineq1 Hineq) "Htime".

  iAssert (_) with "Hsrv" as "Hsrv2".
  iNamed "Hsrv2".

  destruct (decide (int.nat LEASE_EXP < int.nat low)).
  {
    iDestruct (mono_nat_lb_own_get with "Htime") as "#Hlb".
    unfold postLease.
    iMod (fupd_mask_subseteq _) as "Hmask";
      last iMod ("HpostLease" with "[Hlb]") as "HpostLease".
    { set_solver. }
    { iApply mono_nat_lb_own_le; last iFrame "#". word. }
    iMod "Hmask" as "_".
    iModIntro.
    iFrame "Htime".
    wp_pures.
    iDestruct "HpostLease" as (?) "Hghost".
    wp_loadField.
    wp_pures.
    wp_if_destruct.
    2:{ exfalso. word. }
    iModIntro.
    iRight.
    iSplitR; first done.
    wp_pures.
    wp_apply (wp_Get with "Hsrv").
    iApply fupd_mask_intro.
    { set_solver. }
    iIntros "Hmask".
    iExists _; iFrame.
    iIntros "Hvar".
    iMod "Hmask" as "_".
    iModIntro.
    wp_pures.
    wp_apply wp_SumAssumeNoOverflow.
    iIntros (HnoOverflow).
    wp_pures.
    wp_apply (wp_Put with "Hsrv").
    iApply fupd_mask_intro.
    { set_solver. }
    iIntros "Hmask".
    iExists _; iFrame.
    iIntros "Hvar".
    iMod "Hmask" as "_".
    iModIntro.
    wp_pures.
    wp_apply (wp_Get with "Hsrv").
    iApply fupd_mask_intro.
    { set_solver. }
    iIntros "Hmask".
    iExists _; iFrame.
    iIntros "Hvar".
    iMod "Hmask" as "_".
    iModIntro.
    wp_pures.
    wp_apply (wp_Assert).
    { apply bool_decide_true. done. }
    wp_pures.
    iModIntro.
    by iApply "HΦ".
  }
  { (* loop and wait for server's lease to expire *)
    iFrame "Htime".
    iModIntro.
    wp_pures.
    wp_loadField.
    wp_pures.
    wp_if_destruct.
    { exfalso. word. }
    wp_loadField.
    wp_apply wp_Sleep.
    wp_pures.
    iLeft.
    iFrame.
    done.
  }
Qed.

Lemma wp_main :
  {{{
       True
  }}}
    main #()
  {{{
        RET #(); True
  }}}
.
Proof using Type* γtime.
  iIntros (Φ) "_ HΦ".
  wp_lam.
  iMod (ghost_var_alloc (U64 0)) as (γ) "[Hvar Hvar2]".
  iApply fupd_wp.
  iMod (fupd_mask_subseteq (↑minleaseN)) as "Hmask".
  { set_solver. }
  iMod (lease_alloc LEASE_EXP (∃ v:u64, ghost_var γ (1/2) v) with "Hvar2 []") as "[Hlease HpostLease]".
  { iIntros. iExists _; iFrame. }
  iMod "Hmask".
  iModIntro.
  wp_apply (wp_StartServer with "[$Hlease $Hvar]").
  iIntros (s) "#Hsrv".
  wp_pures.
  wp_apply (wp_client with "[$Hsrv $HpostLease]").
  wp_pures.
  iModIntro.
  by iApply "HΦ".
Qed.

End proof.


(*
 * © 2020 Massachusetts Institute of Technology.
 * MIT Proprietary, Subject to FAR52.227-11 Patent Rights - Ownership by the Contractor (May 2014)
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     Eqdep
     List
     Lia.

From SPICY Require Import
     MyPrelude
     Maps
     ChMaps
     Messages
     Keys
     Automation
     Tactics
     Simulation
     SyntacticallySafe
     AdversaryUniverse

     ModelCheck.Commutation
     ModelCheck.InvariantSearch
     ModelCheck.ProtocolFunctions
     ModelCheck.ModelCheck
     ModelCheck.SilentStepElimination
     ModelCheck.SteppingTactics
     ModelCheck.UniverseInversionLemmas
.

From protocols Require Import
     PGP.

From SPICY Require IdealWorld RealWorld.

Import IdealWorld.IdealNotations
       RealWorld.RealWorldNotations
       SimulationAutomation.

Set Implicit Arguments.

Open Scope protocol_scope.

Module PGPProtocolSecure <: AutomatedSafeProtocolSS.

  Import PGPProtocol.

  Definition t__hon := Nat.
  Definition t__adv := Unit.
  Definition b := tt.
  Definition iu0  := ideal_univ_start.
  Definition ru0  := real_univ_start.

  #[export] Hint Unfold t__hon t__adv b ru0 iu0 ideal_univ_start real_univ_start : core.

  Lemma finitelyRuns : exists n, runningTimeMeasure ru0 n.
  Proof.
    autounfold; simpl.
    eexists.
    econstructor; simpl; find_runtime.

    Unshelve.
    all: exact 0.
  Qed.

  Lemma typechecks : syntactically_safe_U ru0.
  Proof.
    unfold syntactically_safe_U; intros.
    autounfold
    ; subst
    ; simpl in *.

    unfold compute_ids; simpl.

    focus_user; simpl
    ; try solve [ do 2 eexists; split
                  ; [ unshelve (repeat typechecks1)
                      ; match goal with
                        | [ |- bool ] => exact true
                        | [ |- list safe_typ ] => exact []
                        end
                    | repeat verify_context_soundness ] ].

    Unshelve.
    all : exact TyDontCare.
  Qed.

  Lemma summarizable : exists summaries, summarize_univ ru0 summaries.
  Proof.
    autounfold; unfold summarize_univ; simpl; intros.
    unshelve (
        eexists; intros; focus_user; simpl
        ; (exists useless_summary; split; [ build_summary |]; eauto using useless_summary_summarizes)
      ) ; exact $0.
  Qed.

  Lemma lameness : @lameAdv t__adv b (RealWorld.adversary ru0).
  Proof.
    unfold lameAdv; autounfold; simpl; eauto.
  Qed.

  Import Gen Tacs.

  Locate safety_inv.

  Set Ltac Profiling.

  Lemma safe_invariant :
    invariantFor
      {| Initial := {(ru0, iu0, true)}; Step := @stepSS t__hon t__adv  |}
      (@noresends_inv t__hon t__adv).
  Proof.
    unfold invariantFor
    ; unfold Initial, Step
    ; intros
    ; simpl in *
    ; split_ors
    ; try contradiction
    ; subst.

    autounfold in H0
    ; unfold fold_left, fst, snd in *.
    unfold real_users, ideal_users, mkrUsr, userProto, userKeys, userId, mkiUsr in *; rwuf.

    time (
        repeat transition_system_step
      ).

    Unshelve.
    all: eauto.
  Qed.

  Show Ltac Profile.

  Lemma U_good : @universe_starts_sane _ Unit b ru0.
  Proof.
    autounfold;
      unfold universe_starts_sane; simpl.
    repeat (apply conj); intros; eauto.
    - focus_user; auto.
    - econstructor.
    - unfold AdversarySafety.keys_honest; rewrite Forall_natmap_forall; intros.
      unfold mkrUsr; simpl.
      rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty; eauto.
    - unfold lameAdv; simpl; eauto.
  Qed.

  Lemma universe_starts_safe : universe_ok ru0.
  Proof.
    pose proof (adversary_is_lame_adv_univ_ok_clauses U_good).

    unfold universe_ok
    ; autounfold
    ; simpl
    ; intuition eauto
    .

    - econstructor; eauto.
    - unfold keys_and_permissions_good; solve_simple_maps; intuition eauto.
      solve_simple_maps; eauto.

      rewrite Forall_natmap_forall; intros.

      solve_simple_maps; simpl
      ; unfold permission_heap_good; intros;
        solve_simple_maps; solve_concrete_maps; eauto.

    - unfold user_cipher_queues_ok.
      rewrite Forall_natmap_forall; intros.
      focus_user
      ; simpl in *; econstructor; eauto.

    - unfold honest_nonces_ok, honest_user_nonces_ok, honest_nonces_ok
      ; repeat simple apply conj
      ; intros
      ; clean_map_lookups
      ; intros
      ; focus_user
      ; try contradiction; try discriminate; simpl;
        repeat (apply conj); intros; clean_map_lookups; eauto.

    - unfold honest_users_only_honest_keys; intros.
      focus_user;
        subst;
        simpl in *;
        clean_map_lookups;
        unfold mkrUsr; simpl;
          rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty;
          eauto;
          simpl in *;
          solve_concrete_perm_merges;
          solve_concrete_maps;
          solve_simple_maps;
          eauto.
  Qed.
End PGPProtocolSecure.

(* Module ProtoCorrect := SSProtocolSimulates (PGPProtocolSecure). *)
(* Print Assumptions ProtoCorrect.protocol_with_adversary_could_generate_spec. *)


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import CtxtSwitchAux.Spec.
Require Import AbsAccessor.Spec.
Require Import CtxtSwitch.Specs.restore_ns_state.
Require Import CtxtSwitch.LowSpecs.restore_ns_state.
Require Import CtxtSwitch.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       restore_ns_state_sysreg_state_spec
       get_ns_state_spec
       sysreg_write_spec
    .

  Lemma restore_realm_state_spec_exists:
    forall habd habd'  labd
      (Hspec: restore_ns_state_spec  habd = Some habd')
      (Hrel: relate_RData habd labd),
    exists labd', restore_ns_state_spec0  labd = Some labd' /\ relate_RData habd' labd'.
  Proof.
    Local Opaque ptr_eq.
    intros. destruct Hrel.
    unfold restore_ns_state_spec, restore_ns_state_spec0 in *.
    repeat autounfold in *. simpl in *.
    hsimpl_hyp Hspec; inv Hspec; simpl_query_oracle; extract_prop_dec;
      repeat destruct_con; bool_rel; simpl in *; srewrite;
        repeat (simpl_htarget; grewrite; simpl in * ).
    destruct regs_is_int64_dec in *. autounfold in e. repeat rewrite e.
    repeat simpl_update_reg.
    eexists; split. reflexivity. constructor. reflexivity.
    inv C.
  Qed.

End Refine.


Require Import Coq.Strings.String.
Require Import bedrock2.Syntax.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import coqutil.Map.Interface coqutil.Map.Properties.
Require Import coqutil.Word.Interface coqutil.Word.Properties.
Require Import coqutil.Datatypes.PropSet.
Require Import Coq.Lists.List. (* after SeparationLogic *)
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Translation.Proofs.Equivalence.
Require Import Crypto.Bedrock.Field.Translation.Proofs.UsedVarnames.
Require Import Crypto.Bedrock.Field.Translation.Proofs.VarnameSet.
Require Import Crypto.Bedrock.Field.Common.Tactics.
Require Import Crypto.Bedrock.Field.Common.Util.
Require Import Crypto.Language.API.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.Tactics.DestructHead.

Import API.Compilers.
Import ListNotations Types.Notations.

Section OnlyDiffer.
  Context
    {width BW word mem locals env ext_spec varname_gen error}
   `{parameters_sentinel : @parameters width BW word mem locals env ext_spec varname_gen error}.
  Context {ok : ok}.
  Local Existing Instance Types.rep.Z.

  Lemma equiv_Z_only_differ_iff1
        {listZ : rep.rep base_listZ}
        locals1 locals2 vset (varname : base_ltype base_Z) s x :
    map.only_differ locals1 vset locals2 ->
    disjoint vset (varname_set_base varname) ->
    Lift1Prop.iff1
      (rep.equiv x (rep.rtype_of_ltype varname) s locals1)
      (rep.equiv x (rep.rtype_of_ltype varname) s locals2).
  Proof.
    cbn [varname_set_base
           rep.varname_set rep.equiv rep.rtype_of_ltype rep.Z].
    cbv [WeakestPrecondition.dexpr].
    rewrite <-disjoint_singleton_r_iff by eauto using string_dec.
    split; intros; sepsimpl; subst; eexists; sepsimpl; eauto;
      eapply expr_untouched; eauto using @only_differ_sym with typeclass_instances.
  Qed.

  Lemma equiv_Z_only_differ_undef {listZ:rep.rep base_listZ} :
    forall x y s locals locals' vset,
      map.only_differ locals vset locals' ->
      map.undef_on locals vset ->
      Lift1Prop.impl1
        (equivalent_base (t:=base_Z) x y s locals)
        (equivalent_base x y s locals').
  Proof.
    cbv [equivalent_base rep.equiv rep.Z WeakestPrecondition.dexpr].
    repeat intro; sepsimpl; subst; eexists; sepsimpl; eauto.
    eauto using expr_only_differ_undef.
  Qed.

  Section Local.
    Local Existing Instance rep.listZ_local.

    Lemma equiv_listZ_only_differ_local : forall
          locals1 locals2 vset (varnames : base_ltype base_listZ) s x (mem : mem),
      map.only_differ locals1 vset locals2 ->
      disjoint vset (varname_set_base varnames) ->
      rep.equiv x (rep.rtype_of_ltype varnames) s locals1 mem ->
      rep.equiv x (rep.rtype_of_ltype varnames) s locals2 mem.
    Proof.
      intros *.
      cbn [rep.equiv rep.rtype_of_ltype rep.listZ_local
                     varname_set rep.varname_set].
      rewrite !Forall.Forall2_map_r_iff.
      revert x; induction varnames; intros;
        match goal with H : Forall2 _ _ _ |- _ =>
                        inversion H; subst; clear H end;
        [ solve [eauto] | ].
      cbn [fold_right] in *; cbv [emp] in *. cleanup.
      constructor.
      { eapply equiv_Z_only_differ_iff1;
          cbn [rep.equiv rep.Z]; cbv [emp];
            destruct_head'_and;
            eauto using @only_differ_sym with typeclass_instances.
        cbv [varname_set rep.varname_set rep.Z] in *.
        match goal with H : disjoint _ _ |- _ =>
                        apply disjoint_union_r_iff in H;
                          cleanup
        end. eauto. }
      { apply IHvarnames; eauto.
        match goal with H : disjoint _ _ |- _ =>
                        apply disjoint_union_r_iff in H;
                          cleanup
        end. eauto. }
    Qed.

    Lemma equiv_listZ_only_differ_local_iff1
          locals1 locals2 vset (varnames : base_ltype base_listZ) s x :
      map.only_differ locals1 vset locals2 ->
      disjoint vset (varname_set_base varnames) ->
      Lift1Prop.iff1
        (rep.equiv x (rep.rtype_of_ltype varnames) s locals1)
        (rep.equiv x (rep.rtype_of_ltype varnames) s locals2).
    Proof.
      cbv [Lift1Prop.iff1]; split; intros;
        eapply equiv_listZ_only_differ_local;
        eauto using @only_differ_sym with typeclass_instances.
    Qed.

    Lemma equiv_listZ_only_differ_undef_local :
      forall x y s locals locals' vset,
        map.only_differ locals vset locals' ->
        map.undef_on locals vset ->
        Lift1Prop.impl1
          (equivalent_base (t:=base_listZ) x y s locals)
          (equivalent_base x y s locals').
    Proof.
      cbn [equivalent_base rep.equiv rep.listZ_local]; intros; sepsimpl.
      repeat intro; sepsimpl.
      eapply Forall.Forall2_Proper_impl;
        try eassumption; try reflexivity; repeat intro.
      eapply (equiv_Z_only_differ_undef (listZ:=rep.listZ_local)); eauto.
    Qed.
  End Local.

  Section InMemory.
    Local Existing Instance rep.listZ_mem.

    Lemma equiv_listZ_only_differ_mem
          locals1 locals2 vset (varnames : base_ltype base_listZ) s x :
          forall (mem : mem),
      map.only_differ locals1 vset locals2 ->
      disjoint vset (varname_set_base varnames) ->
      rep.equiv x (rep.rtype_of_ltype varnames) s locals1 mem ->
      rep.equiv x (rep.rtype_of_ltype varnames) s locals2 mem.
    Proof.
      intros *.
      cbn [rep.equiv rep.rtype_of_ltype rep.listZ_mem
                     varname_set rep.varname_set].
      intros.
      repeat match goal with
               H : Lift1Prop.ex1 _ _ |- Lift1Prop.ex1 _ _ =>
               let x := fresh in
               destruct H as [x ?]; exists x
             end.
      eapply Proper_sep_iff1; [ | reflexivity | eassumption ].
      cancel.
      eapply equiv_Z_only_differ_iff1; eauto using @only_differ_sym with typeclass_instances.
    Qed.

    Lemma equiv_listZ_only_differ_mem_iff1
          locals1 locals2 vset (varnames : base_ltype base_listZ) s x :
      map.only_differ locals1 vset locals2 ->
      disjoint vset (varname_set_base varnames) ->
      Lift1Prop.iff1
        (rep.equiv x (rep.rtype_of_ltype varnames) s locals1)
        (rep.equiv x (rep.rtype_of_ltype varnames) s locals2).
    Proof.
      cbv [Lift1Prop.iff1]; split; intros;
        eapply equiv_listZ_only_differ_mem;
        eauto using @only_differ_sym with typeclass_instances.
    Qed.

    Lemma equiv_listZ_only_differ_undef_mem :
      forall x y s locals locals' vset,
        map.only_differ locals vset locals' ->
        map.undef_on locals vset ->
        Lift1Prop.impl1
          (equivalent_base
             (t:=base_listZ) (listZ:=rep.listZ_mem)
             x y s locals)
          (equivalent_base x y s locals').
    Proof.
      cbn [equivalent_base rep.equiv rep.listZ_mem]; intros; sepsimpl.
      repeat intro; sepsimpl. eexists.
      repeat intro; sepsimpl. eexists.
      eapply Proper_sep_impl1; [ | reflexivity | eassumption ].
      repeat intro; sepsimpl; eauto.
      eapply (equiv_Z_only_differ_undef (listZ:=rep.listZ_mem)); eauto.
    Qed.

    Lemma equiv_nil_iff1 y s : forall (locals : locals),
      Lift1Prop.iff1
        (rep.equiv (rep:=rep.listZ_mem) [] y s locals)
        (Lift1Prop.ex1
           (fun x => rep.equiv (rep:=rep.Z) x y tt locals)).
    Proof.
      cbn [rep.equiv rep.listZ_mem rep.Z].
      intro; split; intros;
        repeat match goal with
               | _ => progress subst
               | _ => progress cbn [Array.array map] in *
               | _ => progress sepsimpl
               | H : map _ _ = [] |- _ =>
                 apply map_eq_nil in H
               | _ => rewrite word.of_Z_unsigned in *
               | |- _ /\ _ => split
               | |- Lift1Prop.ex1 _ _ => eexists
               | |- emp _ _ => cbv [emp]
               | _ => solve [apply word.unsigned_range]
               | _ => solve [eauto using map_nil]
               end.
    Qed.

    Lemma varname_set_listonly_listexcl {t} (names : _ t) :
      sameset
        (varname_set_base names)
        (union (varname_set_listonly names)
               (varname_set_listexcl names)).
    Proof.
      induction t;
        cbn [fst snd varname_set_base varname_set_listexcl
                 varname_set_listonly];
        break_match; intros;
          rewrite ?union_empty_l, ?union_empty_r;
          try reflexivity; [ ].
      rewrite IHt1, IHt2.
      clear. firstorder idtac.
    Qed.

    Lemma varname_set_listexcl_subset {t} (names : base_ltype t) :
      subset (varname_set_listexcl names) (varname_set_base names).
    Proof.
      rewrite varname_set_listonly_listexcl.
      clear. firstorder idtac.
    Qed.
  End InMemory.

  Section Generic.
    Context {listZ : rep.rep base_listZ}
            (equiv_listZ_only_differ_undef :
               forall x y s locals1 locals2 vset,
                 map.only_differ locals1 vset locals2 ->
                 map.undef_on locals1 vset ->
                 Lift1Prop.impl1
                   (rep.equiv (rep:=listZ) x y s locals1)
                   (rep.equiv x y s locals2))
            (equiv_listZ_only_differ :
               forall
                 locals1 locals2 vset
                 (varnames : base_ltype base_listZ) s x mem,
                 map.only_differ locals1 vset locals2 ->
                 disjoint vset (varname_set_base varnames) ->
                 rep.equiv x (rep.rtype_of_ltype varnames) s locals1 mem ->
                 rep.equiv x (rep.rtype_of_ltype varnames) s locals2 mem).

    Lemma equivalent_only_differ {t}
          locals1 locals2 vset (varnames : base_ltype t) s x :
      map.only_differ locals1 vset locals2 ->
      disjoint vset (varname_set_base varnames) ->
      forall mem,
        equivalent_base x (base_rtype_of_ltype varnames) s locals1 mem ->
        equivalent_base x (base_rtype_of_ltype varnames) s locals2 mem.
    Proof.
      intros Hdiffer Hexcl.
      induction t;
        cbn [fst snd rtype_of_ltype varname_set_base equivalent_base] in *;
        intros; break_match; destruct_head'_and; try tauto.
      { (* base case *)
        eapply equiv_Z_only_differ_iff1; eauto using @only_differ_sym with typeclass_instances. }
      { (* prod case *)
        match goal with H : disjoint _ (union _ _) |- _ =>
                        apply disjoint_union_r_iff in H
        end.
        cleanup.
        eapply Proper_sep_impl1; [ | | eassumption]; repeat intro; eauto.
        { apply IHt1; eauto. }
        { apply IHt2; eauto. } }
      { (* list case *)
        eapply equiv_listZ_only_differ; eauto. }
    Qed.

    Lemma equivalent_only_differ_iff1 {t}
          locals1 locals2 vset (varnames : base_ltype t) s x :
      map.only_differ locals1 vset locals2 ->
      disjoint vset (varname_set_base varnames) ->
      Lift1Prop.iff1
        (equivalent_base x (base_rtype_of_ltype varnames) s locals1)
        (equivalent_base x (base_rtype_of_ltype varnames) s locals2).
    Proof.
      repeat intro. split; intros.
      all:eapply equivalent_only_differ; eauto using @only_differ_sym with typeclass_instances.
    Qed.

    Lemma equivalent_args_only_differ {t}
          locals1 locals2 vset
          (argnames : type.for_each_lhs_of_arrow ltype t)
          s x :
      map.only_differ locals1 vset locals2 ->
      disjoint vset (varname_set_args argnames) ->
      let argvalues :=
          type.map_for_each_lhs_of_arrow
            rtype_of_ltype argnames in
      forall m,
        equivalent_args x argvalues s locals1 m ->
        equivalent_args x argvalues s locals2 m.
    Proof.
      induction t;
        cbv [Lift1Prop.iff1];
        cbn [fst snd rtype_of_ltype varname_set_args
                 type.map_for_each_lhs_of_arrow
                 equivalent_args];
        intros; break_match; cbn [fst snd] in *;
          try tauto; [ ].
      intros; cleanup; subst.
      repeat match goal with
             | |- _ /\ _ => split
             | |- exists _, _ => eexists
             | _ => solve [eauto]
             end;
        [ eapply Proper_sep_iff1;
          [ eapply equivalent_only_differ_iff1
          | reflexivity | eassumption ] | eapply IHt2 ];
        eauto using @only_differ_sym with typeclass_instances.
      all:match goal with
          | H : disjoint _ (union _ _) |- _ =>
            apply disjoint_union_r_iff in H;
              cleanup; eauto
          end.
    Qed.

    Lemma equivalent_only_differ_undef {t} :
      forall locals1 locals2 vset x y s,
        map.only_differ locals1 vset locals2 ->
        map.undef_on locals1 vset ->
        Lift1Prop.impl1
          (equivalent_base (t:=t) x y s locals1)
          (equivalent_base x y s locals2).
    Proof.
      induction t;
        cbn [equivalent_base];
        break_match; intros; try reflexivity; [ | | ].
      { eapply equiv_Z_only_differ_undef; eauto. }
      { apply Proper_sep_impl1; eauto. }
      { eapply equiv_listZ_only_differ_undef; eauto. }
    Qed.
  End Generic.
End OnlyDiffer.
Global Hint Resolve
     equiv_listZ_only_differ_undef_local
     equiv_listZ_only_differ_undef_mem
     equiv_listZ_only_differ_local
     equiv_listZ_only_differ_mem : equiv.

Section ContextEquivalence.
  Context
    {width BW word mem locals env ext_spec varname_gen error}
   `{parameters_sentinel : @parameters width BW word mem locals env ext_spec varname_gen error}.
  Context {ok : ok}.
  Local Existing Instance Types.rep.Z.

  Section Local.
    Local Existing Instance Types.rep.listZ_local.

    (* 3-way equivalence (for single elements of the context list G
       from wf3 preconditions) *)
    Definition equiv3 {var1}
               (locals : Interface.map.rep (map:=locals))
               (x : {t : API.type
                         & (var1 t * API.interp_type t * ltype t)%type})
      : Prop :=
      match x with
      | existT (type.base b) (w, x, y) =>
        locally_equivalent x (base_rtype_of_ltype y) locals
      | existT (type.arrow _ _) _ => False (* no functions allowed *)
      end.

    Definition context_equiv {var1} G locals
      : Prop := Forall (equiv3 (var1:= var1) locals) G.

    Fixpoint context_varname_set {var1}
             (G : list {t : API.type & (var1 t * API.interp_type t * ltype t)%type})
      : PropSet.set string :=
      match G with
      | (existT (type.base b) (w, x, y)) :: G' =>
        union (varname_set y) (context_varname_set G')
      |  _ => PropSet.empty_set (* no functions allowed *)
      end.

    Lemma varname_set_local x :
      sameset
        (rep.varname_set (rep:=rep.listZ_local) x)
        (of_list x).
    Proof.
      apply sameset_iff.
      cbn [rep.varname_set rep.listZ_local rep.Z].
      induction x; cbn [fold_right of_list In];
        [ solve [firstorder idtac] | ].
      intros. cbv [of_list] in *.
      rewrite <-IHx. firstorder idtac.
    Qed.
  End Local.

  Lemma equivalent_not_in_context {var1} locals1 locals2 vset x :
    map.only_differ locals1 vset locals2 ->
    disjoint vset (@context_varname_set var1 (x :: nil)) ->
    equiv3 locals1 x ->
    equiv3 locals2 x.
  Proof.
    intros; cbv [equiv3 context_varname_set locally_equivalent] in *.
    destruct x as [x [ [? ?] ?] ]; destruct x; [ | tauto ].
    eapply equivalent_only_differ; eauto with equiv.
    match goal with H : _ |- _ =>
                    apply disjoint_union_r_iff in H end.
    cleanup; eauto.
  Qed.

  Lemma equivalent_not_in_context_forall {var1} locals1 locals2 vset G :
    map.only_differ locals1 vset locals2 ->
    disjoint vset (@context_varname_set var1 G) ->
    Forall (equiv3 locals1) G ->
    Forall (equiv3 locals2) G.
  Proof.
    induction G; intros; constructor;
      repeat match goal with
             | _ => progress cbn [context_varname_set equiv3] in *
             | _ => progress break_match_hyps
             | H : disjoint _ (union _ _) |- _ =>
               apply disjoint_union_r_iff in H; cleanup
             | H : Forall _ (_ :: _) |- _ =>
               inversion H; subst; clear H
             | _ => tauto
             | _ => eapply equivalent_only_differ;
                      solve [eauto with equiv]
             end.
  Qed.
End ContextEquivalence.