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 WFLibLarge.
From Fairness Require Import ModSim.

Set Implicit Arguments.

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

  Variable state_src: Type.
  Variable state_tgt: Type.

  Variable ident_src: ID.
  Variable _ident_tgt: ID.
  Let ident_tgt := @ident_tgt _ident_tgt.

  Variable wf_src: WF.
  Variable wf_tgt: WF.

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

  Let shared := shared state_src state_tgt ident_src _ident_tgt wf_src wf_tgt.

  Let shared_rel: Type := shared -> Prop.

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

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

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

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

  | lsim_observe
      f_src f_tgt r_ctx
      ths im_src im_tgt st_src st_tgt
      fn args ktr_src ktr_tgt
      (LSIM: forall ret,
          _lsim _ _ RR true true r_ctx (ktr_src ret) (ktr_tgt ret) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    __lsim tid lsim _lsim RR f_src f_tgt r_ctx (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
      ths im_src im_tgt st_src st_tgt
      fn args ktr_src itr_tgt
    : __lsim tid lsim _lsim RR f_src f_tgt r_ctx (trigger (Call fn args) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)

  | lsim_yieldL
      f_src f_tgt r_ctx
      ths im_src im_tgt st_src st_tgt
      ktr_src itr_tgt
      (LSIM: _lsim _ _ RR true f_tgt r_ctx (ktr_src tt) (trigger (Yield) >>= itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    __lsim tid lsim _lsim RR f_src f_tgt r_ctx (trigger (Yield) >>= ktr_src) (trigger (Yield) >>= itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | lsim_yieldR
      f_src f_tgt r_ctx0
      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))
      (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 _ _ RR f_src true r_ctx1 (trigger (Yield) >>= ktr_src) (ktr_tgt tt) (ths1, im_src1, im_tgt2, st_src1, st_tgt1))
    :
    __lsim tid lsim _lsim RR f_src f_tgt r_ctx0 (trigger (Yield) >>= ktr_src) (trigger (Yield) >>= ktr_tgt) (ths0, im_src0, im_tgt0, st_src0, st_tgt0)
  | lsim_sync
      f_src f_tgt r_ctx0
      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))
      (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 _ _ RR true true r_ctx1 (ktr_src tt) (ktr_tgt tt) (ths1, im_src1, im_tgt2, st_src1, st_tgt1)>>))
    :
    __lsim tid lsim _lsim RR f_src f_tgt r_ctx0 (trigger (Yield) >>= ktr_src) (trigger (Yield) >>= ktr_tgt) (ths0, im_src0, im_tgt0, st_src0, st_tgt0)

  | lsim_progress
      r_ctx
      ths im_src im_tgt st_src st_tgt
      itr_src itr_tgt
      (LSIM: lsim _ _ RR false false r_ctx itr_src itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
    :
    __lsim tid lsim _lsim RR true true r_ctx 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 -> itree srcE R_src -> itree tgtE R_tgt -> shared_rel :=
    paco9 (fun r => pind9 (__lsim tid r) top9) bot9 R_src R_tgt RR.

  Lemma __lsim_mon tid:
    forall r r' (LE: r <9= r'), (__lsim tid r) <10= (__lsim tid r').
  Proof.
    ii. inv PR; try (econs; eauto; fail).
  Qed.

  Lemma _lsim_mon tid: forall r, monotone9 (__lsim tid r).
  Proof.
    ii. inv IN; try (econs; eauto; fail).
    { des. econs; eauto. }
    { des. econs; eauto. }
    { econs. i. eapply LE. eapply LSIM. eauto. }
    { eapply lsim_sync; eauto. i. eapply LE. eapply LSIM; eauto. }
  Qed.

  Lemma lsim_mon tid: forall q, monotone9 (fun r => pind9 (__lsim tid r) q).
  Proof.
    ii. eapply pind9_mon_gen; eauto.
    ii. eapply __lsim_mon; eauto.
  Qed.

  Local Hint Constructors __lsim: core.
  Local Hint Unfold lsim: core.
  Local Hint Resolve __lsim_mon: paco.
  Local Hint Resolve _lsim_mon: paco.
  Local Hint Resolve lsim_mon: paco.

  Lemma modsim_implies_gensim
        tid
        R0 R1 (RR: R0 -> R1 -> URA.car -> shared_rel)
        ps pt r_ctx src tgt
        (shr: shared)
        (LSIM: ModSim.lsim I tid RR ps pt r_ctx src tgt shr)
    :
    lsim tid RR ps pt r_ctx src tgt shr.
  Proof.
    revert_until tid. pcofix CIH; i.
    punfold LSIM.
    pattern R0, R1, RR, ps, pt, r_ctx, src, tgt, shr.
    revert R0 R1 RR ps pt r_ctx src tgt shr LSIM. apply pind9_acc.
    intros rr DEC IH. clear DEC. intros R0 R1 RR ps pt r_ctx src tgt shr LSIM.
    eapply pind9_unfold in LSIM.
    2:{ eapply ModSim._lsim_mon. }
    inv LSIM.

    { pfold. eapply pind9_fold. eapply lsim_ret; eauto. }
    { pfold. eapply pind9_fold. eapply lsim_tauL; eauto.
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND. punfold IND.
    }
    { pfold. eapply pind9_fold. eapply lsim_chooseL; eauto.
      des. exists x.
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND. punfold IND.
    }
    { pfold. eapply pind9_fold. eapply lsim_rmwL; eauto.
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND. punfold IND.
    }
    { pfold. eapply pind9_fold. eapply lsim_tidL; eauto.
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND. punfold IND.
    }
    { pfold. eapply pind9_fold. eapply lsim_UB; eauto. }
    { pfold. eapply pind9_fold. eapply lsim_fairL; eauto.
      des. esplits; eauto.
      split; ss. destruct LSIM as [LSIM IND]. eapply IH in IND. punfold IND.
    }
    { pfold. eapply pind9_fold. eapply lsim_tauR; eauto.
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND. punfold IND.
    }
    { pfold. eapply pind9_fold. eapply lsim_chooseR; eauto.
      i. specialize (LSIM0 x).
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND. punfold IND.
    }
    { pfold. eapply pind9_fold. eapply lsim_rmwR; eauto.
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND. punfold IND.
    }
    { pfold. eapply pind9_fold. eapply lsim_tidR; eauto.
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND. punfold IND.
    }
    { pfold. eapply pind9_fold. eapply lsim_fairR; eauto.
      i. specialize (LSIM0 _ FAIR).
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND. punfold IND.
    }

    { pfold. eapply pind9_fold. eapply lsim_observe; eauto.
      i. specialize (LSIM0 ret). pclearbot.
      split; ss. eapply pind9_fold. eapply lsim_progress.
      right. eapply CIH; eauto. eapply ModSim.lsim_set_prog. auto.
    }

    { pfold. eapply pind9_fold. eapply lsim_call. }

    { pfold. eapply pind9_fold. eapply lsim_yieldL.
      des. esplits; eauto.
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND. punfold IND.
    }

    { pfold. eapply pind9_fold. eapply lsim_yieldR; eauto.
      i. specialize (LSIM0 _ _ _ _ _ _ _ INV0 VALID0 _ TGT).
      split; ss. destruct LSIM0 as [LSIM IND]. eapply IH in IND. punfold IND.
    }

    { pfold. eapply pind9_fold. eapply lsim_sync; eauto.
      i. specialize (LSIM0 _ _ _ _ _ _ _ INV0 VALID0 _ TGT).
      split; ss. eapply pind9_fold. eapply lsim_progress. pclearbot.
      right. eapply CIH. apply ModSim.lsim_set_prog; auto.
    }

    { pfold. eapply pind9_fold. eapply lsim_progress. right.
      eapply CIH. pclearbot. auto.
    }

  Qed.

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.

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

  Variable state_src: Type.
  Variable state_tgt: Type.

  Variable ident_src: ID.
  Variable _ident_tgt: ID.
  Let ident_tgt := @ident_tgt _ident_tgt.

  Variable wf_src: WF.
  Variable wf_tgt: WF.

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

  Let shared := shared state_src state_tgt ident_src _ident_tgt wf_src wf_tgt.
  Let shared_rel: Type := shared -> Prop.
  Variable I: shared -> URA.car -> Prop.

  Let A R0 R1 := (bool * bool * URA.car * (itree srcE R0) * (itree tgtE R1) * shared)%type.
  Let wf_stt R0 R1 := @ord_tree_WF (A R0 R1).

  Variant _genos
          (tid: thread_id)
          (genos: forall R0 R1 (RR: R0 -> R1 -> URA.car -> shared_rel), bool -> bool -> URA.car -> ((wf_stt R0 R1).(T) * itree srcE R0) -> ((wf_stt R0 R1).(T) * itree tgtE R1) -> shared_rel)
          R0 R1 (RR: R0 -> R1 -> URA.car -> shared_rel)
    :
    bool -> bool -> URA.car -> ((wf_stt R0 R1).(T) * itree srcE R0) -> ((wf_stt R0 R1).(T) * itree tgtE R1) -> shared_rel :=
  | genos_ret
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      r_src r_tgt
      (GENOS: RR r_src r_tgt r_ctx (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, Ret r_src) (ot, Ret r_tgt) (ths, im_src, im_tgt, st_src, st_tgt)

  | genos_tauL
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      itr_src itr_tgt
      (GENOS: genos _ _ RR true f_tgt r_ctx (os, itr_src) (ot, itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, Tau itr_src) (ot, itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | genos_chooseL
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      X ktr_src itr_tgt
      (GENOS: exists x, genos _ _ RR true f_tgt r_ctx (os, ktr_src x) (ot, itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, trigger (Choose X) >>= ktr_src) (ot, itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | genos_rmwL
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      X rmw ktr_src itr_tgt
      (GENOS: genos _ _ RR true f_tgt r_ctx (os, ktr_src (snd (rmw st_src) : X)) (ot, itr_tgt) (ths, im_src, im_tgt, fst (rmw st_src), st_tgt))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, trigger (Rmw rmw) >>= ktr_src) (ot, itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | genos_tidL
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      ktr_src itr_tgt
      (GENOS: genos _ _ RR true f_tgt r_ctx (os, ktr_src tid) (ot, itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, trigger (GetTid) >>= ktr_src) (ot, itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | genos_UB
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      ktr_src itr_tgt
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, trigger (Undefined) >>= ktr_src) (ot, itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | genos_fairL
      f_src f_tgt r_ctx os ot
      ths im_src0 im_tgt st_src st_tgt
      f ktr_src itr_tgt
      (GENOS: exists im_src1,
          (<<FAIR: fair_update im_src0 im_src1 f>>) /\
            (<<GENOS: genos _ _ RR true f_tgt r_ctx (os, ktr_src tt) (ot, itr_tgt) (ths, im_src1, im_tgt, st_src, st_tgt)>>))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, trigger (Fair f) >>= ktr_src) (ot, itr_tgt) (ths, im_src0, im_tgt, st_src, st_tgt)

  | genos_tauR
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      itr_src itr_tgt
      (GENOS: genos _ _ RR f_src true r_ctx (os, itr_src) (ot, itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, itr_src) (ot, Tau itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | genos_chooseR
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      X itr_src ktr_tgt
      (GENOS: forall x, genos _ _ RR f_src true r_ctx (os, itr_src) (ot, ktr_tgt x) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, itr_src) (ot, trigger (Choose X) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | genos_rmwR
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      X rmw itr_src ktr_tgt
      (GENOS: genos _ _ RR f_src true r_ctx (os, itr_src) (ot, ktr_tgt (snd (rmw st_tgt) : X)) (ths, im_src, im_tgt, st_src, fst (rmw st_tgt)))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, itr_src) (ot, trigger (Rmw rmw) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | genos_tidR
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      itr_src ktr_tgt
      (GENOS: genos _ _ RR f_src true r_ctx (os, itr_src) (ot, ktr_tgt tid) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, itr_src) (ot, trigger (GetTid) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | genos_fairR
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt0 st_src st_tgt
      f itr_src ktr_tgt
      (GENOS: forall im_tgt1 (FAIR: fair_update im_tgt0 im_tgt1 (prism_fmap inrp f)),
          (<<GENOS: genos _ _ RR f_src true r_ctx (os, itr_src) (ot, ktr_tgt tt) (ths, im_src, im_tgt1, st_src, st_tgt)>>))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, itr_src) (ot, trigger (Fair f) >>= ktr_tgt) (ths, im_src, im_tgt0, st_src, st_tgt)

  | genos_observe
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      fn args ktr_src ktr_tgt
      (GENOS: forall ret,
          genos _ _ RR true true r_ctx (os, ktr_src ret) (ot, ktr_tgt ret) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, trigger (Observe fn args) >>= ktr_src) (ot, trigger (Observe fn args) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)

  | genos_call
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      fn args ktr_src itr_tgt
    : _genos tid genos RR f_src f_tgt r_ctx (os, trigger (Call fn args) >>= ktr_src) (ot, itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)

  | genos_yieldL
      f_src f_tgt r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      ktr_src itr_tgt
      (GENOS: exists os1 ot1,
          (<<GENOS: genos _ _ RR true f_tgt r_ctx (os1, ktr_src tt) (ot1, trigger (Yield) >>= itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)>>) /\
            (<<LT: (wf_stt R0 R1).(lt) os1 os>>))
    :
    _genos tid genos RR f_src f_tgt r_ctx (os, trigger (Yield) >>= ktr_src) (ot, trigger (Yield) >>= itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | genos_yieldR
      f_src f_tgt r_ctx0 os ot
      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))
      (GENOS: 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))),
        exists os1 ot1,
          (<<GENOS: genos _ _ RR f_src true r_ctx1 (os1, trigger (Yield) >>= ktr_src) (ot1, ktr_tgt tt) (ths1, im_src1, im_tgt2, st_src1, st_tgt1)>>) /\
            (<<LT: (wf_stt R0 R1).(lt) ot1 ot>>))
    :
    _genos tid genos RR f_src f_tgt r_ctx0 (os, trigger (Yield) >>= ktr_src) (ot, trigger (Yield) >>= ktr_tgt) (ths0, im_src0, im_tgt0, st_src0, st_tgt0)
  | genos_sync
      f_src f_tgt r_ctx0 os ot
      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))
      (GENOS: 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))),
        exists os1 ot1,
          (<<GENOS: genos _ _ RR true true r_ctx1 (os1, ktr_src tt) (ot1, ktr_tgt tt) (ths1, im_src1, im_tgt2, st_src1, st_tgt1)>>))
    :
    _genos tid genos RR f_src f_tgt r_ctx0 (os, trigger (Yield) >>= ktr_src) (ot, trigger (Yield) >>= ktr_tgt) (ths0, im_src0, im_tgt0, st_src0, st_tgt0)

  | genos_progress
      r_ctx os ot
      ths im_src im_tgt st_src st_tgt
      itr_src itr_tgt
      (GENOS: lsim I tid RR false false r_ctx (itr_src) (itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _genos tid genos RR true true r_ctx (os, itr_src) (ot, itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  .

  Definition genos (tid: thread_id)
             R0 R1 (RR: R0 -> R1 -> URA.car -> shared_rel):
    bool -> bool -> URA.car -> ((wf_stt R0 R1).(T) * itree srcE R0) -> ((wf_stt R0 R1).(T) * itree tgtE R1) -> shared_rel :=
    pind9 (_genos tid) top9 R0 R1 RR.

  Lemma genos_mon tid: monotone9 (_genos tid).
  Proof.
    ii. inv IN; try (econs; eauto; fail).
    { des. econs; eauto. }
    { des. econs; eauto. }
    { econs. i. eapply LE. eapply GENOS. eauto. }
    { des. econs; eauto. esplits; eauto. }
    { eapply genos_yieldR; eauto. i. hexploit GENOS; eauto. i. des. esplits; eauto. }
    { eapply genos_sync; eauto. i. hexploit GENOS; eauto. i. des. esplits; eauto. }
  Qed.

  Local Hint Constructors _genos: core.
  Local Hint Unfold genos: core.
  Local Hint Resolve genos_mon: paco.

  Lemma genos_ord_weakL
        tid R0 R1 (LRR: R0 -> R1 -> URA.car -> shared_rel)
        ps pt r_ctx src tgt (shr: shared)
        os0 os1
        (LT: (wf_stt R0 R1).(lt) os0 os1)
        (GENOS: genos tid LRR ps pt r_ctx (os0, src) tgt shr)
    :
    genos tid LRR ps pt r_ctx (os1, src) tgt shr.
  Proof.
    remember (os0, src) as osrc.
    move GENOS before tid. revert_until GENOS.
    pattern R0, R1, LRR, ps, pt, r_ctx, osrc, tgt, shr.
    revert R0 R1 LRR ps pt r_ctx osrc tgt shr GENOS. apply pind9_acc.
    intros rr DEC IH. clear DEC. intros R0 R1 LRR ps pt r_ctx osrc tgt shr GENOS.
    i; clarify.
    eapply pind9_unfold in GENOS; eauto with paco.
    inv GENOS.

    { eapply pind9_fold. eapply genos_ret; eauto. }
    { eapply pind9_fold. eapply genos_tauL; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_chooseL; eauto.
      des. destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. esplits; eauto.
      split; ss; eauto.
    }
    { eapply pind9_fold. eapply genos_rmwL; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_tidL; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_UB; eauto. }
    { eapply pind9_fold. eapply genos_fairL; eauto.
      des. destruct GENOS as [GENOS IND]. eapply IH in IND; eauto. esplits; eauto.
      split; ss; eauto.
    }

    { eapply pind9_fold. eapply genos_tauR; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_chooseR; eauto.
      i. specialize (GENOS0 x).
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_rmwR; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_tidR; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_fairR; eauto.
      i. specialize (GENOS0 _ FAIR).
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_observe; eauto.
      i. specialize (GENOS0 ret).
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }

    { eapply pind9_fold. eapply genos_call; eauto. }

    { eapply pind9_fold. eapply genos_yieldL; eauto.
      des. destruct GENOS as [GENOS IND]. eapply IH in IND; eauto.
      esplits. split; ss. eapply IND. auto.
    }

    { eapply pind9_fold. eapply genos_yieldR; eauto.
      i. specialize (GENOS0 _ _ _ _ _ _ _ INV0 VALID0 _ TGT). des. esplits; eauto.
      eapply upind9_mon; eauto. ss.
    }

    { eapply pind9_fold. eapply genos_sync; eauto.
      i. specialize (GENOS0 _ _ _ _ _ _ _ INV0 VALID0 _ TGT). des. esplits; eauto.
      eapply upind9_mon; eauto. ss.
    }

    { eapply pind9_fold. eapply genos_progress; eauto. }

  Qed.

  Lemma genos_ord_weakR
        tid R0 R1 (LRR: R0 -> R1 -> URA.car -> shared_rel)
        ps pt r_ctx src tgt (shr: shared)
        ot0 ot1
        (LT: (wf_stt R0 R1).(lt) ot0 ot1)
        (GENOS: genos tid LRR ps pt r_ctx src (ot0, tgt) shr)
    :
    genos tid LRR ps pt r_ctx src (ot1, tgt) shr.
  Proof.
    remember (ot0, tgt) as otgt.
    move GENOS before tid. revert_until GENOS.
    pattern R0, R1, LRR, ps, pt, r_ctx, src, otgt, shr.
    revert R0 R1 LRR ps pt r_ctx src otgt shr GENOS. apply pind9_acc.
    intros rr DEC IH. clear DEC. intros R0 R1 LRR ps pt r_ctx src otgt shr GENOS.
    i; clarify.
    eapply pind9_unfold in GENOS; eauto with paco.
    inv GENOS.

    { eapply pind9_fold. eapply genos_ret; eauto. }
    { eapply pind9_fold. eapply genos_tauL; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_chooseL; eauto.
      des. destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. esplits; eauto.
      split; ss; eauto.
    }
    { eapply pind9_fold. eapply genos_rmwL; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_tidL; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_UB; eauto. }
    { eapply pind9_fold. eapply genos_fairL; eauto.
      des. destruct GENOS as [GENOS IND]. eapply IH in IND; eauto. esplits; eauto.
      split; ss; eauto.
    }

    { eapply pind9_fold. eapply genos_tauR; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_chooseR; eauto.
      i. specialize (GENOS0 x).
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_rmwR; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_tidR; eauto.
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_fairR; eauto.
      i. specialize (GENOS0 _ FAIR).
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind9_fold. eapply genos_observe; eauto.
      i. specialize (GENOS0 ret).
      destruct GENOS0 as [GENOS IND]. eapply IH in IND; eauto. split; ss.
    }

    { eapply pind9_fold. eapply genos_call; eauto. }

    { eapply pind9_fold. eapply genos_yieldL; eauto.
      des. esplits; eauto.
      eapply upind9_mon; eauto. ss.
    }

    { eapply pind9_fold. eapply genos_yieldR; eauto.
      i. specialize (GENOS0 _ _ _ _ _ _ _ INV0 VALID0 _ TGT). des.
      destruct GENOS as [GENOS IND]. eapply IH in IND; eauto.
      esplits; eauto. split; ss. eauto.
    }

    { eapply pind9_fold. eapply genos_sync; eauto.
      i. specialize (GENOS0 _ _ _ _ _ _ _ INV0 VALID0 _ TGT). des. esplits; eauto.
      eapply upind9_mon; eauto. ss.
    }

    { eapply pind9_fold. eapply genos_progress; eauto. }

  Qed.

  Lemma gensim_genos
        tid R0 R1 (RR: R0 -> R1 -> URA.car -> shared_rel)
        ps pt r_ctx src tgt shr
        (LSIM: lsim I tid RR ps pt r_ctx src tgt shr)
    :
    exists os ot, genos tid RR ps pt r_ctx (os, src) (ot, tgt) shr.
  Proof.
    punfold LSIM.
    pattern R0, R1, RR, ps, pt, r_ctx, src, tgt, shr.
    revert R0 R1 RR ps pt r_ctx src tgt shr LSIM. apply pind9_acc.
    intros rr DEC IH. clear DEC. intros R0 R1 RR ps pt r_ctx src tgt shr LSIM.
    eapply pind9_unfold in LSIM; eauto with paco.
    set (zero:= @ord_tree_base (A R0 R1)). set (fzero:= fun _: (A R0 R1) => zero). set (one:= ord_tree_cons fzero).
    inv LSIM.

    { exists zero, zero. eapply pind9_fold. eapply genos_ret; eauto. }

    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des.
      exists os, ot. eapply pind9_fold. eapply genos_tauL; eauto. split; ss.
    }
    { des. destruct LSIM0 as [LSIM IND]. eapply IH in IND. des.
      exists os, ot. eapply pind9_fold. eapply genos_chooseL; eauto. eexists. split; ss. eauto.
    }
    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des.
      exists os, ot. eapply pind9_fold. eapply genos_rmwL; eauto. split; ss.
    }
    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des.
      exists os, ot. eapply pind9_fold. eapply genos_tidL; auto. split; ss.
    }
    { exists zero, zero. eapply pind9_fold. eapply genos_UB; eauto. }
    { des. destruct LSIM as [LSIM IND]. eapply IH in IND. des.
      exists os, ot. eapply pind9_fold. eapply genos_fairL; eauto. esplits; eauto. split; ss.
    }

    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des. exists os, ot.
      eapply pind9_fold. eapply genos_tauR; eauto. ss.
    }

    { hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs. eapply IH in SAT.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           exists ot, genos tid RR ps pt rs (o, src) (ot, tgt) shr).
        eauto.
      }
      intro JOIN1. des. exists o1.
      hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs.
        specialize (JOIN1 (b, b0, c, i0, i, s)). destruct JOIN1; auto. des.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           genos tid RR ps pt rs (o1, src) (o, tgt) shr).
        exists ot. eapply genos_ord_weakL; eauto.
      }
      intro JOIN2. des. exists o0.
      eapply pind9_fold. eapply genos_chooseR.
      i. specialize (LSIM0 x). destruct LSIM0 as [LSIM IND].
      specialize (JOIN1 (ps, true, r_ctx, src, (ktr_tgt x), (ths, im_src, im_tgt, st_src, st_tgt))).
      destruct JOIN1; auto. des.
      specialize (JOIN2 (ps, true, r_ctx, src, (ktr_tgt x), (ths, im_src, im_tgt, st_src, st_tgt))).
      destruct JOIN2; auto. des.
      split; ss.
      eapply genos_ord_weakR; eauto.
    }

    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des. exists os, ot.
      eapply pind9_fold. eapply genos_rmwR; eauto. ss.
    }
    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des. exists os, ot.
      eapply pind9_fold. eapply genos_tidR; eauto. ss.
    }

    { hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs. eapply IH in SAT.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           exists ot, genos tid RR ps pt rs (o, src) (ot, tgt) shr).
        eauto.
      }
      intro JOIN1. des. exists o1.
      hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs.
        specialize (JOIN1 (b, b0, c, i0, i, s)). destruct JOIN1; auto. des.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           genos tid RR ps pt rs (o1, src) (o, tgt) shr).
        exists ot. eapply genos_ord_weakL; eauto.
      }
      intro JOIN2. des. exists o0.
      eapply pind9_fold. eapply genos_fairR.
      i. specialize (LSIM0 _ FAIR). destruct LSIM0 as [LSIM IND].
      specialize (JOIN1 (ps, true, r_ctx, src, (ktr_tgt tt), (ths, im_src, im_tgt1, st_src, st_tgt))).
      destruct JOIN1; auto. des.
      specialize (JOIN2 (ps, true, r_ctx, src, (ktr_tgt tt), (ths, im_src, im_tgt1, st_src, st_tgt))).
      destruct JOIN2; auto. des.
      split; ss.
      eapply genos_ord_weakR; eauto.
    }

    { hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs. eapply IH in SAT.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           exists ot, genos tid RR ps pt rs (o, src) (ot, tgt) shr).
        eauto.
      }
      intro JOIN1. des. exists o1.
      hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs.
        specialize (JOIN1 (b, b0, c, i0, i, s)). destruct JOIN1; auto. des.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           genos tid RR ps pt rs (o1, src) (o, tgt) shr).
        exists ot. eapply genos_ord_weakL; eauto.
      }
      intro JOIN2. des. exists o0.
      eapply pind9_fold. eapply genos_observe.
      i. specialize (LSIM0 ret). destruct LSIM0 as [LSIM IND].
      specialize (JOIN1 (true, true, r_ctx, (ktr_src ret), (ktr_tgt ret), (ths, im_src, im_tgt, st_src, st_tgt))).
      destruct JOIN1; auto. des.
      specialize (JOIN2 (true, true, r_ctx, (ktr_src ret), (ktr_tgt ret), (ths, im_src, im_tgt, st_src, st_tgt))).
      destruct JOIN2; auto. des.
      split; ss.
      eapply genos_ord_weakR; eauto.
    }

    { hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs. eapply IH in SAT.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           exists ot, genos tid RR ps pt rs (o, src) (ot, tgt) shr).
        eauto.
      }
      intro JOIN1. des. exists o1.
      hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs.
        specialize (JOIN1 (b, b0, c, i0, i, s)). destruct JOIN1; auto. des.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           genos tid RR ps pt rs (o1, src) (o, tgt) shr).
        exists ot. eapply genos_ord_weakL; eauto.
      }
      intro JOIN2. des. exists o0.
      eapply pind9_fold. eapply genos_call.
    }

    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des.
      set (fos:= fun _: (A R0 R1) => os). exists (ord_tree_cons fos), ot.
      eapply pind9_fold. eapply genos_yieldL; eauto. esplits; eauto.
      split; ss. eauto. ss.
      replace os with (fos (true, pt, r_ctx, (ktr_src tt), (x <- trigger Yield;; itr_tgt x), (ths, im_src, im_tgt, st_src, st_tgt))); ss.
    }

    { hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs. eapply IH in SAT.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           exists ot, genos tid RR ps pt rs (o, src) (ot, tgt) shr).
        eauto.
      }
      intro JOIN1. des. exists o1.
      hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs.
        specialize (JOIN1 (b, b0, c, i0, i, s)). destruct JOIN1; auto. des.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           genos tid RR ps pt rs (o1, src) (o, tgt) shr).
        exists ot. eapply genos_ord_weakL; eauto.
      }
      intro JOIN2. des. exists o0.
      eapply pind9_fold. eapply genos_yieldR. 1,2: eauto.
      i. specialize (LSIM0 _ _ _ _ _ _ _ INV0 VALID0 _ TGT). destruct LSIM0 as [LSIM IND].
      specialize (JOIN1 (ps, true, r_ctx1, (x <- trigger Yield;; ktr_src x), ktr_tgt tt, (ths1, im_src1, im_tgt2, st_src1, st_tgt1))).
      destruct JOIN1; auto. des.
      specialize (JOIN2 (ps, true, r_ctx1, (x <- trigger Yield;; ktr_src x), ktr_tgt tt, (ths1, im_src1, im_tgt2, st_src1, st_tgt1))).
      destruct JOIN2; auto. des.
      exists o1, x0. esplits; eauto.
      split; ss.
    }

    { exists zero, zero. eapply pind9_fold. eapply genos_sync; eauto.
      i. specialize (LSIM0 _ _ _ _ _ _ _ INV0 VALID0 _ TGT). destruct LSIM0 as [LSIM IND].
      eapply IH in IND. des. do 2 eexists. split; ss. eapply IND.
    }

    { exists zero, zero. eapply pind9_fold. eapply genos_progress. pclearbot. auto. }

  Qed.

