Require Import TestSuite.admit.
(* -*- mode: coq; coq-prog-args: ("-indices-matter") *)
(* File reduced by coq-bug-finder from original input, then from 4988 lines to 856 lines, then from 648 lines to 398 lines, then from 401 lines to 332 lines, then from 287 lines to 250 lines, then from 257 lines to 241 lines, then from 223 lines to 175 lines *)
Set Universe Polymorphism.
Set Asymmetric Patterns.
Reserved Notation "g 'o' f" (at level 40, left associativity).
Generalizable All Variables.
Definition admit {T} : T.
Admitted.
Inductive paths {A : Type} (a : A) : A -> Type :=
  idpath : paths a a.
Arguments idpath {A a} , [A] a.
Notation "x = y" := (@paths _ x y) : type_scope.
Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) : Type
  := forall x:A, f x = g x.
Hint Unfold pointwise_paths : typeclass_instances.
Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope.
Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g)
: forall x, f x = g x
  := fun x => match h with idpath => idpath end.

Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A }.

Record Equiv A B := BuildEquiv { equiv_fun :> A -> B ; equiv_isequiv :> IsEquiv equiv_fun }.
Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope.

Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope.
Class Contr_internal (A : Type) := {}.
Inductive trunc_index : Type :=
| minus_two : trunc_index
| trunc_S : trunc_index -> trunc_index.

Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type :=
  match n with
    | minus_two => Contr_internal A
    | trunc_S n' => forall (x y : A), IsTrunc_internal n' (x = y)
  end.

Class IsTrunc (n : trunc_index) (A : Type) : Type :=
  Trunc_is_trunc : IsTrunc_internal n A.

Instance istrunc_paths (A : Type) n `{H : IsTrunc (trunc_S n) A} (x y : A)
: IsTrunc n (x = y)
  := H x y.

Notation IsHSet := (IsTrunc minus_two).

Class Funext :=
  { isequiv_apD10 :> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }.

Local Open Scope equiv_scope.

Global Instance isequiv_inverse `{IsEquiv A B f} : IsEquiv f^-1 | 10000
  := BuildIsEquiv B A f^-1 f.
Instance trunc_succ `{IsTrunc n A} : IsTrunc (trunc_S n) A | 1000.

admit.

Defined.
Definition trunc_equiv `(f : A -> B)
           `{IsTrunc n A} `{IsEquiv A B f}
: IsTrunc n B.
  admit.
Defined.
Definition trunc_equiv' `(f : A <~> B) `{IsTrunc n A}
: IsTrunc n B
  := admit.
Set Implicit Arguments.
Delimit Scope morphism_scope with morphism.
Delimit Scope category_scope with category.
Delimit Scope object_scope with object.
Record PreCategory :=
  Build_PreCategory {
      object :> Type;
      morphism : object -> object -> Type;

      identity : forall x, morphism x x;
      compose : forall s d d',
                  morphism d d'
                  -> morphism s d
                  -> morphism s d'
                              where "f 'o' g" := (compose f g);

      associativity : forall x1 x2 x3 x4
                             (m1 : morphism x1 x2)
                             (m2 : morphism x2 x3)
                             (m3 : morphism x3 x4),
                        (m3 o m2) o m1 = m3 o (m2 o m1);

      left_identity : forall a b (f : morphism a b), identity b o f = f;
      right_identity : forall a b (f : morphism a b), f o identity a = f;

      trunc_morphism : forall s d, IsHSet (morphism s d)
    }.
Existing Instance trunc_morphism.

Infix "o" := (@compose _ _ _ _) : morphism_scope.
Delimit Scope functor_scope with functor.

Local Open Scope morphism_scope.
Record Functor (C D : PreCategory) :=
  {
    object_of :> C -> D;
    morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d)
  }.

(** Workaround to simpl losing universe constraints, see bug #5645. *)
Ltac simpl' :=
  simpl; match goal with [ |- ?P ] => let T := type of P in idtac end.

Global Instance trunc_forall `{Funext} `{P : A -> Type} `{forall a, IsTrunc n (P a)}
: IsTrunc n (forall a, P a) | 100.
Proof.
    generalize dependent P.
  induction n as [ | n' IH]; (simpl'; intros P ?).
  - admit.
  - pose (fun f g => trunc_equiv (@apD10 A P f g) ^-1); admit.
Defined.
Instance trunc_sigma `{P : A -> Type}
         `{IsTrunc n A} `{forall a, IsTrunc n (P a)}
: IsTrunc n (sigT P) | 100.
admit.
Defined.
Record NaturalTransformation C D (F G : Functor C D) :=
  Build_NaturalTransformation' {
      components_of :> forall c, morphism D (F c) (G c)
    }.
