From Coq Require Import
     Morphisms
.

From ITree Require Import
     Axioms
     ITree
     ITreeFacts
     Eq.Rutt
     Props.Infinite
     Props.EuttNoRet.

From ITree.Extra Require Import
     ITrace.ITraceDefinition
     ITrace.ITraceFacts
     ITrace.ITracePrefix
.

From Paco Require Import paco.

Import Monads.
Import MonadNotation.
Local Open Scope monad_scope.

(* Contains the proof of peel_lemma which allows us
   to decompose a trace of bind t f into a head that refines t and a tail
   that refines f *)

Section Peel.
Context (classicT : forall (P : Type), P + (P -> False)).

Definition peel_vis {E R S A B} (e0 : E A) (a : A) (k0 : unit -> itrace E R)
           (e1 : E B) (k1 : B -> itree E S)
           (peel : itrace' E R -> itree' E S -> itrace E S) : itrace E S.
Proof.
  destruct (classicT (A = B)).
  - subst. apply (Vis (evans _ e0 a) (fun _ => peel (observe (k0 tt)) (observe (k1 a) ) ) ).
  - apply ITree.spin.
Defined.

CoFixpoint peel_ {E R S} (ob : itrace' E R) (ot : itree' E S) : itrace E S :=
  match ob, ot with
  | TauF b, TauF t => Tau (peel_ (observe b) (observe t))
  | _, RetF s => Ret s
  | TauF b, ot => Tau (peel_ (observe b) ot )
  | ob, TauF t => Tau (peel_ ob (observe t) )
  | VisF (evempty _ Hempty e) _ , _ => Vis (evempty _ Hempty e) (fun v : void => match v with end)
  (* The type of this is problematic need some tricky dependently typed programming
     in order to have this work
   *)

  | VisF (evans _ e0 a) k0, VisF e1 k1 => peel_vis e0 a k0 e1 k1 peel_
  | _, _ => ITree.spin
  end.

Definition peel {E R S} (b : itrace E R) (t : itree E S) : itrace E S :=
  peel_ (observe b) (observe t).
(* here is a sketchy axiom use *)
Definition peel_cont_vis {E R S A B} (e0 : E A) (a : A) (k0 : unit -> itrace E R)
           (e1 : E B) (k1 : B -> itree E S)
           (peel : itrace' E R -> itree' E S -> itrace E R) : itrace E R.
Proof.
  destruct (classicT (A = B) ).
  - subst. apply (Tau (peel (observe (k0 tt)) (observe (k1 a) ) ) ).
  - apply ITree.spin.
Defined.

(*Actually I may be able to remove this ugly bs. I think I really only use peel*)
CoFixpoint peel_cont_ {E R S} (ob : itrace' E R) (ot : itree' E S) : itrace E R :=
  match ot with
  | RetF _ => go ob
  | TauF t => match ob with
             | TauF b => Tau (peel_cont_ (observe b) (observe t))
             | ob => Tau (peel_cont_ ob (observe t)  )
             end
  | VisF e1 k1 => match ob with
                 | TauF b => Tau (peel_cont_ (observe b) ot)
                 | VisF (evempty _ Hempty e) _ =>
                     ITree.spin
                 | VisF (evans _ e0 a) k0 => peel_cont_vis e0 a k0 e1 k1 peel_cont_
                 | _ => ITree.spin
                 end
  end.

Definition peel_cont {E R S} (b : itrace E R) (t : itree E S) : S -> itrace E R :=
  fun s => peel_cont_ (observe b) (observe t).

Lemma refine_ret_vis_contra : forall (E: Type -> Type) (R A: Type)
                                (r : R) (e : E A) (k : A -> itree E R),
    ~ (Ret r ⊑ Vis e k).
Proof.
  intros. intro Hcontra. pinversion Hcontra.
Qed.

(* maybe a better way of doing it is to use strong LEM to see if X = A in the vis case
   then I can remove that if statement given

 *)

Lemma peel_t_ret : forall E R S (b : itrace E S) (t : itree E R) r, t ≅ Ret r -> (peel b t ≅ Ret r).
Proof.
  intros.  unfold peel.
  pinversion H; subst; try inv CHECK.
  destruct (observe b); cbn; auto.
  - pfold. red. cbn. constructor. auto.
  - pfold. red. cbn. constructor; auto.
  - pfold. red. cbn. simpl. destruct e.
    + cbn. constructor. auto.
    + cbn. constructor. auto.
Qed.