End GENORDER.
#[export] Hint Constructors _genos: core.
#[export] Hint Unfold genos: core.
#[export] Hint Resolve genos_mon: paco.


From iris.prelude Require Import options.
Require Import cpdt.CpdtTactics.
Require Import coq_tricks.Deex.
Require Import Burrow.trees.
Require Import Burrow.locations.
Require Import Burrow.indexing.
Require Import Burrow.gmap_utils.

From stdpp Require Import countable.

Section Relive.

Context {M} `{!EqDecision M} `{!TPCM M}.

Definition reserved_get_or_unit_relive (reserved: Lifetime * M) (old: Lifetime) (new: Lifetime) : M :=
  match reserved with
  | (my_lt, m) => if decide (multiset_le my_lt old /\ ¬ multiset_le my_lt new) then m else unit
  end.

Definition sum_reserved_over_lifetime_relive (reserved: listset (Lifetime * M)) (old: Lifetime) (new: Lifetime) :=
  set_fold (λ reserved m , dot m (reserved_get_or_unit_relive reserved old new)) unit reserved.

Global Instance sum_reserved_over_lifetime_relive_proper :
  Proper ((≡) ==> (=) ==> (=) ==> (=)) (sum_reserved_over_lifetime_relive).
Proof.
  unfold sum_reserved_over_lifetime_relive.
  unfold Proper, "==>". intros. subst.
  have p := set_fold_proper (=) ((λ (reserved : Lifetime * M) (m : M), dot m (reserved_get_or_unit_relive reserved y0 y1))).
  unfold Proper in p. unfold "==>" in p.
  eapply p.
  ** typeclasses eauto.
  ** typeclasses eauto.
  ** intros. crush.
  ** intros. rewrite <- tpcm_assoc. rewrite <- tpcm_assoc.
      f_equal. apply tpcm_comm.
  ** trivial.
