(* This file defines a common storage format for countable types.
This format, SerializedValue, is either a unit/int/bool or a pair/list
of these. We also define Serializable as a type class capturing that a
type can be converted from and to this format. *)

From ConCert.Execution Require Import Monad.
From ConCert.Execution Require Import OptionMonad.
From ConCert.Execution Require Import Containers.
From ConCert.Execution Require Import BoundedN.
From Coq Require Import Ascii.
From Coq Require Import List.
From Coq Require Import Psatz.
From Coq Require Import String.
From Coq Require Import ZArith.

Import ListNotations.

Inductive SerializedType :=
  | ser_unit : SerializedType
  | ser_int : SerializedType
  | ser_bool : SerializedType
  | ser_pair : SerializedType -> SerializedType -> SerializedType
  | ser_list : SerializedType -> SerializedType.

Module SerializedType.
  Scheme Equality for SerializedType.
  Definition eqb := SerializedType_beq.
  Definition eq_dec := SerializedType_eq_dec.

  Fixpoint eqb_spec (a b : SerializedType) :
    Bool.reflect (a = b) (eqb a b).
  Proof.
    destruct a, b; cbn in *; try (left; congruence); try (right; congruence).
    - destruct (eqb_spec a1 b1), (eqb_spec a2 b2);
        try (left; congruence); try (right; congruence).
    - destruct (eqb_spec a b); try (left; congruence); try (right; congruence).
  Qed.
End SerializedType.

Fixpoint interp_type (t : SerializedType) : Type :=
  match t with
  | ser_unit => unit
  | ser_int => Z
  | ser_bool => bool
  | ser_pair a b => interp_type a * interp_type b
  | ser_list a => list (interp_type a)
  end.

Set Primitive Projections.
Record SerializedValue :=
  build_ser_value {
    ser_value_type : SerializedType;
    ser_value : interp_type ser_value_type;
  }.
Unset Primitive Projections.

Definition extract_ser_value (t : SerializedType)
                             (value : SerializedValue)
                             : option (interp_type t).
Proof.
  destruct value as [ty val].
  destruct (SerializedType.eq_dec t ty).
  - subst. exact (Some val).
  - exact None.
Defined.

(* Defines that a type can be serialized into SerializedValue
   and deserialized from it, and that deserializing is a left
   inverse of serializing. *)
Class Serializable (ty : Type) :=
  build_serializable {
    serialize : ty -> SerializedValue;
    deserialize : SerializedValue -> option ty;
    deserialize_serialize x : deserialize (serialize x) = Some x;
  }.

Global Opaque serialize deserialize deserialize_serialize.

