(*|
=========================================
Strong and Weak Bisimulations over ctrees
=========================================
The [equ] relation provides [ctree]s with a suitable notion of equality.
It is however much too fine to properly capture any notion of behavioral
equivalence that we could want to capture over computations modelled as
[ctree]s.
If we draw a parallel with [itree]s, [equ] maps directly to [eq_itree],
while [eutt] was introduced to characterize computations that exhibit the
same external observations, but may disagree finitely on the amount of
internal steps occuring between any two observations.
While the only consideration over [itree]s was to be insensitive to the
amount of fuel needed to run, things are richer over [ctree]s.
We essentially want to capture three intuitive things:
- to be insensitive to the particular branches chosen at non-deterministic
nodes -- in particular, we want [br t u ~~ br u t];
- to always be insensitive to how many _invisible_ br nodes are crawled
through -- they really are a generalization of [Tau] in [itree]s;
- to have the flexibility to be sensible or not to the amount of _visible_
br nodes encountered -- they really are a generalization of CCS's tau
steps. This last fact, whether we observe or not these nodes, will constrain
the distinction between the weak and strong bisimulations we define.

In contrast with [equ], as well as the relations in [itree]s, we do not
define the functions generating the relations directly structurally on
the trees. Instead, we follow a definition closely following the style
developed for process calculi, essentially stating that diagrams of this
shape can be closed.
t  R  u
|     |
l     l
v     v
t' R  u'
The transition relations that we use to this end are defined in the [Trans]
module:
- strong bisimulation is defined as a symmetric games over [trans];
- weak bisimulation is defined as an asymmetric game in which [trans] get
answered by [wtrans].

.. coq::none
|*)
From Coq Require Import
     Lia
     Basics
     Fin
     RelationClasses
     Program.Equality
     Logic.Eqdep.

From Coinduction Require Import
     coinduction rel tactics.

From ITree Require Import Core.Subevent.

From CTree Require Import
     CTree
     Utils
     Eq.Equ
     Eq.Shallow
     Eq.Trans
     Eq.SSim
     Eq.CSSim.

From RelationAlgebra Require Export
     rel srel.

Set Implicit Arguments.

(* TODO: Decide where to set this *)
Arguments trans : simpl never.

(*|
Strong Bisimulation
-------------------
Relation relaxing [equ] to become insensitive to:
- the amount of _invisible_ brs taken;
- the particular branches taken during (any kind of) brs.
|*)