Qed.

Definition relive_cell (cell: Cell M) (old: Lifetime) (new: Lifetime) : Cell M :=
  match cell with
  | CellCon m res =>
      CellCon (sum_reserved_over_lifetime_relive res old new) ∅
  end.

Definition relive_cell_exc (cell: Cell M) (old: Lifetime) (new: Lifetime) (exc: Lifetime * M)
      : Cell M :=
  match cell with
  | CellCon m res =>
      CellCon (sum_reserved_over_lifetime_relive (res ∖ {[ exc ]}) old new) ∅
  end.

Global Instance relive_cell_proper : Proper ((≡) ==> (=) ==> (=) ==> (≡)) relive_cell.
Proof.
  unfold Proper, "==>". intros. subst. unfold relive_cell. destruct x, y.
  inversion H. setoid_rewrite H1. trivial.
Qed.

Global Instance relive_cell_exc_proper : Proper ((≡) ==> (=) ==> (=) ==> (=) ==> (≡)) relive_cell_exc.
Proof.
  unfold Proper, "==>". intros. subst. unfold relive_cell_exc. destruct x, y.
  inversion H. setoid_rewrite H1. trivial.
Qed.

Lemma relive_cell_triv old new
  : triv_cell ≡ relive_cell triv_cell old new.
Proof. trivial. Qed.

End Relive.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O E Eprime A B C Oprime Aprime Bprime Cprime Eprimeprime Bprimeprime C2 C3 : Universe, ((wd_ O E /\ (wd_ Oprime Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ A E /\ (wd_ Eprimeprime O /\ (wd_ O Oprime /\ (wd_ Bprimeprime O /\ (wd_ Bprime Oprime /\ (wd_ Oprime C /\ (wd_ Eprimeprime A /\ (wd_ E Eprimeprime /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ Oprime Eprimeprime /\ (wd_ E Oprime /\ (wd_ Bprimeprime C /\ (wd_ Bprime C3 /\ (wd_ B Bprimeprime /\ (wd_ Eprime C2 /\ (wd_ Aprime C2 /\ (wd_ Oprime Aprime /\ (wd_ A Aprime /\ (wd_ C Cprime /\ (wd_ B Bprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ Oprime Eprime Aprime /\ (col_ Oprime Eprime Bprime /\ (col_ Oprime Eprime Cprime /\ (col_ O Eprimeprime Bprimeprime /\ (col_ O Eprimeprime Oprime /\ (col_ O Eprimeprime C2 /\ (col_ O Eprimeprime C3 /\ (col_ O A C /\ (col_ O Oprime C /\ col_ A Oprime C)))))))))))))))))))))))))))))))))))))) -> col_ Oprime O E)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj27eqsynthconj4 : forall  (lv0 : natural), (@eq natural (lv0) (plus lv0 Zero)).
Admitted.
QuickChick conj27eqsynthconj4.


(* Used in output/UnivBinders.v *)

Monomorphic Definition mono@{u} := Type@{u}.

Polymorphic Definition poly@{u} := Type@{u}.

Monomorphic Universe reqU.


From st.prelude Require Import autosubst.
From st.STLCmuVS Require Import lang typing tactics.
From st.STLCmu Require Import types.
From st.STLCmuVS.lib Require Import fixarrow omega.

Inductive action :=
  | Guard
  | Assert.

Definition FstSndga (ga : action) : expr → expr :=
  match ga with
  | Guard => Fst
  | Assert => Snd
  end.

Definition opp_action (ga : action) :=
  match ga with
  | Guard => Assert
  | Assert => Guard
  end.