Section path_natural_transformation.
  Context `{Funext}.
  Variable C : PreCategory.
  Variable D : PreCategory.
  Variables F G : Functor C D.
  Lemma equiv_sig_natural_transformation
  : { CO : forall x, morphism D (F x) (G x)
    & forall s d (m : morphism C s d),
        CO d o morphism_of F _ _ m = morphism_of G _ _ m o CO s }
      <~> NaturalTransformation F G.

    admit.
  Defined.
  Global Instance trunc_natural_transformation
  : IsHSet (NaturalTransformation F G).
  Proof.
    eapply trunc_equiv'; [ exact equiv_sig_natural_transformation | ].
    typeclasses eauto.
  Qed.
  Lemma path_natural_transformation (T U : NaturalTransformation F G)
  : components_of T == components_of U
    -> T = U.
    admit.
  Defined.
End path_natural_transformation.
Ltac path_natural_transformation :=
  repeat match goal with
           | _ => intro
           | _ => apply path_natural_transformation; simpl
         end.

Section FunctorSectionCategory.
  Context `{Funext}.
  Variable C : PreCategory.
  Variable D : PreCategory.

  Definition category_of_sections : PreCategory.
  Proof.
    refine (@Build_PreCategory
              (Functor D C)
              (fun F G => NaturalTransformation F G)
              admit
              admit
              _
              _
              _
              _);
    abstract (path_natural_transformation; admit).
  Defined. (* Stack overflow *)


(** * Simulation up to taus *)

(** A preorder [sutt t1 t2], where every visible step
  ([RetF] or [VisF]) on the left must be matched with a corresponding
  step on the right, ignoring [TauF].

  In particular, [spin := Tau spin] is less than everything.

  The induced equivalence relation is [eutt].
[[
  Theorem sutt_eutt : sutt eq t u -> sutt eq u t -> eutt eq t u.
]]
  Various lemmas about [eutt] may be more easily proved as
  [Proper] lemmas about [sutt] first, and then symmetrizing using
  [eutt_sutt] and [sutt_eutt].
 *)

Require Import Paco.paco.

From Coq Require Import
     Classes.RelationClasses
     Classes.Morphisms
     Setoids.Setoid
     Program
     Relations.Relations.

From ITree Require Import
     Core.ITreeDefinition
     Eq.Eq
     Eq.UpToTaus
     Eq.Shallow
     Eq.Paco2.

Section SUTT.

Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop).

Inductive suttF (sutt: itree' E R1 -> itree' E R2 -> Prop) :
  itree' E R1 -> itree' E R2 -> Prop :=
| suttF_ret r1 r2 : RR r1 r2 -> suttF sutt (RetF r1) (RetF r2)
| suttF_vis u (e : E u) k1 k2
      (SUTTK: forall x, sutt (observe (k1 x)) (observe (k2 x))):
    suttF sutt (VisF e k1) (VisF e k2)
| suttF_tau_right ot1 t2
      (EQTAUS: suttF sutt ot1 (observe t2)):
    suttF sutt ot1 (TauF t2)
| suttF_tau_left t1 ot2
      (EQTAUS: sutt (observe t1) ot2):
    suttF sutt (TauF t1) ot2
.
Hint Constructors suttF: core.

Definition sutt (t1 : itree E R1) (t2 : itree E R2) :=
  paco2 suttF bot2 (observe t1) (observe t2).
Hint Unfold sutt: core.

End SUTT.

Global Hint Constructors suttF: core.
Global Hint Unfold sutt: core.

Section SUTT_rel.

Context {E : Type -> Type} {R : Type} (RR : R -> R -> Prop).

