From sflib Require Import sflib.
From Paco Require Import paco.
Require Export Coq.Strings.String.
Require Import Coq.Classes.RelationClasses.

From Fairness Require Export ITreeLib FairBeh Mod.
From Fairness Require Import pind PCMLarge.

Set Implicit Arguments.

Section PRIMIVIESIM.
  Context `{M: URA.t}.

  Variable state_src: Type.
  Variable state_tgt: Type.

  Variable _ident_src: ID.
  Definition ident_src := sum_tid _ident_src.
  Variable _ident_tgt: ID.
  Definition ident_tgt := sum_tid _ident_tgt.

  Variable wf_src: WF.
  Variable wf_tgt: WF.

  Let srcE := programE _ident_src state_src.
  Let tgtE := programE _ident_tgt state_tgt.

  Variable wf_stt: Type -> Type -> WF.

  Definition shared :=
    (TIdSet.t *
       (@imap ident_src wf_src) *
       (@imap ident_tgt wf_tgt) *
       state_src *
       state_tgt)%type.

  Let shared_rel: Type := shared -> Prop.

  Variable I: shared -> URA.car -> Prop.

  Variant __lsim
          (tid: thread_id) R_src R_tgt (RR: R_src -> R_tgt -> URA.car -> shared_rel)
          (lsim: bool -> bool -> URA.car -> ((wf_stt R_src R_tgt).(T) * itree srcE R_src) -> itree tgtE R_tgt -> shared_rel)
          (_lsim: bool -> bool -> URA.car -> ((wf_stt R_src R_tgt).(T) * itree srcE R_src) -> itree tgtE R_tgt -> shared_rel)
    :
    bool -> bool -> URA.car -> ((wf_stt R_src R_tgt).(T) * itree srcE R_src) -> itree tgtE R_tgt -> shared_rel :=
  | lsim_ret
      f_src f_tgt r_ctx o o0
      ths im_src im_tgt st_src st_tgt
      r_src r_tgt
      (LT: (wf_stt R_src R_tgt).(lt) o0 o)
      (LSIM: RR r_src r_tgt r_ctx (ths, im_src, im_tgt, st_src, st_tgt))
    :
    __lsim tid RR lsim _lsim f_src f_tgt r_ctx (o, Ret r_src) (Ret r_tgt) (ths, im_src, im_tgt, st_src, st_tgt)

  | lsim_tauL
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      itr_src itr_tgt
      (LSIM: _lsim true f_tgt r_ctx (o, itr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
    :
    __lsim tid RR lsim _lsim f_src f_tgt r_ctx (o, Tau itr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  | lsim_chooseL
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      X ktr_src itr_tgt
      (LSIM: exists x, _lsim true f_tgt r_ctx (o, ktr_src x) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
    :
    __lsim tid RR lsim _lsim f_src f_tgt r_ctx (o, trigger (Choose X) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  | lsim_rmwL
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      X rmw ktr_src itr_tgt
      (LSIM: _lsim true f_tgt r_ctx (o, ktr_src (snd (rmw st_src) : X)) itr_tgt (ths, im_src, im_tgt, fst (rmw st_src), st_tgt))
    :
    __lsim tid RR lsim _lsim f_src f_tgt r_ctx (o, trigger (Rmw rmw) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  | lsim_tidL
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      ktr_src itr_tgt
      (LSIM: _lsim true f_tgt r_ctx (o, ktr_src tid) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
    :
    __lsim tid RR lsim _lsim f_src f_tgt r_ctx (o, trigger (GetTid) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  | lsim_UB
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      ktr_src itr_tgt
    :
    __lsim tid RR lsim _lsim f_src f_tgt r_ctx (o, trigger (Undefined) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  | lsim_fairL
      f_src f_tgt r_ctx o
      ths im_src0 im_tgt st_src st_tgt
      f ktr_src itr_tgt
      (LSIM: exists im_src1,
          (<<FAIR: fair_update im_src0 im_src1 (prism_fmap inrp f)>>) /\
            (<<LSIM: _lsim true f_tgt r_ctx (o, ktr_src tt) itr_tgt (ths, im_src1, im_tgt, st_src, st_tgt)>>))
    :
    __lsim tid RR lsim _lsim f_src f_tgt r_ctx (o, trigger (Fair f) >>= ktr_src) itr_tgt (ths, im_src0, im_tgt, st_src, st_tgt)

  | lsim_tauR
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      itr_src itr_tgt
      (LSIM: _lsim f_src true r_ctx (o, itr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
    :
    __lsim tid RR lsim _lsim f_src f_tgt r_ctx (o, itr_src) (Tau itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | lsim_chooseR
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      X itr_src ktr_tgt
      (LSIM: forall x, _lsim f_src true r_ctx (o, itr_src) (ktr_tgt x) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    __lsim tid RR lsim _lsim f_src f_tgt r_ctx (o, itr_src) (trigger (Choose X) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | lsim_rmwR
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      X rmw itr_src ktr_tgt
      (LSIM: _lsim f_src true r_ctx (o, itr_src) (ktr_tgt (snd (rmw st_tgt) : X)) (ths, im_src, im_tgt, st_src, fst (rmw st_tgt)))
    :
    __lsim tid RR lsim _lsim f_src f_tgt r_ctx (o, itr_src) (trigger (Rmw rmw) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | lsim_tidR
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      itr_src ktr_tgt
      (LSIM: _lsim f_src true r_ctx (o, itr_src) (ktr_tgt tid) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    __lsim tid RR lsim _lsim f_src f_tgt r_ctx (o, itr_src) (trigger (GetTid) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | lsim_fairR
      f_src f_tgt r_ctx o
      ths im_src im_tgt0 st_src st_tgt
      f itr_src ktr_tgt
      (LSIM: forall im_tgt1
                   (FAIR: fair_update im_tgt0 im_tgt1 (prism_fmap inrp f)),
          (<<LSIM: _lsim f_src true r_ctx (o, itr_src) (ktr_tgt tt) (ths, im_src, im_tgt1, st_src, st_tgt)>>))
    :
    __lsim tid RR lsim _lsim f_src f_tgt r_ctx (o, itr_src) (trigger (Fair f) >>= ktr_tgt) (ths, im_src, im_tgt0, st_src, st_tgt)

  | lsim_observe
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      fn args ktr_src ktr_tgt
      (LSIM: forall ret,
          lsim true true r_ctx (o, ktr_src ret) (ktr_tgt ret) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    __lsim tid RR lsim _lsim f_src f_tgt r_ctx (o, trigger (Observe fn args) >>= ktr_src) (trigger (Observe fn args) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)

  | lsim_call
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      fn args ktr_src itr_tgt
    : __lsim tid RR lsim _lsim f_src f_tgt r_ctx (o, trigger (Call fn args) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)

  | lsim_yieldR
      f_src f_tgt r_ctx0 o0
      ths0 im_src0 im_tgt0 st_src0 st_tgt0
      r_own r_shared
      ktr_src ktr_tgt
      (INV: I (ths0, im_src0, im_tgt0, st_src0, st_tgt0) r_shared)
      (VALID: URA.wf (r_shared ⋅ r_own ⋅ r_ctx0))
      o1
      (STUTTER: (wf_stt R_src R_tgt).(lt) o1 o0)
      (LSIM: forall ths1 im_src1 im_tgt1 st_src1 st_tgt1 r_shared1 r_ctx1
               (INV: I (ths1, im_src1, im_tgt1, st_src1, st_tgt1) r_shared1)
               (VALID: URA.wf (r_shared1 ⋅ r_own ⋅ r_ctx1))
               im_tgt2
               (TGT: fair_update im_tgt1 im_tgt2 (prism_fmap inlp (tids_fmap tid ths1))),
          (<<LSIM: lsim true true r_ctx1 (o1, trigger (Yield) >>= ktr_src) (ktr_tgt tt) (ths1, im_src1, im_tgt2, st_src1, st_tgt1)>>))
    :
    __lsim tid RR lsim _lsim f_src f_tgt r_ctx0 (o0, trigger (Yield) >>= ktr_src) (trigger (Yield) >>= ktr_tgt) (ths0, im_src0, im_tgt0, st_src0, st_tgt0)
  | lsim_yieldL
      f_src f_tgt r_ctx o0
      ths im_src0 im_tgt st_src st_tgt
      ktr_src itr_tgt
      (LSIM: exists im_src1 o1,
          (<<FAIR: fair_update im_src0 im_src1 (prism_fmap inlp (tids_fmap tid ths))>>) /\
            (<<LSIM: _lsim true f_tgt r_ctx (o1, ktr_src tt) itr_tgt (ths, im_src1, im_tgt, st_src, st_tgt)>>))
    :
    __lsim tid RR lsim _lsim f_src f_tgt r_ctx (o0, trigger (Yield) >>= ktr_src) itr_tgt (ths, im_src0, im_tgt, st_src, st_tgt)

  | lsim_progress
      r_ctx o
      ths im_src im_tgt st_src st_tgt
      itr_src itr_tgt
      (LSIM: lsim false false r_ctx (o, itr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
    :
    __lsim tid RR lsim _lsim true true r_ctx (o, itr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  .

  Definition lsim (tid: thread_id)
             R_src R_tgt (RR: R_src -> R_tgt -> URA.car -> shared_rel):
    bool -> bool -> URA.car -> ((wf_stt R_src R_tgt).(T) * itree srcE R_src) -> itree tgtE R_tgt -> shared_rel :=
    paco6 (fun r => pind6 (__lsim tid RR r) top6) bot6.

  Lemma __lsim_mon tid R0 R1 (RR: R0 -> R1 -> _ -> _):
    forall r r' (LE: r <6= r'), (__lsim tid RR r) <7= (__lsim tid RR r').
  Proof.
    ii. inv PR; try (econs; eauto; fail).
    eapply lsim_yieldR; eauto. i. hexploit LSIM; eauto.
  Qed.

  Lemma _lsim_mon tid R0 R1 (RR: R0 -> R1 -> _ -> _): forall r, monotone6 (__lsim tid RR r).
  Proof.
    ii. inv IN; try (econs; eauto; fail).
    { des. econs; eauto. }
    { des. econs; eauto. }
    { econs. i. eapply LE. eapply LSIM. eauto. }
    { des. econs; esplits; eauto. }
  Qed.

  Lemma lsim_mon tid R0 R1 (RR: R0 -> R1 -> _ -> _):
    forall q, monotone6 (fun r => pind6 (__lsim tid RR r) q).
  Proof.
    ii. eapply pind6_mon_gen; eauto.
    ii. eapply __lsim_mon; eauto.
  Qed.

  Variant lsim_indC tid R_src R_tgt (RR: R_src -> R_tgt -> URA.car -> shared_rel)
          (r: bool -> bool -> URA.car -> ((wf_stt R_src R_tgt).(T) * itree srcE R_src) -> itree tgtE R_tgt -> shared_rel)
    :
    bool -> bool -> URA.car -> ((wf_stt R_src R_tgt).(T) * itree srcE R_src) -> itree tgtE R_tgt -> shared_rel :=
    | lsim_indC_ret
        f_src f_tgt r_ctx o o0
        ths im_src im_tgt st_src st_tgt
        r_src r_tgt
        (LT: (wf_stt R_src R_tgt).(lt) o0 o)
        (LSIM: RR r_src r_tgt r_ctx (ths, im_src, im_tgt, st_src, st_tgt))
      :
      lsim_indC tid RR r f_src f_tgt r_ctx (o, Ret r_src) (Ret r_tgt) (ths, im_src, im_tgt, st_src, st_tgt)

    | lsim_indC_tauL
        f_src f_tgt r_ctx o
        ths im_src im_tgt st_src st_tgt
        itr_src itr_tgt
        (LSIM: r true f_tgt r_ctx (o, itr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
      :
      lsim_indC tid RR r f_src f_tgt r_ctx (o, Tau itr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
    | lsim_indC_chooseL
        f_src f_tgt r_ctx o
        ths im_src im_tgt st_src st_tgt
        X ktr_src itr_tgt
        (LSIM: exists x, r true f_tgt r_ctx (o, ktr_src x) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
      :
      lsim_indC tid RR r f_src f_tgt r_ctx (o, trigger (Choose X) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
    | lsim_indC_rmwL
        f_src f_tgt r_ctx o
        ths im_src im_tgt st_src st_tgt
        X rmw ktr_src itr_tgt
        (LSIM: r true f_tgt r_ctx (o, ktr_src (snd (rmw st_src) : X)) itr_tgt (ths, im_src, im_tgt, fst (rmw st_src), st_tgt))
      :
      lsim_indC tid RR r f_src f_tgt r_ctx (o, trigger (Rmw rmw) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
    | lsim_indC_tidL
        f_src f_tgt r_ctx o
        ths im_src im_tgt st_src st_tgt
        ktr_src itr_tgt
        (LSIM: r true f_tgt r_ctx (o, ktr_src tid) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
      :
      lsim_indC tid RR r f_src f_tgt r_ctx (o, trigger (GetTid) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
    | lsim_indC_UB
        f_src f_tgt r_ctx o
        ths im_src im_tgt st_src st_tgt
        ktr_src itr_tgt
      :
      lsim_indC tid RR r f_src f_tgt r_ctx (o, trigger (Undefined) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
    | lsim_indC_fairL
        f_src f_tgt r_ctx o
        ths im_src0 im_tgt st_src st_tgt
        f ktr_src itr_tgt
        (LSIM: exists im_src1,
            (<<FAIR: fair_update im_src0 im_src1 (prism_fmap inrp f)>>) /\
              (<<LSIM: r true f_tgt r_ctx (o, ktr_src tt) itr_tgt (ths, im_src1, im_tgt, st_src, st_tgt)>>))
      :
      lsim_indC tid RR r f_src f_tgt r_ctx (o, trigger (Fair f) >>= ktr_src) itr_tgt (ths, im_src0, im_tgt, st_src, st_tgt)

    | lsim_indC_tauR
        f_src f_tgt r_ctx o
        ths im_src im_tgt st_src st_tgt
        itr_src itr_tgt
        (LSIM: r f_src true r_ctx (o, itr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
      :
      lsim_indC tid RR r f_src f_tgt r_ctx (o, itr_src) (Tau itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
    | lsim_indC_chooseR
        f_src f_tgt r_ctx o
        ths im_src im_tgt st_src st_tgt
        X itr_src ktr_tgt
        (LSIM: forall x, r f_src true r_ctx (o, itr_src) (ktr_tgt x) (ths, im_src, im_tgt, st_src, st_tgt))
      :
      lsim_indC tid RR r f_src f_tgt r_ctx (o, itr_src) (trigger (Choose X) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
    | lsim_indC_rmwR
        f_src f_tgt r_ctx o
        ths im_src im_tgt st_src st_tgt
        X rmw itr_src ktr_tgt
        (LSIM: r f_src true r_ctx (o, itr_src) (ktr_tgt (snd (rmw st_tgt) : X)) (ths, im_src, im_tgt, st_src, fst (rmw st_tgt)))
      :
      lsim_indC tid RR r f_src f_tgt r_ctx (o, itr_src) (trigger (Rmw rmw) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
    | lsim_indC_tidR
        f_src f_tgt r_ctx o
        ths im_src im_tgt st_src st_tgt
        itr_src ktr_tgt
        (LSIM: r f_src true r_ctx (o, itr_src) (ktr_tgt tid) (ths, im_src, im_tgt, st_src, st_tgt))
      :
      lsim_indC tid RR r f_src f_tgt r_ctx (o, itr_src) (trigger (GetTid) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
    | lsim_indC_fairR
        f_src f_tgt r_ctx o
        ths im_src im_tgt0 st_src st_tgt
        f itr_src ktr_tgt
        (LSIM: forall im_tgt1
                 (FAIR: fair_update im_tgt0 im_tgt1 (prism_fmap inrp f)),
            (<<LSIM: r f_src true r_ctx (o, itr_src) (ktr_tgt tt) (ths, im_src, im_tgt1, st_src, st_tgt)>>))
      :
      lsim_indC tid RR r f_src f_tgt r_ctx (o, itr_src) (trigger (Fair f) >>= ktr_tgt) (ths, im_src, im_tgt0, st_src, st_tgt)

    | lsim_indC_observe
        f_src f_tgt r_ctx o
        ths im_src im_tgt st_src st_tgt
        fn args ktr_src ktr_tgt
        (LSIM: forall ret,
            r true true r_ctx (o, ktr_src ret) (ktr_tgt ret) (ths, im_src, im_tgt, st_src, st_tgt))
      :
      lsim_indC tid RR r f_src f_tgt r_ctx (o, trigger (Observe fn args) >>= ktr_src) (trigger (Observe fn args) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)

    | lsim_indC_call
        f_src f_tgt r_ctx o
        ths im_src im_tgt st_src st_tgt
        fn args ktr_src itr_tgt
      : lsim_indC tid RR r f_src f_tgt r_ctx (o, trigger (Call fn args) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)

    | lsim_indC_yieldR
        f_src f_tgt r_ctx0 o0
        ths0 im_src0 im_tgt0 st_src0 st_tgt0
        r_own r_shared
        ktr_src ktr_tgt
        (INV: I (ths0, im_src0, im_tgt0, st_src0, st_tgt0) r_shared)
        (VALID: URA.wf (r_shared ⋅ r_own ⋅ r_ctx0))
        o1
        (STUTTER: (wf_stt R_src R_tgt).(lt) o1 o0)
        (LSIM: forall ths1 im_src1 im_tgt1 st_src1 st_tgt1 r_shared1 r_ctx1
                 (INV: I (ths1, im_src1, im_tgt1, st_src1, st_tgt1) r_shared1)
                 (VALID: URA.wf (r_shared1 ⋅ r_own ⋅ r_ctx1))
                 im_tgt2
                 (TGT: fair_update im_tgt1 im_tgt2 (prism_fmap inlp (tids_fmap tid ths1))),
            (<<LSIM: r true true r_ctx1 (o1, trigger (Yield) >>= ktr_src) (ktr_tgt tt) (ths1, im_src1, im_tgt2, st_src1, st_tgt1)>>))
      :
      lsim_indC tid RR r f_src f_tgt r_ctx0 (o0, trigger (Yield) >>= ktr_src) (trigger (Yield) >>= ktr_tgt) (ths0, im_src0, im_tgt0, st_src0, st_tgt0)
    | lsim_indC_yieldL
        f_src f_tgt r_ctx o0
        ths im_src0 im_tgt st_src st_tgt
        ktr_src itr_tgt
        (LSIM: exists im_src1 o1,
            (<<FAIR: fair_update im_src0 im_src1 (prism_fmap inlp (tids_fmap tid ths))>>) /\
              (<<LSIM: r true f_tgt r_ctx (o1, ktr_src tt) itr_tgt (ths, im_src1, im_tgt, st_src, st_tgt)>>))
      :
      lsim_indC tid RR r f_src f_tgt r_ctx (o0, trigger (Yield) >>= ktr_src) itr_tgt (ths, im_src0, im_tgt, st_src, st_tgt)

    | lsim_indC_progress
        r_ctx o
        ths im_src im_tgt st_src st_tgt
        itr_src itr_tgt
        (LSIM: r false false r_ctx (o, itr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
      :
      lsim_indC tid RR r true true r_ctx (o, itr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  .

  Lemma lsim_indC_mon tid R0 R1 (RR: R0 -> R1 -> _ -> _): monotone6 (lsim_indC tid RR).
  Proof.
    ii. inv IN; try (econs; eauto; fail).
    { des; econs; eauto. }
    { des; econs; eauto. }
    { econs. i. specialize (LSIM _ FAIR). eauto. }
    { econs; eauto. i. hexploit LSIM; eauto. }
    { des; econs; eauto. esplits; eauto. }
  Qed.

  Hint Resolve lsim_indC_mon: paco.

  Lemma lsim_indC_wrepectful tid R0 R1 (RR: R0 -> R1 -> _ -> _):
    wrespectful6 (fun r => pind6 (__lsim tid RR r) top6) (lsim_indC tid RR).
  Proof.
    econs; eauto with paco.
    i. eapply pind6_fold. inv PR.
    { eapply lsim_ret; eauto. }
    { eapply lsim_tauL; eauto. split; ss.
      eapply GF in LSIM. eapply pind6_mon_gen; ss. eauto.
      i. eapply __lsim_mon. 2: eauto. i. eapply rclo6_base; auto.
    }
    { des. eapply lsim_chooseL; eauto. esplits; eauto. split; ss.
      eapply GF in LSIM. eapply pind6_mon_gen; ss. eauto.
      i. eapply __lsim_mon. 2: eauto. i. eapply rclo6_base; auto.
    }
    { eapply lsim_rmwL; eauto. split; ss.
      eapply GF in LSIM. eapply pind6_mon_gen; ss. eauto.
      i. eapply __lsim_mon. 2: eauto. i. eapply rclo6_base; auto.
    }
    { eapply lsim_tidL; eauto. split; ss.
      eapply GF in LSIM. eapply pind6_mon_gen; ss. eauto.
      i. eapply __lsim_mon. 2: eauto. i. eapply rclo6_base; auto.
    }
    { eapply lsim_UB; eauto. }
    { des. eapply lsim_fairL; eauto. esplits; eauto. split; ss.
      eapply GF in LSIM0. eapply pind6_mon_gen; ss. eauto.
      i. eapply __lsim_mon. 2: eauto. i. eapply rclo6_base; auto.
    }
    { eapply lsim_tauR; eauto. split; ss.
      eapply GF in LSIM. eapply pind6_mon_gen; ss. eauto.
      i. eapply __lsim_mon. 2: eauto. i. eapply rclo6_base; auto.
    }
    { eapply lsim_chooseR; eauto. i. specialize (LSIM x). split; ss.
      eapply GF in LSIM. eapply pind6_mon_gen; ss. eauto.
      i. eapply __lsim_mon. 2: eauto. i. eapply rclo6_base; auto.
    }
    { eapply lsim_rmwR; eauto. split; ss.
      eapply GF in LSIM. eapply pind6_mon_gen; ss. eauto.
      i. eapply __lsim_mon. 2: eauto. i. eapply rclo6_base; auto.
    }
    { eapply lsim_tidR; eauto. split; ss.
      eapply GF in LSIM. eapply pind6_mon_gen; ss. eauto.
      i. eapply __lsim_mon. 2: eauto. i. eapply rclo6_base; auto.
    }
    { eapply lsim_fairR; eauto. i. specialize (LSIM _ FAIR). split; ss.
      eapply GF in LSIM. eapply pind6_mon_gen; ss. eauto.
      i. eapply __lsim_mon. 2: eauto. i. eapply rclo6_base; auto.
    }
    { eapply lsim_observe; eauto. i. specialize (LSIM ret).
      eapply rclo6_base; auto.
    }
    { eapply lsim_call. }
    { eapply lsim_yieldR; eauto. i. specialize (LSIM _ _ _ _ _ _ _ INV0 VALID0 _ TGT).
      des. esplits; eauto.
      eapply rclo6_base; auto.
    }
    { des. eapply lsim_yieldL; eauto. esplits; eauto. split; ss.
      eapply GF in LSIM0. eapply pind6_mon_gen; ss. eauto.
      i. eapply __lsim_mon. 2: eauto. i. eapply rclo6_base; auto.
    }
    { eapply lsim_progress; eauto. eapply rclo6_base; auto. }
  Qed.

  Lemma lsim_indC_spec tid R0 R1 (RR: R0 -> R1 -> _ -> _):
    (lsim_indC tid RR) <7= gupaco6 (fun r => pind6 (__lsim tid RR r) top6) (cpn6 (fun r => pind6 (__lsim tid RR r) top6)).
  Proof.
    i. eapply wrespect6_uclo; eauto with paco.
    { eapply lsim_mon. }
    eapply lsim_indC_wrepectful.
  Qed.

  Variant lsim_resetC R_src R_tgt (RR: R_src -> R_tgt -> URA.car -> shared_rel)
          (r: bool -> bool -> URA.car -> ((wf_stt R_src R_tgt).(T) * itree srcE R_src) -> itree tgtE R_tgt -> shared_rel)
    :
    bool -> bool -> URA.car -> ((wf_stt R_src R_tgt).(T) * itree srcE R_src) -> itree tgtE R_tgt -> shared_rel :=
    | lsim_resetC_intro
        src tgt shr r_ctx
        ps0 pt0 ps1 pt1
        (REL: r ps1 pt1 r_ctx src tgt shr)
        (SRC: ps1 = true -> ps0 = true)
        (TGT: pt1 = true -> pt0 = true)
      :
      lsim_resetC RR r ps0 pt0 r_ctx src tgt shr
  .

  Lemma lsim_resetC_spec tid R_src R_tgt (RR: R_src -> R_tgt -> URA.car -> shared_rel)
    :
    lsim_resetC RR <7= gupaco6 (fun r => pind6 (__lsim tid RR r) top6) (cpn6 (fun r => pind6 (__lsim tid RR r) top6)).
  Proof.
    eapply wrespect6_uclo; eauto with paco.
    { eapply lsim_mon. }
    econs.
    { ii. inv IN. econs; eauto. }
    i. inv PR. eapply GF in REL.
    eapply pind6_acc in REL.
    instantiate (1:= (fun ps1 pt1 r_ctx src tgt shr =>
                        forall ps0 pt0,
                          (ps1 = true -> ps0 = true) ->
                          (pt1 = true -> pt0 = true) ->
                          pind6 (__lsim tid RR (rclo6 (lsim_resetC RR) r)) top6 ps0 pt0 r_ctx src tgt shr)) in REL; eauto.
    ss. i. eapply pind6_unfold in PR.
    2:{ eapply _lsim_mon. }
    rename PR into LSIM. inv LSIM.

    { eapply pind6_fold. econs; eauto. }

    { destruct LSIM0 as [LSIM0 IND]. clear LSIM0.
      eapply pind6_fold. eapply lsim_tauL. split; ss.
      hexploit IH; eauto.
    }

    { des. eapply pind6_fold. eapply lsim_chooseL. esplits; eauto. split; ss.
      destruct LSIM0 as [LSIM0 IND]. hexploit IH; eauto.
    }

    { eapply pind6_fold. eapply lsim_rmwL. split; ss.
      destruct LSIM0 as [LSIM0 IND]. hexploit IH; eauto.
    }

    { eapply pind6_fold. eapply lsim_tidL. split; ss.
      destruct LSIM0 as [LSIM0 IND]. hexploit IH; eauto.
    }

    { eapply pind6_fold. eapply lsim_UB. }

    { des. eapply pind6_fold. eapply lsim_fairL. esplits; eauto. split; ss.
      destruct LSIM as [LSIM IND]. hexploit IH; eauto.
    }

    { destruct LSIM0 as [LSIM0 IND]. clear LSIM0.
      eapply pind6_fold. eapply lsim_tauR. split; ss.
      hexploit IH. eauto. all: eauto.
    }

    { eapply pind6_fold. eapply lsim_chooseR. i. split; ss. specialize (LSIM0 x).
      destruct LSIM0 as [LSIM0 IND]. hexploit IH; eauto.
    }

    { eapply pind6_fold. eapply lsim_rmwR. split; ss.
      destruct LSIM0 as [LSIM0 IND]. hexploit IH; eauto.
    }

    { eapply pind6_fold. eapply lsim_tidR. split; ss.
      destruct LSIM0 as [LSIM0 IND]. hexploit IH; eauto.
    }

    { eapply pind6_fold. eapply lsim_fairR. i. split; ss. specialize (LSIM0 _ FAIR).
      des. destruct LSIM0 as [LSIM0 IND]. hexploit IH; eauto.
    }

    { eapply pind6_fold. eapply lsim_observe. i. eapply rclo6_base. auto. }

    { eapply pind6_fold. eapply lsim_call. }

    { eapply pind6_fold. eapply lsim_yieldR; eauto. i.
      hexploit LSIM0; eauto. clear LSIM0. intros LSIM0. des. esplits; eauto.
      eapply rclo6_base. auto.
    }

    { des. eapply pind6_fold. eapply lsim_yieldL. esplits; eauto. split; ss.
      destruct LSIM as [LSIM IND]. hexploit IH; eauto.
    }

    { hexploit H; ss; i. hexploit H0; ss; i. clarify.
      eapply pind6_fold. eapply lsim_progress. eapply rclo6_base; auto. }
  Qed.

  Lemma lsim_reset_prog
        tid
        R0 R1 (RR: R0 -> R1 -> URA.car -> shared_rel)
        src tgt shr
        ps0 pt0 ps1 pt1 r_ctx
        (LSIM: lsim tid RR ps1 pt1 r_ctx src tgt shr)
        (SRC: ps1 = true -> ps0 = true)
        (TGT: pt1 = true -> pt0 = true)
    :
    lsim tid RR ps0 pt0 r_ctx src tgt shr.
  Proof.
    ginit.
    { eapply lsim_mon. }
    { eapply cpn6_wcompat. eapply lsim_mon. }
    guclo lsim_resetC_spec.
    { eapply lsim_mon. }
    econs; eauto. gfinal.
    { eapply lsim_mon. }
    right. auto.
  Qed.

  Lemma lsim_set_prog
        tid
        R0 R1 (RR: R0 -> R1 -> URA.car -> shared_rel)
        r_ctx src tgt shr
        (LSIM: lsim tid RR true true r_ctx src tgt shr)
    :
    forall ps pt, lsim tid RR ps pt r_ctx src tgt shr.
  Proof.
    i. revert_until RR. pcofix CIH. i.
    remember true as ps0 in LSIM at 1. remember true as pt0 in LSIM at 1.
    move LSIM before CIH. revert_until LSIM. punfold LSIM.
    2:{ eapply lsim_mon. }
    eapply pind6_acc in LSIM.

    { instantiate (1:= (fun ps0 pt0 r_ctx src tgt shr =>
                          ps0 = true ->
                          pt0 = true ->
                          forall ps pt,
                            paco6 (fun r0 => pind6 (__lsim tid RR r0) top6) r ps pt r_ctx src tgt shr)) in LSIM; auto. }

    ss. clear ps0 pt0 r_ctx src tgt shr LSIM.
    intros rr DEC IH gps gpt r_ctx src tgt shr LSIM. clear DEC.
    intros Egps Egpt ps pt.
    eapply pind6_unfold in LSIM.
    2:{ eapply _lsim_mon. }
    inv LSIM.

    { pfold. eapply pind6_fold. econs; eauto. }

    { destruct LSIM0 as [LSIM0 IND]. clear LSIM0.
      pfold. eapply pind6_fold. eapply lsim_tauL. split; ss.
      hexploit IH. eauto. all: eauto. i. punfold H. eapply lsim_mon.
    }

    { des. pfold. eapply pind6_fold. eapply lsim_chooseL. esplits; eauto. split; ss.
      destruct LSIM0 as [LSIM0 IND]. hexploit IH; eauto. i. punfold H. eapply lsim_mon.
    }

    { pfold. eapply pind6_fold. eapply lsim_rmwL. split; ss.
      destruct LSIM0 as [LSIM0 IND]. hexploit IH; eauto. i. punfold H. eapply lsim_mon.
    }

    { pfold. eapply pind6_fold. eapply lsim_tidL. split; ss.
      destruct LSIM0 as [LSIM0 IND]. hexploit IH; eauto. i. punfold H. eapply lsim_mon.
    }

    { pfold. eapply pind6_fold. eapply lsim_UB. }

    { des. pfold. eapply pind6_fold. eapply lsim_fairL. esplits; eauto. split; ss.
      destruct LSIM as [LSIM IND]. hexploit IH; eauto. i. punfold H. eapply lsim_mon.
    }

    { destruct LSIM0 as [LSIM0 IND]. clear LSIM0.
      pfold. eapply pind6_fold. eapply lsim_tauR. split; ss.
      hexploit IH. eauto. all: eauto. i. punfold H. eapply lsim_mon.
    }

    { pfold. eapply pind6_fold. eapply lsim_chooseR. i. split; ss. specialize (LSIM0 x).
      destruct LSIM0 as [LSIM0 IND]. hexploit IH; eauto. i. punfold H. eapply lsim_mon.
    }

    { pfold. eapply pind6_fold. eapply lsim_rmwR. split; ss.
      destruct LSIM0 as [LSIM0 IND]. hexploit IH; eauto. i. punfold H. eapply lsim_mon.
    }

    { pfold. eapply pind6_fold. eapply lsim_tidR. split; ss.
      destruct LSIM0 as [LSIM0 IND]. hexploit IH; eauto. i. punfold H. eapply lsim_mon.
    }

    { pfold. eapply pind6_fold. eapply lsim_fairR. i. split; ss. specialize (LSIM0 _ FAIR).
      des. destruct LSIM0 as [LSIM0 IND]. hexploit IH; eauto. i. punfold H. eapply lsim_mon.
    }

    { pfold. eapply pind6_fold. eapply lsim_observe. i. eapply upaco6_mon_bot; eauto. }

    { pfold. eapply pind6_fold. eapply lsim_call. }

    { pfold. eapply pind6_fold. eapply lsim_yieldR; eauto. i.
      hexploit LSIM0; eauto. clear LSIM0. intros LSIM0. des. esplits; eauto.
      eapply upaco6_mon_bot; eauto.
    }

    { des. pfold. eapply pind6_fold. eapply lsim_yieldL. esplits; eauto. split; ss.
      destruct LSIM as [LSIM IND]. hexploit IH; eauto. i. punfold H. eapply lsim_mon.
    }

    { pclearbot. eapply paco6_mon_bot. eapply lsim_reset_prog. eauto. all: ss. }

  Qed.

  Variant lsim_ord_weakC R_src R_tgt (RR: R_src -> R_tgt -> URA.car -> shared_rel)
          (r: bool -> bool -> URA.car -> ((wf_stt R_src R_tgt).(T) * itree srcE R_src) -> itree tgtE R_tgt -> shared_rel)
    :
    bool -> bool -> URA.car -> ((wf_stt R_src R_tgt).(T) * itree srcE R_src) -> itree tgtE R_tgt -> shared_rel :=
    | lsim_ord_weakC_intro
        src tgt shr r_ctx ps pt o0 o1
        (REL: r ps pt r_ctx (o0, src) tgt shr)
        (LE: (wf_stt R_src R_tgt).(le) o0 o1)
      :
      lsim_ord_weakC RR r ps pt r_ctx (o1, src) tgt shr
  .

  Lemma lsim_ord_weakC_spec tid R_src R_tgt (RR: R_src -> R_tgt -> URA.car -> shared_rel)
    :
    lsim_ord_weakC RR <7= gupaco6 (fun r => pind6 (__lsim tid RR r) top6) (cpn6 (fun r => pind6 (__lsim tid RR r) top6)).
  Proof.
    eapply wrespect6_uclo; eauto with paco.
    { eapply lsim_mon. }
    econs.
    { ii. inv IN. econs; eauto. }
    i. inv PR. destruct LE0 as [EQ | LT].
    { clarify. eapply pind6_mon_gen. eapply GF; eauto. 2: ss.
      i. eapply __lsim_mon. 2: eauto. i. eapply rclo6_base. auto.
    }
    eapply GF in REL.
    remember (o0, src) as osrc. rename REL into LSIM.
    move LSIM before GF. revert_until LSIM.
    pattern x0, x1, x2, osrc, x4, x5.
    revert x0 x1 x2 osrc x4 x5 LSIM. apply pind6_acc.
    intros rr DEC IH. clear DEC. intros ps pt r_ctx osrc tgt shr LSIM.
    i; clarify.
    eapply pind6_unfold in LSIM.
    2:{ eapply _lsim_mon. }
    inv LSIM.

    { eapply pind6_fold. eapply lsim_ret; eauto. }
    { eapply pind6_fold. eapply lsim_tauL; eauto.
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND; eauto.
    }
    { eapply pind6_fold. eapply lsim_chooseL; eauto.
      des. exists x.
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND; eauto.
    }
    { eapply pind6_fold. eapply lsim_rmwL; eauto.
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND; eauto.
    }
    { eapply pind6_fold. eapply lsim_tidL; eauto.
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND; eauto.
    }
    { eapply pind6_fold. eapply lsim_UB; eauto. }
    { eapply pind6_fold. eapply lsim_fairL; eauto.
      des. esplits; eauto.
      split; ss. destruct LSIM as [LSIM IND]. eapply IH in IND; eauto.
    }
    { eapply pind6_fold. eapply lsim_tauR; eauto.
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND; eauto.
    }
    { eapply pind6_fold. eapply lsim_chooseR; eauto.
      i. specialize (LSIM0 x).
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND; eauto.
    }
    { eapply pind6_fold. eapply lsim_rmwR; eauto.
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND; eauto.
    }
    { eapply pind6_fold. eapply lsim_tidR; eauto.
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND; eauto.
    }
    { eapply pind6_fold. eapply lsim_fairR; eauto.
      i. specialize (LSIM0 _ FAIR).
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND; eauto.
    }
    { eapply pind6_fold. eapply lsim_observe; eauto.
      i. specialize (LSIM0 ret).
      eapply rclo6_clo_base. econs; eauto. right. auto.
    }

    { eapply pind6_fold. eapply lsim_call. }

    { eapply pind6_fold. eapply lsim_yieldR; eauto.
      i. hexploit LSIM0; clear LSIM0; eauto; intro LSIM. des. esplits; eauto.
      eapply rclo6_clo_base. econs; eauto. right. auto.
    }

    { eapply pind6_fold. eapply lsim_yieldL; eauto.
      des. esplits; eauto. destruct LSIM as [LSIM IND].
      split; ss. eapply pind6_mon_gen. eapply LSIM. 2: ss.
      i. eapply __lsim_mon. 2: eapply PR. i. eapply rclo6_base; eauto.
    }

    { eapply pind6_fold. eapply lsim_progress.
      eapply rclo6_clo_base. econs; eauto. right. auto.
    }

  Qed.

  Lemma stutter_ord_weak
        tid
        R0 R1 (LRR: R0 -> R1 -> URA.car -> shared_rel)
        ps pt r_ctx src tgt (shr: shared) o0 o1
        (LE: (wf_stt R0 R1).(le) o0 o1)
        (LSIM: lsim tid LRR ps pt r_ctx (o0, src) tgt shr)
    :
    lsim tid LRR ps pt r_ctx (o1, src) tgt shr.
  Proof.
    ginit.
    { eapply lsim_mon. }
    { eapply cpn6_wcompat. eapply lsim_mon. }
    guclo lsim_ord_weakC_spec.
    { eapply lsim_mon. }
    econs; eauto. gfinal.
    { eapply lsim_mon. }
    right. auto.
  Qed.

  Definition local_RR {R0 R1} (RR: R0 -> R1 -> Prop) tid:
    R0 -> R1 -> URA.car -> shared_rel :=
    fun (r_src: R0) (r_tgt: R1) (r_ctx: URA.car) '(ths2, im_src1, im_tgt1, st_src1, st_tgt1) =>
      (exists ths3 r_own r_shared,
          (<<THS: NatMap.remove tid ths2 = ths3>>) /\
            (<<VALID: URA.wf (r_shared ⋅ r_own ⋅ r_ctx)>>) /\
            (<<INV: I (ths3, im_src1, im_tgt1, st_src1, st_tgt1) r_shared>>) /\
            (<<RET: RR r_src r_tgt>>)).

  Definition local_sim {R0 R1} (RR: R0 -> R1 -> Prop) src tgt :=
    forall ths0 im_src0 im_tgt0 st_src0 st_tgt0 r_shared0 r_ctx0
      (INV: I (ths0, im_src0, im_tgt0, st_src0, st_tgt0) r_shared0)
      tid ths1
      (THS: TIdSet.add_new tid ths0 ths1)
      (VALID: URA.wf (r_shared0 ⋅ r_ctx0)),
    forall im_tgt0'
      (UPD: fair_update im_tgt0 im_tgt0' (prism_fmap inlp (fun t => if (tid_dec t tid) then Flag.success else Flag.emp))),
    exists r_shared1 r_own o im_src0',
      (<<INV: I (ths1, im_src0', im_tgt0', st_src0, st_tgt0) r_shared1>>) /\
        (<<VALID: URA.wf (r_shared1 ⋅ r_own ⋅ r_ctx0)>>) /\
        (forall ths im_src1 im_tgt1 st_src st_tgt r_shared2 r_ctx2
           (INV: I (ths, im_src1, im_tgt1, st_src, st_tgt) r_shared2)
           (VALID: URA.wf (r_shared2 ⋅ r_own ⋅ r_ctx2))
           im_tgt2
           (TGT: fair_update im_tgt1 im_tgt2 (prism_fmap inlp (tids_fmap tid ths))),
          exists im_src2, (<<SRC: fair_update im_src1 im_src2 (prism_fmap inlp (tids_fmap tid ths))>>) /\
                       (<<LSIM: forall fs ft,
                           lsim
                             tid
                             (@local_RR R0 R1 RR tid)
                             fs ft
                             r_ctx2
                             (o, src) tgt
                             (ths, im_src2, im_tgt2, st_src, st_tgt)
                             >>)).

  Definition local_sim_init {R0 R1} (RR: R0 -> R1 -> Prop) (r_own: URA.car) tid src tgt o :=
    forall ths im_src im_tgt st_src st_tgt r_shared r_ctx
      (INV: I (ths, im_src, im_tgt, st_src, st_tgt) r_shared)
      (VALID: URA.wf (r_shared ⋅ r_own ⋅ r_ctx)),
    forall im_tgt1 (FAIR: fair_update im_tgt im_tgt1 (prism_fmap inlp (tids_fmap tid ths))),
    exists im_src1,
      (<<SRC: fair_update im_src im_src1 (prism_fmap inlp (tids_fmap tid ths))>>) /\
        forall fs ft,
          lsim
            tid
            (@local_RR R0 R1 RR tid)
            fs ft
            r_ctx
            (o, src) tgt
            (ths, im_src1, im_tgt1, st_src, st_tgt).

End PRIMIVIESIM.
#[export] Hint Constructors __lsim: core.
#[export] Hint Unfold lsim: core.
#[export] Hint Resolve __lsim_mon: paco.
#[export] Hint Resolve _lsim_mon: paco.
#[export] Hint Resolve lsim_mon: paco.

Module ModSim.
  Section MODSIM.

    Variable md_src: Mod.t.
    Variable md_tgt: Mod.t.

    Record mod_sim: Prop :=
      mk {
          wf_src : WF;
          wf_tgt : WF;
          wf_tgt_inhabited: inhabited wf_tgt.(T);
          wf_tgt_open: forall (o0: wf_tgt.(T)), exists o1, wf_tgt.(lt) o0 o1;

          world: URA.t;

          (* I: (@shared md_src.(Mod.state) md_tgt.(Mod.state) md_src.(Mod.ident) md_tgt.(Mod.ident) wf_src wf_tgt) -> world -> Prop; *)
          wf_stt : Type -> Type -> WF;
          init: forall im_tgt,
          exists (I: (@shared md_src.(Mod.state) md_tgt.(Mod.state) md_src.(Mod.ident) md_tgt.(Mod.ident) wf_src wf_tgt) -> world -> Prop),
          (exists im_src r_shared,
            (I (NatSet.empty, im_src, im_tgt, md_src.(Mod.st_init), md_tgt.(Mod.st_init)) r_shared) /\
              (URA.wf r_shared)) /\
              (forall fn args, match md_src.(Mod.funs) fn, md_tgt.(Mod.funs) fn with
                          | Some ktr_src, Some ktr_tgt => local_sim wf_stt I (@eq Any.t) (ktr_src args) (ktr_tgt args)
                          | None        , None         => True
                          | _           , _            => False
                          end);
        }.
  End MODSIM.
End ModSim.

From Fairness Require Import Concurrency.

Module UserSim.
  Section MODSIM.

    Variable md_src: Mod.t.
    Variable md_tgt: Mod.t.

    Record sim (p_src: Th.t _) (p_tgt: Th.t _) : Prop :=
      mk {
          wf_src : WF;
          wf_tgt : WF;
          wf_tgt_inhabited: inhabited wf_tgt.(T);
          wf_tgt_open: forall (o0: wf_tgt.(T)), exists o1, wf_tgt.(lt) o0 o1;

          world: URA.t;

          wf_stt : Type -> Type -> WF;
          funs: forall im_tgt,
          exists (I: (@shared md_src.(Mod.state) md_tgt.(Mod.state) md_src.(Mod.ident) md_tgt.(Mod.ident) wf_src wf_tgt) -> world -> Prop),
          exists im_src rs r_shared os,
            (<<INIT: I (key_set p_src, im_src, im_tgt, md_src.(Mod.st_init), md_tgt.(Mod.st_init)) r_shared>>) /\
              (<<SIM: Forall4
                        (fun '(t1, src) '(t2, tgt) '(t3, r) '(t4, o) =>
                           t1 = t2 /\ t1 = t3 /\ t1 = t4 /\
                             @local_sim_init _ md_src.(Mod.state) md_tgt.(Mod.state) md_src.(Mod.ident) md_tgt.(Mod.ident) wf_src wf_tgt wf_stt I _ _ (@eq Any.t) r t1 src tgt o)
                        (Th.elements p_src) (Th.elements p_tgt) (NatMap.elements rs) (NatMap.elements os)>>) /\
              (<<WF: URA.wf (r_shared ⋅ NatMap.fold (fun _ r s => r ⋅ s) rs ε)>>)
        }.
  End MODSIM.
End UserSim.


From oadt.lang_oadt Require Import
     base syntax semantics typing infrastructure
     equivalence admissible inversion values weakening.
Import syntax.notations semantics.notations typing.notations equivalence.notations.

Implicit Types (b : bool) (x X y Y : atom) (L : aset).

#[local]
Coercion EFVar : atom >-> expr.

(** * Substitution lemmas *)

Section fix_gctx.

Context (Σ : gctx).
Context (Hwf : gctx_wf Σ).

#[local]
Set Default Proof Using "Hwf".

Lemma subst_tctx_typing_kinding_ x s :
  (forall Γ e l τ,
      Γ ⊢ e :{l} τ ->
      x ∉ fv τ ∪ dom Γ ->
      ({x↦s} <$> Γ) ⊢ e :{l} τ) /\
  (forall Γ τ κ,
      Γ ⊢ τ :: κ ->
      x ∉ dom Γ ->
      ({x↦s} <$> Γ) ⊢ τ :: κ).
Proof.
  apply typing_kinding_mutind; intros; subst; simpl in *;
    econstructor; eauto;
      simpl_cofin?;
      (* Try to apply induction hypotheses. *)
      lazymatch goal with
      | |- ?Γ ⊢ ?e : _ =>
        auto_apply || lazymatch goal with
                      | H : _ -> ?Γ' ⊢ e : _ |- _ =>
                        replace Γ with Γ'; [auto_apply |]
                      end
      | |- ?Γ ⊢ ?τ :: _ =>
        auto_apply || lazymatch goal with
                      | H : _ -> ?Γ' ⊢ τ :: _ |- _ =>
                        replace Γ with Γ'; [auto_apply |]
                      end
      | _ => idtac
      end; eauto;
        (* Solve other side conditions *)
        repeat lazymatch goal with
               | |- _ ∉ _ =>
                 shelve
               | |- _ <> _ =>
                 shelve
               | |- {_↦_} <$> (<[_:=_]>_) = <[_:=_]>({_↦_} <$> _) =>
                 rewrite fmap_insert; try reflexivity; repeat f_equal
               | |- _ !! _ = Some _ =>
                 simplify_map_eq
               | |- Some _ = Some _ =>
                 try reflexivity; repeat f_equal
               | |- {_↦_} _ = _ =>
                 rewrite <- ?lexpr_subst_distr; rewrite subst_fresh
               end;
        eauto.

  Unshelve.

  all : try fast_set_solver!!; simpl_fv; fast_set_solver!!.
Qed.

Lemma subst_tctx_typing Γ e l τ x s :
  Γ ⊢ e :{l} τ ->
  x ∉ fv τ ∪ dom Γ ->
  ({x↦s} <$> Γ) ⊢ e :{l} τ.
Proof.
  qauto use: subst_tctx_typing_kinding_.
Qed.

(* Note that [lc s] is not needed, and it is here only for convenience. I will
drop it in the actual lemma. *)
Lemma subst_preservation_ x s l' τ' :
  lc s ->
  (forall Γ' e l τ,
      Γ' ⊢ e :{l} τ ->
      forall Γ,
        Γ' = <[x:=(l', τ')]>Γ ->
        x ∉ fv τ' ∪ dom Γ ->
        Γ ⊢ s :{l'} τ' ->
        ({x↦s} <$> Γ) ⊢ {x↦s}e :{l} {x↦s}τ) /\
  (forall Γ' τ κ,
      Γ' ⊢ τ :: κ ->
      forall Γ,
        Γ' = <[x:=(l', τ')]>Γ ->
        x ∉ fv τ' ∪ dom Γ ->
        Γ ⊢ s :{l'} τ' ->
        ({x↦s} <$> Γ) ⊢ {x↦s}τ :: κ).
Proof.
  intros Hlc.
  apply typing_kinding_mutind; intros; subst; simpl in *;
    (* First we normalize the typing and kinding judgments so they are ready
    for applying typing and kinding rules to. *)
    rewrite ?subst_open_distr by assumption;
    rewrite ?subst_ite_distr;
    try lazymatch goal with
        | |- _ ⊢ [inj@_< ?ω > _] : {_↦_}?ω =>
          rewrite subst_fresh by shelve
        | |- context [decide (_ = _)] =>
          (* The case of [fvar x] is the trickier one. Let's handle it later. *)
          case_decide; subst; [shelve |]
        end;
      (* Apply typing and kinding rules. *)
      econstructor;
      simpl_cofin?;
      (* We define this subroutine [go] for applying induction hypotheses. *)
      let go Γ :=
          (* We massage the typing and kinding judgments so that we can apply
          induction hypotheses to them. *)
          rewrite <- ?subst_ite_distr;
            rewrite <- ?subst_open_distr by assumption;
            rewrite <- ?subst_open_comm by (try assumption; shelve);
            try lazymatch Γ with
                | <[_:=_]>({_↦_} <$> _) =>
                  try rewrite lexpr_subst_distr;
                  rewrite <- fmap_insert
                end;
            (* Apply one of the induction hypotheses. *)
            first [ auto_apply
                  (* In [if] and [case] cases, prove the type matching the
                  induction hypothesis later. *)
                  | relax_typing_type; [ auto_apply | ] ] in
      (* Make sure we complete handling the typing and kinding judgments first.
      Otherwise some existential variables may have undesirable
      instantiation. *)
      lazymatch goal with
      | |- ?Γ ⊢ _ : _ => go Γ
      | |- ?Γ ⊢ _ :: _ => go Γ
      | _ => idtac
      end;
        (* Try to solve other side conditions. *)
        eauto;
        repeat lazymatch goal with
               | |- _ ∉ _ =>
                 shelve
               | |- _ <> _ =>
                 shelve
               | |- <[_:=_]>(<[_:=_]>_) = <[_:=_]>(<[_:=_]>_) =>
                 apply insert_commute
               | |- _ ≡ _ =>
                 apply pared_equiv_subst2
               | |- (_ <$> _) !! _ = Some _ =>
                 simplify_map_eq
               | |- <[_:=_]>_ ⊢ _ : _ =>
                 apply weakening_insert
               | |- Some _ = Some _ =>
                 try reflexivity; repeat f_equal
               | |- _ = <{ {_↦_} _ }> =>
                 rewrite subst_fresh
               | H : ?Σ !! ?x = Some _ |- ?Σ !! ?x = Some _ =>
                 rewrite H
               end;
        eauto.

  (* Prove the types of [if] and [case] match the induction hypotheses. *)
  all : rewrite subst_open_distr by eassumption; simpl; eauto;
    rewrite decide_False by shelve; eauto.

  Unshelve.

  (* Case [fvar x] *)
  simplify_map_eq.
  rewrite subst_fresh.
  apply subst_tctx_typing; eauto.

  (* Solve other side conditions of free variables. *)
  all : try fast_set_solver!!; simpl_fv; fast_set_solver*!!.
Qed.

(** The actual substitution lemma *)
Lemma subst_preservation x s l' τ' Γ e l τ :
  <[x:=(l', τ')]>Γ ⊢ e :{l} τ ->
  Γ ⊢ s :{l'} τ' ->
  x ∉ fv τ' ∪ dom Γ ∪ tctx_fv Γ ->
  Γ ⊢ {x↦s}e :{l} {x↦s}τ.
Proof.
  intros.
  rewrite <- (subst_tctx_fresh Γ x s) by fast_set_solver!!.
  eapply subst_preservation_; eauto using typing_lc.
  fast_set_solver!!.
Qed.

Lemma kinding_subst_preservation x s l' τ' Γ τ κ :
  <[x:=(l', τ')]>Γ ⊢ τ :: κ ->
  Γ ⊢ s :{l'} τ' ->
  x ∉ fv τ' ∪ dom Γ ∪ tctx_fv Γ ->
  Γ ⊢ {x↦s}τ :: κ.
Proof.
  intros.
  rewrite <- (subst_tctx_fresh Γ x s) by fast_set_solver!!.
  eapply subst_preservation_; eauto using typing_lc.
  fast_set_solver!!.
Qed.

Lemma open_preservation_alt x s l' τ' Γ e l τ :
  <[x:=(l', τ')]>Γ ⊢ e^x :{l} τ ->
  Γ ⊢ s :{l'} τ' ->
  x ∉ fv τ' ∪ fv e ∪ dom Γ ∪ tctx_fv Γ ->
  Γ ⊢ e^s :{l} {x↦s}τ.
Proof.
  intros.
  rewrite (subst_intro e s x) by fast_set_solver!!.
  eapply subst_preservation; eauto.
  fast_set_solver!!.
Qed.

Lemma open_preservation x s l' τ' Γ e l τ :
  <[x:=(l', τ')]>Γ ⊢ e^x :{l} τ^x ->
  Γ ⊢ s :{l'} τ' ->
  x ∉ fv τ' ∪ fv e ∪ fv τ ∪ dom Γ ∪ tctx_fv Γ ->
  Γ ⊢ e^s :{l} τ^s.
Proof.
  intros.
  rewrite (subst_intro e s x) by fast_set_solver!!.
  rewrite (subst_intro τ s x) by fast_set_solver!!.
  eapply subst_preservation; eauto.
  fast_set_solver!!.
Qed.

Lemma kinding_open_preservation x s l' τ' Γ τ κ :
  <[x:=(l', τ')]>Γ ⊢ τ^x :: κ ->
  Γ ⊢ s :{l'} τ' ->
  x ∉ fv τ' ∪ fv τ ∪ dom Γ ∪ tctx_fv Γ ->
  Γ ⊢ τ^s :: κ.
Proof.
  intros.
  rewrite (subst_intro τ s x) by fast_set_solver!!.
  eapply kinding_subst_preservation; eauto.
  fast_set_solver!!.
Qed.

Lemma open_preservation_lc x s l' τ' Γ e l τ :
  <[x:=(l', τ')]>Γ ⊢ e^x :{l} τ ->
  Γ ⊢ s :{l'} τ' ->
  x ∉ fv τ' ∪ fv e ∪ fv τ ∪ dom Γ ∪ tctx_fv Γ ->
  Γ ⊢ e^s :{l} τ.
Proof.
  intros H. intros.
  erewrite <- (open_lc_intro τ s) by eauto using typing_type_lc.
  erewrite <- (open_lc_intro τ x) in H by eauto using typing_type_lc.
  eapply open_preservation; eauto.
Qed.

(** * Other lemmas *)

(** Types of well-typed expressions are well-kinded *)
Lemma regularity Γ e l τ :
  Γ ⊢ e :{l} τ ->
  exists κ, Γ ⊢ τ :: κ.
Proof.
  induction 1; simp_hyps; eauto using kinding;
    try (apply_gctx_wf; eauto using kinding_weakening_empty);
    kind_inv; simpl_cofin?; simp_hyps;
    try first [ eexists; typing_kinding_intro; eauto; fast_set_solver!!
              (* Types may be opened. *)
              | eexists; qauto use: kinding_open_preservation
                               solve: fast_set_solver!! ].
  (* Boxed injection case *)
  sfirstorder use: otval_well_kinded, ovalty_elim.
Qed.

Ltac apply_regularity :=
  select! (_ ⊢ _ : _)
        (fun H => dup_hyp H (fun H => eapply regularity in H; simp_hyp H)).

(** We can substitute with an equivalent type and a more permissive label in the
typing contexts. *)
Lemma subst_conv_ x l1 l2 τ1 τ2 :
  τ1 ≡ τ2 ->
  (forall Γ' e l τ,
      Γ' ⊢ e :{l} τ ->
      forall Γ κ',
        Γ' = <[x:=(l1, τ1)]>Γ ->
        x ∉ dom Γ ->
        Γ ⊢ τ2 :: κ' ->
        l2 ⊑ l1 ->
        <[x:=(l2, τ2)]>Γ ⊢ e :{l} τ) /\
  (forall Γ' τ κ,
      Γ' ⊢ τ :: κ ->
      forall Γ κ',
        Γ' = <[x:=(l1, τ1)]>Γ ->
        x ∉ dom Γ ->
        Γ ⊢ τ2 :: κ' ->
        l2 ⊑ l1 ->
        <[x:=(l2, τ2)]>Γ ⊢ τ :: κ).
Proof.
  intros Heq.
  apply typing_kinding_mutind; intros; subst;
    (* [TFVar] is the key base case. Prove it later *)
    try lazymatch goal with
        | |- _ ⊢ fvar _ : _ =>
          shelve
        end;
    try solve [ econstructor; eauto ];
    simpl_cofin?;
    repeat
      match goal with
      | H : forall _ _, _ -> _ -> _ -> _ -> _ |- _ =>
        efeed specialize H;
          [ try reflexivity; rewrite insert_commute by shelve; reflexivity
          | fast_set_solver!!
          | eauto using kinding_weakening_insert
          | solve [eauto]
          | .. ];
          try rewrite insert_commute in H by shelve
      end;

    try apply_regularity;
    try eapply TConv;
      repeat
        (eauto;
         lazymatch goal with
         | |- _ ⊢ _ : _ =>
           typing_intro
         | |- _ ⊢ _^_ :: _ =>
           eapply kinding_open_preservation
         | |- _ ⊢ _ :: _ =>
           kinding_intro
         | |- _ ≡ _ =>
           equiv_naive_solver
         | |- _ ∉ _ =>
           shelve
         end).

  Unshelve.

  (* [TFVar] *)
  match goal with
  | |- _ ⊢ fvar ?x' : _ => destruct (decide (x' = x))
  end; subst;
    try solve [ econstructor; simplify_map_eq; eauto ].
  simplify_map_eq.
  eapply TConv; eauto.
  typing_intro; simplify_map_eq; eauto.
  eauto using kinding_weakening_insert.
  equiv_naive_solver.

  all : try fast_set_solver!!; simpl_fv; fast_set_solver!!.
Qed.

Lemma subst_conv Γ e l τ κ' x l1 l2 τ1 τ2 :
  <[x:=(l1, τ1)]>Γ ⊢ e :{l} τ ->
  Γ ⊢ τ2 :: κ' ->
  τ1 ≡ τ2 ->
  l2 ⊑ l1 ->
  x ∉ dom Γ ->
  <[x:=(l2, τ2)]>Γ ⊢ e :{l} τ.
Proof.
  hauto use: subst_conv_.
Qed.

Lemma kinding_subst_conv Γ τ κ κ' x l1 l2 τ1 τ2 :
  <[x:=(l1, τ1)]>Γ ⊢ τ :: κ ->
  Γ ⊢ τ2 :: κ' ->
  τ1 ≡ τ2 ->
  l2 ⊑ l1 ->
  x ∉ dom Γ ->
  <[x:=(l2, τ2)]>Γ ⊢ τ :: κ.
Proof.
  hauto use: subst_conv_.
Qed.

Lemma oval_safe Γ v l τ :
  Γ ⊢ v :{l} τ ->
  oval v ->
  Γ ⊢ v :{⊥} τ.
Proof.
  intros Ht Hv.
  apply_regularity.
  apply woval_otval in Ht; eauto using oval_woval. simp_hyps.
  eapply ovalty_intro in Hv; eauto.
  select (_ ⊢ _ : _) (fun H => clear H).
  eapply ovalty_elim in Hv. simp_hyps.
  econstructor; eauto.
Qed.

(** * Preservation *)

(** The combined preservation theorems for parallel reduction. *)
Lemma pared_preservation_ :
  (forall Γ e l τ,
      Γ ⊢ e :{l} τ ->
      forall e', e ⇛ e' ->
            Γ ⊢ e' :{l} τ) /\
  (forall Γ τ κ,
      Γ ⊢ τ :: κ ->
      forall τ', τ ⇛ τ' ->
            Γ ⊢ τ' :: κ).
Proof.
  apply typing_kinding_mutind; intros; subst;
    (* Inversion on parallel reduction. *)
    repeat pared_inv;
    simplify_eq;
    try apply_gctx_wf;
    simpl_cofin?;
    (* Solve some trivial cases. *)
    try solve [ lazymatch goal with
                | H : _ !! _ = Some (DFun _ _) |- _ =>
                  eauto using weakening_empty
                end
              | lazymatch goal with
                | H : oval _ |- _ =>
                    eauto using oval_safe
                end
              | try case_ite_expr;
                simp_hyps;
                repeat
                  (eauto;
                   lazymatch goal with
                   | |- _ ⊢ _ : ?τ =>
                     first [ is_evar τ | econstructor ]
                   | |- _ ⊢ _ :: ?κ =>
                     first [ is_evar κ | econstructor ]
                   end)];
    (* Now turn to the more interesting cases. *)
    (* Derive some equivalence for later convenience. *)
    try select! (_ ⇛ _)
        (fun H => dup_hyp H (fun H => apply pared_equiv_pared in H));
    (* Derive well-kindedness from typing. *)
    try apply_regularity;
    (* Apply inversion lemmas for typing and kinding. *)
    kind_inv;
    type_inv;
    (* Instantiate induction hypotheses. *)
    repeat
      match goal with
      | H : forall _, _ ⇛ _ -> _ |- _ =>
        efeed specialize H; [
          solve [ repeat
                    (eauto;
                     lazymatch goal with
                     | |- ?e ⇛ _ =>
                       first [ lazymatch e with
                               | <{ ~if _ then _ else _ }> =>
                                 eapply RCgrIte
                               end
                             | match goal with
                               | H : ?e1 ⇛ _ |- _ =>
                                   let e1 := lazymatch e1 with
                                             | <{ ?e1^_ }> => e1
                                             | _ => e1
                                             end in
                                   lazymatch e with
                                   | context [e1] =>
                                       head_constructor e; pared_intro
                                   end
                               end
                             | eapply pared_open1
                             | lcrefl ]
                     | |- lc _ => eauto using lc, kinding_lc
                     | |- _ ∉ _ => shelve
                     end) ]
         |];
        try type_inv H;
        try kind_inv H
      end;
    (* Derive equivalence for the sub-expressions. *)
    try simpl_whnf_equiv;
    (* We may have cofinite quantifiers that are generated by the inversion
    lemmas. *)
    simpl_cofin?;
    simplify_eq;
    (* Main solver. *)
    repeat
      (try case_ite_expr;
       eauto;
       match goal with
       (* Replace the types in context with an equivalent ones. *)
       | H : <[_:=_]>_ ⊢ _ :{?l} _ |- <[_:=_]>_ ⊢ _ :{?l} _ =>
           eapply subst_conv
       | |- <[_:=_]>_ ⊢ _ :{?l} _ =>
           is_evar l; eapply subst_conv
       | |- <[_:=_]>_ ⊢ _ :: _ =>
           eapply kinding_subst_conv
       (* Apply substitution/open lemmas. *)
       | H : <[_:=_]>?Γ ⊢ ?e^(fvar _) : ?τ |- ?Γ ⊢ ?e^_ : ?τ =>
           eapply open_preservation_lc
       | H : <[_:=_]>?Γ ⊢ ?e^(fvar _) : _^(fvar _) |- ?Γ ⊢ ?e^_ : _ =>
           eapply open_preservation
       (* This is for the dependent case expression. *)
       | H : <[_:=_]>?Γ ⊢ ?e^(fvar _) : _^_ |- ?Γ ⊢ ?e^_ : _ =>
           eapply open_preservation_alt
       | H : <[_:=_]>?Γ ⊢ ?e^(fvar _) :: _ |- ?Γ ⊢ ?e^_ :: _ =>
           eapply kinding_open_preservation
       (* Apply typing rules. *)
       | |- _ ⊢ _ : _ =>
           typing_intro
       | |- _ ⊢ _ : ?τ =>
           assert_fails is_evar τ; eapply TConv
       (* Apply kinding rules. *)
       | |- _ ⊢ _ :: ?κ =>
           eauto using kinding_weakening_empty; kinding_intro
       (* Solve equivalence. *)
       | |- _ ≡ _ =>
           try case_split; equiv_naive_solver
       | |- _ ≡ _ =>
           apply_pared_equiv_congr
       | |- <{ _^_ }> ≡ <{ _^_ }> =>
           eapply pared_equiv_open1; simpl_cofin?
       | |- <{ _^_ }> ≡ <{ _^_ }> =>
           eapply pared_equiv_open
       (* Solve other side conditions. *)
       | |- lc _ =>
           eauto using lc, open_respect_lc,
           typing_type_lc, typing_lc, kinding_lc
       | |- _ ⊑ _ =>
           first [ lattice_naive_solver
                     by eauto using (top_ub (A:=bool)),
                                    (join_ub_l (A:=bool)), (join_ub_r (A:=bool))
                 | hauto use: (join_lub (A:=bool)) ]
       | |- _ ∉ _ => shelve
       end).

  (* The case when oblivious injection steps to boxed injection. *)
  hauto lq: on ctrs: ovalty inv: otval use: ovalty_intro.

  (* These equivalence are generated by the case when the case discriminee takes
  a step. *)
  1-2 :
  rewrite subst_open_distr by eauto using typing_lc; simpl;
  rewrite decide_True by auto;
  rewrite !subst_fresh by shelve;
  eapply pared_equiv_open1; simpl_cofin?;
  eauto 7 using lc, open_respect_lc, typing_lc, kinding_lc, pared_equiv_congr_inj
          with equiv_naive_solver.

  (* These 4 cases are generated by the case when oblivious case analysis steps
  to oblivious condition. *)
  1-4 :
  repeat ovalty_inv;
  select! (ovalty _ _) (fun H => apply ovalty_elim in H; simp_hyp H);
  eapply TConv;
  eauto using weakening, map_empty_subseteq with equiv_naive_solver.

  (* The case when we apply oblivious type to its argument: [RAppOADT] *)
  eapply kinding_open_preservation; eauto; try set_shelve.
  eapply kinding_weakening; eauto.
  rewrite insert_union_singleton_l.
  apply map_union_subseteq_l.

  Unshelve.

  all : fast_set_solver!!.
Qed.

Lemma pared_preservation Γ e l e' τ :
  Γ ⊢ e :{l} τ ->
  e ⇛ e' ->
  Γ ⊢ e' :{l} τ.
Proof.
  hauto use: pared_preservation_.
Qed.

Lemma pared_kinding_preservation Γ τ τ' κ :
  Γ ⊢ τ :: κ ->
  τ ⇛ τ' ->
  Γ ⊢ τ' :: κ.
Proof.
  hauto use: pared_preservation_.
Qed.

(** The preservation theorem for [step]. *)
Theorem preservation Γ e l e' τ :
  Γ ⊢ e :{l} τ ->
  e -->! e' ->
  Γ ⊢ e' :{l} τ.
Proof.
  hauto use: pared_preservation, pared_step, typing_lc.
Qed.

Theorem kinding_preservation Γ τ τ' κ :
  Γ ⊢ τ :: κ ->
  τ -->! τ' ->
  Γ ⊢ τ' :: κ.
Proof.
  hauto use: pared_kinding_preservation, pared_step, kinding_lc.
Qed.

End fix_gctx.

Ltac apply_regularity :=
  select! (_ ⊢ _ : _)
        (fun H => dup_hyp H (fun H => eapply regularity in H;
                                  [ simp_hyp H | assumption ])).


Require Export Arith.EqNat.
Require Export Arith.Lt.
Require Export Arith.Compare_dec.
Require Export List.
Require Import String.
Open Scope string_scope.
Require Import TacticsSF.
Require Import TacticsCPDT.
Require Import Process.
Require Import List.
Require Import PrettyPrinter.
Require Import TypeAssignmentPoly.
Require Import ResultBasics.
Require Import ExampleCommon.
Require Import ExampleRecursion.

Lemma abp_recvA_Nack_procR_typing :
  forall i k r t (xc:free_id) (xerr2:free_id) (xout:free_id),
    ~ In xc ("recv_true" :: "recv_false" :: nil)
    ->
    ~ In xerr2 (xc :: "recv_true" :: "recv_false" :: nil)
    ->
    ~ In xout (xerr2 :: xc :: "recv_true" :: "recv_false" :: nil)
    ->
    (CTX.add (ValVariable (Var (Free xout)), TChannel (SDual (SToks t)))
      (CTX.add (ValVariable (Var (Free xc)), TChannel SEpsilon)
      (CTX.add (ValVariable (Var (Free xerr2)),
        TChannel (SDual (SNack r k t (token_of_bool (negb i)))))
      (CTX.add (ValName (Nm (Free ("recv_" ++ string_of_bool i))),
        TChannel (SFwd (SRecv i)))
      (CTX.add (ValName (CoNm (Free ("recv_" ++ string_of_bool i))),
        TChannel (SDual (SFwd (SRecv i))))
      (CTX.add (ValName (CoNm (Free ("recv_" ++ string_of_bool (negb i)))),
        TChannel (SDual (SFwd (SRecv (negb i)))))
      CTX.empty))))))
    |-p Var (Free xerr2) !
          Token (if if i then false else true then "true" else "false");
        (New
        (CoNm (Free (String.append "recv_" (if i then "true" else "false")))
          ! Nm (Bound 0);
        (CoNm (Bound 0) ! Var (Free xerr2);
        (CoNm (Bound 0) ! Var (Free xout);
        Zero)))).
Proof.
  intros i k r t xc xerr2 xout Hxc_nin Hxerr2_nin Hxout_nin.
  (* err2!(1-i); rest *)
  eapply TypPrefixOutput with
      (s:=SDual (SNack r k t (token_of_bool (negb i))))
      (rho:=TSingleton (token_of_bool (negb i)))
      (t:=SDual (SAck t (token_of_bool (negb i))));
    [apply trdual_w_mdual_involution; constructor; assumption
      | left; discriminate
      | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
      | apply LToken; destruct i; ctx_wf; discriminate_w_list
      | right; split; [reflexivity | constructor]
      | reflexivity
      | ].
  (* main event *)
  (* recv_i(err2, out), i.e. New d *)
  apply TypNew with (s:=SRecv i)
      (L:=xc :: xerr2 :: xout :: "recv_true" :: "recv_false" :: nil);
    intros d G' H_d_nin G'def; compute; subst G'.
  (* d!"recv_i"; rest *)
  eapply TypPrefixOutput with (s:=SDual (SFwd (SRecv i)))
      (rho:=TChannel (SRecv i)) (t:=SDual (SFwd (SRecv i)));
    [apply trdual_w_mdual_involution; constructor
      | left; discriminate
      | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
      | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
      | left; reflexivity
      | reflexivity
      | ].
  (* d!err2; rest *)
  eapply TypPrefixOutput with (s:=SDual (SRecv i))
      (rho:=TChannel (SDual (SAck t (token_of_bool (negb i)))))
      (t:=SDual (SRecv1 i (SAck t (token_of_bool (negb i))) t));
    [apply trdual_w_mdual_involution; constructor; reflexivity
      | left; discriminate
      | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
      | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
      | left; reflexivity
      | reflexivity
      | ].
  (* d!out; rest *)
  eapply TypPrefixOutput with
      (s:=SDual (SRecv1 i (SAck t (token_of_bool (negb i))) t))
      (rho:=TChannel (SDual (SToks t)))
      (t:=SDual SEpsilon);
    [apply trdual_w_mdual_involution; constructor; reflexivity
      | left; discriminate
      | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
      | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
      | left; reflexivity
      | reflexivity
      | ].
  (* 0 *)
  apply TypZero;
    destruct i;
    ctx_wf;
    discriminate_w_list.
Qed.


Require Import syntax.
Require Import alist.
Require Import FMapWeakList.

Require Import Coqlib.
Require Import infrastructure.
Require Import Metatheory.
Import LLVMsyntax.
Import LLVMinfra.

Require Import Exprs.
Require Import Hints.
Require Import TODO.
Require Import Postcond.
Require Import Infrules.

Require Import Debug.

Set Implicit Arguments.

Parameter gen_infrules_from_insns : insn -> insn -> Assertion.t -> list Infrule.t.
Parameter gen_infrules_next_inv : bool -> Assertion.t -> Assertion.t -> list Infrule.t.

Fixpoint valid_cmds
         (m_src m_tgt:module)
         (src tgt:list cmd)
         (hint:list (list Infrule.t * Assertion.t))
         (inv0:Assertion.t): option Assertion.t :=
  match hint, src, tgt with
  | (infrules, inv)::hint, cmd_src::src, cmd_tgt::tgt =>
    let (cmd_src, cmd_tgt) :=
        (debug_print cmd_pair_printer (cmd_src, cmd_tgt)) in
    if (Assertion.has_false inv0) then valid_cmds m_src m_tgt src tgt hint inv else
    let oinv1 :=
        match postcond_cmd cmd_src cmd_tgt inv0 with
        | Some inv1 => Some inv1
        | None =>
          let infr := gen_infrules_from_insns (insn_cmd cmd_src)
                                              (insn_cmd cmd_tgt)
                                              inv0 in
          let inv0_infr := apply_infrules m_src m_tgt infr inv0 in
          let inv0_infr := debug_print_auto infr inv0_infr in
          postcond_cmd cmd_src cmd_tgt inv0_infr
        end
    in
    match oinv1 with
    | None => failwith_None "valid_cmds: postcond_cmd returned None" nil
    | Some inv1 =>
      let infrules_auto := gen_infrules_next_inv true inv1 inv0 in
      let inv2 := apply_infrules m_src m_tgt (infrules_auto++infrules) inv1 in
      let inv3 := reduce_maydiff inv2 in
      let inv := debug_print_validation_process infrules inv0 inv1 inv2 inv3 inv in
      if
        (if Assertion.implies inv3 inv
         then true
         else
           (* TODO: need new print method *)
           let infrules := gen_infrules_next_inv false inv3 inv in
           let inv3_infr := apply_infrules m_src m_tgt infrules inv3 in
           let inv3_red := reduce_maydiff inv3_infr in
           let inv3_red := debug_print_auto infrules inv3_red in
           Assertion.implies inv3_red inv)
      then valid_cmds m_src m_tgt src tgt hint inv
      else failwith_None "valid_cmds: Assertion.implies returned false" nil
    end
  | nil, nil, nil => Some inv0
  | _, _, _ => None
  end.

Definition lookup_phinodes_infrules hint_stmts l_from :=
  match lookupAL _ hint_stmts.(ValidationHint.phinodes) l_from with
  | None => nil
  | Some infrules => infrules
  end.

Definition valid_phinodes
           (hint_fdef:ValidationHint.fdef)
           (inv0:Assertion.t)
           (m_src m_tgt:module)
           (blocks_src blocks_tgt:blocks)
           (l_from l_to:l): bool :=
  let l_from := (debug_print atom_printer l_from) in
  let l_to := (debug_print atom_printer l_to) in
  match lookupAL _ hint_fdef l_to, lookupAL _ blocks_src l_to, lookupAL _ blocks_tgt l_to with
  | Some hint_stmts, Some (stmts_intro phinodes_src _ _), Some (stmts_intro phinodes_tgt _ _) =>
    let infrules := lookup_phinodes_infrules hint_stmts l_from in
    match postcond_phinodes l_from phinodes_src phinodes_tgt inv0 with
      | None => failwith_false "valid_phinodes: postcond_phinodes returned None at phinode" (l_from::l_to::nil)
      | Some inv1 =>
        let infrules_auto := gen_infrules_next_inv true inv1 inv0 in
        let inv2 := apply_infrules m_src m_tgt (infrules_auto++infrules) inv1 in
        let inv3 := reduce_maydiff inv2 in
        let inv4 := hint_stmts.(ValidationHint.assertion_after_phinodes) in
        let inv4 := debug_print_validation_process infrules inv0 inv1 inv2 inv3 inv4 in
        if negb (Assertion.implies inv3 inv4)
        then
          let infrules := gen_infrules_next_inv false inv3 inv4 in
          let inv3_infr := apply_infrules m_src m_tgt infrules inv3 in
          let inv3_red := reduce_maydiff inv3_infr in
          let inv3_red := debug_print_auto infrules inv3_red in
          if negb (Assertion.implies inv3_red inv4)
          then failwith_false "valid_phinodes: Assertion.implies returned false at phinode" (l_from::l_to::nil)
          else true
        else true
    end
  | _, _, _ => false
  end.

(* TODO: position *)
Lemma const_l_dec (cl1 cl2:const * l):
  {cl1 = cl2} + {cl1 <> cl2}.
Proof.
  decide equality. apply const_dec.
Defined.

(* TODO *)
Require Import sflib.

Lemma list_const_l_dec (cls1 cls2:list (const * l)):
  {cls1 = cls2} + {cls1 <> cls2}.
Proof.
  revert cls2.
  induction cls1; destruct cls2;
    (try by left);
    (try by right).
  decide equality. apply const_l_dec.
Defined.

Definition valid_terminator
           (hint_fdef:ValidationHint.fdef)
           (inv0:Assertion.t)
           (m_src m_tgt:module)
           (blocks_src blocks_tgt:blocks)
           (bid:l)
           (src tgt:terminator): bool :=
  if (Assertion.has_false inv0) then true else
  match src, tgt with
  | insn_return_void _, insn_return_void _ => true
  | insn_return _ ty_src val_src, insn_return _ ty_tgt val_tgt =>
    if negb (typ_dec ty_src ty_tgt)
    then failwith_false "valid_terminator: return type not matched at block" [bid]
    else

    if negb (Assertion.inject_value
               inv0
               (ValueT.lift Tag.physical val_src)
               (ValueT.lift Tag.physical val_tgt))
    then failwith_false "valid_terminator: inject_value of returned values failed at block" [bid]
    else true

  | insn_br _ val_src l1_src l2_src, insn_br _ val_tgt l1_tgt l2_tgt =>
    if negb (Assertion.inject_value
               inv0
               (ValueT.lift Tag.physical val_src)
               (ValueT.lift Tag.physical val_tgt))
    then failwith_false "valid_terminator: inject_value of branch conditions failed at block" [bid]
    else

    if negb (l_dec l1_src l1_tgt)
    then failwith_false "valid_terminator: labels of true branches not matched at block" [bid]
    else

    if negb (l_dec l2_src l2_tgt)
    then failwith_false "valid_terminator: labels of false branches not matched at block" [bid]
    else

    if negb (valid_phinodes hint_fdef (add_terminator_cond inv0 src tgt l1_src) m_src m_tgt blocks_src blocks_tgt bid l1_src)
    then failwith_false "valid_terminator: valid_phinodes of true branches failed at block" [bid]
    else

    if negb (valid_phinodes hint_fdef (add_terminator_cond inv0 src tgt l2_src) m_src m_tgt blocks_src blocks_tgt bid l2_src)
    then failwith_false "valid_terminator: valid_phinodes of false branches failed at block" [bid]
    else true

  | insn_br_uncond _ l_src, insn_br_uncond _ l_tgt =>
    if negb (l_dec l_src l_tgt)
    then failwith_false "valid_terminator: labels of unconditional branches not matched at block" [bid]
    else

    if negb (valid_phinodes hint_fdef (add_terminator_cond inv0 src tgt l_src) m_src m_tgt blocks_src blocks_tgt bid l_src)
    then failwith_false "valid_terminator: valid_phinodes of unconditional branches failed at block" [bid]
    else true

  | insn_switch _ typ_src val_src l0_src ls_src,
    insn_switch _ typ_tgt val_tgt l0_tgt ls_tgt =>
    if negb (typ_dec typ_src typ_tgt)
    then failwith_false "valid_terminator: types of switch conditions failed at block" [bid]
    else

    if negb (Assertion.inject_value
               inv0
               (ValueT.lift Tag.physical val_src)
               (ValueT.lift Tag.physical val_tgt))
    then failwith_false "valid_terminator: value of switch conditions failed at block" [bid]
    else

    if negb (l_dec l0_src l0_tgt)
    then failwith_false "valid_terminator: default labels of switch failed at block" [bid]
    else

    if negb (list_const_l_dec ls_src ls_tgt)
    then failwith_false "valid_terminator: other labels conditions failed at block" [bid]
    else

    if negb (forallb
               (fun cl =>
                  if negb (valid_phinodes hint_fdef (add_terminator_cond inv0 src tgt cl.(snd)) m_src m_tgt blocks_src blocks_tgt bid cl.(snd))
                  then failwith_false "valid_terminator: valid_phinodes of switches failed at block" [bid]
                  else true)
               ls_src)
    then failwith_false "valid_terminator: valid_phinodes failed" [bid]
    else

    if negb (valid_phinodes hint_fdef (add_terminator_cond inv0 src tgt l0_src) m_src m_tgt blocks_src blocks_tgt bid l0_src)
    then failwith_false "valid_terminator: valid_phinodes failed" [bid]
    else true

  | insn_unreachable _, insn_unreachable _ => true
  | _, _ => failwith_false "valid_terminator: types of terminators not matched at block" [bid]
  end.

Definition valid_stmts
           (hint_fdef:ValidationHint.fdef)
           (hint:ValidationHint.stmts)
           (m_src m_tgt:module)
           (blocks_src blocks_tgt:blocks)
           (bid:l) (src tgt:stmts): bool :=
  let '(stmts_intro phinodes_src cmds_src terminator_src) := src in
  let '(stmts_intro phinodes_tgt cmds_tgt terminator_tgt) := tgt in
  match valid_cmds m_src m_tgt cmds_src cmds_tgt hint.(ValidationHint.cmds) hint.(ValidationHint.assertion_after_phinodes) with
  | None => failwith_false "valid_stmts: valid_cmds failed at block" [bid]
  | Some inv =>
    (if (valid_terminator hint_fdef inv m_src m_tgt blocks_src blocks_tgt bid terminator_src terminator_tgt)
     then true
     else
       let infrules := gen_infrules_from_insns
                         (insn_terminator terminator_src)
                         (insn_terminator terminator_tgt)
                         inv in
       let inv' := apply_infrules m_src m_tgt infrules inv in
       let inv' := debug_print_auto infrules inv' in
       (if (valid_terminator hint_fdef inv' m_src m_tgt blocks_src blocks_tgt bid terminator_src terminator_tgt)
        then true
        else failwith_false "valid_stmts: valid_terminator failed at block" [bid]))
  end.

Definition valid_entry_stmts (src tgt:stmts) (hint:ValidationHint.stmts)
                             (la_src la_tgt:args) (products_src products_tgt:products): bool :=
  let '(stmts_intro phinodes_src _ _) := src in
  let '(stmts_intro phinodes_tgt _ _) := tgt in
  if negb (is_empty phinodes_src)
  then failwith_false "valid_entry_stmts: phinode of source not empty" nil
  else
  if negb (is_empty phinodes_tgt)
  then failwith_false "valid_entry_stmts: phinode of target not empty" nil
  else
  if negb (Assertion.implies (Assertion.function_entry_inv la_src la_tgt products_src products_tgt) hint.(ValidationHint.assertion_after_phinodes))
  then failwith_false "valid_entry_stmts: implies fail at function entry" nil
  else true
  .

Definition valid_fdef
           (m_src m_tgt:module)
           (src tgt:fdef)
           (hint:ValidationHint.fdef): bool :=
  let '(fdef_intro fheader_src blocks_src) := src in
  let '(fdef_intro fheader_tgt blocks_tgt) := tgt in
  let '(module_intro layouts_src namedts_src products_src) := m_src in
  let '(module_intro layouts_tgt namedts_tgt products_tgt) := m_tgt in

  let fid_src := getFheaderID fheader_src in
  let fid_tgt :=getFheaderID fheader_tgt in

  if negb (fheader_dec fheader_src fheader_tgt)
  then failwith_false "valid_fdef: function headers not matched at fheaders" (fid_src::fid_tgt::nil)
  else
  match blocks_src, blocks_tgt with
  | (bid_src, block_src)::_, (bid_tgt, block_tgt)::_ =>
    if negb (id_dec bid_src bid_tgt)
    then failwith_false "valid_fdef: entry block ids not matched at bids of" (fid_src::bid_src::bid_tgt::nil)
    else
    match lookupAL _ hint bid_src with
    | Some hint_stmts =>
      if negb (valid_entry_stmts block_src block_tgt hint_stmts (getArgsOfFdef src) (getArgsOfFdef tgt) products_src products_tgt)
      then failwith_false "valid_fdef: valid_entry_stmts failed at" (fid_src::bid_src::nil)
      else true

    | None => failwith_false "valid_fdef: entry block hint not exist at block" (fid_src::bid_src::nil)
    end

  | _, _ => failwith_false "valid_fdef: empty source or target block" (fid_src::nil)
  end &&
  forallb2AL
    (fun bid stmts_src stmts_tgt =>
       match lookupAL _ hint bid with
       | Some hint_stmts =>
         if negb (valid_stmts hint hint_stmts m_src m_tgt blocks_src blocks_tgt bid stmts_src stmts_tgt)
         then failwith_false "valid_fdef: valid_stmts failed at block" (fid_src::bid::nil)
         else true

       | None => failwith_false "valid_fdef: block hint not exist at block" (fid_src::bid::nil)
       end)
    blocks_src blocks_tgt.

Definition valid_product (hint:ValidationHint.products) (m_src m_tgt:module) (src tgt:product): bool :=
  match src, tgt with
  | product_gvar gvar_src, product_gvar gvar_tgt =>
    if negb (Decs.gvar_eqb gvar_src gvar_tgt)
    then failwith_false "valid_product: global variables not matched" ((getGvarID gvar_src)::(getGvarID gvar_tgt)::nil)
    else true
  | product_fdec fdec_src, product_fdec fdec_tgt =>
    if negb (fdec_dec fdec_src fdec_tgt)
    then failwith_false "valid_product: function declarations not matched" ((getFdecID fdec_src)::(getFdecID fdec_tgt)::nil)
    else true
  | product_fdef fdef_src, product_fdef fdef_tgt =>
    let fid_src := getFdefID fdef_src in
    let fid_tgt := getFdefID fdef_tgt in
    if negb (id_dec fid_src fid_tgt)
    then failwith_false "valid_product: function ids not matched" (fid_src::fid_tgt::nil)
    else
    match lookupAL _ hint fid_src with
    | None => failwith_false "valid_product: hint of function not exist" [fid_src]
    | Some hint_fdef =>
      if negb (valid_fdef m_src m_tgt fdef_src fdef_tgt hint_fdef)
      then failwith_false "valid_product: valid_fdef failed" [fid_src]
      else true
    end
  | _, _ =>
    failwith_false "valid_product: source and target product types not matched" nil
  end.

Definition valid_products (hint:ValidationHint.products) (m_src m_tgt:module) (src tgt:products): bool :=
  list_forallb2 (valid_product hint m_src m_tgt) src tgt.

Definition valid_module (hint:ValidationHint.module) (src tgt:module): option bool :=
  let '(module_intro layouts_src namedts_src products_src) := src in
  let '(module_intro layouts_tgt namedts_tgt products_tgt) := tgt in
  if negb (layouts_dec layouts_src layouts_tgt)
  then Some false
  else
  if negb (namedts_dec namedts_src namedts_tgt)
  then Some false
  else
  if negb (valid_products hint src tgt products_src products_tgt)
  then failwith_None "valid_module: valid_products failed" nil
  else Some true.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*                Xavier Leroy, INRIA Paris                            *)
(*                Jacques-Henri Jourdan, INRIA Paris                   *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Architecture-dependent parameters for x86 in 64-bit mode *)

Require Import ZArith List.
(*From Flocq
Require Import Binary Bits. *)

Definition ptr64 := true.

Definition big_endian := false.

Definition align_int64 := 8%Z.
Definition align_float64 := 8%Z.

Definition splitlong := negb ptr64.

Lemma splitlong_ptr32: splitlong = true -> ptr64 = false.
Proof.
  unfold splitlong. destruct ptr64; simpl; congruence.
Qed.

Definition default_nan_64 := (true, iter_nat 51 _ xO xH).
Definition default_nan_32 := (true, iter_nat 22 _ xO xH).

(* Always choose the first NaN argument, if any *)

Definition choose_nan_64 (l: list (bool * positive)) : bool * positive :=
  match l with nil => default_nan_64 | n :: _ => n end.

Definition choose_nan_32 (l: list (bool * positive)) : bool * positive :=
  match l with nil => default_nan_32 | n :: _ => n end.

Lemma choose_nan_64_idem: forall n,
  choose_nan_64 (n :: n :: nil) = choose_nan_64 (n :: nil).
Proof. auto. Qed.

Lemma choose_nan_32_idem: forall n,
  choose_nan_32 (n :: n :: nil) = choose_nan_32 (n :: nil).
Proof. auto. Qed.

Definition fma_order {A: Type} (x y z: A) := (x, y, z).

Definition fma_invalid_mul_is_nan := false.

Definition float_of_single_preserves_sNaN := false.

Global Opaque ptr64 big_endian splitlong
              default_nan_64 choose_nan_64
              default_nan_32 choose_nan_32
              fma_order fma_invalid_mul_is_nan
              float_of_single_preserves_sNaN.


(** printing |-#    %\vdash_{\#}%    #⊢##     *)
(** printing |-##   %\vdash_{\#\#}%  #⊢&#35&#35#  *)
(** printing |-##v  %\vdash_{\#\#v}% #⊢&#35&#35v# *)
(** printing |-!    %\vdash_!%       #⊢!#         *)
(** remove printing ~ *)

(** * Converting General Typing To Tight Typing *)

Set Implicit Arguments.

Require Import Sequences.
Require Import Coq.Program.Equality.
Require Import Definitions RecordAndInertTypes PreciseTyping TightTyping InvertibleTyping
        Narrowing Replacement ReplacementTyping GADTRules.

(** ** Sel-<: Replacement *)

(** This lemma strengthens the tight [Sel-<:-#] and [<:-Sel-#] subtyping rules
    ([subtyp_sel1_t] and [subtyp_sel2_t]) by replacing the ⊢!!!
    premise with a ⊢# premise: #
#
    if [G ⊢# p: {A: S..U}] then [G ⊢# S <: p.A <: U] *)
Lemma sel_replacement: forall G p A S U,
    inert G ->
    G ⊢# trm_path p : typ_rcd {A >: S <: U} ->
    G ⊢# p↓A <: U /\ G ⊢# S <: p↓A.
Proof.
  introv Hi Hty.
  pose proof (replacement_closure Hi Hty) as Hinv.
  pose proof (repl_to_precise_rcd Hi Hinv) as [T [Ht [Hs1 Hs2]]].
  split.
  - apply subtyp_sel1_t in Ht. apply subtyp_trans_t with (T:=T); auto.
  - apply subtyp_sel2_t in Ht. apply subtyp_trans_t with (T:=T); auto.
Qed.

(** If [Γ ⊢# p] then [Γ ⊢!! p] *)
Lemma tight_to_prec_exists G p T :
  inert G ->
  G ⊢# trm_path p : T ->
  exists U, G ⊢!! p : U.
Proof.
  intros Hi Hp. pose proof (replacement_closure Hi Hp).
  apply repl_to_inv in H as [? ?]. apply inv_to_prec in H as [? ?]. apply* pt2_exists.
Qed.

(** ** Sngl-<: Replacement *)

(** This lemma strengthens the tight [Sngl-<:-#] and [<:-Sngl-#] subtyping rules
    ([subtyp_sngl_pq_t] and [subtyp_sngl_qp_t]) by replacing the ⊢!!! premise
    with a ⊢# premise: #
#
    if [G ⊢# p: q.type] and [q] is well-typed then [G ⊢# T <: T[q/p] <: T] *)
Lemma sngl_replacement: forall G p q T U S,
    inert G ->
    G ⊢# trm_path p: {{ q }} ->
    G ⊢# trm_path q : S ->
    repl_typ p q T U ->
    G ⊢# T <: U /\ G ⊢# U <: T.
Proof.
  introv Hi Hp Hr.
  apply (tight_to_prec_exists Hi) in Hr as [V Hq].
  lets Hc: (replacement_closure Hi Hp).
  pose proof (repl_to_invertible_sngl Hi Hc Hq) as [r [W [Hpt [Hq' [-> | Hpq]]]]];
    pose proof (inv_to_precise_sngl Hi Hpt (pt3 Hq')) as [r' [Ht [-> | Hrc']]].
  - split. eauto. apply repl_swap in H. eauto.
  - split.
    + destruct (repl_insert r H) as [X [Hr1 Hr2]].
      eapply subtyp_sngl_pq_t. eapply pt3_sngl_trans3. apply Ht. eauto. eauto. eauto.
    + destruct (repl_insert r' H) as [X [Hr1 Hr2]].
      apply subtyp_trans_t with (T:=X).
      * apply repl_swap in Hr2. eauto.
      * apply repl_swap in Hr1. eauto.
  - split.
    + destruct (repl_insert r H) as [X [Hr1 Hr2]].
      apply subtyp_trans_t with (T:=X); eauto.
    + destruct (repl_insert r H) as [X [Hr1 Hr2]].
      apply subtyp_trans_t with (T:=X).
      apply repl_swap in Hr2. eauto. apply repl_swap in Hr1. eauto.
  - split.
    + destruct (repl_insert r' H) as [X [Hr1 Hr2]].
      apply subtyp_trans_t with (T:=X).
      * eauto.
      * destruct (repl_insert r Hr2) as [S' [Hr1' Hr2']].
        apply subtyp_trans_t with (T:=S'); eauto.
    + destruct (repl_insert r H) as [X [Hr1 Hr2]].
      apply subtyp_trans_t with (T:=X).
      * apply repl_swap in Hr2. eauto.
      * destruct (repl_insert r' Hr1) as [S' [Hr1' Hr2']].
        apply subtyp_trans_t with (T:=S').
        ** apply repl_swap in Hr2'. eauto.
        ** apply repl_swap in Hr1'. eauto.
Qed.

(** ** General to Tight [⊢ to ⊢#] *)
(** In an inert environment, general typing ([ty_trm] [⊢]) can
    be reduced to tight typing ([ty_trm_t] [⊢#]).

    [inert G]           #
#
    [G ⊢ t: T]          #
#
    [――――――――――――――]    #
#
    [G ⊢# t: T] #
# #
#

    and                 #
# #
#
    [inert G]           #
#
    [G ⊢ S <: U]        #
#
    [――――――――――――――――]  #
#
    [G ⊢# S <: U]         *)
Lemma general_to_tight: forall G0,
  inert G0 ->
  (forall G t T,
     G ⊢ t : T ->
     G = G0 ->
     G ⊢# t : T) /\
  (forall G S U,
     G ⊢ S <: U ->
     G = G0 ->
     G ⊢# S <: U).
Proof.
  intros G0 Hi.
  apply ts_mutind; intros; subst;
    try solve [eapply sel_replacement; auto]; eauto.
  - specialize (H eq_refl).
    pose proof (invert_subtyp_rcd_t _ _ _ _ _ _ _ _ Hi e e0 H) as [Hg1 Hg2]. auto.
  - specialize (H eq_refl).
    pose proof (invert_subtyp_rcd_t _ _ _ _ _ _ _ _ Hi e e0 H) as [Hg1 Hg2]. auto.
  - specialize (H eq_refl). apply* invert_subtyp_all_t.
  - destruct* (sngl_replacement Hi (H eq_refl) (H0 eq_refl) r).
  - apply repl_swap in r. destruct* (sngl_replacement Hi (H eq_refl) (H0 eq_refl) r).
Qed.

(** The general-to-tight lemma, formulated for term typing. *)
Lemma general_to_tight_typing: forall G t T,
  inert G ->
  G ⊢ t : T ->
  G ⊢# t : T.
Proof.
  intros. apply* general_to_tight.
Qed.

(** If [Γ ⊢ p] then [Γ ⊢!!! p] *)
Lemma pt3_exists G p T :
  inert G ->
  G ⊢ trm_path p : T ->
  exists U, G ⊢!!! p : U.
Proof.
  intros Hi Hp. apply (general_to_tight_typing Hi) in Hp.
  apply tight_to_prec_exists in Hp as [? ?]; eauto.
Qed.

(** ** Proof Recipe *)
(** This tactic converts general typing of paths or values to as much precise typing
    as possible. *)
Ltac proof_recipe :=
  match goal with
  | [ Hg: ?G ⊢ _ : _,
      Hi: inert ?G |- _ ] =>
    apply (general_to_tight_typing Hi) in Hg;
    ((apply (replacement_closure Hi) in Hg) || (apply (replacement_closure_v Hi) in Hg));
    try lets Hok: (inert_ok Hi);
    try match goal with
        | [ Hr: ?G ⊢// _ : ∀(_) _,
            Hok: ok ?G |- _ ] =>
          destruct (repl_to_precise_typ_all Hi Hr) as [Spr [Tpr [Lpr [Hpr [Hspr1 Hspr2]]]]]
        | [ Hrv: ?G ⊢//v _ : μ _ |- _ ] =>
          apply (repl_to_invertible_obj Hi) in Hrv as [U' [Hrv Hrc]];
          apply (invertible_to_precise_obj Hi) in Hrv as [U'' [Hrv Hrc']];
          try match goal with
              | [ Hv: _ ⊢!v val_new ?T _ : μ ?U |- _ ] =>
                assert (T = U) as <- by (inversion Hv; subst*)
              end
        | [ Hrv: ?G ⊢//v _ : ∀(_) _ |- _ ] =>
           apply repl_val_to_precise_lambda in Hrv
              as [L1 [S1 [T1 [Hvpr [HS1 HS2]]]]]; auto
       end
  end.

(** If a path has a function type then its III-level precise type is
    also a function type that is a subtype of the former. *)
Lemma path_typ_all_to_precise: forall G p T U,
    inert G ->
    G ⊢ trm_path p : ∀(T) U ->
    (exists L T' U',
        G ⊢!!! p : ∀(T') U' /\
        G ⊢ T <: T' /\
        (forall y, y \notin L -> G & y ~ T ⊢ (open_typ y U') <: (open_typ y U))).
Proof.
  introv Hin Ht. proof_recipe. repeat eexists. eauto. apply* tight_to_general. eauto.
Qed.

(** If a value has a function type then the value is a function. *)
Lemma val_typ_all_to_lambda: forall G v T U,
    inert G ->
    G ⊢ trm_val v : ∀(T) U ->
    (exists L T' t,
        v = λ(T') t /\
        G ⊢ T <: T' /\
        (forall y, y \notin L -> G & y ~ T ⊢ (open_trm y t) : open_typ y U)).
Proof.
  introv Hin Ht. proof_recipe. inversions Hvpr.
  exists (L1 \u L \u (dom G)) S1 t. repeat split~.
  intros. assert (HL: y \notin L) by auto. assert (HL0: y \notin L1) by auto.
  specialize (HS2 y HL0).
  specialize (H2 y HL).
  eapply ty_sub; eauto. eapply narrow_typing in H2; eauto.
Qed.

Lemma invert_subtyp_all : forall G S1 T1 S2 T2,
    inert G ->
    G ⊢ ∀(S1) T1 <: ∀(S2) T2 ->
    G ⊢ S2 <: S1 /\ (exists L, forall x, x \notin L ->
       G & x ~ S2 ⊢ open_typ x T1 <: open_typ x T2).
Proof.
  introv H0 H.
  lets Hgt: (general_to_tight H0). destruct Hgt as [_ Hgt].
  apply Hgt in H; eauto 2.
  lets Ht: (invert_subtyp_all_t _ _ _ _ _ H0 H).
  destruct Ht as [Ht1 Ht2]. split; eauto 2.
  apply* tight_to_general.
Qed.