Definition fixgenTRecga (gb ab : val) : val :=
  (LamV (* 1 → ((τ → τ) × (τ → τ)) *) (
       LamV (* 1 *) (
           ( LamV (Fold (gb.{ren (+2)} (Unfold %0))) , (* τ → τ *)
             LamV (Fold (ab.{ren (+2)} (Unfold %0))) (* τ → τ *)
           )
         )
     )
  )%Eₙₒ.

Lemma fixgenTRecga_subst (gb ab : val) (σ : var → expr) : (fixgenTRecga gb ab).{σ} = fixgenTRecga gb.{up σ} ab.{up σ}.
Proof. rewrite /fixgenTRecga. repeat rewrite -val_subst_valid. by asimpl. Qed.

(* Lemma App_fixgenTRecga_STLCmuVS_step (gb ab : val) (e : expr) : *)
(*   STLCmuVS_step (fixgenTRecga gb ab (Lam e)) *)
(* ((LamV ( *)
(*            ( LamV (Fold ((of_val gb).[Lam e.[ren (0 .: (+3))] .: ren (+2)] (Unfold %0))) , (* τ → τ *) *)
(*              LamV (Fold ((of_val ab).[Lam e.[ren (0 .: (+3))] .: ren (+2)] (Unfold %0))) (* τ → τ *) *)
(*            ) *)
(*          )))%Eₙₒ. *)
(* Proof. *)
(*   assert ( *)
(* (of_val (LamV ( *)
(*            ( LamV (Fold ((of_val gb).[Lam e.[ren (0 .: (+3))] .: ren (+2)] (Unfold %0))) , (* τ → τ *) *)
(*              LamV (Fold ((of_val ab).[Lam e.[ren (0 .: (+3))] .: ren (+2)] (Unfold %0))) (* τ → τ *) *)
(*            ) *)
(*          )))%Eₙₒ = *)
(* ((LamV ( *)
(*            ( LamV (Fold ((of_val gb).[ren (+2)] (Unfold %0))) , (* τ → τ *) *)
(*              LamV (Fold ((of_val ab).[ren (+2)] (Unfold %0))) (* τ → τ *) *)
(*            ) *)
(*          )))%Eₙₒ.[Lam e/] *)
(*     ) as ->. by asimpl. *)
(*   apply head_prim_step. eapply App_Lam_head_step. by simpl. *)
(* Qed. *)

Lemma fixgenTRecga_typed (gb ab : val) Γ τb
      (pgb : (TUnit ⟶ ((TRec τb ⟶ TRec τb) × (TRec τb ⟶ TRec τb)))%Tₙₒ :: Γ ⊢ₙₒ gb : τb.[TRec τb/] ⟶ τb.[TRec τb/])
      (pab : (TUnit ⟶ ((TRec τb ⟶ TRec τb) × (TRec τb ⟶ TRec τb)))%Tₙₒ :: Γ ⊢ₙₒ ab : τb.[TRec τb/] ⟶ τb.[TRec τb/]) :
  Γ ⊢ₙₒ fixgenTRecga gb ab :
    (TUnit ⟶ ((TRec τb ⟶ TRec τb) × (TRec τb ⟶ TRec τb))) ⟶ (TUnit ⟶ ((TRec τb ⟶ TRec τb) × (TRec τb ⟶ TRec τb))).
Proof.
  constructor. constructor. constructor.
  constructor. constructor. apply App_typed with (τ1 := τb.[TRec τb/]). rewrite -val_subst_valid.
  apply context_weakening2. apply pgb.
  constructor. by constructor.
  constructor. constructor. apply App_typed with (τ1 := τb.[TRec τb/]). rewrite -val_subst_valid.
  apply context_weakening2. apply pab.
  constructor. by constructor.
Qed.

Global Opaque fixgenTRecga.

(* Lemma test (t : expr) : t = (ids 1).[up (ren (+2))]. *)
(* asimpl.  *)
Fixpoint ga_pair (ga : action) (τ : type) : val :=
  (match τ with
   | TUnit => match ga with
             | Guard => LamV %0
             | Assert => LamV (Seq %0 ())
             end
   | TBool => match ga with
             | Guard => LamV %0
             | Assert => LamV (If %0 true false)
             end
   | TInt => match ga with
            | Guard => LamV %0
            | Assert => LamV (%0 + 0)
            end
   | TProd τ1 τ2 => LamV (LetIn (Fst %0) (LetIn (Snd %1) ((ga_pair ga τ1).{ren (+3)} %1, (ga_pair ga τ2).{ren (+3)} %0)))
   | TSum τ1 τ2 => LamV (Case %0 (InjL ((ga_pair ga τ1).{ren (+2)} %0)) (InjR ((ga_pair ga τ2).{ren (+2)} %0)))
   | TArrow τ1 τ2 => LamV (Lam ((ga_pair ga τ2).{ren (+2)} (%1 ((ga_pair (opp_action ga) τ1).{ren (+2)} %0))))
   | TRec τb => let β := fixgenTRecga (ga_pair Guard τb) (ga_pair Assert τb) in
               LamV (FstSndga ga (LamV (FixArrow β.{ren (+2)} %0(*_*)) ()) %0)
   | TVar X => LamV (FstSndga ga (Var (S X) ()) %0)
   end)%Eₙₒ.

(* We never actually need typedness of ga; but it serves as a good sanity check *)
Lemma ga_typed_gen (τ : type) (τs : list type) (pτn : Closed_n (length τs) τ) (ga : action) :
  map (fun τ => (TUnit ⟶ (τ ⟶ τ) × (τ ⟶ τ))%Tₙₒ) τs ⊢ₙₒ (ga_pair ga τ) : (τ.[subst_list τs] ⟶ τ.[subst_list τs]).
Proof.
  generalize dependent ga.
  generalize dependent τs.
  induction τ as [ | | | τ1 IHτ1 τ2 IHτ2 | τ1 IHτ1 τ2 IHτ2 | τ1 IHτ1 τ2 IHτ2 | τb IHτb | X ]; intros τs Cnτ ga;
    try by (destruct ga; by repeat econstructor).
  - repeat econstructor; fold ga_pair.
    rewrite -val_subst_valid. apply context_weakening3. apply IHτ1. closed_solver.
    rewrite -val_subst_valid. apply context_weakening3. apply IHτ2. closed_solver.
  - repeat econstructor; fold ga_pair.
    rewrite -val_subst_valid. apply context_weakening2. apply IHτ1. closed_solver.
    rewrite -val_subst_valid. apply context_weakening2. apply IHτ2. closed_solver.
  - repeat econstructor; fold ga_pair.
    rewrite -val_subst_valid. apply context_weakening2. apply IHτ2. closed_solver.
    rewrite -val_subst_valid. apply context_weakening2. apply IHτ1. closed_solver.
  - (* TRec *) destruct ga.
    + constructor. fold ga_pair.
      apply App_typed with (τ1 := (TRec τb).[subst_list τs]). 2: by constructor.
      eapply Fst_typed.
      apply App_typed with (τ1 := TUnit). 2: by constructor. apply Lam_typed.
      apply App_typed with (τ1 := TUnit). 2: by constructor.
      apply FixArrow_typed. rewrite -val_subst_valid. apply context_weakening2. apply fixgenTRecga_typed.
      * asimpl. change (TRec τb.[up (subst_list τs)] .: subst_list τs) with (subst_list (TRec τb.[up (subst_list τs)] :: τs)).
        rewrite -map_cons. apply IHτb with (ga := Guard). closed_solver.
      * asimpl. change (TRec τb.[up (subst_list τs)] .: subst_list τs) with (subst_list (TRec τb.[up (subst_list τs)] :: τs)).
        rewrite -map_cons. apply IHτb with (ga := Assert). closed_solver.
    + constructor. fold ga_pair.
      eapply App_typed. 2: by constructor.
      eapply Snd_typed.
      apply App_typed with (τ1 := TUnit). 2: by constructor. apply Lam_typed.
      apply App_typed with (τ1 := TUnit). 2: by constructor.
      apply FixArrow_typed. rewrite -val_subst_valid. apply context_weakening2.
      simpl. apply fixgenTRecga_typed.
      * asimpl. change (TRec τb.[up (subst_list τs)] .: subst_list τs) with (subst_list (TRec τb.[up (subst_list τs)] :: τs)).
        rewrite -map_cons. apply IHτb with (ga := Guard). closed_solver.
      * asimpl. change (TRec τb.[up (subst_list τs)] .: subst_list τs) with (subst_list (TRec τb.[up (subst_list τs)] :: τs)).
        rewrite -map_cons. apply IHτb with (ga := Assert). closed_solver.
  - (* TVar *)
    destruct (TVar_subst_list_closed_n_length _ _ Cnτ) as [τ [eq ->]].
    destruct ga; repeat econstructor; simpl; by rewrite list_lookup_fmap eq /=.
Qed.

Lemma ga_pair_typed (τ : type) (pτn : Closed τ) (ga : action) :
  [] ⊢ₙₒ (ga_pair ga τ) : (τ ⟶ τ).
Proof.
  cut (map (fun τ => (TUnit ⟶ (τ ⟶ τ) × (τ ⟶ τ))%Tₙₒ) [] ⊢ₙₒ (ga_pair ga τ) : (τ.[subst_list []] ⟶ τ.[subst_list []])).
  by asimpl. by apply ga_typed_gen.
Qed.

Lemma ga_pair_closed (τ : type) (pτn : Closed τ) (ga : action) :
  Closed (of_val (ga_pair ga τ)).
Proof.
  intro σ. change 0 with (length ([] : list type)).
  apply (typed_n_closed [] (TArrow τ τ)). by apply ga_pair_typed.
Qed.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2017   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.

Require Import floating_point.GenFloat.

(* Why3 goal *)
Definition single : Type.
exact (t 24 128).
Defined.

Global Instance single_WhyType : WhyType single.
Proof.
apply t_WhyType.
Qed.


(**************************  uc/OS-II  ******************************)
(*************************** OS_TIME.C ******************************)
(******Proofs for API Fucntion:  void* OSTimeDly(INT16U ticks)*******)
(************************C Source Code:******************************)
(*
void  OSTimeDly (INT16U ticks)
{
1  if (ticks > 0)
   {
2    OS_ENTER_CRITICAL();
3    if(OSTCBCur -> OSTCBPrio == OS_PRIO_IDLE)
     {
4      OS_EXIT_CRITICAL;
5      reutrn;
     }
6    if (OSTCBCur->OSTCBStat == OS_STAT_RDY && OSTCBCur -> OSTCBDly == 0)
     {
7      if ((OSRdyTbl[OSTCBCur->OSTCBY] &= ~OSTCBCur->OSTCBBitX) == 0)
       {
8        OSRdyGrp &= ~OSTCBCur->OSTCBBitY;
       }
9      OSTCBCur->OSTCBDly = ticks;
10       OS_EXIT_CRITICAL();
11      OS_Sched();
     }
12   else
13     OS_EXIT_CRITICAL();
   }
14 return;
}
*)
(*********************************************************************)

Require Import ucos_include.
Require Import OSTimeDlyPure.
Require Import time_absop_rules.

Open Scope code_scope.
(* OSTimeDelay Proof *)
Open Scope int_scope.

Lemma val_inj_ltu_true:
forall i,
val_inj
         (if Int.ltu ($ 0) i
          then Some (Vint32 Int.one)
          else Some (Vint32 Int.zero)) <> Vint32 Int.zero ->
Int.ltu ($ 0) i = true.
Proof.
  intros.
  remember (Int.ltu ($ 0) i) as Hi.
  destruct Hi; auto.
Qed.

Lemma val_inj_ltu_false:
  forall i,val_inj
             (if Int.ltu ($ 0) i
              then Some (Vint32 Int.one)
              else Some (Vint32 Int.zero)) = Vint32 Int.zero \/
           val_inj
             (if Int.ltu ($ 0) i
              then Some (Vint32 Int.one)
              else Some (Vint32 Int.zero)) = Vnull ->
           i = Int.zero.