Lemma serialize_injective {T : Type} `{Serializable T} x y :
  serialize x = serialize y ->
  x = y.
Proof.
  intros eq.
  enough (Some x = Some y) by congruence.
  rewrite <- 2!deserialize_serialize.
  now rewrite eq.
Qed.

#[export]
Program Instance unit_serializable : Serializable unit :=
  {| serialize u := build_ser_value ser_unit u;
     deserialize := extract_ser_value ser_unit; |}.
Solve Obligations with reflexivity.

#[export]
Program Instance int_serializable : Serializable Z :=
  {| serialize i := build_ser_value ser_int i;
     deserialize := extract_ser_value ser_int; |}.
Solve Obligations with reflexivity.

#[export]
Program Instance bool_serializable : Serializable bool :=
  {| serialize b := build_ser_value ser_bool b;
     deserialize := extract_ser_value ser_bool; |}.
Solve Obligations with reflexivity.

#[export]
Program Instance nat_serializable : Serializable nat :=
  {| serialize n := serialize (Z.of_nat n);
     deserialize z := do z' <- deserialize z;
                      if (z' <? 0)%Z
                      then None
                      else Some (Z.to_nat z'); |}.
Next Obligation.
  intros x.
  cbn.
  rewrite deserialize_serialize.
  cbn.
  rewrite Nat2Z.id.
  specialize (Nat2Z.is_nonneg x) as H.
  apply Z.ltb_ge in H.
  rewrite H.
  reflexivity.
Qed.

#[export]
Program Instance N_serializable : Serializable N :=
  {| serialize n := serialize (Z.of_N n);
     deserialize z := do z' <- deserialize z;
                      if (z' <? 0)%Z
                      then None
                      else Some (Z.to_N z'); |}.
Next Obligation.
  intros x.
  cbn.
  rewrite deserialize_serialize.
  cbn.
  rewrite N2Z.id.
  specialize (N2Z.is_nonneg x) as H.
  apply Z.ltb_ge in H.
  rewrite H.
  reflexivity.
Qed.

#[export]
Program Instance ser_positive_equivalence : Serializable positive :=
  {| serialize p := serialize (Zpos p);
     deserialize z := do z' <- deserialize z;
                      if (0 <? z')%Z
                      then Some (Z.to_pos z')
                      else None; |}.
Solve Obligations with auto.

#[export]
Program Instance ser_value_equivalence : Serializable SerializedValue :=
  {| serialize v := v;
     deserialize v := Some v; |}.
Solve Obligations with reflexivity.

#[export]
Program Instance BoundedN_equivalence {bound : N} : Serializable (BoundedN bound) :=
  {| serialize bn := serialize (countable.encode bn);
    deserialize v :=
      do p <- (deserialize v : option positive);
      countable.decode p |}.
Next Obligation.
  intros bound x.
  cbn.
  rewrite deserialize_serialize.
  cbn.
  now rewrite countable.decode_encode.
Qed.

(* Program Instance generates an insane amount of obligations for sums,
   so we define it by ourselves. *)
Section Sum.
  Context `{Serializable A} `{Serializable B}.

  Definition serialize_sum (v : A + B) :=
    let (is_left, ser) :=
        match v with
        | inl l => (true, serialize l)
        | inr r => (false, serialize r)
        end in
    build_ser_value (ser_pair ser_bool ser.(ser_value_type)) (is_left, ser.(ser_value)).

  Definition deserialize_sum (val : SerializedValue) : option (A + B) :=
    match val with
    | build_ser_value (ser_pair ser_bool v) (is_left, val) =>
      if is_left then
        do a <- deserialize (build_ser_value v val) : option A;
        Some (inl a)
      else
        do b <- deserialize (build_ser_value v val) : option B;
        Some (inr b)
    | _ => None
    end.

  Lemma deserialize_serialize_sum (s : A + B)
    : deserialize_sum (serialize_sum s) = Some s.
  Proof.
    unfold serialize_sum, deserialize_sum.
    destruct s as [a | b]; cbn; rewrite deserialize_serialize; reflexivity.
  Qed.

  Global Instance sum_serializable : Serializable (A + B) :=
    {| serialize := serialize_sum;
       deserialize := deserialize_sum;
       deserialize_serialize := deserialize_serialize_sum; |}.
End Sum.

Section Product.
  Context `{Serializable A} `{Serializable B}.

  Definition serialize_product (pair : A * B) : SerializedValue :=
    let (a, b) := pair in
    let (a_ty, a_val) := serialize a in
    let (b_ty, b_val) := serialize b in
    build_ser_value (ser_pair a_ty b_ty) (a_val, b_val).

  Definition deserialize_product (val : SerializedValue) : option (A * B) :=
    match val with
    | build_ser_value (ser_pair a_ty b_ty) (a_val, b_val) =>
      do a <- deserialize (build_ser_value a_ty a_val) : option A;
      do b <- deserialize (build_ser_value b_ty b_val) : option B;
      Some (a, b)
    | _ => None
    end.

  Lemma deserialize_serialize_product (p : A * B)
        : deserialize_product (serialize_product p) = Some p.
  Proof.
    unfold serialize_product, deserialize_product.
    destruct p.
    repeat rewrite deserialize_serialize.
    reflexivity.
  Qed.

  Global Instance product_serializable : Serializable (A * B) :=
    {| serialize := serialize_product;
       deserialize := deserialize_product;
       deserialize_serialize := deserialize_serialize_product; |}.
End Product.

Section List.
  Context `{Serializable A}.

  Definition serialize_list (l : list A) : SerializedValue :=
    let go a (acc : SerializedValue) :=
        let (a_ty, a_val) := serialize a in
        let (acc_ty, acc_val) := acc in
        build_ser_value (ser_pair a_ty acc_ty) (a_val, acc_val) in
    fold_right go (build_ser_value ser_unit tt) l.

  Definition deserialize_list (val : SerializedValue) : option (list A) :=
    let fix aux (ty : SerializedType) (val : interp_type ty) : option (list A) :=
        match ty, val with
        | ser_pair hd_ty tl_ty, (hd_val, tl_val) =>
          do hd <- deserialize (build_ser_value hd_ty hd_val);
          do tl <- aux tl_ty tl_val;
          Some (hd :: tl)
        | ser_unit, _ => Some []
        | _, _ => None
        end in
    let (ty, uval) := val in
    aux ty uval.

  Lemma deserialize_serialize_list (l : list A)
        : deserialize_list (serialize_list l) = Some l.
  Proof.
    unfold serialize_list, deserialize_list.
    induction l as [| hd tl IHl].
    - reflexivity.
    - cbn in *.
      rewrite IHl; clear IHl.
      rewrite deserialize_serialize.
      reflexivity.
  Qed.

  Global Instance list_serializable : Serializable (list A) :=
    {| serialize := serialize_list;
       deserialize := deserialize_list;
       deserialize_serialize := deserialize_serialize_list; |}.
