Require Import Tid.
Require Import Fid.
Require Import Finish.Lang.
Require Import Coq.Lists.List.
Import ListNotations.

Section Defs.
  Structure t := make {
    state : state;
    history : Trace.t;
    spec: Trace.ReducesN state history
  }.

  (** A typed reduction *)

  Inductive Reduces: t -> (tid*op) -> t -> Prop :=
  | reduces_def:
    forall t o pm1 pm2,
    Lang.Reduces (state pm1) (t, o) (state pm2) ->
    history pm2 = (t,o)::(history pm1) ->
    Reduces pm1 (t, o) pm2.
End Defs.

Section Props.
  Program Definition reduces_step_aux
    x o (s:t) s'
    (Hr: Lang.Reduces (state s) (x, o) s') :=
    {| state := s'; history := (x,o)::(history s) |}.
  Next Obligation.
    destruct s.
    eapply Trace.reduces_n_cons; eauto.
  Qed. (* leave it open *)

  Program Definition empty := {| state := Lang.empty; history := nil |}.
  Next Obligation.
    auto using Trace.reduces_n_nil.
  Defined.

  Lemma reduces_step:
    forall x o s s' (X : Lang.Reduces (state s) (x, o) s'),
    exists s',
    Reduces s (x, o) s'.
  Proof.
    intros.
    exists (reduces_step_aux x o s s' X).
    eauto using reduces_def.
  Qed.

  (** An enabled task can reduce with any operation. *)
  Definition Enabled s t :=
  forall o, Valid (state s) t o -> exists s', Reduces s (t, o) s'.

  Let enabled_to_enabled:
    forall s t,
    Lang.Enabled (state s) t ->
    Enabled s t.
  Proof.
    intros.
    unfold Enabled, Lang.Enabled in *.
    intros ? Hv.
    apply H in Hv.
    destruct Hv as (s', Hr).
    eauto using reduces_step.
  Qed.

  Corollary progress_ex:
    forall (s:t),
    (* And that state is not empty *)
    ~ Map_TID.Empty (state s) ->
    (* Then there is some [f] such that *)
    exists f,
    ((* [f] is nonempty and every task in [f] reduces. *)
      Nonempty f (state s)
      /\
      (forall x, Registered x f (state s) -> Enabled s x)
      /\
      (forall x, Registered x f (state s) -> IEF x f (state s))
    )
    \/
    ((* Or [f] is empty, and [t]'s current finish-scope is [f] *)
      Empty f (state s)
      /\
      exists x, Current x f (state s) /\ Enabled s x
    ).
  Proof.
    intros.
    edestruct Trace.progress_ex as (f,[(Hx,(Hy,?))|(Hx,(x,(Hy,Hz)))]); eauto using spec;
    exists f. {
      left.
      split; auto.
    }
    right.
    split; auto.
    exists x.
    split; auto.
  Qed.

  Lemma progress_nonblocking:
    forall s t o,
    Valid (state s) t o ->
    Nonblocking o ->
    exists s', Reduces s (t, o) s'.
  Proof.
    intros.
    eapply progress_nonblocking in H; eauto using spec.
    destruct H as (s', H).
    eauto using reduces_step.
  Qed.

  Theorem progress:
    forall s,
    ~ Map_TID.Empty (state s) ->
    (* Then there is some [f] such that *)
    exists t,
    Enabled s t.
  Proof.
    intros.
    eapply Trace.progress in H; eauto using spec.
    destruct H as (t, Hx);
    eauto using enabled_to_enabled.
  Qed.

  Lemma reduces_inv_ief_root:
    forall (x y:tid) f (s s':t),
    IEF x f (state s) ->
    Reduces s (x, BEGIN_TASK y) s' ->
    Registered y f (state s').
  Proof.
    intros.
    inversion H0; subst; clear H0.
    eauto using Lang.reduces_inv_ief_registered.
  Qed.
End Props.


Require Import Containers.Maps Containers.Sets Containers.SetProperties.
Require Import Theory TermUtils.

Set Implicit Arguments.
Unset Strict Implicit.

Section WithTheory.
  Context `{Th : Theory}.

  SubClass t := Map[R, set term].

  Definition empty : t := [].

  Definition find (m : t) (r : R) : set term :=
    match m[r] with
      | Some r => r
      | None => {}
    end.
  Global Coercion find : t >-> Funclass.

  Definition merge (m : t) (p P : R) : t :=
    match m[p] with
      | None => m
      | Some usedp =>
        let lP := leaves P in
          List.fold_left (fun m l => insert l usedp (union usedp) m) lP
          (MapInterface.remove p m)
    end.

  Definition add (m : t) (fa : term) (la : list R) : t :=
    List.fold_left (fun m l => insert l {fa} (add fa) m) la m.

  Definition using_all (m : t) (lvs : list R) : set term :=
    match lvs with
      | nil => {}
      | x::ls =>
        List.fold_left (fun acc y => inter acc (m y)) ls (m x)
    end.

  Definition terms_of (m : t) : set term :=
    MapInterface.fold (fun _ v acc => v ++ acc) m {}.
End WithTheory.

Section WithTheorySpecs.
  Context `{Th: Theory}.

  (* About empty *)
  Property empty_find : forall r, empty r = {}.
  Proof.
    intros; unfold empty, find; rewrite MapFacts.empty_o; reflexivity.
  Qed.

  (* About merge *)
  Fixpoint in_list (r : R) (l : list R) : bool :=
    match l with
      | nil => false
      | r'::q => if r == r' then true else in_list r q
    end.
  Property in_list_rev_iff : forall r l, in_list r l = in_list r (rev l).
  Proof.
    intros r; induction l; simpl.
    reflexivity.
    destruct (eq_dec r a); simpl.
    clear IHl; pattern (rev l); apply list_ind; simpl; intros.
    destruct (eq_dec r a); auto; order.
    destruct (eq_dec r a0); auto.
    rewrite IHl; clear IHl; pattern (rev l); apply list_ind; simpl; intros.
    destruct (eq_dec r a); auto; order.
    rewrite H0; auto.
  Qed.

  Property insert_eq_o :
    forall (k : R) (d : set term) f m k',
      k === k' -> (insert k d f m)[k'] =
      match m[k'] with Some d' => Some (f d') | None => Some d end.
  Proof.
    intros; destruct (m[k']) as [d'|]_eqn:Hk'; apply find_1.
    apply insert_1; [exact H | exact (find_2 Hk')].
    apply insert_2; auto; rewrite MapFacts.not_find_in_iff; exact Hk'.
  Qed.
  Property insert_neq_o :
    forall (k : R) (d : set term) f m k',
      k =/= k' -> (insert k d f m)[k'] = m[k'].
  Proof.
    intros; destruct (m[k']) as [d'|]_eqn:Hk'.
    apply find_1; apply insert_3; [exact H | exact (find_2 Hk')].
    rewrite <- MapFacts.not_find_in_iff in Hk' |- *;
      intros [d' abs]; apply Hk'; exists d'; exact (insert_4 H abs).
  Qed.

  Property merge_find : forall m p P r,
    in_list p (leaves P) = false ->
    (merge m p P) r [=]
    (match m[p] with
       | None => m r
       | Some usedp =>
         if r == p then {} else
           if in_list r (leaves P) then
             usedp ++ m r
             else m r
     end).
  Proof.
    intros; unfold merge, find.
    destruct (m[p]) as [usedp|]_eqn:Hp; [|reflexivity].
    set (f (l : R) m0 := insert l usedp (union usedp) m0).
    match goal with
      | |- context G [fun m0 l => insert l usedp (union usedp) m0] =>
        let t := context G [fun m0 l => f l m0] in change t
    end.
    rewrite <- fold_left_rev_right, in_list_rev_iff in *; revert H.
    pattern (rev (leaves P)); apply list_ind; simpl; intros.
    (* - nil *)
    destruct (eq_dec r p).
    rewrite MapFacts.remove_eq_o; auto; reflexivity.
    rewrite MapFacts.remove_neq_o; try reflexivity; intro abs; order.
    (* - cons *)
    set (M := fold_right f (MapInterface.remove p m) l) in *; clearbody M.
    unfold f in *; clear f.
    destruct M[r] as [usedr|]_eqn:Hr.
    destruct (eq_dec r a) as [Heqa | Hneqa].
    rewrite insert_eq_o; auto; rewrite Hr; simpl.
    destruct (eq_dec r p) as [Heqp | Hneqp].
    destruct (eq_dec p a); [discriminate | order].
    destruct (eq_dec p a); [order | rewrite (H H0)].
    destruct (in_list r l).
    rewrite <-union_assoc; apply union_m; try reflexivity.
    apply union_subset_equal; reflexivity.
    reflexivity.
    rewrite insert_neq_o by (intro abs; apply Hneqa; auto).
    rewrite Hr; apply H.
    destruct (eq_dec p a); auto; discriminate.
    destruct (eq_dec r a) as [Heqa | Hneqa].
    rewrite insert_eq_o; auto; rewrite Hr; simpl.
    destruct (eq_dec r p) as [Heqp | Hneqp].
    destruct (eq_dec p a); [discriminate | order].
    destruct (eq_dec p a); [order |].
    assert (H' := H H0); clear H H0.
    destruct (in_list r l).
    cut (usedp [=] {}).
    intro cut; rewrite <- H', cut; reflexivity.
    apply empty_is_empty_1; intros z Hz; apply empty_1 with z.
    rewrite H'; apply union_2; exact Hz.
    rewrite <- H'; rewrite empty_union_2; [reflexivity |
      intros ? abs; contradiction (empty_1 abs)].
    rewrite insert_neq_o by (intro abs; apply Hneqa; auto).
    rewrite Hr; apply H.
    destruct (eq_dec p a); auto; discriminate.
  Qed.

  (* About terms_of *)
  Property terms_of_iff :
    forall m t, t \In terms_of m <-> exists r, t \In m r.
  Proof.
    intro m; unfold terms_of, find.
    apply (@MapFacts.fold_rec_bis _ _ _ _ _ _
      (fun (mvu : t) f => forall t,
        t \In f <-> exists r, t \In
          match mvu[r] with | Some r0 => r0 | None => {} end)); simpl; intros.
    (* - morphism *)
    rewrite H0; split; intros [r Hr]; exists r;
      [rewrite <- H | rewrite H]; exact Hr.
    (* - empty *)
    split; intro abs.
    contradiction (empty_1 abs).
    destruct abs as [r Hr]; rewrite MapFacts.empty_o in Hr; auto.
    (* - add *)
    rewrite union_iff, H1; clear H1; split.
    intros [Ht | [r Hr]].
    exists k; rewrite MapFacts.add_eq_o; auto.
    exists r; rewrite MapFacts.add_neq_o; auto.
    intro abs; apply H0; rewrite abs.
    destruct (m'[r]) as [ ]_eqn.
    exists s; apply find_2; auto.
    contradiction (empty_1 Hr).
    intros [r Hr].
    destruct (eq_dec k r); [left | right].
    rewrite MapFacts.add_eq_o in Hr; auto.
    exists r; rewrite MapFacts.add_neq_o in Hr; auto.
  Qed.

  Property terms_of_empty : terms_of empty = {}.
  Proof.
    reflexivity.
  Qed.

  Property terms_of_find : forall (m : t) r, m r [<=] terms_of m.
  Proof.
    intros; intros a Ha; rewrite terms_of_iff; exists r; auto.
  Qed.

  Remark InA_in_list : forall r l, reflects (InA _eq r l) (in_list r l).
  Proof.
    intro r; induction l; simpl.
    constructor; intro abs; inversion abs.
    inversion_clear IHl.
    destruct (r == a); constructor; constructor 2; exact Htrue.
    destruct (eq_dec r a); constructor.
    constructor; auto. intro abs; inversion_clear abs; auto.
  Qed.
  Property terms_of_merge `{ThSpecs: @TheorySpecs Th} :
    forall m p P, ~InA _eq p (leaves P) ->
      terms_of (merge m p P) [=] terms_of m.
  Proof.
    intros; intro a; rewrite 2terms_of_iff.
    assert (H' : in_list p (leaves P) = false)
      by (destruct (InA_in_list p (leaves P)); intuition).
    split; intros [r Hr].
    rewrite merge_find in Hr by assumption.
    destruct m[p] as [usedp|]_eqn:Hp.
    destruct (eq_dec r p) as [Heqp | Hneqp].
    contradiction (empty_1 Hr).
    destruct (in_list r (leaves P)).
    rewrite union_iff in Hr; destruct Hr; [exists p | exists r]; auto.
    unfold find; rewrite Hp; exact H0.
    exists r; auto.
    exists r; auto.
    destruct m[p] as [usedp|]_eqn:Hp.
    destruct (eq_dec r p) as [Heqp | Hneqp].
    assert (Hnot_empty := leaves_not_empty (r:=P)).
    destruct (leaves P) as [|l q]_eqn; try congruence.
    exists l; rewrite merge_find by congruence; rewrite Hp.
    destruct (eq_dec l p).
    contradiction H; constructor; auto.
    destruct (InA_in_list l (leaves P)).
    apply union_2; unfold find in Hr; rewrite <- Heqp in Hp;
      rewrite Hp in Hr; auto.
    contradiction Hfalse; rewrite Heql; constructor; auto.
    exists r; rewrite merge_find by assumption; rewrite Hp.
    destruct (eq_dec r p); [order |].
    destruct (in_list r (leaves P)); [apply union_3 |]; exact Hr.
    exists r; rewrite merge_find by assumption; rewrite Hp; exact Hr.
  Qed.
End WithTheorySpecs.
Global Opaque t empty find merge add using_all terms_of.


Require Import Coq.Lists.List
        Coq.Strings.String
        Fiat.Common
        Coq.Arith.Arith
        Coq.Logic.FunctionalExtensionality
        Coq.Sets.Ensembles
        Fiat.Common.StringBound.
Require Export
        Fiat.QueryStructure.Specification.Representation.Notations
        Fiat.QueryStructure.Specification.Representation.Heading
        Fiat.QueryStructure.Specification.Representation.Tuple
        Fiat.QueryStructure.Specification.Representation.Schema
        Fiat.QueryStructure.Specification.Representation.Relation.

Import Vectors.Vector.VectorNotations.

(* A Query Structure schema is a set of named relation
   schemas and a set of cross-relation constraints
   (i.e. foreign key constraints). *)

Record NamedSchema  :=
  { relName : string;
    relSchema : Schema
  }.

Definition GetNRelSchema
           {n}
           (namedSchemas : Vector.t RawSchema n)
           (idx : Fin.t n) :=
  Vector.nth namedSchemas idx.

Definition GetNRelSchemaHeading
           {n}
           (namedSchemas : Vector.t RawSchema n)
           (idx : Fin.t n)
  := rawSchemaHeading (GetNRelSchema namedSchemas idx).

Definition crossRelationR
           {n}
           (namedSchemas : Vector.t RawSchema n)
           (idx idx' : Fin.t n)
  := @RawTuple (GetNRelSchemaHeading namedSchemas idx)
     -> Ensemble (@IndexedRawTuple (GetNRelSchemaHeading namedSchemas idx'))
     -> Prop.

Definition crossRelationProdR
           {n}
           (namedSchemas : Vector.t RawSchema n)
           (idxs : _ * _)
  := crossRelationR namedSchemas (fst idxs) (snd idxs).

Record RawQueryStructureSchema :=
  { numRawQSschemaSchemas : nat;
    qschemaSchemas : Vector.t RawSchema numRawQSschemaSchemas;
    qschemaConstraints:
      list (sigT (crossRelationProdR qschemaSchemas))
  }.

Record QueryStructureSchema :=
  { numQSschemaSchemas : nat;
    QSschemaSchemas : Vector.t Schema numQSschemaSchemas;
    QSschemaConstraints:
      list (sigT (crossRelationProdR (Vector.map schemaRaw QSschemaSchemas)));
    QSschemaNames : Vector.t string numQSschemaSchemas  }.

Definition QueryStructureSchemaRaw
           (QSSchema : QueryStructureSchema)
  : RawQueryStructureSchema :=
  {| numRawQSschemaSchemas := numQSschemaSchemas QSSchema;
     qschemaConstraints := QSschemaConstraints QSSchema |}.

Coercion QueryStructureSchemaRaw : QueryStructureSchema >-> RawQueryStructureSchema.

Definition QSGetNRelSchema
           (QSSchema : QueryStructureSchema)
           (idx : BoundedString (QSschemaNames QSSchema)) :=
  Vector.nth (QSschemaSchemas QSSchema) (ibound (indexb idx)).

Definition QSGetNRelSchemaHeading
           (QSSchema : QueryStructureSchema)
           (idx : BoundedString (QSschemaNames QSSchema)) :=
  schemaHeading (QSGetNRelSchema QSSchema idx).

Notation GetHeading QSSchema index :=
  (@QSGetNRelSchemaHeading QSSchema (@Build_BoundedIndex _ _ _ index _)).

(* Notations for Query Structures. *)

Notation "'relation' name 'has' sch " :=
  {| relName := name%string;
     relSchema := sch%Schema
  |} : NamedSchema_scope.

Notation "[ rel1 ; .. ; reln ]" :=
  (@Vector.cons _ rel1 _ (.. (@Vector.cons _ reln _ (Vector.nil _)) .. )) : NamedSchema_scope.
Notation "[ rel1 ; rel2 ; .. ; reln ]" :=
  (@Vector.cons _ rel1 _ (@Vector.cons _ rel2 _ (.. (@Vector.cons _ reln _ (Vector.nil _)) .. ))) : NamedSchema_scope.

Bind Scope NamedSchema_scope with NamedSchema.

(* A notation for foreign key constraints. This gives us
  a pair of relation schema names and a predicate on
  tuples in those tables. We use the namedSchemaHint
  typeclass to get the typechecking to work. *)

Definition ForeignKey_P heading relSchema attr1 attr2 tupmap
           (tup : @RawTuple heading)
           (R : Ensemble (@IndexedRawTuple relSchema)) :=
  exists tup2,
    R tup2 /\
    GetAttributeRaw tup attr1 =
    tupmap (GetAttributeRaw (indexedRawTuple tup2) attr2).

Definition BuildForeignKeyConstraints
           {n}
           (namedSchemas : Vector.t RawSchema n)
           (rel1 rel2 : _)
           attr1
           attr2
           {tupmap} :=
  (existT (crossRelationProdR namedSchemas)
          (rel1, rel2)
          (ForeignKey_P attr1 attr2 tupmap)).

Class namedSchemaHint :=
  { numnSchemaHint : nat;
    nSchemaHint :> Vector.t Schema numnSchemaHint;
    nSchemaNamesHint :> Vector.t string numnSchemaHint}.

Notation "'attribute' attr 'for' rel1 'references' rel2 " :=
  (let hint : namedSchemaHint := _ in
   let rel1' := ibound (indexb (@Build_BoundedIndex _ _ (@nSchemaNamesHint hint) rel1%string _)) in
   let rel2' := ibound (indexb (@Build_BoundedIndex _ _ (@nSchemaNamesHint hint) rel2%string _)) in
   @BuildForeignKeyConstraints
     _ (Vector.map schemaRaw (@nSchemaHint hint)) rel1' rel2'
     (ibound (indexb (@Build_BoundedIndex _ _ (schemaHeadingNames (Vector.nth (@nSchemaHint hint) rel1')) attr%string _)))
     (ibound (indexb (@Build_BoundedIndex _ _ (schemaHeadingNames (Vector.nth (@nSchemaHint hint) rel2')) attr%string _)))
     id) : QSSchemaConstraints_scope.

Notation "'Query' 'Structure' 'Schema' relList 'enforcing' constraints" :=
  (let relNames := Vector.map relName relList%NamedSchema in
   let relSchemas := Vector.map relSchema relList%NamedSchema in
   @Build_QueryStructureSchema
     _ relSchemas
     (let relListHint := Build_namedSchemaHint relSchemas relNames in
          (constraints%QSSchemaConstraints)%list)
     relNames) : QSSchema_scope.

Arguments BuildForeignKeyConstraints _ _ [_ _] _ _ _ (*/*) .

Arguments eq_rect_r _ _ _ _ _ _ / .
(*Arguments ForeignKey_P _ _ _ _ _ / _ _ . *)

Notation "'Query' 'Structure' 'Schema' relList " :=
    (let relNames := Vector.map relName relList%NamedSchema in
   let relSchemas := Vector.map relSchema relList%NamedSchema in
   @Build_QueryStructureSchema _ relSchemas nil relNames) : QSSchema_scope.

Bind Scope QSSchema_scope with QueryStructureSchema.
Require Export Fiat.Common.DecideableEnsembles.

#[global]
Instance Astring_eq : Query_eq string := {| A_eq_dec := string_dec |}.

#[global]
Instance Anat_eq : Query_eq nat := {| A_eq_dec := eq_nat_dec |}.

#[global]
Instance Query_eq_list {A : Type}
         {a_eq_dec : Query_eq A}
: Query_eq (list A) :=
  {| A_eq_dec := list_eq_dec (@A_eq_dec A a_eq_dec) |}.

Require Import Coq.NArith.NArith Coq.ZArith.ZArith.
#[global]
Instance AN_eq : Query_eq N := {| A_eq_dec := N.eq_dec |}.
#[global]
Instance AZ_eq : Query_eq Z := {| A_eq_dec := Z.eq_dec |}.

(*Notation GetAttributeKey Rel index :=
  ((fun x : Attributes (GetNRelSchemaHeading (qschemaSchemas _) Rel) => x)  {| bindex := index |}).

Notation GetRelationKey QSSchema index :=
  (@Build_BoundedIndex _ (map relName (qschemaSchemas QSSchema))
                      index _).

Notation RawTupleDef QSSchema index :=
  (@RawTuple (QSGetNRelSchemaHeading QSSchema {| bindex := index%string |})). *)


(* begin hide *)
From Coq Require Import
     RelationClasses
     Morphisms
     Program.Equality.

From Paco Require Import paco.
From ITree Require Import
     ITree
     ITreeFacts
     Eq.Eqit.
Set Implicit Arguments.
Set Strict Implicit.
(* end hide *)

(** * NoEvent
    We develop in this file a theory to reason about absence of a given event signature
    in a tree, and how to use this absence to safely eliminate this signature from the tree.
 *)

(** * Signature vacuousness
  A simple way to assert the absence of a signature is based on the shape of the signature.
  We define straightforward non-recursive functors and take the cofixed points.
 *)

(* The left part of the signature is absent *)
Variant no_event_lF {E F X} (R: itree (E +' F) X -> Prop) : itree' (E +' F) X -> Prop :=
| no_event_l_ret: forall (x: X), no_event_lF R (RetF x)
| no_event_l_tau: forall t, R t -> no_event_lF R (TauF t)
| no_event_l_vis: forall {Y} (e: F Y) k, (forall x, R (k x)) -> no_event_lF R (VisF (inr1 e) k).
#[export] Hint Constructors no_event_lF : core.

Lemma no_event_lF_mono : forall {E F X} (R1 R2 : itree (E +' F) X -> Prop) (LE : R1 <1= R2),
    no_event_lF R1 <1= no_event_lF R2.
Proof.
  intros.
  induction PR; auto.
Qed.

Definition no_event_lF_ {E F X} R (t : itree (E +' F) X) := no_event_lF R (observe t).
#[export] Hint Unfold no_event_lF_ : core.

Lemma no_event_lF__mono : forall E F X, (monotone1 (@no_event_lF_ E F X)).
Proof.
  do 2 red.
  intros.
  eapply no_event_lF_mono; eauto.
Qed.

#[export] Hint Resolve no_event_lF_mono : paco.

Definition no_event_l {E F X} := paco1 (@no_event_lF_ E F X) bot1.

(* This exists in the stdlib as [ProofIrrelevance.inj_pair2], but we reprove
   it to not depend on proof irrelevance (we use axiom [JMeq.JMeq_eq] instead).
   The itree library now avoids as much as possible using this axiom, we may want
   to see if it's possible to do so here.
 *)
Lemma inj_pair2 :
  forall (U : Type) (P : U -> Type) (p : U) (x y : P p),
    existT P p x = existT P p y -> x = y.
  Proof.
    intros. apply JMeq.JMeq_eq.
    refine (
        match H in _ = w return JMeq.JMeq x (projT2 w) with
        | eq_refl => JMeq.JMeq_refl
        end).
  Qed.

(* The right part of the signature is absent *)
Variant no_event_rF {E F X} (R: itree (E +' F) X -> Prop): itree' (E +' F) X -> Prop :=
| no_event_r_ret: forall (x: X), no_event_rF R (RetF x)
| no_event_r_tau: forall t, R t -> no_event_rF R (TauF t)
| no_event_r_vis: forall {Y} (e: E Y) k, (forall x, R (k x)) -> no_event_rF R (VisF (inl1 e) k).

#[export] Hint Constructors no_event_rF : core.

Lemma no_event_rF_mono : forall {E F X} (R1 R2 : itree (E +' F) X -> Prop) (LE : R1 <1= R2),
    no_event_rF R1 <1= no_event_rF R2.
Proof.
  intros.
  induction PR; auto.
Qed.

Definition no_event_rF_ {E F X} R (t : itree (E +' F) X) := no_event_rF R (observe t).
#[export] Hint Unfold no_event_rF_ : core.

Lemma no_event_rF__mono : forall E F X, (monotone1 (@no_event_rF_ E F X)).
Proof.
  do 2 red.
  intros.
  eapply no_event_rF_mono; eauto.
Qed.

#[export] Hint Resolve no_event_rF_mono : paco.

Definition no_event_r {E F X} := paco1 (@no_event_rF_ E F X) bot1.

(* The tree contains no event *)
Variant no_eventF {E X} (R: itree E X -> Prop): itree' E X -> Prop :=
| no_event_ret: forall (x: X), no_eventF R (RetF x)
| no_event_tau: forall t, R t -> no_eventF R (TauF t).

#[export] Hint Constructors no_eventF : core.

Lemma no_eventF_mono : forall {E X} (R1 R2 : itree E X -> Prop) (LE : R1 <1= R2),
    no_eventF R1 <1= no_eventF R2.
Proof.
  intros.
  induction PR; auto.
Qed.

Definition no_eventF_ {E X} R (t : itree E X) := no_eventF R (observe t).
#[export] Hint Unfold no_eventF_ : core.

Lemma no_eventF__mono : forall E X, (monotone1 (@no_eventF_ E X)).
Proof.
  do 2 red.
  intros.
  eapply no_eventF_mono; eauto.
Qed.

#[export] Hint Resolve no_eventF_mono : paco.

Definition no_event {E X} := paco1 (@no_eventF_ E X) bot1.

(** up-to eq_itree closure
  Coinductive proofs about no_event can be performed up-to `eq_itree`.

  Note that up-to eutt is not valid:
    Tau (Vis e k)
        |  no_eventF
        v
      Vis e k ~~ Tau (Vis e k)

  Up-to euttge is valid as well.
  *)
Section eqit_closure.

  Inductive eqit_clo {E R} (r : itree E R -> Prop)
    : itree E R -> Prop :=
  | eqit_clo_intro b t t' (EQVl: eqit eq b false t t') (REL: r t')
    : eqit_clo r t.
  Hint Constructors eqit_clo: core.

  Lemma eqit_clo_mon {E R} r1 r2 t
        (IN: eqit_clo r1 t)
        (LE: r1 <1= r2):
    @eqit_clo E R r2 t.
  Proof.
    destruct IN. econstructor; eauto.
  Qed.

  Lemma no_event_eqit_clo_wcompat {E R} :
    wcompatible1 (@no_eventF_ E R) eqit_clo.
  Proof.
    econstructor.
    pmonauto.
    intros.
    inv PR.
    punfold EQVl.
    unfold_eqit.
    unfold no_eventF_ in *.
    induction EQVl; auto.
    - inv REL.
      constructor.
      pclearbot.
      gclo; econstructor; cycle -1; eauto with paco.
    - inv REL.
    - constructor.
      gstep; auto.
    - congruence.
  Qed.

  #[global] Instance eq_itree_no_event_cong {E R} r rg :
    Proper ((eq_itree eq) ==> flip impl) (gpaco1 (@no_eventF_ E R) eqit_clo r rg).
  Proof.
    repeat intro.
    gclo.
    econstructor; cycle -1; eauto.
  Qed.

  #[global] Instance euttge_no_event_cong {E R} r rg :
    Proper ((euttge eq) ==> flip impl) (gpaco1 (@no_eventF_ E R) eqit_clo r rg).
  Proof.
    repeat intro.
    gclo.
    econstructor; cycle -1; eauto.
  Qed.

  Lemma no_event_r_eqit_clo_wcompat {E F R} :
    wcompatible1 (@no_event_rF_ E F R) eqit_clo.
  Proof.
    econstructor.
    pmonauto.
    intros.
    inv PR.
    punfold EQVl.
    unfold_eqit.
    unfold no_event_rF_ in *.
    induction EQVl; auto.
    - inv REL.
      constructor.
      pclearbot.
      gclo; econstructor; cycle -1; eauto with paco.
    - destruct e.
      + constructor.
        dependent induction REL.
        pclearbot; intros; gclo; econstructor; cycle -1; eauto with paco.
        apply REL0.
      + inversion REL.
    - constructor.
      gstep; auto.
    - congruence.
  Qed.

  #[global] Instance eq_itree_no_event_r_cong {E F R} r rg :
    Proper ((eq_itree eq) ==> flip impl) (gpaco1 (@no_event_rF_ E F R) eqit_clo r rg).
  Proof.
    repeat intro.
    gclo.
    econstructor; cycle -1; eauto.
  Qed.

  #[global] Instance euttge_no_event_r_cong {E F R} r rg :
    Proper ((euttge eq) ==> flip impl) (gpaco1 (@no_event_rF_ E F R) eqit_clo r rg).
  Proof.
    repeat intro.
    gclo.
    econstructor; cycle -1; eauto.
  Qed.

  Lemma no_event_l_eqit_clo_wcompat {E F R} :
    wcompatible1 (@no_event_lF_ E F R) eqit_clo.
  Proof.
    econstructor.
    pmonauto.
    intros.
    inversion PR.
    punfold EQVl.
    unfold_eqit.
    unfold no_event_lF_ in *.
    induction EQVl; auto.
    - inversion REL.
      constructor.
      pclearbot.
      gclo; econstructor; cycle -1; eauto with paco.
    - destruct e.
      + inversion REL.
      + constructor.
        dependent induction REL.
        pclearbot; intros; gclo; econstructor; cycle -1; eauto with paco.
        apply REL0.
    - constructor.
      gstep; auto.
    - congruence.
  Qed.

  #[global] Instance eq_itree_no_event_l_cong {E F R} r rg :
    Proper ((eq_itree eq) ==> flip impl) (gpaco1 (@no_event_lF_ E F R) eqit_clo r rg).
  Proof.
    repeat intro.
    gclo.
    econstructor; cycle -1; eauto.
  Qed.

  #[global] Instance euttge_no_event_l_cong {E F R} r rg :
    Proper ((euttge eq) ==> flip impl) (gpaco1 (@no_event_lF_ E F R) eqit_clo r rg).
  Proof.
    repeat intro.
    gclo.
    econstructor; cycle -1; eauto.
  Qed.

End eqit_closure.
#[export] Hint Resolve eqit_clo_mon : paco.
#[export] Hint Constructors eqit_clo: core.
#[export] Hint Resolve no_event_eqit_clo_wcompat : paco.
#[export] Hint Resolve no_event_l_eqit_clo_wcompat : paco.
#[export] Hint Resolve no_event_r_eqit_clo_wcompat : paco.

(* In particular [eq_itree] is hence a congruence for [no_event] *)
#[global] Instance no_event_l_eq_itree {E F X} : Proper (eq_itree eq ==> iff) (@no_event_l E F X).
Proof.
  repeat red. intros. split; intros.
  ginit. rewrite <- H. gfinal; auto.
  ginit. rewrite H. gfinal; auto.
Qed.

#[global] Instance no_event_r_eq_itree {E F X} : Proper (eq_itree eq ==> iff) (@no_event_r E F X).
Proof.
  repeat red. intros. split; intros.
  ginit. rewrite <- H. gfinal; auto.
  ginit. rewrite H. gfinal; auto.
Qed.

#[global] Instance no_event_eq_itree {E X} : Proper (eq_itree eq ==> iff) (@no_event E X).
Proof.
  repeat red. intros. split; intros.
  ginit. rewrite <- H. gfinal; auto.
  ginit. rewrite H. gfinal; auto.
Qed.

(* But although not a valid up-to, [eutt] is also a congruence for [no_event] *)
#[global] Instance no_event_l_eutt {E F X} : Proper (eutt eq ==> iff) (@no_event_l E F X).
Proof.
  do 2 red.
  repeat red. intros. split; intros.
  - revert x y H H0.
    pcofix CIH.
    intros x y H0 H1.
    + punfold H0. red in H0.
      punfold H1. red in H1.
      genobs x ox.
      genobs y oy.
      pstep. red.
      revert x Heqox y Heqoy.
      induction H0; inversion H1; intros; subst.
      * rewrite <- Heqoy. econstructor.
      * rewrite <- Heqoy. econstructor. pclearbot. right. eapply CIH. 2:  { apply H0. }  apply REL.
      * rewrite <- Heqoy. destruct e. inversion H1. econstructor. intros.
        specialize (REL x0). red in REL. pclearbot. right. eapply CIH. apply REL.
        apply inj_pair2 in H3. rewrite <- H3. specialize (H0 x0). apply H0.
      * eapply IHeqitF. pclearbot. punfold H2. reflexivity. reflexivity.
      * rewrite <- Heqoy. econstructor. left.
        pstep. red. eapply IHeqitF. econstructor. apply Heqox. reflexivity.
      * rewrite <- Heqoy. econstructor. left.
        pstep. red. eapply IHeqitF. econstructor. assumption. apply Heqox. reflexivity.
      * rewrite <- Heqoy. econstructor. left.
        pstep. red. eapply IHeqitF. econstructor. intros. apply H. apply Heqox. reflexivity.
  - revert x y H H0.
    pcofix CIH.
    intros x y H0 H1.
    + punfold H0. red in H0.
      punfold H1. red in H1.
      genobs x ox.
      genobs y oy.
      pstep. red.
      revert x Heqox y Heqoy.
      induction H0; inversion H1; intros; subst.
      * rewrite <- Heqox. econstructor.
      * rewrite <- Heqox. econstructor. pclearbot. right. eapply CIH. 2:  { apply H0. }  apply REL.
      * rewrite <- Heqox. destruct e. inversion H1. econstructor. intros.
        specialize (REL x0). red in REL. pclearbot. right. eapply CIH. apply REL.
        apply inj_pair2 in H3. rewrite <- H3. specialize (H0 x0). apply H0.
      * rewrite <- Heqox. econstructor. left.
        pstep. red. eapply IHeqitF. econstructor. reflexivity. apply Heqoy.
      * rewrite <- Heqox. econstructor. left.
        pstep. red. eapply IHeqitF. econstructor. assumption. reflexivity. apply Heqoy.
      * rewrite <- Heqox. econstructor. left.
        pstep. red. eapply IHeqitF. econstructor. intros. apply H. reflexivity. apply Heqoy.
      * eapply IHeqitF. pclearbot. punfold H2. reflexivity. reflexivity.
Qed.

#[global] Instance no_event_r_eutt {E F X} : Proper (eutt eq ==> iff) (@no_event_r E F X).
Proof.
  do 2 red.
  repeat red. intros. split; intros.
  - revert x y H H0.
    pcofix CIH.
    intros x y H0 H1.
    + punfold H0. red in H0.
      punfold H1. red in H1.
      genobs x ox.
      genobs y oy.
      pstep. red.
      revert x Heqox y Heqoy.
      induction H0; inversion H1; intros; subst.
      * rewrite <- Heqoy. econstructor.
      * rewrite <- Heqoy. econstructor. pclearbot. right. eapply CIH. 2:  { apply H0. }  apply REL.
      * rewrite <- Heqoy. destruct e. econstructor. intros.
        specialize (REL x0). red in REL. pclearbot. right. eapply CIH. apply REL.
        apply inj_pair2 in H3. rewrite <- H3. specialize (H0 x0). apply H0.
        inversion H1.
      * eapply IHeqitF. pclearbot. punfold H2. reflexivity. reflexivity.
      * rewrite <- Heqoy. econstructor. left.
        pstep. red. eapply IHeqitF. econstructor. apply Heqox. reflexivity.
      * rewrite <- Heqoy. econstructor. left.
        pstep. red. eapply IHeqitF. econstructor. assumption. apply Heqox. reflexivity.
      * rewrite <- Heqoy. econstructor. left.
        pstep. red. eapply IHeqitF. econstructor. intros. apply H. apply Heqox. reflexivity.
  - revert x y H H0.
    pcofix CIH.
    intros x y H0 H1.
    + punfold H0. red in H0.
      punfold H1. red in H1.
      genobs x ox.
      genobs y oy.
      pstep. red.
      revert x Heqox y Heqoy.
      induction H0; inversion H1; intros; subst.
      * rewrite <- Heqox. econstructor.
      * rewrite <- Heqox. econstructor. pclearbot. right. eapply CIH. 2:  { apply H0. }  apply REL.
      * rewrite <- Heqox. destruct e. econstructor. intros.
        specialize (REL x0). red in REL. pclearbot. right. eapply CIH. apply REL.
        apply inj_pair2 in H3. rewrite <- H3. specialize (H0 x0). apply H0.
        inversion H1.
      * rewrite <- Heqox. econstructor. left.
        pstep. red. eapply IHeqitF. econstructor. reflexivity. apply Heqoy.
      * rewrite <- Heqox. econstructor. left.
        pstep. red. eapply IHeqitF. econstructor. assumption. reflexivity. apply Heqoy.
      * rewrite <- Heqox. econstructor. left.
        pstep. red. eapply IHeqitF. econstructor. intros. apply H. reflexivity. apply Heqoy.
      * eapply IHeqitF. pclearbot. punfold H2. reflexivity. reflexivity.
Qed.

#[global] Instance no_event_eutt {E X} : Proper (eutt eq ==> iff) (@no_event E X).
Proof.
  repeat red. intros. split; intros.
  - revert x y H H0.
    pcofix CIH.
    intros x y H0 H1.
    + punfold H0. red in H0.
      punfold H1. red in H1.
      genobs x ox.
      genobs y oy.
      pstep. red.
      revert x Heqox y Heqoy.
      induction H0; inversion H1; intros; subst.
      * rewrite <- Heqoy. econstructor.
      * rewrite <- Heqoy. econstructor. pclearbot. right. eapply CIH. 2:  { apply H0. }  apply REL.
      * eapply IHeqitF. pclearbot. punfold H2. reflexivity. reflexivity.
      * rewrite <- Heqoy. econstructor. left.
        pstep. red. eapply IHeqitF. econstructor. apply Heqox. reflexivity.
      * rewrite <- Heqoy. econstructor. left.
        pstep. red. eapply IHeqitF. econstructor. assumption. apply Heqox. reflexivity.
  - revert x y H H0.
    pcofix CIH.
    intros x y H0 H1.
    + punfold H0. red in H0.
      punfold H1. red in H1.
      genobs x ox.
      genobs y oy.
      pstep. red.
      revert x Heqox y Heqoy.
      induction H0; inversion H1; intros; subst.
      * rewrite <- Heqox. econstructor.
      * rewrite <- Heqox. econstructor. pclearbot. right. eapply CIH. 2:  { apply H0. }  apply REL.
      * rewrite <- Heqox. econstructor. left.
        pstep. red. eapply IHeqitF. econstructor. reflexivity. apply Heqoy.
      * rewrite <- Heqox. econstructor. left.
        pstep. red. eapply IHeqitF. econstructor. assumption. reflexivity. apply Heqoy.
      * eapply IHeqitF. pclearbot. punfold H2. reflexivity. reflexivity.
Qed.

(* Sanity check, trees with empty signature should have no event *)
Lemma no_event_empty {X} : forall (t: itree void1 X), no_event t.
Proof.
  pcofix CIH.
  intros t.
  pstep.
  red.
  genobs t obt.
  destruct obt.
  - econstructor.
  - econstructor. right. apply CIH.
  - inversion e.
Qed.

Lemma no_event_l_empty {E X} : forall (t: itree (void1 +' E) X), no_event_l t.
Proof.
  pcofix CIH.
  intros t.
  pstep.
  red.
  genobs t obt.
  destruct obt; auto.
  destruct e; auto.
  inversion v.
Qed.

Lemma no_event_r_empty {E X} : forall (t: itree (E +' void1) X), no_event_r t.
Proof.
  pcofix CIH.
  intros t.
  pstep.
  red.
  genobs t obt.
  destruct obt; auto.
  destruct e; auto.
  inversion v.
Qed.

(** * Signature elimination
  In order to eliminate a signature from the type,
  we need to handle it into an itree over the remaining signature.
  Since the intent is to run these handlers over trees that do not
  contain such events, how we handle them should not matter, but
  the obvious solution is to interpret them into [spin]
 *)

Definition helim_l {E F}: E +' F ~> itree F :=
  fun _ e => match e with
          | inl1 _ => ITree.spin
          | inr1 e => trigger e
          end.

Definition helim_r {E F}: E +' F ~> itree E :=
  fun _ e => match e with
          | inr1 _ => ITree.spin
          | inl1 e => trigger e
          end.

Definition helim {E}: E ~> itree void1 :=
  fun _ _ => ITree.spin.

Definition elim_l {E F}: itree (E +' F) ~> itree F     := interp helim_l.
Definition elim_r {E F}: itree (E +' F) ~> itree E     := interp helim_r.
Definition elim   {E}  : itree E        ~> itree void1 := interp helim.

(** * Soundness
    The tricky part is now to figure out how to express the correctness of
    the elimination of vacuous signatures.
 *)

(** By asserting that handlers can't be distinguished: *)

Lemma no_event_elim_l :
  forall {E F X} (t : itree (E +' F) X),
    no_event_l t ->
    forall (h : E ~> itree F) , elim_l t  ≈ interp (case_ h (id_ F)) t.
Proof.
  intros E F X.
  unfold elim_l.
  intros t H h.
  revert t H.
  einit.
  ecofix CIH.
  intros.
  rewrite (itree_eta t).
  pinversion H0.
  - rewrite interp_ret. rewrite interp_ret. reflexivity.
  - rewrite interp_tau. rewrite interp_tau. estep.
  - rewrite interp_vis. rewrite interp_vis. cbn.
    unfold id_. unfold Id_Handler, Handler.id_.
    ebind. econstructor. reflexivity.
    intros. subst. estep.
    ebase. right. eapply CIHL. apply H1.
Qed.

Lemma no_event_elim_r :
  forall {E F X} (t : itree (E +' F) X),
    no_event_r t ->
    forall (h : F ~> itree E), elim_r t ≈ interp (case_ (id_ E) h) t.
Proof.
  intros E F X.
  unfold elim_r.
  intros t H h.
  revert t H.
  einit.
  ecofix CIH.
  intros.
  rewrite (itree_eta t).
  pinversion H0.
  - rewrite interp_ret. rewrite interp_ret. reflexivity.
  - rewrite interp_tau. rewrite interp_tau. estep.
  - rewrite interp_vis. rewrite interp_vis. cbn.
    unfold id_. unfold Id_Handler, Handler.id_.
    ebind. econstructor. reflexivity.
    intros. subst. estep.
    ebase. right. eapply CIHL. apply H1.
Qed.

Lemma no_event_elim :
  forall {E X} (t : itree E X),
    no_event t ->
    forall h, elim t ≈ interp h t.
Proof.
  intros E X.
  unfold elim.
  intros t H h.
  revert t H.
  einit.
  ecofix CIH.
  intros.
  rewrite (itree_eta t).
  pinversion H0.
  - rewrite interp_ret. rewrite interp_ret. reflexivity.
  - rewrite interp_tau. rewrite interp_tau. estep.
Qed.

Lemma no_event_l_interp :
  forall {E F X} (t : itree (E +' F) X),
    no_event_l t ->
    forall (h : E ~> itree (E +' F)) ,
      t ≈ interp (case_ h inr_) t.
Proof.
  intros E F X.
  intros t H h.
  revert t H.
  einit.
  ecofix CIH.
  intros.
  rewrite (itree_eta t).
  pinversion H0.
  - rewrite interp_ret. reflexivity.
  - rewrite interp_tau. estep.
  - clear - CIHH H0 H1 H.
    rewrite interp_vis. cbn.
    unfold inr_, Inr_sum1_Handler, Handler.inr_, Handler.htrigger.
    rewrite bind_trigger.
    estep; intros.
    rewrite tau_eutt.
    ebase. right. eapply CIHH. apply H1.
Qed.

Lemma no_event_r_interp :
  forall {E F X} (t : itree (E +' F) X),
    no_event_r t ->
    forall (h : F ~> itree (E +' F)), t ≈ interp (case_ inl_ h) t.
Proof.
  intros E F X.
  intros t H h.
  revert t H.
  einit.
  ecofix CIH.
  intros.
  rewrite (itree_eta t).
  pinversion H0.
  - rewrite interp_ret. reflexivity.
  - rewrite interp_tau. estep.
  - clear - CIHH H0 H1 H.
    rewrite interp_vis. cbn.
    unfold inl_, Inl_sum1_Handler, Handler.inl_, Handler.htrigger.
    rewrite bind_trigger.
    estep; intros.
    rewrite tau_eutt.
    ebase. right. eapply CIHH. apply H1.
Qed.

Lemma no_event_interp :
  forall {E X} (t : itree E X),
    no_event t ->
    forall h, t ≈ interp h t.
Proof.
  intros E X.
  intros t H h.
  revert t H.
  einit.
  ecofix CIH.
  intros.
  rewrite (itree_eta t).
  pinversion H0.
  - rewrite interp_ret. reflexivity.
  - rewrite interp_tau. estep.
Qed.

(** By expressing that [elim] is an inverse to the signature injection: *)

(* Injection to the left *)
Definition inject_l {E F}: itree F ~> itree (E +' F) :=
  translate inr_.

(* Injection to the right *)
Definition inject_r {E F}: itree E ~> itree (E +' F) :=
  translate inl_.

(* Injection *)
Definition inject {E}: itree void1 ~> itree E :=
  translate (fun _ (e : void1 _) => match e with end).

(* For some reason the new definition of [ecofix] in itrees loops here.
  We redefine the old one for now.
*)
Require Import Paco.pacotac_internal.

Tactic Notation "ecofix" ident(CIH) "with" ident(gL) ident(gH) :=
   repeat red;
   paco_pre2;
   eapply euttG_cofix;
   paco_post2 CIH with gL;
   paco_post2 CIH with gH.

Tactic Notation "ecofix" ident(CIH) := ecofix CIH with gL gH.

Lemma inject_no_event_l : forall {E F X} t,
  no_event_l (@inject_l E F X t).
Proof.
  intros E F X.
  ginit; gcofix CIH; intros t.
  setoid_rewrite unfold_translate.
  gstep.
  destruct (observe t); cbn; constructor.
  - gbase; apply CIH.
  - intros ?; gbase; apply CIH.
Qed.

Lemma inject_no_event_r : forall {E F X} t,
  no_event_r (@inject_r E F X t).
Proof.
  intros E F X.
  ginit; gcofix CIH; intros t.
  setoid_rewrite unfold_translate.
  gstep.
  destruct (observe t); cbn; constructor.
  - gbase; apply CIH.
  - intros ?; gbase; apply CIH.
Qed.

Lemma inject_no_event : forall {E X} t,
  no_event (@inject E X t).
Proof.
  intros E X.
  ginit; gcofix CIH; intros t.
  unfold inject; setoid_rewrite unfold_translate.
  gstep.
  destruct (observe t); cbn; try constructor.
  - gbase; apply CIH.
  - inversion e.
Qed.

(* [elim_l] is _always_ a left inverse to [inject_l] *)
Lemma elim_inject_l :
  forall {E F X} (t : itree F X),
    elim_l (@inject_l E F _ t) ≈ t.
Proof.
  einit.
  ecofix CIH.
  intros.
  rewrite (itree_eta t).
  unfold elim_l. unfold inject_l.
  destruct (observe t).
  - rewrite translate_ret. rewrite interp_ret.
    estep.
  - rewrite translate_tau. rewrite interp_tau.
    estep.
  - rewrite translate_vis. rewrite interp_vis. cbn.
    rewrite bind_trigger. estep.
    intros.
    rewrite tau_eutt. ebase.
Qed.

(* [inject_l] is a left inverse to [elim_l] when considering trees with [no_event_l] *)
Lemma inject_elim_l :
  forall {E F X} (t : itree (E +' F) X),
    no_event_l t ->
    inject_l (elim_l t) ≈ t.
Proof.
  einit.
  ecofix CIH.
  intros.
  rewrite (itree_eta t).
  unfold elim_l in *.
  unfold inject_l in *.
  pinversion H0.
  - rewrite interp_ret. rewrite translate_ret. estep.
  - rewrite interp_tau. rewrite translate_tau. estep.
  - rewrite interp_vis. rewrite translate_bind.  cbn.
    unfold trigger.  rewrite translate_vis. rewrite bind_vis.
    estep. intros. rewrite translate_ret. rewrite bind_ret_l.
    rewrite translate_tau. rewrite tau_eutt. ebase.
    left. apply CIH0. apply H1.
Qed.

(* [elim_r] is _always_ a left inverse to [inject_r] *)
Lemma elim_inject_r :
  forall {E F X} (t : itree E X),
    elim_r (@inject_r E F _ t) ≈ t.
Proof.
  einit.
  ecofix CIH.
  intros.
  rewrite (itree_eta t).
  unfold elim_r. unfold inject_r.
  destruct (observe t).
  - rewrite translate_ret. rewrite interp_ret. estep.
  - rewrite translate_tau. rewrite interp_tau. estep.
  - rewrite translate_vis. rewrite interp_vis. cbn.
    rewrite bind_trigger. estep.
    intros.
    rewrite tau_eutt. ebase.
Qed.

(* [inject_r] is a left inverse to [elim_r] when considering trees with [no_event_r] *)
Lemma inject_elim_r :
  forall {E F X} (t : itree (E +' F) X),
    no_event_r t ->
    inject_r (elim_r t) ≈ t.
Proof.
  einit.
  ecofix CIH.
  intros.
  rewrite (itree_eta t).
  unfold elim_r in *.
  unfold inject_r in *.
  pinversion H0.
  - rewrite interp_ret. rewrite translate_ret. estep.
  - rewrite interp_tau. rewrite translate_tau. estep.
  - rewrite interp_vis. rewrite translate_bind.  cbn.
    unfold trigger.  rewrite translate_vis. rewrite bind_vis.
    estep. intros. rewrite translate_ret. rewrite bind_ret_l.
    rewrite translate_tau. rewrite tau_eutt. ebase.
    left. apply CIH0. apply H1.
Qed.

(* [elim] is _always_ a left inverse to [inject] *)
Lemma elim_inject :
  forall {E X} (t : itree void1 X),
    elim (@inject E _ t) ≈ t.
Proof.
  einit.
  ecofix CIH.
  intros.
  rewrite (itree_eta t).
  unfold elim. unfold inject.
  destruct (observe t).
  - rewrite translate_ret. rewrite interp_ret. estep.
  - rewrite translate_tau. rewrite interp_tau. estep.
  - inversion e.
Qed.

(* [inject] is a left inverse to [elim] when considering trees with [no_event] *)
Lemma inject_elim :
  forall {E X} (t : itree E X),
    no_event t ->
    inject (elim t) ≈ t.
Proof.
  einit.
  ecofix CIH.
  intros.
  rewrite (itree_eta t).
  unfold elim. unfold inject.
  pinversion H0.
  - rewrite interp_ret. rewrite translate_ret. estep.
  - rewrite interp_tau. rewrite translate_tau. estep.
Qed.

(** * Establishing [no_event]
    If two tree are similar after non-trivial injections, they have no events.
    The following probably needs to be refined.
 *)

(*  ------------------------------------------------------------------------- *)
(* TODO: Move these to the itrees library? *)

Lemma translate_ret_inv : forall E F A (h : E ~> F) (t : itree E A) a,
    translate h t ≅ ret a -> t ≅ ret a.
Proof.
  intros.
  rewrite (itree_eta t) in *.
  pinversion H.
  destruct (observe t); cbn in *; inversion H1. subst. reflexivity.
  inversion CHECK.
Qed.

Lemma translate_tau_inv : forall E F A (h : E ~> F) (t : itree E A) u,
    translate h t ≅ Tau u -> exists u', t ≅ Tau u'.
Proof.
  intros.
  setoid_rewrite (itree_eta t).
  rewrite (itree_eta t) in H.
  pinversion H; try inversion CHECK.
  destruct (observe t); cbn in *; inversion H1. subst. exists t0. reflexivity.
Qed.

Lemma translate_tau_vis : forall E F A B (h : E ~> F) (t : itree E B) f k,
    translate h t ≅ Vis f k -> exists e k', f = @h A e /\ t ≅ Vis e k'.
Proof.
  intros.
  setoid_rewrite (itree_eta t).
  rewrite (itree_eta t) in H.
  pinversion H; try inversion CHECK.
  apply inj_pair2 in H3.
  apply inj_pair2 in H4.
  subst. destruct (observe t). cbn in *. inversion H1. inversion H1. cbn in *.
  inversion H. cbn in *.
  apply inj_pair2 in H3.
  apply inj_pair2 in H4.
  subst.
  apply inj_pair2 in H7.
  apply inj_pair2 in H6. subst.
  exists e0.
  exists k2. split; reflexivity.
Qed.
(*  ------------------------------------------------------------------------- *)

Lemma eutt_disjoint_no_event_l :
  forall {E F X Y} (R : X -> Y -> Prop) (t : itree E X) (s : itree F Y),
    eutt R (inject_r t) (@inject_l E F _ s) ->
    no_event t.
Proof.
  intros E F X Y R.
  pcofix CIH.
  intros t s H0.
  rewrite (itree_eta t) in H0.
  rewrite (itree_eta s) in H0.
  repeat red in H0.
  punfold H0.
  red in H0.
  unfold inject_r, inject_l in H0.
  pstep. red.
  genobs t obt.
  genobs s obs.
  match goal with
  | [_ : eqitF _ _ _ _ _ ?X ?Y |- _] => remember X; remember Y
  end.
  revert t s obt Heqobt obs Heqobs Heqi Heqi0.
  induction H0; intros.
  - destruct obt; cbn in *; inversion Heqi. constructor.
  - destruct obt; cbn in *; inversion Heqi. constructor. destruct obs; cbn in *; inversion Heqi0. subst.
    right. eapply CIH. unfold inject_r. unfold inject_l. pclearbot. apply REL.
  - destruct obt; cbn in *; inversion Heqi. destruct obs; cbn in *; inversion Heqi0. subst.
    apply inj_pair2 in H4.
    apply inj_pair2 in H1. rewrite H4 in H1. inversion H1.
  - destruct obt; cbn in *; inversion Heqi. constructor. right. eapply CIH. unfold inject_r. rewrite <- H1.
    pstep. red. unfold inject_l. rewrite Heqi0 in H0. apply H0.
  - destruct obs; cbn in *; inversion Heqi0.
    eapply IHeqitF. apply Heqobt. 2 : { apply Heqi. } assert (observe t0 = observe t0) by reflexivity. apply H.
    rewrite H1. reflexivity.
Qed.

Lemma eutt_disjoint_no_event_r :
  forall {E F X Y} (R : X -> Y -> Prop) (t : itree E X) (s : itree F Y),
    eutt R (inject_r t) (@inject_l E F _ s) ->
    no_event s.
Proof.
  intros E F X Y R.
  pcofix CIH.
  intros t s H0.
  rewrite (itree_eta t) in H0.
  rewrite (itree_eta s) in H0.
  repeat red in H0.
  punfold H0.
  red in H0.
  unfold inject_r, inject_l in H0.
  pstep. red.
  genobs t obt.
  genobs s obs.
  match goal with
  | [_ : eqitF _ _ _ _ _ ?X ?Y |- _] => remember X; remember Y
  end.
  revert t s obt Heqobt obs Heqobs Heqi Heqi0.
  induction H0; intros.
  - destruct obs; cbn in *; inversion Heqi0. constructor.
  - destruct obs; cbn in *; inversion Heqi0. constructor. destruct obt; cbn in *; inversion Heqi. subst.
    right. eapply CIH. unfold inject_r. unfold inject_l. pclearbot. apply REL.
  - destruct obs; cbn in *; inversion Heqi0. destruct obt; cbn in *; inversion Heqi. subst.
    apply inj_pair2 in H4.
    apply inj_pair2 in H1. rewrite H4 in H1. inversion H1.
  - destruct obt; cbn in *; inversion Heqi.
    eapply IHeqitF. assert (observe t0 = observe t0) by reflexivity. apply H. apply Heqobs.
    rewrite H1. reflexivity. assumption.
  - destruct obs; cbn in *; inversion Heqi0. constructor. right. eapply CIH. unfold inject_l. rewrite <- H1.
    pstep. red. unfold inject_r. rewrite Heqi in H0. apply H0.
Qed.

#[global] Instance Proper_inject_l {E F X} : Proper (eq_itree eq ==> eq_itree eq) (@inject_l E F X).
Proof.
  do 3 red.
  intros x y EQ.
  rewrite EQ. reflexivity.
Qed.

Lemma no_event_translate :
  forall {E F X} (m : E ~> F) (t : itree E X), no_event t -> no_event (translate m t).
Proof.
  ginit.
  intros E F X m t H.
  rewrite (itree_eta t).
  revert t H.
  gcofix CIH.
  intros * NEV.
  rewrite itree_eta in NEV.
  red in NEV.
  punfold NEV.
  inversion NEV.
  - rewrite translate_ret.
    gstep.
    constructor.
  - pclearbot.
    rewrite translate_tau.
    gstep.
    constructor.
    rewrite (itree_eta t0).
    gbase.
    eauto.
Qed.

(* And while we're at it, injection should not compromise [no_event] *)
Lemma no_event_inject_l :
  forall {E F X} (t : itree F X), no_event t -> no_event (@inject_l E F _ t).
Proof.
  ginit.
  intros * H.
  rewrite (itree_eta t).
  revert t H.
  gcofix CIH.
  intros * NEV.
  rewrite itree_eta in NEV.
  red in NEV.
  punfold NEV.
  inversion NEV.
  - unfold inject_l; rewrite translate_ret.
    gstep.
    constructor.
  - pclearbot.
    unfold inject_l; rewrite translate_tau.
    gstep.
    constructor.
    rewrite (itree_eta t0).
    gbase.
    eauto.
Qed.

Lemma no_event_inject_r :
  forall {E F X} (t : itree E X),
    no_event t ->
    no_event (@inject_r E F _ t).
  ginit.
  intros * H.
  rewrite (itree_eta t).
  revert t H.
  gcofix CIH.
  intros * NEV.
  rewrite itree_eta in NEV.
  red in NEV.
  punfold NEV.
  inversion NEV.
  - unfold inject_r; rewrite translate_ret.
    gstep.
    constructor.
  - pclearbot.
    unfold inject_r; rewrite translate_tau.
    gstep.
    constructor.
    rewrite (itree_eta t0).
    gbase.
    eauto.
Qed.