Proof.
  intros.
  destruct H;
    match goal with
      | H : context [if ?x then _ else _ ] |- _ =>
        let y := fresh in  remember x as y ; destruct y; simpl in H; tryfalse
    end.
  apply ltu_zero_eq_zero;eauto.
  int auto.
Qed.
(*
Ltac solve_if_neq :=
  match goal with
  |  |- context[if ?c then _ else _] =>
     try solve
         [ let x := fresh in
           (destruct c; simpl; introv x; tryfalse) |
           apply true_if_else_true;
             apply Zle_is_le_bool;
             try rewrite byte_max_unsigned_val;
             try rewrite max_unsigned_val;
             try omega; auto
         ]

  end.

Ltac pure_auto := first [ do 2 solve_if_neq | go | pauto'].
*)

Lemma OSTimeDlyProof :
  forall vl p r tid ,
    Some p = BuildPreA' os_api OSTimeDly dlyapi vl OSLInv tid init_lg ->
    Some r = BuildRetA' os_api OSTimeDly dlyapi vl OSLInv tid init_lg ->
    exists t d1 d2 s,
      os_api OSTimeDly = Some (t, d1, d2, s) /\
      {| OS_spec, GetHPrio, OSLInv, I, r, Afalse |} |-tid {{ p }} s {{ Afalse }}.
Proof.
  init_spec.

(* if----------------------L1*)
  hoare forward; pure_auto.
  Focus 2.
  instantiate (1 := <||END None||>  **
                           LV ticks @ Int16u |-> Vint32 i **
                           Aie true **
                           Ais nil **
                           Acs nil ** Aisr empisr ** A_dom_lenv ((ticks, Int16u) :: nil) ** p_local OSLInv tid init_lg).

  hoare forward.
  hoare forward.

  hoare unfold pre.
  hoare abscsq.
  apply noabs_oslinv.
  eapply  OSTimeDly_high_level_step_1.
  eapply val_inj_ltu_false; auto.
  pure_auto.
  hoare forward.
  (* en_crit---------------L2*)
  pure intro.
  assert (Int.ltu ($ 0) i = true).
  remember (Int.ltu ($ 0) i) as X.
  destruct X;unfolds in H;simpl in H;tryfalse;auto.
  clear H H0 H2.
  hoare forward prim.
  hoare unfold.
  (* if idle ---------------L3*)
  hoare forward.
  pure_auto.
  pure_auto.
  pure intro.
  instantiate (1:=Afalse).
  (*------------------------L4*)
  assert (Int.eq i4 ($ OS_IDLE_PRIO) =true).
  destruct (Int.eq i4 ($ OS_IDLE_PRIO));unfolds in H4;simpl in H4;tryfalse;auto.
  clear H4 H5 H12.
  unfold1 TCBList_P in H10;simpljoin.
  unfold TCBNode_P in *.
  destruct x2.
  destruct p.
  simpljoin.
  unfold V_OSTCBNext, V_OSTCBMsg, V_OSTCBPrio in *.
  unfold TcbJoin in *.
  assert (TcbMod.get v'21 x = Some (p, t, m)).
  lets H100 : TcbMod.get_sig_some x (p, t, m).
  eapply TcbMod.join_get_get_l; eauto.
  assert (TcbMod.get v'13 x = Some (p, t, m)).
  eapply TcbMod.join_get_get_r; eauto.
  unfolds in H25.
  inverts H25.
  lets Hx: Int.eq_spec p ($ OS_IDLE_PRIO).
  rewrite H23 in Hx.
  subst p.
  inverts H4.
  hoare abscsq.
  apply noabs_oslinv.
  eapply OSTimeDly_high_level_step_4;eauto.
  pure_auto.

  hoare forward prim.
  unfold AOSTCBList.
  sep pauto;eauto.
  sep cancel tcbdllflag.
  unfold tcbdllseg.
  unfold dllseg at 2;fold dllseg.
  sep pauto.
  unfold node.
  sep pauto.
  splits; pauto.
  unfolds;simpl;auto.
  unfolds;simpl;auto.
  simpl;auto.
  do 4 eexists;splits;eauto.
  unfolds.
  splits;eauto.
  simpl;auto.
  (* return----------------------L5*)
  hoare forward.

  (* if rdy ---------------L6*)
  hoare forward.
  pure intro.
  assert (Int.eq i4 ($ OS_IDLE_PRIO) = false) as Hnidle.
  clear -H4.
  destruct (Int.eq i4 ($ OS_IDLE_PRIO));auto;destruct H4;simpl in H;tryfalse.
  clear H4.
  hoare forward;pure_auto.
  pure intro.
  (*-----------------------L4*)
  assert (Int.eq i5 ($ OS_STAT_RDY) =true).
  destruct (Int.eq i5 ($ OS_STAT_RDY));destruct (Int.eq i6 ($ 0));unfolds in H4;simpl in H4;tryfalse;auto.
  assert (Int.eq i6  ($ 0) = true) as Hdly0.
  destruct (Int.eq i5 ($ OS_STAT_RDY));destruct (Int.eq i6 ($ 0));unfolds in H4;simpl in H4;tryfalse;auto.
  clear H4 H5 H12.
  hoare unfold.
  assert (TCBList_P (Vptr (v'23, Int.zero))
                    ((v'22
                        :: v'18
                        :: x7
                        :: x6
                        :: Vint32 i6
                        :: Vint32 i5
                        :: Vint32 i4
                        :: Vint32 i3
                        :: Vint32 i2
                        :: Vint32 i1 :: Vint32 i0 :: nil) :: v'9)
                    v'10 v'21) as Htcblistp.
  auto.
  unfold1 TCBList_P in H10; simpljoin.
  unfold TCBNode_P in *.
  rename e into H10.
  rename e0 into H25.
  rename j into  H26.
  rename t into H27.
  rename t0 into H28.
  destruct x2.
  destruct p.
  simpljoin.
  unfold V_OSTCBNext, V_OSTCBMsg, V_OSTCBPrio in *.
  unfold TcbJoin in *.
  assert (TcbMod.get v'21 x = Some (p, t, m)).
  lets H100 : TcbMod.get_sig_some x (p, t, m).
  eapply TcbMod.join_get_get_l; eauto.
  assert (TcbMod.get v'13 x = Some (p, t, m)).
  eapply TcbMod.join_get_get_r; eauto.
  assert ((Int.unsigned i2 < 8)%Z).
  unfold RL_TCBblk_P in r; simpljoin.
  unfold V_OSTCBY in H34; simpl in H34; inverts H34.
  pauto.
  assert (length v'10 = 8%nat).
  pauto.
  assert (exists i4,
            nth_val' (Z.to_nat (Int.unsigned i2)) v'10 = Vint32 i4 /\
            Int.unsigned i4 <= 255)%Z.
  apply array_int8u_nth_lt_len; auto.
  rewrite H31.
  clear - H30.
  apply Nat2Z.inj_lt.
  rewrite Z2Nat.id; int auto.
  simpljoin.
  hoare forward.
  pure_auto.
  rewrite H32; simpl; pure_auto.
  pure_auto.
(*  pure_auto. *)
  rewrite H32; simpl; pure_auto.
  pure_auto.

  (* if -----------------------L5*)

  hoare unfold.
  hoare forward.
  pure_auto.
  rewrite H32; simpl val_inj.
  rewrite update_nth_val_len_eq.
  rewrite H31.
  simpl; auto.

  rewrite H32; simpl val_inj.
  rewrite len_lt_update_get_eq.
  simpl.
  cut (Int.unsigned (Int.and x2 (Int.not i1)) <=? Byte.max_unsigned = true)%Z.
  intros H100; rewrite H100; auto.
  apply leb_bytemax_true_intro.
  apply int_lemma1; auto.
  rewrite H31; simpl; auto.

  rewrite H32; simpl val_inj.
  rewrite len_lt_update_get_eq.
  simpl.
  pure_auto.
  rewrite H31; simpl; auto.
  unfold AOSRdyGrp.
  hoare_assign.
  pure_auto.
  pure_auto.
  rule_type_val_match_elim; simpl; auto.
  pure_auto.

  hoare forward.
  lets Hst: low_stat_rdy_imp_high r H23 Hdly0;eauto.
  subst.
  hoare forward.
  pure_auto.
  hoare abscsq.
  apply noabs_oslinv.
  eapply OSTimeDly_high_level_step_2; eauto.
  pure_auto.
  unfold AECBList in *.
  instantiate (1 := <||END None||> ** Aie true **
                       Ais nil **
                       Acs nil **
                       Aisr empisr ** p_local OSLInv (v'23, Int.zero) init_lg ** LV ticks @ Int16u |-> Vint32 i ** A_dom_lenv ((ticks, Int16u) :: nil)).
  hoare forward prim.
  unfold AECBList in *.
  instantiate (1 := LV ticks @ Int16u |-> Vint32 i ** A_dom_lenv ((ticks, Int16u) :: nil)).
  sep semiauto.
  sep cancel evsllseg.
  sep cancel Astruct.
  sep cancel dllseg.
  sep cancel dllseg.
  sep lift 3%nat in H10.
  sep lift 3%nat.
  eapply tcbdllflag_hold;eauto.
  apply tcbdllflag_hold_middle.
  simpl;auto.
  rule_type_val_match_elim; simpl val_inj.
  rewrite H32; simpl val_inj.
  split.
  eapply event_wait_rl_tbl_grp';eauto.
  rewrite len_lt_update_get_eq in H36.
  rewrite H32 in H36.
  simpl in H36.
  destruct (Int.eq (x2&ᵢInt.not i1) ($ 0));simpl in H36;tryfalse;auto.
  rewrite H31.
  unfolds OS_RDY_TBL_SIZE.
  simpl Z.of_nat.
  auto.
  eapply idle_in_rtbl_hold;eauto.

  rule_type_val_match_elim; simpl; auto.
  cut (Int.unsigned (i4&ᵢInt.not i0) <=? Byte.max_unsigned = true)%Z.
  intros H100;rewrite H100; auto.
  apply leb_bytemax_true_intro.
  apply int_lemma1; auto.

  split.
  apply array_type_vallist_match_hold; auto.
  rewrite H31; simpl; auto.
  apply Nat2Z.inj_lt.
  clear - H30.
  rewrite Z2Nat.id; int auto.

  rewrite H32; simpl.
  cut (Int.unsigned (x2&ᵢInt.not i1) <=? Byte.max_unsigned = true)%Z.
  intros H100; rewrite H100; auto.
  apply leb_bytemax_true_intro.
  apply int_lemma1; auto.

  rewrite update_nth_val_len_eq.
  simpl; auto.

  eapply R_PrioTbl_P_hold1; eauto.

  rewrite H32.
  simpl.

  eapply rtbl_remove_RL_RTbl_PrioTbl_P_hold with (prio:= p) ;eauto;
  (funfold r; try rewrite Int.repr_unsigned; auto).

  apply nth_val'_imp_nth_val_int;auto.

  eapply ECBList_P_hold1;eauto.
  instantiate (1 := (TcbMod.set v'21 (v'23, Int.zero)
                                (p, wait os_stat_time  i, m))).
  rewrite H32; simpl val_inj.

  3:apply TcbMod.join_set_r; eauto;unfold TcbMod.indom;eauto.

  eapply TCBList_P_tcb_dly_hold;eauto.

  eapply TcbMod_join_impl_prio_neq_cur_r;eauto.

  eapply R_PrioTbl_P_impl_prio_neq_cur; eauto.
  funfold r; auto.
  apply nth_val'_imp_nth_val_int;auto.
  rewrite H32; simpl val_inj.
  eapply TCBList_P_tcb_dly_hold';eauto; (funfold r; try rewrite Int.repr_unsigned; auto).
  eapply TcbMod_join_impl_prio_neq_cur_l;eauto.
  eapply R_PrioTbl_P_impl_prio_neq_cur; eauto.
  apply nth_val'_imp_nth_val_int;auto.
  unfolds; simpl; auto.
  unfolds; simpl; auto.
  split; auto.
  pure_auto.
  eapply RH_CurTCB_hold1; eauto.
  eapply RH_TCBList_ECBList_P_hold1; eauto.
  simpl; auto.

  (**hoare forward**)

  hoare forward.
  instantiate (1:=  LV ticks @ Int16u |-> Vint32 i **
                       A_dom_lenv ((ticks, Int16u) :: nil)).
  sep auto.
  eauto.
  unfolds;simpl;auto.
  simpl;auto.
  sep auto.
  sep cancel p_local.
  simpl; auto.
  sep auto.
  sep cancel p_local.
  simpl; auto.
  unfold getasrt in H10.
  unfold OS_SchedPost  in H10.
  unfold OS_SchedPost' in H10.
  sep auto.
  inverts H25; auto.

  (* if false  *)
  lets Hst: low_stat_rdy_imp_high r r0 Hdly0;eauto.
  subst.
  hoare forward.
  pauto.
  hoare abscsq.
  apply noabs_oslinv.
  eapply OSTimeDly_high_level_step_2;eauto.
  can_change_aop_solver.
  unfold AECBList in *.
  hoare forward prim.
  unfold AECBList in *.
  instantiate (1 := LV ticks @ Int16u |-> Vint32 i ** A_dom_lenv ((ticks, Int16u) :: nil)).
  sep semiauto.
  sep cancel evsllseg.
  sep cancel Astruct.
  sep cancel dllseg.
  sep cancel dllseg.
  sep lift 3%nat in H10.
  sep lift 3%nat.

  eapply tcbdllflag_hold;eauto.
  apply tcbdllflag_hold_middle.
  simpl;auto.
  rule_type_val_match_elim; simpl val_inj.
  rewrite H32; simpl val_inj.
  split.
  eapply event_wait_rl_tbl_grp'';eauto.
  rewrite H32 in H34.
  rewrite len_lt_update_get_eq in H34.
  clear -H34.
  unfold val_inj in H34.
  simpl in H34.
  destruct ( Int.eq (x2&ᵢInt.not i1) ($ 0));tryfalse;auto.
  destruct H34;tryfalse.
  rewrite H31.
  simpl Z.of_nat.
  auto.
  eapply idle_in_rtbl_hold;eauto.

  split.
  apply array_type_vallist_match_hold; auto.
  rewrite H31; simpl; auto.
  apply Nat2Z.inj_lt.
  clear -H30.
  rewrite Z2Nat.id; int auto.

  rewrite H32; simpl.
  cut (Int.unsigned (x2&ᵢInt.not i1) <=? Byte.max_unsigned = true)%Z.
  intros H100; rewrite H100; auto.
  apply leb_bytemax_true_intro.
  apply int_lemma1; auto.

  rewrite update_nth_val_len_eq.
  simpl; auto.

  eapply R_PrioTbl_P_hold1; eauto.

  rewrite H32.
  simpl.
  eapply rtbl_remove_RL_RTbl_PrioTbl_P_hold with (prio:= p) ;eauto;
  (funfold r; try rewrite Int.repr_unsigned; auto).
  apply nth_val'_imp_nth_val_int;auto.
  eapply ECBList_P_hold1;eauto.
  instantiate (1 := (TcbMod.set v'21 (v'23, Int.zero)
                                (p, wait os_stat_time i, m))).
  rewrite H32; simpl val_inj.

  3:apply TcbMod.join_set_r; eauto;unfold TcbMod.indom;eauto.
  eapply TCBList_P_tcb_dly_hold;eauto.
  eapply TcbMod_join_impl_prio_neq_cur_r;eauto.

  eapply R_PrioTbl_P_impl_prio_neq_cur; eauto.
  funfold r; auto.
  apply nth_val'_imp_nth_val_int;auto.
  rewrite H32; simpl val_inj.
  eapply TCBList_P_tcb_dly_hold';eauto;
  (funfold r; try rewrite Int.repr_unsigned; auto).
  eapply TcbMod_join_impl_prio_neq_cur_l;eauto.
  eapply R_PrioTbl_P_impl_prio_neq_cur; eauto.
  apply nth_val'_imp_nth_val_int;auto.
  unfolds; simpl; auto.

  unfolds; simpl; auto.

  split; auto.
  pauto.
  eapply RH_CurTCB_hold1; eauto.
  eapply RH_TCBList_ECBList_P_hold1; eauto.
  simpl; auto.

  (*hoare forward*)
  hoare forward.

  instantiate (1:=  LV ticks @ Int16u |-> Vint32 i **
           A_dom_lenv ((ticks, Int16u) :: nil)).
  sep auto.
  eauto.
  unfolds;simpl;auto.
  simpl;auto.
  sep auto.
  inverts H25.
  sep cancel 1%nat 1%nat.
  simpl ; auto.
  unfold getasrt.
  unfold OS_SchedPre.
  unfold OS_SchedPre'.
  sep auto.
  sep cancel 1%nat 1%nat.
  simpl; auto.
   unfold getasrt in H10.
  unfold OS_SchedPost in H10.
  unfold OS_SchedPost' in H10.
  sep auto.
  inverts H25; auto.

  pure intro.
  assert (Int.eq i5 ($ OS_STAT_RDY)=false \/ Int.eq i6 ($ 0) = false).
  clear -H4.
  unfold val_inj in H4;destruct (Int.eq i5 ($ OS_STAT_RDY));destruct (Int.eq i6 ($ 0));simpl in H4;tryfalse;auto.
  assert (Int.ltu Int.zero Int.one && Int.ltu Int.zero Int.one = true).
  unfolds.

  assert ( Int.ltu Int.zero Int.one = true).
  clear;int auto.
  rewrite H.
  auto.
  rewrite H in H4.
  destruct H4;tryfalse.

  assert (TCBList_P (Vptr (v'23, Int.zero))
                    ((v'22
                        :: v'18
                        :: x7
                        :: x6
                        :: Vint32 i6
                        :: Vint32 i5
                        :: Vint32 i4
                        :: Vint32 i3
                        :: Vint32 i2
                        :: Vint32 i1 :: Vint32 i0 :: nil) :: v'9)
                    v'10 v'21) as X.
  auto.
  unfold1 TCBList_P in H10.
  simpljoin.
  unfold TCBNode_P in *.
  destruct x2.
  destruct p.
  simpljoin.
  lets Hx: low_stat_nordy_imp_high r0 H5.

  unfolds in j.
  assert (TcbMod.get v'21 x = Some (p, t1, m)).
  lets H100 : TcbMod.get_sig_some x (p, t1, m).
  eapply TcbMod.join_get_get_l; eauto.
  assert (TcbMod.get v'13 x = Some (p, t1, m)).
  eapply TcbMod.join_get_get_r; eauto.

  hoare abscsq.
  apply noabs_oslinv.
  eapply OSTimeDly_high_level_step_3;eauto.
  inverts e.
  eauto.
  can_change_aop_solver.
  instantiate (1:= <|| END None ||>  ** p_local OSLInv (v'23, Int.zero) init_lg **
                           Aisr empisr **
                           Aie true **
                           Ais nil **
                           Acs nil **
                           LV ticks @ Int16u |-> Vint32 i ** A_dom_lenv ((ticks, Int16u) :: nil)).
  hoare forward prim.

  unfold AOSTCBList.
  sep pauto;eauto.
  unfold tcbdllseg.
  unfold dllseg at 2;fold dllseg.
  sep pauto.
  unfold node.
  sep pauto.
  splits; pure_auto.
  unfolds;simpl;auto.
  unfolds;simpl;auto.
  simpl;auto.
  destruct H4.
  sep auto.
  sep auto.
Qed.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.

Require Import floating_point.GenFloat.

(* Why3 goal *)
Definition single : Type.
exact (t 24 128).
Defined.

Global Instance single_WhyType : WhyType single.
Proof.
apply t_WhyType.
Qed.


Require compcert.common.Events.

Import Coqlib.
Import Values.
Import Memory.
Import Globalenvs.
Export Events.

(** [CompCertX:test-compcert-protect-stack] For CompCertX, we are
 going to instantiate CompCert with a non-trivial predicate for
 "writable memory blocks", ensuring that the stack locations of the
 caller are not "writable", and thus not overwritten by the compiled code.
 *)

Class WritableBlockAllowGlobals
      WB
      `{wb_ops: WritableBlockOps WB} :=
  {
    writable_block_allow_globals:
      forall {F V} (ge: Genv.t F V) i b,
        Genv.find_symbol ge i = Some b ->
        writable_block ge b
  }.

Section WITHMEM.
Context `{memory_model_ops: Mem.MemoryModelOps}.

Lemma protect_inject:
  forall (m_init: mem) f
         (Hincr: inject_incr (Mem.flat_inj (Mem.nextblock m_init)) f)
         (Hsep: inject_separated (Mem.flat_inj (Mem.nextblock m_init)) f m_init m_init)
         b1 b2 o
         (Hf: f b1 = Some (b2, o))
         n
         (Hn: Ple n (Mem.nextblock m_init))
  ,
        ((Ple n b1 /\ Plt b1 (Mem.nextblock m_init)) <-> (Ple n b2 /\ Plt b2 (Mem.nextblock m_init))).
Proof.
  intros.
  case_eq (Mem.flat_inj (Mem.nextblock m_init) b1).
   intros ? Hinj.
   generalize Hinj.
   unfold Mem.flat_inj. destruct (plt b1 (Mem.nextblock m_init)); try discriminate.
   injection 1; intros; subst.
   apply Hincr in Hinj.
   replace b2 with b1  in * by congruence.
   tauto.
  intro.
  exploit Hsep; eauto.
  unfold Mem.valid_block.
  xomega.
Qed.

Definition writable_block
           (m_init: mem)
           (F V: Type)
           (ge: Genv.t F V)
           (b: block)
: Prop
  :=
    ~ (Ple (Genv.genv_next ge) b /\ Plt b (Mem.nextblock m_init)).
Global Arguments writable_block _ [_ _] _ _.

Theorem global_writable_block:
  forall m_init
         (F V: Type)
         (ge: Genv.t F V)
         i b,
    Genv.find_symbol ge i = Some b ->
    writable_block m_init ge b.
Proof.
  intros.
  exploit Genv.genv_symb_range; eauto.
  unfold writable_block. xomega.
Qed.

Theorem callee_writable_block:
  forall m_init b,
    ~ Mem.valid_block m_init b ->
    forall (F V: Type)
           (ge: Genv.t F V),
      writable_block m_init ge b.
Proof.
  unfold Mem.valid_block, writable_block.
  intros. xomega.
Qed.

Theorem writable_block_genv_next:
  forall m_init
         (F1 V1 F2 V2: Type) (ge1: Genv.t F1 V1) (ge2: Genv.t F2 V2)
         (Hnext: Genv.genv_next ge2 = Genv.genv_next ge1)
         b,
    writable_block m_init ge2 b = writable_block m_init ge1 b.
Proof.
  unfold writable_block. intros. congruence.
Qed.

Theorem writable_block_inject:
  forall m_init
         (F V: Type)
         (ge: Genv.t F V)
         (Hn: Ple (Genv.genv_next ge) (Mem.nextblock m_init))
         f
         (Hincr: inject_incr (Mem.flat_inj (Mem.nextblock m_init)) f)
         (Hsep: inject_separated (Mem.flat_inj (Mem.nextblock m_init)) f m_init m_init)
         b1 b2 o
         (Hf: f b1 = Some (b2, o))
  ,
  writable_block m_init ge b1 -> writable_block m_init ge b2.
Proof.
  unfold writable_block. intros.
  rewrite <- protect_inject; eauto.
Qed.

Global Instance writable_block_with_init_mem_ops:
  WritableBlockWithInitMemOps writable_block.
Proof.
  constructor.
  intro. constructor.
Defined.

Global Instance writable_block_with_init_mem:
  WritableBlockWithInitMem writable_block.
Proof.
  constructor.
  intro. constructor.
   unfold Events.writable_block, writable_block_with_init_mem, writable_block.
   congruence.
  unfold writable_block_with_init_mem, writable_block.
  intros; eapply writable_block_inject; eauto.
Qed.

Global Instance writable_block_ops
       (m: mem):
  WritableBlockOps (writable_block m).
Proof.
  eauto using writable_block_with_init_mem_writable_block_ops.
Defined.

Global Instance Hwritable_block
       (m: mem):
  WritableBlock (writable_block m).
Proof.
  typeclasses eauto.
Qed.

Global Instance Hwritable_block_allow_globals
       (m: mem):
  WritableBlockAllowGlobals (writable_block m).
Proof.
  constructor.
  apply global_writable_block.
Qed.

End WITHMEM.


Require Import Integers.
Require Import Coqlib.
Definition main_id := (77%positive).
Definition func_id := (54%positive).


(* Functional implementation of Salsa20 whose
   structure matches the one of tweetnacl.c implementation,
   plus proof of coorrectness wrt Salsa20.v

   Lennart Beringer, June 2015*)
(*Processing time for this file: approx 13mins*)
Require Import VST.floyd.proofauto.
Local Open Scope logic.
Require Import List. Import ListNotations.
(*Require Import general_lemmas.

Require Import split_array_lemmas.*)
Require Import ZArith.
Local Open Scope Z.
Require Import tweetnacl20140427.tweetNaclBase.
Require Import tweetnacl20140427.Salsa20.
Require Import tweetnacl20140427.verif_salsa_base.
Require Import tweetnacl20140427.tweetnaclVerifiableC.
Require Import tweetnacl20140427.Snuffle.
Require Import tweetnacl20140427.spec_salsa.

Require Import tweetnacl20140427.verif_fcore_loop1.
Require Import tweetnacl20140427.verif_fcore_loop2.
Require Import tweetnacl20140427.verif_fcore_loop3.

Require Import tweetnacl20140427.verif_fcore_epilogue_htrue.
Require Import tweetnacl20140427.verif_fcore_epilogue_hfalse.

Opaque littleendian_invert. Opaque Snuffle.Snuffle.

Lemma HFalse_inv16_char: forall l xs ys,
  HFalse_inv l 16 xs ys ->
  Zlength xs = 16 -> Zlength ys=16 ->
  exists sum, Some sum = sumlist xs ys /\
  l = QuadChunks2ValList (map littleendian_invert sum).
Proof. intros. destruct H.
 destruct (listGE16 l) as
  [v0 [v1 [v2 [v3 [v4 [v5 [v6 [v7 [v8 [v9 [v10 [v11 [v12 [v13 [v14 [v15 [t1 [T1 L1]]]]]]]]]]]]]]]]]]. lia.
 rewrite H in L1; simpl in L1.
 destruct (listGE16 t1) as
  [v16 [v17 [v18 [v19 [v20 [v21 [v22 [v23 [v24 [v25 [v26 [v27 [v28 [v29 [v30 [v31 [t2 [T2 L2]]]]]]]]]]]]]]]]]]. lia.
 rewrite L1 in L2; simpl in L2.
 destruct (listGE16 t2) as
  [v32 [v33 [v34 [v35 [v36 [v37 [v38 [v39 [v40 [v41 [v42 [v43 [v44 [v45 [v46 [v47 [t3 [T3 L3]]]]]]]]]]]]]]]]]]. lia.
 rewrite L2 in L3; simpl in L3.
 destruct (listGE16 t3) as
  [v48 [v49 [v50 [v51 [v52 [v53 [v54 [v55 [v56 [v57 [v58 [v59 [v60 [v61 [v62 [v63 [t4 [T4 L4]]]]]]]]]]]]]]]]]]. lia.
 rewrite L3 in L4; simpl in L4.
 apply Zlength_nil_inv in L4. subst t3 t4 t2 t1. clear L1 L2 L3 H. simpl in T1.
 destruct (listD16 _ H0) as
  [x0 [x1 [x2 [x3 [x4 [x5 [x6 [x7 [x8 [x9 [x10 [x11 [x12 [x13 [x14 [x15 A1]]]]]]]]]]]]]]]].
 destruct (listD16 _ H1) as
  [y0 [y1 [y2 [y3 [y4 [y5 [y6 [y7 [y8 [y9 [y10 [y11 [y12 [y13 [y14 [y15 B1]]]]]]]]]]]]]]]].
subst l xs ys.
eexists; split. reflexivity.
unfold Znth in H2. simpl.
destruct (H2 0) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 1) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 2) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 3) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 4) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 5) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 6) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 7) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 8) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 9) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 10) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 11) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 12) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 13) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 14) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
destruct (H2 15) as [x [X [y [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y. rewrite <- Q; clear Q.
reflexivity.
Qed.

Lemma TP C1 C2 C3 C4 N1 N2 N3 N4 intsums OUT: Zlength intsums = 16 -> Zlength OUT = 32 ->
  hPosLoop3 4 (hPosLoop2 4 intsums (C1, C2, C3, C4) (N1, N2, N3, N4)) OUT =
 QuadByte2ValList (littleendian_invert (Int.sub (Znth 0 intsums)  (littleendian C1))) ++
 QuadByte2ValList (littleendian_invert (Int.sub (Znth 5 intsums)  (littleendian C2))) ++
 QuadByte2ValList (littleendian_invert (Int.sub (Znth 10 intsums) (littleendian C3))) ++
 QuadByte2ValList (littleendian_invert (Int.sub (Znth 15 intsums) (littleendian C4))) ++
 QuadByte2ValList (littleendian_invert (Int.sub (Znth 6 intsums)  (littleendian N1))) ++
 QuadByte2ValList (littleendian_invert (Int.sub (Znth 7 intsums)  (littleendian N2))) ++
 QuadByte2ValList (littleendian_invert (Int.sub (Znth 8 intsums)  (littleendian N3))) ++
 QuadByte2ValList (littleendian_invert (Int.sub (Znth 9 intsums)  (littleendian N4))).
Proof. intros.
rewrite Zlength_length in H, H0. simpl in H, H0.
destruct intsums; simpl in H. lia. rename i into v0.
destruct intsums; simpl in H. lia. rename i into v1.
destruct intsums; simpl in H. lia. rename i into v2.
destruct intsums; simpl in H. lia. rename i into v3.
destruct intsums; simpl in H. lia. rename i into v4.
destruct intsums; simpl in H. lia. rename i into v5.
destruct intsums; simpl in H. lia. rename i into v6.
destruct intsums; simpl in H. lia. rename i into v7.
destruct intsums; simpl in H. lia. rename i into v8.
destruct intsums; simpl in H. lia. rename i into v9.
destruct intsums; simpl in H. lia. rename i into v10.
destruct intsums; simpl in H. lia. rename i into v11.
destruct intsums; simpl in H. lia. rename i into v12.
destruct intsums; simpl in H. lia. rename i into v13.
destruct intsums; simpl in H. lia. rename i into v14.
destruct intsums; simpl in H. lia. rename i into v15.
destruct intsums; simpl in H. 2: lia. clear H. simpl.
unfold Znth. simpl.
destruct OUT; simpl in H0. lia. rename v into u0.
destruct OUT; simpl in H0. lia. rename v into u1.
destruct OUT; simpl in H0. lia. rename v into u2.
destruct OUT; simpl in H0. lia. rename v into u3.
destruct OUT; simpl in H0. lia. rename v into u4.
destruct OUT; simpl in H0. lia. rename v into u5.
destruct OUT; simpl in H0. lia. rename v into u6.
destruct OUT; simpl in H0. lia. rename v into u7.
destruct OUT; simpl in H0. lia. rename v into u8.
destruct OUT; simpl in H0. lia. rename v into u9.
destruct OUT; simpl in H0. lia. rename v into u10.
destruct OUT; simpl in H0. lia. rename v into u11.
destruct OUT; simpl in H0. lia. rename v into u12.
destruct OUT; simpl in H0. lia. rename v into u13.
destruct OUT; simpl in H0. lia. rename v into u14.
destruct OUT; simpl in H0. lia. rename v into u15.
destruct OUT; simpl in H0. lia. rename v into u16.
destruct OUT; simpl in H0. lia. rename v into u17.
destruct OUT; simpl in H0. lia. rename v into u18.
destruct OUT; simpl in H0. lia. rename v into u19.
destruct OUT; simpl in H0. lia. rename v into u20.
destruct OUT; simpl in H0. lia. rename v into u21.
destruct OUT; simpl in H0. lia. rename v into u22.
destruct OUT; simpl in H0. lia. rename v into u23.
destruct OUT; simpl in H0. lia. rename v into u24.
destruct OUT; simpl in H0. lia. rename v into u25.
destruct OUT; simpl in H0. lia. rename v into u26.
destruct OUT; simpl in H0. lia. rename v into u27.
destruct OUT; simpl in H0. lia. rename v into u28.
destruct OUT; simpl in H0. lia. rename v into u29.
destruct OUT; simpl in H0. lia. rename v into u30.
destruct OUT; simpl in H0. lia. rename v into u31.
destruct OUT; simpl in H0. 2: lia. clear H0. simpl. reflexivity. lia. lia.
Qed.

Definition HTrue_inv intsums xs ys:Prop:=
Zlength intsums = 16 /\
        (forall j, 0 <= j < 16 ->
           exists xj, exists yj,
           Znth j (map Vint xs) = Vint xj /\
           Znth j (map Vint ys) = Vint yj /\
           Znth j (map Vint intsums) = Vint (Int.add yj xj)).

Lemma HTrue_inv_char l xs ys: Zlength xs = 16 -> Zlength ys=16 ->
      HTrue_inv l xs ys -> Some l = sumlist xs ys.
Proof. rewrite sumlist_symm. intros LX LY [H L].
 destruct (listD16 _ LX) as
  [x0 [x1 [x2 [x3 [x4 [x5 [x6 [x7 [x8 [x9 [x10 [x11 [x12 [x13 [x14 [x15 A1]]]]]]]]]]]]]]]].
 destruct (listD16 _ LY) as
  [y0 [y1 [y2 [y3 [y4 [y5 [y6 [y7 [y8 [y9 [y10 [y11 [y12 [y13 [y14 [y15 B1]]]]]]]]]]]]]]]].
 destruct (listD16 _ H) as
  [z0 [z1 [z2 [z3 [z4 [z5 [z6 [z7 [z8 [z9 [z10 [z11 [z12 [z13 [z14 [z15 C1]]]]]]]]]]]]]]]].
subst xs ys l.
unfold Znth in L.
destruct (L 0) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 1) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 2) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 3) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 4) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 5) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 6) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 7) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 8) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 9) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 10) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 11) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 12) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 13) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 14) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q.
destruct (L 15) as [x [y [X [Y Q]]]]; try lia.
simpl in X, Y, Q. symmetry in X, Y; inv X; inv Y; inv Q. reflexivity.
Qed.