End List.

#[export]
Program Instance map_serializable
        `{Serializable A}
        `{countable.Countable A}
        `{Serializable B}
  : Serializable (FMap A B) :=
  {| serialize m := serialize (@FMap.elements A B _ _ m);
     deserialize val :=
       do elems <- deserialize val : option (list (A * B));
       Some (FMap.of_list elems); |}.
Next Obligation.
  intros.
  cbn.
  rewrite deserialize_serialize.
  cbn.
  rewrite FMap.of_elements_eq.
  reflexivity.
Qed.

#[export]
Program Instance set_serializable
        `{Serializable A}
        `{countable.Countable A}
  : Serializable (FMap A unit) :=
  {| serialize s := serialize (@FMap.elements A unit _ _ s);
     deserialize val :=
       do elems <- deserialize val : option (list (A * unit));
       Some (FMap.of_list elems); |}.
Next Obligation.
  intros.
  cbn.
  rewrite deserialize_serialize.
  cbn.
  rewrite FMap.of_elements_eq.
  reflexivity.
Qed.

#[export]
Program Instance option_serializable `{Serializable A} : Serializable (option A) :=
  {| serialize s := serialize
                      match s with
                      | None => inl tt
                      | Some s => inr s
                      end;
     deserialize s := do s <- deserialize s;
                      match s : unit + A with
                      | inl _ => Some None
                      | inr s => Some (Some s)
                      end; |}.
Next Obligation.
  intros.
  cbn.
  rewrite deserialize_serialize.
  cbn.
  destruct x; auto.
Qed.

#[export]
Program Instance ascii_serializable : Serializable ascii :=
  {| serialize a := serialize (Ascii.N_of_ascii a);
     deserialize p := do p <- deserialize p;
                      if (p <? 256)%N then Some (Ascii.ascii_of_N p)
                      else None; |}.
Next Obligation.
  intros.
  cbn.
  rewrite deserialize_serialize.
  specialize (N_ascii_bounded x) as H.
  apply N.ltb_lt in H.
  rewrite H.
  apply f_equal.
  apply ascii_N_embedding.
Qed.

#[export]
Program Instance string_serializable : Serializable string :=
  {| serialize s := serialize (list_ascii_of_string s);
     deserialize p := do la <- deserialize p;
                      Some (string_of_list_ascii la); |}.
Next Obligation.
  intros.
  cbn.
  rewrite deserialize_serialize.
  apply f_equal.
  apply string_of_list_ascii_of_string.
Qed.

Ltac make_serializer_case ty :=
  match ty with
  | ?T1 -> ?T2 =>
    let rest := make_serializer_case T2 in
    constr:(fun (f : SerializedValue -> SerializedValue) (v : T1) =>
              rest (fun (cur : SerializedValue) => f (serialize (v, cur))))
  | SerializedValue =>
    constr:(fun (f : SerializedValue -> SerializedValue) => f (serialize tt))
  end.

Ltac make_serializer_aux term tag :=
  match type of term with
  | ?T1 -> (?T2 -> ?T3) =>
    let cs := make_serializer_case T1 in
    let cs := constr:(cs (fun x => serialize (tag, x))) in
    let term := (eval hnf in (term cs)) in
    make_serializer_aux term (S tag)
  | ?T -> SerializedValue =>
    term
  end.

Ltac make_serializer eliminator :=
  let term := (eval hnf in (eliminator (fun _ => SerializedValue))) in
  let serializer := make_serializer_aux term 0 in
  eval cbn in serializer.

Ltac make_deserializer_case ty :=
  match ty with
  | ?T1 -> ?T2 =>
    let rest := make_deserializer_case T2 in
    constr:(fun builder sv =>
              do '(a, sv) <- (deserialize sv : option (T1 * SerializedValue));
              rest (builder a) sv)
  | ?T => constr:(fun (value : T) (sv : SerializedValue) =>
              do _ <- (deserialize sv : option unit);
              Some value)
  end.