(*doing these proofs, may require some techniques you don't really know*)

Lemma peel_refine_t : forall (E : Type -> Type) (R S : Type)
                        (b : itrace E S) (t : itree E R) (f : R -> itree E S)
                        (Hrutt : b ⊑ ITree.bind t f),
    peel b t ⊑ t.
Proof.
  intros E R S b t f. generalize dependent b. generalize dependent t.
  pcofix CIH. intros.
  punfold Hrutt. red in Hrutt. cbn in Hrutt. pfold. red.
  unfold peel.
  destruct (observe t) eqn : Heq.
  - destruct (observe b); cbn; try (constructor; auto).
    destruct e; cbn; constructor; auto.
  - dependent induction Hrutt.
    + exfalso. symmetry in Heq. apply simpobs in Heq. apply simpobs in x.
      rewrite Heq in x. rewrite bind_tau in x. pinversion x.
      inv CHECK.
    + rewrite <- x0. cbn. constructor. right. eapply CIH.
      pclearbot. symmetry in Heq. apply simpobs in x0.
      apply simpobs in x. apply simpobs in Heq.
      apply eq_sub_eutt in x0. apply eq_sub_eutt in Heq.
      rewrite tau_eutt in Heq. rewrite tau_eutt in x0.
      rewrite <- Heq. rewrite x. rewrite tau_eutt. auto.
    + exfalso. symmetry in Heq. apply simpobs in Heq.
      apply simpobs in x.
      rewrite Heq in x. rewrite bind_tau in x. pinversion x.
      inv CHECK.
    + rewrite <- x. cbn. constructor. right. eapply CIH.
      clear IHHrutt. symmetry in Heq. apply simpobs in Heq.
      apply eq_sub_eutt in Heq. rewrite tau_eutt in Heq.
      rewrite <- Heq. pfold. auto.
    + cbn. destruct (observe b) eqn : Heq'.
      * cbn. rewrite <- Heq'. constructor. right. eapply CIH.
        symmetry in Heq'.
        apply simpobs in Heq'. rewrite Heq'.
        symmetry in Heq. apply simpobs in Heq.
        apply eq_sub_eutt in Heq. rewrite tau_eutt in Heq.
        rewrite <- Heq. apply simpobs in x. rewrite x.
        rewrite tau_eutt. pfold. auto.
      * cbn. clear IHHrutt.
        constructor. right. eapply CIH.
        symmetry in Heq. apply simpobs in Heq.
        apply eq_sub_eutt in Heq. rewrite tau_eutt in Heq.
        rewrite <- Heq.
        apply simpobs in x. apply eq_sub_eutt in x.
        rewrite tau_eutt in x. rewrite x.
        enough (Tau t1 ⊑ t2).
        { rewrite tau_eutt in H. auto. }
        pfold. auto.
      * destruct e; cbn.
        ++ constructor. right. rewrite <- Heq'. clear IHHrutt.
           eapply CIH. symmetry in Heq.
           apply simpobs in Heq. apply eq_sub_eutt in Heq.
           rewrite tau_eutt in Heq. apply simpobs in x.
           apply eq_sub_eutt in x. rewrite tau_eutt in x.
           rewrite <- Heq. rewrite x. pfold. red.
           rewrite Heq'. auto.
        ++ constructor. right. rewrite <- Heq'. clear IHHrutt.
           eapply CIH. symmetry in Heq.
           apply simpobs in Heq. apply eq_sub_eutt in Heq.
           rewrite tau_eutt in Heq. apply simpobs in x.
           apply eq_sub_eutt in x. rewrite tau_eutt in x.
           rewrite <- Heq. rewrite x. pfold. red.
           rewrite Heq'. auto.
  - dependent induction Hrutt.
    + exfalso. symmetry in Heq. apply simpobs in Heq. apply simpobs in x.
      rewrite Heq in x. rewrite bind_vis in x.
      pinversion x.
    + exfalso. symmetry in Heq. apply simpobs in Heq. apply simpobs in x.
      rewrite Heq in x. rewrite bind_vis in x.
      pinversion x; inv CHECK.
    + rewrite <- x0.
      symmetry in Heq. apply simpobs in Heq. apply simpobs in x.
      rewrite Heq in x. rewrite bind_vis in x. pinversion x.
      ddestruction. inversion H; ddestruction.
      * unfold observe. cbn. unfold peel_vis.
        destruct (classicT (B = B) ); try contradiction.
        unfold eq_rect_r, eq_rect.
        remember (eq_sym _) as He. clear HeqHe.
        dependent destruction He. cbn. constructor; eauto.
        intros. inversion H1. ddestruction.
        apply H0 in H1. pclearbot. unfold id. right. eapply CIH.
        red in x1. cbn in x1. inversion x1. ddestruction.
        red in H0. specialize (H0 tt a (rar _ _ _)).
        specialize (REL0 a). pclearbot.
        change (paco2 ?x ?y ?t ?u) with (eq_itree eq t u) in REL0.
        rewrite REL0. apply H0.
      * cbn. constructor; eauto. intros. contradiction.
    + rewrite <- x. cbn. constructor. eapply IHHrutt; eauto.
    + exfalso. symmetry in Heq. apply simpobs in x. apply simpobs in Heq.
      rewrite Heq in x. rewrite bind_vis in x.
      pinversion x; inv CHECK.
Qed.

Lemma not_spin_eutt_ret : forall E R (r : R), ~ (@ITree.spin E R ≈ Ret r).
Proof.
  intros. intros Hcontra. specialize (@spin_infinite E R) as Hdiv.
  rewrite Hcontra in Hdiv. pinversion Hdiv.
Qed.

Lemma proper_peel_eutt_l : forall (E : Type -> Type) (R S : Type)
                                  (b b': itrace E R) (t : itree E S),
    (b ≈ b') -> (peel b t ≈ peel b' t).
Proof.
  intros E R S. pcofix CIH. intros. unfold peel.
  destruct (observe t).
  - pfold. red. destruct (observe b); destruct (observe b'); cbn;
      try (destruct e); try (destruct e0); cbn;
      try (constructor; auto; fail).
  - pfold. punfold H0. red in H0. dependent induction H0.
    + rewrite <- x0. rewrite <- x. red. cbn. constructor.
      right. rewrite x0. eapply CIH. reflexivity.
    + rewrite <- x0. rewrite <- x. red. cbn. constructor. right.
      pclearbot. eapply CIH. auto.
    + rewrite <- x0. rewrite <- x. destruct e; cbn.
      * red. cbn. constructor. right. rewrite x. rewrite x0.
        eapply CIH. pfold. red. rewrite <- x. rewrite <- x0.
        constructor. auto.
      * red. cbn. constructor. right. rewrite x0. rewrite x.
        eapply CIH. pfold. red. rewrite <- x0. rewrite <- x.
        constructor. auto.
    + destruct (observe b); destruct (observe b'); dependent destruction x.
      * red. cbn. constructor. right. remember (@go (EvAns E) _ (RetF r0)) as t1.
        assert (RetF r0 = observe t1).
        { rewrite Heqt1. auto. }
        rewrite H. eapply CIH. rewrite Heqt1. pfold. auto.
      * red. cbn. constructor. right. eapply CIH.
        enough (t2 ≈ Tau t3).
        { rewrite tau_eutt in H. auto. }
        pfold. auto.
      * red. destruct e; cbn.
        ++ constructor. right.
           remember (@go (EvAns E) _ (VisF (evans A ev ans) k )  ) as t1.
           assert (VisF (evans A ev ans) k  = observe t1).
           { rewrite Heqt1. auto. }
           rewrite H. eapply CIH. subst. pfold. auto.
        ++ constructor. right.
           remember (go (VisF (evempty A Hempty ev) k )  ) as t1.
           assert (VisF (evempty A Hempty ev) k = observe t1 ).
           { subst. auto. }
           rewrite H. eapply CIH. subst. pfold. auto.
    + destruct (observe b); destruct (observe b'); dependent destruction x.
      * red. cbn. constructor. right. remember (@go (EvAns E) _ (RetF r0)) as t2.
        assert (RetF r0 = observe t2).
        { subst. auto. }
        rewrite H. eapply CIH. rewrite Heqt2. pfold. auto.
      * red. cbn. constructor. right. eapply CIH.
        enough (Tau t1 ≈ t3).
        { rewrite tau_eutt in H. auto. }
        pfold. auto.
      * red. destruct e; cbn.
        ++ constructor. right.
           remember (@go (EvAns E) _ (VisF (evans A ev ans) k )  ) as t2.
           assert (VisF (evans A ev ans) k  = observe t2).
           { subst. auto. }
           rewrite H. eapply CIH. subst. pfold. auto.
        ++ constructor. right.
           remember (go (VisF (evempty A Hempty ev) k )  ) as t2.
           assert (VisF (evempty A Hempty ev) k = observe t2 ).
           { subst. auto. }
           rewrite H. eapply CIH. subst. pfold. auto.
  - pfold. punfold H0. red in H0. dependent induction H0.
    + rewrite <- x0. rewrite <- x. red. cbn. constructor.
      left. eapply paco2_mon with (r := bot2); intuition.
      enough (@ITree.spin (EvAns E) S  ≈ ITree.spin); auto.
      reflexivity.
    + rewrite <- x. rewrite <- x0. red. cbn. constructor. right.
      remember (go (VisF e k) ) as t0.
      assert (VisF e k = observe t0).
      { subst. auto. }
      rewrite H. eapply CIH. pclearbot. auto.
    + rewrite <- x0. rewrite <- x. red. destruct e; cbn.
      * unfold observe. cbn. unfold peel_vis.
        destruct (classicT (A = X) ).
        ++ unfold eq_rect_r, eq_rect. remember (eq_sym e) as He.
           dependent destruction He. cbn. constructor. intros.
           right. eapply CIH. pclearbot. auto with itree.
        ++ cbn. constructor. left. eapply paco2_mon with (r := bot2); intuition.
           enough (@ITree.spin (EvAns E) S ≈ ITree.spin ); auto.
           reflexivity.
      * constructor. left. contradiction.
    + rewrite <- x. red. destruct (observe b') eqn : Heq.
      * rewrite <- Heq. cbn. constructor; auto. eapply IHeqitF; eauto. rewrite Heq. auto.
      * cbn. constructor. right.
        remember (go (VisF e k) ) as t2.
        assert (VisF e k = observe t2).
        { subst. auto. }
        rewrite H. eapply CIH.
        enough (t1 ≈ Tau t0).
        { rewrite tau_eutt in H1. auto. }
        pfold; auto.
      * cbn. constructor; eauto. rewrite <- Heq. eapply IHeqitF; eauto.
        rewrite Heq. auto.
    + rewrite <- x. red. destruct (observe b) eqn : Heq.
      * rewrite <- Heq. cbn. constructor; auto. eapply IHeqitF; eauto. rewrite Heq. auto.
      * cbn. constructor. right.
        remember (go (VisF e k) ) as t1.
        assert (VisF e k = observe t1).
        { subst. auto. }
        rewrite H. eapply CIH.
        enough (Tau t0 ≈ t2).
        { rewrite tau_eutt in H1. auto. }
        pfold; auto.
      * cbn. constructor; eauto. rewrite <- Heq. eapply IHeqitF; eauto.
        rewrite Heq. auto.
Qed.

Lemma proper_peel_eutt_r : forall (E : Type -> Type) (R S : Type)
                                  (b: itrace E R) (t t': itree E S),
    (t ≈ t') -> (peel b t ≈ peel b t').
Proof.
  intros E R S. pcofix CIH. intros.
  pfold. red. unfold peel. destruct (observe b) eqn : Heqb.
  - punfold H0. red in H0. dependent induction H0.
    + rewrite <- x. rewrite <- x0.  cbn. constructor. auto.
    + rewrite <- x. rewrite <- x0. cbn. constructor. right. rewrite <- Heqb.
      eapply CIH. pclearbot. auto.
    + rewrite <- x0. rewrite <- x. cbn. constructor.
      left. apply paco2_eqit_refl.
    + rewrite <- x.  cbn. constructor; auto. eapply IHeqitF; eauto.
    + rewrite <- x. cbn. constructor; auto. eapply IHeqitF; eauto.
  - punfold H0. red in H0. dependent induction H0.
    + rewrite <- x. rewrite <- x0. cbn. constructor. auto.
    + rewrite <- x0. rewrite <- x. cbn. constructor. right.
      pclearbot. eapply CIH; auto.
    + rewrite <- x0. rewrite <- x. cbn. constructor. right.
      rewrite x0. rewrite x. eapply CIH.
      pfold. red. rewrite <- x0. rewrite <- x.
      constructor. auto.
    + rewrite <- x. destruct (observe t') eqn : Heqt'.
      * cbn.  constructor; auto. clear IHeqitF.
        dependent induction H0.
        ++ rewrite <- x. destruct (observe t0); cbn; try (constructor; auto; fail).
           destruct e; cbn; constructor; auto.
        ++ rewrite <- x. cbn. destruct (observe t2) eqn : Heqt2; cbn.
           ** constructor; eauto. rewrite <- Heqt2.  eapply IHeqitF; eauto.
           ** constructor; auto. eapply IHeqitF; eauto.
           ** destruct e; cbn;
                try (constructor; auto; rewrite <- Heqt2; eapply IHeqitF; eauto).
      * cbn. constructor. right. eapply CIH; eauto.
        enough (t1 ≈ Tau t2).
        { rewrite tau_eutt in H. auto. }
        pfold. auto.
      * cbn. constructor. rewrite <- Heqt'. right. eapply CIH.
        pfold. red. rewrite Heqt'. auto.
    + rewrite <- x. destruct (observe t).
      * cbn. constructor; auto. clear IHeqitF.
        dependent induction H0.
        ++ rewrite <- x. destruct (observe t0); try (destruct e); cbn; constructor; auto.
        ++ rewrite <- x. destruct (observe t1) eqn : Heqt1; cbn.
           ** constructor; auto. rewrite <- Heqt1. eapply IHeqitF; eauto.
           ** constructor; auto. eapply IHeqitF; eauto.
           ** destruct e; cbn; try (constructor; auto; rewrite <- Heqt1; eapply IHeqitF; eauto).
      * cbn. constructor. right. eapply CIH; eauto.
        rewrite <- tau_eutt at 1. pfold. auto.
      * cbn. constructor. right. remember ((Vis e k) ) as t1.
        assert (VisF e k = observe t1).
        { subst. auto. }
        rewrite H. eapply CIH. subst. pfold. auto.
  - punfold H0. red in H0. dependent induction H0.
    + rewrite <- x. rewrite <- x0. destruct e; cbn; constructor; auto.
    + rewrite <- x. rewrite <- x0. destruct e; cbn; constructor; right; rewrite <- Heqb;
        eapply CIH; pclearbot; eauto.
    + rewrite <- x. rewrite <- x0. destruct e0; cbn.
      * unfold observe. cbn. unfold peel_vis.
        destruct (classicT (A = u) ).
        ++ unfold eq_rect_r, eq_rect. remember (eq_sym e0) as He.
           dependent destruction He. cbn. constructor. intros.
           right. eapply CIH. pclearbot. auto with itree.
        ++ cbn. constructor. left. apply paco2_eqit_refl.
      * constructor. intuition.
    + rewrite <- x. destruct (observe t'); destruct e; cbn.
      * constructor; auto. clear IHeqitF. dependent induction H0.
        ++ rewrite <- x. cbn. constructor; auto.
        ++ rewrite <- x. cbn. constructor; eauto.
      * constructor; auto. clear IHeqitF. dependent induction H0.
        ++ rewrite <- x. cbn. constructor; auto.
        ++ rewrite <- x. cbn. constructor; eauto.
      * constructor. rewrite <- Heqb. right. eapply CIH.
        setoid_rewrite <- tau_eutt at 2. pfold. auto.
      * rewrite <- Heqb. constructor. right. eapply CIH.
        setoid_rewrite <- tau_eutt at 2. pfold. auto.
      * constructor; auto. clear IHeqitF.
        dependent induction H0.
        ++ rewrite <- x. unfold observe. cbn.
           unfold peel_vis. destruct (classicT (A = X0) ).
           ** unfold eq_rect_r, eq_rect.
              remember (eq_sym e) as He. dependent destruction He.
              cbn. constructor. intros. right. pclearbot. eapply CIH; eauto with itree.
           ** cbn. constructor. left. apply paco2_eqit_refl.
        ++ rewrite <- x. cbn. constructor; auto; eapply IHeqitF; eauto.
      * constructor; auto. clear IHeqitF.
        dependent induction H0.
        ++ rewrite <- x. cbn. constructor. intuition.
        ++ rewrite <- x. cbn. constructor; auto; eapply IHeqitF; eauto.
    + rewrite <- x. cbn. destruct (observe t) eqn : Heqt; destruct e; cbn.
      * constructor; auto. clear IHeqitF. dependent induction H0.
        ++ rewrite <- x. cbn. constructor; auto.
        ++ rewrite <- x. cbn. constructor; eauto.
      * constructor; auto. clear IHeqitF. dependent induction H0.
        ++ rewrite <- x. cbn. constructor; auto.
        ++ rewrite <- x. cbn. constructor; eauto.
      * constructor. right. rewrite <- Heqb. eapply CIH; eauto. rewrite <- tau_eutt.
        pfold. auto.
      * constructor. rewrite <- Heqb. right. eapply CIH; eauto. rewrite <- tau_eutt.
        pfold. auto.
      * constructor; auto. clear IHeqitF. dependent induction H0.
        ++ rewrite <- x. unfold observe. cbn.
           unfold peel_vis.
           destruct (classicT (A = X0) ).
           ** unfold eq_rect_r, eq_rect.
              remember (eq_sym e) as He. dependent destruction He.
              cbn. constructor. intros. right. pclearbot. eapply CIH; apply REL.
           ** cbn. constructor. left. apply paco2_eqit_refl.
        ++ rewrite <- x. cbn. constructor; eauto.
      * constructor; auto. clear IHeqitF. dependent induction H0.
        ++ rewrite <- x. cbn. constructor. intuition.
        ++ rewrite <- x. cbn. constructor; eauto.
Qed.

#[global] Instance proper_eutt_peel {E R S} : Proper (eutt eq ==> eutt eq ==> eutt eq) (@peel E R S).
Proof.
  intros ? ? ? ? ? ?. rewrite proper_peel_eutt_l with (t := x0); eauto.
  eapply proper_peel_eutt_r; eauto.
Qed.

Lemma not_peel_vis_ret: forall (R : Type) (E : Type -> Type) (S X : Type) (e : E X) (k : X -> itree E R)
                               (r : R) (t1 : itree (EvAns E) S),
    ~ (peel t1 (Vis e k) ≈ Ret r).
Proof.
  intros R E S X e k r t1 Heutt.
  punfold Heutt. unfold peel in *. red in Heutt. cbn in *.
  dependent induction  Heutt.
  - destruct (observe t1); cbn in x; try discriminate.
    destruct e0; cbn in *; try discriminate.
    unfold observe in x. cbn in x. unfold peel_vis in x.
    destruct (classicT (A = X)); try discriminate.
    unfold eq_rect_r, eq_rect in x. remember (eq_sym e0) as He.
    dependent destruction He. discriminate.
  - destruct (observe t1); cbn in x; try discriminate.
    + injection x as Hspin. rewrite Hspin in Heutt.
      eapply not_spin_eutt_ret. pfold. eauto.
    + injection x as Ht0. eapply IHHeutt; eauto. rewrite Ht0. reflexivity.
    + destruct e0; cbn in *; try discriminate.
      unfold observe in x. cbn in x. unfold peel_vis in *.
      destruct (classicT (A = X) ).
      * unfold eq_rect_r, eq_rect in x. remember (eq_sym e0) as He.
        dependent destruction He. discriminate.
      * cbn in x. injection x as Hspin. rewrite Hspin in Heutt.
        eapply not_spin_eutt_ret. pfold. eauto.
Qed.

Lemma peel_ret_inv:
  forall (R : Type) (r : R) (E : Type -> Type) (S : Type) (b : itrace E S) (t : itree E R),
    (peel b t ≈ Ret r) -> (t ≈ Ret r).
Proof.
  intros R r E S b t H. unfold peel in H.
  punfold H. red in H. cbn in H. pfold. red. cbn.
  dependent induction H.
  - unfold peel in x. destruct (observe b); destruct (observe t); cbn in *;
      dependent destruction x; try (constructor; auto; fail).
    + destruct e; dependent destruction x; try (constructor; auto).
    + destruct e; dependent destruction x.
    + destruct e; dependent destruction x.
      unfold observe in x. cbn in x. unfold peel_vis in x.
      destruct (classicT (A = X0) ) eqn : Heq.
      * unfold eq_rect_r, eq_rect in x. subst. remember (eq_sym eq_refl) as He.
        dependent destruction He. cbn in x0. discriminate.
      * discriminate.
  - destruct (observe b); destruct (observe t); cbn in x; dependent destruction x.
    + constructor; auto. eapply IHeqitF with (b := Ret r0); eauto.
    + exfalso. eapply not_spin_eutt_ret. pfold. eauto.
    + constructor; auto. eapply IHeqitF; eauto.
    + exfalso. destruct (observe t0).
      * cbn in H. eapply not_spin_eutt_ret.
        inv  H. pfold. eauto.
      * cbn in H. inv H. eapply not_peel_vis_ret.
        pfold. eauto.
      * destruct e0.
        ++ clear IHeqitF. unfold observe in H. cbn in H. unfold peel_vis in H.
           destruct (classicT (A = X) ).
           ** unfold eq_rect_r, eq_rect in H. remember (eq_sym e0) as He.
              dependent destruction He. inv H.
           ** eapply not_spin_eutt_ret. pfold. eauto.
        ++ cbn in H. inv H.
    + destruct e; cbn in x; try discriminate.
    + constructor; auto. eapply IHeqitF with (b := Vis e k); eauto. cbn.
      destruct e; cbn in x; dependent destruction x; auto.
    + destruct e; cbn in x; try discriminate.
      unfold observe in x. cbn in x. unfold peel_vis in x.
      destruct (classicT (A = X0) ).
      * unfold eq_rect_r, eq_rect in x. remember (eq_sym e) as He.
        dependent destruction He. discriminate.
      * injection x as Hspin. cbn in Hspin. exfalso.
        assert (t1 ≈ Ret r).
        { pfold. auto. }
        rewrite Hspin in H0. eapply not_spin_eutt_ret; eauto.
Qed.

Lemma eqitF_r_refl: forall (E : Type -> Type) (R: Type) r
                           (ot: itree' E R),
    eqitF eq true true id (upaco2 (eqit_ eq true true id) r)
          ot ot.
Proof.
  intros E R r ot.
  destruct ot; constructor; auto.
  - left. eapply paco2_mon with (r := bot2); intuition.
    apply Equivalence_eutt. apply eq_equivalence.
  - left. eapply paco2_mon with (r := bot2); intuition.
    apply Equivalence_eutt. apply eq_equivalence.
Qed.

Lemma eqitF_mon:
  forall (E : Type -> Type) (R : Type) (r : itree (EvAns E) R -> itree (EvAns E) R -> Prop)
         (t1 : itree' (EvAns E) R) (t0 : itree' (EvAns E) R),
    eqitF eq true true id (upaco2 (eqit_ eq true true id) bot2) t1 t0 ->
    eqitF eq true true id (upaco2 (eqit_ eq true true id) r) t1 t0.
Proof.
  intros E R r t1 t0' REL.
  induction REL; constructor; eauto.
  - pclearbot. left. eapply paco2_mon; eauto; intuition.
  - pclearbot. intros. left. eapply paco2_mon; eauto; intuition.
Qed.

Lemma eqitF_observe_peel_cont_vis:
  forall (E : Type -> Type) (R S A : Type) (ev : E A) (ans : A)
         (k1 k2 : unit -> itree (EvAns E) R),
    (forall v : unit, id (upaco2 (eqit_ eq true true id) bot2) (k1 v) (k2 v)) ->
    forall r : itree (EvAns E) R -> itree (EvAns E) R -> Prop,
      (forall (b b' : itrace E R) (t : itree E S),
          (b ≈ b') ->
          r (peel_cont_ (observe b) (observe t)) (peel_cont_ (observe b') (observe t))) ->
      forall (X : Type) (e : E X) (k : X -> itree E S),
        eqitF eq true true id (upaco2 (eqit_ eq true true id) r)
              (observe (peel_cont_ (VisF (evans A ev ans) k1) (VisF e k)))
              (observe (peel_cont_ (VisF (evans A ev ans) k2) (VisF e k))).
Proof.
  intros E R S A ev ans k1 k2 REL r CIH X e k.
  unfold observe. cbn. unfold peel_cont_vis.
  destruct (classicT (A = X) ).
  - unfold eq_rect_r, eq_rect. remember (eq_sym e0) as He.
    dependent destruction He. cbn. constructor.
    intros. right. pclearbot. eapply CIH. auto with itree.
  - cbn. apply eqitF_r_refl.
Qed.

Lemma proper_peel_cont_eutt_l : forall (E : Type -> Type) (R S : Type)
                                       (b b': itrace E R) (t : itree E S) (s : S),
    (b ≈ b') -> (peel_cont b t s ≈ peel_cont b' t s).
Proof.
  intros E R S. unfold peel_cont. intros b b' t _.
  revert b b' t. pcofix CIH. intros. pfold. punfold H0. red in H0.
  destruct (observe t) eqn : Heqt.
  - red. destruct (observe b') eqn : Hb; destruct (observe b) eqn : Hb'; inversion H0; cbn;
      try (constructor; auto; fail);
      try (constructor; auto; eapply eqitF_mon; eauto; fail);
      try (destruct e; cbn);
      try (constructor; auto; eapply eqitF_mon; eauto; fail).
    + constructor. pclearbot. left. eapply paco2_mon; eauto; intuition.
    + subst. ddestruction. subst. cbn. constructor. intros. left. inv H0.
      ddestruction. subst. pclearbot. eapply paco2_mon; eauto; intuition.
    + ddestruction. subst. ddestruction. subst. cbn. constructor; auto. intuition.
  (*looks like I didn't actually need to induct here ... *)
  - dependent induction H0; try clear IHeqitF.
    + rewrite <- x0. rewrite <- x. red. cbn. constructor. right.
      rewrite x. eapply CIH; eauto. pfold. red. rewrite <- x. constructor; auto.
    + rewrite <- x0. rewrite <- x. red. cbn. constructor. right.
      eapply CIH. pclearbot. auto.
    + rewrite <- x0. rewrite <- x. red. destruct e; cbn; constructor; right.
      * rewrite x. rewrite x0. eapply CIH; eauto. pfold. red.
        rewrite <- x0. rewrite <- x. constructor. auto.
      * rewrite x. rewrite x0. eapply CIH; eauto. pfold. red.
        rewrite <- x0. rewrite <- x. constructor. auto.
    + rewrite <- x. red. cbn.
      destruct (observe b') eqn : Heqb'; cbn.
      * constructor. right. rewrite <- Heqb'. eapply CIH.
        symmetry in Heqb'. apply simpobs in Heqb'. rewrite Heqb'.
        pfold. auto.
      * constructor. right. eapply CIH. setoid_rewrite <- tau_eutt at 2.
        pfold. auto.
      * constructor. right. rewrite <- Heqb'. eapply CIH.
        symmetry in Heqb'. apply simpobs in Heqb'. rewrite Heqb'. pfold. auto.
    + rewrite <- x. red. cbn. destruct (observe b) eqn : Heqb; cbn.
      * constructor; auto. right. rewrite <- Heqb. eapply CIH.
        pfold. red. rewrite Heqb. auto.
      * constructor. right. eapply CIH. rewrite <- tau_eutt at 1. pfold. auto.
      * constructor. right. rewrite <- Heqb. eapply CIH. pfold.
        red. rewrite Heqb. auto.
  - red. dependent induction H0; cbn.
    +  rewrite <- x0. rewrite <- x. cbn. constructor. left. pfold. apply eqitF_r_refl.
    + rewrite <- x0. rewrite <- x. cbn. constructor. right. rewrite <- Heqt. eapply CIH.
      pclearbot. auto.
    + rewrite <- x. rewrite <- x0. destruct e; cbn; try (apply eqitF_observe_peel_cont_vis; auto).
      apply eqitF_r_refl.
    + rewrite <- x. cbn. constructor; eauto.
    + rewrite <- x. cbn. constructor; eauto.
Qed.

Lemma peel_cont_ret_inv : forall E R S (b : itrace E R) (t : itree E S) (s : S),
    t ≈ Ret s -> (peel_cont_ (observe b) (observe t) ≈ b).
Proof.
  intros E R S. pcofix CIH. intros. punfold H0. red in H0. cbn in H0. dependent induction H0; subst.
  - rewrite <- x. cbn. pfold. red. cbn. apply eqitF_r_refl.
  - rewrite <- x. destruct (observe b) eqn : Hb.
    + pfold. red. cbn. constructor; auto.

      specialize (IHeqitF r CIH (Ret r0) t1 s ); auto.
      assert (S = S). auto. apply IHeqitF in H; auto. rewrite Hb.
      punfold H.
    + pfold. red. rewrite Hb. cbn.   constructor. right. eapply CIH with (s := s).
      pfold. auto.
    + pfold. red. rewrite Hb. cbn. rewrite <- Hb. constructor; auto.
      specialize (IHeqitF r CIH b t1 s ); auto.
      assert (S = S). auto. apply IHeqitF in H; auto. punfold H.
Qed.

Lemma proper_peel_cont_eutt_r : forall (E : Type -> Type) (R S : Type)
                                       (b: itrace E R) (t t': itree E S) (s : S),
    (t ≈ t') -> (peel_cont b t s ≈ peel_cont b t' s).
Proof.
  intros E R S. unfold peel_cont. intros b t t' _.
  revert b t t'. pcofix CIH. intros. pfold. punfold H0. red in H0. dependent induction H0.
  - rewrite <- x. rewrite <- x0. red. cbn. apply eqitF_r_refl.
  - rewrite <- x. rewrite <- x0. red. destruct (observe b) eqn : Heqb; cbn.
    + constructor. right. rewrite <- Heqb. eapply CIH. pclearbot. auto.
    + constructor. right. eapply CIH. pclearbot. auto.
    + constructor. right. rewrite <- Heqb. eapply CIH; pclearbot; auto.
  - rewrite <- x. rewrite <- x0. pclearbot. destruct (observe b) eqn : Heqb; red; cbn.
    + apply eqitF_r_refl.
    + constructor. rewrite x. rewrite x0. right. eapply CIH.
      pfold. red. rewrite <- x. rewrite <- x0. constructor. intros.
      left. auto.
    + destruct e0; cbn.
      * unfold observe. cbn. unfold peel_cont_vis.
        destruct (classicT (A = u) ); try apply eqitF_r_refl.
        unfold eq_rect_r, eq_rect. remember (eq_sym e0) as He.
        dependent destruction He. cbn. constructor. intros. right.
        eapply CIH. auto with itree.
      * apply eqitF_r_refl.
  - rewrite <- x. destruct (observe b) eqn : Heqb; red; cbn.
    + constructor; eauto. rewrite <- Heqb. eapply IHeqitF; eauto.
    + cbn. destruct (observe t') eqn : Heqt'; cbn.
      * constructor. left. eapply paco2_mon with (r := bot2); intuition.
        eapply peel_cont_ret_inv with (s := r0). pfold. auto.
      * constructor. right. eapply CIH; eauto. setoid_rewrite <- tau_eutt at 2.
        pfold. auto.
      * constructor. right. rewrite <- Heqt'. eapply CIH.
        pfold. red. rewrite Heqt'. auto.
    + rewrite <- Heqb. constructor; auto. eapply IHeqitF; eauto.
  - rewrite <- x. destruct (observe b) eqn : Heqb; red; cbn.
    + constructor; auto. rewrite <- Heqb. eapply IHeqitF; eauto.
    + destruct (observe t) eqn : Heqt; cbn.
      * constructor. left. eapply paco2_mon with (r := bot2); intuition.
        enough (t0 ≈ peel_cont_ (observe t0) (observe t2) ). auto.
        symmetry.
        eapply peel_cont_ret_inv with (s := r0). symmetry. pfold. auto.
      * constructor. right. eapply CIH. rewrite <- tau_eutt at 1. pfold. auto.
      * constructor. right. rewrite <- Heqt. eapply CIH.
        pfold. red. rewrite Heqt. auto.
    + rewrite <- Heqb. constructor; auto. eapply IHeqitF; eauto.
Qed.

#[global] Instance proper_eutt_peel_cont {E R S} : Proper (eutt eq ==> eutt eq ==> eq ==> eutt eq) (@peel_cont E R S).
Proof.
  repeat intro. subst. rewrite proper_peel_cont_eutt_l; eauto.
  rewrite proper_peel_cont_eutt_r; eauto. reflexivity.
Qed.
(*
Lemma peel_cont_bind : forall (E : Type -> Type) (R S : Type) (b : itrace E S) (t : itree E R) (f : R -> itree E S),
    b ⊑ ITree.bind t f -> (ITree.bind (peel b t) (peel_cont b t) ≈ b).
Proof.
  intros E R S. pcofix CIH. intros. punfold H0. pfold. red. red in H0. cbn in *.
  unfold ITree.bind in H0. unfold ITree.bind. cbn in *.
  unfold observe at 1. cbn.
 *)
(*may need an analgous lemma for *)
Lemma vis_refine_peel : forall (E : Type -> Type) (R S A : Type) (e : E A) (a : A)
                               (k1: unit -> itrace E S) (k2 : A -> itree E R) (k3 : unit -> itrace E R),
    (peel (Vis (evans _ e a) k1) (Vis e k2) ≈ Vis (evans _ e a) k3) ->
    (k3 tt ≈ peel (k1 tt) (k2 a)).
Proof.
  intros E R S A. (* pcofix CIH. *) intros e a k1 k2 k3 Hpeel.
  unfold peel in *. cbn in *. punfold Hpeel.
  red in Hpeel. cbn in *. cbn in Hpeel.
  unfold observe in Hpeel. cbn in Hpeel.
  unfold peel_vis in Hpeel.
  assert (A = A). auto.
  destruct (classicT (A = A) ); try contradiction. unfold eq_rect_r, eq_rect in Hpeel.
  remember (eq_sym e0) as He. dependent destruction He. cbn in *.
  clear HeqHe e0 H. pfold. red. cbn. inv Hpeel. ddestruction.
  pclearbot. specialize (REL tt).
  assert (peel_ (observe (k1 tt)) (observe (k2 a)) ≈ k3 tt ). auto.
  symmetry in H. punfold H.
Qed.

Lemma vis_refine_peel_cont :  forall (E : Type -> Type) (R S A : Type) (e : E A) (a : A)
                                     (k1: unit -> itrace E S) (k2 : A -> itree E R) (t : itrace E S),
    (peel_cont_ (VisF (evans _ e a) k1) (VisF e k2) ≈ t) ->
    (t ≈ peel_cont_ (observe (k1 tt)) (observe (k2 a))).
Proof.
  intros E R S A e a k1 k2 t Hpeelcont. punfold Hpeelcont. red in Hpeelcont.
  unfold observe in Hpeelcont at 1. cbn in *. unfold peel_cont_vis in *.
  assert (A = A); auto. destruct (classicT (A = A) ); try contradiction.
  unfold eq_rect_r, eq_rect in *. remember (eq_sym e0) as He.
  dependent destruction He. cbn in *. symmetry.
  assert (Tau (peel_cont_ (observe (k1 tt)) (observe (k2 a) ) )  ≈ t ).
  { pfold. auto. }
  rewrite tau_eutt in H0. auto.
Qed.

Lemma spin_not_vis : forall (E : Type -> Type) (R A : Type)
                            (e : E A) (k : A -> itree E R),
    ~ ITree.spin ≈ Vis e k.
Proof.
  intros E R A e k Hcontra. punfold Hcontra. red in Hcontra. cbn in *.
  dependent induction Hcontra.
  eapply IHHcontra; eauto.
Qed.

Lemma peel_vis_empty_contra: forall (R : Type) (E : Type -> Type) (S A0 : Type) (Hempty : A0 -> void)
                                    (ev : E A0) (k0 : void -> itree (EvAns E) S) (t0 : itree E R) (A : Type)
                                    (a : A) (e : E A) (k : unit -> itrace E R),
    eqitF eq true true id (upaco2 (eqit_ eq true true id) bot2)
          (observe (peel_ (VisF (evempty A0 Hempty ev) k0) (observe t0)))
          (VisF (evans A e a) k) -> False.
Proof.
  intros R E S A0 Hempty ev k0 t0 A a e k Hpeel.
  dependent induction Hpeel.
  - destruct (observe t0) eqn : Heqt0; discriminate.
  - destruct (observe t0) eqn : Heqt0; try discriminate. cbn in x. injection x as Ht1.
    rewrite Ht1 in IHHpeel. eapply IHHpeel; eauto.
Qed.

Lemma vis_peel_l : forall (E : Type -> Type) (R S A : Type) (e : E A) (a : A)
                          (b : itrace E S) (t : itree E R) (f : R -> itree E S) (k : unit -> itrace E R),
    b ⊑ ITree.bind t f ->
    (peel b t ≈ Vis (evans _ e a) k) -> exists k', (b ≈ Vis (evans _ e a) k').
Proof.
  intros E R S A e a b t f k Href Hpeel.
  punfold Hpeel. red in Hpeel. cbn in Hpeel. dependent induction Hpeel.
  - unfold peel in x.
    destruct (observe b) eqn : Heqb; destruct (observe t) eqn : Heqt; try destruct e0; cbn in *;
      dependent destruction x. unfold observe in x. cbn in x.
    unfold peel_vis in x.
    assert (A0 = X0).
    {
      clear x.
      symmetry in Heqb. symmetry in Heqt. apply simpobs in Heqb. apply simpobs in Heqt.
      rewrite Heqb in Href. rewrite Heqt in Href.
      rewrite bind_vis in Href.
      punfold Href. red in Href. cbn in *. inv Href.
      ddestruction. subst. inv H1. auto.
    }
    destruct (classicT (A0 = X0)); try (exfalso; auto; fail).
    unfold eq_rect_r, eq_rect in x. remember (eq_sym e0) as He.
    dependent destruction He. cbn in x. injection x as Hevans.
    ddestruction. subst. ddestruction. subst. exists k0.
    symmetry in Heqb. apply simpobs in Heqb. rewrite Heqb. reflexivity.
  - unfold peel in x. destruct (observe b) eqn : Heqb; destruct (observe t) eqn : Heqt;
      try destruct e0; cbn in *; dependent destruction x.
    + symmetry in Heqt. apply simpobs in Heqt. rewrite Heqt in Href.
      rewrite tau_eutt in Href. eapply IHHpeel in Href; eauto. unfold peel.
      rewrite Heqb. auto.
    + exfalso. eapply spin_not_vis. pfold. eauto.
    + symmetry in Heqb. symmetry in Heqt. apply simpobs in Heqt.
      apply simpobs in Heqb. setoid_rewrite Heqb. setoid_rewrite tau_eutt.
      rewrite Heqb in Href. rewrite Heqt in Href. repeat rewrite tau_eutt in Href.
      eapply IHHpeel in Href; eauto.
    + symmetry in Heqb. symmetry in Heqt. apply simpobs in Heqb. apply simpobs in Heqt.
      setoid_rewrite Heqb. setoid_rewrite tau_eutt. rewrite Heqb in Href.
      rewrite Heqt in Href. repeat rewrite tau_eutt in Href.
      eapply IHHpeel in Href; eauto.
    + symmetry in Heqt. apply simpobs in Heqt. rewrite Heqt in Href.
      rewrite tau_eutt in Href.
      symmetry in Heqb. apply simpobs in Heqb. rewrite Heqb in Href.
      setoid_rewrite Heqb. eapply IHHpeel in Href; eauto.
    + exfalso. eapply peel_vis_empty_contra; eauto.
    + unfold observe in x. cbn in x. unfold peel_vis in x.
      symmetry in Heqb. symmetry in Heqt. apply simpobs in Heqt.
      apply simpobs in Heqb. rewrite Heqb in Href. rewrite Heqt in Href.
      rewrite bind_vis in Href. punfold Href. red in Href. cbn in *.
      inv Href. ddestruction. subst. inv H1. subst; ddestruction; subst.
      assert (A0 = A0); auto. destruct (classicT (A0 = A0) ); try contradiction.
      unfold eq_rect_r, eq_rect in *. remember (eq_sym e0) as He.
      dependent destruction He. cbn in *. discriminate.
Qed.

Lemma vis_peel_r : forall (E : Type -> Type) (R S A : Type) (e : E A) (a : A)
                          (b : itrace E S) (t : itree E R) (f : R -> itree E S) (k : unit -> itrace E R),
    b ⊑ ITree.bind t f ->
    (peel b t ≈ Vis (evans _ e a) k) -> exists k', (t ≈ Vis e k').
Proof.
  intros E R S A e a b t f k Href Hpeel.
  eapply vis_peel_l in Hpeel as Hpeell; eauto. destruct Hpeell as [k' Hb].
  rewrite Hb in Href. rewrite Hb in Hpeel. clear Hb b. punfold Hpeel. red in Hpeel. cbn in *.
  unfold peel in Hpeel. cbn in *. dependent induction Hpeel.
  - destruct (observe t) eqn : Heqt; dependent destruction x.
    symmetry in Heqt. apply simpobs in Heqt. setoid_rewrite Heqt.
    unfold observe in x. cbn in *. unfold peel_vis in x. destruct (classicT (A = X));
      cbn in *; try discriminate.
    unfold eq_rect_r, eq_rect in x. remember (eq_sym e1) as He.
    dependent destruction He. cbn in *. exists k0.
    rewrite Heqt in Href. rewrite bind_vis in Href. punfold Href. red in Href.
    cbn in *. inv Href. ddestruction; subst. inv H1. ddestruction; subst. reflexivity.
  - destruct (observe t) eqn : Heqt; cbn in *; dependent destruction x.
    + symmetry in Heqt. apply simpobs in Heqt. rewrite Heqt in Href. rewrite tau_eutt in Href.
      setoid_rewrite Heqt. setoid_rewrite tau_eutt. eapply IHHpeel; eauto.
    + unfold observe in x. cbn in x. unfold peel_vis in x.
      destruct (classicT (A = X) ).
      * unfold eq_rect_r, eq_rect in x. remember (eq_sym e1) as He. dependent destruction He.
        cbn in *. discriminate.
      * cbn in x. injection x as Ht1. rewrite Ht1 in Hpeel.
        exfalso. eapply spin_not_vis. pfold. eauto.
Qed.

Lemma peel_cont_vis_eutt: forall (R : Type) (r : R) (E : Type -> Type) (S A : Type) (ev : E A)
                                 (ans : A) (kb : unit -> itree (EvAns E) S) (kt : A -> itree E R),
    (peel_cont (Vis (evans A ev ans) kb) (Vis ev kt) r ≈ peel_cont (kb tt) (kt ans) r).
Proof.
  intros R r E S A ev ans kb kt.
  pfold. cbn. red. unfold observe at 1. cbn in *. unfold peel_cont_vis.
  assert (A = A); auto. destruct (classicT (A = A)); try contradiction.
  unfold eq_rect_r, eq_rect. remember (eq_sym e) as He.
  dependent destruction He. cbn. constructor; auto. unfold peel_cont.
  apply eqitF_r_refl.
Qed.

Lemma peel_cont_refine_t : forall (E : Type -> Type) (R S : Type)
                                  (b : itrace E S) (t : itree E R) (f : R -> itree E S) (r : R)
                                  (Hrutt : b ⊑ ITree.bind t f),
    may_converge r (peel b t) -> peel_cont b t r ⊑ f r.
Proof.
  intros. remember (peel b t) as t'. assert (peel b t ≈ t').
  { subst. reflexivity. }
  clear Heqt'. generalize dependent b. generalize dependent t.
  induction H; intros.
  - rewrite <- H0 in H. clear H0. apply peel_ret_inv in H as Ht.
    rewrite Ht in Hrutt.
    rewrite bind_ret_l in Hrutt.
    rewrite Ht in H.
    unfold peel_cont. cbn. rewrite peel_cont_ret_inv; eauto.
  - rewrite H in H1. clear H.
    destruct e; try contradiction. eapply vis_peel_l in H1 as Hb; eauto.
    eapply vis_peel_r in H1 as Ht; eauto.
    destruct Hb as [kb Hkb]. destruct Ht as [kt Htk].
    rewrite Htk. rewrite Hkb.
    rewrite Hkb in Hrutt. rewrite Htk in Hrutt.
    rewrite Hkb in H1. rewrite Htk in H1.
    apply vis_refine_peel in H1 as Hk.
    rewrite peel_cont_vis_eutt. apply IHmay_converge; auto.
    + rewrite bind_vis in Hrutt. punfold Hrutt. red in Hrutt. cbn in *.
      inv Hrutt. ddestruction; subst.
      assert (RAnsRef E unit A (evans A ev ans) tt ev ans ); auto with itree.
      apply H8 in H. pclearbot. auto.
    + destruct b. symmetry. auto.
Qed.

Ltac fold_eutt := match goal with |- paco2 _ _ ?t1 ?t2 =>
                                    eapply paco2_mon with (r := bot2); intuition; enough (t1 ≈ t2); auto end.

Ltac fold_peel_cont r := match goal with |- context [peel_cont_ (observe ?b) (observe ?t) ] =>
                                           assert (Hfpc : forall r, peel_cont_ (observe b) (observe t) = peel_cont b t r ); auto; rewrite (Hfpc r);
                                           clear Hfpc end.

Lemma trace_prefix_tau_ret:
  forall (E : Type -> Type) (R S : Type) (r : itrace E S -> itrace E R -> Prop)
         (b : itrace E R) (t : itree E S) (f : S -> itree E R) (r0 : R),
    b ⊑ ITree.bind t f ->
    observe b = RetF r0 ->
    forall t0 : itree E S,
      observe t = TauF t0 ->
      trace_prefixF (upaco2 trace_prefix_ r) (TauF (peel_ (RetF r0) (observe t0))) (RetF r0).
Proof.
  intros E R S r b t f r0 Hrutt Heqb t0 Heqt.
  symmetry in Heqb. symmetry in Heqt.
  apply simpobs in Heqb. apply simpobs in Heqt. rewrite Heqb in Hrutt.
  rewrite Heqt in Hrutt. rewrite tau_eutt in Hrutt.
  apply trace_refine_ret_inv_r in Hrutt. constructor.
  assert (exists s, t0 ≈ Ret s).
  {
    punfold Hrutt. red in Hrutt. dependent induction Hrutt.
    - unfold observe in x. cbn in *. destruct (observe t0) eqn : Ht0; cbn in *; try discriminate.
      exists r1. pfold. red. rewrite Ht0. cbn. auto with itree.
    - unfold observe in x. cbn in *. destruct (observe t0) eqn : Ht0; cbn in *; try discriminate.
      + exists r1. pfold. red. rewrite Ht0. cbn. auto with itree.
      + injection x as Ht1. symmetry in Ht0. apply simpobs in Ht0.
        apply eq_sub_eutt in Ht0 as Ht0'. setoid_rewrite Ht0'.
        setoid_rewrite tau_eutt. eapply IHHrutt; eauto.
        rewrite Ht1. eauto. subst. cbn. unfold ITree.bind. reflexivity.
  }
  destruct H as [s Ht0]. punfold Ht0. red in Ht0. cbn in Ht0.
  clear Heqt Hrutt.
  dependent induction Ht0.
  - rewrite <- x. cbn. punfold Heqb. red in Heqb. cbn in *. inv Heqb; try inv CHECK.
    rewrite H0. auto with itree.
  - rewrite <- x. cbn. constructor. eapply IHHt0; eauto.
Qed.

Lemma trace_prefix_vis_evans: forall (E : Type -> Type) (R S : Type) (r : itrace E S -> itrace E R -> Prop)
                                     (A0 : Type) (ev : E A0) (ans : A0) (k : unit -> itree (EvAns E) R)
                                     (k' : A0 -> itree E S)
                                     (t0 : itree E S) (f : S -> itree E R),
    (forall (a : unit) (b : A0),
        RAnsRef E unit A0 (evans A0 ev ans) a ev b ->
        id
          (upaco2 (rutt_ (REvRef E) (RAnsRef E) eq)
                  bot2) (k a) (ITree.bind (k' b) f)) ->
    (t0 ≈ Vis ev k') ->
    (forall (b : itrace E R) (t : itree E S)
            (f : S -> itree E R),
        b ⊑ ITree.bind t f -> r (peel b t) b) ->
    trace_prefixF (upaco2 trace_prefix_ r)
                  (observe (peel_ (VisF (evans A0 ev ans) k) (observe t0))) (VisF (evans A0 ev ans) k).
Proof.
  intros E R S r A0 ev ans k k' t0 f Hk' Ht0 CIH.
  punfold Ht0. red in Ht0. cbn in *. dependent induction Ht0.
  - rewrite <- x. unfold observe. cbn. unfold peel_vis.
    assert (A0 = A0); auto. destruct (classicT (A0 = A0)); try contradiction.
    unfold eq_rect_r, eq_rect. remember (eq_sym e) as He.
    dependent destruction He. cbn. constructor. right. eapply CIH.
    assert (RAnsRef E unit A0 (evans A0 ev ans) tt ev ans); auto with itree.
    apply Hk' in H0. pclearbot. assert (k1 ans ≈ k' ans); try apply REL.
    rewrite H1. eauto.
  - rewrite <- x. cbn. constructor. eapply IHHt0; eauto.
Qed.

Lemma trace_prefix_vis_evempty: forall (E : Type -> Type) (R S : Type)
                                       (r : itrace E S -> itrace E R -> Prop)
                                       (A0 : Type) (Hempty : A0 -> void) (ev : E A0)
                                       (k : void -> itree (EvAns E) R) (A : Type)
                                       (e0 : E A) (t0 : itree E S) (k' : A -> itree E S),
    eqitF eq true true id
          (upaco2 (eqit_ eq true true id) bot2)
          (observe t0) (VisF e0 k') ->
    trace_prefixF (upaco2 trace_prefix_ r)
                  (observe
                     (peel_ (VisF (evempty A0 Hempty ev) k) (TauF t0)))
                  (VisF (evempty A0 Hempty ev) k).
Proof.
  intros E R S r A0 Hempty ev k A e0 t0 k' Ht0.
  cbn. constructor.
  dependent induction Ht0.
  - rewrite <- x. cbn. constructor.
  - rewrite <- x. cbn. constructor. eapply IHHt0; eauto.
Qed.

Lemma trace_prefix_peel_ret_vis:  forall (E : Type -> Type) (R S : Type)
                                         (r : itrace E S -> itrace E R -> Prop)
                                         (A0 : Type) (ev : E A0) (ans : A0)
                                         (k : unit -> itree (EvAns E) R) (t0 : itree E S)
                                         (s : S),
    t0 ≈ Ret s ->
    trace_prefixF (upaco2 trace_prefix_ r)
                  (observe
                     (peel_ (VisF (evans A0 ev ans) k) (observe t0)))
                  (VisF (evans A0 ev ans) k).
Proof.
  intros E R S r A0 ev ans k t0 s Ht0.
  punfold Ht0. red in Ht0. cbn in *. dependent induction Ht0.
  - rewrite <- x. cbn. remember (go (VisF (evans A0 ev ans) k ) ) as t.
    enough (trace_prefixF (upaco2 trace_prefix_ r) (RetF s) (observe t) ).
    { subst. auto. }
    constructor.
  - rewrite <- x. cbn. constructor. eapply IHHt0; eauto.
Qed.

Lemma trace_prefix_peel_ret_vis_empty: forall (E : Type -> Type) (R S : Type)
                                              (r : itrace E S -> itrace E R -> Prop)
                                              (A0 : Type) (Hempty : A0 -> void) (ev : E A0)
                                              (k : void -> itree (EvAns E) R) (t0 : itree E S)
                                              (s : S),
    t0 ≈ Ret s ->
    trace_prefixF (upaco2 trace_prefix_ r)
                  (observe
                     (peel_ (VisF (evempty A0 Hempty ev) k) (observe t0)))
                  (VisF (evempty A0 Hempty ev) k).
Proof.
  intros E R S r A0 Hempty ev k t0 s Ht0.
  punfold Ht0. red in Ht0. cbn in *. dependent induction Ht0.
  - rewrite <- x. cbn. remember (go (VisF (evempty A0 Hempty ev) k ) ) as t.
    enough (trace_prefixF (upaco2 trace_prefix_ r) (RetF s) (observe t) ).
    { subst. auto. }
    constructor.
  - rewrite <- x. cbn. constructor. eapply IHHt0; eauto.
Qed.

Lemma trace_prefix_peel : forall (E : Type -> Type) (S R : Type) (b : itrace E R) (t : itree E S)
                                 (f : S -> itree E R),
    b ⊑ ITree.bind t f ->
    trace_prefix (peel b t) b.
Proof.
  intros E S R. pcofix CIH. intros b t f Href. pfold. red. unfold peel.
  destruct (observe b) eqn : Heqb; destruct (observe t) eqn : Heqt; cbn.
  - rewrite <- Heqb. auto with itree.
  - eapply trace_prefix_tau_ret; eauto.
  - symmetry in Heqb. symmetry in Heqt. apply simpobs in Heqb. apply simpobs in Heqt.
    rewrite Heqb in Href. rewrite Heqt in Href. rewrite bind_vis in Href.
    pinversion Href.
  - rewrite <- Heqb. auto with itree.
  - constructor. right. eapply CIH. symmetry in Heqb. symmetry in Heqt.
    apply simpobs in Heqb. apply simpobs in Heqt. rewrite Heqb in Href. rewrite Heqt in Href.
    repeat rewrite tau_eutt in Href. eauto.
  - constructor. rewrite <- Heqt. right. eapply CIH.
    symmetry in Heqb. apply simpobs in Heqb. rewrite Heqb in Href.
    rewrite tau_eutt in Href. eauto.
  - destruct e; cbn; rewrite <- Heqb; auto with itree.
  - symmetry in Heqb. apply simpobs in Heqb.
    rewrite Heqb in Href.
    apply trace_refine_vis_l in Href as Hbt. destruct Hbt as [A [e0 [k0 Hvis] ]  ].
    symmetry in Heqt. apply simpobs in Heqt. rewrite Heqt in Hvis.
    rewrite tau_eutt in Hvis.
    assert ((exists B, exists k', exists (e1 : E B) , t0 ≈ Vis e1 k') \/ exists s, t0 ≈ Ret s).
    {
      punfold Hvis. red in Hvis. clear Heqb Heqt.
      dependent induction Hvis.
      - unfold observe in x. cbn in *. destruct (observe t0) eqn : Heqt0; try discriminate.
        + right. exists r0. pfold. red. cbn. rewrite Heqt0. auto with itree.
        + cbn in x. left. exists X0. exists k2. exists e1. symmetry in Heqt0.
          apply simpobs in Heqt0. rewrite Heqt0. reflexivity.
      - unfold observe in x. cbn in *. destruct (observe t0) eqn : Heqt0; try discriminate.
        + right. exists r0. pfold. red. cbn. rewrite Heqt0. auto with itree.
        + injection x as Ht1. symmetry in Heqt0. apply simpobs in Heqt0.
          setoid_rewrite Heqt0. setoid_rewrite tau_eutt. eapply IHHvis; eauto.
          rewrite Ht1. auto.
    }
    destruct H as [ [B [k' [e1 Ht0] ] ] | [s Ht0] ].
    + rewrite Heqt in Href. rewrite tau_eutt in Href.
      rewrite Ht0 in Href. rewrite bind_vis in Href.
      pinversion Href. subst; ddestruction; subst.
      rewrite Ht0 in Hvis. rewrite bind_vis in Hvis. pinversion Hvis.
      subst; ddestruction; subst. clear Heqt Heqb.
      punfold Ht0. red in Ht0. cbn in *.
      destruct e.
      * inv H1. ddestruction; subst. cbn. constructor.
        eapply trace_prefix_vis_evans; eauto with itree.
      * eapply trace_prefix_vis_evempty; eauto.
    + rewrite Heqt in Href. rewrite Ht0 in Href.
      rewrite tau_eutt in Href. rewrite bind_ret_l in Href. clear Hvis.
      destruct e.
      * cbn. constructor. eapply trace_prefix_peel_ret_vis; eauto.
      * cbn. constructor. eapply trace_prefix_peel_ret_vis_empty; eauto.
  - destruct e; cbn; [ | constructor ].
    symmetry in Heqt. apply simpobs in Heqt. rewrite Heqt in Href.
    rewrite bind_vis in Href. symmetry in Heqb. apply simpobs in Heqb.
    rewrite Heqb in Href. pinversion Href. subst; ddestruction; subst.
    inversion H1. ddestruction; subst.
    unfold observe at 1. cbn. unfold peel_vis. assert (A = A); auto.
    destruct (classicT (A = A) ); try contradiction.
    unfold eq_rect_r, eq_rect. remember (eq_sym e) as He.
    dependent destruction He. cbn. constructor. right. eapply CIH.
    ddestruction; subst.
    assert (RAnsRef E unit A (evans A ev ans) tt ev ans ); auto with itree.
    apply H6 in H0. pclearbot. eauto.
Qed.

Lemma peel_bind : forall (E : Type -> Type) (S R : Type) (b : itrace E R) (t : itree E S)
                         (f : S -> itree E R),
    b ⊑ ITree.bind t f -> exists g, (ITree.bind (peel b t) g ≈ b).
Proof.
  intros. apply trace_prefix_bind. eapply trace_prefix_peel; eauto.
Qed.

Lemma peel_lemma : forall E R S (b : itrace E R) (t : itree E S) (f : S -> itree E R),
    (b ⊑ ITree.bind t f) -> trace_prefix (peel b t) b /\ (peel b t ⊑ t).
Proof.
  intros. split; try eapply peel_refine_t; eauto; eapply trace_prefix_peel; eauto.
Qed.

End Peel.

Lemma bind_peel_ret_tau_aux:
  forall (E : Type -> Type) (S R : Type) (f : R -> itree E S)
    (r0 : S) (t0 : itree E R),
    Ret r0 ⊑ ITree.bind t0 f -> exists r : R, t0 ≈ Ret r.
Proof.
  intros E S R f r0 t0 Hrutt.
  punfold Hrutt. red in Hrutt. cbn in *. dependent induction Hrutt.
  - unfold ITree.bind in x. unfold observe in x at 1. cbn in *.
    destruct (observe t0) eqn : Ht0; try discriminate.
    exists r. pfold. red. rewrite Ht0. constructor. auto.
  - unfold observe in x. cbn in x. destruct (observe t0) eqn : Ht0; try discriminate.
    + exists r. pfold. red. rewrite Ht0. constructor. auto.
    + symmetry in Ht0. apply simpobs in Ht0. setoid_rewrite Ht0. setoid_rewrite tau_eutt.
      cbn in x. injection x as Ht2. eapply IHHrutt; auto.
      subst. reflexivity.
Qed.

Lemma decompose_trace_refine_bind : forall (E : Type -> Type) (R S : Type)
                                      (b : itrace E S) (t : itree E R) (f : R -> itree E S),
    b ⊑ t >>= f -> exists b', exists g', (ITree.bind b' g' ≈ b) /\ b' ⊑ t.
Proof.
  destruct classicT_inhabited as [classicT].
  intros. exists (peel classicT b t).
  apply (peel_bind classicT) in H as Heutt. destruct Heutt as [g Heutt].
  exists g. split; auto; eapply (peel_refine_t classicT); apply H.
Qed.

Lemma bind_trigger_refine : forall (E : Type -> Type) (A R : Type) (b : itree (EvAns E) R)
                              (e : E A) (k : A -> itree E R),
    (exists a : A, True) ->
    b ⊑ ITree.bind (ITree.trigger e) k ->
    exists a : A, exists (k' : unit -> itrace E R), b ≈ Vis (evans A e a) k' /\ k' tt ⊑ k a.
Proof.
  intros. rewrite bind_trigger in H0. apply trace_refine_vis in H0 as Hvis.
  destruct Hvis as [X [e' [k' Hbvis] ] ]. setoid_rewrite Hbvis.
  rewrite Hbvis in H0.
  punfold H0. red in H0. cbn in *. inv H0. ddestruction. subst. inv H3; ddestruction; subst.
  - exists a. exists k'. split; try reflexivity. pclearbot.
    assert (RAnsRef E unit A (evans A e a) tt e a ); auto with itree.
    apply H8 in H0. pclearbot. auto.
  - destruct H as [a _]. contradiction.
Qed.


Load loadpath.
Require Import Coq.Lists.List Coq.Arith.EqNat Coq.Arith.Compare_dec
               Coq.ZArith.ZArith.
Require Import veristar.tactics.

Set Implicit Arguments.
Unset Strict Implicit.

Section option.
Variables (A B : Type) (h : A -> B) (f : A -> option B) (o : option A).

Definition omap := match o with Some a => Some (h a) | None => None end.

Definition obnd := match o with Some a => f a | None => None end.

End option.
Implicit Arguments omap [A B].
Implicit Arguments obnd [A B].

Definition isSome {A : Type} (o : option A) :=
  match o with Some _ => true | _ => false end.

Section comp.
Variables (A B C : Type) (g : B -> C) (f : A -> B) (a : A).

Definition compose := g (f a).

End comp.
Implicit Arguments compose [A B C].

(*new notation*)
(*Notation "f \o g" := (compose f g) (at level 54, right associativity).*)

(*for backwards compatibility*)
Infix "oo" := compose (at level 54, right associativity).

(*why does List appear to not export this notation?*)
Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y []) ..).

Fixpoint zip_with_acc {A B : Type} acc (l1 : list A) (l2 : list B) :=
  match l1, l2 with
    | a :: l1', b :: l2' => (a, b) :: zip_with_acc acc l1' l2'
    | _, _ => acc
  end.

Definition zip {A B : Type} := @zip_with_acc A B [].

Section iter.
Variables (A : Type) (f : nat -> A -> A).

Fixpoint iter (n : nat) (a : A) :=
  match n with
    | O => a
    | S n' => iter n' (f n' a)
  end.

End iter.
Implicit Arguments iter [A].

Section tryfind.
Variables (A E B : Type) (f : A -> E + B).

Fixpoint tryfind (err : E) (l : list A) :=
  match l with
    | nil => inl _ err
    | a :: l' => match f a with
                   | inl err' => tryfind err' l'
                   | inr success as r => r
                 end
  end.

End tryfind.

Definition max (n m : nat) := if leb n m then m else n.

Definition maxs (l : list nat) := fold_left (fun m n => max m n) l 0.

Definition elemb (n : nat) := existsb (fun m => beq_nat n m).

(*positive lemmas*)

Require Import ZArith.

Lemma Ppred_decrease n : (n<>1)%positive -> (nat_of_P (Ppred n)<nat_of_P n)%nat.
Proof.
intros; destruct (Psucc_pred n) as [Hpred | Hpred]; try contradiction;
  pattern n at 2; rewrite <- Hpred; rewrite nat_of_P_succ_morphism; omega.
Defined.

Ltac Ppred_tac n :=
  apply Ppred_decrease; destruct n;
  let H := fresh "H" in intro H; try (inversion H||inversion H1); congruence.

Definition Pleb (x y : positive) :=
  match Pcompare x y Eq with
    | Lt => true
    | Eq => true
    | Gt => false
  end.

Lemma Pleb_Ple (x y : positive) : Pleb x y = true <-> Ple x y.
Proof.
unfold Pleb, Ple; split; intro H1.
intro H2; done(rewrite H2 in H1).
done(remember ((x ?= y)%positive Eq) as b; destruct b).
Qed.

(* N lemmas *)

Require Import NArith NOrderedType.

Definition Nleb (x y : N) :=
  match Ncompare x y with
    | Lt => true
    | Eq => true
    | Gt => false
  end.

Lemma Nleb_Nle (x y : N) : Nleb x y = true <-> Nle x y.
Proof.
unfold Nleb, Nle; split; intro H1.
intro H2; done(rewrite H2 in H1).
done(remember ((x ?= y)%N) as b; destruct b).
Qed.

(*reverse comparison*)

Section revc.
Variables (A : Type) (c : A -> A -> comparison).

Definition revc a1 a2 :=
  match c a1 a2 with
    | Gt => Lt
    | Eq => Eq
    | Lt => Gt
  end.

End revc.

Inductive ret_kind (val : Type) : Type :=
| Success : val -> ret_kind val
| Failure : ret_kind val.

Implicit Arguments Success [val].
Implicit Arguments Failure [val].


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B X Y P Q R Qprime : Universe, ((wd_ A B /\ (wd_ X Y /\ (wd_ Q Qprime /\ (wd_ P Q /\ (wd_ R Q /\ (wd_ P Qprime /\ (wd_ R Qprime /\ (wd_ B Q /\ (wd_ A Q /\ (wd_ P R /\ (col_ A B P /\ (col_ A B Qprime /\ (col_ A B R /\ (col_ P Qprime R /\ col_ P Q R)))))))))))))) -> col_ A P R)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.Sets.Ensembles.
Require Import Coq.Sets.Finite_sets.
Require Import Coq.Arith.Arith.
Require Import Coq.Lists.List.
Require Import Coq.Logic.ProofIrrelevance.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import CertiGraph.Coqlib.
Require Import CertiGraph.graph.graph.
Require Import CertiGraph.graph.graph_reachable.

Definition GraphPredicate {N D DEC} (g : @PreGraph N D DEC) :=
  {p : Ensemble D & forall x, {Ensembles.In D p x} + {~ Ensembles.In D p x}}.

Definition negateP {N D DEC} {g: @PreGraph N D DEC} (p : GraphPredicate g) : GraphPredicate g.
Proof.
  exists (Complement D (projT1 p)).
  intros. destruct p. simpl in *. unfold Complement.
  destruct (s x); [right | left]; auto.
Defined.

Definition app_graph_predicate {N D DEC} (g : @PreGraph N D DEC) (p : GraphPredicate g) (v : D) := projT1 p v.

Coercion app_graph_predicate : GraphPredicate >-> Funclass.

Lemma negateP_spec {N D DEC} {g : @PreGraph N D DEC}: forall (p: GraphPredicate g) (x : D), (negateP p) x <-> ~ p x.
Proof. intros; unfold negateP; simpl; unfold Complement; tauto. Qed.

Lemma negateP_spec_d {N D DEC} {g : @PreGraph N D DEC}:
  forall (p: GraphPredicate g) (x : D), ~ Ensembles.In D (projT1 (negateP p)) x <-> p x.
Proof.
  intros. unfold negateP. simpl. unfold Complement.
  destruct p; simpl. split; intros; destruct (s x); try tauto.
  intro. hnf in H0. tauto.
Qed.

Definition predicate_valid {N D DEC} (g : @PreGraph N D DEC) (p : GraphPredicate g) : N -> Prop :=
  fun n => valid n /\ p (node_label n).

Definition predicate_edge_func {N D DEC} (g : @PreGraph N D DEC) (p : GraphPredicate g) (x: N) : list N :=
  filter (fun s => if ((projT2 p) (node_label s)) then true else false) (edge_func x).

Definition predicate_subgraph {N D DEC} (g : @PreGraph N D DEC) (p : GraphPredicate g) : PreGraph N D :=
  Build_PreGraph N D DEC (predicate_valid g p) node_label (predicate_edge_func g p).

Definition predicate_sub_mathgraph {N D DEC} {g : @PreGraph N D DEC} {nV : N}
           (mg: MathGraph g nV) (p : GraphPredicate g) : MathGraph (predicate_subgraph g p) nV.
Proof.
  refine (Build_MathGraph N D DEC _ nV _ _); intros.
  + destruct (t_eq_dec y nV).
    - trivial.
    - unfold edge_func in H0.
      unfold predicate_subgraph in H0.
      unfold predicate_edge_func in H0.
      rewrite filter_In in H0. destruct H0.
      destruct (projT2 p (node_label y)) eqn:? . 2: inversion H1.
      destruct H. split.
      * apply (valid_graph x H y) in H0. hnf in H0. destruct (t_eq_dec y nV). exfalso; auto. auto.
      * hnf in i. hnf. auto.
  + destruct H. apply valid_not_null. auto.
Defined.

Lemma reachable_by_eq_subgraph_reachable {N D DEC}:
  forall (g : @PreGraph N D DEC) (p : GraphPredicate g) (n1 n2: N),
    g |= n1 ~o~> n2 satisfying p <-> reachable (predicate_subgraph g p) n1 n2.
Proof.
  intros; split; intros; destruct H as [path [? [? ?]]]; exists path.
  + split; auto. split. 2: repeat intro; hnf; auto.
    (* destruct path. simpl; auto. *)
    clear H.
    destruct path. simpl; auto.
    revert n H0 H1. induction path; intros.
    - simpl in *. unfold predicate_valid. split; auto.
      hnf in H1. unfold node_prop in H1. apply H1. apply in_eq.
    - specialize (IHpath a). simpl in *. destruct H0. split.
      * hnf in H. destruct H as [? [? ?]]. hnf.
        unfold valid. unfold edge_func.
        unfold predicate_subgraph.
        unfold predicate_valid. unfold predicate_edge_func.
        hnf in H1. unfold node_prop in H1.
        split. split; auto. apply H1. apply in_eq.
        split. split; auto. apply H1. apply in_cons, in_eq.
        rewrite filter_In. split; auto. destruct (projT2 p (node_label a)). auto.
        exfalso; apply n0. hnf. apply H1. apply in_cons, in_eq.
      * apply IHpath. apply H0. hnf in H1. hnf; intros. apply H1.
        apply in_cons. auto.
  + split; auto. split.
    - clear H H1. destruct path. simpl; auto.
      revert n H0. induction path; intros; simpl in *.
      * destruct H0; auto.
      * destruct H0. split. hnf in H.
        destruct H as [[? ?] [[? ?] ?]].
        split; auto. split; auto. unfold edge_func in H4.
        unfold predicate_subgraph in H4.
        unfold predicate_edge_func in H4.
        rewrite filter_In in H4. destruct H4. auto.
        apply IHpath. apply H0.
    - clear H H1. destruct path. hnf; intros. inversion H.
      revert n H0. induction path; intros.
      * hnf. intros. simpl in H. destruct H. 2: exfalso; auto. subst.
        destruct H0. hnf. hnf in H0. auto.
      * unfold path_prop in *. rewrite <- Forall_forall in *.
        apply Forall_cons. destruct H0. hnf in H. destruct H as [[? ?] _].
        hnf in H1. hnf. auto. rewrite Forall_forall.
        apply IHpath. simpl in *. destruct H0. apply H0.
Qed.

Lemma reachable_decidable {N D DEC} {g : @PreGraph N D DEC}:
  forall (null : N) (mg : MathGraph g null) x l, valid x -> (forall y, reachable g x y -> In y l) ->
                                                 forall y, {reachable g x y} + {~ reachable g x y}.
Proof.
  intros. destruct (finite_reachable_computable mg x l H H0) as [l' [? ?]]. specialize (H1 y).
  destruct (in_dec t_eq_dec y l').
  + rewrite H1 in i. left; auto.
  + rewrite H1 in n. right; auto.
Qed.

Lemma reachable_by_decidable {N D DEC} {g : @PreGraph N D DEC}:
  forall (null : N) (mg : MathGraph g null) (p : GraphPredicate g) x l ,
    valid x -> (forall y, reachable g x y -> In y l) -> p (node_label x) ->
    forall y, {g |= x ~o~> y satisfying p} + {~ g |= x ~o~> y satisfying p}.
Proof.
  intros. remember (predicate_subgraph g p) as pdg.
  assert (@valid _ _ _ pdg x) by (subst; split; auto).
  assert (forall y, reachable pdg x y -> In y l). {
    subst. intro z. intros. apply H0.
    rewrite <- reachable_by_eq_subgraph_reachable in H3.
    apply reachable_by_is_reachable in H3. auto.
  } subst.
  destruct (reachable_decidable null (predicate_sub_mathgraph mg p) x l H2 H3 y).
  rewrite <- reachable_by_eq_subgraph_reachable in r. left; auto.
  rewrite <- reachable_by_eq_subgraph_reachable in n. right; auto.
Qed.

Lemma mark_exists: forall {N D DEC} (g: @PreGraph N D DEC) (marked: GraphPredicate g) (null: N) (mg: MathGraph g null) x v l,
                   valid x -> (forall y, reachable g x y -> In y l) -> marked v -> exists g', mark marked g x g'.
Proof.
  intros. destruct ((projT2 (negateP marked)) (node_label x)).
  + remember (fun (n : N) => if (reachable_by_decidable null mg (negateP marked) x l H H0 i n) then v else (node_label n)) as f.
    exists (Build_PreGraph N D DEC valid f edge_func). split.
    - split; tauto.
    - split; intros; subst; hnf; unfold node_label;
      destruct (reachable_by_decidable null mg (negateP marked) x l H H0 i n); tauto.
  + rewrite negateP_spec_d in n. exists g. split. reflexivity. split; intros.
    - destruct H2 as [path ?]. apply (reachable_by_path_In_prop _ _ _ _ _ _ _ _ x) in H2.
      hnf in H2. tauto. destruct H2 as [[? _] _]. destruct path; simpl in H2; inversion H2. apply in_eq.
    - auto.
Qed.

Lemma mark1_exists: forall {N D DEC} (g: @PreGraph N D DEC) (marked: GraphPredicate g) x v,
                      marked v -> valid x -> exists g', mark1 marked g x g'.
Proof.
  intros. destruct ((projT2 marked) (node_label x)).
  + exists g. split. reflexivity. auto.
  + remember (fun (t : N) => if (t_eq_dec t x) then v else (node_label t)) as f.
    exists (Build_PreGraph N D DEC valid f edge_func). split.
    * split; tauto.
    * subst. split; auto. split; intros; hnf; unfold node_label.
      destruct (t_eq_dec x x). auto. tauto.
      destruct (t_eq_dec n' x). exfalso; intuition. auto.
Qed.

Lemma subgraph_exists: forall {N D DEC} (marked: Ensemble D) (g: @PreGraph N D DEC) x,
  exists g', subgraph g x g'.
Proof.
  intros.
  exists (reachable_subgraph g (x :: nil)).
  reflexivity.
Qed.

Lemma reachable_mark1: forall {N D DEC} (marked: Ensemble D) (g g': @PreGraph N D DEC) x y z,
                         mark1 marked g x g' -> (reachable g y z <-> reachable g' y z).
Proof. intros. destruct H as [? _]. split; [| symmetry in H ]; apply si_reachable with (n := y) in H; apply H. Qed.

Lemma reachable_mark: forall {N} {D} {DEC} (marked: Ensemble D) (g g':  @PreGraph N D DEC) x y z,
                        mark marked g x g' -> (reachable g y z <-> reachable g' y z).
Proof. intros. destruct H as [? _]. split; [| symmetry in H ]; apply si_reachable with (n := y) in H; apply H. Qed.


From st.STLCmu Require Import lang typing types contexts.
From st.STLCmuST Require Import lang types typing contexts.
From st.embedding Require Import types.
From st.end_to_end Require Import embedding_STLCmu_STLCmuST pres_ctx_equiv refl_ctx_equiv_help.

Theorem reflection_equiv (Γ : list STLCmu.types.type) e1 e2 (τ : STLCmu.types.type) :
  STLCmuST_equiv (fmap embed Γ) (embd_expr e1) (embd_expr e2) (embed τ) →
  STLCmu_equiv Γ e1 e2 τ.
Proof.
  (* admin *)
  intros (pΓ & pτ & de1 & de2 & H).
  assert (de1' : Γ ⊢ₙₒ e1 : τ). by apply embd_expr_typed_inv.
  assert (de2' : Γ ⊢ₙₒ e2 : τ). by apply embd_expr_typed_inv.
  do 4 try split; auto.
  pose proof (iffLR (Forall_fmap _ _ _) pΓ). eapply Forall_impl; eauto.
  simpl. intros. by apply embed_Closed_n_inv. by apply embed_Closed_n_inv.
  (* okay *)
  intros C dC.
  assert (dC' : typed_ctx (embd_ctx C) (embed <$> Γ) [|τ|] [] TUnit).
  { change [] with (embed <$> []).
    change TUnit with (embed STLCmu.types.TUnit).
    rewrite -boring.comp_embeddings_ctx.
    by apply contexts.embd_ctx_typed, boring.embd_ctx_typed.
  }
  specialize (H (embd_ctx C) dC').
  split; intro halts.
  - apply embd_expr_halts_iff; first by eapply STLCmu.contexts.typed_ctx_typed; eauto.
    rewrite -comm_fill_ctx_embd.
    apply H.
    rewrite comm_fill_ctx_embd.
    by apply embd_expr_halts_iff; first by eapply STLCmu.contexts.typed_ctx_typed; eauto.
  - apply embd_expr_halts_iff; first by eapply STLCmu.contexts.typed_ctx_typed; eauto.
    rewrite -comm_fill_ctx_embd.
    apply H.
    rewrite comm_fill_ctx_embd.
    by apply embd_expr_halts_iff; first by eapply STLCmu.contexts.typed_ctx_typed; eauto.
Qed.


(*|
######################################################
How do you prove in Coq that ``(e: p = p) = eq_refl``?
######################################################

:Link: https://stackoverflow.com/q/60665385
|*)

(*|
Question
********

I am trying to prove this:
|*)

Lemma eq_eq: forall (U: Type) (p: U) (eqv: p = p), eq_refl = eqv.
Abort. (* .none *)

(*|
But there just seems to be no way to do it. The problem is the type
``p = p`` being an equality on the same term, and then trying to match
its instance. If this were not the case, it is easy enough to prove
that a term of a type with a single constructor is equal to that
constructor.
|*)

Lemma eq_tt: forall (U: Type) (x: unit), tt = x.
Proof fun (U: Type) (x: unit) =>
        match x as x' return tt = x' with
          tt => eq_refl
        end.

(*| But when you try the same strategy on my problem, it fails. |*)

Lemma eq_eq: forall (U: Type) (p: U) (eqv: p = p), eq_refl = eqv.
  Fail Proof fun (U: Type) (p: U) (eqv: p = p) =>
               match eqv as e in _ = p' return eq_refl = e with
                 eq_refl => eq_refl
               end. (* .unfold .fails *)

(*|
The problem is that the ``return`` clause here translates internally
to a predicate function something like this:

.. code-block:: coq

    fun (p': U) (e: p = p') => eq_refl = e

which fails to typecheck because we have now lost the constraint
between the 2 terms in ``e``'s equality and ``eq_refl`` requires that
constraint.

Is there any way around this problem? Am I missing something?
|*)

(*|
Answer
******

Your proposed lemma is precisely the statement of `uniqueness of
identity proofs (UIP) <https://ncatlab.org/nlab/show/axiom+UIP>`__. It
was first proven that the negation of UIP is consistent in MLTT with
`Hofmann and Streicher's groupoid model
<https://www.tcs.ifi.lmu.de/mitarbeiter/martin-hofmann/pdfs/agroupoidinterpretationoftypetheroy.pdf>`__
(pdf link). In this model, types are interpreted as groupoids, where
the identity type ``x = y`` is the set of morphisms from ``x`` to
``y`` in the groupoid. In this model, there can be more than one
distinct ``e: x = y``.

More recently, `homotopy type theory
<https://ncatlab.org/nlab/show/homotopy+type+theory>`__ has embraced
this point of view. Rather than mere groupoids, types are interpreted
as ∞-groupoids, with not only the possibility of multiple equalities
between ``x`` and ``y``, but also possibly multiple identities between
identities ``p q: x = y``, etc.

Suffice to say, your lemma isn't provable without an extra axiom such
as UIP mentioned above or `Axiom K
<https://ncatlab.org/nlab/show/axiom+K+%28type+theory%29>`__.
|*)


From RelationAlgebra Require Import lattice monoid rel kat_tac kleene.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype choice seq path.
From mathcomp Require Import order finmap fintype ssrnat finfun.
From eventstruct Require Import utils rel_algebra rewriting_system.
From eventstruct Require Import inhtype ident porf_eventstruct.

(******************************************************************************)
(* Here we want to make function that by event and event structure creates a  *)
(* new event structure with added event. Then we want to describe behavior of *)
(* ca, cf, ... on new structure in terms of ca, cf, ... on old one. Finally   *)
(* we want to prove that if our structure is consistent, and we are adding    *)
(* the element that is not conflicting with his predecessors, then our new    *)
(* structure is going to be consistent, too.                                  *)
(*                                                                            *)
(* This file contains the definitions of:                                     *)
(*         add_label == special record with all necessary information about   *)
(*                   event that we want to add to a porf_eventstruct          *)
(*         add_event es al == function that takes porf_eventstruct            *)
(*                   and record add_label with event we want to add and       *)
(*                   returns new porf_eventstruct with added element          *)
(*         'function'_add_eventE == lemma that determines behavior of         *)
(*                   'function' on the new event structure with added element *)
(*                    in terms of 'function' on event structure without one   *)
(*         consist_add_event == statement about consistence of our new        *)
(*                    structure                                               *)
(*         tr_add_event e1 e2 == we can add some event to e1 and obtain e2    *)
(*         ltr_add_event e1 al e2 == we can add al to e1 and obtain e2        *)
(*         add_label_of_nread == takes non-read label and predecessor and     *)
(*                    returns corresponding add_label structure               *)
(*         rf_ncf_nread == lemma that ensures event structures obtained by    *)
(*                         add_label_of_nread is prime                        *)
(*         contain al es == checks if event that we want to add (al) is       *)
(*                    already in es                                           *)
(*         add_new_event == adding a new event to the event structure if it   *)
(*                    is not contained there                                  *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import Order.LTheory.

Local Open Scope rel_scope.
Local Open Scope order_scope.
Local Open Scope fset_scope.
Local Open Scope ident_scope.

Import Label.Syntax.

Arguments dom0 {_ _ _}.

Section TransitionSystem.

Context (E : identType) (Lab : labType).

Notation porf_eventstruct := (@porf_eventstruct E Lab).
Notation prime_porf_eventstruct := (@prime_porf_eventstruct E Lab).

Notation label := (Lab).

Implicit Types (x : Loc) (es : porf_eventstruct).

(* Section with definitions for execution graph with added event *)
Section AddEvent.

(* execution graph in which we want to add l *)
Context (es : porf_eventstruct).

Notation dom  := (dom es).
Notation ffed := (fed es).
Notation flab := (lab es).
Notation ffpo := (fpo es).
Notation ffrf := (frf es).

Notation fresh_id := (fresh_seq dom).

Structure add_label := Add {
  add_lb         : Lab;
  add_po         : E;
  add_rf         : E;

  add_po_in_dom  : add_po \in dom;
  add_rf_in_dom  : add_rf \in dom;
  add_po_consist : flab add_po (po)>> add_lb;
  add_rf_consist : flab add_rf (rf)>> add_lb;
}.

Coercion of_add_label := fun
  '(Add l p w _ _ _ _) => mk_edescr l p w.

Lemma of_add_label_inj : injective of_add_label.
Proof.
  case=> ??? ++++ [??? ++++ [le pe we]].
  move: le pe we; (do ? case :_ /)=> *; congr Add; exact/eq_irrelevance.
Qed.

Variable al : add_label.

(* label of an event to add *)
Notation lb := (add_lb al).

(* predecessor of the new event (if it exists) *)
Notation pred := (add_po al).

(* if our event is `Read` then we should provide the corresponding `Write`
   event *)
Notation write := (add_rf al).

Lemma po_fresh_id : pred <^i fresh_id.
Proof. by move/add_po_in_dom/fresh_seq_mem: al. Qed.

Lemma rf_fresh_id : write <^i fresh_id.
Proof. by move/add_rf_in_dom/fresh_seq_mem: al. Qed.

Definition contain :=
  has (fun e => (flab e == lb) && (ffrf e == write) && (ffpo e == pred)) dom.

Definition add_fed :=
  [ fsfun ffed with fresh_id |->
                    {| lab_prj := lb; fpo_prj := pred; frf_prj := write |} ].

Definition add_lab := fun e : E => lab_prj (add_fed e).
Definition add_fpo := fun e : E => fpo_prj (add_fed e).
Definition add_frf := fun e : E => frf_prj (add_fed e).

Lemma add_fedE e :
  add_fed e = if e == fresh_id then mk_edescr lb pred write else fed es e.
Proof. by rewrite /= fsfun_withE /=; case: ifP. Qed.

Lemma add_labE e :
  add_lab e = if e == fresh_id then lb else lab es e.
Proof. by rewrite /add_lab /add_fed /= fsfun_withE /=; case: ifP. Qed.

Lemma add_fpoE e :
  add_fpo e = if e == fresh_id then pred else fpo es e.
Proof. by rewrite /add_fpo /add_fed /= fsfun_withE /=; case: ifP. Qed.

Lemma add_frfE e :
  add_frf e = if e == fresh_id then write else frf es e.
Proof. by rewrite /add_frf /add_fed /= fsfun_withE; case: ifP. Qed.

Fact add_fed_finsupp : finsupp add_fed == (seq_fset tt (fresh_id :: dom)).
Proof.
  apply/fset_eqP=> x; rewrite ?inE seq_fsetE finsupp_with.
  case: ifP; rewrite ?inE fed_supp //.
  move: po_fresh_id=> /[swap]/eqP[?->]; by rewrite ltxx.
Qed.

Lemma add_fed0 :
  add_fed ident0 = {| lab_prj := \init; fpo_prj := ident0; frf_prj := ident0 |}.
Proof.
  rewrite add_fedE lt_eqF; first exact/fed0.
  exact/fresh_seq_mem/dom0.
Qed.

Fact add_fpo_dom :
  [forall e : finsupp add_fed, add_fpo (val e) \in fresh_id :: dom].
Proof.
  apply/forallP=> [[/= x]].
  rewrite (eqP add_fed_finsupp) ?inE seq_fsetE ?inE /add_fpo fsfun_withE.
  case: (x =P fresh_id) => /=; first by rewrite (add_po_in_dom al).
  by move=> ? /fpo_dom->.
Qed.

Fact add_frf_dom :
  [forall e : finsupp add_fed, add_frf (val e) \in fresh_id :: dom].
Proof.
  apply/forallP=> [[/= x]].
  rewrite (eqP add_fed_finsupp) ?inE seq_fsetE ?inE /add_frf fsfun_withE.
  case: (x =P fresh_id)=> /=; first by rewrite (add_rf_in_dom al).
  by move=> ? /frf_dom->.
Qed.

Fact add_fpo_le :
  [forall e : finsupp add_fed, (val e != \i0) ==> (add_fpo (val e) <^i val e)].
Proof.
  apply/forallP=> [[/=]] e.
  rewrite (eqP add_fed_finsupp) ?inE seq_fsetE ?inE.
  rewrite add_fpoE; case: ifP=> /= [/eqP-> _|?].
  - by rewrite po_fresh_id implybT.
  by move/fpo_n0/implyP.
Qed.

Fact add_frf_le :
  [forall e : finsupp add_fed, (val e != \i0) ==> (add_frf (val e) <^i val e)].
Proof.
  apply/forallP=> [[/=]] e.
  rewrite (eqP add_fed_finsupp) ?inE seq_fsetE ?inE.
  rewrite add_frfE; case: ifP=> /= [/eqP-> _|?].
  - by rewrite rf_fresh_id implybT.
  by move/frf_n0/implyP.
Qed.

Fact add_frf_sync :
  [forall e : finsupp add_fed, add_lab (add_frf (val e)) (rf)>> add_lab (val e)].
Proof.
  apply/forallP=> [[/=]] e.
  rewrite (eqP add_fed_finsupp) ?inE seq_fsetE ?inE.
  rewrite !add_labE !add_frfE.
  case: (e =P fresh_id)=> /= [|? /frf_dom /fresh_seq_mem /lt_eqF->].
  - by rewrite (lt_eqF rf_fresh_id) (add_rf_consist al).
  exact/frf_sync.
Qed.

Fact add_fpo_sync :
  [forall e : finsupp add_fed, add_lab (add_fpo (val e)) (po)>> add_lab (val e)].
Proof.
  apply/forallP=> [[/=]] e.
  rewrite (eqP add_fed_finsupp) ?inE seq_fsetE ?inE.
  rewrite !add_labE !add_fpoE.
  case: (e =P fresh_id)=> /= [|? /fpo_dom /fresh_seq_mem /lt_eqF->].
  - by rewrite (lt_eqF po_fresh_id) (add_po_consist al).
  exact/fpo_sync.
Qed.

Lemma nfresh_dom0 :
  \i0 \in fresh_id :: dom.
Proof. by rewrite ?inE dom0. Qed.

Definition add_event :=
  @Pack _ _
        (fresh_id :: dom)
        add_fed
        add_fed_finsupp
        nfresh_dom0
        add_fed0
        add_fpo_dom
        add_frf_dom
        add_fpo_le
        add_frf_le
        add_fpo_sync
        add_frf_sync.

Definition add_new_event := if contain then es else add_event.

Hypothesis rf_ncf_dom_  : rf_ncf_dom es.
(* Hypothesis rf_ncf_fresh : ~~ (cf add_event fresh_id write). *)

Import Relation_Operators.

(* TODO: remove duplicate lemmas `add_fedE`, `add_labE`, etc *)

Lemma fed_add_eventE e :
  fed add_event e = if e == fresh_id then mk_edescr lb pred write else fed es e.
Proof. exact: add_fedE. Qed.

Lemma lab_add_eventE e :
  lab add_event e = if e == fresh_id then lb else lab es e.
Proof. exact: add_labE. Qed.

Lemma fpo_add_eventE e :
  fpo add_event e = if e == fresh_id then pred else fpo es e.
Proof. exact: add_fpoE. Qed.

Lemma frf_add_eventE e :
  frf add_event e = if e == fresh_id then write else frf es e.
Proof. exact: add_frfE. Qed.

Lemma ica_add_eventE e1 e2 :
  ica add_event e1 e2 =
  if e2 == fresh_id then
    (pred == e1) || (write == e1)
  else ica es e1 e2.
Proof.
  rewrite icaE /= /fca frf_add_eventE fpo_add_eventE.
  case: ifP=> ?; rewrite ?(andTb, andFb) ?orbF // ?inE.
  by rewrite eq_sym orbC eq_sym orbC.
Qed.

Lemma ca_add_eventE e1 e2 :
  e2 != fresh_id -> ca es e1 e2 = ca add_event e1 e2.
Proof.
  move=> N.
  apply/closure_n1P/closure_n1P; move: N=> /[swap]; elim; try constructor.
  all: move=> y ? I ? H /negbTE Z; apply: (@rtn1_trans _ _ _ y).
  2,4: apply/H/negP; move: I.
  - by rewrite ica_add_eventE Z.
  - move/[swap]/eqP=>->/ica_fresh Ez.
    by move/eqP: Z Ez.
  - rewrite ica_add_eventE Z=> /[swap]/eqP->/ica_fresh.
    by move/eqP: Z.
  move: I; by rewrite ica_add_eventE Z.
Qed.

Lemma icf_add_eventE e1 e2 :
  e1 != fresh_id -> e2 != fresh_id ->
  icf es e1 e2 = icf add_event e1 e2.
Proof.
  rewrite /icf !fpo_add_eventE lab_add_eventE=> /[dup] N /negbTE->/negbTE->.
  case: ifP=> //; case: (boolP (e1 \in dom))=> [|/fpo_ndom-> /(negP N)//].
  by move/fpo_dom/fresh_seq_mem/lt_eqF->.
Qed.

Lemma cf_add_eventE e1 e2 :
  e1 != fresh_id -> e2 != fresh_id ->
  cf es e1 e2 = cf add_event e1 e2.
Proof.
  move=> /[dup] /ca_fresh_contra Cnf1 Nf1 /[dup] /ca_fresh_contra Cnf2 Nf2.
  apply/cfP/cfP=> -[x [y C]]; exists x, y; move: C; rewrite -?ca_add_eventE //.
  - move=> [] ??; rewrite -icf_add_eventE //;
      [by rewrite Cnf1 | by rewrite Cnf2].
  move=> [] ??; rewrite icf_add_eventE //; first by rewrite Cnf1 ?C.
  by rewrite Cnf2 ?C.
Qed.

Lemma rf_ncf_add_event :
  ~~ (cf add_event fresh_id write) <-> rf_ncf_dom add_event.
Proof.
  split=> [? |].
  - rewrite /rf_ncf_dom; apply /allP=> e1.
    rewrite /frf /= fsfun_withE ?inE.
    case: ifP=> /= [/eqP-> _|/negbT N /(allP rf_ncf_dom_)] //; first exact/implyP.
    rewrite -cf_add_eventE //.
    apply/negP=> /eqP Ef.
    have /ica_fresh /eqP /(negP N) //: ica es fresh_id e1.
    by rewrite icaE /= ?inE -Ef eq_refl.
  case: (boolP (write == fresh_id))=> [/eqP<- /cf_irrelf/(_ write)->|?] //.
  move/allP/(_ fresh_id)=> /=; rewrite frf_add_eventE inE eq_refl /=.
  move/(_ erefl)/implyP; exact.
Qed.

(* Lemma rf_ncf_add_new_event :
  ~~ (cf add_event fresh_id write) -> rf_ncf_dom add_new_event.
Proof. rewrite /add_new_event; case: ifP=>// _; exact/rf_ncf_add_event. Qed. *)

End AddEvent.

(*Section NreadPrime.

Context (pes : prime_porf_eventstruct) (pr : E) (l : label).

Notation domain := (dom pes).
Notation fresh_id := (fresh_seq domain).

Hypothesis pr_mem : pr \in domain.
Hypothesis nr     : ~~ Label.is_read l.

Fact add_nread_synch : lab pes ident0 \>> l.
Proof.
  rewrite lab0 /Label.synch.
  case H: l=> //; symmetry; apply/contraPF.
  - move=> x; apply/negP; exact/nr.
  by rewrite /Label.is_read H.
Qed.

Let add_label_nread := Add pr_mem dom0 add_nread_synch.

Lemma rf_ncf_nread :
   rf_ncf_dom (add_event add_label_nread).
Proof. apply/rf_ncf_add_event=> //=; first (by case: pes); exact/cf0. Qed.

Lemma rf_ncf_new_nread :
  rf_ncf_dom (add_new_event add_label_nread).
Proof.
  rewrite /add_new_event; case: ifP=> // _.
  - by case pes.
  by rewrite ?rf_ncf_nread //.
Qed.

End NreadPrime.*)

End TransitionSystem.

Module AddEvent.

Section Confluence.

Context (E : identType) (Lab : labType).

Notation porf_eventstruct := (@porf_eventstruct E Lab).
Notation prime_porf_eventstruct := (@prime_porf_eventstruct E Lab).

Notation label := Lab.

Implicit Types (x : Loc) (es : porf_eventstruct).

Definition tr es1 es2 := exists al, es2 = @add_event _ Lab es1 al.

Notation "es1 '~>' es2" := (tr es1 es2) (at level 0).

Definition ltr (ed : edescr E label) es1 es2 :=
  exists2 al, es2 = @add_event _ Lab es1 al & ed = al.

Notation "es1 '~(' l ')~>' es2" := (ltr l es1 es2) (at level 0).

Section Equivalence.

Section IsoDef.

Context (f : E -> E) (es1 es2 : porf_eventstruct).

Definition is_morph := fed es2 \o f =1 (edescr_map f) \o fed es1.

Section Morphism.

Hypothesis morph: is_morph.

Lemma is_morph_lab e :
   lab es1 e = lab es2 (f e).
Proof.
  move/(congr1 (@lab_prj _ _)): (morph e).
  by rewrite /lab /=; case: (fed es1 e).
Qed.

Lemma is_morph_po e :
  f (fpo es1 e) = fpo es2 (f e).
Proof.
  move/(congr1 (@fpo_prj _ _)): (morph e).
  by rewrite fpo_prj_edescr_map.
Qed.

Lemma is_morph_rf e :
  f (frf es1 e) = frf es2 (f e).
Proof.
  move/(congr1 (@frf_prj _ _)): (morph e).
  by rewrite frf_prj_edescr_map.
Qed.

Lemma is_morph_ica e1 e2 :
  ica es1 e1 e2 -> ica es2 (f e1) (f e2).
Proof.
  rewrite ?icaE /fca /= ?inE -is_morph_po -is_morph_rf=> /orP[]/eqP->;
  by rewrite eq_refl.
Qed.

Lemma is_morph_ca e1 e2 :
  ca es1 e1 e2 -> ca es2 (f e1) (f e2).
Proof.
  move/closure_n1P; elim=> [|??/is_morph_ica I ?]; first exact/ca_refl.
  move/closure_n1P=> ?; apply/closure_n1P.
  by apply/Relation_Operators.rtn1_trans; first by exact/I.
Qed.

End Morphism.

Definition is_iso := is_morph /\ bijective f.

Section IsoMorphism.

Hypothesis iso : is_iso.

Lemma iso_dom : map f (dom es1) =i dom es2.
Proof.
  case: iso=> l /[dup] B [g /[dup] c1 /can_inj I c2 x].
  rewrite -[x]c2 (mem_map I) -?fed_supp_mem !mem_finsupp.
  move: (l (g x))=> /= ->.
  rewrite -[_ _ (f _) _]/(edescr_map f (mk_edescr _ _ _)).
  by rewrite (bij_eq (@edescr_map_bij label E E _ B)).
Qed.

Lemma f_icf e1 e2 :
  icf es1 e1 e2 -> icf es2 (f e1) (f e2).
Proof.
  case: iso=> ??.
  rewrite/icf ?lt_neqAle ?fpo_le ?andbT.
  by rewrite ?is_morph_lab -?is_morph_po ?(bij_eq (f := f)).
Qed.

Lemma f_cf e1 e2 :
  es1 |- e1 # e2 -> es2 |- (f e1) # (f e2).
Proof.
  case: iso=> ?? /cfP [x [y [*]]]; apply/cfP; exists (f x), (f y).
  by rewrite ?is_morph_ca ?f_icf.
Qed.

End IsoMorphism.

End IsoDef.

Lemma is_iso_can es1 es2 f g :
  is_iso f es1 es2 -> cancel f g -> cancel g f ->
  is_iso g es2 es1.
Proof.
  move=> [l b c1 c2].
  have B: bijective g by apply/(bij_can_bij b).
  split=> //; do ? split; try move=> x /=.
  apply/(bij_inj (@edescr_map_bij label _ _ _ b)).
  move: (l (g x))=> /= <-.
  by rewrite ?(edescr_map_can c2) c2.
Qed.

Lemma isoE f e1 e2 es1 es2: is_iso f es1 es2 ->
  (
    (lab es1 e1 = lab es2 (f e1)) *
    ((f (fpo es1 e1) = fpo es2 (f e1)) *
    (f (frf es1 e1) = frf es2 (f e1))) *
    ((ca es1 e1 e2 = ca es2 (f e1) (f e2)) *
    (cf es1 e1 e2 = cf es2 (f e1) (f e2)))
  )%type.
Proof.
  move=> /[dup] If [M []? /[dup] c /(is_iso_can If) /[apply] Ig].
  do ? split; rewrite ?(is_morph_po M) ?(is_morph_lab M) ?(is_morph_rf M) //.
  - apply/(sameP idP)/(equivP idP).
    split=> [/(is_morph_ca Ig.1)|/(is_morph_ca M)//]; by rewrite ?c.
  apply/(sameP idP)/(equivP idP).
  split=> [/(f_cf Ig)|/(f_cf If)//]; by rewrite ?c.
Qed.

Lemma eq_is_iso f g es1 es2 : f =1 g ->
  is_iso f es1 es2 <-> is_iso g es1 es2.
Proof.
  move=> /[dup] /fsym H1 H2; rewrite /is_iso /is_morph.
  have->: bijective f <-> bijective g.
  - by split=> [/eq_bij/(_ _ H2) |/eq_bij/(_ _ H1)].
  apply/(and_iff_compat_r (bijective g)).
  split=> H x; move: (H x)=> /=; rewrite (H1, H2)=>->;
    by under edescr_map_eqfun=> ? do rewrite (H1, H2) over //.
Qed.

Definition eqv := exlab is_iso.

Lemma eqv_refl : \1 \<= eqv.
Proof.
  move=> ??->. exists id; do ? split=> //; last exact/inv_bij;
  rewrite ?map_id // => ? /=; by rewrite edescr_map_id.
Qed.

Lemma is_iso_comp es1 es2 es3 f g :
  is_iso f es1 es2 -> is_iso g es2 es3 ->
  is_iso (g \o f) es1 es3 .
Proof.
  case=> [] l1 ?[] l2 /[dup] [[?? c1 ?]] .
  (do ? split)=>[x|]; last exact/bij_comp.
  by move: (l1 x) (l2 (f x))=> /=; rewrite edescr_map_comp /= => <-.
Qed.

Lemma eqv_trans : Transitive eqv.
Proof. move=> ???[f i [g ?]]; exists (g \o f); exact/(is_iso_comp i). Qed.

Lemma eqv_symm : Symmetric eqv.
Proof. move=>> [? /[dup] I [_ [f *]]]; exists f; exact/(is_iso_can I).  Qed.

End Equivalence.

Notation "e1 ~~ e2" := (eqv e1 e2) (at level 20).

Notation fresh_id1  es := (fresh_seq (dom es)).
Notation fresh_id2 es := (fresh_seq (fresh_seq (dom es) :: dom es)).

Lemma is_iso_swap es1 es2 f e1 e2 :
  e1 \notin dom es1 ->
  e2 \notin dom es1 ->
  is_iso f es1 es2 ->
  is_iso (swap f e1 e2) es1 es2.
Proof.
  move=> N1 N2 /[dup] I [ l /[dup] /bij_inj ? b].
  case: (e1 =P e2)=> /= [->|/eqP/negbTE e12].
  - by under eq_is_iso=> ? do rewrite swapxx over //.
  (do ? split)=> [x/=|]; last exact/bij_swap.
  have H: forall e es, e \notin dom es -> fed es e = mk_edescr \eps e e.
  - by move=> ?? D; rewrite fsfun_dflt // fed_supp_mem D.
  rewrite /swap; case: ifP=> [/eqP->|].
  - rewrite ?H /= ?eq_refl // -?(iso_dom I) mem_map //.
  case: ifP=> [/eqP-> N|F1 F2].
  rewrite ?H //= ?N ?eq_refl // -?(iso_dom I) mem_map //.
  case: (boolP (x \in dom es1))=> [/[dup]/fpo_dom I1 /frf_dom I2|?].
  - apply/eqP; rewrite edescr_eq.
    rewrite lab_prj_edescr_map fpo_prj_edescr_map frf_prj_edescr_map.
    rewrite ?(negbTE (memPn _ _ I1)) ?(negbTE (memPn _ _ I2)) //.
    move: (l x)=> /=->.
    rewrite lab_prj_edescr_map fpo_prj_edescr_map frf_prj_edescr_map.
    by rewrite !eq_refl.
  by rewrite ?H //= ?F1 ?F2 //  -?(iso_dom I) mem_map.
Qed.

Arguments Add {_ _ _ _} _ _ _.

Lemma comm_eqv_tr :
  diamond_commute eqv tr.
Proof.
  move=> es es3 ? /[swap][][[al ap aw apd awd apc awc]]->.
  case=> f /[dup][[_ [g? c]]] I.
  have NI: g (fresh_id1 es3) \notin dom es.
  - by rewrite -(mem_map (bij_inj (proj2 I))) c (iso_dom I) fresh_seq_nmem //.
  move/(is_iso_swap (fresh_seq_nmem (dom es)) NI): I.
  set h := (swap f (fresh_id1 es) (g (fresh_id1 es3))).
  move=> /[dup] I [ l /[dup] /bij_inj ? b].
  have H: forall e, e \in dom es -> h e \in dom es3=> [e|].
  by rewrite -(iso_dom I) mem_map.
  have [: a1 a2 a3 a4] @s4: add_label es3 := @Add E Lab es3 al (h ap) (h aw) a1 a2 a3 a4.
  1,2: by apply/H; rewrite (apd, awd).
  - move: apc; move: (l ap)=> /=; rewrite /lab.
    by case L1: (fed _ ap)=> /=; case L2: (fed es3 (f ap))=> -> /=.
  - move: awc; move: (l aw)=> /=; rewrite /lab.
    by case L1: (fed _ aw)=> /=; case L2: (fed es3 (f aw))=> -> /=.
  exists (add_event s4); [by exists s4 | exists h].
  (do ? split)=> // x /=.
  rewrite ?fed_add_eventE /= -[fresh_id1 _]c -(swap1 f (fresh_id1 es)).
  rewrite -/h (bij_eq b); case: ifP=> // ?; exact/l.
Qed.

Lemma swap_dom es e : e \in dom es ->
  swap id (fresh_id1 es) (fresh_id2 es) e = e.
Proof.
  move=> H; rewrite -swap_not_eq=> //; rewrite lt_eqF //.
  - by apply /fresh_seq_mem.
  by apply /fresh_seq_mem; rewrite inE; apply /orP; right.
Qed.

Lemma add_add (es : porf_eventstruct)
  (al1 al2 : add_label es) :
  exists al : add_label (add_event al1),
  al = al2 :> edescr E label.
Proof.
  case: al2=> l p w ap aw ??.
  have [:a1 a2 a3 a4] @al : add_label (add_event al1) :=
    @Add E Lab (add_event al1) l p w a1 a2 a3 a4; try by rewrite ?inE (ap, aw) orbT.
    - by rewrite /= lab_add_eventE (lt_eqF (fresh_seq_mem ap)).
    - by rewrite /= lab_add_eventE (lt_eqF (fresh_seq_mem aw)).
    by exists al; rewrite ?(swap_dom (lexx _)).
Qed.

Lemma swap_add es
  (al1 al2 : add_label es)
  (al3 : add_label (add_event al1))
  (al4 : add_label (add_event al2)) :
  al1 = al4 :> edescr E label ->
  al2 = al3 :> edescr E label ->
  is_iso (swap id (fresh_id1 es) (fresh_id2 es))
    (add_event al3) (add_event al4) .
Proof.
  case: al1 al3 al2 al4=> ???????[/=???++++] [???????[/=???++++ E1 E2]].
  case: E1 E2; do 3? case:_/; case; (do 3? case:_/)=>*.
  do ? split; last exact/bij_swap/inv_bij.
  move=> x /=; rewrite /comp !fed_add_eventE /=.
  have: fresh_id1 es <> fresh_id2 es.
  - suff: fresh_id1 es < fresh_id2 es by rewrite lt_def eq_sym=> /andP[] /eqP.
    by apply/fresh_seq_mem/mem_head.
  move/eqP/negbTE=>F; case: (x =P fresh_id1 es)=> [->|/eqP/[dup] ? /negbTE N1].
  - rewrite swap1 eq_refl F /= !swap_dom //.
  rewrite ?inv_eq ?swap1 ?swap2 ?N1; try exact/swap_inv.
  case: ifP=> //=; first by rewrite !swap_dom=> //.
  move/negbT=> ?; rewrite -swap_not_eq //.
  case: (boolP (x \in dom es))=> [|I].
  - case L: (fed _ x)=> [l p r] I /=; apply/congr2; rewrite swap_dom //.
    - by rewrite -[p]/(fpo_prj (mk_edescr l p r)) -L fpo_dom.
    by rewrite -[r]/(frf_prj (mk_edescr l p r)) -L frf_dom.
  by rewrite fsfun_dflt /= -?swap_not_eq // fed_supp I.
Qed.

Lemma comm_ltr l1 l2 :
  eqv_diamond_commute (ltr l1) (ltr l2) eqv.
Proof.
  move=> es ?? [al1 -> /[swap][[al2->]]].
  case: (add_add al1 al2)=> al3 /[dup]? <-->.
  case: (add_add al2 al1)=> al4 /[dup]? <-->.
  exists (add_event al3), (add_event al4).
  split; [by exists al3| by exists al4|].
  exists (swap id (fresh_id1 es) (fresh_id2 es)); exact/swap_add.
Qed.

Lemma exlab_tr : tr \== exlab ltr.
Proof. by move=> ??; split=> [[l ->]|[?[l ->]]]; do ? exists l. Qed.

Arguments isoE {_ _ _ _ _}.

Lemma dom_consist_eqv es1 es2 :
  es1 ~~ es2 -> rf_ncf_dom es1 ->
  rf_ncf_dom es2.
Proof.
  rewrite /rf_ncf_dom=> [[f /[dup] If]] [L ? /allP H]; apply/allP.
  move=> x; rewrite -(iso_dom If)=> /mapP[y /H ?->].
  move/(congr1 (@frf_prj _ _)): (L y)=> /=; rewrite -frfE=>->.
  by rewrite frf_prj_edescr_map bij_eq // -(isoE If).
Qed.

Lemma dom_consist_add l1 l2
  (es1 es2 es3 es4 : porf_eventstruct) :
  rf_ncf_dom es1 ->
  es1 ~(l1)~> es2 -> rf_ncf_dom es2 ->
  es1 ~(l2)~> es3 -> rf_ncf_dom es3 ->
  es2 ~(l2)~> es4 -> rf_ncf_dom es4.
Proof.
  move=> ?; case=> [[la1 p1 w1 ap1 aw1 ad1 ac1 ->]].
  set al1 := @Add E Lab _ _ _ _ ap1 aw1 ad1 ac1=> e2; move=> C'.
  case=> [[l p w ap aw ad ac]]+->; set al2 := @Add E Lab _ _ _ _ ap aw ad ac=> -> C.
  case=> [[l' p' ap' ++++-> [le pe we]]].
  move: le pe we; (do ? case: _/).
  move=> ap2 aw2 ad2 ac2; set al2' := @Add E Lab _ _ _ _ ap2 aw2 ad2 ac2.
  apply/rf_ncf_add_event=> //=.
  set f := swap id (fresh_id1 es1) (fresh_id2 es1).
  have P : f p1 = p1 by rewrite /f (swap_dom ap1).
  have W : f w1 = w1 by rewrite /f (swap_dom aw1).
  have [: a1 a2 a3 a4] @al3 : add_label (add_event al2)
    := @Add E Lab _ la1 (f p1) (f w1) a1 a2 a3 a4=> /=.
  1,2: rewrite ?inE (P, W) (ap1, aw1); lattice.
  - by rewrite P lab_add_eventE (lt_eqF (po_fresh_id al1)).
  - by rewrite W lab_add_eventE (lt_eqF (rf_fresh_id al1)).
  have E1: al1 = al3 :> edescr _ _ by rewrite /= W P.
  have E2: al2 = al2' :> edescr _ _ by [].
  rewrite (isoE (swap_add E1 E2)) swap2 (swap_dom aw) //.
  rewrite -cf_add_eventE; first exact/rf_ncf_add_event.
  - suff: fresh_id1 es1 < fresh_id1 (add_event al2) by rewrite lt_def eq_sym=> /andP[].
    by apply /fresh_seq_mem=> /=; apply mem_head.
  by rewrite (lt_eqF (rf_fresh_id al2')).
Qed.

Lemma dup_free_eqv es1 es2 :
  es1 ~~ es2 -> dup_free es1 -> dup_free es2.
Proof.
  case=> f /[dup] If [M /[dup][[g c1 c2]] b /dup_freeP I].
  apply/dup_freeP=> x y.
  rewrite -?(iso_dom If) -[x]c2 -[y]c2 ?(mem_map (bij_inj b)).
  move: (M (g x)) (M (g y)).
  by move=> /=->-> /I/[apply] Eq /(bij_inj (edescr_map_bij b))/Eq->.
Qed.

Lemma fresh_id12 es :
  fresh_id1 es == fresh_id2 es = false.
Proof.
  apply /contra_neqF; first exact /eqP.
  suff: fresh_id1 es < fresh_id2 es by rewrite lt_def eq_sym=> /andP[].
  by apply/fresh_seq_mem/mem_head.
Qed.

Lemma dup_free_add l1 l2
  (es1 es2 es3 es4 : porf_eventstruct) :
  es2 != es3 ->
  dup_free es1 ->
  es1 ~(l1)~> es2 -> dup_free es2 ->
  es1 ~(l2)~> es3 -> dup_free es3 ->
  es2 ~(l2)~> es4 -> dup_free es4.
Proof.
  move=> + /dup_freeP I1 [al1] + ? => /[swap]->.
  move=> + /dup_freeP I2 [al2] + -> => /[swap]-> /negP N.
  have {N} ?: al1 <> al2 :> edescr _ _ by move: N=>/[swap]/of_add_label_inj->.
  move/dup_freeP=> I3 [al3] -> Eq.
  have N: al1 <> al3 :> edescr _ _ by rewrite -Eq=> /of_add_label_inj //.
  apply/dup_freeP=> x y /=.
  move: (I1 x y) (I2 x y)=> /=. rewrite ?add_fedE ?inE /=.
  case: ifP=> /= [/eqP->|].
  - rewrite fresh_id12 /=; case: ifP=> [/eqP->|].
    - by rewrite fresh_id12.
    case: ifP=> /= [/eqP->|???/[apply]/[apply]//].
    move=> ????? []; case: (al1) (al3) N=> /= ??????? [/=].
    by move=>> ???? /[swap]->/[swap]->/[swap]->.
  case: ifP=> /= [/eqP->|].
  - rewrite fresh_id12 /=; case: ifP=> /= // ?????? /esym.
    by case: (al1) (al3) N=> /= ??????? [].
  case: ifP=> /= [/eqP->|]; case: ifP=> [/eqP->|] //=.
  - move=> ? /[dup] EN + ???? D Ef; move: (I3 (fresh_id1 es1) y)=> /=.
    rewrite ?inE ?add_fedE {-3}EN -Ef ?eqxx D /==> /(_ erefl erefl) L.
    have->: fresh_id1 es1 = y by apply/L; case: (al2) (al3) Eq=> ??????? [].
    by rewrite eqxx.
  move=> ?? /[dup] EN + ?? D ? Ef; move: (I3 x (fresh_id1 es1))=> /=.
  rewrite ?inE ?add_fedE {-3}EN Ef ?eqxx D /==> /(_ erefl erefl) L.
  have->: x = fresh_id1 es1 by apply/L; case: (al2) (al3) Eq=> ??????? [].
  by rewrite eqxx.
Qed.

End Confluence.

End AddEvent.