Definition fcore_EpiloguePOST t y x w nonce out c k h OUT
  (data : SixteenByte * SixteenByte * (SixteenByte * SixteenByte)) :=
match data with ((Nonce, C), K) =>
EX xs:_, EX ys:_,
PROP (ys = prepare_data data /\ Snuffle 20 ys = Some xs)
LOCAL (lvar _t (tarray tuint 4) t;
       lvar _y (tarray tuint 16) y; lvar _x (tarray tuint 16) x;
       lvar _w (tarray tuint 16) w; temp _in nonce; temp _out out; temp _c c;
       temp _k k; temp _h (Vint (Int.repr h)))
  SEP (CoreInSEP data (nonce, c, k);
       data_at Tsh (tarray tuint 16) (map Vint ys) y;
       data_at_ Tsh (tarray tuint 4) t; data_at_ Tsh (tarray tuint 16) w;
       if Int.eq (Int.repr h) Int.zero
         then EX l:_,
          !!HFalse_inv l 16 xs ys &&
          (data_at Tsh (tarray tuchar 64) l out *
           data_at Tsh (tarray tuint 16) (map Vint xs) x)
         else EX intsums:_, !!(HTrue_inv intsums xs ys) &&
            (data_at Tsh (tarray tuchar 32)
               (hPosLoop3 4 (hPosLoop2 4 intsums C Nonce) OUT) out
             * data_at Tsh (tarray tuint 16)
                 (map Vint (hPosLoop2 4 intsums C Nonce)) x))