Ltac make_deserializer_aux ctors rty :=
  match ctors with
  | (?ctor, ?tl) =>
    let ty := type of ctor in
    let cs := make_deserializer_case ty in
    let rest := make_deserializer_aux tl rty in
    constr:(
      fun tag sv =>
        match tag with
        | 0 => cs ctor sv
        | S tag => rest tag sv
        end)
  | tt => constr:(fun (tag : nat) (sv : SerializedValue) => @None rty)
  end.

Ltac get_final_type ty :=
  match ty with
  | ?T1 -> ?T2 => get_final_type T2
  | ?T => T
  end.

Ltac make_deserializer ctors rty :=
  let deser := make_deserializer_aux ctors rty in
  let deser := constr:(fun sv => do '(tag, sv) <- deserialize sv; deser tag sv) in
  eval cbn in deser.

Ltac get_ty_from_elim_ty ty :=
  match ty with
  | forall (_ : ?T -> Type), _ => T
  end.

Ltac make_serializable eliminator ctors :=
  let ser := make_serializer eliminator in
  let elim_ty := type of eliminator in
  let ty := get_ty_from_elim_ty elim_ty in
  let deser := make_deserializer ctors ty in
  exact
    {| serialize := ser;
       deserialize := deser;
       deserialize_serialize :=
         ltac:(intros []; repeat (cbn in *; try rewrite deserialize_serialize; auto)) |}.

Notation "'Derive' 'Serializable' rect" :=
  ltac:(make_serializable rect tt) (at level 0, rect at level 10, only parsing).

Notation "'Derive' 'Serializable' rect < c0 , .. , cn >" :=
  (let pairs := pair c0 .. (pair cn tt) .. in
   ltac:(
     (* This matches last-to-first so it always finds 'pairs' *)
     match goal with
     | [pairs := ?x |- _] => make_serializable rect x
     end))
    (at level 0, rect at level 10, c0, cn at level 9, only parsing).

Section Countable.
  Instance SerializedType_interp_EqDecision
           (t : SerializedType) : stdpp.base.EqDecision (interp_type t).
  Proof. induction t; typeclasses eauto. Defined.
  Instance SerializedType_interp_Countable
           (t : SerializedType) : countable.Countable (interp_type t).
  Proof. induction t; typeclasses eauto. Defined.

  Global Instance SerializedValue_EqDecision : stdpp.base.EqDecision SerializedValue.
  Proof.
    intros x y.
    destruct x as [xt xv], y as [yt yv].
    destruct (SerializedType.eq_dec xt yt) as [<-|?]; [|right; congruence].
    destruct (stdpp.base.decide (xv = yv)).
    - left.
      congruence.
    - right.
      intros eq.
      inversion eq.
      congruence.
  Defined.

  Instance SerializedType_EqDecision : stdpp.base.EqDecision SerializedType.
  Proof.
    intros x y.
    destruct (SerializedType.eq_dec x y) as [<-|?]; [left|right]; easy.
  Defined.
  Fixpoint depth st : nat :=
    match st with
    | ser_unit => 1
    | ser_int => 1
    | ser_bool => 1
    | ser_pair x y => S (max (depth x) (depth y))
    | ser_list x => S (depth x)
    end.
  Local Open Scope positive.
  Fixpoint encode_st_body (st : SerializedType) : positive :=
    match st with
    | ser_unit => countable.encode (1, 1)
    | ser_int => countable.encode (2, 1)
    | ser_bool => countable.encode (3, 1)
    | ser_pair x y =>
        countable.encode (4, countable.encode (encode_st_body x, encode_st_body y))
    | ser_list x => countable.encode (5, encode_st_body x)
    end.
  Definition encode_st (st : SerializedType) : positive :=
    countable.encode (depth st, encode_st_body st).

  Fixpoint decode_st_body (depth : nat) (p : positive) : option SerializedType :=
    match depth with
    | 0%nat => None
    | S depth =>
      do '(tag, body) <- countable.decode p;
      match tag with
      | 1 => ret ser_unit
      | 2 => ret ser_int
      | 3 => ret ser_bool
      | 4 => do '(x, y) <- countable.decode body;
             do x <- decode_st_body depth x;
             do y <- decode_st_body depth y;
             ret (ser_pair x y)
      | 5 => do x <- decode_st_body depth body;
             ret (ser_list x)
      | _ => None
      end
    end.
  Definition decode_st (p : positive) : option SerializedType :=
    do '(depth, body) <- countable.decode p;
    decode_st_body depth body.

  Local Open Scope nat.
  Lemma decode_st_body_encode_st_body (d : nat) (st : SerializedType) :
    depth st <= d ->
    decode_st_body d (encode_st_body st) = Some st.
  Proof.
    revert st.
    induction d; intros st dle; cbn in *.
    - exfalso.
      induction st; cbn in *; lia.
    - destruct st; auto; cbn in *.
      + now rewrite !countable.decode_encode, !IHd by lia.
      + now rewrite !countable.decode_encode, !IHd by lia.
  Qed.

  Lemma decode_st_encode_st (st : SerializedType) :
    decode_st (encode_st st) = Some st.
  Proof.
    unfold decode_st, encode_st.
    rewrite countable.decode_encode; cbn.
    now apply decode_st_body_encode_st_body.
  Qed.

  Local Open Scope positive.
  Instance SerializedType_Countable : countable.Countable SerializedType :=
    {| countable.encode := encode_st;
       countable.decode := decode_st;
       countable.decode_encode := decode_st_encode_st |}.

  Definition encode_sv (sv : SerializedValue) : positive :=
    countable.encode (ser_value_type sv, countable.encode (ser_value sv)).

  Definition decode_sv (p : positive) : option SerializedValue :=
    do '(ty, p) <- countable.decode p;
    do v <- countable.decode p;
    ret {| ser_value_type := ty; ser_value := v |}.

  Lemma decode_sv_encode_sv (sv : SerializedValue) :
    decode_sv (encode_sv sv) = Some sv.
  Proof.
    unfold decode_sv, encode_sv.
    rewrite countable.decode_encode; cbn.
    rewrite countable.decode_encode; cbn.
    reflexivity.
  Qed.

  Global Instance SerializedValue_Countable : countable.Countable SerializedValue :=
    {| countable.encode := encode_sv;
       countable.decode := decode_sv;
       countable.decode_encode := decode_sv_encode_sv |}.

  (* Low priority to always pick 'direct' EqDecision instances first *)
  Global Instance SerializableType_EqDecision
         (A : Type) `{Serializable A} : stdpp.base.EqDecision A | 1000.
  Proof.
    intros a a'.
    destruct (stdpp.base.decide (serialize a = serialize a')) as [eq|neq].
    - left.
      now apply serialize_injective.
    - right.
      intros ->.
      congruence.
  Defined.

  Definition encode_serializable_type {A : Type} `{Serializable A} (a : A) : positive :=
    countable.encode (serialize a).

  Definition decode_serializable_type {A : Type}
                                      `{Serializable A}
                                      (p : positive)
                                      : option A :=
    countable.decode p >>= deserialize.

  Lemma decode_serializable_type_encode_serializable_type
        {A : Type} `{Serializable A}
        (a : A) :
    decode_serializable_type (encode_serializable_type a) = Some a.
  Proof.
    unfold decode_serializable_type, encode_serializable_type.
    rewrite countable.decode_encode.
    cbn.
    now rewrite deserialize_serialize.
  Qed.

  (* Low priority to always pick 'direct' Countable instances first *)
  Global Instance SerializableType_Countable {A : Type} `{Serializable A} :
    countable.Countable A | 1000 :=
    {| countable.encode := encode_serializable_type;
       countable.decode := decode_serializable_type;
       countable.decode_encode := decode_serializable_type_encode_serializable_type; |}.
End Countable.

Section RightInverse.
Local Transparent deserialize serialize.

Lemma deserialize_unit_right_inverse : forall x (y : unit),
  deserialize x = Some y ->
  x = serialize y.
Proof.
  intros * deser_some.
  destruct x as [ty val].
  destruct ty;
    now inversion_clear deser_some.
Qed.

Lemma deserialize_int_right_inverse : forall x (y : Z),
  deserialize x = Some y ->
  x = serialize y.
Proof.
  intros * deser_some.
  destruct x as [ty val].
  destruct ty;
    now inversion_clear deser_some.
Qed.

Lemma deserialize_bool_right_inverse : forall x (y : bool),
  deserialize x = Some y ->
  x = serialize y.
Proof.
  intros * deser_some.
  destruct x as [ty val].
  destruct ty;
    now inversion_clear deser_some.
Qed.

Lemma deserialize_nat_right_inverse : forall x (y : nat),
  deserialize x = Some y ->
  x = serialize y.
Proof.
  intros * deser_some.
  apply deserialize_int_right_inverse.
  cbn in *.
  destruct extract_ser_value;
    try discriminate.
  destruct (i <? 0)%Z eqn:H;
    try discriminate.
  apply Z.ltb_ge in H.
  inversion_clear deser_some.
  rewrite Z2Nat.id by assumption.
  reflexivity.
Qed.

Lemma deserialize_N_right_inverse : forall x (y : N),
  deserialize x = Some y ->
  x = serialize y.
Proof.
  intros * deser_some.
  apply deserialize_int_right_inverse.
  cbn in *.
  destruct extract_ser_value;
    try discriminate.
  destruct (i <? 0)%Z eqn:H;
    try discriminate.
  apply Z.ltb_ge in H.
  inversion_clear deser_some.
  rewrite Z2N.id by assumption.
  reflexivity.
Qed.

Lemma deserialize_positive_right_inverse : forall x (y : positive),
  deserialize x = Some y ->
  x = serialize y.
Proof.
  intros * deser_some.
  apply deserialize_int_right_inverse.
  cbn in *.
  destruct extract_ser_value;
    try discriminate.
  destruct (0 <? i)%Z eqn:H;
    try discriminate.
  apply Z.ltb_lt in H.
  inversion_clear deser_some.
  rewrite Z2Pos.id by assumption.
  reflexivity.
Qed.

Lemma deserialize_serialized_value_right_inverse : forall x (y : SerializedValue),
  deserialize x = Some y ->
  x = serialize y.
Proof.
  intros * deser_some.
  now inversion deser_some.
Qed.

Lemma deserialize_sum_right_inverse : forall {A B : Type} `{Serializable A} `{Serializable B}
                                              x (y : A + B),
  (forall x' (y' : A), deserialize x' = Some y' -> x' = serialize y') ->
  (forall x' (y' : B), deserialize x' = Some y' -> x' = serialize y') ->
  deserialize x = Some y ->
  x = serialize y.
Proof.
  cbn.
  unfold serialize_sum, deserialize_sum in *.
  destruct x as [ty val].
  intros * HA HB deser_some.
  destruct ty;
    try discriminate.
  destruct ty1;
    try discriminate.
  destruct val.
  destruct i; cbn in *;
    destruct deserialize eqn:deser_a_some;
    try discriminate;
    inversion_clear deser_some.
  - apply HA in deser_a_some as <-.
    reflexivity.
  - apply HB in deser_a_some as <-.
    reflexivity.
Qed.

Lemma deserialize_product_right_inverse : forall {A B : Type} `{Serializable A} `{Serializable B}
                                              x (y : A * B),
  (forall x' (y' : A), deserialize x' = Some y' -> x' = serialize y') ->
  (forall x' (y' : B), deserialize x' = Some y' -> x' = serialize y') ->
  deserialize x = Some y ->
  x = serialize y.
Proof.
  cbn.
  unfold serialize_product, deserialize_product.
  destruct x as [ty val].
  intros * HA HB deser_some.
  destruct ty;
    try discriminate.
  destruct val.
  cbn in *.
  destruct deserialize eqn:deser_a_some in deser_some;
    try discriminate.
  destruct deserialize eqn:deser_b_some in deser_some;
    try discriminate.
  inversion_clear deser_some.
  apply HA in deser_a_some as <-.
  apply HB in deser_b_some as <-.
  reflexivity.
Qed.

Lemma deserialize_list_right_inverse : forall {A : Type} `{Serializable A} (l : list A) x,
  (forall x' (l' : A), deserialize x' = Some l' -> x' = serialize l') ->
  deserialize x = Some l ->
  x = serialize l.