Section StrongBisim.
  Context {E F C D : Type -> Type} {X Y : Type} `{HasStuck : B0 -< C} `{HasStuck' : B0 -< D}.
  Notation S := (ctree E C X).
  Notation S' := (ctree F D Y).

(*|
In the heterogeneous case, the relation is not symmetric.
|*)
  Program Definition sb L : mon (S -> S' -> Prop) :=
    {| body R t u := ss L R t u /\ ss (flip L) (flip R) u t |}.
  Next Obligation.
    split; intros; [edestruct H0 as (? & ? & ?) | edestruct H1 as (? & ? & ?)]; eauto; eexists; eexists; intuition; eauto.
  Qed.

  #[global] Instance weq_sb : Proper (weq ==> weq) sb.
  Proof.
    split; intros.
    - split.
      + epose proof (weq_ss H). do 13 red in H1. setoid_rewrite <- H1. apply H0.
      + cbn in H. assert (flip x == flip y).
        { cbn. split; intro. apply H. apply H1. apply H. apply H1. }
        epose proof (weq_ss H1).
        do 13 red in H2. setoid_rewrite <- H2. apply H0.
    - split.
      + epose proof (weq_ss H). do 13 red in H1. setoid_rewrite H1. apply H0.
      + cbn in H. assert (flip x == flip y).
        { cbn. split; intro. apply H. apply H1. apply H. apply H1. }
        epose proof (weq_ss H1).
        do 13 red in H2. setoid_rewrite H2. apply H0.
  Qed.

End StrongBisim.

Definition sbisim {E F C D X Y} `{HasStuck : B0 -< C} `{HasStuck': B0 -< D} L :=
  (gfp (@sb E F C D X Y _ _ L) : hrel _ _).

#[global] Instance weq_sbisim : forall {E F C D X Y} `{B0 -< C} `{B0 -< D},
  Proper (weq ==> weq) (@sbisim E F C D X Y _ _).
Proof.
  intros. split.
  - intro. unfold sbisim.
    epose proof (gfp_weq (sb x) (sb y)). lapply H3.
    + intro. red in H4. cbn in H4. rewrite <- H4. unfold sbisim in H2. apply H2.
    + now rewrite H1.
  - intro. unfold sbisim.
    epose proof (gfp_weq (sb x) (sb y)). lapply H3.
    + intro. red in H4. cbn in H4. rewrite H4. unfold sbisim in H2. apply H2.
    + now rewrite H1.
Qed.

(* This instance allows to use the symmetric tactic from coq-coinduction
   for homogeneous bisimulations *)
#[global] Instance sbisim_sym {E C X L} `{HasStuck : B0 -< C} :
  Symmetric L ->
  Sym_from converse (@sb E E C C X X _ _ L) (@ss E E C C X X _ _ L).
Proof.
  intros SYM. split; intro.
  - destruct H. split.
    + apply H.
    + cbn. intros. apply H0 in H1 as (? & ? & ? & ? & ?). apply SYM in H3. eauto.
  - destruct H. split.
    + apply H.
    + cbn. intros. apply H0 in H1 as (? & ? & ? & ? & ?). apply SYM in H3. eauto.
Qed.

Module SBisimNotations.

(*|
sb (bisimulation) notation
|*)
  Notation st L := (t (sb L)).
  Notation sT L := (T (sb L)).
  Notation sbt L := (bt (sb L)).
  Notation sbT L := (bT (sb L)).
  Notation "t ~ u" := (sbisim eq t u) (at level 70).
  Notation "t (~ L ) u" := (sbisim L t u) (at level 70).
  Notation "t [~ L] u" := (st L _ t u) (at level 79).
  Notation "t [~] u" := (st eq _ t u) (at level 79).
  Notation "t {~ L } u" := (sbt L _ t u) (at level 79).
  Notation "t {~} u" := (sbt eq _ t u) (at level 79).
  Notation "t {{ ~ L }} u" := (sb L _ t u) (at level 79).
  Notation "t {{~}} u" := (sb eq _ t u) (at level 79).

End SBisimNotations.

Import SBisimNotations.

Ltac fold_sbisim :=
  repeat
    match goal with
    | h: context[gfp (@sb ?E ?F ?C ?D ?X ?Y _ _ ?L)] |- _  => fold (@sbisim E F C D X Y _ _ L) in h
    | |- context[gfp (@sb ?E ?F ?C ?D ?X ?Y _ _ ?L)]       => fold (@sbisim E F C D X Y _ _ L)
    end.

Ltac __coinduction_sbisim R H :=
  (try unfold sbisim);
  apply_coinduction; fold_sbisim; intros R H.

Tactic Notation "__step_sbisim" :=
  match goal with
  | |- context[@sbisim ?E ?F ?C ?D ?X ?Y _ _ ?LR] =>
      unfold sbisim;
      step;
      fold (@sbisim E F C D X Y _ _ L)
           (* TODO double check that this second match made no sense, I'm confused *)
  (* | |- context[@sb ?E ?F ?C ?D ?X ?Y _ _ ?LR] => *)
  (*     unfold sb; *)
  (*     step; *)
  (*     fold (@sb E F C D X Y _ _ L) *)
  end.

#[local] Tactic Notation "step" := __step_sbisim || __step_ssim || __step_cssim || step.

#[local] Tactic Notation "coinduction" simple_intropattern(R) simple_intropattern(H) :=
  __coinduction_sbisim R H || __coinduction_ssim R H || __coinduction_cssim R H || coinduction R H.

Ltac __step_in_sbisim H :=
  match type of H with
  | context [@sbisim ?E ?F ?C ?D ?X ?Y _ _ ?LR] =>
      unfold sbisim in H;
      step in H;
      fold (@sbisim E F C D X Y _ _ L) in H
  end.

#[local] Tactic Notation "step" "in" ident(H) := __step_in_sbisim H || step in H.

(*|
  This section should describe lemmas proved for the
  heterogenous version of `css`, parametric on
  - Return types X, Y
  - Label types E, F
  - Branch effects C, D
|*)
Section sbisim_heterogenous_theory.

  Arguments label: clear implicits.
  Context {E F C D : Type -> Type} {X Y : Type}
          {L: rel (@label E) (@label F)}
          {HasStuck1: B0 -< C} {HasStuck2: B0 -< D}.

  Notation sb := (@sb E F C D X Y _ _).
  Notation sbisim := (@sbisim E F C D X Y _ _).
  Notation st L := (coinduction.t (sb L)).
  Notation sbt L := (coinduction.bt (sb L)).
  Notation sT  L := (coinduction.T (sb L)).

(*|
Strong bisimulation up-to [equ] is valid
----------------------------------------
|*)
  Lemma equ_clos_st : @equ_clos E F C D X Y <= (st L).
  Proof.
    apply Coinduction; cbn.
    intros R x y [x' y' x'' y'' EQ' [Fwd Back] EQ'']; split.
    - intros l z x'z.
      rewrite EQ' in x'z.
      apply Fwd in x'z.
      destruct x'z as (? & ? & ? & ? & ?).
      do 2 eexists; intuition.
      rewrite <- EQ''; eauto.
      eapply (f_Tf (sb L)).
      econstructor; eauto.
      assumption.
    - intros l z y'z.
      rewrite <- EQ'' in y'z.
      apply Back in y'z.
      destruct y'z as (? & ? & ? & ? & ?).
      do 2 eexists; intuition.
      rewrite EQ'; eauto.
      eapply (f_Tf (sb L)).
      econstructor; eauto.
      eauto.
  Qed.

(*|
    Aggressively providing instances for rewriting [equ] under all [sb]-related
    contexts.
|*)
  #[global] Instance equ_clos_st_goal RR :
    Proper (@equ E C X X eq ==> @equ F D Y Y eq ==> flip impl) (st L RR).
  Proof.
    cbn; intros ? ? eq1 ? ? eq2 H.
    apply (ft_t equ_clos_st); econstructor; [eauto | | symmetry; eauto]; assumption.
  Qed.

  #[global] Instance equ_clos_st_ctx RR :
    Proper (@equ E C X X eq ==> @equ F D Y Y eq ==> impl) (st L RR).
  Proof.
    cbn; intros ? ? eq1 ? ? eq2 H.
    apply (ft_t equ_clos_st); econstructor; [symmetry; eauto | | eauto]; assumption.
  Qed.

  #[global] Instance equ_clos_sT_goal RR f :
    Proper (equ eq ==> equ eq ==> flip impl) (sT L f RR).
  Proof.
    cbn; intros ? ? eq1 ? ? eq2 H.
    apply (fT_T equ_clos_st); econstructor; [eauto | | symmetry; eauto]; assumption.
  Qed.

  #[global] Instance equ_clos_sT_ctx RR f :
    Proper (equ eq ==> equ eq ==> impl) (sT L f RR).
  Proof.
    cbn; intros ? ? eq1 ? ? eq2 H.
    apply (fT_T equ_clos_st); econstructor; [symmetry; eauto | | eauto]; assumption.
  Qed.

  #[global] Instance equ_clos_sbisim_goal :
    Proper (equ eq ==> equ eq ==> flip impl) (sbisim L).
  Proof.
    cbn; intros ? ? eq1 ? ? eq2 H.
    apply (ft_t equ_clos_st); econstructor; [eauto | | symmetry; eauto]; assumption.
  Qed.

  #[global] Instance equ_clos_sbisim_ctx :
    Proper (equ eq ==> equ eq ==> impl) (sbisim L).
  Proof.
    cbn; intros ? ? eq1 ? ? eq2 H.
    apply (ft_t equ_clos_st); econstructor; [symmetry; eauto | | eauto]; assumption.
  Qed.

  #[global] Instance equ_ss_closed_goal {r} : Proper (@equ E C X X eq ==> @equ F D Y Y eq ==> flip impl) (ss L r).
  Proof.
    intros t t' tt' u u' uu'; cbn; intros.
    rewrite tt' in H0. apply H in H0 as (? & ? & ? & ? & ?).
    eexists; eexists; eauto. rewrite uu'. eauto.
  Qed.

  #[global] Instance equ_ss_closed_ctx {r} : Proper (@equ E C X X eq ==> @equ F D Y Y eq ==> impl) (ss L r).
  Proof.
    intros t t' tt' u u' uu'; intros.
    rewrite tt', uu'. reflexivity.
  Qed.

(*|
Up-to-bisimulation enhancing function
|*)
  Variant sbisim_clos_body {LE LF}
          (R : rel (ctree E C X) (ctree F D Y)) : (rel (ctree E C X) (ctree F D Y)) :=
    | Sbisim_clos : forall t t' u' u
                      (Sbisimt : t (~ LE) t')
                      (HR : R t' u')
                      (Sbisimu : u' (~ LF) u),
        @sbisim_clos_body LE LF R t u.

  Program Definition sbisim_clos {LE LF} : mon (rel (ctree E C X) (ctree F D Y)) :=
    {| body := @sbisim_clos_body LE LF |}.
  Next Obligation.
    destruct H0.
    econstructor; eauto.
  Qed.

(*|
stuck ctrees can be simulated by anything.
|*)
  Lemma is_stuck_sb (R : rel _ _) (t : ctree E C X) (t': ctree F D Y):
    is_stuck t -> is_stuck t' -> sb L R t t'.
  Proof.
    split; repeat intro.
    - now apply H in H1.
    - now apply H0 in H1.
  Qed.

  Theorem sbisim_clos_upto R: @sbisim_clos eq eq R <= st L R.
  Proof.
    apply leq_t.
    intros S t u HRel.
    split; cbn; intros ? ? TR.
    - inv HRel.
      step in Sbisimt; apply Sbisimt in TR; destruct TR as (? & ? & TR & Sbis & <-).
      apply HR in TR; destruct TR as (? & ? & TR & Sbis' & HL).
      step in Sbisimu; apply Sbisimu in TR; destruct TR as (? & ? & TR & Sbis'' & <-).
      do 2 eexists; repeat split; eauto.
      econstructor.
      apply Sbis.
      eauto.
      apply Sbis''.
    - inv HRel.
      step in Sbisimu; apply Sbisimu in TR; destruct TR as (? & ? & TR & Sbis & <-).
      apply HR in TR; destruct TR as (? & ? & TR & Sbis' & HL).
      step in Sbisimt; apply Sbisimt in TR; destruct TR as (? & ? & TR & Sbis'' & <-).
      do 2 eexists; repeat split; eauto.
      econstructor.
      apply Sbis''.
      eauto.
      apply Sbis.
  Qed.

End sbisim_heterogenous_theory.

Section sbisim_homogenous_theory.
  Context {E C: Type -> Type} {X: Type} `{HasStuck: B0 -< C}
          (L: relation (@label E)).

  Notation sb  := (@sb E E C C X X _ _).
  Notation sbisim := (@sbisim E E C C X X _ _).
  Notation st L := (coinduction.t (sb L)).
  Notation sbt L := (coinduction.bt (sb L)).
  Notation sT  L := (coinduction.T (sb L)).

(*|
This is just a hack suggested by Damien Pous to avoid a
universe inconsistency when using both the relational algebra
and coinduction libraries (we fix the type at which we'll use [eq]).
|*)
  Definition seq: relation (ctree E C X) := eq.
  Arguments seq/.

  Lemma refl_st {RL: Reflexive L} : const seq <= (st L).
  Proof.
    apply leq_t.
    split; intros; cbn*; intros; inv H; subst;
      exists l, t'; split; eauto.
  Qed.

(*|
[converse] is compatible
i.e. validity of up-to symmetry
|*)
  Lemma converse_st `{SL: Symmetric _ L}: converse <= (st L).
  Proof.
    apply leq_t; cbn.
    intros R ? ? [H1 H2]; split; intros.
    - destruct (H2 _ _ H) as (? & ? & ? & ? & ?); subst; symmetry in H4; eauto.
    - destruct (H1 _ _ H) as (? & ? & ? & ? & ?); subst; symmetry in H4; eauto.
  Qed.

(*|
[square] is compatible
i.e. validity of up-to transivitiy
|*)
  Lemma square_st `{TR: Transitive _ L}: square <= (st L).
  Proof.
    apply Coinduction; cbn.
    intros R x z [y [xy yx] [yz zy]].
    split.
     - intros ?l x' xx'.
      destruct (xy _ _ xx') as (?l & y' & yy' & ? & EQ).
      destruct (yz _ _ yy') as (?l & z' & zz' & ? & EQ').
      do 2 eexists; repeat split.
      eauto.
      apply (f_Tf (sb L)).
      eexists; eauto.
      transitivity l0; assumption.
    - intros ?l z' zz'.
      destruct (zy _ _ zz') as (?l & y' & yy' & ? & EQ).
      destruct (yx _ _ yy') as (?l & x' & xx' & ? & EQ').
      do 2 eexists; repeat split.
      eauto.
      apply (f_Tf (sb L)).
      eexists; eauto.
      transitivity l0; assumption.
  Qed.

(*|
Reflexivity
|*)
  #[global] Instance Reflexive_st R `{Reflexive _ L}: Reflexive (st L R).
  Proof. apply build_reflexive; apply ft_t; apply refl_st. Qed.

  Corollary Reflexive_sbisim `{Reflexive _ L}: Reflexive (sbisim L).
  Proof. now apply Reflexive_st. Qed.

  #[global] Instance Reflexive_sbt R `{Reflexive _ L}: Reflexive (sbt L R).
  Proof. apply build_reflexive; apply fbt_bt; apply refl_st. Qed.

  #[global] Instance Reflexive_sT f R `{Reflexive _ L}: Reflexive (sT L f R).
  Proof. apply build_reflexive; apply fT_T; apply refl_st. Qed.

(*|
Transitivity
|*)
  #[global] Instance Transitive_st R `{Transitive _ L}: Transitive (st L R).
  Proof. apply build_transitive; apply ft_t; apply (square_st). Qed.

  Corollary Transitive_sbisim `{Transitive _ L}: Transitive (sbisim L).
  Proof. now apply Transitive_st. Qed.

  #[global] Instance Transitive_sbt R `{Transitive _ L}: Transitive (sbt L R).
  Proof. apply build_transitive; apply fbt_bt; apply square_st. Qed.

  #[global] Instance Transitive_sT f R `{Transitive _ L}: Transitive (sT L f R).
  Proof. apply build_transitive; apply fT_T; apply square_st. Qed.

(*|
Symmetry
|*)
  #[global] Instance Symmetric_st R `{Symmetric _ L}: Symmetric (st L R).
  Proof. apply build_symmetric; apply ft_t; apply (converse_st). Qed.

  Corollary Symmetric_sbisim `{Symmetric _ L}: Symmetric (sbisim L).
  Proof. now apply Symmetric_st. Qed.

  #[global] Instance Symmetric_sbt R `{Symmetric _ L}: Symmetric (sbt L R).
  Proof. apply build_symmetric; apply fbt_bt; apply converse_st. Qed.

  #[global] Instance Symmetric_sT f R `{Symmetric _ L}: Symmetric (sT L f R).
  Proof. apply build_symmetric; apply fT_T; apply converse_st. Qed.

(*|
Thus bisimilarity and [t R] are always equivalence relations.
|*)
  #[global] Instance Equivalence_st `{Equivalence _ L} R: Equivalence (st L R).
  Proof. split; typeclasses eauto. Qed.

  Corollary Equivalence_bisim `{Equivalence _ L}: Equivalence (sbisim L).
  Proof. split; typeclasses eauto. Qed.

  #[global] Instance Equivalence_sbt `{Equivalence _ L} R: Equivalence (sbt L R).
  Proof. split; typeclasses eauto. Qed.

  #[global] Instance Equivalence_sT `{Equivalence _ L} f R: Equivalence ((T (sb L)) f R).
  Proof. split; typeclasses eauto. Qed.

(*|
Aggressively providing instances for rewriting hopefully faster
[sbisim] under all [sb]-related contexts (consequence of the transitivity
of the companion).
|*)
  #[global] Instance sbisim_sbisim_closed_goal `{Transitive _ L} `{Symmetric _ L} :
    Proper (sbisim L ==> sbisim L ==> flip impl) (sbisim L).
  Proof.
    repeat intro.
    etransitivity; [etransitivity; eauto | symmetry; eassumption].
  Qed.

  #[global] Instance sbisim_sbisim_closed_ctx `{Transitive _ L} `{Symmetric _ L} :
    Proper (sbisim L ==> sbisim L ==> impl) (sbisim L).
  Proof.
    repeat intro.
    etransitivity; [symmetry; eassumption | etransitivity; eauto].
  Qed.

  #[global] Instance sbisim_clos_st_goal `{Equivalence _ L} R:
    Proper (sbisim L ==> sbisim L ==> flip impl) (st L R).
  Proof.
    cbn; intros ? ? eq1 ? ? eq2 ?.
    rewrite eq1, eq2.
    auto.
  Qed.

  #[global] Instance sbisim_clos_st_ctx `{Equivalence _ L} R :
    Proper (sbisim L ==> sbisim L ==> impl) (st L R).
  Proof.
    cbn; intros ? ? eq1 ? ? eq2 ?.
    rewrite <- eq1, <- eq2.
    auto.
  Qed.

  #[global] Instance sbisim_clos_sT_goal `{Equivalence _ L} R f :
    Proper (sbisim L ==> sbisim L ==> flip impl) (sT L f R).
  Proof.
    cbn; intros ? ? eq1 ? ? eq2 ?.
    rewrite eq1, eq2.
    auto.
  Qed.

  #[global] Instance sbisim_clos_sT_ctx `{Equivalence _ L} R f :
    Proper (sbisim L ==> sbisim L ==> impl) (sT L f R).
  Proof.
    cbn; intros ? ? eq1 ? ? eq2 ?.
    rewrite <- eq1, <- eq2.
    auto.
  Qed.

  #[global] Instance equ_sbt_closed_goal `{EqL: Equivalence _ L} R:
    Proper (equ eq ==> equ eq ==> flip impl) (sbt L R).
  Proof.
    repeat intro. pose proof (gfp_bt (sb L) R).
    etransitivity; [| etransitivity]; [ | apply H1 | ]; apply H2.
    rewrite H; auto. rewrite H0; auto.
  Qed.

  #[global] Instance equ_sbt_closed_ctx `{EqL: Equivalence _ L} {R} :
    Proper (equ eq ==> equ eq ==> impl) (sbt L R).
  Proof.
    repeat intro. pose proof (gfp_bt (sb L) R).
    etransitivity; [| etransitivity]; [ | apply H1 | ]; apply H2.
    rewrite H; auto. rewrite H0; auto.
  Qed.

(*|
Hence [equ eq] is a included in [sbisim]
|*)
  #[global] Instance equ_sbisim_subrelation `{EqL: Equivalence _ L} : subrelation (equ eq) (sbisim L).
  Proof.
    red; intros.
    rewrite H; reflexivity.
  Qed.

End sbisim_homogenous_theory.

(*|
Up-to [bind] context bisimulations
----------------------------------
We have proved in the module [Equ] that up-to bind context is
a valid enhancement to prove [equ].
We now prove the same result, but for strong and weak bisimulation.
|*)

Section bind.
  Obligation Tactic := trivial.
  Arguments label: clear implicits.
  Context {E F C D: Type -> Type} {X X' Y Y': Type}
          `{HasStuck: B0 -< C} `{HasStuck': B0 -< D}
          {L: rel (label E) (label F)} (R0 : rel X Y).

  Program Definition bind_ctx_sbisim L0 : mon (rel (ctree E C X') (ctree F D Y')) :=
    {|body := fun R => @bind_ctx E F C D X Y X' Y' (sbisim L0)
                              (pointwise R0 R) |}.
  Next Obligation.
    intros ??? H. apply leq_bind_ctx. intros ?? H' ?? H''.
    apply in_bind_ctx. apply H'. intros t t' HS. apply H, H'', HS.
  Qed.

(*|
The resulting enhancing function gives a valid up-to technique
|*)
  Lemma bind_ctx_sbisim_t L0 :
    is_update_val_rel L R0 L0 -> bind_ctx_sbisim L0 <= st L.
  Proof.
    intros HL0. apply Coinduction.
    intros R. apply (leq_bind_ctx _).
    intros t1 t2 tt k1 k2 kk.
    step in tt; split; simpl;  intros l u STEP.
    - apply trans_bind_inv in STEP as [(VAL & t' & STEP & EQ) | (v & STEPres & STEP)]; cbn in *.
      + apply tt in STEP as (l' & u' & STEP & SIM & LBL).
        apply HL0 in LBL; etrans.
        apply update_val_rel_nonval_l in LBL as [VAL' LBL]; auto.
        do 2 eexists. split.
        apply trans_bind_l; eauto.
        split; auto.
        apply (fT_T equ_clos_st).
        econstructor; [exact EQ | | reflexivity].
        apply (fTf_Tf (sb L)).
        apply in_bind_ctx; auto.
        intros ? ? ?.
        apply (b_T (sb L)).
        red in kk; now apply kk.
      + apply tt in STEPres as (l' & u' & STEPres & SIM & LBL).
        apply HL0 in LBL; etrans.
        apply update_val_rel_val_l in LBL as (v' & -> & ?).
        pose proof (trans_val_inv STEPres) as EQ.
        rewrite EQ in STEPres.
        specialize (kk v v' H).
        apply kk in STEP as (l' & u'' & STEP & EQ'' & ?); cbn in *.
        do 2 eexists; split.
        eapply trans_bind_r; eauto.
        split; auto.
        eapply (id_T (sb L)); auto.

    - apply trans_bind_inv in STEP as [(H & t' & STEP & EQ) | (v & STEPres & STEP)]; cbn in *.
      + apply tt in STEP as (l' & u' & STEP & EQ' & LBL).
        apply HL0 in LBL; etrans.
        apply update_val_rel_nonval_r in LBL as [VAL' LBL]; auto.
        do 2 eexists; split.
        apply trans_bind_l; eauto.
        split; auto.
        apply (fT_T equ_clos_st).
        symmetry in EQ.
        econstructor; [reflexivity | | exact EQ].
        apply (fTf_Tf (sb L)).
        apply in_bind_ctx; auto.
        intros ? ? ?.
        apply (b_T (sb L)).
        red in kk; now apply kk.
      + apply tt in STEPres as (l' & u' & STEPres & EQ' & LBL).
        apply HL0 in LBL; etrans.
        apply update_val_rel_val_r in LBL as (v' & -> & ?).
        pose proof (trans_val_inv STEPres) as EQ.
        rewrite EQ in STEPres.
        specialize (kk v' v H).
        apply kk in STEP as (u'' & ? & STEP & EQ'' & ?); cbn in *.
        do 2 eexists; split.
        eapply trans_bind_r; eauto.
        split; auto.
        eapply (id_T (sb L)); auto.
  Qed.

End bind.

Import CTree.
Import CTreeNotations.
Import EquNotations.

(*|
Expliciting the reasoning rule provided by the up-to principles.
This principle is unusable for most [L], see https://github.com/vellvm/ctrees/issues/21
|*)
Lemma st_clo_bind_gen {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (@label E) (@label F)}
      `{HasStuck: B0 -< C} `{HasStuck': B0 -< D}
      (R0 : rel X Y) L0
      (t1 : ctree E C X) (t2: ctree F D Y)
      (HL0 : is_update_val_rel L R0 L0)
      (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y') RR:
  t1 (~L0) t2 ->
  (forall x y, R0 x y -> (st L RR) (k1 x) (k2 y)) ->
  st L RR (t1 >>= k1) (t2 >>= k2).
Proof.
  intros ? ?.
  apply (ft_t (@bind_ctx_sbisim_t E F C D X X' Y Y' _ _ L R0 L0 HL0)).
  apply in_bind_ctx; eauto.
Qed.

Lemma st_clo_bind {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (@label E) (@label F)}
      `{HasStuck: B0 -< C} `{HasStuck': B0 -< D}
      (R0 : rel X Y)
      (t1 : ctree E C X) (t2: ctree F D Y)
      (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y') RR:
  t1 (~update_val_rel L R0) t2 ->
  (forall x y, R0 x y -> (st L RR) (k1 x) (k2 y)) ->
  st L RR (t1 >>= k1) (t2 >>= k2).
Proof.
  intros ? ?.
  eapply st_clo_bind_gen; eauto.
  apply update_val_rel_correct.
Qed.

Lemma st_clo_bind_eq {E C D: Type -> Type} {X X': Type}
      `{HasStuck: B0 -< C} `{HasStuck': B0 -< D}
      (t1 : ctree E C X) (t2: ctree E D X)
      (k1 : X -> ctree E C X') (k2 : X -> ctree E D X') RR:
  t1 ~ t2 ->
  (forall x, st eq RR (k1 x) (k2 x)) ->
  st eq RR (t1 >>= k1) (t2 >>= k2).
Proof.
  intros ? ?.
  eapply st_clo_bind_gen.
  - apply is_update_val_rel_eq.
  - assumption.
  - intros. now subst.
Qed.

Lemma sbt_clo_bind_gen {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (@label E) (@label F)}
      `{HasStuck: B0 -< C} `{HasStuck': B0 -< D}
      (R0 : rel X Y) L0
      (t1 : ctree E C X) (t2: ctree F D Y)
      (HL0 : is_update_val_rel L R0 L0)
      (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y') RR:
  t1 (~L0) t2 ->
  (forall x y, R0 x y -> (sbt L RR) (k1 x) (k2 y)) ->
  sbt L RR (t1 >>= k1) (t2 >>= k2).
Proof.
  intros ? ?.
  apply (fbt_bt (@bind_ctx_sbisim_t E F C D X X' Y Y' _ _ L R0 L0 HL0)).
  apply in_bind_ctx; eauto.
Qed.

Lemma sbt_clo_bind {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (@label E) (@label F)}
      `{HasStuck: B0 -< C} `{HasStuck': B0 -< D}
      (R0 : rel X Y)
      (t1 : ctree E C X) (t2: ctree F D Y)
      (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y') RR:
  t1 (~update_val_rel L R0) t2 ->
  (forall x y, R0 x y -> (sbt L RR) (k1 x) (k2 y)) ->
  sbt L RR (t1 >>= k1) (t2 >>= k2).
Proof.
  intros ? ?.
  eapply sbt_clo_bind_gen; eauto.
  apply update_val_rel_correct.
Qed.

Lemma sbt_clo_bind_eq {E C D: Type -> Type} {X X': Type}
      `{HasStuck: B0 -< C} `{HasStuck': B0 -< D}
      (t1 : ctree E C X) (t2: ctree E D X)
      (k1 : X -> ctree E C X') (k2 : X -> ctree E D X') RR:
  t1 ~ t2 ->
  (forall x, sbt eq RR (k1 x) (k2 x)) ->
  sbt eq RR (t1 >>= k1) (t2 >>= k2).
Proof.
  intros ? ?.
  eapply sbt_clo_bind_gen.
  - apply is_update_val_rel_eq.
  - assumption.
  - intros. now subst.
Qed.

Lemma sbisim_clo_bind_gen {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (@label E) (@label F)}
      `{HasStuck: B0 -< C} `{HasStuck': B0 -< D}
      (R0 : rel X Y) L0
      (t1 : ctree E C X) (t2: ctree F D Y)
      (HL0 : is_update_val_rel L R0 L0)
      (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y') :
  t1 (~L0) t2 ->
  (forall x y, R0 x y -> k1 x (~L) k2 y) ->
  t1 >>= k1 (~L) t2 >>= k2.
Proof.
  now apply st_clo_bind_gen.
Qed.

Lemma sbisim_clo_bind {E F C D: Type -> Type} {X Y X' Y': Type} {L : rel (@label E) (@label F)}
      `{HasStuck: B0 -< C} `{HasStuck': B0 -< D}
      (R0 : rel X Y)
      (t1 : ctree E C X) (t2: ctree F D Y)
      (k1 : X -> ctree E C X') (k2 : Y -> ctree F D Y') :
  t1 (~update_val_rel L R0) t2 ->
  (forall x y, R0 x y -> k1 x (~L) k2 y) ->
  t1 >>= k1 (~L) t2 >>= k2.
Proof.
  now apply st_clo_bind.
Qed.

Lemma sbisim_clo_bind_eq {E C D: Type -> Type} {X X': Type}
      `{HasStuck: B0 -< C} `{HasStuck': B0 -< D}
      (t1 : ctree E C X) (t2: ctree E D X)
      (k1 : X -> ctree E C X') (k2 : X -> ctree E D X') :
  t1 ~ t2 ->
  (forall x, k1 x ~ k2 x) ->
  t1 >>= k1 ~ t2 >>= k2.
Proof.
  now apply st_clo_bind_eq.
Qed.

(*|
And in particular, we get the proper instance justifying rewriting [~ L] to the left of a [bind].
|*)
(*#[global] Instance bind_sbisim_cong_gen {E C X X'} (RR: relation (ctree E C X')) `{HasStuck: B0 -< C}
      {L: relation (@label E)} {RL: Reflexive L}:
  Proper (sbisim eq ==> (fun f g => forall x, st L RR (f x) (g x)) ==> st L RR) (@bind E C X X').
Proof.
  repeat red; intros. eapply st_clo_bind_gen. 2: apply H.
   Qed.*)

Ltac __upto_bind_sbisim :=
  match goal with
    |- @sbisim ?E ?F ?C ?D ?X ?Y _ _ ?L
              (CTree.bind (T := ?T) _ _) (CTree.bind (T := ?T) _ _) => apply sbisim_clo_bind_eq
  | |- body (t (@sb ?E ?F ?C ?D ?X ?Y _ _ ?L)) ?R
           (CTree.bind (T := ?X') _ _) (CTree.bind (T := ?X') _ _) =>
      apply st_clo_bind_eq
  | |- body (bt (@sb ?E ?F ?C ?D ?X ?Y _ _ ?L)) ?R
           (CTree.bind (T := ?X') _ _) (CTree.bind (T := ?X') _ _) =>
      apply sbt_clo_bind_eq
  end.

Ltac __upto_bind_eq_sbisim :=
  match goal with
  | |- @sbisim ?E ?F ?C ?D ?X ?Y _ _ eq (CTree.bind (T := ?Z) _ _) (CTree.bind (T := ?Z) _ _) =>
      __upto_bind_sbisim; [reflexivity | intros ?]
  | _ =>
      __upto_bind_sbisim; [reflexivity | intros ? ? EQl]
  end.

(* Ltac __upto_bind_sbisim := *)
(*   match goal with *)
(*     |- @sbisim ?E ?F ?C ?D ?X ?Y _ _ ?L *)
(*               (CTree.bind (T := ?T) _ _) (CTree.bind (T := ?T) _ _) => apply sbisim_clo_bind *)
(*   | |- body (t (@sb ?E ?F ?C ?D ?X ?Y _ _ ?L)) ?R *)
(*            (CTree.bind (T := ?X') _ _) (CTree.bind (T := ?Y') _ _) => *)
(*       apply (ft_t (@bind_ctx_sbisim_t E F C D X' X Y' Y _ _ L _)), in_bind_ctx *)
(*   | |- body (bt (@sb ?E ?F ?C ?D ?X ?Y _ _ ?L)) ?R *)
(*            (CTree.bind (T := ?X') _ _) (CTree.bind (T := ?Y') _ _) => *)
(*       apply (fbt_bt (@bind_ctx_sbisim_t E F C D X' X Y' Y _ _ L _)), in_bind_ctx *)
(*   end. *)

(* Ltac __upto_bind_eq_sbisim := *)
(*   match goal with *)
(*   | |- @sbisim ?E ?F ?C ?D ?X ?Y _ _ eq (CTree.bind (T := ?Z) _ _) (CTree.bind (T := ?Z) _ _) => *)
(*       __upto_bind_sbisim; [reflexivity | intros ?] *)
(*   | _ => *)
(*       __upto_bind_sbisim; [reflexivity | intros ? ? EQl] *)
(*   end. *)

Section Ctx.

  Context {E F C D: Type -> Type} {X X' Y Y': Type}.

  Definition vis_ctx (e : E X) (f: F Y)
             (R: rel (X -> ctree E C X') (Y -> ctree F D Y')):
    rel (ctree E C X') (ctree F D Y') :=
    sup_all (fun k => sup (R k) (fun k' => pairH (Vis e k) (Vis f k'))).

  Lemma leq_vis_ctx e f:
    forall R R', vis_ctx e f R <= R' <->
              (forall k k', R k k' -> R' (Vis e k) (Vis f k')).
  Proof.
    intros.
    unfold vis_ctx.
    setoid_rewrite sup_all_spec.
    setoid_rewrite sup_spec.
    setoid_rewrite <-leq_pairH.
    firstorder.
  Qed.

  Lemma in_vis_ctx e f (R :rel _ _) x x' :
    R x x' -> vis_ctx e f R (Vis e x) (Vis f x').
  Proof. intros. now apply ->leq_vis_ctx. Qed.
  #[global] Opaque vis_ctx.

End Ctx.

Section sb_vis_ctx.
  Arguments label: clear implicits.
  Obligation Tactic := idtac.

  Section Gen.
    Context {E F C D: Type -> Type} {X Y X' Y': Type}.
    Context `{HasFailC: B0 -< C} `{HasFailD: B0 -< D}.

    Program Definition vis_ctx_sbisim_gen (e : E X) (f: F Y) (right : X -> Y) (left : Y -> X) :
      mon (rel (ctree E C X') (ctree F D Y')) :=
      {|body := fun R =>
                  @vis_ctx E F C D X X' Y Y' e f
                    (fun ff gg =>
                       (forall x, R (ff x) (gg (right x))) /\
                         (forall y, R (ff (left y)) (gg y)))
      |}.
    Next Obligation.
      intros e f Rf Rg ? ? ? . apply leq_vis_ctx. intros k k' [H1 H2].
      apply in_vis_ctx; split; intros.
      eapply H in H1; eapply H1.
      eapply H in H2; eapply H2.
    Qed.

(*|
The resulting enhancing function gives a valid up-to technique
|*)
    Lemma vis_ctx_sbisim_gen_t {L: rel (label E) (label F)} (e : E X) (f: F Y) right left :
      (forall x, L (obs e x) (obs f (right x))) ->
      (forall y, L (obs e (left y)) (obs f y)) ->
      vis_ctx_sbisim_gen e f right left <= (st L).
    Proof.
      intros HT HF.
      apply Coinduction.
      intros R.
      apply leq_vis_ctx.
      intros k k' kk'.
      cbn.
      split; intros ? ? TR; inv_trans; subst; cbn.
      - do 2 eexists; split; etrans; split; auto.
        rewrite EQ; now eapply (b_T (sb L)).
      - do 2 eexists; split; etrans; split; auto.
        rewrite EQ; now eapply (b_T (sb L)).
    Qed.

  End Gen.

  Section Specialized.

    Context {E C: Type -> Type} {X X': Type}.
    Context `{HasFailC: B0 -< C}.

    Program Definition vis_ctx_sbisim (e : E X) :
      mon (rel (ctree E C X') (ctree E C X')) :=
      {|body := fun R =>
                  @vis_ctx E E C C X X' X X' e e
                    (fun ff gg => forall x, R (ff x) (gg x))
      |}.
    Next Obligation.
      intros e ? ? ?. apply leq_vis_ctx. intros k k' H0.
      apply in_vis_ctx; intros.
      eapply H in H0; eapply H0.
    Qed.

(*|
The resulting enhancing function gives a valid up-to technique
|*)
    Lemma vis_ctx_sbisim_t (e : E X) :
      vis_ctx_sbisim e <= (st eq).
    Proof.
      apply Coinduction.
      intros R.
      apply leq_vis_ctx.
      intros k k' kk'.
      cbn.
      split; intros ? ? TR; inv_trans; subst; cbn.
      - do 2 eexists; split; etrans; split; auto.
        rewrite EQ; now eapply (b_T (sb eq)).
      - do 2 eexists; split; etrans; split; auto.
        rewrite EQ; now eapply (b_T (sb eq)).
    Qed.

  End Specialized.

End sb_vis_ctx.

Arguments vis_ctx_sbisim_t {E C X X' _} e.

Ltac __upto_vis_sbisim :=
  match goal with
    |- @sbisim ?E ?F ?C _ ?X _ _ _ ?RR (Vis ?e _) (Vis ?e _) =>
      apply (ft_t (vis_ctx_sbisim_t e)), in_vis_ctx; intros ?
  | |- body (t (@sb ?E ?F ?C _ ?X _ _ ?R _)) ?RR (Vis ?e _) (Vis ?f _) =>
      apply (ft_t (vis_ctx_sbisim_t e)), in_vis_ctx; intros ?
  | |- body (bt (@sb ?E ?F ?C _ ?X _ _ ?R _)) ?RR (Vis ?e _) (Vis ?f _) =>
      apply (fbt_bt (vis_ctx_sbisim_t e)), in_vis_ctx; intros ?
  end.

#[local] Tactic Notation "upto_vis" := __upto_vis_sbisim.

Ltac __play_sbisim := step; split; cbn; intros ? ? ?TR.

Ltac __playL_sbisim H :=
  step in H;
  let Hf := fresh "Hf" in
  destruct H as [Hf _];
  cbn in Hf; edestruct Hf as (? & ? & ?TR & ?EQ & ?);
  clear Hf; subst; [etrans |].

Ltac __eplayL_sbisim :=
  match goal with
  | h : @sbisim ?E _ ?C _ ?X _ _ _ ?RR _ _ |- _ =>
      __playL_sbisim h
  end.

Ltac __playR_sbisim H :=
  step in H;
  let Hb := fresh "Hb" in
  destruct H as [_ Hb];
  cbn in Hb; edestruct Hb as (? & ? & ?TR & ?EQ & ?);
  clear Hb; subst; [etrans |].

Ltac __eplayR_sbisim :=
  match goal with
  | h : @sbisim ?E ?C ?X _ _ _ |- _ =>
      __playR_sbisim h
  end.

#[local] Tactic Notation "play" := __play_sbisim.
#[local] Tactic Notation "playL" "in" ident(H) := __playL_sbisim H.
#[local] Tactic Notation "playR" "in" ident(H) := __playR_sbisim H.
#[local] Tactic Notation "eplayL" := __eplayL_sbisim.
#[local] Tactic Notation "eplayR" := __eplayR_sbisim.

(*|
Proof rules for [~]
-------------------
Naive bisimulations proofs naturally degenerate into exponential proofs,
splitting into two goals at each step.
The following proof rules avoid this issue in particular cases.

Be sure to notice that contrary to equations such that [sb_guard] or
up-to principles such that [upto_vis], (most of) these rules consume a [sb].

TODO: need to think more about this --- do we want more proof rules?
Do we actually need them on [sb (st R)], or something else?
|*)
Section Proof_Rules.

  Arguments label : clear implicits.
  Context {E C : Type -> Type} {X: Type}
          `{HasStuck : B0 -< C}.

  Lemma step_sb_ret_gen {Y F D} {L: rel (label E) (label F)} `{B0 -< D}
        (x: X) (y: Y) (R : rel (ctree E C X) (ctree F D Y)) :
    R stuckD stuckD ->
    L (val x) (val y) ->
    (Proper (equ eq ==> equ eq ==> impl) R) ->
    sb L R (Ret x) (Ret y).
  Proof.
    intros Rstuck ValRefl PROP.
    split; apply step_ss_ret_gen; eauto.
    typeclasses eauto.
  Qed.

  Lemma step_sb_ret {Y F D} {L: rel (label E) (label F)} `{B0 -< D}
        (x: X) (y: Y) (R : rel (ctree E C X) (ctree F D Y)) :
    L (val x) (val y) ->
    sbt L R (Ret x) (Ret y).
  Proof.
    intros LH; subst.
    apply step_sb_ret_gen; eauto.
    - step; split;
      apply is_stuck_sb; apply stuckD_is_stuck.
    - typeclasses eauto.
  Qed.

  (*|
    The vis nodes are deterministic from the perspective of the labeled transition system,
    stepping is hence symmetric and we can just recover the itree-style rule.
  |*)
  Lemma step_sb_vis_gen {Y F D X' Y'} `{B0 -< D} (e: E X) (f: F Y)
        (k: X -> ctree E C X') (k': Y -> ctree F D Y') {L R : rel _ _}:
    (Proper (equ eq ==> equ eq ==> impl) R) ->
    (forall x, exists y, R (k x) (k' y) /\ L (obs e x) (obs f y)) ->
    (forall y, exists x, R (k x) (k' y) /\ L (obs e x) (obs f y)) ->
    sb L R (Vis e k) (Vis f k').
  Proof.
    intros PR EQs EQs'.
    split; apply step_ss_vis_gen; eauto.
    typeclasses eauto.
  Qed.

  Lemma step_sb_vis {Y F D X' Y'} `{B0 -< D}
        (e: E X) (f: F Y) (k: X -> ctree E C X') (k': Y -> ctree F D Y') {L R : rel _ _}:
    (forall x, exists y, st L R (k x) (k' y) /\ L (obs e x) (obs f y)) ->
    (forall y, exists x, st L R (k x) (k' y) /\ L (obs e x) (obs f y)) ->
    sbt L R (Vis e k) (Vis f k').
  Proof.
    intros EQs EQs'.
    apply step_sb_vis_gen; eauto.
    typeclasses eauto.
  Qed.

  Lemma step_sb_vis_id_gen {F D X' Y'} `{B0 -< D}
        (e: E X) (f: F X) (k: X -> ctree E C X') (k': X -> ctree F D Y') {L R : rel _ _}:
    (Proper (equ eq ==> equ eq ==> impl) R) ->
    (forall x, R (k x) (k' x) /\ L (obs e x) (obs f x)) ->
    sb L R (Vis e k) (Vis f k').
  Proof.
    intros PR EQs.
    split; apply step_ss_vis_id_gen; auto.
    typeclasses eauto.
  Qed.

  Lemma step_sb_vis_id {F D X' Y'} `{B0 -< D}
        (e: E X) (f: F X) (k: X -> ctree E C X') (k': X -> ctree F D Y') {L R : rel _ _}:
    (forall x, st L R (k x) (k' x)) ->
    (forall x, L (obs e x) (obs f x)) ->
    sbt L R (Vis e k) (Vis f k').
  Proof.
    intros.
    eapply step_sb_vis_id_gen; auto.
    typeclasses eauto.
  Qed.

  (*|
    Same goes for visible tau nodes.
  |*)
  Lemma step_sb_step_gen {Y F D} `{HasStuck': B0 -< D} `{HasTau: B1 -< C}
        `{HasTau': B1 -< D} (t : ctree E C X) (t' : ctree F D Y) (R L: rel _ _) :
    (Proper (equ eq ==> equ eq ==> impl) R) ->
    L tau tau ->
    (R t t') ->
    sb L R (Step t) (Step t').
  Proof.
    intros. split; apply step_ss_step_gen; auto.
    typeclasses eauto.
  Qed.

  Lemma step_sb_step {Y F D} `{HasStuck': B0 -< D} `{HasTau: B1 -< C}
        `{HasTau': B1 -< D} (t : ctree E C X) (t' : ctree F D Y) (R L: rel _ _) :
    L tau tau ->
    (st L R t t') ->
    sbt L R (Step t) (Step t').
  Proof.
    apply step_sb_step_gen.
    typeclasses eauto.
  Qed.

  (*|
    When matching visible brs one against another, in general we need to explain how
    we map the branches from the left to the branches to the right, and reciprocally.
    A useful special case is the one where the arity coincide and we simply use the identity
    in both directions. We can in this case have [n] rather than [2n] obligations.
    |*)
  Lemma step_sb_brS_gen {X' Y Y' F D} (c : C X) (c' : D Y) `{B0 -< D}
        (k : X -> ctree E C X') (k' : Y -> ctree F D Y') (L R : rel _ _):
    (Proper (equ eq ==> equ eq ==> impl) R) ->
    L tau tau ->
    (forall x, exists y, R (k x) (k' y)) ->
    (forall y, exists x, R (k x) (k' y)) ->
    sb L R (BrS c k) (BrS c' k').
  Proof.
    intros PROP ? EQs1 EQs2.
    split; intros ? ? TR; inv_trans; subst.
    - destruct (EQs1 x) as [y HR].
      do 2 eexists. intuition.
      etrans.
      rewrite EQ; eauto.
    - destruct (EQs2 x) as [y HR].
      do 2 eexists. intuition.
      etrans.
      cbn; rewrite EQ; eauto.
  Qed.

  Lemma step_sb_brS {Y F D X' Y'} (c : C X) (c' : D Y) `{B0 -< D}
        (k : X -> ctree E C X') (k' : Y -> ctree F D Y') (L R : rel _ _):
    L tau tau ->
    (forall x, exists y, st L R (k x) (k' y)) ->
    (forall y, exists x, st L R (k x) (k' y)) ->
    sbt L R (BrS c k) (BrS c' k').
  Proof.
    intros EQs1 EQs2.
    apply step_sb_brS_gen; auto.
    typeclasses eauto.
  Qed.

  Lemma step_sb_brS_id_gen {F X' Y'} (c : C X)
        (k : X -> ctree E C X') (k' : X -> ctree F C Y') (R L: rel _ _) :
    (Proper (equ eq ==> equ eq ==> impl) R) ->
    L tau tau ->
    (forall x, R (k x) (k' x)) ->
    sb L R (BrS c k) (BrS c k').
  Proof.
    intros PROP ? EQs.
    apply step_sb_brS_gen; trivial; intros x; exists x; auto.
  Qed.

  Lemma step_sb_brS_id {F X' Y'} (c : C X)
        (k : X -> ctree E C X') (k' : X -> ctree F C Y') (R L: rel _ _):
    L tau tau ->
    (forall x, st L R (k x) (k' x)) ->
    sbt L R (BrS c k) (BrS c k').
  Proof.
    apply step_sb_brS_id_gen.
    typeclasses eauto.
  Qed.

  (*|
    For invisible nodes, the situation is different: we may kill them, but that execution
    cannot act as going under the guard.
  |*)
  Lemma step_sb_guard_gen {Y F D} `{B0 -< D} `{B1 -< C} `{B1 -< D}
        (t : ctree E C X) (t' : ctree F D Y) (R L: rel _ _) :
    sb L R t t' ->
    sb L R (Guard t) (Guard t').
  Proof.
    intros EQ.
    split; apply step_ss_guard_gen; apply EQ.
  Qed.

  Lemma step_sb_guard {Y F D} `{B0 -< D} `{B1 -< D} `{B1 -< C}
        (t : ctree E C X) (t' : ctree F D Y) (R L: rel _ _) :
    sbt L R t t' ->
    sbt L R (Guard t) (Guard t').
  Proof.
    now apply step_sb_guard_gen.
  Qed.

  Lemma step_sb_brD_gen {Y X' Y' F D} `{B0 -< D} (c : C X) (d: D Y)
        (k : X -> ctree E C X') (k' : Y -> ctree F D Y') (R L: rel _ _) :
    (forall x, exists y, sb L R (k x) (k' y)) ->
    (forall y, exists x, sb L R (k x) (k' y)) ->
    sb L R (BrD c k) (BrD d k').
  Proof.
    intros EQs1 EQs2.
    split; apply step_ss_brD_gen; intros.
    - destruct (EQs1 x) as [z [FW _]]. eauto.
    - destruct (EQs2 x) as [z [_ BA]]. eauto.
  Qed.

  Lemma step_sb_brD {Y X' Y' F D} `{B0 -< D} (c : C X) (d: D Y)
        (k : X -> ctree E C X') (k' : Y -> ctree F D Y') (R L: rel _ _) :
    (forall x, exists y, sbt L R (k x) (k' y)) ->
    (forall y, exists x, sbt L R (k x) (k' y)) ->
    sbt L R (BrD c k) (BrD d k').
  Proof.
    now apply step_sb_brD_gen.
  Qed.

  Lemma step_sb_brD_id_gen {Y Z F} (c : C X)
        (k : X -> ctree E C Y) (k' : X -> ctree F C Z) (R L: rel _ _) :
    (forall x, sb L R (k x) (k' x)) ->
    sb L R (BrD c k) (BrD c k').
  Proof.
    intros; apply step_sb_brD_gen.
    intros x; exists x; apply H.
    intros x; exists x; apply H.
  Qed.

  Lemma step_sb_brD_id  {Y Z F} (c : C X)
        (k : X -> ctree E C Y) (k' : X -> ctree F C Z) (R L: rel _ _) :
    (forall x, sbt L R (k x) (k' x)) ->
    sbt L R (BrD c k) (BrD c k').
  Proof.
    now apply step_sb_brD_id_gen.
  Qed.

End Proof_Rules.

(*|
Proof system for [~]
--------------------

While the proof rules from the previous section are useful for performing full on
coinductive proofs, lifting these at the level of [sbisim] can allow for completely
avoiding any coinduction when combined with a pre-established equational theory.
|*)
Section Sb_Proof_System.
  Arguments label: clear implicits.
  Context {E C: Type -> Type} {X: Type}
          `{B0 -< C}.

  Lemma sb_ret : forall x y,
      x = y ->
      (Ret x: ctree E C X) ~ (Ret y: ctree E C X).
  Proof.
    intros * EQ; step.
    now apply step_sb_ret; subst.
  Qed.

  Lemma sb_vis {Y}: forall (e: E X) (k k': X -> ctree E C Y),
      (forall x, k x ~ k' x) ->
      Vis e k ~ Vis e k'.
  Proof.
    intros.
    upto_vis.
    apply H0.
  Qed.

  (*|
    Visible vs. Invisible Taus
    ~~~~~~~~~~~~~~~~~~~~~~~~~~
    Invisible taus can be stripped-out w.r.t. to [sbisim], but not visible ones
  |*)
  Lemma sb_guard `{B1 -< C}: forall (t : ctree E C X),
      Guard t ~ t.
  Proof.
    intros t; play.
    - inv_trans; etrans.
    - eauto 6 with trans.
  Qed.

 Lemma sb_guard_l `{B1 -< C}: forall (t u : ctree E C X),
      t ~ u ->
      Guard t ~ u.
  Proof.
    intros * EQ; now rewrite sb_guard.
  Qed.

  Lemma sb_guard_r `{B1 -< C}: forall (t u : ctree E C X),
      t ~ u ->
      t ~ Guard u.
  Proof.
    intros * EQ; now rewrite sb_guard.
  Qed.

  Lemma sb_guard_lr `{B1 -< C}: forall (t u : ctree E C X),
      t ~ u ->
      Guard t ~ Guard u.
  Proof.
    intros * EQ; now rewrite !sb_guard.
  Qed.

  Lemma sb_step `{B1 -< C}: forall (t u : ctree E C X),
      t ~ u ->
      Step t ~ Step u.
  Proof.
    intros * EQ; step.
    apply step_sb_step; auto.
  Qed.

  (* TODO: Double check that this is needed, it should be taus in all contexts I can think of *)
  Lemma sb_brD1 (c1: C (fin 1)): forall (k : fin 1 -> ctree E C X),
      BrD c1 k ~ k F1.
  Proof.
    intros; step; econstructor.
    - intros ? ? ?. inv H0.
      apply Eqdep.EqdepTheory.inj_pair2 in H4, H5; subst.
      dependent destruction x; exists l, t'; etrans; auto.
      inversion x.
    - intros ? ? ?; cbn.
      eauto 6 with trans.
  Qed.

  Lemma sb_brS I J (ci : C I) (cj : C J)
        (k : I -> ctree E C X) (k' : J -> ctree E C X) :
    (forall x, exists y, k x ~ k' y) ->
    (forall y, exists x, k x ~ k' y) ->
    BrS ci k ~ BrS cj k'.
  Proof.
    intros * EQs1 EQs2; step.
    apply @step_sb_brS; auto.
  Qed.

  Lemma sb_brS_id I (c : C I)
        (k k' : I -> ctree E C X) :
    (forall x, k x ~ k' x) ->
    BrS c k ~ BrS c k'.
  Proof.
    intros * EQs; step.
    apply @step_sb_brS_id; auto.
  Qed.

  Lemma sb_brD I J (ci : C I) (cj : C J)
        (k : I -> ctree E C X) (k' : J -> ctree E C X) :
    (forall x, exists y, k x ~ k' y) ->
    (forall y, exists x, k x ~ k' y) ->
    BrD ci k ~ BrD cj k'.
  Proof.
    intros; step.
    eapply @step_sb_brD; auto.
    intros x; destruct (H0 x) as (y & EQ).
    exists y; now step in EQ.
    intros y; destruct (H1 y) as (x & EQ).
    exists x; now step in EQ.
  Qed.

  Lemma sb_brD_id I (c : C I)
        (k k' : I -> ctree E C X) :
    (forall x, k x ~ k' x) ->
    BrD c k ~ BrD c k'.
  Proof.
    intros; step.
    apply @step_sb_brD_id; intros x.
    specialize (H0 x).
    now step in H0.
  Qed.

  Lemma sb_brD_idempotent `{B1 -< C} {HasFin : Bn -< C} n (k: fin (S n) -> ctree E C X) (t: ctree E C X):
      (forall x, k x ~ t) ->
      brDn k ~ t.
  Proof.
    intros * EQ.
    rewrite <- sb_guard with (t:=t).
    apply sb_brD; intros.
    exists tt; apply EQ.
    exists F1; apply EQ.
  Qed.

  Lemma unfold_forever{HasTau: B1 -< C}: forall (t: ctree E C X),
      @forever C _ E X X t ~ t ;; @forever C _ E X X t.
  Proof.
    intro t.
    rewrite (ctree_eta (forever t)).
    rewrite unfold_forever_.
    rewrite <- ctree_eta.
    __upto_bind_eq_sbisim.
    apply sb_guard.
  Qed.
End Sb_Proof_System.

(* TODO: tactics!
   Should it be the same to step at both levels or two different sets?

Ltac bsret  := apply step_sb_ret.
Ltac bsvis  := apply step_sb_vis.
Ltac bstauv := apply step_sb_tauV.
Ltac bsstep := bsret || bsvis || bstauv.

Ltac sret  := apply sb_ret.
Ltac svis  := apply sb_vis.
Ltac stauv := apply sb_tauV.
Ltac sstep := sret || svis || stauv.

 *)

Section WithParams.

  Context {E C : Type -> Type}.
  Context {HasStuck : B0 -< C}.
  Context {HasTau : B1 -< C}.
  Context {HasC2 : B2 -< C}.
  Context {HasC3 : B3 -< C}.

(*|
Sanity checks
=============
- invisible n-ary spins are strongly bisimilar
- non-empty visible n-ary spins are strongly bisimilar
- Binary invisible br is:
  + associative
  + commutative
  + merges into a ternary invisible br
  + admits any stuckD computation as a unit

Note: binary visible br are not associative up-to [sbisim].
They aren't even up-to [wbisim].
|*)

(*|
Note that with visible schedules, nary-spins are equivalent only
if neither are empty, or if both are empty: they match each other's
tau challenge infinitely often.
With invisible schedules, they are always equivalent: neither of them
produce any challenge for the other.
|*)

  Lemma spinS_gen_nonempty : forall {Z X Y} (c: C X) (c': C Y) (x: X) (y: Y),
      @spinS_gen E C Z X c ~ @spinS_gen E C Z Y c'.
  Proof.
    intros R.
    coinduction S CIH. symmetric.
    intros ** L t' TR;
    rewrite ctree_eta in TR; cbn in TR;
    apply trans_brS_inv in TR as (_ & EQ & ->);
    eexists; eexists;
    rewrite ctree_eta; cbn.
    split; [econstructor|].
    - exact y.
    - reflexivity.
    - rewrite EQ; eauto.
  Qed.

  Lemma spinD_gen_bisim : forall {Z X Y} (c: C X) (c': C Y),
      @spinD_gen E C Z X c ~ @spinD_gen E C Z Y c'.
  Proof.
    intros R.
    coinduction S _; split; cbn;
      intros * TR; exfalso; eapply spinD_gen_is_stuck, TR.
  Qed.

  (*|
    BrD2 is associative, commutative, idempotent, merges into BrD3, and admits _a lot_ of units.
    |*)
  Lemma brD2_assoc X : forall (t u v : ctree E C X),
	    brD2 (brD2 t u) v ~ brD2 t (brD2 u v).
  Proof.
    intros.
    play; inv_trans; eauto 7 with trans.
  Qed.

  Lemma brD2_commut {X} : forall (t u : ctree E C X),
	    brD2 t u ~ brD2 u t.
  Proof.
    intros.
    play; inv_trans; eauto 6 with trans.
  Qed.

  Lemma brD2_idem {X} : forall (t : ctree E C X),
	    brD2 t t ~ t.
  Proof.
    intros.
    play; inv_trans; eauto 6 with trans.
  Qed.

  Lemma brD2_merge {X} : forall (t u v : ctree E C X),
	    brD2 (brD2 t u) v ~ brD3 t u v.
  Proof.
    intros.
    play; inv_trans; eauto 7 with trans.
  Qed.

  Lemma brD2_is_stuck {X} : forall (u v : ctree E C X),
      is_stuck u ->
	    brD2 u v ~ v.
  Proof.
    intros * ST.
    play.
    - inv_trans.
      exfalso; eapply ST, TR. (* automate stuck transition trying to step? *)
      exists l, t'; eauto.             (* automate trivial case *)
    - eauto 6 with trans.
  Qed.

  Lemma brD2_stuckS_l {X} : forall (t : ctree E C X),
	    brD2 stuckS t ~ t.
  Proof.
    intros; apply brD2_is_stuck, stuckS_is_stuck.
  Qed.

  Lemma brD2_stuckD_l {X} : forall (t : ctree E C X),
	    brD2 stuckD t ~ t.
  Proof.
    intros; apply brD2_is_stuck, stuckD_is_stuck.
  Qed.

  Lemma brD2_stuckS_r {X} : forall (t : ctree E C X),
	    brD2 t stuckS ~ t.
  Proof.
    intros; rewrite brD2_commut; apply brD2_stuckS_l.
  Qed.

  Lemma brD2_stuckD_r {X} : forall (t : ctree E C X),
	    brD2 t stuckD ~ t.
  Proof.
    intros; rewrite brD2_commut; apply brD2_stuckD_l.
  Qed.

  Lemma brD2_spinD_l {X} : forall (t : ctree E C X),
	    brD2 spinD t ~ t.
  Proof.
    intros; apply brD2_is_stuck, spinD_is_stuck.
  Qed.

  Lemma brD2_spinD_r {X} : forall (t : ctree E C X),
	    brD2 t spinD ~ t.
  Proof.
    intros; rewrite brD2_commut; apply brD2_is_stuck, spinD_is_stuck.
  Qed.

(*|
BrS2 is commutative and "almost" idempotent
|*)
  Lemma brS2_commut : forall X (t u : ctree E C X),
	    brS2 t u ~ brS2 u t.
  Proof.
    intros.
    play; inv_trans; subst.
    all: do 2 eexists; split; [| split; [rewrite EQ; reflexivity| reflexivity]]; etrans.
  Qed.

  Lemma brS2_idem : forall X (t : ctree E C X),
	    brS2 t t ~ Step t.
  Proof.
    intros.
    play; inv_trans; subst.
    all: do 2 eexists; split; [| split; [rewrite EQ; reflexivity| reflexivity]]; etrans.
  Qed.

(*|
Inversion principles
--------------------
|*)
  Lemma sbisim_ret_inv X (r1 r2 : X) :
    (Ret r1 : ctree E C X) ~ (Ret r2 : ctree E C X) -> r1 = r2.
  Proof.
    intro.
    eplayL.
    now inv_trans.
  Qed.

(*|
 For the next few lemmas, we need to know that [X] is inhabited in order to
 take a step
|*)
  Lemma sbisim_vis_invT {X X1 X2}
        (e1 : E X1) (e2 : E X2) (k1 : X1 -> ctree E C X) (k2 : X2 -> ctree E C X) (x : X1):
    Vis e1 k1 ~ Vis e2 k2 ->
    X1 = X2.
  Proof.
    intros.
    eplayL.
    inv TR; auto.
    Unshelve. auto.
  Qed.

  Lemma sbisim_vis_inv {X Y} (e1 e2 : E Y) (k1 k2 : Y -> ctree E C X) (x : Y) :
    Vis e1 k1 ~ Vis e2 k2 ->
    e1 = e2 /\ forall x, k1 x ~ k2 x.
  Proof.
    intros.
    split.
    - eplayL.
      etrans.
      inv_trans; eauto.
    - intros.
      clear x.
      eplayL.
      inv_trans.
      subst. eauto.
      Unshelve. auto.
  Qed.

  Lemma sbisim_BrS_inv {X Y Z}
        c1 c2 (k1 : X -> ctree E C Z) (k2 : Y -> ctree E C Z) :
    BrS c1 k1 ~ BrS c2 k2 ->
    (forall i1, exists i2, k1 i1 ~ k2 i2).
  Proof.
    intros EQ i1.
    eplayL.
    inv_trans.
    eexists; eauto.
  Qed.

  (*|
    Annoying case: [Vis e k ~ BrS c k'] is true if [e : E void] and [c : C void].
    We rule out this case in this definition.
    |*)
  Definition are_bisim_incompat {X} (t u : ctree E C X) : Type :=
    match observe t, observe u with
    | RetF _, RetF _
    | VisF _ _, VisF _ _
    | BrF true _ _, BrF true _ _
    | BrF false _ _, _
    | _, BrF false _ _ => False
    | BrF true n _, RetF _ => True
    | RetF _,  BrF true n _ => True
    | @BrF _ _ _ _ true X _ _, @VisF _ _ _ _ Y _ _ =>
        inhabited X + inhabited Y
    | @VisF _ _ _ _ Y _ _, @BrF _ _ _ _ true X _ _ =>
        inhabited X + inhabited Y
    | _, _ => True
    end.

  Lemma sbisim_absurd {X} (t u : ctree E C X) :
    are_bisim_incompat t u ->
    t ~ u ->
    False.
  Proof.
    intros * IC EQ.
    unfold are_bisim_incompat in IC.
    setoid_rewrite ctree_eta in EQ.
    genobs t ot. genobs u ou.
    destruct ot, ou;
      (try now inv IC); (try destruct vis); (try destruct vis0);
      try now inv IC.
    - playL in EQ. inv_trans.
    - playL in EQ. inv_trans.
    - playR in EQ. inv_trans.
    - destruct IC as [[] | []]; [ playR in EQ | playL in EQ ]; inv_trans.
    - playR in EQ. inv_trans.
    - destruct IC as [[] | []]; [ playL in EQ | playR in EQ ]; inv_trans.
    Unshelve. all: auto.
  Qed.

  Ltac sb_abs h :=
    eapply sbisim_absurd; [| eassumption]; cbn; try reflexivity.

  Lemma sbisim_ret_vis_inv {X Y}(r : Y) (e : E X) (k : X -> ctree E C Y) :
    (Ret r : ctree E C _) ~ Vis e k -> False.
  Proof.
    intros * abs. sb_abs abs.
  Qed.

  Lemma sbisim_ret_BrS_inv {X Y} (r : Y) (c : C X) (k : X -> ctree E C Y) :
    (Ret r : ctree E C _) ~ BrS c k -> False.
  Proof.
    intros * abs; sb_abs abs.
  Qed.

  (*|
    For this to be absurd, we need one of the return types to be inhabited.
    |*)
  Lemma sbisim_vis_BrS_inv {X Y Z}
        (e : E X) (k1 : X -> ctree E C Z) (c : C Y) (k2: Y -> ctree E C Z) (y : Y) :
    Vis e k1 ~ BrS c k2 -> False.
  Proof.
    intros * abs.
    sb_abs abs. eauto.
  Qed.

  Lemma sbisim_vis_BrS_inv' {X Y Z}
        (e : E X) (k1 : X -> ctree E C Z) (c : C Y) (k2: Y -> ctree E C Z) (x : X) :
    Vis e k1 ~ BrS c k2 -> False.
  Proof.
    intros * abs.
    sb_abs abs. eauto.
  Qed.

(*|
Not fond of these two, need to give some thoughts about them
|*)
  Lemma sbisim_ret_BrD_inv {X Y} (r : Y) (c : C X) (k : X -> ctree E C Y) :
    (Ret r : ctree E C _) ~ BrD c k ->
    exists x, (Ret r : ctree E C _) ~ k x.
  Proof.
    intro. step in H. destruct H as [Hf Hb]. cbn in *.
    edestruct Hf as (x & ? & Ht & Hs & ?); [apply trans_ret |].
    apply trans_brD_inv in Ht.
    destruct Ht as [i Ht]. exists i.
    step. split.
    - repeat intro. inv H0. exists (val r), x0. split; intuition. rewrite <- Hs.
      rewrite ctree_eta. rewrite <- H4. rewrite br0_always_stuck. reflexivity.
    - repeat intro. eapply trans_brD in H0; eauto.
  Qed.

  Lemma sbisim_BrD_1_inv X (c1: C (fin 1)) (k : fin 1 -> ctree E C X) (t: ctree E C X) i :
    BrD c1 k ~ t ->
    k i ~ t.
  Proof.
    intro. step in H. step. destruct H. cbn in *. split; repeat intro.
    - apply H. econstructor; apply H1.
    - edestruct H0. apply H1. exists x; auto.
      destruct H2 as (? & ? & ? & ?); subst.
      destruct (trans_brD_inv H2) as (j & ?).
      assert (i = j).
      {
        remember 1%nat.
        destruct i.
        - dependent destruction j; auto.
          inv Heqn. inv j.
        - inv Heqn. inv i.
      }
      subst. eauto.
  Qed.

End WithParams.

Section StrongSimulations.

  Context {E F C D: Type -> Type} {X Y: Type}
          {L: rel (@label E) (@label F)}
          {HasStuck1: B0 -< C} {HasStuck2: B0 -< D}.

  Notation ss := (@ss E F C D X Y _ _).
  Notation sst L := (coinduction.t (ss L)).
  Notation ssim  := (@ssim E F C D X Y _ _).
  Notation ssbt L := (coinduction.bt (ss L)).
  Notation ssT L := (coinduction.T (ss L)).

  Lemma sbisim_clos_ss : @sbisim_clos E F C D X Y _ _ eq eq <= (sst L).
  Proof.
    intro R1. apply Coinduction.
    cbn; intros Rs x y [z x' y' z' SBzx' x'y' SBy'z'].
    - intros l t zt.
      step in SBzx'.
      apply SBzx' in zt as (l' & t' & x't' & ? & ?); subst.
      destruct (x'y' _ _ x't') as (l'' & t'' & y't'' & ? & ?).

      step in SBy'z'.
      apply SBy'z' in y't'' as (ll & tt & z'tt & ? & ?); subst.
      exists ll, tt; split; trivial.
      + split; trivial.
        apply (f_Tf (ss L)).
        econstructor; eauto.
  Qed.

(*|
    Instances for rewriting [sbisim] under all [ss]-related contexts
|*)
  #[global] Instance sbisim_eq_clos_ssim_goal:
    Proper (sbisim eq ==> sbisim eq ==> flip impl) (ssim L).
  Proof.
    cbn.
    coinduction R CH. intros * EQ1 * EQ2 SIM.
    do 2 red; cbn; intros * TR.
    symmetry in EQ2.
    step in EQ1; apply EQ1 in TR as (? & ? & ? & ? & ?).
    step in SIM; apply SIM in H as (? & ? & ? & ? & ?).
    step in EQ2; apply EQ2 in H as (? & ? & ? & ? & ?); subst.
    do 2 eexists.
    split; [eassumption |].
    split; [| eassumption].
    symmetry in H4. eapply CH; eassumption.
  Qed.

  #[global] Instance sbisim_eq_clos_ssim_ctx :
    Proper (sbisim eq ==> sbisim eq ==> impl) (ssim L).
  Proof.
    repeat intro. symmetry in H, H0. eapply sbisim_eq_clos_ssim_goal; eauto.
  Qed.

  #[global] Instance sbisim_eq_clos_sst_goal RR :
    Proper (sbisim eq ==> sbisim eq ==> flip impl) (sst L RR).
  Proof.
    cbn; intros ? ? eq1 ? ? eq2 H.
    apply (ft_t sbisim_clos_ss). cbn.
    econstructor; eauto.
    now rewrite eq2.
  Qed.

  #[global] Instance sbisim_eq_clos_sst_ctx RR :
    Proper (sbisim eq ==> sbisim eq ==> impl) (sst L RR).
  Proof.
    cbn; intros ? ? eq1 ? ? eq2 ?.
    rewrite <- eq1, <- eq2.
    auto.
  Qed.

  #[global] Instance sbisim_eq_clos_ssT_goal RR f :
    Proper (sbisim eq ==> sbisim eq ==> flip impl) (ssT L f RR).
  Proof.
    cbn; intros ? ? eq1 ? ? eq2 H.
    apply (fT_T sbisim_clos_ss). cbn.
    econstructor; eauto.
    now rewrite eq2.
  Qed.

  #[global] Instance sbisim_eq_clos_ssT_ctx RR f :
    Proper (sbisim eq ==> sbisim eq ==> impl) (ssT L f RR).
  Proof.
    cbn; intros ? ? eq1 ? ? eq2 ?.
    rewrite <- eq1, <- eq2.
    auto.
  Qed.

End StrongSimulations.

Section CompleteStrongSimulations.

  Context {E F C D: Type -> Type} {X Y: Type}
          {L: rel (@label E) (@label F)}
          {HasStuck1: B0 -< C} {HasStuck2: B0 -< D}.

  Notation css := (@css E F C D X Y _ _).
  Notation csst L := (coinduction.t (css L)).
  Notation cssim  := (@cssim E F C D X Y _ _).
  Notation cssbt L := (coinduction.bt (css L)).
  Notation cssT L := (coinduction.T (css L)).

(*|
A bisimulation trivially gives a simulation.
|*)
  Lemma sb_css : forall RR (t : ctree E C X) (t' : ctree F D Y),
      sb L RR t t' -> css L RR t t'.
  Proof.
    intros; split.
    - apply H.
    - intros. apply H in H0 as (? & ? & ? & ? & ?). eauto.
  Qed.

  (* TODO MOVE to CSim *)
  Lemma cssim_ssim : forall (t : ctree E C X) (t' : ctree F D Y),
      cssim L t t' -> ssim L t t'.
  Proof.
    coinduction R CH. simpl. intros.
    step in H.
    apply H in H0 as (? & ? & ? & ? & ?).
    apply CH in H1.
    exists x, x0; eauto.
  Qed.

  Lemma sbisim_cssim : forall (t : ctree E C X) (t' : ctree F D Y),
      sbisim L t t' -> cssim L t t'.
  Proof.
    coinduction R CH. simpl. intros.
    split; step in H; intros;
      apply H in H0 as (? & ? & ? & ? & ?);
      exists x, x0; auto.
  Qed.

(*|
Various results on reflexivity and transitivity.
|*)
  Lemma sbisim_clos_css : @sbisim_clos E F C D X Y _ _ eq eq <= (csst L).
  Proof.
    intro R1. apply Coinduction.
    cbn; intros Rs x y [z x' y' z' SBzx' [x'y' y'x'] SBy'z']; split.
    - intros l t zt.
      step in SBzx'.
      apply SBzx' in zt as (l' & t' & x't' & ? & ?); subst.
      destruct (x'y' _ _ x't') as (l'' & t'' & y't'' & ? & ?).

      step in SBy'z'.
      apply SBy'z' in y't'' as (ll & tt & z'tt & ? & ?); subst.
      exists ll, tt; split; trivial.
      + split; trivial.
        apply (f_Tf (css L)).
        econstructor; eauto.
    - intros l t z't.
      step in SBy'z'.
      symmetry in SBy'z'.
      apply SBy'z' in z't as (l' & t' & y't' & ? & ?); subst.
      destruct (y'x' _ _ y't') as (l'' & t'' & y't'').
      step in SBzx'.
      apply SBzx' in y't'' as (ll & tt & ztt & ?); subst.
      exists ll, tt; trivial.
  Qed.

(*|
    Aggressively providing instances for rewriting hopefully faster
    [sbisim] under all [ss1]-related contexts (consequence of the transitivity
    of the companion).
|*)
  #[global] Instance sbisim_clos_cssim_goal:
    Proper (sbisim eq ==> sbisim eq ==> flip impl) (cssim L).
  Proof.
    cbn.
    coinduction R CH. intros * EQ1 * EQ2 SIM.
    do 2 red; cbn; split; intros * TR.
    - symmetry in EQ2.
      step in EQ1; apply EQ1 in TR as (? & ? & ? & ? & ?).
      step in SIM; apply SIM in H as (? & ? & ? & ? & ?).
      step in EQ2; apply EQ2 in H as (? & ? & ? & ? & ?); subst.
      do 2 eexists.
      split; [eassumption |].
      split; [| eassumption].
      symmetry in H4. eapply CH; eassumption.
    - step in EQ2; apply EQ2 in TR as (? & ? & ? & ? & ?).
      step in SIM. apply SIM in H as (? & ? & ?).
      step in EQ1. apply EQ1 in H as (? & ? & ? & ?); simpl in *; subst.
      do 2 eexists.
      eauto.
  Qed.

  #[global] Instance sbisim_clos_cssim_ctx :
    Proper (sbisim eq ==> sbisim eq ==> impl) (cssim L).
  Proof.
    repeat intro. symmetry in H, H0. eapply sbisim_clos_cssim_goal; eauto.
  Qed.

  #[global] Instance sbisim_clos_csst_goal RR :
    Proper (sbisim eq ==> sbisim eq ==> flip impl) (csst L RR).
  Proof.
    cbn; intros ? ? eq1 ? ? eq2 H.
    apply (ft_t sbisim_clos_css). cbn.
    econstructor; eauto.
    now rewrite eq2.
  Qed.

  #[global] Instance sbisim_clos_csst_ctx RR :
    Proper (sbisim eq ==> sbisim eq ==> impl) (csst L RR).
  Proof.
    cbn; intros ? ? eq1 ? ? eq2 ?.
    rewrite <- eq1, <- eq2.
    auto.
  Qed.

  #[global] Instance sbisim_clos_cssT_goal RR f :
    Proper (sbisim eq ==> sbisim eq ==> flip impl) (cssT L f RR).
  Proof.
    cbn; intros ? ? eq1 ? ? eq2 H.
    apply (fT_T sbisim_clos_css). cbn.
    econstructor; eauto.
    now rewrite eq2.
  Qed.

  #[global] Instance sbisim_clos_ccssT_ctx RR f :
    Proper (sbisim eq ==> sbisim eq ==> impl) (cssT L f RR).
  Proof.
    cbn; intros ? ? eq1 ? ? eq2 ?.
    rewrite <- eq1, <- eq2.
    auto.
  Qed.

(*|
A strong bisimulation gives two strong simulations,
but two strong simulations do not always give a strong bisimulation.
This property is true if we only allow choices with 0 or 1 branch,
but we prove a counter-example for a ctree with a binary choice.
|*)

  Lemma css_sb : forall RR (t : ctree E C X) (t' : ctree F D Y),
      css L RR t t' ->
      CSSim.css (flip L) (flip RR) t' t ->
      sb L RR t t'.
  Proof.
    split; cbn; intros.
    - apply H in H1 as (? & ? & ? & ? & ?); eauto.
    - apply H0 in H1 as (? & ? & ? & ? & ?); eauto.
  Qed.

  (* TODO MOVE To Trans *)
  Lemma ctree_B01_trans_det : forall {E X} l (t t' t'' : ctree E B01 X),
      trans l t t' -> trans l t t'' -> t' ≅ t''.
  Proof.
    intros. do 3 red in H.
    rewrite ctree_eta in H0.
    genobs t ot. genobs t' ot'. rewrite ctree_eta, <- Heqot'.
    clear t t' Heqot Heqot'. revert t'' H0.
    dependent induction H; intros; inv_trans.
    - eapply IHtrans_; cbn.
      rewrite <- ctree_eta.
      destruct c, b, x0, x; intuition.
    - rewrite <- ctree_eta. destruct c, b, x, x0.
      now rewrite H.
    - subst. rewrite <- ctree_eta. now rewrite H.
    - apply br0_always_stuck.
  Qed.

  (* TODO Think a bit about these and reestablish them, they are a bit weird *)
  (* Lemma ssim_sbisim_equiv_gen :
    forall `{Injective (@label E) (@label F) L}
      `{Deterministic _ _ L}
      (t : ctree E C X) (t' : ctree F D Y),
      ssim L t t' -> ssim (flip L) t' t -> sbisim L t t'.
  Proof.
    intros until 2.
    coinduction R CH. red. red. cbn. split; intros.
    - step in H1. cbn in H1.
      apply H1 in H3 as H3'. destruct H3' as (? & ? & ? & ? & ?).
      exists x, x0. intuition. apply CH.
      + apply H5.
      + step in H2. cbn in H2. apply H2 in H4 as (? & ? & ? & ? & ?).
        do_inj.
        assert (t'0 ≅ x2) by (eapply ctree_B01_trans_det; eauto). *)
  (*       now rewrite H6. *)
  (*   - step in H2. cbn in H2. *)
  (*     apply H2 in H3 as H3'. destruct H3' as (? & ? & ? & ? & ?). *)
  (*     exists x, x0. intuition. apply CH. *)
  (*     + step in H1. cbn in H1. apply H1 in H4 as (? & ? & ? & ? & ?). *)
  (*       do_det. *)
  (*       assert (t'0 ≅ x2) by (eapply ctree_B01_trans_det; eauto). *)
  (*       now rewrite H6. *)
  (*     + apply H5. *)
  (* Qed. *)

  (* Import SSimNotations. *)
  (* Lemma ssim_sbisim_equiv_gen : *)
  (*   forall `{Injective (@label E) (@label F) L} *)
  (*     `{Deterministic _ _ L} *)
  (*     (t : ctree E C X) (t' : ctree F D Y), *)
  (*     ssim L t t' -> ssim (flip L) t' t -> sbisim L t t'. *)
  (* Proof. *)
  (*   intros until 2. *)
  (*   clear H H0. *)
  (*   coinduction R CH. red. red. cbn. intros * SIM1 SIM2; split; intros * TR. *)
  (*   - step in SIM1. *)
  (*     apply SIM1 in TR as (l' & u' & TR' & ? & ?). *)
  (*     exists l', u'; intuition. *)
  (*     apply CH. *)
  (*     auto. *)
  (*     step in SIM2. *)

  (*     apply SIM1 in TR as TR'. destruct TR' as (? & ? & TR' & ? & ?). *)
  (*     exists x, x0. intuition. apply CH; auto. *)
  (*     step in SIM2. cbn in SIM2. apply SIM2 in TR' as (? & ? & ? & ? & ?). *)

  (*     do_inj. *)
  (*     assert (t'0 ≅ x2) by (eapply ctree_B01_trans_det; eauto). *)
  (*     now rewrite H6. *)
  (*   - step in H2. cbn in H2. *)
  (*     apply H2 in H3 as H3'. destruct H3' as (? & ? & ? & ? & ?). *)
  (*     exists x, x0. intuition. apply CH. *)
  (*     + step in H1. cbn in H1. apply H1 in H4 as (? & ? & ? & ? & ?). *)
  (*       do_det. *)
  (*       assert (t'0 ≅ x2) by (eapply ctree_B01_trans_det; eauto). *)
  (*       now rewrite H6. *)
  (*     + apply H5. *)
  (* Qed. *)

  (* Lemma ssim_sbisim_equiv_eq : forall {E X} (t t' : ctree E B01 X), *)
  (*     ssim eq t t' -> ssim eq t' t -> sbisim eq t t'. *)
  (* Proof. *)
  (*   intros. apply ssim_sbisim_equiv_gen; intros. *)
  (*   - typeclasses eauto. *)
  (*   - typeclasses eauto. *)
  (*   - apply H. *)
  (*   - apply (@ssim_subrelation _ _ _ eq); auto. *)
  (*     red. intros. subst. reflexivity. *)
  (* Qed. *)

  (* #[local] Definition t1 : ctree void1 (B01 +' B2) unit := *)
  (*   Step (Ret tt). *)

  (* #[local] Definition t2 : ctree void1 (B01 +' B2) unit := *)
  (*   brS2 (Ret tt) (stuckD). *)

  (* Lemma ssim_sbisim_nequiv : *)
  (*   ssim eq t1 t2 /\ ssim (flip eq) t2 t1 /\ ~ sbisim eq t1 t2. *)
  (* Proof. *)
  (*   unfold t1, t2. intuition. *)
  (*   - step. eapply step_ss_brS; auto. *)
  (*     exact  (exist _ tt I). *)
  (*     intros _. exists true. reflexivity. *)
  (*   - step. eapply step_ss_brS; auto. *)
  (*     exact  (exist _ true I). *)
  (*     intro. exists tt. destruct x. *)
  (*     + reflexivity. *)
  (*     + step. apply ss_is_stuck. *)
  (*       * apply stuckD_is_stuck. *)
  (*       * admit. (* This looks wrong, Ret is not stuck *) *)
  (*   - step in H. cbn in H. destruct H as [_ ?]. *)
  (*     specialize (H tau stuckD). lapply H; [| etrans]. *)
  (*     intros. destruct H0 as (? & ? & ? & ? & ?). subst. *)
  (*     inv_trans. step in H1. cbn in H1. destruct H1 as [? _]. *)
  (*     specialize (H0 (val tt) stuckD). lapply H0. 2: { etrans. } *)
  (*                                               intro. destruct H1 as (? & ? & ? & ? & ?). subst. *)
  (*     now apply stuckD_is_stuck in H1. *)
  (* Admitted. *)

  (* #[global] Instance sbisim_sbisim_hclosed_goal {E F C D X Y} `{HasStuck: B0 -< C} `{HasStuck': B0 -< D} *)
  (*   {L: rel (@label E) (@label F)} {LE: rel (@label E) (@label E)} {LF: rel (@label F) (@label F)}: *)
  (*   Proper (@sbisim E E C C X X _ _ LE ==> @sbisim F F D D Y Y _ _ LF ==> flip impl) (@sbisim E F C D X Y _ _ L). *)
  (* Proof. *)
  (* Admitted. *)

  (* #[global] Instance sbisim_sbisim_hclosed_ctx {E F C D X Y} `{HasStuck: B0 -< C} `{HasStuck': B0 -< D} *)
  (*   {L: rel (@label E) (@label F)} {LE: rel (@label E) (@label E)} {LF: rel (@label F) (@label F)}: *)
  (*   Proper (@sbisim E E C C X X _ _ LE ==> @sbisim F F D D Y Y _ _ LF ==> impl) (@sbisim E F C D X Y _ _ L). *)
  (* Proof. *)
  (* Admitted. *)

End CompleteStrongSimulations.

Section StrongSimulations.

  Section Heterogeneous.
    Context {E F C D: Type -> Type} {X Y: Type}
      {L: rel (@label E) (@label F)}
      {HasStuck1: B0 -< C} {HasStuck2: B0 -< D}.
    Notation ss := (@ss E F C D X Y _ _).
    Notation sst L := (coinduction.t (ss L)).
    Notation ssim  := (@ssim E F C D X Y _ _).
    Notation ssbt L := (coinduction.bt (ss L)).
    Notation ssT L := (coinduction.T (ss L)).

    Lemma sbisim_ssim : forall (t : ctree E C X) (t' : ctree F D Y),
        sbisim L t t' -> ssim L t t'.
    Proof.
      intros. apply cssim_ssim. now apply sbisim_cssim.
    Qed.

  End Heterogeneous.

  Section Homogeneous.
    Context {E C: Type -> Type} {X: Type}
      {L: rel (@label E) (@label E)}
      {HasStuck1: B0 -< C}.
    Notation ss := (@ss E E C C X X _ _).
    Notation sst L := (coinduction.t (ss L)).
    Notation ssim  := (@ssim E E C C X X _ _).
    Notation ssbt L := (coinduction.bt (ss L)).
    Notation ssT L := (coinduction.T (ss L)).

(*|
Aggressively providing instances for rewriting hopefully faster
[sbisim] under all [ss1]-related contexts (consequence of the transitivity
of the companion).
|*)
  #[global] Instance sbisim_clos_ssim_goal `{Symmetric _ L} `{Transitive _ L} :
    Proper (sbisim L ==> sbisim L ==> flip impl) (ssim L).
  Proof.
    repeat intro.
    transitivity y0. transitivity y.
    - now apply sbisim_ssim in H1.
    - now exact H3.
    - symmetry in H2; now apply sbisim_ssim in H2.
  Qed.

  #[global] Instance sbisim_clos_ssim_ctx `{Equivalence _ L}:
    Proper (sbisim L ==> sbisim L ==> impl) (ssim L).
  Proof.
    repeat intro. symmetry in H0, H1. eapply sbisim_clos_ssim_goal; eauto.
  Qed.

  #[global] Instance sbisim_clos_sst_goal RR `{Equivalence _ L}:
    Proper (sbisim L ==> sbisim L ==> flip impl) (sst L RR).
  Proof.
    cbn; intros ? ? eq1 ? ? eq2 H0.
    symmetry in eq2. apply sbisim_ssim in eq1, eq2.
    rewrite eq1, <- eq2.
    auto.
  Qed.

  #[global] Instance sbisim_clos_sst_ctx RR `{Equivalence _ L}:
    Proper (sbisim L ==> sbisim L ==> impl) (sst L RR).
  Proof.
    cbn; intros ? ? eq1 ? ? eq2 ?.
    rewrite <- eq1, <- eq2.
    auto.
  Qed.

  #[global] Instance sbisim_clos_ssT_goal RR f `{Equivalence _ L}:
    Proper (sbisim L ==> sbisim L ==> flip impl) (ssT L f RR).
  Proof.
    cbn; intros ? ? eq1 ? ? eq2 ?.
    symmetry in eq2. apply sbisim_ssim in eq1, eq2.
    rewrite eq1, <- eq2.
    auto.
  Qed.

  #[global] Instance sbisim_clos_ssT_ctx RR f `{Equivalence _ L}:
    Proper (sbisim L ==> sbisim L ==> impl) (ssT L f RR).
  Proof.
    cbn; intros ? ? eq1 ? ? eq2 ?.
    rewrite <- eq1, <- eq2.
    auto.
  Qed.

(*|
A strong bisimulation gives two strong simulations,
but two strong simulations do not always give a strong bisimulation.
This property is true if we only allow brs with 0 or 1 branch,
but we prove a counter-example for a ctree with a binary br.
|*)

  End Homogeneous.

  Lemma ss_sb : forall {E C X} RR {HasStuck: B0 -< C}
                  (t t' : ctree E C X),
      ss eq RR t t' ->
      ss eq (flip RR) t' t ->
      sb eq RR t t'.
  Proof.
    intros.
    split; eauto.
    simpl in *; intros.
    destruct (H0 _ _ H1) as (? & ? & ? & ? & ?).
    destruct (H _ _ H2) as (? & ? & ? & ? & ?).
    subst; eauto.
  Qed.

  #[local] Definition t1 : ctree void1 (B0 +' B1 +' B2) unit :=
    Step (Ret tt).

  #[local] Definition t2 : ctree void1 (B0 +' B1 +' B2) unit :=
    brS2 (Ret tt) (stuckD).

  Lemma ssim_sbisim_nequiv :
    ssim eq t1 t2 /\ ssim eq t2 t1 /\ ~ sbisim eq t1 t2.
  Proof.
    unfold t1, t2. intuition.
    - step.
      apply step_ss_brS; auto.
      intros _. exists true. reflexivity.
    - step. apply step_ss_brS; auto.
      intros [|]; exists tt.
      + reflexivity.
      + step. apply stuckD_ss.
    - step in H. cbn in H. destruct H as [_ ?].
      specialize (H tau stuckD). lapply H; [| etrans].
      intros. destruct H0 as (? & ? & ? & ? & ?).
      inv_trans. step in H1. cbn in H1. destruct H1 as [? _].
      specialize (H0 (val tt) stuckD). lapply H0.
      2: subst; etrans.
      intro; destruct H1 as (? & ? & ? & ? & ?).
      now apply stuckD_is_stuck in H1.
  Qed.

End StrongSimulations.


Require Import Bool.
Require Import DepList List.
Require Import Expr SepExpr SymEval.
Require Import Word Memory IL SepIL SymIL ILEnv.
Require Import EqdepClass.
Require Import Env Prover.
Require Import PropX PropXTac Nomega NArith.
Require Import Array.

Set Implicit Arguments.

Fixpoint array8 (bs : list B) (p : W) : HProp :=
  match bs with
    | nil => Emp
    | b :: bs' => p =8> b * array8 bs' (p ^+ $1)
  end%Sep.

Fixpoint selN (bs : list B) (n : nat) : B :=
  match bs with
    | nil => wzero _
    | b :: bs' => match n with
                    | O => b
                    | S n' => selN bs' n'
                  end
  end.

Definition sel (bs : list B) (a : W) : B :=
  selN bs (wordToNat a).

Fixpoint updN (bs : list B) (n : nat) (v : B) : list B :=
  match bs with
    | nil => nil
    | b :: bs' => match n with
                    | O => v :: bs'
                    | S n' => b :: updN bs' n' v
                  end
  end.

Definition upd (bs : list B) (a : W) (v : B) : list B :=
  updN bs (wordToNat a) v.

Definition bedrock_type_B : type :=
  {| Expr.Impl := B
   ; Expr.Eqb := (fun _ _ => false)
   ; Expr.Eqb_correct := @ILEnv.all_false_compare _ |}.

Definition bedrock_type_listB : type :=
  {| Expr.Impl := list B
   ; Expr.Eqb := (fun _ _ => false)
   ; Expr.Eqb_correct := @ILEnv.all_false_compare _ |}.

Definition types_r : Env.Repr Expr.type :=
  Eval cbv beta iota zeta delta [ Env.listOptToRepr ] in
    let lst :=
      Some ILEnv.bedrock_type_W ::
      Some ILEnv.bedrock_type_setting_X_state ::
      None ::
      None ::
      Some ILEnv.bedrock_type_nat ::
      None ::
      None ::
      None ::
      None ::
      Some bedrock_type_B ::
      Some bedrock_type_listB :: nil
    in Env.listOptToRepr lst EmptySet_type.

Local Notation pcT := (tvType 0).
Local Notation stT := (tvType 1).
Local Notation wordT := (tvType 0).
Local Notation natT := (tvType 4).
Local Notation byteT := (tvType 9).
Local Notation listBT := (tvType 10).

Local Notation wplusF := 0.
Local Notation wltF := 4.
Local Notation natToWF := 5.
Local Notation lengthF := 15.
Local Notation selF := 16.
Local Notation updF := 17.
Local Notation btowF := 18.
Local Notation wtobF := 19.

Section parametric.
  Variable types' : list type.
  Definition types := repr types_r types'.
  Variable Prover : ProverT types.

  Definition natToW_r : signature types.
    refine {| Domain := natT :: nil; Range := wordT |}.
    exact natToW.
  Defined.

  Definition blength_r : signature types.
    refine {| Domain := listBT :: nil; Range := natT |}.
    exact (@length _).
  Defined.

  Definition sel_r : signature types.
    refine {| Domain := listBT :: wordT :: nil; Range := byteT |}.
    exact sel.
  Defined.

  Definition upd_r : signature types.
    refine {| Domain := listBT :: wordT :: byteT :: nil; Range := listBT |}.
    exact upd.
  Defined.

  Definition BtoW_r : signature types.
    refine {| Domain := byteT :: nil; Range := wordT |}.
    exact BtoW.
  Defined.

  Definition WtoB_r : signature types.
    refine {| Domain := wordT :: nil; Range := byteT |}.
    exact WtoB.
  Defined.

  Definition funcs_r : Env.Repr (signature types) :=
    Eval cbv beta iota zeta delta [ Env.listOptToRepr ] in
      let lst :=
        Some (ILEnv.wplus_r types) ::
        None ::
        None ::
        None ::
        Some (ILEnv.wlt_r types) ::
        Some (ILEnv.natToW_r types) ::
        None ::
        None ::
        None ::
        None ::
        None ::
        None ::
        None ::
        None ::
        None ::
        Some blength_r ::
        Some sel_r ::
        Some upd_r ::
        Some BtoW_r ::
        Some WtoB_r ::
        nil
      in Env.listOptToRepr lst (Default_signature _).

  Definition deref (e : expr types) : option (expr types * expr types) :=
    match e with
      | Func wplusF (base :: offset :: nil) => Some (base, offset)
      | _ => None
    end.

  Definition sym_read (summ : Prover.(Facts)) (args : list (expr types)) (p : expr types)
    : option (expr types) :=
    match args with
      | bs :: p' :: nil =>
        match deref p with
          | None => None
          | Some (base, offset) =>
            if Prover.(Prove) summ (Equal wordT p' base)
              && Prover.(Prove) summ (Func wltF (offset :: Func natToWF (Func lengthF (bs :: nil)
                :: nil) :: nil))
              then Some (Func btowF (Func selF (bs :: offset :: nil) :: nil))
              else None
        end
      | _ => None
    end.

  Definition sym_write (summ : Prover.(Facts)) (args : list (expr types)) (p v : expr types)
    : option (list (expr types)) :=
    match args with
      | bs :: p' :: nil =>
        match deref p with
          | None => None
          | Some (base, offset) =>
            if Prover.(Prove) summ (Equal wordT p' base)
              && Prover.(Prove) summ (Func wltF (offset :: Func natToWF (Func lengthF (bs :: nil)
                :: nil) :: nil))
              then Some (Func updF (bs :: offset :: Func wtobF (v :: nil) :: nil) :: p' :: nil)
              else None
        end
      | _ => None
    end.
End parametric.

Definition MemEval types' : @MEVAL.PredEval.MemEvalPred (types types').
  apply MEVAL.PredEval.Build_MemEvalPred.
  exact (fun _ _ _ _ => None).
  exact (fun _ _ _ _ _ => None).
  apply sym_read.
  apply sym_write.
Defined.

Section correctness.
  Variable types' : list type.
  Definition types0 := types types'.

  Definition ssig : SEP.predicate types0 pcT stT.
    refine (SEP.PSig _ _ _ (listBT :: wordT :: nil) _).
    exact array8.
  Defined.

  Definition ssig_r : Env.Repr (SEP.predicate types0 pcT stT) :=
    Eval cbv beta iota zeta delta [ Env.listOptToRepr ] in
      let lst :=
        None :: None :: None :: Some ssig :: nil
      in Env.listOptToRepr lst (SEP.Default_predicate _ _ _).

  Variable funcs' : functions types0.
  Definition funcs := Env.repr (funcs_r _) funcs'.

  Variable Prover : ProverT types0.
  Variable Prover_correct : ProverT_correct Prover funcs.

  Lemma deref_correct : forall uvars vars e w base offset,
    exprD funcs uvars vars e wordT = Some w
    -> deref e = Some (base, offset)
    -> exists wb, exists wo,
      exprD funcs uvars vars base wordT = Some wb
      /\ exprD funcs uvars vars offset wordT = Some wo
      /\ w = wb ^+ wo.
    destruct e; simpl; intuition; try discriminate.
    repeat (deconstruct' ltac:(simpl in *); []).
    eauto.
  Qed.

  Lemma sym_read_correct'' : forall specs stn bs sm p i,
    (i < length bs)%nat
    -> interp specs (array8 bs p stn sm)
    -> smem_get (p ^+ $(i)) sm = Some (selN bs i).
    induction bs.

    simpl length; inversion 1.

    simpl length.
    unfold array8; fold array8.
    intros.
    apply simplify_fwd in H0.
    destruct H0.
    destruct H0.
    destruct H0.
    destruct H1.
    simpl in H0.

    destruct i; simpl selN.
    replace (p ^+ $(0)) with p by W_eq.
    simpl in H1; intuition.
    eapply split_smem_get; eauto.

    rewrite natToW_S.
    rewrite wplus_assoc.
    eapply split_smem_get; eauto.
    right.
    apply IHbs; try omega.
    propxFo.
  Qed.

  Lemma array8_bound' : forall cs base stn bs m i,
    (0 < i < length bs)%nat
    -> base ^+ $(i) = base
    -> interp cs (array8 bs base stn m)
    -> False.
    destruct bs; simpl length; intros.

    elimtype False; omega.

    simpl in H1.
    propxFo.
    destruct i; try omega.
    eapply sym_read_correct'' in H5.
    2: instantiate (1 := i); omega.
    match goal with
      | [ H : smem_get ?E _ = Some (selN _ _), H' : ?E' = base |- _ ] =>
        replace E with E' in H by (rewrite natToW_S; unfold natToW; W_eq)
    end.
    rewrite H0 in H5.
    destruct H1.
    eapply smem_get_disjoint; eauto.
  Qed.

  Lemma array_boundAlt : forall tht cs bs base stn m,
    interp cs (array8 bs base stn m)
    -> tht = 32
    -> (length bs <= pow2 tht)%nat.
    intros.
    Require Import Arith.
    destruct (le_lt_dec (length bs) (pow2 tht)); auto.
    eapply array8_bound' in H; try tauto.
    instantiate (1 := pow2 tht); intuition.
    apply pow2_pos.
    rewrite wplus_alt.
    unfold wplusN, wordBinN.

    Lemma natToWord_pow2_alt : forall sz tht,
      tht = sz
      -> natToWord sz (pow2 tht) = $(0).
      intros; subst; apply natToWord_pow2.
    Qed.

    rewrite natToWord_pow2_alt by assumption.
    rewrite roundTrip_0.
    rewrite plus_0_r.
    apply natToWord_wordToNat.
  Qed.

  Lemma array8_bound : forall cs bs base stn m,
    interp cs (array8 bs base stn m)
    -> (length bs <= pow2 32)%nat.
    intros; eapply array_boundAlt; eauto.
  Qed.

  Lemma sym_read_correct' : forall specs stn bs sm p i,
    i < natToW (length bs)
    -> interp specs (array8 bs p stn sm)
    -> smem_get (p ^+ i) sm = Some (sel bs i).
    intros.
    eapply sym_read_correct'' in H0.
    Focus 2.
    instantiate (1 := wordToNat i).
    red in H.
    apply Nlt_out in H.
    unfold natToW in *.
    repeat rewrite wordToN_nat in H.
    autorewrite with N in *.

    Lemma bounded : forall sz n m,
      (m <= pow2 sz)%nat
      -> (n < wordToNat (natToWord sz m))%nat
      -> (n < m)%nat.
      intros; destruct (eq_nat_dec m (pow2 sz)); subst.
      rewrite natToWord_pow2 in H0.
      rewrite roundTrip_0 in H0.
      nomega.
      rewrite wordToNat_natToWord_idempotent in H0; auto.
      pre_nomega.
      rewrite Npow2_nat.
      omega.
    Qed.

    eapply bounded; eauto.
    eapply array8_bound; eauto.
    rewrite natToWord_wordToNat in H0; auto.
  Qed.

  Lemma sym_read_correct : forall P (PE : ProverT_correct P funcs),
    forall args uvars vars cs facts pe p ve stn st,
      sym_read P facts args pe = Some ve ->
      Valid PE uvars vars facts ->
      exprD funcs uvars vars pe wordT = Some p ->
      match
        applyD (exprD funcs uvars vars) (SEP.SDomain ssig) args _ (SEP.SDenotation ssig)
        with
        | None => False
        | Some p => ST.satisfies cs p stn st
      end ->
      match ST.HT.smem_get p st with
        | Some b => exprD funcs uvars vars ve wordT = Some (BtoW b)
        | _ => False
      end.
  Proof.
    simpl; intuition.
    do 3 (destruct args; simpl in *; intuition; try discriminate).
    generalize (deref_correct uvars vars pe); destr ltac:(simpl in *) (deref pe); intro Hderef.
    destruct p0.

    repeat match goal with
             | [ H : Valid _ _ _ _, _ : context[Prove P ?summ ?goal] |- _ ] =>
               match goal with
                 | [ _ : context[ValidProp _ _ _ goal] |- _ ] => fail 1
                 | _ => specialize (Prove_correct PE summ H (goal := goal)); intro
               end
           end; unfold ValidProp in *; simpl in *.

    match goal with
      | [ _ : (if ?E then _ else _) = Some _ |- _ ] => case_eq E; intro Heq; rewrite Heq in *
    end; try discriminate.
    unfold types0 in *; simpl in *.
    unfold Provable in *; simpl in *.
    deconstruct.
    repeat match goal with
             | [ H : _ |- _ ] => apply andb_prop in H; intuition
           end.
    rewrite H1 in *.
    specialize (Hderef _ _ _ eq_refl eq_refl); destruct Hderef as [ ? [ ] ]; intuition.
    subst.
    rewrite H4 in *.
    rewrite H7 in *.
    specialize (H6 (ex_intro _ _ (refl_equal _))).
    specialize (H3 (ex_intro _ _ (refl_equal _))); subst.
    red in H2.

    eapply sym_read_correct' in H2; eauto.
    rewrite H2; reflexivity.
  Qed.

  Lemma sym_write_correct'' : forall specs stn v bs p i st,
    (i < length bs)%nat
    -> interp specs (array8 bs p stn st)
    -> exists st', smem_set (p ^+ $(i)) v st = Some st'
      /\ ST.satisfies specs (array8 (updN bs i v) p) stn st'.
    induction bs.

    inversion 1.

    simpl length.
    unfold array8; fold array8.
    intros.
    propxFo.
    destruct i.
    assert (Ho : smem_get p st = Some a) by (eapply split_smem_get; eauto).
    eapply smem_set_get_valid in Ho.
    generalize Ho; instantiate (1 := v); intro Ho'; clear Ho'.
    case_eq (smem_set p v st); intros; try congruence.
    do 2 esplit.
    replace (p ^+ $(0)) with p by W_eq.
    eauto.
    simpl.
    propxFo.
    assert (smem_set p v x <> None) by (eapply smem_set_get_valid; eauto).
    case_eq (smem_set p v x); intros; try congruence.
    exists s0; exists x0; intuition.
    unfold split in *; intuition subst.
    eapply smem_set_disjoint; eauto.
    eapply split_set in H6; eauto.
    destruct H6.
    congruence.
    eapply smem_set_get_eq; eauto.
    erewrite smem_set_get_neq; eauto.

    eapply IHbs in H3.
    2: instantiate (1 := i); omega.
    destruct H3; intuition.
    rewrite natToW_S.
    rewrite wplus_assoc.
    exists (HT.join x x1).
    eapply split_set in H3.
    2: destruct H1; apply disjoint_comm; eauto.
    destruct H3.
    rewrite disjoint_join by (apply disjoint_comm; auto).
    destruct H1; subst.
    intuition.
    rewrite disjoint_join by auto.
    auto.
    propxFo.
    do 2 eexists; intuition.
    apply split_comm; apply disjoint_split_join; auto.
    auto.
    auto.
  Qed.

  Lemma sym_write_correct' : forall i bs p specs stn st v,
    i < natToW (length bs)
    -> interp specs (array8 bs p stn st)
    -> exists st', smem_set (p ^+ i) v st = Some st'
      /\ ST.satisfies specs (array8 (upd bs i v) p) stn st'.
    intros.
    eapply sym_write_correct'' in H0.
    Focus 2.
    instantiate (1 := wordToNat i).
    red in H.
    apply Nlt_out in H.
    unfold natToW in *.
    repeat rewrite wordToN_nat in H.
    autorewrite with N in *.
    eapply bounded; eauto.
    eapply array8_bound; eauto.
    rewrite natToWord_wordToNat in H0; eauto.
  Qed.

  Lemma sym_write_correct : forall P (PE : ProverT_correct P funcs),
    forall args uvars vars cs facts pe p ve v stn st args',
      sym_write P facts args pe ve = Some args' ->
      Valid PE uvars vars facts ->
      exprD funcs uvars vars pe wordT = Some p ->
      exprD funcs uvars vars ve wordT = Some v ->
      match
        applyD (@exprD _ funcs uvars vars) (SEP.SDomain ssig) args _ (SEP.SDenotation ssig)
        with
        | None => False
        | Some p => ST.satisfies cs p stn st
      end ->
      match
        applyD (@exprD _ funcs uvars vars) (SEP.SDomain ssig) args' _ (SEP.SDenotation ssig)
        with
        | None => False
        | Some pr =>
          match ST.HT.smem_set p (WtoB v) st with
            | None => False
            | Some sm' => ST.satisfies cs pr stn sm'
          end
      end.
  Proof.
    simpl; intuition.
    do 3 (destruct args; simpl in *; intuition; try discriminate).
    generalize (deref_correct uvars vars pe); destr ltac:(simpl in *) (deref pe); intro Hderef.
    destruct p0.

    repeat match goal with
             | [ H : Valid _ _ _ _, _ : context[Prove P ?summ ?goal] |- _ ] =>
               match goal with
                 | [ _ : context[ValidProp _ _ _ goal] |- _ ] => fail 1
                 | _ => specialize (Prove_correct PE summ H (goal := goal)); intro
               end
           end; unfold ValidProp in *; simpl in *.

    match goal with
      | [ _ : (if ?E then _ else _) = Some _ |- _ ] => case_eq E; intro Heq; rewrite Heq in *
    end; try discriminate.
    unfold types0 in *; simpl in *.
    unfold Provable in *; simpl in *.
    deconstruct.
    repeat match goal with
             | [ H : _ |- _ ] => apply andb_prop in H; intuition
           end.
    rewrite H1 in *.
    rewrite H2 in *.
    specialize (Hderef _ _ _ (refl_equal _) (refl_equal _)); destruct Hderef as [ ? [ ] ]; intuition.
    subst.
    simpl in *.
    rewrite H8 in *.
    rewrite H5 in *.
    specialize (H7 (ex_intro _ _ (refl_equal _))).
    specialize (H4 (ex_intro _ _ (refl_equal _))); subst.
    red in H3.

    eapply sym_write_correct' in H3; eauto.
    destruct H3; intuition.
    rewrite H7; assumption.
  Qed.
End correctness.

Definition MemEvaluator types' : MEVAL.MemEvaluator (types types') (tvType 0) (tvType 1) :=
  Eval cbv beta iota zeta delta [ MEVAL.PredEval.MemEvalPred_to_MemEvaluator ] in
    @MEVAL.PredEval.MemEvalPred_to_MemEvaluator _ (tvType 0) (tvType 1) (MemEval types') 3.

Theorem MemEvaluator_correct types' funcs' preds'
  : @MEVAL.MemEvaluator_correct (Env.repr types_r types') (tvType 0) (tvType 1)
  (MemEvaluator (Env.repr types_r types')) (funcs funcs') (Env.repr (ssig_r _) preds')
  (IL.settings * IL.state) (tvType 0) (tvType 0)
  (@IL_mem_satisfies (types types')) (@IL_ReadWord (types types')) (@IL_WriteWord (types types'))
  (@IL_ReadByte (types types')) (@IL_WriteByte (types types')).
Proof.
  intros. eapply (@MemPredEval_To_MemEvaluator_correct (types types')); try reflexivity;
  intros; unfold MemEval in *; simpl in *; try discriminate.
  { generalize (@sym_read_correct types' funcs' P PE). simpl in *. intro.
    eapply H3 in H; eauto. }
  { generalize (@sym_write_correct types' funcs' P PE). simpl in *. intro.
    eapply H4 in H; eauto. }
Qed.

Definition pack : MEVAL.MemEvaluatorPackage types_r (tvType 0) (tvType 1) (tvType 0) (tvType 0)
  IL_mem_satisfies IL_ReadWord IL_WriteWord IL_ReadByte IL_WriteByte :=

  @MEVAL.Build_MemEvaluatorPackage types_r (tvType 0) (tvType 1) (tvType 0) (tvType 0)
  IL_mem_satisfies IL_ReadWord IL_WriteWord IL_ReadByte IL_WriteByte
  types_r
  funcs_r
  (fun ts => Env.listOptToRepr (None :: None :: None :: Some (ssig ts) :: nil)
    (SEP.Default_predicate (Env.repr types_r ts)
      (tvType 0) (tvType 1)))
  (fun ts => MemEvaluator _)
  (fun ts fs ps => MemEvaluator_correct _ _).