end.

Opaque Snuffle. Opaque hPosLoop2. Opaque hPosLoop3.

Lemma HTruePOST F t y x w nonce out c k h snuffleRes l data OUT:
      Snuffle 20 l = Some snuffleRes ->
      Int.eq (Int.repr h) Int.zero = false ->
      l = prepare_data data ->
      F |-- (data_at_ Tsh (tarray tuint 4) t * data_at_ Tsh (tarray tuint 16) w)%logic ->
      HTruePostCond F t y x w nonce out c k h snuffleRes l data OUT
|-- fcore_EpiloguePOST t y x w nonce out c k h OUT data.
Proof. intros.
unfold HTruePostCond, fcore_EpiloguePOST.
destruct data as [[? ?] [? ?]].
Exists snuffleRes l.
rewrite H0, <- H1, H. clear - H2.
Time normalize. (*1.4*)
 Exists intsums.
 go_lowerx. (* must do this explicitly because it's not an ENTAIL *)
 Time entailer!; auto. (*6.8*)
Qed.

Lemma HFalsePOST F t y x w nonce out c k h snuffleRes l data OUT:
      Snuffle 20 l = Some snuffleRes ->
      Int.eq (Int.repr h) Int.zero = true ->
      l = prepare_data data ->
      F |-- ((CoreInSEP data (nonce, c,k) * data_at_ Tsh (tarray tuint 4) t *
             data_at_ Tsh (tarray tuint 16) w))%logic ->
      HFalsePostCond F t y x w nonce out c k h snuffleRes l
     |-- fcore_EpiloguePOST t y x w nonce out c k h OUT data.
Proof. intros.
unfold HFalsePostCond, fcore_EpiloguePOST.
destruct data as [[? ?] [? ?]].
Exists snuffleRes l.
rewrite H0, <- H1, H. clear - H2.
go_lowerx. (* must do this explicitly because it's not an ENTAIL *)
Time entailer!. (*3.4*)
Intros intsums. Exists intsums; entailer!. apply H2.
Qed.

Opaque HTruePostCond. Opaque HFalsePostCond.

Lemma core_spec_ok: semax_body SalsaVarSpecs SalsaFunSpecs
       f_core core_spec.
Proof. unfold core_spec, f_core_POST.
start_function. abbreviate_semax.
rename v_t into t.
rename v_y into y.
rename v_x into x.
rename v_w into w.
freeze [0;1;2;3;4] FR1.
Time assert_PROP (Zlength OUT = Z.max 0 (OutLen h)) as ZL_OUT by entailer!.
rewrite Z.max_r in ZL_OUT.
2:{ unfold OutLen. simple_if_tac; lia. }
(* apply semax_seq with (Q:=fcore_EpiloguePOST t y x w nonce out c k h OUT data). *)
thaw FR1. freeze [0;1;3;5] FR2.
eapply semax_seq.
apply (f_core_loop1 Espec (FRZL FR2) c k h nonce out w x y t data); trivial.
(*/FOR(i,16) y[i] = x[i]*)
Intros xInit. red in H. rename H into XInit.
thaw FR2. freeze [0;2;3;5] FR3.
subst MORE_COMMANDS; unfold abbreviate.
eapply semax_seq.
apply (f_core_loop2 _ (FRZL FR3) c k h nonce out w x y t data); trivial.
    (* mkConciseDelta SalsaVarSpecs SalsaFunSpecs f_core Delta.*)

    Intros YS.
    destruct H as [? [? [? [? [? [? [? [? ?]]]]]]]].
    assert (L31: Zlength (x3 ++ x1) = 16) by (rewrite H1; reflexivity).
    rewrite Zlength_app, H3 in L31. destruct x1. 2:{ rewrite Zlength_cons', Z.add_assoc in L31. specialize (Zlength_nonneg x1); intros; lia. }
    rewrite app_nil_r in *. clear L31; subst x0. clear H3 H1 x3.
    assert (LX: Zlength xInit = 16).
      rewrite XInit. rewrite upd_upto_Zlength; trivial. simpl; lia.
    rewrite <- H0, Zlength_app, H2 in LX. destruct x2. 2:{ rewrite Zlength_cons', Z.add_assoc in LX. specialize (Zlength_nonneg x2); intros; lia. }
    rewrite app_nil_r in *. clear LX; subst YS. rename H2 into xInit_Zlength.

    rewrite upd_upto_char in XInit. 2: reflexivity.
    destruct data as [[Nonce C] [Key1 Key2]].
    destruct Nonce as [[[N1 N2] N3] N4].
    destruct C as [[[C1 C2] C3] C4].
    destruct Key1 as [[[K1 K2] K3] K4].
    destruct Key2 as [[[L1 L2] L3] L4].

    thaw FR3. subst xInit.
    freeze [2;3;5] FR4.
    remember [C1; K1; K2; K3; K4; C2; N1; N2; N3; N4; C3; L1; L2; L3; L4; C4] as xInit.
    forward_seq.
    eapply semax_post_flipped'.
    apply (f_core_loop3 _ (FRZL FR4) c k h nonce out w x y t (map littleendian xInit)).
    intros. apply andp_left2. apply derives_refl.
    Intros snuffleRes. rename H into RES.

    freeze [0;1;2;3] FR5.
    Time forward_if (fcore_EpiloguePOST t y x w nonce out c k h OUT
               ((N1, N2, N3, N4), (C1, C2, C3, C4), ((K1, K2, K3, K4), (L1, L2, L3, L4)))). (*4.8*)
    - (*apply typed_true_tint_Vint in H.*)
      assert (HOUTLEN: OutLen h = 32). unfold OutLen. rewrite Int.eq_false; trivial.
      thaw FR5. thaw FR4. rewrite HOUTLEN in *. freeze [3;4] FR6.
      force_sequential.
      eapply semax_post_flipped'.
      eapply (verif_fcore_epilogue_htrue Espec (FRZL FR6) t y x w nonce out c k h
                     OUT snuffleRes (map littleendian xInit)
                     (((N1, N2, N3, N4), (C1, C2, C3, C4)), (K1, K2, K3, K4, (L1, L2, L3, L4)))).
        apply andp_left2.
        apply HTruePOST; trivial. rewrite Int.eq_false; trivial.
        subst xInit; reflexivity.
        thaw FR6. cancel.
    - (*unfold typed_false in H. simpl in H. inversion H. apply negb_false_iff in H1. clear H.*)
      assert (HOUTLEN: OutLen h = 64). unfold OutLen; rewrite H; trivial.
      thaw FR5. thaw FR4. rewrite HOUTLEN in *. freeze [1;3;4] FR6.
      drop_LOCAL 0%nat.
      eapply semax_post_flipped'.
      apply (verif_fcore_epilogue_hfalse Espec (FRZL FR6)
            t y x w nonce out c k h OUT).
      apply andp_left2.
        apply HFalsePOST; trivial. rewrite H. trivial. subst; trivial.
        thaw FR6. cancel.
-
   clear - ZL_OUT. clearbody Delta_specs.
   set (data :=(N1, N2, N3, N4, (C1, C2, C3, C4),
  (K1, K2, K3, K4, (L1, L2, L3, L4)))).
  change (N1, N2, N3, N4, (C1, C2, C3, C4),
             (K1, K2, K3, K4, (L1, L2, L3, L4))) with data.
   destruct data as [[Nonce C] [Key1 Key2]].
   unfold fcore_EpiloguePOST.
    Intros snuffleRes ys. subst ys.
    destruct (Int.eq (Int.repr h) Int.zero) eqn:hh.
 + Intros l. Exists l. rename H into H99. entailer!.
    rewrite Zlength_map in H1.
    specialize (Snuffle_length _ _ _  H0 (prepare_data_length _ )); intros L.
    unfold fcore_result.
    unfold Snuffle20, bind. rewrite H0; clear H0.
        destruct (HFalse_inv16_char _ _ _ H99) as [sums [SUMS1 SUMS2]].
          rewrite Zlength_correct, L; reflexivity. trivial.
        rewrite <- SUMS1, <- SUMS2. rewrite hh. auto.
        unfold fcorePOST_SEP, OutLen.
        rewrite hh. auto.
  +  Intros intsums.   unfold fcorePOST_SEP.
      Exists (hPosLoop3 4 (hPosLoop2 4 intsums C Nonce) OUT).
      rename H into H99. entailer!.    unfold fcore_result.
    unfold Snuffle20, bind. rewrite H0.
      apply HTrue_inv_char in H99. rewrite <- H99.
      rewrite hh.
    rewrite Zlength_map in H1.
    specialize (Snuffle_length _ _ _  H0 (prepare_data_length _ )); intros L.
      destruct Nonce as [[[? ?] ?] ?]. destruct C as [[[? ?] ?] ?].
     auto.
      rewrite <- TP with (OUT:=OUT).
      unfold fcorePOST_SEP, OutLen. auto.
       rewrite Zlength_correct, (sumlist_length _ _ _ H99), prepare_data_length; trivial.
        rewrite ZL_OUT. unfold OutLen; rewrite hh. trivial.
    specialize (Snuffle_length _ _ _  H0 (prepare_data_length _ )); intros L.
        rewrite Zlength_correct, L; reflexivity.
        rewrite Zlength_correct, prepare_data_length; reflexivity.
     unfold OutLen. rewrite hh. auto.
Time Qed. (*20 versus 58*)


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

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
(* Revised December 2002 *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*  Z_to_Q.v                                                                *)
(*                                                                          *)
(*  Details of the coercion between integers and rationals                  *)
(*                                                                          *)
(*                                                                          *)
(*  Samuel Boutin                                                           *)
(*  Coq V5.10                                                               *)
(*  June  1995                                                              *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)
(*                              Z_to_Q.v                                    *)
(****************************************************************************)

Require Import quotient.
Require Import subset.
Require Import HS.
Require Import AC.
Require Import intnumbers.
Require Import rational_defs.

Section Integers_are_Rationals.

Require Import productSyntax.

Open Scope INT_scope.

Lemma one_is_a_denominator : 1 <= 1.

red in |- *; simpl in |- *.
rewrite (Reduce_prop Z_typ Z_rel).
red in |- *; simpl in |- *.
rewrite (Reduce_prop Z_typ Z_rel).
red in |- *; simpl in |- *.
apply le_n; auto.
Qed.

Definition fromZ_to_Q (x : Z) : Q := |(x, %+ (1) one_is_a_denominator) |q.

End Integers_are_Rationals.
(*
Grammar rational final :=
[ "{" integer:expr($c) "}" ] -> [<<(fromZ_to_Q $c)>>].
*)