Proof.
  cbn.
  (* unfold serialize_list, deserialize_list. *)
  destruct x as [ty val]. cbn.
  generalize dependent ty.
  induction l as [| hd tl IHl];
    intros * HA deser_some;
    cbn.
  -
    destruct ty;
      try discriminate;
      destruct val;
      auto.
    repeat match goal with
    | H : match ?x with | Some _ => _ | None => _ end = _ |- _ => destruct x
    end;
    discriminate.
  - destruct ty;
      try discriminate.
    destruct val.
    destruct deserialize eqn:deser_hd_some in deser_some;
      try discriminate.
    match goal with
    | H : match ?x with | Some _ => _ | None => _ end = _ |- _ => destruct x eqn:H1
    end;
    try discriminate.
    inversion deser_some. subst.
    apply HA in deser_hd_some as <-.
    apply IHl in H1; auto.
    unfold serialize_list in H1.
    rewrite <- H1.
    reflexivity.
Qed.

Lemma deserialize_option_right_inverse : forall {A : Type} `{Serializable A} x (y : option A),
  (forall x' (y' : A), deserialize x' = Some y' -> x' = serialize y') ->
  deserialize x = Some y ->
  x = serialize y.
Proof.
  intros * H deser_some.
  specialize deserialize_unit_right_inverse as H1.
  apply deserialize_sum_right_inverse; auto.
  clear H H1.
  cbn in *.
  destruct deserialize_sum;
    try discriminate.
  destruct s;
    inversion_clear deser_some;
    auto.
  now destruct u.
Qed.

Lemma deserialize_ascii_right_inverse : forall x (y : ascii),
  deserialize x = Some y ->
  x = serialize y.
Proof.
  intros * deser_some.
  apply deserialize_N_right_inverse.
  unfold deserialize, ascii_serializable in deser_some.
  destruct deserialize;
    try discriminate.
  cbn in *.
  destruct (n <? 256)%N eqn:H;
    inversion_clear deser_some.
  apply N.ltb_lt in H.
  now rewrite N_ascii_embedding.
Qed.

Lemma deserialize_string_right_inverse : forall x (y : string),
  deserialize x = Some y ->
  x = serialize y.
Proof.
  intros * deser_some.
  specialize deserialize_ascii_right_inverse as H.
  apply deserialize_list_right_inverse; auto.
  clear H.
  cbn in *.
  destruct deserialize_list;
    try discriminate.
  inversion_clear deser_some.
  rewrite list_ascii_of_string_of_list_ascii.
  reflexivity.
Qed.

Local Opaque deserialize serialize.
End RightInverse.


Require Export Iron.Language.SystemF2Cap.Step.TypeC.
Require Export Iron.Language.SystemF2Cap.Store.LiveE.
Require Export Iron.Language.SystemF2Cap.Store.LiveS.

(* Evaluation is done when the stack is empty and the expression has
   been reduced to a value. *)
Definition done (fs : stack) (x : exp)
 := fs = nil /\ (exists v, x = XVal v).

(* Add condition, e1 does not mention handles of any deleted regions.
   Also add this condition to preservation to get region deallocation. *)
Lemma progress
 :   forall se ss sp fs x1 t1 e1
 ,   WfFS   se sp ss fs
 ->  LiveS  ss fs -> LiveE fs e1
 ->  TypeC  nil nil se sp fs x1 t1 e1
 ->  done fs x1
  \/ (exists ss' sp' fs' x1', StepF ss sp fs x1 ss' sp' fs' x1').
Proof.
 intros se ss sp fs x1 t1 e1 HW HLS HLE HC.
 gen t1 e1.
 induction x1; intros; eauto.

 (*********************************************************)
 Case "XVal".
 { induction fs.
   - SCase "fs = nil".
     left.
     unfold done. rip. exists v. auto.

   - SCase "fs = cons ...".
     right.
     destruct a as [t x | m1 p2].
     + SSCase "FLet".
       exists ss. exists sp. exists fs. exists (substVX 0 v x).
       eauto.
     + destruct m1 as [p1 | ].
       * SSCase "FPriv ext".
         exists (map (mergeB p1 p2) ss).
         exists sp. exists fs. exists (XVal (mergeV p1 p2 v)).
         eauto.

       * SSCase "FPriv top".
         exists (map (deallocRegion p2) ss).
         exists sp. exists fs. exists (XVal v).
         eauto.
 }

 (*********************************************************)
 Case "XLet".
 { right.
   exists ss. exists sp. exists (fs :> FLet t x1_2). exists x1_1.
   eauto.
 }

 (*********************************************************)
 Case "XApp".
 { right.
   exists ss. exists sp. exists fs.
   inverts_typec.
   destruct v; nope.
   SCase "v1 = XLam".
    exists (substVX 0 v0 e). eauto.
   SCase "v1 = XConst".
    destruct c; nope.
 }

 (*********************************************************)
 Case "XAPP".
 { right.
   exists ss. exists sp. exists fs.
   inverts_typec.
   destruct v; nope.
   SCase "v1 = XLAM".
    exists (substTX 0 t e). eauto.
   SCase "v1 = XConst".
    destruct c; nope.
 }

 (*********************************************************)
 Case "XOp1".
 { right.
   exists ss. exists sp. exists fs.
   destruct o.
   SCase "OSucc".
    inverts_typec.
    snorm. inverts H8.
    destruct v; nope.
    destruct c; nope.
    eauto.
  SCase "OIsZero".
    inverts_typec.
    snorm. inverts H8.
    destruct v; nope.
    destruct c; nope.
    eauto.
 }

 (*********************************************************)
 Case "XPrivate".
 { right.
   exists ss.
   exists (SRegion (allocRegion sp) <: sp).
   exists (fs :> FPriv None (allocRegion sp) l).
   eauto.
 }

 (*********************************************************)
 Case "XExtend".
 { right.
   inverts HC. inverts_type.
   have HR: (exists n, t = TRgn n).
   destruct HR as [p]. subst.

   exists ss.
   exists (SRegion (allocRegion sp) <: sp).
   exists (fs :> FPriv (Some p) (allocRegion sp) nil).
   eauto.
 }

 (*********************************************************)
 Case "XRun".
 { right.
   inverts_typec.
   exists ss. exists sp. exists fs.
   destruct v; nope.
   - exists e. auto.
   - destruct c; nope.
 }

 (*********************************************************)
 Case "XAlloc".
 { right.
   inverts_typec.
   have HR: (exists n, t = TRgn n).
   destruct HR as [n].
   exists (StValue n v <: ss).
   exists sp.
   exists fs.
   exists (XVal (VLoc (length ss))).
   subst. auto.
 }

 (*********************************************************)
 Case "XRead".
 { right.
   inverts HC. inverts_type.
   have HR: (exists n, t = TRgn n).
   destruct HR as [n]. subst.

   assert (exists l, v = VLoc l) as HL.
    destruct v; burn.
    destruct c; nope.
   dest l. subst.

   inverts_type. inverts HW.
   exists ss. exists sp. exists fs.
   rip.

   (* There is a binding in the store corresponding
      to the entry in the store environment. *)
   have (exists b, get l ss = Some b).
    dest b.

   unfold StoreT in *.

   destruct b.
   (* Store binding contains a value. *)
   - have HB: (TypeB nil nil se sp (StValue n0 v) (TRef (TRgn n) t0))
      by (eapply Forall2_get_get_same; eauto).
     inverts HB.
     exists (XVal v).
     eauto.

   (* Store binding is dead,
      can't happen due to binding liveness constraints LiveE/LiveE *)
   - have HB: (TypeB nil nil se sp (StDead n0)    (TRef (TRgn n) t0))
      by (eapply Forall2_get_get_same; eauto).
     inverts HB.

     remember (TRgn n) as p.

     have (SubsT nil sp e1 (TRead p) KEffect)
      by  (eapply EqSym in H; eauto).

     have (LiveE fs (TRead p)).

     lets D: liveS_liveE_value ss fs (TRead p) l (StDead n).
     spec D n. rip. subst p. snorm. rip.
     have (Some n = Some n). rip.
     have (n = n). rip. nope.
 }

 (*********************************************************)
 Case "XWrite".
 { right.
   inverts_typec. inverts HW. rip.

   have HR: (exists n, t = TRgn n).
    destruct HR as [n]. subst.

   destruct v; burn.

   (* Write to a location. *)
   - inverts_type.

     exists (update n0 (StValue n v0) ss).
     exists sp. exists fs. exists (XVal (VConst CUnit)).

     have (exists b, get n0 ss = Some b).
      dest b.

     destruct b.
     (* Original binding contains a live value that can be overwritten. *)
     + have HB: (TypeB nil nil se sp (StValue n1 v) (TRef (TRgn n) t2))
        by (eapply Forall2_get_get_same; eauto).
       inverts HB.
       eauto.

     (* Original binding is dead,
        can't happen due to binding liveness constraints. *)
     + have HB: (TypeB nil nil se sp (StDead n1)    (TRef (TRgn n) t2))
        by (eapply Forall2_get_get_same; eauto).
       inverts HB.

       remember (TRgn n) as p.

       have (SubsT nil sp e1 (TWrite p) KEffect)
         by  (eapply EqSym in H; eauto).

       have (LiveE fs (TWrite p)).

       lets D: liveS_liveE_value ss fs (TWrite p) n0 (StDead n).
       spec D n. rip. subst p. snorm.
       have (Some n = Some n). rip.
       have (n = n). rip. nope.

   (* Write to a constant, can't happen. *)
   - destruct c; nope.
 }
Qed.


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.