Lemma reflexive_suttF `{Reflexive _ RR} sutt (r1:Reflexive sutt) : Reflexive (@suttF E _ _ RR sutt).
Proof.
  unfold Reflexive. intros x.
  destruct x; eauto.
Qed.

End SUTT_rel.

Section SUTT_facts.

Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop).

Lemma monotone_suttF : monotone2 (@suttF E _ _ RR).
Proof. repeat red; intros. induction IN; eauto. Qed.
Hint Resolve monotone_suttF : paco.

End SUTT_facts.

Global Hint Resolve monotone_suttF : paco.

Lemma suttF_inv_vis {E R1 R2} (RR : R1 -> R2 -> Prop) sutt :
  forall X e (k1 : X -> itree E R1) (k2 : X -> itree E R2),
    suttF RR sutt (VisF e k1) (VisF e k2) ->
    forall x, sutt (observe (k1 x)) (observe (k2 x)).
Proof.
  intros. inv H. apply inj_pair2 in H3; apply inj_pair2 in H5. subst. auto.
Qed.

Lemma sutt_inv_vis {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall X e (k1 : X -> itree E R1) (k2 : X -> itree E R2),
  sutt RR (Vis e k1) (Vis e k2) ->
  forall x, sutt RR (k1 x) (k2 x).
Proof.
  intros. pstep. punfold H. simpl in *.
  eapply suttF_inv_vis in H; pclearbot; punfold H.
Qed.

Lemma sutt_tau_right {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall (t1 : itree E R1) (t2 : itree E R2),
    sutt RR t1 t2 ->
    sutt RR t1 (Tau t2).
Proof.
  intros. punfold H. pstep.
  repeat red. repeat red in H. constructor.
  auto.
Qed.

Lemma sutt_tau_left {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall (t1 : itree E R1) (t2 : itree E R2),
    sutt RR t1 t2 ->
    sutt RR (Tau t1) t2.
Proof.
  intros. punfold H. pstep.
  repeat red. repeat red in H. constructor.
  eauto with paco.
Qed.

Lemma sutt_elim_tau_right {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall (t1: itree E R1) (t2: itree E R2),
    sutt RR t1 (Tau t2) ->
    sutt RR t1 t2.
Proof.
  pcofix CIH. pstep. intros.
  punfold H0. repeat red in H0.
  inv H0.
  - eapply monotone_suttF; eauto using upaco2_mon_bot with paco.
  - constructor. pclearbot. eauto with paco.
Qed.

Lemma suttF_inv_tau_left {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall (t1: itree E R1) ot2,
    suttF RR (upaco2 (suttF RR) bot2) (TauF t1) ot2 ->
    suttF RR (upaco2 (suttF RR) bot2) (observe t1) ot2.
Proof.
  intros.
  remember (TauF t1) as ott1.
  induction H; intros; subst; try dependent destruction Heqott1; eauto.
  pclearbot. punfold EQTAUS.
Qed.

Lemma sutt_inv_tau_left {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall (t1: itree E R1) (t2: itree E R2),
    sutt RR (Tau t1) t2 ->
    sutt RR t1 t2.
Proof.
  intros.
  punfold H. pstep. repeat red in H |- *.
  apply suttF_inv_tau_left; auto.
Qed.

Theorem sutt_eutt {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall (t1 : itree E R1) (t2 : itree E R2),
    sutt RR t1 t2 -> sutt (flip RR) t2 t1 -> eutt RR t1 t2.
Proof.
  pcofix CIH. intros.
  punfold H0. punfold H. pstep. red.
  induction H0; intros; subst; auto.
  - constructor. intro. right. eapply suttF_inv_vis in H. pclearbot. eauto with paco.
  - constructor; eauto. eapply IHsuttF; auto. eapply suttF_inv_tau_left; auto.
  - (* doing induction when one of the trees is a tau doesn't work well *)
    inv H; pclearbot.
    + clear t1 t2. genobs t0 ot0.
      hinduction EQTAUS0 before CIH; intros; subst; pclearbot.
      * constructor; eauto. simpobs. constructor. eauto.
      * constructor; eauto. simpobs. constructor. intros.
        right. apply CIH; auto. eapply sutt_inv_vis in EQTAUS; eauto.
      * constructor; eauto. simpobs. eapply IHEQTAUS0; eauto.
        rewrite (itree_eta' ot1). apply sutt_inv_tau_left; auto.
      * constructor. right. apply CIH; auto. apply sutt_elim_tau_right; auto.
    + constructor. right. apply CIH; apply sutt_elim_tau_right; auto.
Qed.

Theorem eutt_sutt {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall (t1 : itree E R1) (t2 : itree E R2),
    eutt RR t1 t2 -> sutt RR t1 t2.
Proof.
  pcofix CIH. pstep. intros.
  punfold H0. red in H0.
  induction H0; constructor; pclearbot; eauto 7 with paco.
Qed.

(** Generalized heterogeneous version of [eutt_bind] *)
Lemma sutt_bind' {E R1 R2 S1 S2} {RR: R1 -> R2 -> Prop} {SS: S1 -> S2 -> Prop}:
  forall t1 t2,
    sutt RR t1 t2 ->
    forall s1 s2, (forall r1 r2, RR r1 r2 -> sutt SS (s1 r1) (s2 r2)) ->
                  @sutt E _ _ SS (ITree.bind t1 s1) (ITree.bind t2 s2).
Proof.
  pcofix self. pstep. intros.
  punfold H0. unfold observe; cbn.
  induction H0; intros.
  - simpl. apply H1 in H. punfold H. eapply monotone_suttF; eauto using upaco2_mon_bot.
  - simpl. pclearbot. econstructor. eauto.
  - constructor. eauto with paco.
  - constructor. pclearbot.
    right. specialize (self t0 (go ot2) EQTAUS _ _ H1).
    apply self.
Qed.

Require Import Coq.Relations.Relations.

(* todo: this could be made stronger with eutt rather than eq_itree
 *)
#[global]
 Instance Proper_sutt {E : Type -> Type} {R1 R2 : Type} r
: Proper (eq_itree eq ==> eq_itree eq ==> flip impl)
       (@sutt E R1 R2 r).
Proof.
  repeat red. pcofix CIH; pstep. intros.
  punfold H0; punfold H1; punfold H2. red in H0, H1.
  (* rename H1 into H2, Hxy into H1.  *)
  hinduction H2 before CIH; subst; intros.
  - inv H0; try discriminate. inv H1; try discriminate. econstructor. eauto.
  - dependent destruction H0; try discriminate.
    dependent destruction H1; try discriminate.
    simpobs. pclearbot.
    constructor. intros. right. eauto 7 with paco.
  - dependent destruction H1; try discriminate.
    simpobs. pclearbot. punfold REL.
  - dependent destruction H0; try discriminate.
    simpobs. pclearbot. constructor.
    right. rewrite (itree_eta' ot2) in *. eauto.
Qed.