Require Import Coqlib.
Require Import STS.
Require Import Behavior.
Require Import ModSem.
Require Import Skeleton.
Require Import PCM.
Require Import Any.
Require Import HoareDef OpenDef STB SimModSem.

Require Import Relation_Definitions.
Require Import Relation_Operators.
Require Import RelationPairs.
From ExtLib Require Import
     Data.Map.FMapAList.
Require Import Red IRed.
Require Import ProofMode Invariant.
Require Import HTactics.

Set Implicit Arguments.

Ltac ired_l := try (prw _red_gen 2 1 0).
Ltac ired_r := try (prw _red_gen 1 1 0).

Ltac ired_both := ired_l; ired_r.

Section SIM.
  Context `{Σ: GRA.t}.
  Variable world: Type.
  Variable le: relation world.
  Variable I: world -> Any.t -> Any.t -> iProp.

  Variable mn: mname.
  Variable stb: gname -> option fspec.
  Variable o: ord.

  Definition option_Ord_lt (o0 o1: option Ord.t): Prop :=
    match o0, o1 with
    | None, Some _ => True
    | Some o0, Some o1 => Ord.lt o0 o1
    | _, _ => False
    end.

  Lemma option_Ord_lt_well_founded: well_founded option_Ord_lt.
  Proof.
    ii. destruct a.
    { induction (Ord.lt_well_founded t). econs.
      i. destruct y; ss.
      { eapply H0; eauto. }
      { econs. ii. destruct y; ss. }
    }
    { econs; ii. destruct y; ss. }
  Qed.

  Definition option_Ord_le (o0 o1: option Ord.t): Prop :=
    match o0, o1 with
    | None, _ => True
    | Some o0, Some o1 => Ord.le o0 o1
    | _, _ => False
    end.

  Global Program Instance option_Ord_le_PreOrder: PreOrder option_Ord_le.
  Next Obligation.
  Proof.
    ii. destruct x; ss. refl.
  Qed.
  Next Obligation.
  Proof.
    ii. destruct x, y, z; ss. etrans; eauto.
  Qed.

  Lemma option_Ord_lt_le o0 o1
        (LT: option_Ord_lt o0 o1)
    :
      option_Ord_le o0 o1.
  Proof.
    destruct o0, o1; ss. apply Ord.lt_le; auto.
  Qed.

  Lemma option_Ord_lt_le_lt o0 o1 o2
        (LT: option_Ord_lt o0 o1)
        (LE: option_Ord_le o1 o2)
    :
      option_Ord_lt o0 o2.
  Proof.
    destruct o0, o1, o2; ss. eapply Ord.lt_le_lt; eauto.
  Qed.

  Lemma option_Ord_le_lt_lt o0 o1 o2
        (LE: option_Ord_le o0 o1)
        (LT: option_Ord_lt o1 o2)
    :
      option_Ord_lt o0 o2.
  Proof.
    destruct o0, o1, o2; ss. eapply Ord.le_lt_lt; eauto.
  Qed.

  Definition inv_with w0 st_src st_tgt: iProp :=
    (∃ w1, I w1 st_src st_tgt ** ⌜le w0 w1⌝)%I.

  Lemma inv_with_current `{PreOrder _ le} w0 st_src st_tgt
    :
      bi_entails (I w0 st_src st_tgt) (inv_with w0 st_src st_tgt).
  Proof.
    unfold inv_with. iIntros "H". iExists w0. iSplit; auto.
  Qed.

  Lemma inv_with_le `{PreOrder _ le} w0 w1 st_src st_tgt
        (LE: le w0 w1)
    :
      bi_entails (inv_with w1 st_src st_tgt) (inv_with w0 st_src st_tgt).
  Proof.
    unfold inv_with. iIntros "H". iDestruct "H" as (w2) "[H0 %]".
    iExists w2. iSplit; auto. iPureIntro. etrans; eauto.
  Qed.

  Inductive _hsim
            (hsim: forall R_src R_tgt
                          (Q: Any.t -> Any.t -> R_src -> R_tgt -> iProp)
                          (ctx: Σ),
                option Ord.t -> bool -> bool -> Any.t * itree hEs R_src -> Any.t * itree Es R_tgt -> Prop)
            {R_src R_tgt}
            (Q: Any.t -> Any.t -> R_src -> R_tgt -> iProp)
            (ctx: Σ)
    : option Ord.t -> bool -> bool -> Any.t * itree hEs R_src -> Any.t * itree Es R_tgt -> Prop :=
  | hsim_ret
      v_src v_tgt
      st_src st_tgt
      fuel f_src f_tgt
      (RET: current_iProp ctx (Q st_src st_tgt v_src v_tgt))
    :
      _hsim hsim Q ctx fuel f_src f_tgt (st_src, (Ret v_src)) (st_tgt, (Ret v_tgt))
  | hsim_call
      fsp (x: fsp.(meta)) w0 FR
      fn arg_src arg_tgt
      st_src0 st_tgt0 ktr_src ktr_tgt
      fuel f_src f_tgt
      (SPEC: stb fn = Some fsp)
      (PRE: current_iProp ctx (FR ** inv_with w0 st_src0 st_tgt0 ** fsp.(precond) (Some mn) x arg_src arg_tgt))
      (MEASURE: o = ord_top)
      (NPURE: fsp.(measure) x = ord_top)
      (POST: forall ctx1 st_src1 st_tgt1 ret_src ret_tgt
                    (ACC: current_iProp ctx1 (FR ** inv_with w0 st_src1 st_tgt1 ** fsp.(postcond) (Some mn) x ret_src ret_tgt)),
          hsim _ _ Q ctx1 None true true (st_src1, ktr_src ret_src) (st_tgt1, ktr_tgt ret_tgt))
    :
      _hsim hsim Q ctx fuel f_src f_tgt (st_src0, trigger (Call fn arg_src) >>= ktr_src) (st_tgt0, trigger (Call fn arg_tgt) >>= ktr_tgt)
  | hsim_apc_start
      fuel1
      st_src st_tgt ktr_src itr_tgt
      fuel f_src f_tgt
      (SIM: _hsim hsim Q ctx (fuel1) true f_tgt (st_src, ktr_src tt) (st_tgt, itr_tgt))
    :
      _hsim hsim Q ctx fuel f_src f_tgt (st_src, trigger (hAPC) >>= ktr_src) (st_tgt, itr_tgt)
  | hsim_apc_step
      fsp (x: fsp.(meta)) w0 FR arg_src
      fn arg_tgt
      st_src0 st_tgt0 itr_src ktr_tgt
      fuel0 f_src f_tgt
      (SPEC: stb fn = Some fsp)
      (PRE: current_iProp ctx (FR ** inv_with w0 st_src0 st_tgt0 ** fsp.(precond) (Some mn) x arg_src arg_tgt))
      (MEASURE: ord_lt (fsp.(measure) x) o)
      (PURE: is_pure (fsp.(measure) x))
      (POST: exists fuel1,
          (<<FUEL: Ord.lt fuel1 fuel0>>) /\
          (<<SIM: forall ctx1 st_src1 st_tgt1 ret_src ret_tgt
                         (ACC: current_iProp ctx1 (FR ** inv_with w0 st_src1 st_tgt1 ** fsp.(postcond) (Some mn) x ret_src ret_tgt)),
              hsim _ _ Q ctx1 (Some fuel1) true true (st_src1, itr_src) (st_tgt1, ktr_tgt ret_tgt)>>))
    :
      _hsim hsim Q ctx (Some fuel0) f_src f_tgt (st_src0, itr_src) (st_tgt0, trigger (Call fn arg_tgt) >>= ktr_tgt)
  | hsim_syscall
      fn arg rvs
      st_src st_tgt ktr_src ktr_tgt
      fuel f_src f_tgt
      (POST: forall ret,
          hsim _ _ Q ctx None true true (st_src, ktr_src ret) (st_tgt, ktr_tgt ret))
    :
      _hsim hsim Q ctx fuel f_src f_tgt (st_src, trigger (Syscall fn arg rvs) >>= ktr_src) (st_tgt, trigger (Syscall fn arg rvs) >>= ktr_tgt)
  | hsim_tau_src
      st_src st_tgt itr_src itr_tgt
      fuel f_src f_tgt
      (SIM: _hsim hsim Q ctx None true f_tgt (st_src, itr_src) (st_tgt, itr_tgt))
    :
      _hsim hsim Q ctx fuel f_src f_tgt (st_src, tau;; itr_src) (st_tgt, itr_tgt)
  | hsim_tau_tgt
      st_src st_tgt itr_src itr_tgt
      fuel f_src f_tgt
      (SIM: _hsim hsim Q ctx fuel f_src true (st_src, itr_src) (st_tgt, itr_tgt))
    :
      _hsim hsim Q ctx fuel f_src f_tgt (st_src, itr_src) (st_tgt, tau;; itr_tgt)
  | hsim_choose_src
      X
      st_src st_tgt ktr_src itr_tgt
      fuel f_src f_tgt
      (SIM: exists x, _hsim hsim Q ctx None true f_tgt (st_src, ktr_src x) (st_tgt, itr_tgt))
    :
      _hsim hsim Q ctx fuel f_src f_tgt (st_src, trigger (Choose X) >>= ktr_src) (st_tgt, itr_tgt)
  | hsim_choose_tgt
      X
      st_src st_tgt itr_src ktr_tgt
      fuel f_src f_tgt
      (SIM: forall x, _hsim hsim Q ctx fuel f_src true (st_src, itr_src) (st_tgt, ktr_tgt x))
    :
      _hsim hsim Q ctx fuel f_src f_tgt (st_src, itr_src) (st_tgt, trigger (Choose X) >>= ktr_tgt)
  | hsim_take_src
      X
      st_src st_tgt ktr_src itr_tgt
      fuel f_src f_tgt
      (SIM: forall x, _hsim hsim Q ctx None true f_tgt (st_src, ktr_src x) (st_tgt, itr_tgt))
    :
      _hsim hsim Q ctx fuel f_src f_tgt (st_src, trigger (Take X) >>= ktr_src) (st_tgt, itr_tgt)
  | hsim_take_tgt
      X
      st_src st_tgt itr_src ktr_tgt
      fuel f_src f_tgt
      (SIM: exists x, _hsim hsim Q ctx fuel f_src true (st_src, itr_src) (st_tgt, ktr_tgt x))
    :
      _hsim hsim Q ctx fuel f_src f_tgt (st_src, itr_src) (st_tgt, trigger (Take X) >>= ktr_tgt)
  | hsim_pput_src
      st_src1
      st_src0 st_tgt ktr_src itr_tgt
      fuel f_src f_tgt
      (SIM: _hsim hsim Q ctx None true f_tgt (st_src1, ktr_src tt) (st_tgt, itr_tgt))
    :
      _hsim hsim Q ctx fuel f_src f_tgt (st_src0, trigger (PPut st_src1) >>= ktr_src) (st_tgt, itr_tgt)
  | hsim_pput_tgt
      st_tgt1
      st_src st_tgt0 itr_src ktr_tgt
      fuel f_src f_tgt
      (SIM: _hsim hsim Q ctx fuel f_src true (st_src, itr_src) (st_tgt1, ktr_tgt tt))
    :
      _hsim hsim Q ctx fuel f_src f_tgt (st_src, itr_src) (st_tgt0, trigger (PPut st_tgt1) >>= ktr_tgt)
  | hsim_pget_src
      st_src st_tgt ktr_src itr_tgt
      fuel f_src f_tgt
      (SIM: _hsim hsim Q ctx None true f_tgt (st_src, ktr_src st_src) (st_tgt, itr_tgt))
    :
      _hsim hsim Q ctx fuel f_src f_tgt (st_src, trigger (PGet) >>= ktr_src) (st_tgt, itr_tgt)
  | hsim_pget_tgt
      st_src st_tgt itr_src ktr_tgt
      fuel f_src f_tgt
      (SIM: _hsim hsim Q ctx fuel f_src true (st_src, itr_src) (st_tgt, ktr_tgt st_tgt))
    :
      _hsim hsim Q ctx fuel f_src f_tgt (st_src, itr_src) (st_tgt, trigger (PGet) >>= ktr_tgt)
  | hsim_progress
      st_src st_tgt itr_src itr_tgt
      fuel
      (SIM: hsim _ _ Q ctx fuel false false (st_src, itr_src) (st_tgt, itr_tgt))
    :
      _hsim hsim Q ctx fuel true true (st_src, itr_src) (st_tgt, itr_tgt)
  .

  Lemma _hsim_ind2
        (hsim: forall R_src R_tgt
                      (Q: Any.t -> Any.t -> R_src -> R_tgt -> iProp)
                      (ctx: Σ),
            option Ord.t -> bool -> bool -> Any.t * itree hEs R_src -> Any.t * itree Es R_tgt -> Prop)
        R_src R_tgt Q ctx
        (P: option Ord.t -> bool -> bool -> Any.t * itree hEs R_src -> Any.t * itree Es R_tgt -> Prop)
        (RET: forall
            v_src v_tgt
            st_src st_tgt
            fuel f_src f_tgt
            (RET: current_iProp ctx (Q st_src st_tgt v_src v_tgt)),
            P fuel f_src f_tgt (st_src, (Ret v_src)) (st_tgt, (Ret v_tgt)))
        (CALL: forall
            fsp (x: fsp.(meta)) w0 FR
            fn arg_src arg_tgt
            st_src0 st_tgt0 ktr_src ktr_tgt
            fuel f_src f_tgt
            (SPEC: stb fn = Some fsp)
            (PRE: current_iProp ctx (FR ** inv_with w0 st_src0 st_tgt0 ** fsp.(precond) (Some mn) x arg_src arg_tgt))
            (MEASURE: o = ord_top)
            (NPURE: fsp.(measure) x = ord_top)
            (POST: forall ctx1 st_src1 st_tgt1 ret_src ret_tgt
                          (ACC: current_iProp ctx1 (FR ** inv_with w0 st_src1 st_tgt1 ** fsp.(postcond) (Some mn) x ret_src ret_tgt)),
                hsim _ _ Q ctx1 None true true (st_src1, ktr_src ret_src) (st_tgt1, ktr_tgt ret_tgt)),
            P fuel f_src f_tgt (st_src0, trigger (Call fn arg_src) >>= ktr_src) (st_tgt0, trigger (Call fn arg_tgt) >>= ktr_tgt))
        (APCSTART: forall
            fuel1
            st_src st_tgt ktr_src itr_tgt
            fuel f_src f_tgt
            (SIM: _hsim hsim Q ctx (fuel1) true f_tgt (st_src, ktr_src tt) (st_tgt, itr_tgt))
            (IH: P (fuel1) true f_tgt (st_src, ktr_src tt) (st_tgt, itr_tgt)),
            P fuel f_src f_tgt (st_src, trigger (hAPC) >>= ktr_src) (st_tgt, itr_tgt))
        (APCSTEP: forall
            fsp (x: fsp.(meta)) w0 FR arg_src
            fn arg_tgt
            st_src0 st_tgt0 itr_src ktr_tgt
            fuel0 f_src f_tgt
            (SPEC: stb fn = Some fsp)
            (PRE: current_iProp ctx (FR ** inv_with w0 st_src0 st_tgt0 ** fsp.(precond) (Some mn) x arg_src arg_tgt))
            (MEASURE: ord_lt (fsp.(measure) x) o)
            (PURE: is_pure (fsp.(measure) x))
            (POST: exists fuel1,
                (<<FUEL: Ord.lt fuel1 fuel0>>) /\
                (<<SIM: forall ctx1 st_src1 st_tgt1 ret_src ret_tgt
                               (ACC: current_iProp ctx1 (FR ** inv_with w0 st_src1 st_tgt1 ** fsp.(postcond) (Some mn) x ret_src ret_tgt)),
                    hsim _ _ Q ctx1 (Some fuel1) true true (st_src1, itr_src) (st_tgt1, ktr_tgt ret_tgt)>>)),
            P (Some fuel0) f_src f_tgt (st_src0, itr_src) (st_tgt0, trigger (Call fn arg_tgt) >>= ktr_tgt))
        (SYSCALL: forall
            fn arg rvs
            st_src st_tgt ktr_src ktr_tgt
            fuel f_src f_tgt
            (POST: forall ret,
                hsim _ _ Q ctx None true true (st_src, ktr_src ret) (st_tgt, ktr_tgt ret)),
            P fuel f_src f_tgt (st_src, trigger (Syscall fn arg rvs) >>= ktr_src) (st_tgt, trigger (Syscall fn arg rvs) >>= ktr_tgt))
        (TAUSRC: forall
            st_src st_tgt itr_src itr_tgt
            fuel f_src f_tgt
            (SIM: _hsim hsim Q ctx None true f_tgt (st_src, itr_src) (st_tgt, itr_tgt))
            (IH: P None true f_tgt (st_src, itr_src) (st_tgt, itr_tgt))
          ,
            P fuel f_src f_tgt (st_src, tau;; itr_src) (st_tgt, itr_tgt))
        (TAUTGT: forall
            st_src st_tgt itr_src itr_tgt
            fuel f_src f_tgt
            (SIM: _hsim hsim Q ctx fuel f_src true (st_src, itr_src) (st_tgt, itr_tgt))
            (IH: P fuel f_src true (st_src, itr_src) (st_tgt, itr_tgt)),
            P fuel f_src f_tgt (st_src, itr_src) (st_tgt, tau;; itr_tgt))
        (CHOOSESRC: forall
            X
            st_src st_tgt ktr_src itr_tgt
            fuel f_src f_tgt
            (SIM: exists x, (<<SIM: _hsim hsim Q ctx None true f_tgt (st_src, ktr_src x) (st_tgt, itr_tgt)>>) /\ (<<IH: P None true f_tgt (st_src, ktr_src x) (st_tgt, itr_tgt)>>)),
            P fuel f_src f_tgt (st_src, trigger (Choose X) >>= ktr_src) (st_tgt, itr_tgt))
        (CHOOSETGT: forall
            X
            st_src st_tgt itr_src ktr_tgt
            fuel f_src f_tgt
            (SIM: forall x, (<<SIM: _hsim hsim Q ctx fuel f_src true (st_src, itr_src) (st_tgt, ktr_tgt x)>>) /\ (<<IH: P fuel f_src true (st_src, itr_src) (st_tgt, ktr_tgt x)>>)),
            P fuel f_src f_tgt (st_src, itr_src) (st_tgt, trigger (Choose X) >>= ktr_tgt))
        (TAKESRC: forall
            X
            st_src st_tgt ktr_src itr_tgt
            fuel f_src f_tgt
            (SIM: forall x, (<<SIM: _hsim hsim Q ctx None true f_tgt (st_src, ktr_src x) (st_tgt, itr_tgt)>>) /\ (<<IH: P None true f_tgt (st_src, ktr_src x) (st_tgt, itr_tgt)>>)),
            P fuel f_src f_tgt (st_src, trigger (Take X) >>= ktr_src) (st_tgt, itr_tgt))
        (TAKETGT: forall
            X
            st_src st_tgt itr_src ktr_tgt
            fuel f_src f_tgt
            (SIM: exists x, (<<SIM: _hsim hsim Q ctx fuel f_src true (st_src, itr_src) (st_tgt, ktr_tgt x)>>) /\ (<<IH: P fuel f_src true (st_src, itr_src) (st_tgt, ktr_tgt x)>>)),
            P fuel f_src f_tgt (st_src, itr_src) (st_tgt, trigger (Take X) >>= ktr_tgt))
        (PPUTSRC: forall
            st_src1
            st_src0 st_tgt ktr_src itr_tgt
            fuel f_src f_tgt
            (SIM: _hsim hsim Q ctx None true f_tgt (st_src1, ktr_src tt) (st_tgt, itr_tgt))
            (IH: P None true f_tgt (st_src1, ktr_src tt) (st_tgt, itr_tgt)),
            P fuel f_src f_tgt (st_src0, trigger (PPut st_src1) >>= ktr_src) (st_tgt, itr_tgt))
        (PPUTTGT: forall
            st_tgt1
            st_src st_tgt0 itr_src ktr_tgt
            fuel f_src f_tgt
            (SIM: _hsim hsim Q ctx fuel f_src true (st_src, itr_src) (st_tgt1, ktr_tgt tt))
            (IH: P fuel f_src true (st_src, itr_src) (st_tgt1, ktr_tgt tt)),
            P fuel f_src f_tgt (st_src, itr_src) (st_tgt0, trigger (PPut st_tgt1) >>= ktr_tgt))
        (PGETSRC: forall
            st_src st_tgt ktr_src itr_tgt
            fuel f_src f_tgt
            (SIM: _hsim hsim Q ctx None true f_tgt (st_src, ktr_src st_src) (st_tgt, itr_tgt))
            (IH: P None true f_tgt (st_src, ktr_src st_src) (st_tgt, itr_tgt)),
            P fuel f_src f_tgt (st_src, trigger (PGet) >>= ktr_src) (st_tgt, itr_tgt))
        (PGETTGT: forall
            st_src st_tgt itr_src ktr_tgt
            fuel f_src f_tgt
            (SIM: _hsim hsim Q ctx fuel f_src true (st_src, itr_src) (st_tgt, ktr_tgt st_tgt))
            (IH: P fuel f_src true (st_src, itr_src) (st_tgt, ktr_tgt st_tgt)),
            P fuel f_src f_tgt (st_src, itr_src) (st_tgt, trigger (PGet) >>= ktr_tgt))
        (PROGRESS: forall
            st_src st_tgt itr_src itr_tgt
            fuel
            (SIM: hsim _ _ Q ctx fuel false false (st_src, itr_src) (st_tgt, itr_tgt)),
            P fuel true true (st_src, itr_src) (st_tgt, itr_tgt))
    :
      forall fuel f_src f_tgt st_src st_tgt
             (SIM: @_hsim hsim _ _ Q ctx fuel f_src f_tgt st_src st_tgt),
        P fuel f_src f_tgt st_src st_tgt.
  Proof.
    fix IH 6. i. inv SIM.
    { eapply RET; eauto. }
    { eapply CALL; eauto. }
    { eapply APCSTART; eauto. }
    { des. eapply APCSTEP; eauto. }
    { eapply SYSCALL; eauto. }
    { eapply TAUSRC; eauto. }
    { eapply TAUTGT; eauto. }
    { des. eapply CHOOSESRC; eauto. }
    { eapply CHOOSETGT; eauto. }
    { eapply TAKESRC; eauto. }
    { des. eapply TAKETGT; eauto. }
    { eapply PPUTSRC; eauto. }
    { eapply PPUTTGT; eauto. }
    { eapply PGETSRC; eauto. }
    { eapply PGETTGT; eauto. }
    { eapply PROGRESS; eauto. }
  Qed.

  Definition hsim := paco9 _hsim bot9.
  Arguments hsim [_ _] _ _ _ _ _ _ _.

  Lemma _hsim_mon: monotone9 _hsim.
  Proof.
    ii. induction IN using _hsim_ind2.
    { econs 1; eauto. }
    { econs 2; eauto. }
    { econs 3; eauto. }
    { des. econs 4; eauto. esplits; eauto. }
    { econs 5; eauto. }
    { econs 6; eauto. }
    { econs 7; eauto. }
    { econs 8; eauto. des. esplits; eauto. }
    { econs 9; eauto. i. hexploit SIM; eauto. i. des. eauto. }
    { econs 10; eauto. i. hexploit SIM; eauto. i. des. eauto. }
    { econs 11; eauto. des. esplits; eauto. }
    { econs 12; eauto. }
    { econs 13; eauto. }
    { econs 14; eauto. }
    { econs 15; eauto. }
    { econs 16; eauto. }
  Qed.
  Hint Resolve _hsim_mon: paco.

  Lemma hsim_ind
        R_src R_tgt Q ctx
        (P: option Ord.t -> bool -> bool -> Any.t * itree hEs R_src -> Any.t * itree Es R_tgt -> Prop)
        (RET: forall
            v_src v_tgt
            st_src st_tgt
            fuel f_src f_tgt
            (RET: current_iProp ctx (Q st_src st_tgt v_src v_tgt)),
            P fuel f_src f_tgt (st_src, (Ret v_src)) (st_tgt, (Ret v_tgt)))
        (CALL: forall
            fsp (x: fsp.(meta)) w0 FR
            fn arg_src arg_tgt
            st_src0 st_tgt0 ktr_src ktr_tgt
            fuel f_src f_tgt
            (SPEC: stb fn = Some fsp)
            (PRE: current_iProp ctx (FR ** inv_with w0 st_src0 st_tgt0 ** fsp.(precond) (Some mn) x arg_src arg_tgt))
            (MEASURE: o = ord_top)
            (NPURE: fsp.(measure) x = ord_top)
            (POST: forall ctx1 st_src1 st_tgt1 ret_src ret_tgt
                          (ACC: current_iProp ctx1 (FR ** inv_with w0 st_src1 st_tgt1 ** fsp.(postcond) (Some mn) x ret_src ret_tgt)),
                hsim Q ctx1 None true true (st_src1, ktr_src ret_src) (st_tgt1, ktr_tgt ret_tgt)),
            P fuel f_src f_tgt (st_src0, trigger (Call fn arg_src) >>= ktr_src) (st_tgt0, trigger (Call fn arg_tgt) >>= ktr_tgt))
        (APCSTART: forall
            fuel1
            st_src st_tgt ktr_src itr_tgt
            fuel f_src f_tgt
            (SIM: hsim Q ctx (fuel1) true f_tgt (st_src, ktr_src tt) (st_tgt, itr_tgt))
            (IH: P (fuel1) true f_tgt (st_src, ktr_src tt) (st_tgt, itr_tgt)),
            P fuel f_src f_tgt (st_src, trigger (hAPC) >>= ktr_src) (st_tgt, itr_tgt))
        (APCSTEP: forall
            fsp (x: fsp.(meta)) w0 FR arg_src
            fn arg_tgt
            st_src0 st_tgt0 itr_src ktr_tgt
            fuel0 f_src f_tgt
            (SPEC: stb fn = Some fsp)
            (PRE: current_iProp ctx (FR ** inv_with w0 st_src0 st_tgt0 ** fsp.(precond) (Some mn) x arg_src arg_tgt))
            (MEASURE: ord_lt (fsp.(measure) x) o)
            (PURE: is_pure (fsp.(measure) x))
            (POST: exists fuel1,
                (<<FUEL: Ord.lt fuel1 fuel0>>) /\
                (<<SIM: forall ctx1 st_src1 st_tgt1 ret_src ret_tgt
                               (ACC: current_iProp ctx1 (FR ** inv_with w0 st_src1 st_tgt1 ** fsp.(postcond) (Some mn) x ret_src ret_tgt)),
                    hsim Q ctx1 (Some fuel1) true true (st_src1, itr_src) (st_tgt1, ktr_tgt ret_tgt)>>)),
            P (Some fuel0) f_src f_tgt (st_src0, itr_src) (st_tgt0, trigger (Call fn arg_tgt) >>= ktr_tgt))
        (SYSCALL: forall
            fn arg rvs
            st_src st_tgt ktr_src ktr_tgt
            fuel f_src f_tgt
            (POST: forall ret,
                hsim Q ctx None true true (st_src, ktr_src ret) (st_tgt, ktr_tgt ret)),
            P fuel f_src f_tgt (st_src, trigger (Syscall fn arg rvs) >>= ktr_src) (st_tgt, trigger (Syscall fn arg rvs) >>= ktr_tgt))
        (TAUSRC: forall
            st_src st_tgt itr_src itr_tgt
            fuel f_src f_tgt
            (SIM: hsim Q ctx None true f_tgt (st_src, itr_src) (st_tgt, itr_tgt))
            (IH: P None true f_tgt (st_src, itr_src) (st_tgt, itr_tgt))
          ,
            P fuel f_src f_tgt (st_src, tau;; itr_src) (st_tgt, itr_tgt))
        (TAUTGT: forall
            st_src st_tgt itr_src itr_tgt
            fuel f_src f_tgt
            (SIM: hsim Q ctx fuel f_src true (st_src, itr_src) (st_tgt, itr_tgt))
            (IH: P fuel f_src true (st_src, itr_src) (st_tgt, itr_tgt)),
            P fuel f_src f_tgt (st_src, itr_src) (st_tgt, tau;; itr_tgt))
        (CHOOSESRC: forall
            X
            st_src st_tgt ktr_src itr_tgt
            fuel f_src f_tgt
            (SIM: exists x, (<<SIM: hsim Q ctx None true f_tgt (st_src, ktr_src x) (st_tgt, itr_tgt)>>) /\ (<<IH: P None true f_tgt (st_src, ktr_src x) (st_tgt, itr_tgt)>>)),
            P fuel f_src f_tgt (st_src, trigger (Choose X) >>= ktr_src) (st_tgt, itr_tgt))
        (CHOOSETGT: forall
            X
            st_src st_tgt itr_src ktr_tgt
            fuel f_src f_tgt
            (SIM: forall x, (<<SIM: hsim Q ctx fuel f_src true (st_src, itr_src) (st_tgt, ktr_tgt x)>>) /\ (<<IH: P fuel f_src true (st_src, itr_src) (st_tgt, ktr_tgt x)>>)),
            P fuel f_src f_tgt (st_src, itr_src) (st_tgt, trigger (Choose X) >>= ktr_tgt))
        (TAKESRC: forall
            X
            st_src st_tgt ktr_src itr_tgt
            fuel f_src f_tgt
            (SIM: forall x, (<<SIM: hsim Q ctx None true f_tgt (st_src, ktr_src x) (st_tgt, itr_tgt)>>) /\ (<<IH: P None true f_tgt (st_src, ktr_src x) (st_tgt, itr_tgt)>>)),
            P fuel f_src f_tgt (st_src, trigger (Take X) >>= ktr_src) (st_tgt, itr_tgt))
        (TAKETGT: forall
            X
            st_src st_tgt itr_src ktr_tgt
            fuel f_src f_tgt
            (SIM: exists x, (<<SIM: hsim Q ctx fuel f_src true (st_src, itr_src) (st_tgt, ktr_tgt x)>>) /\ (<<IH: P fuel f_src true (st_src, itr_src) (st_tgt, ktr_tgt x)>>)),
            P fuel f_src f_tgt (st_src, itr_src) (st_tgt, trigger (Take X) >>= ktr_tgt))
        (PPUTSRC: forall
            st_src1
            st_src0 st_tgt ktr_src itr_tgt
            fuel f_src f_tgt
            (SIM: hsim Q ctx None true f_tgt (st_src1, ktr_src tt) (st_tgt, itr_tgt))
            (IH: P None true f_tgt (st_src1, ktr_src tt) (st_tgt, itr_tgt)),
            P fuel f_src f_tgt (st_src0, trigger (PPut st_src1) >>= ktr_src) (st_tgt, itr_tgt))
        (PPUTTGT: forall
            st_tgt1
            st_src st_tgt0 itr_src ktr_tgt
            fuel f_src f_tgt
            (SIM: hsim Q ctx fuel f_src true (st_src, itr_src) (st_tgt1, ktr_tgt tt))
            (IH: P fuel f_src true (st_src, itr_src) (st_tgt1, ktr_tgt tt)),
            P fuel f_src f_tgt (st_src, itr_src) (st_tgt0, trigger (PPut st_tgt1) >>= ktr_tgt))
        (PGETSRC: forall
            st_src st_tgt ktr_src itr_tgt
            fuel f_src f_tgt
            (SIM: hsim Q ctx None true f_tgt (st_src, ktr_src st_src) (st_tgt, itr_tgt))
            (IH: P None true f_tgt (st_src, ktr_src st_src) (st_tgt, itr_tgt)),
            P fuel f_src f_tgt (st_src, trigger (PGet) >>= ktr_src) (st_tgt, itr_tgt))
        (PGETTGT: forall
            st_src st_tgt itr_src ktr_tgt
            fuel f_src f_tgt
            (SIM: hsim Q ctx fuel f_src true (st_src, itr_src) (st_tgt, ktr_tgt st_tgt))
            (IH: P fuel f_src true (st_src, itr_src) (st_tgt, ktr_tgt st_tgt)),
            P fuel f_src f_tgt (st_src, itr_src) (st_tgt, trigger (PGet) >>= ktr_tgt))
        (PROGRESS: forall
            st_src st_tgt itr_src itr_tgt
            fuel
            (SIM: hsim Q ctx fuel false false (st_src, itr_src) (st_tgt, itr_tgt)),
            P fuel true true (st_src, itr_src) (st_tgt, itr_tgt))
    :
      forall fuel f_src f_tgt st_src st_tgt
             (SIM: hsim Q ctx fuel f_src f_tgt st_src st_tgt),
        P fuel f_src f_tgt st_src st_tgt.
  Proof.
    i. punfold SIM. induction SIM using _hsim_ind2.
    { eapply RET; eauto. }
    { eapply CALL; eauto. i. hexploit POST; eauto. i. pclearbot. eauto. }
    { eapply APCSTART; eauto. pfold. eauto. }
    { des. eapply APCSTEP; eauto. esplits; eauto. i. hexploit SIM; eauto. i. pclearbot. eauto. }
    { eapply SYSCALL; eauto. i. hexploit POST; eauto. i. pclearbot. eauto. }
    { eapply TAUSRC; eauto. pfold. eauto. }
    { eapply TAUTGT; eauto. pfold. eauto. }
    { des. eapply CHOOSESRC; eauto. esplits; eauto. pfold. eauto. }
    { eapply CHOOSETGT; eauto. i. hexploit SIM; eauto. i. des. pclearbot. splits; eauto. pfold. eauto. }
    { eapply TAKESRC; eauto. i. hexploit SIM; eauto. i. des. pclearbot. splits; eauto. pfold. eauto. }
    { des. eapply TAKETGT; eauto. esplits; eauto. pfold. eauto. }
    { eapply PPUTSRC; eauto. pfold. eauto. }
    { eapply PPUTTGT; eauto. pfold. eauto. }
    { eapply PGETSRC; eauto. pfold. eauto. }
    { eapply PGETTGT; eauto. pfold. eauto. }
    { eapply PROGRESS; eauto. pclearbot. eauto. }
  Qed.

  Definition mylift (fuel: option Ord.t) (mn_caller: option mname) X (x: X)
             ctx
             (Q: option mname -> X -> Any.t -> Any.t -> iProp) (itr_src: itree hEs Any.t): itree Es Any.t :=
    match fuel with
    | None =>
      (interp_hCallE_tgt mn stb o (interp_hEs_tgt itr_src) ctx) >>= (HoareFunRet Q mn_caller x)
    | Some fuel =>
      r0 <- (interp_hCallE_tgt mn stb o (_APC fuel) ctx);;
      r1 <- (interp_hCallE_tgt mn stb o (tau;; Ret (snd r0)) (fst r0));;
      r2 <- (interp_hCallE_tgt mn stb o (interp_hEs_tgt itr_src) (fst r1));;
      (HoareFunRet Q mn_caller x r2)
    end.

  Lemma current_iPropL_convert ctx P
        (CUR: current_iProp ctx P)
    :
      current_iPropL ctx [("H", P)].
  Proof.
    unfold current_iPropL. ss. unfold from_iPropL.
    eapply current_iProp_entail; eauto.
  Qed.

  Lemma hsim_adequacy_aux `{PreOrder _ le}:
    forall
      f_src f_tgt st_src st_tgt (itr_src: itree (hAPCE +' Es) Any.t) itr_tgt mr_src ctx X (x: X) Q mn_caller fuel w0
      (SIM: hsim (fun st_src st_tgt ret_src ret_tgt =>
                    (inv_with w0 st_src st_tgt) ** (Q mn_caller x ret_src ret_tgt: iProp)) ctx fuel f_src f_tgt (st_src, itr_src) (st_tgt, itr_tgt)),
      paco8 (_sim_itree (mk_wf I) le) bot8 Any.t Any.t (lift_rel (mk_wf I) le w0 (@eq Any.t))
            f_src f_tgt w0
            (Any.pair st_src mr_src,
             mylift fuel mn_caller x ctx Q itr_src)
            (st_tgt, itr_tgt).
  Proof.
    ginit. gcofix CIH. i.
    remember (st_src, itr_src). remember (st_tgt, itr_tgt).
    revert st_src st_tgt itr_src itr_tgt Heqp Heqp0 CIH.
    induction SIM using hsim_ind; i; clarify.
    { eapply current_iPropL_convert in RET. mDesAll. destruct fuel; steps.
      { astop. steps. unfold inv_with in RET. mDesAll. hret _; eauto.
        iModIntro. iSplitL "H"; auto.
      }
      { unfold inv_with in RET. mDesAll. hret _; eauto.
        iModIntro. iSplitL "H"; auto. }
    }
    { eapply current_iPropL_convert in PRE. mDesAll. destruct fuel; steps.
      { astop. steps. rewrite SPEC. steps. destruct fsp. ss.
        unfold inv_with in PRE. mDesAll. hcall _ _ with "A A1".
        { iModIntro. iSplitL "A1"; eauto. }
        { rewrite MEASURE in *. splits; ss. unfold ord_lt. des_ifs. }
        { steps. gbase. hexploit CIH.
          { eapply POST. eapply current_iProp_entail; [eauto|].
            start_ipm_proof. iSplitR "POST".
            { iSplitL "H"; eauto. iExists a1. iSplit; eauto. iPureIntro. etrans; eauto. }
            { iApply "POST". }
          }
          i. ss. eauto.
        }
      }
      { rewrite SPEC. steps. destruct fsp. ss.
        unfold inv_with in PRE. mDesAll. hcall _ _ with "A A1".
        { iModIntro. iSplitL "A1"; eauto. }
        { rewrite MEASURE in *. splits; ss. unfold ord_lt. des_ifs. }
        { steps. gbase. hexploit CIH.
          { eapply POST. eapply current_iProp_entail; [eauto|].
            start_ipm_proof. iSplitR "POST".
            { iSplitL "H"; eauto. iExists a1. iSplit; eauto. iPureIntro. etrans; eauto. }
            { iApply "POST". }
          }
          i. ss. eauto.
        }
      }
    }
    { destruct fuel; steps.
      { astop. steps. exploit IHSIM; eauto. i. destruct fuel1; ss.
        { astart t0.
          match goal with
          | |- ?P0 (_, ?itr1) _ =>
            match (type of x1) with
            | ?P1 (_, ?itr0) _ =>
              replace itr1 with itr0
            end
          end; auto.
          grind. destruct x0, x2. destruct u, u0. grind.
        }
        { astop. steps. }
      }
      { exploit IHSIM; eauto. i. destruct fuel1; ss.
        { astart t.
          match goal with
          | |- ?P0 (_, ?itr1) _ =>
            match (type of x1) with
            | ?P1 (_, ?itr0) _ =>
              replace itr1 with itr0
            end
          end; auto.
          grind. destruct x0, x2. destruct u, u0. grind.
        }
        { astop. steps. }
      }
    }
    { des. steps. rewrite unfold_APC. steps.
      force_l. exists false. steps.
      force_l. exists fuel1. steps.
      force_l; [eauto|..]. steps.
      force_l. exists (fn, arg_src). steps.
      rewrite SPEC. steps.
      eapply current_iPropL_convert in PRE. mDesAll.
      destruct fsp. ss. unfold inv_with in PRE. mDesAll.
      hcall _ _ with "A A1".
      { iModIntro. iSplitL "A1"; eauto. }
      { splits; ss. }
      { steps. gbase. hexploit CIH.
        { eapply SIM. eapply current_iProp_entail; [eauto|].
          start_ipm_proof. iSplitR "POST".
          { iSplitL "H"; eauto. iExists a1. iSplit; eauto. iPureIntro. etrans; eauto. }
          { iApply "POST". }
        }
        i. ss. eauto.
      }
    }
    { destruct fuel; steps.
      { astop. steps. gbase. hexploit CIH; eauto. }
      { gbase. hexploit CIH; eauto. }
    }
    { destruct fuel; steps.
      { astop. steps. exploit IHSIM; eauto. }
      { exploit IHSIM; eauto. }
    }
    { steps. exploit IHSIM; eauto. }
    { des. exploit IH; eauto. i. destruct fuel; steps.
      { astop. steps. force_l. eexists. steps. eauto. }
      { force_l. eexists. steps. eauto. }
    }
    { steps. exploit SIM; eauto. i. des. eauto. }
    { destruct fuel; steps.
      { astop. steps. exploit SIM; eauto. i. des. eauto. }
      { exploit SIM; eauto. i. des. eauto. }
    }
    { des. exploit IH; eauto. i. force_r. eexists. eauto. }
    { destruct fuel; steps.
      { astop. steps. exploit IHSIM; eauto. }
      { exploit IHSIM; eauto. }
    }
    { steps. exploit IHSIM; eauto. }
    { destruct fuel; steps.
      { astop. steps. exploit IHSIM; eauto. }
      { exploit IHSIM; eauto. }
    }
    { steps. exploit IHSIM; eauto. }
    { deflag. gbase. eapply CIH; eauto. }
  Qed.

  Lemma hsim_adequacy `{PreOrder _ le}:
    forall
      f_src f_tgt st_src st_tgt (itr_src: itree (hAPCE +' Es) Any.t) itr_tgt mr_src ctx X (x: X) Q mn_caller w0
      (SIM: hsim (fun st_src st_tgt ret_src ret_tgt =>
                    (inv_with w0 st_src st_tgt) ** (Q mn_caller x ret_src ret_tgt: iProp)) ctx None f_src f_tgt (st_src, itr_src) (st_tgt, itr_tgt)),
      paco8 (_sim_itree (mk_wf I) le) bot8 Any.t Any.t (lift_rel (mk_wf I) le w0 (@eq Any.t))
            f_src f_tgt w0
            (Any.pair st_src mr_src,
             (interp_hCallE_tgt mn stb o (interp_hEs_tgt itr_src) ctx) >>= (HoareFunRet Q mn_caller x))
            (st_tgt, itr_tgt).
  Proof.
    i. hexploit hsim_adequacy_aux; eauto.
  Qed.

  Lemma hsim_progress_flag R_src R_tgt r g Q ctx fuel st_src st_tgt
        (SIM: gpaco9 _hsim (cpn9 _hsim) g g R_src R_tgt Q ctx fuel false false st_src st_tgt)
    :
      gpaco9 _hsim (cpn9 _hsim) r g _ _ Q ctx fuel true true st_src st_tgt.
  Proof.
    destruct st_src, st_tgt. gstep. eapply hsim_progress; eauto.
  Qed.

  Lemma _hsim_flag_mon
        r
        R_src R_tgt Q ctx
        fuel f_src0 f_tgt0 f_src1 f_tgt1 st_src st_tgt
        (SIM: @_hsim r R_src R_tgt Q ctx fuel f_src0 f_tgt0 st_src st_tgt)
        (SRC: f_src0 = true -> f_src1 = true)
        (TGT: f_tgt0 = true -> f_tgt1 = true)
    :
      @_hsim r R_src R_tgt Q ctx fuel f_src1 f_tgt1 st_src st_tgt.
  Proof.
    revert f_src1 f_tgt1 SRC TGT.
    induction SIM using _hsim_ind2; i; clarify.
    { econs 1; eauto. }
    { econs 2; eauto. }
    { econs 3. eapply IHSIM; eauto. }
    { econs 4; eauto. }
    { econs 5; eauto. }
    { econs 6. eapply IHSIM; eauto. }
    { econs 7; eauto. }
    { econs 8; eauto. des. esplits. eapply IH; eauto. }
    { econs 9; eauto. i. hexploit SIM; eauto. i. des. eauto. }
    { econs 10; eauto. i. hexploit SIM; eauto. i. des. eapply IH; eauto. }
    { econs 11; eauto. des. esplits; eauto. }
    { econs 12. eapply IHSIM; auto. }
    { econs 13. eapply IHSIM; auto. }
    { econs 14. eapply IHSIM; auto. }
    { econs 15. eapply IHSIM; auto. }
    { exploit SRC; auto. exploit TGT; auto. i. clarify. econs 16; eauto. }
  Qed.

  Variant fuelC (r: forall R_src R_tgt
                           (Q: Any.t -> Any.t -> R_src -> R_tgt -> iProp)
                           (ctx: Σ),
                    option Ord.t -> bool -> bool -> Any.t * itree hEs R_src -> Any.t * itree Es R_tgt -> Prop)
          {R_src R_tgt}
          (Q: Any.t -> Any.t -> R_src -> R_tgt -> iProp)
          (ctx: Σ)
    : option Ord.t -> bool -> bool -> Any.t * itree hEs R_src -> Any.t * itree Es R_tgt -> Prop :=
  | fuelC_intro
      f_src f_tgt fuel0 fuel1
      st_src st_tgt
      (SIM: r _ _ Q ctx fuel0 f_src f_tgt st_src st_tgt)
      (ORD: option_Ord_le fuel0 fuel1)
    :
      fuelC r Q ctx fuel1 f_src f_tgt st_src st_tgt
  .

  Lemma fuelC_mon:
    monotone9 fuelC.
  Proof. ii. inv IN; econs; et. Qed.
  Hint Resolve fuelC_mon: paco.

  Lemma fuelC_spec: fuelC <10= gupaco9 (_hsim) (cpn9 _hsim).
  Proof.
    eapply wrespect9_uclo; eauto with paco.
    econs; eauto with paco. i. inv PR. eapply GF in SIM.
    revert x4 ORD. induction SIM using _hsim_ind2; i; clarify.
    { econs 1; eauto. }
    { econs 2; eauto. i. eapply rclo9_base. eauto. }
    { econs 3; eauto. eapply _hsim_mon; eauto. i. eapply rclo9_base. auto. }
    { destruct x4; ss. econs 4; eauto. des. esplits; eauto.
      { eapply Ord.lt_le_lt; eauto. }
      { i. eapply rclo9_base. eauto. }
    }
    { econs 5; eauto. i. eapply rclo9_base. auto. }
    { econs 6; eauto. eapply _hsim_mon; eauto. i. apply rclo9_base. auto. }
    { econs 7; eauto. }
    { econs 8; eauto. des. esplits; eauto. eapply _hsim_mon; eauto. i. apply rclo9_base. auto. }
    { econs 9; eauto. i. hexploit SIM; eauto. i. des. esplits; eauto. }
    { econs 10; eauto. i. hexploit SIM; eauto. i. des. eapply _hsim_mon; eauto. i. eapply rclo9_base; auto. }
    { econs 11; eauto. des. esplits; eauto. }
    { econs 12; eauto. eapply _hsim_mon; eauto. i. eapply rclo9_base; eauto. }
    { econs 13; eauto. }
    { econs 14; eauto. eapply _hsim_mon; eauto. i. eapply rclo9_base; eauto. }
    { econs 15; eauto. }
    { econs 16; eauto. eapply rclo9_clo_base. econs; eauto. }
  Qed.

  Variant hflagC (r: forall R_src R_tgt
                            (Q: Any.t -> Any.t -> R_src -> R_tgt -> iProp)
                            (ctx: Σ),
                     option Ord.t -> bool -> bool -> Any.t * itree hEs R_src -> Any.t * itree Es R_tgt -> Prop)
          {R_src R_tgt}
          (Q: Any.t -> Any.t -> R_src -> R_tgt -> iProp)
          (ctx: Σ)
    : option Ord.t -> bool -> bool -> Any.t * itree hEs R_src -> Any.t * itree Es R_tgt -> Prop :=
  | hflagC_intro
      f_src0 f_src1 f_tgt0 f_tgt1 fuel0 fuel1
      st_src st_tgt
      (SIM: r _ _ Q ctx fuel0 f_src0 f_tgt0 st_src st_tgt)
      (SRC: f_src0 = true -> f_src1 = true)
      (TGT: f_tgt0 = true -> f_tgt1 = true)
      (ORD: option_Ord_le fuel0 fuel1)
    :
      hflagC r Q ctx fuel1 f_src1 f_tgt1 st_src st_tgt
  .

  Lemma hflagC_mon:
    monotone9 hflagC.
  Proof. ii. inv IN; econs; et. Qed.
  Hint Resolve hflagC_mon: paco.

  Structure grespectful clo : Prop :=
    grespect_intro {
        grespect_mon: monotone9 clo;
        grespect_respect :
          forall l r
                 (LE: l <9= r)
                 (GF: l <9= @_hsim r),
            clo l <9= gpaco9 _hsim (cpn9 _hsim) bot9 (rclo9 (clo \10/ gupaco9 _hsim (cpn9 _hsim)) r);
      }.

  Lemma grespect_uclo clo
        (RESPECT: grespectful clo)
    :
      clo <10= gupaco9 (_hsim) (cpn9 _hsim).
  Proof.
    eapply grespect9_uclo; eauto with paco.
    econs.
    { eapply RESPECT. }
    i. hexploit grespect_respect.
    { eauto. }
    { eapply LE. }
    { eapply GF. }
    { eauto. }
    i. inv H. eapply rclo9_mon.
    { eauto. }
    i. ss. des; ss. eapply _paco9_unfold in PR0.
    2:{ ii. eapply _hsim_mon; [eapply PR1|]. i. eapply rclo9_mon; eauto. }
    ss. eapply _hsim_mon.
    { eapply PR0; eauto. }
    i. eapply rclo9_clo. right. econs.
    eapply rclo9_mon; eauto. i. inv PR2.
    { left. eapply paco9_mon; eauto. i. ss. des; ss.
      left. auto. }
    { des; ss. right. auto. }
  Qed.

  Lemma hflagC_spec: hflagC <10= gupaco9 (_hsim) (cpn9 _hsim).
  Proof.
    eapply grespect_uclo; eauto with paco.
    econs; eauto with paco. i. inv PR. eapply GF in SIM.
    guclo fuelC_spec. econs; [|eauto]. gstep.
    eapply _hsim_flag_mon; eauto.
    eapply _hsim_mon; eauto. i. gbase. eapply rclo9_base. auto.
  Qed.

  Variant hsimC
          (r g: forall R_src R_tgt
                       (Q: Any.t -> Any.t -> R_src -> R_tgt -> iProp)
                       (ctx: Σ),
              option Ord.t -> bool -> bool -> Any.t * itree hEs R_src -> Any.t * itree Es R_tgt -> Prop)
          {R_src R_tgt}
          (Q: Any.t -> Any.t -> R_src -> R_tgt -> iProp)
          (ctx: Σ)
    : option Ord.t -> bool -> bool -> Any.t * itree hEs R_src -> Any.t * itree Es R_tgt -> Prop :=
  | hsimC_ret
      v_src v_tgt
      st_src st_tgt
      fuel f_src f_tgt
      (RET: current_iProp ctx (Q st_src st_tgt v_src v_tgt))
    :
      hsimC r g Q ctx fuel f_src f_tgt (st_src, (Ret v_src)) (st_tgt, (Ret v_tgt))
  | hsimC_call
      fsp (x: fsp.(meta)) w0 FR
      fn arg_src arg_tgt
      st_src0 st_tgt0 ktr_src ktr_tgt
      fuel f_src f_tgt
      (SPEC: stb fn = Some fsp)
      (PRE: current_iProp ctx (FR ** inv_with w0 st_src0 st_tgt0 ** fsp.(precond) (Some mn) x arg_src arg_tgt))
      (MEASURE: o = ord_top)
      (NPURE: fsp.(measure) x = ord_top)
      (POST: forall ctx1 st_src1 st_tgt1 ret_src ret_tgt
                    (ACC: current_iProp ctx1 (FR ** inv_with w0 st_src1 st_tgt1 ** fsp.(postcond) (Some mn) x ret_src ret_tgt)),
          g _ _ Q ctx1 None true true (st_src1, ktr_src ret_src) (st_tgt1, ktr_tgt ret_tgt))
    :
      hsimC r g Q ctx fuel f_src f_tgt (st_src0, trigger (Call fn arg_src) >>= ktr_src) (st_tgt0, trigger (Call fn arg_tgt) >>= ktr_tgt)
  | hsimC_apc_start
      fuel1
      st_src st_tgt ktr_src itr_tgt
      fuel f_src f_tgt
      (SIM: r _ _ Q ctx (fuel1) true f_tgt (st_src, ktr_src tt) (st_tgt, itr_tgt))
    :
      hsimC r g Q ctx fuel f_src f_tgt (st_src, trigger (hAPC) >>= ktr_src) (st_tgt, itr_tgt)
  | hsimC_apc_step
      fsp (x: fsp.(meta)) w0 FR arg_src
      fn arg_tgt
      st_src0 st_tgt0 itr_src ktr_tgt
      fuel0 f_src f_tgt
      (SPEC: stb fn = Some fsp)
      (PRE: current_iProp ctx (FR ** inv_with w0 st_src0 st_tgt0 ** fsp.(precond) (Some mn) x arg_src arg_tgt))
      (MEASURE: ord_lt (fsp.(measure) x) o)
      (PURE: is_pure (fsp.(measure) x))
      (POST: exists fuel1,
          (<<FUEL: Ord.lt fuel1 fuel0>>) /\
          (<<SIM: forall ctx1 w0 st_src1 st_tgt1 ret_src ret_tgt
                         (ACC: current_iProp ctx1 (FR ** inv_with w0 st_src1 st_tgt1 ** fsp.(postcond) (Some mn) x ret_src ret_tgt)),
              g _ _ Q ctx1 (Some fuel1) true true (st_src1, itr_src) (st_tgt1, ktr_tgt ret_tgt)>>))
    :
      hsimC r g Q ctx (Some fuel0) f_src f_tgt (st_src0, itr_src) (st_tgt0, trigger (Call fn arg_tgt) >>= ktr_tgt)
  | hsimC_syscall
      fn arg rvs
      st_src st_tgt ktr_src ktr_tgt
      fuel f_src f_tgt
      (POST: forall ret,
          g _ _ Q ctx None true true (st_src, ktr_src ret) (st_tgt, ktr_tgt ret))
    :
      hsimC r g Q ctx fuel f_src f_tgt (st_src, trigger (Syscall fn arg rvs) >>= ktr_src) (st_tgt, trigger (Syscall fn arg rvs) >>= ktr_tgt)
  | hsimC_tau_src
      st_src st_tgt itr_src itr_tgt
      fuel f_src f_tgt
      (SIM: r _ _ Q ctx None true f_tgt (st_src, itr_src) (st_tgt, itr_tgt))
    :
      hsimC r g Q ctx fuel f_src f_tgt (st_src, tau;; itr_src) (st_tgt, itr_tgt)
  | hsimC_tau_tgt
      st_src st_tgt itr_src itr_tgt
      fuel f_src f_tgt
      (SIM: r _ _ Q ctx fuel f_src true (st_src, itr_src) (st_tgt, itr_tgt))
    :
      hsimC r g Q ctx fuel f_src f_tgt (st_src, itr_src) (st_tgt, tau;; itr_tgt)
  | hsimC_choose_src
      X
      st_src st_tgt ktr_src itr_tgt
      fuel f_src f_tgt
      (SIM: exists x, r _ _ Q ctx None true f_tgt (st_src, ktr_src x) (st_tgt, itr_tgt))
    :
      hsimC r g Q ctx fuel f_src f_tgt (st_src, trigger (Choose X) >>= ktr_src) (st_tgt, itr_tgt)
  | hsimC_choose_tgt
      X
      st_src st_tgt itr_src ktr_tgt
      fuel f_src f_tgt
      (SIM: forall x, r _ _ Q ctx fuel f_src true (st_src, itr_src) (st_tgt, ktr_tgt x))
    :
      hsimC r g Q ctx fuel f_src f_tgt (st_src, itr_src) (st_tgt, trigger (Choose X) >>= ktr_tgt)
  | hsimC_take_src
      X
      st_src st_tgt ktr_src itr_tgt
      fuel f_src f_tgt
      (SIM: forall x, r _ _ Q ctx None true f_tgt (st_src, ktr_src x) (st_tgt, itr_tgt))
    :
      hsimC r g Q ctx fuel f_src f_tgt (st_src, trigger (Take X) >>= ktr_src) (st_tgt, itr_tgt)
  | hsimC_take_tgt
      X
      st_src st_tgt itr_src ktr_tgt
      fuel f_src f_tgt
      (SIM: exists x, r _ _ Q ctx fuel f_src true (st_src, itr_src) (st_tgt, ktr_tgt x))
    :
      hsimC r g Q ctx fuel f_src f_tgt (st_src, itr_src) (st_tgt, trigger (Take X) >>= ktr_tgt)
  | hsimC_pput_src
      st_src1
      st_src0 st_tgt ktr_src itr_tgt
      fuel f_src f_tgt
      (SIM: r _ _ Q ctx None true f_tgt (st_src1, ktr_src tt) (st_tgt, itr_tgt))
    :
      hsimC r g Q ctx fuel f_src f_tgt (st_src0, trigger (PPut st_src1) >>= ktr_src) (st_tgt, itr_tgt)
  | hsimC_pput_tgt
      st_tgt1
      st_src st_tgt0 itr_src ktr_tgt
      fuel f_src f_tgt
      (SIM: r _ _ Q ctx fuel f_src true (st_src, itr_src) (st_tgt1, ktr_tgt tt))
    :
      hsimC r g Q ctx fuel f_src f_tgt (st_src, itr_src) (st_tgt0, trigger (PPut st_tgt1) >>= ktr_tgt)
  | hsimC_pget_src
      st_src st_tgt ktr_src itr_tgt
      fuel f_src f_tgt
      (SIM: r _ _ Q ctx None true f_tgt (st_src, ktr_src st_src) (st_tgt, itr_tgt))
    :
      hsimC r g Q ctx fuel f_src f_tgt (st_src, trigger (PGet) >>= ktr_src) (st_tgt, itr_tgt)
  | hsimC_pget_tgt
      st_src st_tgt itr_src ktr_tgt
      fuel f_src f_tgt
      (SIM: r _ _ Q ctx fuel f_src true (st_src, itr_src) (st_tgt, ktr_tgt st_tgt))
    :
      hsimC r g Q ctx fuel f_src f_tgt (st_src, itr_src) (st_tgt, trigger (PGet) >>= ktr_tgt)
  | hsimC_progress
      st_src st_tgt itr_src itr_tgt
      fuel
      (SIM: g _ _ Q ctx fuel false false (st_src, itr_src) (st_tgt, itr_tgt))
    :
      hsimC r g Q ctx fuel true true (st_src, itr_src) (st_tgt, itr_tgt)
  .

  Lemma hsim_indC_mon_gen r0 r1 g0 g1
        (LE0: r0 <9= r1)
        (LE1: g0 <9= g1)
    :
      @hsimC r0 g0 <9= @hsimC r1 g1.
  Proof.
    ii. inv PR.
    { econs 1; eauto. }
    { econs 2; eauto. }
    { econs 3; eauto. }
    { econs 4; eauto. des. esplits; eauto. }
    { econs 5; eauto. }
    { econs 6; eauto. }
    { econs 7; eauto. }
    { econs 8; eauto. des. esplits; eauto. }
    { econs 9; eauto. }
    { econs 10; eauto. }
    { econs 11; eauto. des. esplits; eauto. }
    { econs 12; eauto. }
    { econs 13; eauto. }
    { econs 14; eauto. }
    { econs 15; eauto. }
    { econs 16; eauto. }
  Qed.

  Lemma hsim_indC_mon: monotone9 (fun r => @hsimC r r).
  Proof.
    ii. eapply hsim_indC_mon_gen; eauto.
  Qed.

  Lemma hsim_indC_spec:
    (fun r => @hsimC r r) <10= gupaco9 (_hsim) (cpn9 _hsim).
  Proof.
    eapply wrespect9_uclo; eauto with paco. econs.
    { eapply hsim_indC_mon. }
    i. inv PR.
    { econs 1; eauto. }
    { econs 2; eauto. i. eapply rclo9_base. eauto. }
    { econs 3; eauto. eapply GF in SIM. eapply _hsim_mon; eauto. i. eapply rclo9_base. eauto. }
    { econs 4; eauto. des. esplits; eauto. i. eapply rclo9_base. eauto. }
    { econs 5; eauto. i. eapply rclo9_base. eauto. }
    { econs 6; eauto. eapply _hsim_mon; eauto. i. eapply rclo9_base. eauto. }
    { econs 7; eauto. eapply _hsim_mon; eauto. i. eapply rclo9_base. eauto. }
    { econs 8; eauto. des. esplits; eauto. eapply _hsim_mon; eauto. i. eapply rclo9_base. eauto. }
    { econs 9; eauto. i. eapply _hsim_mon; eauto. i. eapply rclo9_base. eauto. }
    { econs 10; eauto. i. eapply _hsim_mon; eauto. i. eapply rclo9_base. eauto. }
    { econs 11; eauto. des. esplits; eauto. eapply _hsim_mon; eauto. i. eapply rclo9_base. eauto. }
    { econs 12; eauto. eapply _hsim_mon; eauto. i. eapply rclo9_base. eauto. }
    { econs 13; eauto. eapply _hsim_mon; eauto. i. eapply rclo9_base. eauto. }
    { econs 14; eauto. eapply _hsim_mon; eauto. i. eapply rclo9_base. eauto. }
    { econs 15; eauto. eapply _hsim_mon; eauto. i. eapply rclo9_base. eauto. }
    { econs 16; eauto. eapply rclo9_base. eauto. }
  Qed.

  Lemma hsimC_spec:
    hsimC <11= gpaco9 (_hsim) (cpn9 _hsim).
  Proof.
    i. inv PR.
    { gstep. econs 1; eauto. }
    { gstep. econs 2; eauto. i. gbase. eauto. }
    { guclo hsim_indC_spec. ss. econs 3; eauto. gbase. eauto. }
    { gstep. econs 4; eauto. des. esplits; eauto. i. gbase. eauto. }
    { gstep. econs 5; eauto. i. gbase. eauto. }
    { guclo hsim_indC_spec. ss. econs 6; eauto. gbase. eauto. }
    { guclo hsim_indC_spec. ss. econs 7; eauto. gbase. eauto. }
    { guclo hsim_indC_spec. ss. econs 8; eauto. des. esplits; eauto. gbase. eauto. }
    { guclo hsim_indC_spec. ss. econs 9; eauto. gbase. eauto. }
    { guclo hsim_indC_spec. ss. econs 10; eauto. gbase. eauto. }
    { guclo hsim_indC_spec. ss. econs 11; eauto. des. esplits; eauto. gbase. eauto. }
    { guclo hsim_indC_spec. ss. econs 12; eauto. gbase. eauto. }
    { guclo hsim_indC_spec. ss. econs 13; eauto. gbase. eauto. }
    { guclo hsim_indC_spec. ss. econs 14; eauto. gbase. eauto. }
    { guclo hsim_indC_spec. ss. econs 15; eauto. gbase. eauto. }
    { gstep. econs 16; eauto. i. gbase. eauto. }
  Qed.

  Lemma hsimC_uclo r g:
    @hsimC (gpaco9 (_hsim) (cpn9 _hsim) r g) (gupaco9 (_hsim) (cpn9 _hsim) g) <9= gpaco9 (_hsim) (cpn9 _hsim) r g.
  Proof.
    i. eapply hsimC_spec in PR.  ss.
    eapply gpaco9_gpaco; [eauto with paco|].
    eapply gpaco9_mon; eauto. i. eapply gupaco9_mon; eauto.
  Qed.

  Variant hbindC (r: forall R_src R_tgt
                            (Q: Any.t -> Any.t -> R_src -> R_tgt -> iProp)
                            (ctx: Σ),
                     option Ord.t -> bool -> bool -> Any.t * itree hEs R_src -> Any.t * itree Es R_tgt -> Prop)
          {R_src R_tgt}
          (Q: Any.t -> Any.t -> R_src -> R_tgt -> iProp)
          (ctx: Σ)
    : option Ord.t -> bool -> bool -> Any.t * itree hEs R_src -> Any.t * itree Es R_tgt -> Prop :=
  | hbindC_intro
      S_src S_tgt
      (P: Any.t -> Any.t -> S_src -> S_tgt -> iProp)
      fuel f_src f_tgt st_src0 st_tgt0 itr_src itr_tgt ktr_src ktr_tgt
      (SIM: @r S_src S_tgt P ctx fuel f_src f_tgt (st_src0, itr_src) (st_tgt0, itr_tgt))
      (SIMK: forall ctx1 st_src1 st_tgt1 ret_src ret_tgt
                    (POST: current_iProp ctx1 (P st_src1 st_tgt1 ret_src ret_tgt)),
          @r R_src R_tgt Q ctx1 None false false (st_src1, ktr_src ret_src) (st_tgt1, ktr_tgt ret_tgt))
    :
      hbindC r Q ctx fuel f_src f_tgt (st_src0, itr_src >>= ktr_src) (st_tgt0, itr_tgt >>= ktr_tgt)
  .

  Lemma hbindC_mon:
    monotone9 hbindC.
  Proof. ii. inv IN; econs; et. Qed.
  Hint Resolve hbindC_mon: paco.

  Lemma hbindC_spec: hbindC <10= gupaco9 (_hsim) (cpn9 _hsim).
  Proof.
    eapply grespect_uclo.
    econs; eauto with paco. i. inv PR. eapply GF in SIM.
    remember (st_src0, itr_src). remember (st_tgt0, itr_tgt).
    revert st_src0 itr_src st_tgt0 itr_tgt Heqp Heqp0.
    induction SIM using _hsim_ind2; i; clarify; ired_both.
    { hexploit SIMK; eauto. i.
      eapply GF in H. guclo hflagC_spec. econs.
      2:{ instantiate (1:=false). ss. }
      2:{ instantiate (1:=false). ss. }
      2:{ instantiate (1:=None). destruct fuel; ss. }
      gstep. eapply _hsim_mon; eauto. i. gbase. eapply rclo9_base. auto.
    }
    { gstep. econs 2; eauto. i. hexploit POST; eauto. i.
      gbase. eapply rclo9_clo_base. left. econs; eauto.
    }
    { eapply hsimC_uclo. econs 3; eauto. }
    { des. gstep. econs 4; eauto. esplits; eauto. i.
      hexploit SIM; eauto. i. gbase. eapply rclo9_clo_base. left. econs; eauto.
    }
    { gstep. econs 5; eauto. i. gbase. eapply rclo9_clo_base. left. econs; eauto. }
    { eapply hsimC_uclo. econs 6; eauto. }
    { eapply hsimC_uclo. econs 7; eauto. }
    { des. eapply hsimC_uclo. econs 8; eauto. }
    { eapply hsimC_uclo. econs 9; eauto. i. hexploit SIM; eauto. i. des. esplits; eauto. }
    { eapply hsimC_uclo. econs 10; eauto. i. hexploit SIM; eauto. i. des. esplits; eauto. }
    { des. eapply hsimC_uclo. econs 11; eauto. }
    { eapply hsimC_uclo. econs 12; eauto. }
    { eapply hsimC_uclo. econs 13; eauto. }
    { eapply hsimC_uclo. econs 14; eauto. }
    { eapply hsimC_uclo. econs 15; eauto. }
    { gstep. econs 16; eauto. gbase. eapply rclo9_clo_base. left. econs; eauto. }
  Qed.

  Variant hbind_rightC (r: forall R_src R_tgt
                                  (Q: Any.t -> Any.t -> R_src -> R_tgt -> iProp)
                                  (ctx: Σ),
                           option Ord.t -> bool -> bool -> Any.t * itree hEs R_src -> Any.t * itree Es R_tgt -> Prop)
          {R_src R_tgt}
          (Q: Any.t -> Any.t -> R_src -> R_tgt -> iProp)
          (ctx: Σ)
    : option Ord.t -> bool -> bool -> Any.t * itree hEs R_src -> Any.t * itree Es R_tgt -> Prop :=
  | hbind_rightC_intro
      S_tgt
      (P: Any.t -> Any.t -> S_tgt -> iProp)
      fuel f_src f_tgt st_src0 st_tgt0 itr_src itr_tgt ktr_tgt
      (SIM: @r unit S_tgt (fun st_src st_tgt _ ret_tgt => P st_src st_tgt ret_tgt) ctx None f_src f_tgt (st_src0, Ret tt) (st_tgt0, itr_tgt))
      (SIMK: forall ctx1 st_src1 st_tgt1 ret_tgt
                    (POST: current_iProp ctx1 (P st_src1 st_tgt1 ret_tgt)),
          @r R_src R_tgt Q ctx1 fuel false false (st_src1, itr_src) (st_tgt1, ktr_tgt ret_tgt))
    :
      hbind_rightC r Q ctx fuel f_src f_tgt (st_src0, itr_src) (st_tgt0, itr_tgt >>= ktr_tgt)
  .

  Lemma hbind_rightC_mon:
    monotone9 hbind_rightC.
  Proof. ii. inv IN; econs; et. Qed.
  Hint Resolve hbind_rightC_mon: paco.

  Lemma hbind_rightC_spec: hbind_rightC <10= gupaco9 (_hsim) (cpn9 _hsim).
  Proof.
    eapply grespect_uclo.
    econs; eauto with paco. i. inv PR. eapply GF in SIM. remember None in SIM.
    remember (st_src0, Ret tt). remember (st_tgt0, itr_tgt).
    revert st_src0 st_tgt0 itr_tgt Heqp Heqp0 Heqo0.
    induction SIM using _hsim_ind2; i; clarify; ired_both.
    { hexploit SIMK; eauto. i.
      eapply GF in H. guclo hflagC_spec. econs.
      2:{ instantiate (1:=false). ss. }
      2:{ instantiate (1:=false). ss. }
      2:{ refl. }
      gstep. eapply _hsim_mon; eauto. i. gbase. eapply rclo9_base. auto.
    }
    { apply f_equal with (f:=_observe) in H0. ss. }
    { apply f_equal with (f:=_observe) in H0. ss. }
    { apply f_equal with (f:=_observe) in H0. ss. }
    { eapply hsimC_uclo. econs 7; eauto. }
    { apply f_equal with (f:=_observe) in H0. ss. }
    { eapply hsimC_uclo. econs 9; eauto. i. hexploit SIM; eauto. i. des. esplits; eauto. }
    { apply f_equal with (f:=_observe) in H0. ss. }
    { des. eapply hsimC_uclo. econs 11; eauto. }
    { apply f_equal with (f:=_observe) in H0. ss. }
    { eapply hsimC_uclo. econs 13; eauto. }
    { apply f_equal with (f:=_observe) in H0. ss. }
    { eapply hsimC_uclo. econs 15; eauto. }
    { gstep. econs 16; eauto. gbase. eapply rclo9_clo_base. left. econs; eauto. }
  Qed.

  Variant hsplitC (r: forall R_src R_tgt
                             (Q: Any.t -> Any.t -> R_src -> R_tgt -> iProp)
                             (ctx: Σ),
                      option Ord.t -> bool -> bool -> Any.t * itree hEs R_src -> Any.t * itree Es R_tgt -> Prop)
          {R_src R_tgt}
          (Q: Any.t -> Any.t -> R_src -> R_tgt -> iProp)
          (ctx: Σ)
    : option Ord.t -> bool -> bool -> Any.t * itree hEs R_src -> Any.t * itree Es R_tgt -> Prop :=
  | hsplitC_intro
      S_tgt
      (P: Any.t -> Any.t -> S_tgt -> iProp)
      fuel0 fuel1 f_src f_tgt st_src0 st_tgt0 itr_src itr_tgt ktr_tgt
      (SIM: @r unit S_tgt (fun st_src st_tgt _ ret_tgt => P st_src st_tgt ret_tgt) ctx (Some fuel0) f_src f_tgt (st_src0, Ret tt) (st_tgt0, itr_tgt))
      (SIMK: forall ctx1 st_src1 st_tgt1 ret_tgt
                    (POST: current_iProp ctx1 (P st_src1 st_tgt1 ret_tgt)),
          @r R_src R_tgt Q ctx1 (Some fuel1) false false (st_src1, itr_src) (st_tgt1, ktr_tgt ret_tgt))
    :
      hsplitC r Q ctx (Some (fuel1 + fuel0)%ord) f_src f_tgt (st_src0, itr_src) (st_tgt0, itr_tgt >>= ktr_tgt)
  .

  Lemma hsplitC_mon:
    monotone9 hsplitC.
  Proof. ii. inv IN; econs; et. Qed.
  Hint Resolve hsplitC_mon: paco.

  Lemma hsplitC_spec: hsplitC <10= gupaco9 (_hsim) (cpn9 _hsim).
  Proof.
    eapply grespect_uclo.
    econs; eauto with paco. i. inv PR. eapply GF in SIM.
    remember (st_src0, Ret tt). remember (st_tgt0, itr_tgt). remember (Some fuel0).
    revert fuel0 st_src0 st_tgt0 itr_tgt Heqp Heqp0 Heqo0.
    induction SIM using _hsim_ind2; i; clarify; ired_both.
    { hexploit SIMK; eauto. i.
      eapply GF in H. guclo hflagC_spec. econs.
      2:{ instantiate (1:=false). ss. }
      2:{ instantiate (1:=false). ss. }
      2:{ instantiate (1:=(Some fuel1)). ss. apply OrdArith.add_base_l. }
      gstep. eapply _hsim_mon; eauto. i. gbase. eapply rclo9_base. auto.
    }
    { apply f_equal with (f:=_observe) in H0. ss. }
    { apply f_equal with (f:=_observe) in H0. ss. }
    { des. gstep. econs 4; eauto. esplits; eauto.
      { eapply OrdArith.lt_add_r. eauto. }
      i. hexploit SIM; eauto. i. gbase. eapply rclo9_clo_base. left. econs; eauto.
    }
    { apply f_equal with (f:=_observe) in H0. ss. }
    { eapply hsimC_uclo. econs 7; eauto. }
    { apply f_equal with (f:=_observe) in H0. ss. }
    { eapply hsimC_uclo. econs 9; eauto. i. hexploit SIM; eauto. i. des. esplits; eauto. }
    { apply f_equal with (f:=_observe) in H0. ss. }
    { des. eapply hsimC_uclo. econs 11; eauto. }
    { apply f_equal with (f:=_observe) in H0. ss. }
    { eapply hsimC_uclo. econs 13; eauto. }
    { apply f_equal with (f:=_observe) in H0. ss. }
    { eapply hsimC_uclo. econs 15; eauto. }
    { gstep. econs 16; eauto. gbase. eapply rclo9_clo_base. left. econs; eauto. }
  Qed.

  Variant hmonoC (r: forall R_src R_tgt
                            (Q: Any.t -> Any.t -> R_src -> R_tgt -> iProp)
                            (ctx: Σ),
                     option Ord.t -> bool -> bool -> Any.t * itree hEs R_src -> Any.t * itree Es R_tgt -> Prop)
          {R_src R_tgt}
          (Q: Any.t -> Any.t -> R_src -> R_tgt -> iProp)
          (ctx: Σ)
    : option Ord.t -> bool -> bool -> Any.t * itree hEs R_src -> Any.t * itree Es R_tgt -> Prop :=
  | hmonoC_intro
      f_src f_tgt fuel Q0
      st_src st_tgt
      (SIM: r _ _ Q0 ctx fuel f_src f_tgt st_src st_tgt)
      (MONO: forall st_src st_tgt ret_src ret_tgt,
          (bi_entails (Q0 st_src st_tgt ret_src ret_tgt) (#=> Q st_src st_tgt ret_src ret_tgt)))
    :
      hmonoC r Q ctx fuel f_src f_tgt st_src st_tgt
  .

  Lemma hmonoC_mon:
    monotone9 hmonoC.
  Proof. ii. inv IN; econs; et. Qed.
  Hint Resolve hmonoC_mon: paco.

  Lemma hmonoC_spec: hmonoC <10= gupaco9 (_hsim) (cpn9 _hsim).
  Proof.
    eapply wrespect9_uclo; eauto with paco.
    econs; eauto with paco. i. inv PR. eapply GF in SIM.
    induction SIM using _hsim_ind2; i; clarify; ired_both.
    { econs 1; eauto. eapply current_iProp_upd.
      eapply current_iProp_entail; eauto.
    }
    { econs 2; eauto. i. eapply rclo9_clo_base. econs; eauto. }
    { econs 3; eauto. }
    { econs 4; eauto. des. esplits; eauto. i. hexploit SIM; eauto. i. eapply rclo9_clo_base. econs; eauto. }
    { econs 5; eauto. i. eapply rclo9_clo_base. econs; eauto. }
    { econs 6; eauto. }
    { econs 7; eauto. }
    { econs 8; eauto. des. esplits; eauto. }
    { econs 9; eauto. i. hexploit SIM; eauto. i. des. esplits; eauto. }
    { econs 10; eauto. i. hexploit SIM; eauto. i. des. esplits; eauto. }
    { econs 11; eauto. des. esplits; eauto. }
    { econs 12; eauto. }
    { econs 13; eauto. }
    { econs 14; eauto. }
    { econs 15; eauto. }
    { econs 16; eauto. eapply rclo9_clo_base. econs; eauto. }
  Qed.

  Variant hframeC_aux (r: forall R_src R_tgt
                             (Q: Any.t -> Any.t -> R_src -> R_tgt -> iProp)
                             (ctx: Σ),
                      option Ord.t -> bool -> bool -> Any.t * itree hEs R_src -> Any.t * itree Es R_tgt -> Prop)
          {R_src R_tgt}
          (Q: Any.t -> Any.t -> R_src -> R_tgt -> iProp)
          (ctx: Σ)
    : option Ord.t -> bool -> bool -> Any.t * itree hEs R_src -> Any.t * itree Es R_tgt -> Prop :=
  | hframeC_aux_intro
      res
      f_src f_tgt fuel
      st_src st_tgt
      (PRE: URA.wf (ctx ⋅ res))
      (SIM: r _ _ (fun st_src st_tgt ret_src ret_tgt => Own res -* #=> Q st_src st_tgt ret_src ret_tgt) (ctx ⋅ res) fuel f_src f_tgt st_src st_tgt)
    :
      hframeC_aux r Q ctx fuel f_src f_tgt st_src st_tgt
  .

  Lemma hframeC_aux_mon:
    monotone9 hframeC_aux.
  Proof. ii. inv IN; econs; et. Qed.
  Hint Resolve hframeC_aux_mon: paco.

  Lemma current_iProp_frame_own ctx0 ctx1 P
        (CUR: current_iProp (ctx0 ⋅ ctx1) (Own ctx1 -* P))
    :
      current_iProp ctx0 P.
  Proof.
    inv CUR. uipropall. hexploit IPROP.
    2:{ exists URA.unit. eapply URA.unit_id. }
    { eapply URA.wf_mon. instantiate (1:=ctx0). r_wf GWF. }
    i. econs; [|eauto]. r_wf GWF.
  Qed.

  Lemma current_iProp_frame_own_rev ctx0 ctx1 P
        (CUR: current_iProp ctx0 (Own ctx1 ** P))
    :
      current_iProp (ctx0 ⋅ ctx1) P.
  Proof.
    inv CUR. uipropall.
    unfold URA.extends in *. des; clarify.
    econs; [|eauto]. eapply URA.wf_mon.
    instantiate (1:=ctx). r_wf GWF.
  Qed.

  Lemma current_iProp_own_wf ctx res
        (CUR: current_iProp ctx (Own res))
    :
      URA.wf (ctx ⋅ res).
  Proof.
    inv CUR. uipropall. unfold URA.extends in *. des. clarify.
    eapply URA.wf_mon.
    instantiate (1:=ctx0). r_wf GWF.
  Qed.

  Lemma hframeC_aux_spec: hframeC_aux <10= gupaco9 (_hsim) (cpn9 _hsim).
  Proof.
    eapply wrespect9_uclo; eauto with paco.
    econs; eauto with paco. i. inv PR. eapply GF in SIM.
    induction SIM using _hsim_ind2; i; clarify; ired_both.
    { econs 1; eauto. eapply current_iProp_upd. eapply current_iProp_frame_own; eauto. }
    { econs 2; eauto.
      { eapply current_iProp_frame_own.
        eapply current_iProp_entail.
        { eapply PRE0. }
        iIntros "[[H0 H1] H2] H3".
        iSplitR "H2"; [|iExact "H2"].
        iSplitR "H1"; [|iExact "H1"].
        instantiate (1:= _ ** _).
        iSplitL "H0"; [iExact "H0"|].
        iExact "H3".
      }
      { i. eapply rclo9_clo_base. econs.
        { instantiate (1:=res). eapply current_iProp_own_wf.
          eapply current_iProp_entail.
          { eapply ACC. }
          iIntros "[[[H0 H1] H2] H3]". ss.
        }
        { eapply POST; eauto.
          eapply current_iProp_frame_own_rev.
          eapply current_iProp_entail.
          { eapply ACC. }
          iIntros "[[[H0 H1] H2] H3]".
          iSplitL "H1"; [iExact "H1"|].
          iSplitR "H3"; [|iExact "H3"].
          iSplitR "H2"; [|iExact "H2"].
          iExact "H0".
        }
      }
    }
    { econs 3; eauto. }
    { econs 4; eauto.
      { eapply current_iProp_frame_own.
        eapply current_iProp_entail.
        { eapply PRE0. }
        iIntros "[[H0 H1] H2] H3".
        iSplitR "H2"; [|iExact "H2"].
        iSplitR "H1"; [|iExact "H1"].
        instantiate (1:= _ ** _).
        iSplitL "H0"; [iExact "H0"|].
        iExact "H3".
      }
      { des. esplits; eauto.
        i. eapply rclo9_clo_base. econs.
        { instantiate (1:=res). eapply current_iProp_own_wf.
          eapply current_iProp_entail.
          { eapply ACC. }
          iIntros "[[[H0 H1] H2] H3]". ss.
        }
        { eapply SIM; eauto.
          eapply current_iProp_frame_own_rev.
          eapply current_iProp_entail.
          { eapply ACC. }
          iIntros "[[[H0 H1] H2] H3]".
          iSplitL "H1"; [iExact "H1"|].
          iSplitR "H3"; [|iExact "H3"].
          iSplitR "H2"; [|iExact "H2"].
          iExact "H0".
        }
      }
    }
    { econs 5; eauto. i. eapply rclo9_clo_base. econs; eauto. }
    { econs 6; eauto. }
    { econs 7; eauto. }
    { econs 8; eauto. des. esplits; eauto. }
    { econs 9; eauto. i. hexploit SIM; eauto. i. des. esplits; eauto. }
    { econs 10; eauto. i. hexploit SIM; eauto. i. des. esplits; eauto. }
    { econs 11; eauto. des. esplits; eauto. }
    { econs 12; eauto. }
    { econs 13; eauto. }
    { econs 14; eauto. }
    { econs 15; eauto. }
    { econs 16; eauto. eapply rclo9_clo_base. econs; eauto. }
  Qed.

  Variant hframeC (r: forall R_src R_tgt
                             (Q: Any.t -> Any.t -> R_src -> R_tgt -> iProp)
                             (ctx: Σ),
                      option Ord.t -> bool -> bool -> Any.t * itree hEs R_src -> Any.t * itree Es R_tgt -> Prop)
          {R_src R_tgt}
          (Q: Any.t -> Any.t -> R_src -> R_tgt -> iProp)
          (ctx: Σ)
    : option Ord.t -> bool -> bool -> Any.t * itree hEs R_src -> Any.t * itree Es R_tgt -> Prop :=
  | hframeC_intro
      P0 P1
      f_src f_tgt fuel
      st_src st_tgt
      (PRE: current_iProp ctx (P0 ** P1))
      (SIM: forall ctx (PRE: current_iProp ctx P1),
          r _ _ (fun st_src st_tgt ret_src ret_tgt => P0 -* #=> Q st_src st_tgt ret_src ret_tgt) ctx fuel f_src f_tgt st_src st_tgt)
    :
      hframeC r Q ctx fuel f_src f_tgt st_src st_tgt
  .

  Lemma hframeC_spec: hframeC <10= gupaco9 (_hsim) (cpn9 _hsim).
  Proof.
    ii. inv PR.
    inv PRE. rr in IPROP.
    autounfold with iprop in IPROP.
    autorewrite with iprop in IPROP. des. clarify.
    guclo hframeC_aux_spec. econs.
    { instantiate (1:=a). eapply URA.wf_mon. instantiate (1:=b). r_wf GWF. }
    { guclo hmonoC_spec. econs.
      { gbase. eapply SIM. econs; [|eauto]. r_wf GWF.
      }
      { i. ss. iIntros "H0". iModIntro. iIntros "H1".
        iApply bupd_trans. iApply "H0".
        iStopProof. uipropall.
        i. red in H. des. clarify. esplits; [|eauto].
        eapply URA.wf_mon. instantiate (1:=ctx0). r_wf H0.
      }
    }
  Qed.
End SIM.
#[export] Hint Resolve _hsim_mon: paco.
#[export] Hint Resolve cpn9_wcompat: paco.


(** tests the computes non-uniform parameter **)

Load non_uniform.

Compute (countOfCtor 1 100 (tApp (tRel 1) (tRel 0))).
Compute (countOfCtor 1 100 (tApp (tRel 100) (tApp (tRel 1) (tRel 0)))).
Compute (countOfCtor 1 100 (tApp (tVar "Not relevant"%string) (tApp (tRel 1) (tRel 0)))).
Compute (countOfCtor 1 100 (tApp
                              (tInd {| inductive_mind := "Coq.Init.Datatypes.list"; inductive_ind := 0 |} [])
                              (tApp (tRel 1) (tRel 0)))).
(* Compute (countOfCtor 1 1 (tApp (tApp (tRel 1) (tRel 0)) (tVar "N"%string))). *)
Compute (countOfCtor 2 2 (tApp (tApp (tRel 2) (tRel 1)) (tVar "N"%string))).
Compute (countOfCtor 2 100 (tApp (tApp (tRel 2) (tRel 1)) (tVar "N"%string))).
Compute (countOfCtor 2 100 (tApp (tApp (tRel 2) (tRel 0)) (tVar "N"%string))).
Compute (countOfCtor 2 100 (tApp (tApp (tRel 2) (tRel 1)) (tRel 0))).
Compute (countOfCtor 2 100 (tApp
                              (tInd {| inductive_mind := "Coq.Init.Datatypes.list"; inductive_ind := 0 |} [])
                              (tApp (tApp (tRel 2) (tRel 1)) (tRel 0)))).
Compute (countOfCtor 2 100 (tApp
                              (tInd {| inductive_mind := "Coq.Init.Datatypes.list"; inductive_ind := 0 |} [])
                              (tApp (tApp (tRel 2) (tRel 42)) (tRel 0)))).
Compute (countOfCtor 2 2 (tApp
                              (tInd {| inductive_mind := "Coq.Init.Datatypes.list"; inductive_ind := 0 |} [])
                              (tApp (tApp (tRel 2) (tRel 42)) (tRel 1)))). (* Problem *)
Compute (countOfCtor 2 100 (tApp
                              (tInd {| inductive_mind := "Coq.Init.Datatypes.list"; inductive_ind := 0 |} [])
                              (tApp (tApp (tRel 2) (tRel 1)) (tRel 42)))).
Compute (countOfCtor 1 100 (tApp
                              (tInd {| inductive_mind := "Coq.Init.Datatypes.list"; inductive_ind := 0 |} [])
                              (tApp (tApp (tRel 1) (tRel 42)) (tRel 42)))).
Compute (countOfCtor 1 100 (tApp
                              (tInd {| inductive_mind := "Coq.Init.Datatypes.list"; inductive_ind := 0 |} [])
                              (tApp (tApp (tRel 1) (tVar "N"%string)) (tVar "N"%string)))).

Compute (countOfCtor 1 100
(tApp
                                             (tInd
                                                {|
                                                inductive_mind := "Coq.Init.Datatypes.list";
                                                inductive_ind := 0 |} [])
                                             (tApp(tApp (tRel 1)
                                                (* (tApp *)
                                                (*    (tConstruct *)
                                                (*       {| *)
                                                (*       inductive_mind := "Coq.Init.Datatypes.nat"; *)
                                                (*       inductive_ind := 0 |} 1 []) (tRel 0)) *)
                                                (tConstruct
                                                  {|
                                                  inductive_mind := "Coq.Init.Datatypes.nat";
                                                  inductive_ind := 0 |} 0 [])
                                                  )
                                                (tConstruct
                                                  {|
                                                  inductive_mind := "Coq.Init.Datatypes.nat";
                                                  inductive_ind := 0 |} 0 [])
))
        ).

MetaCoq Run (getP <% nat %>). (* 0 *)
MetaCoq Run (getP <% list %>). (* 1 *)
MetaCoq Run (getP <% VectorDef.t %>). (* 1 *)
MetaCoq Run (getP <% le %>). (* 1 *)
MetaCoq Run (getP <% Acc %>). (* 2 *)

Definition t1 := Ast.tProd (nNamed "n"%string)
   (Ast.tInd
      {|
      inductive_mind := "Coq.Init.Datatypes.nat";
      inductive_ind := 0 |} [])
   (Ast.tApp (Ast.tRel 1)
      [Ast.tRel 0; Ast.tRel 0]).
Definition t2 := Ast.tProd (nNamed "n"%string)
    (Ast.tInd
       {|
       inductive_mind := "Coq.Init.Datatypes.nat";
       inductive_ind := 0 |} [])
    (Ast.tProd (nNamed "m"%string)
       (Ast.tInd
          {|
          inductive_mind := "Coq.Init.Datatypes.nat";
          inductive_ind := 0 |} [])
       (Ast.tProd nAnon
          (Ast.tApp
             (Ast.tRel 2)
             [Ast.tRel 1; Ast.tRel 0])
          (Ast.tApp
             (Ast.tRel 3)
             [Ast.tRel 2;
             Ast.tApp
               (Ast.tConstruct
               {|
               inductive_mind := "Coq.Init.Datatypes.nat";
               inductive_ind := 0 |} 1 [])
               [
               Ast.tRel 1]]))).

From MetaCoq.PCUIC Require Import TemplateToPCUIC.
Compute (countOfCtor 0 2 (trans t1)).
Compute (countOfCtor 0 2 (trans t2)).

MetaCoq Run (tmQuoteInductive ("le"%string) >>= tmPrint).

Definition vt1 :=
                                     Ast.tProd (nNamed "A"%string)
                                       (Ast.tSort
                                          (Universe.from_kernel_repr
                                             (Level.Level
                                                "Coq.Vectors.VectorDef.4",
                                             false) []))
                                       (Ast.tApp (Ast.tRel 1)
                                          [Ast.tRel 0;
                                          Ast.tConstruct
                                            {|
                                            inductive_mind := "Coq.Init.Datatypes.nat";
                                            inductive_ind := 0 |} 0 []]).

Definition vt2 :=
                                    Ast.tProd (nNamed "A"%string)
                                      (Ast.tSort
                                         (Universe.from_kernel_repr
                                            (Level.Level
                                               "Coq.Vectors.VectorDef.4",
                                            false) []))
                                      (Ast.tProd (nNamed "h"%string)
                                         (Ast.tRel 0)
                                         (Ast.tProd
                                            (nNamed "n"%string)
                                            (Ast.tInd
                                               {|
                                               inductive_mind := "Coq.Init.Datatypes.nat";
                                               inductive_ind := 0 |} [])
                                            (Ast.tProd nAnon
                                               (Ast.tApp
                                                 (Ast.tRel 3)
                                                 [Ast.tRel 2; Ast.tRel 0])
                                               (Ast.tApp
                                                 (Ast.tRel 4)
                                                 [
                                                 Ast.tRel 3;
                                                 Ast.tApp
                                                 (Ast.tConstruct
                                                 {|
                                                 inductive_mind := "Coq.Init.Datatypes.nat";
                                                 inductive_ind := 0 |} 1 [])
                                                 [Ast.tRel 1]])))).

MetaCoq Run (tmQuoteInductive ("VectorDef.t"%string) >>= tmPrint).

From MetaCoq.PCUIC Require Import TemplateToPCUIC.
Compute (countOfCtor 0 2 (trans vt1)).
Compute (countOfCtor 0 2 (trans vt2)).

Print Coq.Init.Logic.eq_refl.

Inductive dep (X:Type) : nat -> forall (x:X), x=x -> Prop :=
| dep0 y : dep X 0 y (@Coq.Init.Logic.eq_refl _ y).
Inductive G (f:nat->bool) : nat -> Prop :=
  GI : forall n, (f n = false -> G f (S n)) -> G f n.
Inductive G3 (f:nat->bool) (n:nat) : Prop :=
  G3I : (f n = false -> G3 f (S n)) -> G3 f n.
Inductive G2 (f:nat->bool) : nat -> Prop :=
  G2I1 : forall n, (f n = false -> G2 f (S n)) -> (f n = true -> G2 f (S (S n))) -> G2 f n
| G2I2 : forall n, (f n = false -> G2 f (S n)) -> G2 f n.

MetaCoq Run (getP <% dep %>).
MetaCoq Run (getP <% G %>).
MetaCoq Run (getP <% G3 %>).
MetaCoq Run (getP <% G2 %>).

Inductive roseTreePI8 (n : nat) : nat -> Set :=  treePI8 : list (roseTreePI8 (S n) 0) -> roseTreePI8 n 1.

MetaCoq Run (tmQuoteInductive ("roseTreePI8"%string) >>= tmPrint).

MetaCoq Run (getP <% roseTreePI8 %>).


Require Import String.
Require Import Functors.
Require Import MonadLib.
Require Import Names.
Require Import PNames.
Require Import EffPure.
Require Import EffState.
Require Import EffExcept.
Require Import EffReader.
Require Import Arith.
Require Import Lambda.
Require Import Ref.
Require Import Exception.
Require Import Lambda_Arith.
Require Import Lambda_Ref.
Require Import Lambda_Exception.
Require Import ESoundERS.

Section Test_Section.

  Definition D := AType :+: LType :+: UnitType :+: RefType.
  Definition E (A : Set) := Arith :+: Lambda D A :+: RefE :+: ExceptE D.

  Global Instance Fun_E : forall (A : Set),
    Functor (E A).
  Proof.
    eauto with typeclass_instances.
  Defined.

  Definition V := StuckValue :+: NatValue :+:
    (ClosValue E) :+: LocValue :+: UnitValue.

  Variable MT : Set -> Set.
  Context `{Fail_MT : FailMonad MT}.
  Context {Inj_MT : InjMonad MT}.
  Context {Reasonable_MT : Reasonable_Monad MT}.
  Context {MT_eq_dec : forall (A : Set) (mta : MT A),
    {exists a, mta = return_ a} + {mta = fail}}.

  Variable ME : Set -> Set.
  Context `{Mon_ME : Environment ME (list (Value V))}.
  Context {State_ME : StateM ME (list (Value V))}.
  Context {Fail_ME : FailMonad ME}.
  Context {FailEnvM : FailEnvironmentMonad (Env (Value V)) ME}.
  Context {Exception_ME : Exception ME Datatypes.unit}.

  Definition EQV_E (A B : Set) := (Arith_eqv E A B) ::+:: (Lambda_eqv D E A B) ::+:: (RefE_eqv E A B)
    ::+:: (Exception_eqv D E A B).

  Definition WFV := (WFValue_VI V D (list (Names.DType D) * list (Names.DType D))) ::+::
    (WFValue_Clos D E MT V EQV_E _) ::+:: (WFValue_Unit D V _) ::+:: (WFValue_Loc D V _).

  Definition WFVM := (WFValueM_base D V MT ME _ WFV) ::+:: (WFValueM_Environment D MT V ME _ WFV)
    ::+:: (WFValueM_Bot D V MT ME _) ::+:: (WFValueM_State D V MT ME _
      (TypContextCE := SigGamma_GammaTypContextCE _)
      (TypContext_WFE := SigGamma_WF_EnvC _ _ WFV))
    ::+:: (WFValueM_Except D V MT ME _).

  Instance eval_alg : FAlgebra EvalName (Exp (E nat)) (evalMR V ME) (E nat).
  Proof.
    eauto 250 with typeclass_instances.
  Defined.

  Instance typeof_alg : forall T, FAlgebra TypeofName T (typeofR D MT) (E (DType D)).
  Proof.
    intros; eauto 150 with typeclass_instances.
  Defined.

  Instance eqv_soundness_X_alg eval_rec :
    iPAlgebra soundness_X'_Name
    (soundness_X'_P D V E MT ME _ EQV_E WFVM (fun e => typeof _ _ MT (proj1_sig e)) eval_rec
      (f_algebra (FAlgebra := typeof_alg _))
      (f_algebra (FAlgebra := eval_alg))) (EQV_E _ _).
  Proof.
    repeat apply iPAlgebra_Plus.
    apply eqv_soundness_X'_Arith_eqv with (WFV := WFV) (Fail_MT := Fail_MT)
      (monad := monad0) (TypContextCE := SigGamma_GammaTypContextCE _)
      (Sub_AType_D := _) (Sub_StuckValue_V := _) (Sub_NatValue_V := _);
      intros; eauto 550 with typeclass_instances.
    apply eqv_soundness_X'_Lambda_eqv with (WFV := WFV) (Fail_MT := Fail_MT)
      (TypContextCE := SigGamma_GammaTypContextCE _)
      (Environment_ME := Mon_ME) (Sub_LType_D := _)
      (Sub_StuckValue_V := _) (Sub_ClosValue_V := _)
      (eq_DType_DT := _); intros; eauto 550 with typeclass_instances.
    apply eqv_soundness_X'_RefE_eqv with (WFV := WFV) (TypContext_S := _)
      (TypContextCE := SigGamma_GammaTypContextCE _)
      (TypContext_WFE := SigGamma_WF_EnvC _ _ WFV)
      (Fail_MT := Fail_MT) (StateM_ME := State_ME) (Sub_RefType_D := _)
      (Sub_StuckValue_V := _) (Sub_LocValue_V := _)
      (eq_DType_DT := _) (Sub_UnitType_D := _) (Sub_UnitValue_V := _);
      intros; eauto 550 with typeclass_instances.
    apply eqv_soundness_X'_Except_eqv with (Fail_MT := Fail_MT)
      (TypContextCE := SigGamma_GammaTypContextCE _)
      (Exception_ME := Exception_ME) (eq_DType_DT := _);
      intros; eauto 550 with typeclass_instances.
  Qed.

  Variable put_local : forall (A : Set) sigma f (m : ME A),
    put (M := ME) sigma >> (local f m) = local f (put sigma >> m).

  Variable local_throw : forall (A : Set) f t,
    local f (throw t) = throw t (A := A).
  Variable local_catch : forall (A : Set) e h f,
    local f (catch (A := A) e h) = catch (local f e) (fun t => local f (h t)).

  Variable catch_fail : forall (A : Set) h,
    catch (A := A) fail h = fail.
  Context {fail_neq_throw : forall A env env',
    put env >> fail (M := ME) <> put env' >> throw (A := A) tt}.

  Context {Put_Exception_Disc :
    forall (A B : Set) (a : A) (mb : ME B) env n,
      (put env >>= fun _ => return_ a) <> mb >>= fun _ => throw n}.

  Context {put_catch : forall (A : Set) (env : list (Value V)) e h,
    put env >>= (fun _ => catch (A := A) e h) = catch (put env >>= fun _ => e) h}.
  Context {put_throw : forall (A B : Set) (env env' : list (Value V)) t,
    put env >>= (fun _ => throw t (A := A)) = put env' >>= (fun _ => throw t) ->
    put env >>= (fun _ => throw t (A := B)) = put env' >>= (fun _ => throw t)}.

  Context {ME_eq_dec' : forall (A : Set) (mte : ME A) (env gamma'' : list (Names.Value V)),
    (exists a : A, exists env' : list (Names.Value V),
      put env >> (local (fun _ => gamma'') mte) = put env' >> return_ a) \/
    (exists env', put env >> (local (fun _ => gamma'') mte) = put env' >> fail) \/
    (exists env', put env >> (local (fun _ => gamma'') mte) = put env' >> throw tt)}.

  Instance Except_State_Sound_X_WFVM :
    iPAlgebra Except_State_Sound_X_Name (Except_State_Sound_X_P D V MT ME WFV) WFVM.
  Proof.
    eauto 850 with typeclass_instances.
  Qed.

  Theorem eval_Sound :
    forall (n : nat) Sigma gamma gamma' gamma'' e' e'',
      E_eqvC E EQV_E gamma' gamma e'' e' ->
      forall (WF_gamma : forall n b, lookup gamma' n = Some b ->
        exists T, lookup gamma b = Some T)
      (WF_gamma'' : WF_Environment _ _ _ WFV Sigma gamma'' gamma)
      (WF_gamma2 : List.length gamma = List.length gamma')
      (WF_gamma' : forall n b, lookup gamma' n = Some b -> b = n)
      (WF_Sigma : Gamma D Sigma = gamma)
      (T : DType D)
      (env : Env (Names.Value V))
      (WF_env : WF_Environment _ _ _ WFV Sigma env (fst Sigma)),
      typeof D (E (DType D)) MT (proj1_sig e') = return_ T ->
      (exists env', put env >>
        local (M := ME) (fun _ => gamma'') (bevalM V E ME n e'') = put env' >> fail) \/
      (exists t, exists env', exists Sigma',
        put env >> local (M := ME) (fun _ => gamma'') (bevalM V E ME n e'') = put env' >> throw t
        /\ WF_Environment D V _ WFV Sigma' env' (fst Sigma')
        /\ ConsExtension Sigma' Sigma) \/
        exists v : Value V,
          exists env' : Env (Value V),
          exists Sigma' ,
            ConsExtension Sigma' Sigma /\
          put env >> local (M := ME) (fun _ => gamma'') (bevalM V E ME n e'') =
          put env' >> return_ (M := ME) v /\ WFValueC _ _ _ WFV Sigma' v T
          /\ WF_Environment D V _ WFV Sigma' env' (fst Sigma').
  Proof.
    intros.
    apply Except_State_Sound_X with (EQV_E := EQV_E) (WFVM := WFVM) (Mon_MT := monad)
      (Typeof_E := typeof_alg) (gamma := gamma) (gamma' := gamma') (e' := e');
      eauto 250 with typeclass_instances.
  Qed.

  Open Scope string_scope.

  Eval compute in ("Type Soundness for Arith + Ref + Lambda + Exception Proven!").

End Test_Section.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Import floyd.proofauto.
Import ListNotations.
Local Open Scope logic.

(************************ TO BE MOVED SOMEWHERE INSODE FLOYD****************)
Lemma map_Vint_injective: forall l m, map Vint l = map Vint m -> l=m.
Proof. induction l; intros.
+ destruct m; simpl in *; inv H; trivial.
+ destruct m; simpl in *; inv H. f_equal; eauto.
Qed.

(****************************************************************************)

Require Import floyd.library.

Require Import sha.spec_sha.
Require Import sha.protocol_spec_hmac.

Require Import sha.hkdf_functional_prog.
Require Import sha.hkdf.
Require Import sha.hkdf_compspecs.

Declare Module HMAC_SPEC : HMAC_ABSTRACT_SPEC.

Definition digest_len:Z := 32.
Definition expand_out_post sh PrkCont InfoCont olen out: Z * mpred :=
  let n := (olen + digest_len - 1) / digest_len in
  if zlt (olen + digest_len) olen
  then (0, memory_block sh olen out)
  else if zlt 255 n
       then (0, memory_block sh olen out)
       else (1, data_block sh (HKDF_expand PrkCont InfoCont olen) out).

Definition HKDF_expand_spec :=
  DECLARE _HKDF_expand
   WITH out: val, olen:Z,
        prk: val, PRK:spec_hmac.DATA,
        info: val, INFO:spec_hmac.DATA,
        kv:val, shmd: share
   PRE [ _out_key OF tptr tuchar, _out_len OF tuint,
         _prk OF tptr tuchar, _prk_len OF tuint,
         _info OF tptr tuchar, _info_len OF tuint]
         PROP (writable_share shmd;
               spec_hmac.has_lengthK (spec_hmac.LEN PRK) (spec_hmac.CONT PRK);
               Zlength (spec_hmac.CONT INFO) = spec_hmac.LEN INFO;
               0 <= Zlength (spec_hmac.CONT INFO) <= Int.max_unsigned /\
                 Zlength (spec_hmac.CONT INFO) + 97 < two_power_pos 61;
               0 <= olen /\ olen + 32 <= Int.max_unsigned)
         LOCAL (temp _out_key out; temp _out_len (Vint (Int.repr olen));
                temp _prk prk;
                temp _prk_len (Vint (Int.repr (spec_hmac.LEN PRK)));
                temp _info info;
                temp _info_len (Vint (Int.repr (spec_hmac.LEN INFO)));
                gvar sha._K256 kv)
         SEP(data_block Tsh (spec_hmac.CONT INFO) info;
             data_block Tsh (spec_hmac.CONT PRK) prk;
             K_vector kv;
             memory_block shmd olen out
             (*data_at_ shmd (tarray tuchar olen) out*))
  POST [ tint ] EX result:_,
          PROP (result = expand_out_post shmd (spec_hmac.CONT PRK) (spec_hmac.CONT INFO) olen out)
          LOCAL (temp ret_temp (Vint (Int.repr (fst result))))
          SEP(K_vector kv;
              data_block Tsh (spec_hmac.CONT INFO) info;
              data_block Tsh (spec_hmac.CONT PRK) prk;
              (snd result)).

Definition HKDF_extract_spec :=
  DECLARE _HKDF_extract
   WITH out: val, olen:val,
        secret: val, SECRET:spec_hmac.DATA,
        salt: val, SALT:spec_hmac.DATA,
        kv:val, shmd: share
   PRE [_out_key OF tptr tuchar, _out_len OF tptr tuint,
        _secret OF tptr tuchar, _secret_len OF tuint,
        _salt OF tptr tuchar, _salt_len OF tuint ]
         PROP (writable_share shmd; spec_hmac.has_lengthK (spec_hmac.LEN SALT) (spec_hmac.CONT SALT);
               spec_hmac.has_lengthD 512 (spec_hmac.LEN SECRET) (spec_hmac.CONT SECRET))
         LOCAL (temp _out_key out;
                temp _out_len olen;
                temp _salt salt;
                temp _salt_len (Vint (Int.repr (spec_hmac.LEN SALT)));
                temp _secret secret;
                temp _secret_len (Vint (Int.repr (spec_hmac.LEN SECRET)));
                gvar sha._K256 kv)
         SEP(data_block Tsh (spec_hmac.CONT SECRET) secret;
             data_block Tsh (spec_hmac.CONT SALT) salt;
             K_vector kv; data_at_ Tsh tuint olen;
             memory_block shmd 32 out)
  POST [ tint ]
          PROP ()
          LOCAL (temp ret_temp (Vint (Int.repr 1)))
          SEP(K_vector kv;
              data_block Tsh (spec_hmac.CONT SECRET) secret;
              data_block Tsh (spec_hmac.CONT SALT) salt; data_at Tsh tuint (Vint (Int.repr 32)) olen;
              data_block shmd (HKDF_extract (spec_hmac.CONT SALT) (spec_hmac.CONT SECRET)) out).

Definition HKDF_spec :=
  DECLARE _HKDF
   WITH out: val, olen:Z,
        secret: val, SECRET:spec_hmac.DATA,
        salt: val, SALT:spec_hmac.DATA,
        info:val, INFO:spec_hmac.DATA,
        kv:val, shmd: share
   PRE [_out_key OF tptr tuchar, _out_len OF tuint,
        _secret OF tptr tuchar, _secret_len OF tuint,
        _salt OF tptr tuchar, _salt_len OF tuint,
        _info OF tptr tuchar, _info_len OF tuint ]
         PROP (writable_share shmd;
               spec_hmac.has_lengthK (spec_hmac.LEN SALT) (spec_hmac.CONT SALT);
               spec_hmac.has_lengthD 512 (spec_hmac.LEN SECRET) (spec_hmac.CONT SECRET);
               Zlength (spec_hmac.CONT INFO) = spec_hmac.LEN INFO;
               0 <= Zlength (spec_hmac.CONT INFO) <= Int.max_unsigned;
               Zlength (spec_hmac.CONT INFO) + 97 < two_power_pos 61;
               0 <= olen; olen + 32 <= Int.max_unsigned)
         LOCAL (temp _out_key out; temp _out_len (Vint (Int.repr olen));
                temp _salt salt;
                temp _salt_len (Vint (Int.repr (spec_hmac.LEN SALT)));
                temp _secret secret;
                temp _secret_len (Vint (Int.repr (spec_hmac.LEN SECRET)));
                temp _info info;
                temp _info_len (Vint (Int.repr (spec_hmac.LEN INFO)));
                gvar sha._K256 kv)
         SEP(data_block Tsh (spec_hmac.CONT SECRET) secret;
             data_block Tsh (spec_hmac.CONT SALT) salt;
             data_block Tsh (spec_hmac.CONT INFO) info;
             K_vector kv;
             memory_block shmd olen out)
  POST [ tint ] EX r:Z,
          PROP ()
          LOCAL (temp ret_temp (Vint (Int.repr r)))
          SEP(K_vector kv;
              data_block Tsh (spec_hmac.CONT SECRET) secret;
              data_block Tsh (spec_hmac.CONT SALT) salt;
              data_block Tsh (spec_hmac.CONT INFO) info;
              if zlt 255 ((olen + 31) / 32)
              then (!!(r=0) && memory_block shmd olen out)
              else (!!(r=1) && data_block shmd (HKDF (spec_hmac.CONT SALT) (spec_hmac.CONT SECRET) (spec_hmac.CONT INFO) olen) out)).

(*generalizes spec_sha.memcpy_spec by allowing SRC/TGT-array to be longer than necessary.
 Also adds cs to the WITH clause. Because we're copying a tarray tuchar we don't need a
field_compatible/size_compatible side condition (cf Lemma memory_block_data_at__tarray_tuchar) *)
Definition memcpy_tuchar_array_spec :=
  DECLARE _memcpy
   WITH cs:compspecs, sh : share*share, p: val, q: val, n: Z, m:Z, k:Z, contents: list int
   PRE [ 1%positive OF tptr tvoid, 2%positive OF tptr tvoid, 3%positive OF tuint ]
       PROP (readable_share (fst sh); writable_share (snd sh); 0 <= k <= n;
       k <= m <= Int.max_unsigned)
       LOCAL (temp 1%positive p; temp 2%positive q; temp 3%positive (Vint (Int.repr k)))
       SEP (@data_at cs (fst sh) (tarray tuchar m) (map Vint contents) q;
            @memory_block (snd sh) n p)
    POST [ tptr tvoid ]
       PROP() LOCAL(temp ret_temp p)
       SEP(data_at (fst sh) (tarray tuchar m) (map Vint contents) q;
           data_at (snd sh) (tarray tuchar k) (map Vint (sublist 0 k contents)) p;
           memory_block (snd sh) (n-k) (offset_val k p)).
(*Definition memcpy_spec := (_memcpy, snd spec_sha.memcpy_spec). *)

(***************** We combine all specifications to a specification context *******)

(*Definition SHA256_spec := (_SHA256, snd spec_sha.SHA256_spec). *)(*
Definition sha256init_spec := (_SHA256_Init, snd SHA256_Init_spec).
Definition sha256update_spec := (_SHA256_Update, snd SHA256_Update_spec).
Definition sha256final_spec := (_SHA256_Final, snd SHA256_Final_spec).
Definition memset_spec := (_memset, snd spec_sha.memset_spec). *)

Definition Hkdf_VarSpecs : varspecs := (sha._K256, tarray tuint 64)::nil.

Definition hmac_init_funspec:=
    (WITH x : val * Z * list Z * val + val * Z * list Z * val * val
     PRE
     [(hmac._ctx, tptr spec_hmac.t_struct_hmac_ctx_st), (hmac._key, tptr tuchar),
     (hmac._len, tint)] match x with
                        | inl (c, l, key, kv) =>
                            PROP ( )
                            LOCAL (temp hmac._ctx c; temp hmac._key nullval;
                            temp hmac._len (Vint (Int.repr l));
                            gvar sha._K256 kv)
                            SEP (HMAC_SPEC.FULL key c;
                            spec_sha.K_vector kv)
                        | inr (c, l, key, kv, k) =>
                            PROP (spec_hmac.has_lengthK l key)
                            LOCAL (temp hmac._ctx c; temp hmac._key k;
                            temp hmac._len (Vint (Int.repr l));
                            gvar sha._K256 kv)
                            SEP (HMAC_SPEC.EMPTY c;
                            spec_sha.data_block Tsh key k;
                            spec_sha.K_vector kv)
                        end
     POST [tvoid] match x with
                  | inl (c, _, key, kv) =>
                      PROP ( )
                      LOCAL ()
                      SEP (HMAC_SPEC.REP
                             (HMAC_SPEC.hABS key []) c;
                      spec_sha.K_vector kv)
                  | inr (c, _, key, kv, k) =>
                      PROP ( )
                      LOCAL ()
                      SEP (HMAC_SPEC.REP
                             (HMAC_SPEC.hABS key []) c;
                      spec_sha.data_block Tsh key k;
                      spec_sha.K_vector kv)
                  end).

Definition Hkdf_FunSpecs : funspecs := ltac:(with_library prog (
  HKDF_spec :: HKDF_expand_spec :: HKDF_extract_spec ::
  memcpy_tuchar_array_spec:: (*memcpy__data_at:: *)
  (*memset_spec::*)
  (HMAC_SPEC.hmac_update_spec)::
  (HMAC_SPEC.hmac_final_spec)::
  (HMAC_SPEC.hmac_cleanup_spec)::
  (_HMAC_Init, hmac_init_funspec)::
  (HMAC_SPEC.hmac_crypto_spec)::nil)).
(*
Inductive augmentFunspecsResult :=
  OK_aFR: funspecs -> augmentFunspecsResult
| DeleteErr_aFR: ident -> augmentFunspecsResult
| NoDeletaErr_aFR: ident -> augmentFunspecsResult
| MismatchErr_aFR: list ident ->  augmentFunspecsResult.

Fixpoint my_augment_funspecs' (fds: list (ident * fundef)) (G:funspecs) :augmentFunspecsResult :=
 match fds with
 | (i,fd)::fds' => match delete_id i G with
                       | Some (f, G') =>
                              match my_augment_funspecs' fds' G' with
                               | OK_aFR G2 => OK_aFR ((i,f)::G2)
                               | DeleteErr_aFR i => DeleteErr_aFR i
                               | NoDeletaErr_aFR i => NoDeletaErr_aFR i
                               | MismatchErr_aFR l => MismatchErr_aFR l
                              end
                       | None =>
                              match my_augment_funspecs' fds' G with
                               | OK_aFR G2 => OK_aFR ((i, vacuous_funspec fd)::G2)
                               | DeleteErr_aFR i => DeleteErr_aFR i
                               | NoDeletaErr_aFR i => NoDeletaErr_aFR i
                               | MismatchErr_aFR l => MismatchErr_aFR l
                              end
                        end
 | nil => match G with nil => OK_aFR nil | (* _::_ => None*) (h::t) => MismatchErr_aFR (map fst (h::t)) end
 end.
(*
Fixpoint my_augment_funspecs' (fds: list (ident * fundef)) (G:funspecs) : option funspecs :=
 match fds with
 | (i,fd)::fds' => match delete_id i G with
                       | Some (f, G') =>
                              match my_augment_funspecs' fds' G' with
                               | Some G2 => Some ((i,f)::G2)
                               | None => None
                              end
                       | None =>
                              match my_augment_funspecs' fds' G with
                               | Some G2 => Some ((i, vacuous_funspec fd)::G2)
                               | None => None
                              end
                        end
 | nil => match G with nil => Some nil | _::_ => None end
 end.*)

Definition StringofPos (p:positive): string := String (Coq.Strings.Ascii.ascii_of_pos p) EmptyString.

Delimit Scope string_scope with string.
Bind Scope string_scope with string.
Open Local Scope string_scope.
Definition printlist (l:list ident):string := List.fold_right (fun p s => String (Coq.Strings.Ascii.ascii_of_pos p) s) EmptyString l.

Ltac mywith_library' p G :=
  let x := eval hnf in (my_augment_funspecs' (prog_funct p) G) in match x with
  | OK_aFR ?l => exact l
  | DeleteErr_aFR ?i => let v := constr:("Delete " ++ (StringofPos i)) in fail 5 v
  | NoDeletaErr_aFR ?i => let v:= constr:("NoDelete " ++ (StringofPos i)) in fail 5 v
  | MismatchErr_aFR ?l => let v := constr:("Mismatch " ++ printlist (map fst l))
                          in fail 5 v
  end.

Ltac mywith_library prog G := mywith_library' prog G.
Locate _HMAC.
Definition Hkdf_FunSpecs : funspecs := ltac:(with_library prog (
(*  HKDF_spec :: HKDF_expand_spec :: HKDF_extract_spec ::
  memcpy_spec:: (*memcpy__data_at:: *)
  (*memset_spec::*)
  HMAC_SPEC.hmac_update_spec::
  HMAC_SPEC.hmac_final_spec::
  HMAC_SPEC.hmac_cleanup_spec::
  (_HMAC_Init,hmac_init_funspec)::*)
  _HMAC, (snd HMAC_SPEC.hmac_crypto_spec)::nil)).
Definition Hkdf_FunSpecs : funspecs := ltac:(with_library prog (
  HKDF_spec :: HKDF_expand_spec :: HKDF_extract_spec ::
  memcpy_spec:: (*memcpy__data_at:: *)
  (*memset_spec::*)
  HMAC_SPEC.hmac_update_spec::
  HMAC_SPEC.hmac_final_spec::
  HMAC_SPEC.hmac_cleanup_spec::
  (_HMAC_Init,hmac_init_funspec)::
  HMAC_SPEC.hmac_crypto_spec::nil)).
(*
Definition HMS : hmacstate := default_val t_struct_hmac_ctx_st.

Lemma change_compspecs_t_struct_SHA256state_st:
  @data_at spec_sha.CompSpecs Tsh t_struct_SHA256state_st =
  @data_at CompSpecs Tsh t_struct_SHA256state_st.
Proof.
extensionality gfs v.
reflexivity.
Qed.

Hint Rewrite change_compspecs_t_struct_SHA256state_st : norm.
*)
*)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C IB XB IA XA X : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ IB B /\ (wd_ IA A /\ (wd_ XA B /\ (wd_ XB A /\ (wd_ X A /\ (wd_ X B /\ (wd_ XB B /\ (wd_ XA A /\ (col_ A C X /\ (col_ C A IA /\ (col_ IA A B /\ (col_ XA X A /\ (col_ XB X B /\ (col_ B XA C /\ (col_ A XB C /\ (col_ A XA IA /\ col_ B XB IB))))))))))))))))))) -> col_ C A B)).
Proof.
  time tac.
Qed.

End FOFProblem.