Require Import HoTT.

(* Require Import finite_lemmas path_lemmas pointed_lemmas delooping *)
(*                permutations BSigma group_complete_1type. *)
Require Import Categories.Functor Category.Morphisms.
Require Import Category.Core.
Require Import set_quotient.
Add Rec LoadPath "~/Coq-projects/groupoids" as GR.
From GR Require Import cquot cquot_principles.

Definition cat_isomorphic_compose {C D E : PreCategory}
           (G : cat.isomorphic D E) (F : cat.isomorphic C D)
  : cat.isomorphic C E.
Proof.
  destruct G as [G iso_G]. destruct F as [F iso_F].
  exists (G o F)%functor.
  destruct iso_G as [ff_G equiv_G].
  destruct iso_F as [ff_F equiv_F].
  srefine (_ , isequiv_compose).
  unfold cat.fullyfaithful in *.
  intros s d.
  unfold Functor.Composition.Core.compose. simpl.
  apply isequiv_compose.
Defined.

Definition double_transport {A B : Type} (P : A -> B -> Type)
           {a a' : A} {b b' : B}
           (p : a = a') (q : b = b') :
  P a b -> P a' b'.
Proof.
  destruct p. destruct q. exact idmap.
Defined.

Definition double_transport_compose {A B : Type} (P : A -> B -> Type)
           {a a' a'' : A} {b b' b'' : B}
           (p : a = a') (p' : a' = a'')
           (q : b = b') (q' : b' = b'')
  : double_transport P (p @ p') (q @ q') ==
    double_transport P p' q' o double_transport P p q.
Proof.
  intro x.
  destruct q'. destruct q.
  destruct p'. destruct p. reflexivity.
Defined.

Definition path_functor' {C D : PreCategory} (F G : Functor C D)
           (p0 : forall c : C, F c = G c)
           (p1 : forall (c d : C) (f : morphism C c d),
               double_transport (morphism D) (p0 c) (p0 d) (morphism_of F f )
               = morphism_of G f)
  : F = G.
Proof.
  srapply @path_functor.
  - apply path_forall. exact p0.
  - apply path_forall. intro s. apply path_forall. intro d.
    apply path_arrow. intro f.
    refine (_ @ p1 _ _ f).
    rewrite <- (apD10_path_forall (object_of F) (object_of G) p0 s).
    rewrite <- (apD10_path_forall (object_of F) (object_of G) p0 d).
    change (path_forall (Core.object_of F) (Core.object_of G) p0) with
    (path_forall F G p0).
    destruct (path_forall F G p0). simpl.
    reflexivity.
Defined.

  (* The functor given by the constructors of cquot *)
  Definition include_in_cquot (C : PreCategory)
  : Functor C (Core.groupoid_category (cquot C)).
  Proof.
    srapply @Build_Functor.
    - apply ccl.
    - apply ccleq.
    - apply cconcat.
    - apply ce.
  Defined.

    Definition functor_groupoid_category
             (X Y : Type) {istrunc_X : IsTrunc 1 X} {istrunc_Y : IsTrunc 1 Y}
    : (X -> Y) -> Functor (Core.groupoid_category X) (Core.groupoid_category Y).
  Proof.
    intro f.
    srapply @Build_Functor.
    + exact f.
    + intros x1 x2. simpl. exact (ap f).
    + intros x1 x2 x3 p1 p2. simpl in *.
      apply ap_pp.
    + reflexivity.
  Defined.

  Definition univ_cquot (C : PreCategory) (Y : Type) {istrunc_Y : IsTrunc 1 Y}
    : (cquot C -> Y) <~> Functor C (Core.groupoid_category Y).
  Proof.
    srapply @equiv_adjointify.
    - intro f.
      refine (_ o (include_in_cquot C))%functor.
      apply functor_groupoid_category. exact f.
    - intro F.
      srapply @cquot_rec.
      + exact (object_of F).
      + apply (morphism_of F).
      + apply (identity_of F).
      + apply (composition_of F).
    - intro F.
      srapply @path_functor'.
      + reflexivity.
      + intros a b f. simpl.
        apply cquot_rec_beta_ccleq.
    - intro F. apply path_arrow. intro x. revert x.
      srapply @cquot_ind_set.
      + intro c. simpl. reflexivity.
      + intros c1 c2 f. simpl.
        apply path_to_path_over.
        refine (transport_paths_FlFr _ _ @ _).
        simpl. rewrite concat_p1.
        apply moveR_Vp. rewrite concat_p1.
        apply inverse.
        refine (cquot_rec_beta_ccleq _ _ _ _ _ _ _ _ _ _).
  Defined.

  (* move *)
  Definition functor_cquot {C D : PreCategory}
    : Functor C D -> (cquot C -> cquot D).
  Proof.
    intro F.
    apply (univ_cquot _ _)^-1.
    refine (include_in_cquot _ o F)%functor.
    (* srapply @cquot_rec. *)
    (* - intro c. apply ccl. exact (F c). *)
    (* - intros c1 c2 f. simpl. *)
    (*   apply ccleq. apply (morphism_of F). exact f. *)
    (* - intro c. simpl. *)
    (*   rewrite identity_of. apply ce. *)
    (* - intros c1 c2 c3 f g. simpl. *)
    (*   rewrite composition_of. apply cconcat. *)
  Defined.

  Definition univ_cquot_beta_ccleq {C : PreCategory}
             (Y : Type) {istrunc_Y : IsTrunc 1 Y}
             (F : Functor C (Core.groupoid_category Y))
             {c1 c2 : C} (f : morphism C c1 c2)
    : ap ((univ_cquot C Y)^-1 F) (ccleq C f) = (morphism_of F f).
  Proof.
    unfold univ_cquot. simpl.
    apply cquot_rec_beta_ccleq.
  Defined.

  Definition functor_cquot_beta_ccleq {C D : PreCategory}
             (F : Functor C D)
             {c1 c2 : C} (f : morphism C c1 c2)
    : ap (functor_cquot F) (ccleq C f) =
      ccleq D (morphism_of F f).
  Proof.
    unfold functor_cquot.
    apply univ_cquot_beta_ccleq.
  Defined.

Section Pi_0.
Definition pi0_cat (C : PreCategory) : Type
  := set_quotient (morphism C).

Definition class_of_pi0cat {C : PreCategory} : C -> pi0_cat C :=
  class_of (morphism C).

Definition path_pi0_cat {C : PreCategory} {c d : C} (f : morphism C c d)
  : class_of_pi0cat c = class_of_pi0cat d.
Proof.
  apply related_classes_eq. exact f.
Defined.

Definition pi0_cat_cquot (C : PreCategory) :
  pi0_cat C <~> Trunc 0 (cquot C).
Proof.
  srapply @equiv_adjointify.
  - srapply @set_quotient_rec.
    + intro c. apply tr. apply (ccl C c).
    + simpl. intros x y f.
      apply (ap tr).
      apply ccleq. exact f.
  - srapply @Trunc_rec.
    srapply @cquot_rec.
    + apply class_of.
    + intros c d f.
      apply related_classes_eq. exact f.
    + simpl. intro c.
      apply set_quotient_set.
    + simpl. intros.
      apply set_quotient_set.
  - intro x. revert x.
    srefine (Trunc_ind _ _).
    srefine (cquot_ind_prop _ _ _).
    simpl. reflexivity.
  - intro x. revert x.
    srefine (set_quotient_ind_prop _ _ _).
    simpl. reflexivity.
Defined.
End Pi_0.

Section Cat_sum.

(* Given a family of categories over a type, we can define the sum *)
Definition cat_sum_obj (X : Type) (C : X -> PreCategory) :=
  {x : X & object (C x)}.

Definition morphism_over {X : Type} (C : X -> PreCategory)
           {x0 x1 : X} (p : x0 = x1) (c0 : C x0) (c1 : C x1) : Type.
Proof.
  destruct p.
  exact (morphism (C x0) c0 c1).
Defined.

Global Instance isset_morphism_over {X : Type} (C : X -> PreCategory)
       {x0 x1 : X} (p : x0 = x1) (c0 : C x0) (c1 : C x1)
  : IsHSet (morphism_over C p c0 c1).
Proof.
  destruct p. simpl. exact _.
Defined.

Definition morphism_over_compose {X : Type} (C : X -> PreCategory)
           {x0 x1 x2 : X} {p1 : x0 = x1} {p2 : x1 = x2}
           {c0 : C x0} {c1 : C x1} {c2 : C x2}
  : morphism_over C p2 c1 c2 ->  morphism_over C p1 c0 c1
    -> morphism_over C (p1 @ p2) c0 c2.
Proof.
  intros f g.
  destruct p2. destruct p1.
  simpl. exact (f o g)%morphism.
Defined.

Definition cat_sum_morph (X : Type) (C : X -> PreCategory)
  : cat_sum_obj X C -> cat_sum_obj X C -> Type.
Proof.
  intros [x a] [y b].
  exact {p : x = y & morphism_over C p a b}.
Defined.

Definition cat_sum (X : Type) {istrunc_X : IsTrunc 1 X}
           (C : X -> PreCategory) : PreCategory.
Proof.
  srapply (Build_PreCategory (cat_sum_morph X C)).
  (* identity *)
  - intros [x a]. exists idpath. apply identity.
  - intros [x a] [y b] [z c].
    intros [p f] [q g].
    exists (q @ p).
    apply (morphism_over_compose C f g).
  - intros [x a] [y b] [z c] [w d].
    intros [p f] [q g] [r h].
    destruct r. destruct q. destruct p. simpl in *.
    srapply (@path_sigma).
    { reflexivity. } apply associativity.
  - intros [x a] [y b]. intros [p f].
    destruct p.
    srapply (@path_sigma).
    { reflexivity. } simpl.
    apply left_identity.
  - intros [x a] [y b]. intros [p f].
    destruct p.
    srapply (@path_sigma).
    { reflexivity. } simpl.
    apply right_identity.
Defined.

Definition include_summand (X : Type) {istrunc_X : IsTrunc 1 X}
           (C : X -> PreCategory) (x : X)
  : Functor (C x) (cat_sum X C).
Proof.
  srapply @Build_Functor.
  - intro c. exact (x; c).
  - intros s d f. simpl.
    exists idpath. exact f.
  - intros a b c f g. simpl. reflexivity.
  - reflexivity.
Defined.

Definition univ_cat_sum (X : Type) {istrunc_X : IsTrunc 1 X}
           (C : X -> PreCategory) (D : PreCategory)
  :  Functor (cat_sum X C) D <~> (forall x : X, Functor (C x) D).
Proof.
  srapply @equiv_adjointify.
  - intro F. intro x.
    refine (F o _)%functor.
    apply include_summand.
  - intro F.
    srapply @Build_Functor.
    + intros [x c]. exact (F x c).
    + intros [x1 c1] [x2 c2]. simpl.
      intros [p f]. simpl. destruct p. simpl in *.
      apply (morphism_of (F x1)). exact f.
    + intros [x1 c1] [x2 c2] [x3 c3].
      intros [p f] [q g]. simpl.
      destruct q. destruct p. simpl.
      apply composition_of.
    + simpl. intro x.
      apply identity_of.
  - simpl. intro F. apply path_forall.
    intro x. srapply @path_functor'.
    + simpl. reflexivity.
    + simpl. reflexivity.
  - simpl. intro F.
    srapply @path_functor'.
    + simpl. intros [x c]. reflexivity.
    + simpl. intros [x1 c1] [x2 c2] [p f].
      destruct p. reflexivity.
Defined.

Definition cat_sum_to_groupoid (X : Type) (Y : X -> Type)
           {istrunc_X : IsTrunc 1 X} {istrunc_Y : forall x : X, IsTrunc 1 (Y x)}
  : Functor (cat_sum X (fun x => Core.groupoid_category (Y x)))
            (Core.groupoid_category {x : X & Y x}).
Proof.
  srapply @Build_Functor.
  - exact idmap.
  - intros [x1 y1] [x2 y2]. simpl.
    intros [p f]. destruct p. simpl in f. destruct f. reflexivity.
  - intros [x1 y1] [x2 y2] [x3 y3]. simpl.
    intros [p1 f1] [p2 f2]. destruct p2. destruct p1. simpl.
    destruct f2. destruct f1. reflexivity.
  - simpl. reflexivity.
Defined.

(* show that the above functor is an isomorphism instead...*)
(* the path groupoid of a sigma type is equivalent to such a type *)
Definition iso_path_groupoid_cat_sum (X : Type) (Y : X -> Type)
           {istrunc_X : IsTrunc 1 X} {istrunc_Y : forall x : X, IsTrunc 1 (Y x)}
  : cat.isomorphic (Core.groupoid_category {x : X & Y x})
                   (cat_sum X (fun x => Core.groupoid_category (Y x))).
Proof.
  unfold cat.isomorphic.
  srapply @exist.
  - srapply @Build_Functor.
    + simpl. exact idmap.
    + simpl. intros a b p.
      unfold cat_sum_morph. destruct p.
      exists idpath. reflexivity.
    + simpl. intros a b c p q. destruct q. destruct p. simpl.
      reflexivity.
    + simpl. reflexivity.
  - apply Datatypes.pair.
    + intros a b. simpl.
      srapply @isequiv_adjointify.
      * intros [p f]. destruct a as [x1 y1]. destruct b as [x2 y2].
        destruct p. simpl in f. destruct f. reflexivity.
      * intros [p f].
        destruct a as [x1 y1]. destruct b as [x2 y2].
        destruct p. simpl in f. destruct f. reflexivity.
      * simpl. intro p. destruct p. reflexivity.
    + simpl. exact _.
Defined.
End Cat_sum.

Section Component.
Definition component (X : Type) (x0 : Trunc 0 X) :=
  {x : X & tr x = x0}.

(* full subcategory given by a family of propositions on the type of objects *)
Definition full_subcategory
           (C : PreCategory) (P : C -> Type) : PreCategory.
Proof.
  srapply (Build_PreCategory
           (object := {c : C & P c})
           (fun c d => morphism C (c.1) (d.1))).
  - intros. simpl.
    apply identity.
  - simpl. intros a b c f g.
    apply (compose f g).
  - simpl. intros a b c d. intros f g h.
    apply (associativity).
  - simpl. intros a b f.
    apply left_identity.
  - simpl. intros a b f.
    apply right_identity.
Defined.

Definition include_full_subcategory (C : PreCategory) (P : C -> Type)
  : Functor (full_subcategory C P) C.
Proof.
  srapply @Build_Functor.
  - exact pr1.
  - intros [c1 p1] [c2 p2]. exact idmap.
  - intros [c1 p1] [c2 p2] [c3 p3]. reflexivity.
  - simpl. reflexivity.
Defined.

Definition component_cat (C : PreCategory) (c0 : pi0_cat C) :=
  full_subcategory C (fun c => class_of _ c = c0).

Definition include_component_cat (C : PreCategory) (c0 : pi0_cat C)
  : Functor (component_cat C c0) C.
Proof.
  apply include_full_subcategory.
Defined.

(* Definition fib_cquot_include (C : PreCategory) (c0 : pi0_cat C) *)
(*   : cquot C -> hProp. *)
(* Proof. *)
(*   srapply @cquot_rec. *)
(*   - intro c. exact (BuildTruncType -1 (class_of_pi0cat c = c0)). *)
(*   - intros c1 c2 f. simpl. *)
(*     apply path_trunctype. simpl. *)
(*     apply (BuildEquiv _ _ (fun p => (path_pi0_cat f)^ @ p)). *)
(*     apply isequiv_concat_l. *)
(*   - intro c. simpl. *)
(*     apply (istrunc_paths _ -1). *)
(*   - intros. simpl. apply (istrunc_paths _ -1). *)
(* Defined. *)

(* Definition isembedding_cquot_include (C : PreCategory) (c0 : pi0_cat C) *)
(*   : IsEmbedding (functor_cquot (include_component_cat C c0)). *)
(* Proof. *)
(*   unfold IsEmbedding. *)
(*   srapply @cquot_ind_prop. *)
(*   intro c. simpl. *)
(*   unfold hfiber. *)
(*   intros [x1 p1] [x2 p2]. *)
(*   (* revert x2 p2. srapply @cquot_ind_prop. *) *)
(*   (* intros x2 p2. *) *)
(*   revert x1 p1. srapply @cquot_ind_prop. *)
(*   intros [x1 q1] p1.  *)
(*   unfold functor_cquot in p1. simpl in p1.   *)
(*   srapply @BuildContr. *)
(*   - srapply @path_sigma. *)
(*     + simpl. *)

(*   (* apply (trunc_equiv' ((pi0_cat_cquot C)^-1 (tr y) = c0)). *) *)
(*   apply (trunc_equiv' (class_of_pi0cat c = c0)). *)
(*   - srapply @equiv_adjointify. *)
(*     + intro p. unfold hfiber. *)
(*       exists (ccl (component_cat C c0) (c; p)). *)
(*       reflexivity. *)
(*     + intros [x p]. revert x p. *)
(*       srapply @cquot_ind_prop. *)
(*       intros [d p]. *)
(*       unfold functor_cquot. simpl. *)
(*       intro q. refine (_ @ p). *)
(*       apply (equiv_inj (pi0_cat_cquot C)). *)
(*       simpl. *)
(*       apply (ap tr). exact q^. *)
(*     + intros [x p]. simpl. *)
(*       revert x p. srapply @cquot_ind_set. *)
(*       * intros [d q]. unfold functor_cquot. simpl. intro p. *)
(*         srapply @path_sigma. *)
(*         { simpl. apply ccleq. *)
(*           simpl.  *)
(*           apply path *)

(*         destruct q. simpl. *)

(*        admit. *)

(*     + intro p. apply (set_quotient_set). *)
(*   - apply (istrunc_paths _ -1). *)

(* Definition isembedding_cquot_include (C : PreCategory) (P : C -> Type) *)
(*            {isprop_P : forall c : C, IsHProp (P c)} *)
(*   : IsEmbedding (functor_cquot (include_full_subcategory C P)). *)
(* Proof. *)
(*   unfold IsEmbedding. *)
(*   srapply @cquot_ind_prop. *)
(*   intro c. simpl. *)
(*   apply (trunc_equiv' (P c)). *)
(*   - srapply @equiv_adjointify. *)
(*     + intro p. unfold hfiber. *)
(*       exists (ccl (full_subcategory C P) (c; p)). *)
(*       reflexivity. *)
(*     + intros [x p]. revert x p. *)
(*       srapply @cquot_ind_prop. *)
(*       intros [d p]. simpl. *)
(*       unfold functor_cquot. simpl. *)
(*       intro q.  *)

(* istruncmap_fiber *)

End Component.

Definition cquot_comp_to_comp_cquot (C : PreCategory) (x : pi0_cat C)
  : cquot (component_cat C x) -> component (cquot C) (pi0_cat_cquot C x).
Proof.
  intro c.
  srapply @exist.
  - revert c. apply functor_cquot.
    apply include_component_cat.
  - revert c.
    srapply @cquot_ind_prop.
    intro c. simpl. unfold functor_cquot. simpl.
    revert x c.
    srapply @set_quotient_ind_prop. intro x. simpl.
    intros [c p].
    apply (equiv_inj (pi0_cat_cquot C)^-1). simpl.
    exact p.
Defined.

Definition comp_cquot_to_cquot_comp (C : PreCategory) (x : pi0_cat C)
  : component (cquot C) (pi0_cat_cquot C x) -> cquot (component_cat C x).
Proof.
  intros [c p]. revert c p.
  srapply @cquot_ind.
  - intros c p. simpl.
    apply ccl. exists c.
    apply (equiv_inj (pi0_cat_cquot C)). simpl.
    apply p.
  - intros c1 c2 f.
    apply path_over_arrow.
    + intro p.  apply const_path_over.
      apply ccleq. simpl. exact f.
    + exact _.
  - intro c. admit.
  - intros. admit.

    simpl.

Section Decompose_cat.

Definition transport_morph_component {C : PreCategory} {c d : C}
           (f : morphism C c d) :
  transport (component_cat C) (path_pi0_cat f) (c; idpath) =
  (c; path_pi0_cat f).
Proof.
  destruct (path_pi0_cat f). reflexivity.
Defined.

Definition decompose_cat_obj {C : PreCategory}
  : C -> cat_sum (pi0_cat C) (component_cat C).
Proof.
  intro c. exists (class_of_pi0cat c).
  exists c. reflexivity.
Defined.

Definition morphism_over_decomp {C : PreCategory} {c1 c2 : C}
           {x1 x2 : pi0_cat C}
           (p1 : class_of_pi0cat c1 = x1)
           (p2 : class_of_pi0cat c2 = x2)
           (q : x1 = x2)
  : morphism (component_cat C x2) (c1; p1 @ q) (c2 ; p2) ->
    morphism_over (component_cat C) q (c1; p1) (c2; p2).
Proof.
  destruct q. simpl. exact idmap.
Defined.

Definition morphism_to_morphism_over_comp {C : PreCategory} {c1 c2 c3 : C}
           {x1 x2 x3 : pi0_cat C}
           (p1 : class_of_pi0cat c1 = x1)
           (p2 : class_of_pi0cat c2 = x2)
           (p3 : class_of_pi0cat c3 = x3)
           (q1 : x1 = x2) (q2 : x2 = x3)
           (f : morphism C c2 c3) (g : morphism C c1 c2)
  : morphism_over_compose _
      (morphism_over_decomp p2 p3 q2 f) (morphism_over_decomp p1 p2 q1 g) =
    morphism_over_decomp p1 p3 (q1 @ q2) (f o g)%morphism.
Proof.
  destruct q2. destruct q1. reflexivity.
Defined.

(* Definition morphism_over_decomp {C : PreCategory} {c1 c2 : C} *)
(*            (f : morphism C c1 c2) *)
(*   : morphism_over (component_cat C) (path_pi0_cat f) (c1; idpath) (c2; idpath). *)
(* Proof. *)
(*   apply morphism_to_morphism_over. exact f. *)
(* Defined.   *)

Definition decompose_cat (C : PreCategory)
  : cat.isomorphic C (cat_sum (pi0_cat C) (component_cat C)).
Proof.
  refine
    (cat_isomorphic_compose
       (D := full_subcategory C (fun c => {x : pi0_cat C & class_of_pi0cat c = x}))
       _ _).
  - srapply @exist.
    + srapply @Build_Functor.
      * intros [c [x p]].
        exact (x; (c; p)).
      * intros [c1 [x1 p1]] [c2 [x2 p2]].
        simpl. intro f.
        srapply @exist.
        { simpl. exact (p1^ @ (path_pi0_cat f) @ p2). }
        simpl.

        (* destruct p1. destruct p2. *)
        (* exists (path_pi0_cat f). *)
        apply morphism_over_decomp. simpl.
        exact f.
      * intros [c1 [x1 p1]] [c2 [x2 p2]] [c3 [x3 p3]].
        destruct p3. destruct p2. destruct p1.
        intros f1 f2. simpl in f1. simpl in f2.
        simpl. rewrite morphism_to_morphism_over_comp.
        repeat rewrite concat_1p. repeat rewrite concat_p1.
        simpl. unfold morphism_over_decomp.
        assert (p : path_pi0_cat (f2 o f1) =
                    path_pi0_cat f1 @ path_pi0_cat f2).
        { apply set_quotient_set. }

        destruct p. reflexivity.
      * simpl.
        intros [c [x p]]. destruct p.
        unfold morphism_over_decomp.
        rewrite concat_1p. rewrite concat_p1.
        assert (p :path_pi0_cat (identity c) = idpath).
        { apply set_quotient_set. } rewrite p.
        reflexivity.
    + simpl. unfold cat.is_isomorphism.
      unfold cat.fullyfaithful. simpl.
      apply Datatypes.pair.
      { intros [c1 [x1 p1]] [c2 [x2 p2]].
        srapply @isequiv_adjointify.
        - simpl.
          intros [p f]. destruct p. simpl in f. exact f.
        - intros [p f].
          destruct p. simpl. simpl in f.
          assert (p : (p1^ @ path_pi0_cat f) @ p2 = idpath).
          { apply set_quotient_set. }
          rewrite p.
          reflexivity.
        - intro f. simpl in f.
          generalize ((p1^ @ path_pi0_cat f) @ p2).
          intro p. destruct p. reflexivity. }
      { srapply @isequiv_adjointify.
        - intros [x [c p]].
          exact (c; (x; p)).
        - intros [x [c p]]. reflexivity.
        - intros [c [x p]]. reflexivity. }
  - srapply @exist.
    + srapply @Build_Functor.
      * intro c. exists c. exists (class_of_pi0cat c). reflexivity.
      * intros s d f. simpl. exact f.
      * intros a b c f g. simpl. reflexivity.
      * reflexivity.
    + simpl. apply Datatypes.pair.
      * intros c d. simpl. exact _.
      * simpl.
        srapply @isequiv_adjointify.
        { apply pr1. }
        { intros [c [x p]]. simpl.
          destruct p. reflexivity. }
        intro c. reflexivity.
Defined.

End Decompose_cat.

(* Record IsIso_Cat {C D : PreCategory} (F : Functor C D) := *)
(*   {isequiv_obj : IsEquiv (object_of F); *)
(*    isequiv_morphism : forall a b : C, IsEquiv (@morphism_of _ _ F a b) *)
(*   }. *)

(* Definition Iso_Cat_inv {C D : PreCategory} (F : Functor C D) *)
(*   : (IsIso_Cat F) -> Functor D C. *)
(* Proof. *)
(*   intros [iseq_0 iseq_1]. *)
(*   srapply @Build_Functor. *)
(*   - exact (F^-1). *)
(*   - intros c d f. *)
(*     apply (morphism_of F (s := F^-1 c) (d := F^-1 d))^-1. *)
(*     srefine (double_transport (morphism D) _ _ f). *)
(*     { apply (eisretr F c)^. } *)
(*     { apply (eisretr F d)^. } *)
(*   - intros a b c f g. *)
(*     simpl. *)
(*     apply (equiv_inj (morphism_of F (d:=F^-1 c))). *)
(*     refine (eisretr (morphism_of F (d:=F^-1 c)) _ @ _). *)
(*     refine (_ @ (composition_of F _ _ _ _ _)^). *)
(*     rewrite (eisretr (morphism_of F (d:=F^-1 c))). *)
(*     rewrite (eisretr (morphism_of F (d:=F^-1 b))). *)
(*     destruct (eisretr F b)^. *)
(*     destruct (eisretr F c)^. *)
(*     destruct (eisretr F a)^. reflexivity. *)
(*   - simpl. intro d. *)
(*     apply (equiv_inj (morphism_of F (d:=F^-1 d))). *)
(*     refine (eisretr (morphism_of F (d:=F^-1 d)) _ @ _). *)
(*     refine (_ @ (identity_of F _)^). *)
(*     destruct (eisretr F d)^. reflexivity. *)
(* Defined. *)

(* Definition path_functor_uncurried' {C D : PreCategory} (F G : Functor C D) *)
(*   : {p0 : forall c : C, F c = G c & *)
(*       forall (c d : C) (f : morphism C c d), *)
(*                double_transport (morphism D) (p0 c) (p0 d) (morphism_of F f ) *)
(*                = morphism_of G f} -> F = G. *)
(* Proof. *)
(*   intros [p0 p1]. exact (path_functor' F G p0 p1). *)
(* Defined. *)

(* Definition equiv_path_functor' {C D : PreCategory} (F G : Functor C D) *)
(*   : {p0 : forall c : C, F c = G c & *)
(*       forall (c d : C) (f : morphism C c d), *)
(*                double_transport (morphism D) (p0 c) (p0 d) (morphism_of F f ) *)
(*                = morphism_of G f} <~> F = G. *)
(* Proof. *)
(*   refine (equiv_path_functor_uncurried F G oE _). *)
(*   srapply @equiv_functor_sigma'. *)
(*   - apply equiv_path_forall. *)
(*   - intro p. simpl. *)
(*     transitivity *)
(*       (forall (c d : C) (f : morphism C c d), *)
(*           double_transport (morphism D) *)
(*                            ((apD10 (path_forall F G p)) c) *)
(*                            ((apD10 (path_forall F G p)) d) *)
(*                            (F _1 f)%morphism = *)
(*           (G _1 f)%morphism). *)
(*     { apply equiv_functor_forall_id. intro a. *)
(*       apply equiv_functor_forall_id. intro b. *)
(*       apply equiv_functor_forall_id. intro f. *)
(*       rewrite <- (apD10_path_forall (object_of F) (object_of G) p a). *)
(*       rewrite <- (apD10_path_forall (object_of F) (object_of G) p b). *)
(*       reflexivity. } *)
(*     generalize (path_forall F G p). clear p. intro p. *)
(*     srapply @equiv_adjointify. *)
(*     + intro q. *)
(*       destruct (path_arrow _ _ (path_forall _ _ (path_forall _ _ q))). *)
(*       apply path_forall. intro a. *)
(*       apply path_forall. intro b. *)
(*       apply path_arrow. intro f. *)
(*       refine (_ @ q a b f). *)
(*       change  *)

(*     change (path_forall (Core.object_of F) (Core.object_of G) p) with *)
(*     .     *)
(*     destruct (path_forall F G p). *)

(*   unfold path_functor_uncurried'. unfold path_functor'. *)
(*   srapply @isequiv_adjointify. *)
(*   - intros []. *)
(*     srapply @exist. *)
(*     + intro c. reflexivity. *)
(*     + simpl. reflexivity. *)
(*   - intro p. destruct p. *)
(*     unfold path_functor_uncurried'. *)
(*     unfold path_functor'. simpl. *)

(* Definition linv_iso_cat_inv {C D : PreCategory} (F : Functor C D) *)
(*            {isiso_F : IsIso_Cat F} *)
(*   : Functor.compose (Iso_Cat_inv F isiso_F) F = (Functor.identity C). *)
(* Proof. *)
(*   srapply @path_functor'. *)
(*   - simpl. intro c. *)
(*     apply eissect. *)
(*   - simpl. intros c d f. *)
(*     rewrite eisadj. *)
(*     rewrite eisadj. *)

(*     (* refine (_ @ eissect (morphism_of F (s := c) (d := d)) f). *) *)
(*     (* generalize (F _1 f)%morphism. intro g. clear f. *) *)
(*     destruct isiso_F as [iseq_0 iseq_1]. *)
(*     rewrite <- ap_V. rewrite <- ap_V. *)
(*     change (eissect (Core.object_of F) c) with (eissect F c). *)
(*     change (eissect (Core.object_of F) d) with (eissect F d). *)
(*     assert (H : double_transport (morphism C) (eissect F c) (eissect F d) *)
(*                              o (morphism_of F (d:=F^-1 (F _0 d)%object))^-1 *)
(*             == *)
(*             (morphism_of F (d := d))^-1 o *)
(*                  double_transport (morphism D) (ap F (eissect F c)) *)
(*                                                (ap F (eissect F d))). *)
(*     { destruct (eissect F c). destruct (eissect F d). intro g. *)
(*       simpl. reflexivity. } *)
(*     rewrite H. *)
(*     rewrite <- double_transport_compose. *)
(*     rewrite <- ap_pp. rewrite <- ap_pp. *)
(*     rewrite concat_Vp. rewrite concat_Vp. simpl. *)
(*     apply eissect. *)
(* Defined. *)

(* Definition rinv_iso_cat_inv {C D : PreCategory} (F : Functor C D) *)
(*            {isiso_F : IsIso_Cat F} *)
(*   : Functor.compose F (Iso_Cat_inv F isiso_F) = (Functor.identity D). *)
(* Proof. *)
(*   srapply @path_functor'. *)
(*   - simpl. intro d. *)
(*     apply eisretr. *)
(*   - simpl. intros c d f. *)
(*     destruct isiso_F as [iseq_0 iseq_1]. *)
(*     rewrite (eisretr ((morphism_of F (d:=F^-1 d)))). *)
(*     refine ((double_transport_compose _ _ _ _ _ _)^ @ _). *)
(*     rewrite concat_Vp. rewrite concat_Vp. *)
(*     reflexivity. *)
(* Defined. *)

(* Definition cat_inv_to_iso {C D : PreCategory} *)
(*            (F : Functor C D) *)
(*            (G : Functor D C) *)
(*            : (F o G = 1)%functor -> (G o F = 1)%functor -> *)
(*              IsIso_Cat F. *)
(* Proof. *)
(*   intros rinv linv. *)
(*   assert (linv_obj : forall c : C, G (F c) = c). *)
(*   {intro c. change (G _0 (F _0 c))%object with ((G o F)%functor c). *)
(*    rewrite linv. reflexivity. } *)
(*   assert (rinv_obj : forall d : D, F (G d) = d). *)
(*   {intro d. change (F _0 (G _0 d))%object with ((F o G)%functor d). *)
(*    rewrite rinv. reflexivity. } *)

(*   assert (isequiv_F0 : IsEquiv F). *)
(*   {srapply @isequiv_adjointify. *)
(*    - exact G. *)
(*    - intro d. apply rinv_obj. *)
(*    - intro c. apply linv_obj. *)
(*   }  *)
(*   assert (isequiv_F1 : forall (a b : C), IsEquiv (morphism_of F (s := a) (d := b))). *)
(*   {intros a b. *)
(*    srapply @isequiv_adjointify. *)
(*    - intro f. *)
(*      apply (double_transport (morphism C) (linv_obj a) (linv_obj b)). *)
(*      apply (morphism_of G f). *)
(*    - intro f. *)
(*      transitivity (double_transport (morphism D) (morphism_of (F o G)%functor f). *)

(* srefine (@Build_IsIso_Cat C D F isequiv_f _). *)

(* srapply @ *)

(* (* A category is the sum of its components *) *)
(* Definition decompose_cat (C : PreCategory) : *)
(*   C  *)

(* Definition inclution_comp_cat (C : PreCategory) (c0 : pi0_cat C) : *)
(*            Functor (component_cat C c0) C. *)
(* Proof. *)
(*   srapply @Build_Functor. *)
(*   - exact pr1. *)
(*   - intros c d. exact idmap. *)
(*   - reflexivity. *)
(*   - reflexivity. *)
(* Defined. *)

(* Definition functor_cquot (C D : PreCategory) (F : Functor C D) *)
(*   : cquot C -> cquot D. *)
(* Proof. *)
(*   srapply @cquot_rec. *)
(*   - intro x. apply ccl. exact (F x). *)
(*   - intros a b f. simpl. *)
(*     apply ccleq. *)
(*     apply (morphism_of F f). *)
(*   - intro a. simpl. *)
(*     refine (_ @ ce D _). *)
(*     apply (ap (ccleq D)). *)
(*     apply identity_of. *)
(*   - intros a b c f g. simpl. *)
(*     refine (_ @ cconcat D _ _). *)
(*     apply (ap (ccleq D)). *)
(*     apply composition_of. *)
(* Defined. *)

Section Cquot_sum.
  (* move *)

  Definition cat_sum_pr1 (X : Type) {istrunc_X : IsTrunc 1 X} (C : X -> PreCategory)
    : Functor (cat_sum X C) (Core.groupoid_category X).
  Proof.
    srapply @Build_Functor.
    - exact pr1.
    - intros s d. exact pr1.
    - intros a b c f g. simpl. reflexivity.
    - intro c. simpl. reflexivity.
  Defined.

  Definition functor_cat_sum_id
             (X : Type) {istrunc_X : IsTrunc 1 X} (C D : X -> PreCategory)
    : (forall x : X, Functor (C x) (D x)) ->
      Functor (cat_sum X C) (cat_sum X D).
  Proof.
    intro F.
    srapply (univ_cat_sum _ C (cat_sum X D))^-1.
    intro x.
    refine (_ o (F x))%functor.
    apply include_summand.
  Defined.

  Definition cquot_unique (C : PreCategory) (Y : Type) {istrunc_Y : IsTrunc 1 Y}
             (F G : cquot C -> Y)
             (p0 : forall c : C, F (ccl _ c) = G (ccl _ c))
             (p1 : forall (c1 c2 : C) (f : morphism C c1 c2),
                 (p0 c1)^ @ ap F (ccleq _ f) @ (p0 c2) = ap G (ccleq _ f))
    : forall (c : cquot C), F c = G c.
  Proof.
    intro c. revert c.
    srapply @cquot_ind_set.
    - apply p0.
    - intros c1 c2 f.
      apply path_to_path_over.
      refine (transport_paths_FlFr _ _ @ _).
      destruct (p1 c1 c2 f).
      destruct (p0 c1). destruct (p0 c2).
      destruct (ccleq C f). reflexivity.
  Defined.

Definition cquot_sum (X : Type) {istrunc_X : IsTrunc 1 X} (C : X -> PreCategory)
  :  cquot (cat_sum X C) <~> {x : X & (cquot (C x))}.
Proof.
  srapply @equiv_adjointify.
  - apply (univ_cquot _ _)^-1.
    refine (cat_sum_to_groupoid _ _ o _)%functor.
    apply functor_cat_sum_id.
    intro x. apply include_in_cquot.
  - intros [x c]. revert c.
    apply functor_cquot. apply include_summand.
  - intros [x c].
    srefine
      (cquot_unique
         (C x) _
         (fun c => (univ_cquot (cat_sum X C) {x0 : X & cquot (C x0)})^-1
                     (cat_sum_to_groupoid
                        X (fun x0 : X => cquot (C x0)) o
                        functor_cat_sum_id X C
                        (fun x0 : X => Core.groupoid_category (cquot (C x0)))
                        (fun x0 : X => include_in_cquot (C x0)))%functor
                     (functor_cquot (include_summand X C x) c))
         (fun c => (x; c)) _ _ c) .
    + simpl. reflexivity.
    + intros c1 c2 f.
      rewrite concat_p1. rewrite concat_1p.
      rewrite (ap_compose (functor_cquot (include_summand X C x))).
      rewrite functor_cquot_beta_ccleq.
      rewrite univ_cquot_beta_ccleq. simpl.
      destruct (ccleq (C x) f). reflexivity.
  - intro c.
    (* assert *)
    (*   ((univ_cquot (cat_sum X C) {x : X & cquot (C x)})^-1 *)
    (*        (cat_sum_to_groupoid X (fun x : X => cquot (C x)) *)
    (*                             o functor_cat_sum_id X C *)
    (*                             (fun x : X => Core.groupoid_category (cquot (C x))) *)
    (*                             (fun x : X => include_in_cquot (C x)))%functor c *)
    (*    = (pr1 c; ccl _ (pr2 c))). *)

    srefine
      (cquot_unique
         (cat_sum X C) _
         (fun c
          => functor_cquot
               (include_summand X C
                 ((univ_cquot
                     (cat_sum X C)
                     {x : X &
                      cquot (C x)})^-1 (cat_sum_to_groupoid
                                          X
                                          (fun x : X => cquot (C x))
                                          o functor_cat_sum_id X C
                                          (fun x : X => Core.groupoid_category
                                                          (cquot (C x)))
                                          (fun x : X => include_in_cquot
                                                          (C x)))%functor c).1)
               ((univ_cquot
                   (cat_sum X C)
                   {x : X & cquot (C x)})^-1
                          (cat_sum_to_groupoid X (fun x : X => cquot (C x))
                                               o functor_cat_sum_id X C
                                               (fun x : X =>
                                                  Core.groupoid_category
                                                    (cquot (C x)))
                                               (fun x : X => include_in_cquot
                                                               (C x)))%functor c).2 )
                    idmap _ _ ).
    +  simpl. intro c.
       reflexivity.
    + intros [x1 c1] [x2 c2]. intro f.
      rewrite concat_1p. rewrite concat_p1.
      rewrite ap_idmap.
      rewrite (ap_compose (fun c =>
      destruct p. simpl in f.
      apply
simpl.

      rewrite (ap_compose _ (functor_cquot
       (include_summand X C
          ((univ_cquot (cat_sum X C) {x : X & cquot (C x)})^-1
             (cat_sum_to_groupoid X (fun x : X => cquot (C x))
              o functor_cat_sum_id X C (fun x : X => Core.groupoid_category (cquot (C x)))
                  (fun x : X => include_in_cquot (C x)))%functor c).1))).
      unfold functor_cquot.
      assert (ap (functor_cquot (include_summand X C x)) (ccleq (C x) f) =
              ccleq _

simpl.

    srapply @exist.
    + revert c.
      apply (univ_cquot _ _)^-1.
      apply cat_sum_pr1.
    + simpl.
      revert c.
      srapply @cquot_ind.
      *  simpl. intros [x c]. exact (ccl _ c).
      * simpl. intros [x1 c1] [x2 c2]. intros [p f]. destruct p. simpl in f.
        simpl.

    apply (univ_cat_sum _ _ _)^-1.

    intro x. refine (cat.inv_iso_map (iso_path_groupoid_cat_sum _ _) o _)%functor.
    refine (include_summand _ _ x o _)%functor.
    apply include_in_cquot.
  (* -  *)
  (*   srapply @cquot_rec. *)
  (*   + intros [x c]. exists x. *)
  (*     exact (ccl _ c). *)
  (*   + intros [x1 c1] [x2 c2]. intros [p f]. *)
  (*     srapply @path_sigma. *)
  (*     { exact p. } *)
  (*     destruct p. simpl. simpl in f. *)
  (*     apply ccleq. exact f. *)
  (*   + simpl. intros [x c]. *)
  (*     rewrite ce. reflexivity. *)
  (*   + intros [x1 c1] [x2 c2] [x3 c3]. simpl. *)
  (*     intros [p1 f1] [p2 f2]. destruct p2. destruct p1. simpl. *)
  (*     rewrite cconcat. destruct (ccleq (C x1) f2). *)
  (*     destruct (ccleq (C x1) f1). reflexivity. *)
  - intros [x c]. revert c.
    apply functor_cquot. apply include_summand.
  - intros [x c].

    revert c. apply apD10. apply (equiv_inj (univ_cquot _ {x0 : X & cquot (C x0)})).

    apply (equiv

    revert c. unfold functor_cquot.

    srapply @cquot_ind_set.
    + simpl. reflexivity.
    + simpl. intros c1 c2 f.
      srapply @path_to_path_over.

    apply (univ_cquot _ _)^-1.
    apply (univ_cat_sum _ _ _)^-1.
    intro x.
    refine (cat.inv_iso_map (iso_path_groupoid_cat_sum _ _) o _)%functor.
    refine (include_summand _ _ x o _)%functor.
    apply include_in_cquot.
  (* -  *)
  (*   srapply @Build_Functor. *)
  (*   + intro c. exists x. *)
  (*     apply ccl. exact c. *)
  (*   + intros c1 c2 f. simpl. *)
  (*     srapply @path_sigma. *)
  (*     { reflexivity. } *)
  (*     simpl. *)
  (*     apply ccleq. exact f. *)
  (*   + intros a b c f g. simpl. *)
  (*     refine (_ @ path_sigma_pp_pp _ _ _ _ _). simpl. *)
  (*     rewrite concat_1p. *)
  (*     apply (ap (path_sigma _ _ _ _)). *)
  (*     rewrite ap_idmap. *)
  (*     apply cconcat. *)
  (*   + intro c. simpl. rewrite ce. reflexivity. *)
  - intros [x c]. revert c.
    apply (univ_cquot _ _)^-1.
    refine (include_in_cquot _ o _)%functor.
    apply include_summand.
  - intros [x c].

    revert c. apply apD10. apply (equiv_inj (univ_cquot _ {x0 : X & cquot (C x0)})).

    srapply @cquot_ind_set.
    + intro c. simpl. reflexivity.
    + intros c1 c2 f. apply path_to_path_over.

      refine (transport_paths_FlFr (ccleq (C x) f) idpath @ _).

    unfold univ_cquot.
simpl.

simpl.
    apply (apD10 (A := X) (B := fun x => forall c : cquot (C x), ).
    srapply @path_sigma. { simpl.
    revert c.
    apply
      (equiv_inj (univ_cat_sum X C (Core.groupoid_category {x1 : X & cquot (C x1)}))).
    apply (equiv_inj (univ_cquot (cat_sum X C) {x1 : X & cquot (C x1)})).
    srapply @cquot_ind_set.
    + intro c. simpl. reflexivity.
    + intros c1 c2 f.
      apply path_to_path_over.
      refine

    srapply @cquot_rec.
    + simpl.
      intros [x c].
      exists x. exact (ccl (C x) c).
    + intros [x1 c1] [x2 c2].
      simpl. unfold cat_sum_morph.
      intros [p f]. destruct p. simpl in f.
      srapply @path_sigma. {reflexivity. }
      simpl. apply ccleq. exact f.
    + intros [x1 c1]. simpl.
      rewrite ce. reflexivity.
    + intros [x1 c1] [x2 c2] [x3 c3].
      intros [

Definition cquot_comp_to_comp_cquot (C : PreCategory) (c0 : pi0_cat C)
  : cquot (component_cat C c0) -> component (cquot C) (pi0_cat_cquot C c0).
Proof.
  intro x.
  srapply @exist.
  + revert x.
    apply functor_cquot.
    apply inclution_comp_cat.
  + simpl. revert x.
    srapply @cquot_ind_prop. intros [a p]. simpl.
    destruct p. reflexivity.
Defined.

Definition isequiv_cquot_comp_to_comp_cquot (C : PreCategory) (c0 : pi0_cat C)
           (* (c0 : Trunc 0 (cquot C)) *)
  : IsEquiv (cquot_comp_to_comp_cquot C c0). (* ((pi0_cat_cquot _)^-1 c0)). *)
Proof.
  revert c0.
  srefine (equiv_functor_forall_pf (pi0_cat_cquot C) _).
  intro c0.
  (* srefine (set_quotient_ind_prop _ _ _). *)

  (* (* srefine (Trunc_ind _ _). simpl. *) *)
  (* (* srefine (cquot_ind_prop _ _ _). simpl. *) *)
  (* intro c0. *)
  srapply @isequiv_adjointify.
  - unfold component.
    cut (
        {x : cquot C & tr x = c0} ->
        cquot (component_cat C ((pi0_cat_cquot C)^-1 c0))).
    { intro f. intros [x p]. apply f.
      exists x. refine (p @ _).
      apply eisretr. }
    intros [x p].  destruct p.
    revert x.
    srapply @cquot_ind.
    + intro c. simpl.
      apply ccl. exists c. reflexivity.
    + intros a b f. admit.
    + admit.
    + admit.
      simpl in p.

    destruct (eisretr (pi0_cat_cquot C) c0) in p.

  apply isequiv_fcontr.
  intros [x p].  revert p. revert x.
  srefine (cquot_ind_prop _ _ _). simpl.
  intros c p.
  srapply @BuildContr.
  - srapply @exist.
    + apply ccl. simpl. exists c.
      apply (equiv_inj (pi0_cat_cquot C)). exact p.
    + simpl.
      apply path_sigma_hprop. reflexivity.
  - intros [x q]. simpl in q.
    srapply @path_sigma.
    + simpl.

  revert p.
  apply
    (equiv_functor_forall_pf (equiv_moveR_equiv_V (f := pi0_cat_cquot C) (tr x) c0)).
  intros [].

  rewrite <- (eissect (equiv_moveR_equiv_V (f := pi0_cat_cquot C) (tr x) c0) p).
  destruct (equiv_moveR_equiv_V (f := pi0_cat_cquot C) (tr x) c0 p).
  clear p.
  unfold equiv_inv.
simpl.

Definition component_cquot (C : PreCategory) (c0 : pi0_cat C)
  : cquot (component_cat C c0) <~> component (cquot C) (pi0_cat_cquot C c0).
Proof.
  srapply @equiv_adjointify.
  - intro x.
    srapply @exist.
    + revert x.
      apply functor_cquot.
      apply inclution_comp_cat.
    + simpl. revert x.
      srapply @cquot_ind_prop. intros [a p]. simpl.
      destruct p. reflexivity.
  - intros [x p]. revert p.
    cut (((pi0_cat_cquot C)^-1 (tr x) = c0) -> cquot (component_cat C c0)).
    { intro f. intro p. apply f.
      refine (ap ((pi0_cat_cquot C)^-1) p @ _).
      apply eissect. }
    intros [].
    revert x.
    srapply @cquot_ind.
    + intro a. simpl. apply ccl.
      exists a. reflexivity.
    + intros a b f. simpl.

    srapply @cquot_rec.
    + simpl. intros [c p].
      exists (ccl C c).
      apply (ap
               (set_quotient_rec (morphism C)
                                 (fun c1 : C => tr (ccl C c1))
                                 (fun (x y : C)
                                      (f : morphism C x y) => ap tr (ccleq C f)))
               p).
    + simpl. intros [c p] [d q].
      simpl. intro f.
      apply (path_sigma _ (_;_) (_;_) (ccleq C f)).
      simpl.


(** * Theory of Sets : two type of ordinals
  Copyright INRIA (2013-2013) Marelle Team (Jose Grimm).
*)
(* $Id: ssete10.v,v 1.3 2018/09/04 07:58:00 grimm Exp $ *)

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat.
From gaia Require Export sset14 ssete9.

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

Module Ordinals9.

Fixpoint T1toB (x: T1) : Set :=
  if x is cons a n b then
     omega0 ^o (T1toB a) *o (nat_to_B n.+1) +o  (T1toB b)
  else \0o.

Lemma OS_succN n : ordinalp (nat_to_B n.+1).
Proof.  exact: (OS_nat (nat_to_B_Nat n.+1)). Qed.

Lemma OS_T1toB x : ordinalp (T1toB x).
Proof.
elim:x; first by apply:OS0.
move => a oa n b; apply:OS_sum2.
apply:(OS_prod2 (OS_pow OS_omega oa) (@OS_succN n)).
Qed.

Lemma T1toB_small x : T1toB x <o epsilon0.
Proof.
move: (ord_eps_p3 epsilon0p) => H.
elim:x.
   exact: (olt_ltT olt_0omega H).
move => a ha n b hb.
apply: (sum_lt_eps0 (prod_lt_eps0 (pow_lt_eps0 ha) (nat_to_B_Nat n.+1)) hb).
Qed.

Lemma T1toB_surjective x: x <o epsilon0 -> exists y, x = T1toB y.
Proof.
move => xo; move:(proj31_1 xo) => ox; move: xo.
case:(least_ordinal6 (fun z => z <o epsilon0 -> exists y, z = T1toB y) ox) =>//.
set z := least_ordinal _ _.
move => [oz Hz []] zo.
case: (ozero_dichot oz); first by move => ->; exists zero.
move => h; move: (CNF_simple_bdn2 h zo).
move:(the_CNF_simplP h).
set a := (P (the_CNF_simpl z)).
set b:= (P (Q (the_CNF_simpl z))).
set c:=(Q (Q (the_CNF_simpl z))).
move => ax [ha hb].
have ae:= olt_ltT ha zo.
have ce:=olt_ltT hb zo.
move/(oltP oz): ha => az.
move/(oltP oz): hb => cz.
move: (Hz _ az ae) => [a' a'v].
move: (Hz _ cz ce) => [c' c'v].
move: ax => [qa qb qc qd qe].
move: (nat_to_B_surjective qc) => [n' n'v].
by exists (cons a' n' c'); simpl; rewrite - n'v - a'v - c'v.
Qed.

Lemma T1toB_mon1 x y: T1nf x -> T1nf y ->
   x < y -> T1toB x <o T1toB y.
Proof.
have qa: forall n u v, ordinalp n ->
   u <o omega0^o n ->v <o  omega0^o n -> u +o v <o  omega0^o n.
    move => n u v on ux vx; apply: (indecomp_prop2 ux vx  (indecomp_prop4 on)).
have qb: forall n u m,  ordinalp n ->
  u <o  omega0^o n -> natp m -> u *o m <o  omega0^o n.
  move => n u m on ux nN; move:(proj31_1 ux) => ou.
  move: m nN; apply:Nat_induction.
    rewrite oprod0r; exact:(ole_ltT (ole0x ou) ux).
  move => m mN Hrec.
  rewrite (succ_of_nat mN) (oprod2_succ ou (OS_nat mN)).
  apply: (qa _ _ _ on Hrec ux).
move => nx ny; move:  (T1lenn y) ny (ny) nx.
move: {2 3} (y) => z zy nz; move: z nz x y zy.
apply:T1transfinite_induction.
case; first by move => _ _ x y; rewrite T1len0 => /eqP ->; rewrite T1ltn0.
move => za m zb nz Hrec.
case.
  case => // a n b _ _ _ _ /=.
  move:(@OS_T1toB a)(@OS_T1toB b) => oa ob.
  move: (OS_pow OS_omega oa) => op.
  move: (@succ_nz (nat_to_B n)) => snz.
  move:(NS_succ (nat_to_B_Nat n)) => n1.
  move:(OS_prod2 op (OS_nat n1)) => o2.
  apply: (ord_ne0_pos (OS_sum2 o2 ob)) => h.
  move: (proj1 (osum2_zero o2 ob h)).
  by move: (oprod2_nz op (OS_nat n1) (oopow_nz oa) snz).
move => a' n' b'; case => // a n b ha /=.
move => /and3P [na nb etc] /and3P [na' nb' etc'].
have ob := (@OS_T1toB b).
have oa:=(@OS_T1toB a).
have ox:= OS_pow OS_omega oa.
set x := omega0 ^o T1toB a.
have hb:=(T1lt_le_trans (head_lt_cons a n b) ha).
have l1: x <=o x *o csucc(nat_to_B n) +o T1toB b.
  have nN:=nat_to_B_Nat n.
  have on := (OS_nat nN).
  rewrite (Nsucc_rw nN)  csumC - (osum2_2int NS1 nN) (oprodD OS1 on ox).
  rewrite -/x (oprod1r ox) - (osumA ox (OS_prod2 ox on) ob).
  apply: (osum_Mle0 ox (OS_sum2  (OS_prod2 ox on) ob)).
have rb: phi0 za <= cons za m zb.
  rewrite T1le_consE eqxx T1le0n T1ltnn; case m => //.
have : a' <= a -> T1toB b' <o (omega0 ^o T1toB a').
  move:nb' etc' ha.
  case: b'; first by move => _ _ _ _;apply:oopow_pos; apply:OS_T1toB.
  move => a'' n'' b'' nb''; rewrite phi0_lt1 /= => ha hc aa'.
  move: nb'' => /= /and3P [na'' nb'' etc''].
  move: (T1le_lt_trans aa' hb) => ra.
  move: (Hrec a' na' ra a'' a' (T1lenn a') na' na'' ha) => l2.
  have nx:natp (csucc (nat_to_B n'')) by apply:NS_succ; apply:nat_to_B_Nat.
  have rc: phi0 a'' < cons za m zb.
    move:(T1lt_le_trans ha (T1le_trans aa' (T1le_cons_le hc))).
    rewrite -phi0_lt => rc; exact: (T1lt_le_trans rc rb).
  have l3: T1toB b'' <o omega0 ^o T1toB a''.
     move:na''; rewrite -nf_phi0 => nsa''.
     have op:= (OS_pow OS_omega (proj31_1 l2)).
     move: (Hrec _ nsa'' rc _ _  (T1lenn (phi0 a'')) nsa'' nb'' etc'').
     by rewrite /phi0 /= succ_zero (oprod1r op) (osum0r op).
  have l4:= (opow_Mo_lt l2).
  move: (olt_ltT l3 l4) => l5.
  apply: (qa _ _ _ (@OS_T1toB a') (qb _ _ _ (@OS_T1toB a') l4 nx) l5).
case: (T1ltgtP a' a) => //.
  move => aa' HR _; apply:olt_leT l1.
  move: (Hrec a na hb a' a (T1lenn a) na na' aa') => /opow_Mo_lt l2.
  have ns: natp (csucc (nat_to_B n')) by apply:NS_succ; apply:nat_to_B_Nat.
  move: (HR (T1ltW aa')) => hr1.
  apply: qa; [exact oa | by apply: qb  |  exact: (olt_ltT hr1 l2)].
move => -> HR; case:(ltngtP n' n) => //.
  move => nn _; rewrite -/x - (subnKC nn) (nat_to_B_sum).
  have hc: natp (csucc (nat_to_B n')) by  apply:NS_succ; apply:nat_to_B_Nat.
  have hd:= (NS_succ hc).
  have he: natp (nat_to_B (n - n'.+1)) by apply:nat_to_B_Nat.
  have o1 := (OS_nat hd).
  have o2 := (OS_nat he).
  have o3:= (OS_nat hc).
  set u := x *o csucc (csucc (nat_to_B n')).
  set v := (x *o nat_to_B (n - n'.+1) +o T1toB b).
  have ou := (OS_prod2 ox o1).
  have ov1:= (OS_prod2 ox o2).
  have hf:= (osum_Mle0 ou (OS_sum2 ov1 ob)).
  rewrite - nat_to_B_succ - (csum_Sn _ hc) - (osum2_2int hd he).
  rewrite (oprodD o1 o2 ox)- (osumA ou (OS_prod2 ox o2) ob).
  apply: (olt_leT _ hf).
  move:(osum_Meqlt (HR (T1lenn a)) (OS_prod2 ox o3)).
  by rewrite -(oprod2_succ ox o3) - (succ_of_nat hc).
move => -> lbb.
move:(T1le_cons_le ha); rewrite - phi0_le => h; move:(T1le_trans h rb) => rc.
move:(Hrec b nb (T1lt_le_trans etc rc) b' b (T1lenn b) nb nb' lbb) => h2.
apply:(osum_Meqlt h2); apply:(OS_prod2 ox (@OS_succN n)).
Qed.

Lemma T1toB_mon2 x y: T1nf x -> T1nf y ->
   (x < y <-> T1toB x <o T1toB y).
Proof.
move => ha hb.
case:T1ltgtP => h.
  by split =>//; move:(T1toB_mon1 hb ha h) => [hc _] /(oleNgt hc).
  split =>// _; exact:(T1toB_mon1 ha hb h).
by rewrite h; split => // [] [_].
Qed.

Lemma T1toB_injective x y: T1nf x -> T1nf y ->
 T1toB x = T1toB y -> x = y.
Proof.
move => ha hb.
case /or3P: (T1lt_trichotomy x y).
+ by move/(T1toB_mon1 ha hb) => [].
+ by move /eqP.
+ by move/(T1toB_mon1 hb ha) => [_ /nesym].
Qed.

Export Gamma0.

Fixpoint T2toB (x: T2) : Set :=
  if x is cons a b n c then
    Spsi (T2toB a) (T2toB b)  *o (nat_to_B n.+1) +o  (T2toB c)
  else \0o.

Lemma T2toB_small x : T2toB x <o Gamma_0.
Proof.
elim:x.
  rewrite /= - Gamma0_epsilon; apply:(oopow_pos OS_Gamma_0).
by move => a ha b hb n c hc; apply:T2_to_bourbaki_small.
Qed.

Lemma OS_T2toB x : ordinalp (T2toB x).
Proof.  exact: (proj31_1 (T2toB_small x)). Qed.

Lemma T2le_cons_le a b n c a' b' n' c':
   (cons a b n c <= cons a' b' n' c') -> [a,b] <= [a',b'].
Proof.
rewrite T2le_consE - T2lt_psi.
case h: ([a, b] < [a', b']); first by  move => _; exact :(T2ltW h).
case h1: ((a == a') && (b == b')) => // _.
by move/andP:h1 => [/eqP -> /eqP ->]; apply: T2lenn.
Qed.

Lemma T2toB_mon1 x y: T2nf x -> T2nf y ->
   x < y -> T2toB x <o T2toB y.
Proof.
have HS:forall a b, Spsi (T2toB a) (T2toB b) = T2toB [a, b].
  move => a b.
  have ox :=(OS_Spsi (@OS_T2toB a) (@OS_T2toB b)).
  by rewrite /= succ_zero (oprod1r ox) (osum0r ox).
set n := (size x + size y).+1.
move: (leqnn n); rewrite {1}/n; move: n.
move => n; elim: n x y; first by move  => a b//;rewrite ltn0.
move => m Hrec [].
  move=> y _ _ _; case:y => // a b n c _ /=.
  move: (@Cardinal.succ_nz (nat_to_B n)) => snz.
  move:(NS_succ (nat_to_B_Nat n)) => n1.
  move:(@OS_T2toB a)(@OS_T2toB b) (@OS_T2toB c) => oa ob oc.
  move: (OS_Spsi oa ob) => ozx.
  move:(OS_prod2 ozx (OS_nat n1)) => o2.
  apply: (ord_ne0_pos (OS_sum2 o2 oc)) => h.
  move: (proj1 (osum2_zero o2 oc h)).
  by move: (oprod2_nz ozx (OS_nat n1) (Spsi_nz oa ob) snz).
move => a b n c; case => // a' b' n' c' sz /=.
move: sz; rewrite ltnS => la.
move => /and4P[na nb nc etc] /and4P[na' nb' nc' etc'].
move:(@OS_T2toB a) (@OS_T2toB b) (@OS_T2toB c) => oa ob oc.
move:(@OS_T2toB a') (@OS_T2toB b') (@OS_T2toB c') => oa' ob' oc'.
set x := Spsi (T2toB a) (T2toB b).
set x' := Spsi (T2toB a') (T2toB b').
have ox':=(OS_Spsi oa' ob').
have nN':=nat_to_B_Nat n'.
have oxsn: ordinalp (x' *o csucc (nat_to_B n')).
  by apply:(OS_prod2 ox'); apply:OS_nat; apply:NS_succ.
have l1: x' <=o x' *o csucc(nat_to_B n') +o T2toB c'.
  have on := (OS_nat nN').
  rewrite (Nsucc_rw nN')  csumC - (osum2_2int NS1 nN') (oprodD OS1 on ox').
  rewrite -/x' (oprod1r ox') - (osumA ox' (OS_prod2 ox' on) oc').
  apply: (osum_Mle0 ox' (OS_sum2 (OS_prod2 ox' on) oc')).
move => leb.
have lew1:= (T2le_cons_le (T2ltW leb)).
move: (size_prop1 a b n c) => [pa pb pc pd].
move: (size_prop1 a' b' n' c') => [pa' pb' pc' pd'].
have nab': T2nf [a', b'] by rewrite nf_psi na' nb'.
have nab: T2nf [a, b] by rewrite nf_psi na nb.
have HR: T2toB c <o x'.
  move: (T2lt_le_trans etc lew1);rewrite /x' HS; apply: Hrec => //.
  apply:leq_trans la; rewrite ltn_add_le //.
move: leb;rewrite T2lt_consE /x'/x.
case h1: (lt_psi a b a' b'); last first.
  case h2: ((a == a') && (b == b')) => //.
  rewrite /x;move/andP: h2 => [/eqP -> /eqP ->];rewrite -/x'.
  case:(ltngtP n n') => //; last first.
    move => -> cc; apply:(osum_Meqlt _ oxsn).
    move:cc; apply: Hrec=> //; apply:leq_trans la; rewrite ltn_add_le //.
    exact:(ltnW pc').
  move => nn _; rewrite  - (subnKC nn) (nat_to_B_sum).
  have hc: natp (csucc (nat_to_B n)) by  apply:NS_succ; apply:nat_to_B_Nat.
  have hd:= (NS_succ hc).
  have he: natp (nat_to_B (n' - n.+1)) by apply:nat_to_B_Nat.
  have o1 := (OS_nat hd).
  have o2 := (OS_nat he).
  have o3:= (OS_nat hc).
  rewrite - (csum_Sn _ hc) - (osum2_2int hd he) (oprodD o1 o2 ox').
  rewrite - (osumA (OS_prod2 ox' o1) (OS_prod2 ox' o2) oc').
  rewrite -/x';set u := x' *o csucc (csucc (nat_to_B n)).
  have ou: ordinalp u by apply: OS_prod2 => //.
  have res1: x' *o csucc (nat_to_B n) +o T2toB c <o u.
    rewrite /u (succ_of_nat hc) (oprod2_succ ox' o3).
    by apply:(osum_Meqlt HR); apply: OS_prod2.
  apply:(olt_leT res1); apply:osum_Mle0 => //.
  by apply: OS_sum2 => //; apply:OS_prod2.
move => _; apply:(olt_leT _ l1).
suff: x <o x'.
   move => w3; apply: Spsi_indecomp_rec => //.
have HR1: a' < a -> T2toB a' <o T2toB a.
    apply: Hrec => //; apply:leq_trans la.
    rewrite addnC ltn_add_le //; exact:(ltnW pa').
move:h1; case/orP; last first.
  move /andP => [/HR1 ha /eqP hb].
  apply:(Spsi_cpc ob ha);rewrite HS hb; fprops.
case /orP; last first.
  move => /andP [/HR1 ha hb].
  have [Rb _]: T2toB [a,b] <o T2toB b'.
    apply: Hrec => //; apply:leq_trans la; rewrite ltn_add_el //.
  by apply:(Spsi_cpc ob ha); rewrite HS.
case /orP; last first.
  rewrite /x/x';move /andP => [/eqP -> qb];apply:Spsi_cpb => //.
  apply:Hrec => //;apply:leq_trans la; rewrite ltn_add_le //; exact:(ltnW pb').
move => /andP [ha hb].
have hc:T2toB a <o T2toB a'.
  apply: Hrec => //; apply:leq_trans la;rewrite ltn_add_le //;exact:(ltnW pa').
apply: Spsi_cpa => //; rewrite HS; apply: Hrec => //.
apply:leq_trans la; rewrite ltn_add_le //.
Qed.

Lemma T2toB_mon2 x y: T2nf x -> T2nf y ->
   (x < y <-> T2toB x <o T2toB y).
Proof.
move => ha hb.
case:T2ltgtP => h.
  by split =>//; move:(T2toB_mon1 hb ha h) => [hc _] => /(oleNgt hc).
  split =>// _; exact:(T2toB_mon1 ha hb h).
by rewrite h; split => // [] [_].
Qed.

Lemma T2toB_injective x y: T2nf x -> T2nf y ->
 T2toB x = T2toB y -> x = y.
Proof.
move => ha hb.
case /or3P: (T2lt_trichotomy x y).
+ by move/(T2toB_mon1 ha hb) => [].
+ by move /eqP.
+ by move/(T2toB_mon1 hb ha) => [_ /nesym].
Qed.

Lemma T2toB_surjective x: x <o Gamma_0 -> exists2 y, T2nf y & x = T2toB y.
Proof.
move => xo; move:(proj31_1 xo) => ox; move: xo.
case:(least_ordinal6 (fun z => z <o Gamma_0 -> exists2 y, T2nf y  &z = T2toB y) ox) =>//.
set z := least_ordinal _ _.
move => [oz Hz []] zo.
case: (ozero_dichot oz); first by move => ->; exists zero.
move => zp.
move: (the_CNF_simplP zp) (CNF_simple_bdn3 zp zo).
set aa := (P (the_CNF_simpl z)); set n := (P (Q (the_CNF_simpl z)));
set c := (Q (Q (the_CNF_simpl z))); set w := inv_psi_omega _.
move => h1  [ra rb rc rd].
move:(CNF_simple_p2 h1) =>[_ cz _].
move: h1 => [qa qb qc qd qe].
move: (nat_to_B_surjective qc) => [n' n'v].
have h: forall t, t <o z -> exists2 y : T2, T2nf y & t = T2toB y.
   move => t ta; apply: Hz; [by apply/(oltP oz) |  exact: (olt_ltT ta zo) ].
move: (h _ rb) => [A an ap].
move: (h _ rc) => [B bn bp].
move: (h _ cz) => [C cn cp].
exists (cons A B n' C); last by rewrite /= - ap -bp - cp - n'v rd qd.
have ha: T2nf [A, B] by rewrite nf_psi an bn.
have hb:= (OS_pow OS_omega qa).
rewrite /= an bn cn /=; apply /(T2toB_mon2 cn ha).
move: qe; rewrite {2} /T2toB -/T2toB - ap - bp - cp rd /nat_to_B succ_zero.
by rewrite oprod1r // osum0r.
Qed.

(** first try *)

(* demo

Lemma Ex1: forall a:T1, inc (Ro a) T1.
Proof. by move => a; apply:R_inc. Qed.

Lemma Ex2: forall a b:T1, Ro a = Ro b -> a = b.
Proof. by move => a b ; apply:R_inj. Qed.

Lemma Ex3: forall (b:Set)(Ha:inc b T1), Ro (Bo Ha) = b.
Proof. by move => b; apply:B_eq. Qed.

Lemma Ex4: forall (a:T1)(Ha:inc (Ro a) T1), (Bo Ha) = a.
Proof. by move => a; apply:B_back. Qed.

*)

Definition  set_to_T1 x := match  (ixm (inc x T1) )  with
 | inl hx => Bo hx
 | inr _ => CantorOrdinal.zero end.

Lemma set_to_T1_pr x (Hx: inc x T1) : set_to_T1 x = Bo Hx.
Proof.
rewrite /set_to_T1;case: (ixm (inc x T1)) => // Hy; apply: R_inj.
by rewrite (B_eq Hx) (B_eq Hy).
Qed.

Lemma set_to_T1_inj x y: inc x T1 -> inc y T1 ->
   set_to_T1 x = set_to_T1 y -> x = y.
Proof.
move => ha hb.
by rewrite !set_to_T1_pr - {2} (B_eq ha) - {2} (B_eq hb) => ->.
Qed.

Definition ST1_le x y :=
  [/\ inc x T1, inc y T1 & set_to_T1 x <=  set_to_T1 y] %ca.

Definition ST1_order := graph_on ST1_le T1.

Lemma ST1_osr: order_on ST1_order T1.
Proof.
have rr: forall a, inc a T1 -> (ST1_le a a) by move => h; split => //.
move: (graph_on_sr rr); rewrite -/ ST1_order => st; split => //.
apply:order_from_rel; split.
+ move => y x t [xE yE ha] [_ zE /(T1le_trans ha) hb]; split => //.
+ move => x y [xE yE ha][_ _ hb].
  by apply:set_to_T1_inj=> //; apply/eqP; rewrite T1eq_le ha hb.
+ by move =>  u v [uE vE _]; split; fprops.
Qed.

Lemma ST1_leP x y: gle ST1_order x y <->   ST1_le x y.
Proof.
split; first by  move/graph_on_P1 => [].
by move => h; move:(h) =>[ha hb _]; apply/graph_on_P1.
Qed.

Definition T1N := Zo T1 (fun z => T1nf (set_to_T1 z)).

Definition STN_order:= induced_order  ST1_order T1N.

Lemma STN_osr: order_on STN_order T1N.
Proof.
move: ST1_osr => [ha hb].
apply:iorder_osr => //; rewrite hb; apply:Zo_S.
Qed.

Lemma STN_tor: total_order STN_order.
Proof.
move: STN_osr => [ha hb]; split => //; rewrite hb => x y xE yE.
have s1: sub T1N T1 by apply: Zo_S.
move:(s1 _ xE)(s1 _ yE) => x1 y1.
case /orP: (T1le_total(set_to_T1 x)(set_to_T1 y)) => h.
+ left; apply/iorder_gle0P => //; apply/ ST1_leP; split => //.
+ right; apply/iorder_gle0P => //; apply/ ST1_leP; split => //.
Qed.

Lemma STN_wosr: worder_on STN_order T1N.
Proof.
move: STN_osr => [ha hb]; split => //.
case: (total_order_worder_dichot STN_tor) => // [] [f [fgf df rf fd]].
case:(not_decreasing nf_Wf).
rewrite hb in rf.
have hc: forall n, natp n -> inc (Vg f n) T1N.
   move => n nN; apply:rf; apply/(range_gP fgf); exists n => //; ue.
pose g n := (set_to_T1 (Vg f (nat_to_B n))).
exists g; move => i; rewrite /restrict.
have sT: sub T1N T1 by apply:Zo_S.
move:  (nat_to_B_Nat i)  (nat_to_B_Nat i.+1) => aN bN.
have lt1: (nat_to_B i) <c (nat_to_B i.+1).
  by rewrite - nat_to_B_succ; apply:cltS.
move:(hc _ aN) (hc _ bN) => hu hv.
move:(hu)(hv)=> /Zo_P [aT1 Na] /Zo_P [bT1 Nb]; split => //.
move:(fd _ _ aN bN lt1) => [].
move/(iorder_gle0P _ hv hu) /ST1_leP => [_ _ sa] sb.
rewrite T1lt_neAle /g sa andbT; apply/eqP => h; case sb.
by apply:set_to_T1_inj.
Qed.

Definition STN_iso:= (the_ordinal_iso STN_order).
Definition ord_T1:= (ordinal STN_order).

Lemma  STN_iso_pr:  order_isomorphism STN_iso (ordinal_o ord_T1) STN_order.
Proof. exact: (the_ordinal_iso1 (proj1 STN_wosr)).  Qed.

Parameter T1graph_aux: Set.
Axiom T1graph_o1 :
   (forall a b (Ha: inc a T1) (Hb: inc b T1), inc (J a b)  T1graph_aux <->
      (Bo Ha) <= (Bo  Hb))%ca.

Definition T1graph := T1graph_aux \cap (coarse T1).

Lemma T1graph_p1 a b: (a <= b)%ca -> inc (J (Ro a) (Ro b)) T1graph.
Proof.
move => lab.
apply/setI2_P; split.
  by apply/(T1graph_o1 (R_inc a) (R_inc b)); rewrite !B_back.
by apply: setXp_i; apply: R_inc.
Qed.

Lemma T1graph_p2 x: inc x T1graph -> [/\ pairp x, inc (P x) T1 & inc (Q x) T1].
Proof. by move /setI2_P => [_ /setX_P]. Qed.

Lemma T1graph_p3 x (H:inc x T1graph)
     (Ha:= proj32 (T1graph_p2 H)) (Hb:= proj33 (T1graph_p2 H)):
     ((Bo Ha) <= (Bo Hb))%ca.
Proof.
apply/(T1graph_o1 Ha Hb); rewrite ( proj31 (T1graph_p2 H)).
by move /setI2_P : (H) => [].
Qed.

Lemma T1graph_o: order_on  T1graph T1.
Proof.
have ha: sgraph T1graph.
  by move => t /setI2_P [_ /setX_P []].
have rr: forall t, inc t T1 -> related T1graph t t.
  by move => t h;  move:(T1graph_p1(T1lenn (Bo h)));  rewrite B_eq.
have hb: substrate T1graph = T1.
   set_extens t.
     by case/(substrate_P ha) => [] [y /T1graph_p2 []]; aw.
   move => /rr; apply:arg1_sr.
have hc: reflexivep T1graph by move => t; rewrite hb; apply: rr.
have hd: antisymmetricp T1graph.
  move => u v hu hv; move:(T1graph_p3 hu) (T1graph_p3 hv) => /=.
  set a := Bo _; set b := Bo _.
  set a' := Bo _; set b' := Bo _.
  have ea: u = Ro a by rewrite (B_eq (proj32 (T1graph_p2 hu))); aw.
  have eb: v = Ro b by rewrite (B_eq (proj33 (T1graph_p2 hu))); aw.
  have : v = Ro a' by rewrite (B_eq (proj32 (T1graph_p2 hv))); aw.
  have : u = Ro b' by rewrite (B_eq (proj33 (T1graph_p2 hv))); aw.
  rewrite ea eb => ec ed; rewrite - (R_inj ec)  - (R_inj ed) => l1 l2.
  have -> // : a = b by apply/eqP; rewrite T1eq_le l1 l2.
have he:transitivep T1graph.
  move => v u w hu hv.
  move:(T1graph_p3 hu) (T1graph_p3 hv) => /=.
  set a := Bo _; set b := Bo _; set c := Bo _; set d := Bo _.
  have ea: u = Ro a by rewrite (B_eq (proj32 (T1graph_p2 hu))); aw.
  have eb: v = Ro b by rewrite (B_eq (proj33 (T1graph_p2 hu))); aw.
  have: v = Ro c by rewrite (B_eq (proj32 (T1graph_p2 hv))); aw.
  have ed: w = Ro d by rewrite (B_eq (proj33 (T1graph_p2 hv))); aw.
  rewrite eb => ec;  rewrite - (R_inj ec) => ab bd.
  by move:(T1graph_p1 (T1le_trans ab bd)); rewrite - ea - ed.
by split.
Qed.

End  Ordinals9.


From Undecidability.L Require Import L Tactics.LTactics.
From Undecidability.L.Datatypes Require Import LNat LProd Lists LTerm LOptions.

From Complexity.L.AbstractMachines Require Import FunctionalDefinitions AbstractHeapMachineDef.

Require Import Undecidability.L.AbstractMachines.LargestVar.

From Undecidability.L Require Import Prelim.LoopSum Functions.LoopSum Functions.UnboundIteration.
Import Nat.

#[export]
Instance termT_max : computableTime' max (fun x _ => (5,fun y _ => (min x y * 15 + 8,tt))).
Proof.
  extract. fold max. solverec.
Qed.
Import L.
Definition largestVarTR' '(stack,res) : (list term * nat) + nat :=
  match stack with
    [] => inr res
  | s::stack =>
    match s with
      var n => inl (stack,max n res)
    | app s t => inl (s::t::stack,res)
    | lam s => inl (s::stack,res)
    end
  end.

Fixpoint largestVarTR'_fuel (s:term) : nat :=
  match s with
    var _ => 1
  | app s t => 1 + (largestVarTR'_fuel s + largestVarTR'_fuel t)
  | lam s => 1 + largestVarTR'_fuel s
  end.

Lemma largestVarTR'_correct stack res s k:
  loopSum (largestVarTR'_fuel s + k) largestVarTR' (s::stack,res)
  = loopSum k largestVarTR' (stack,max (largestVar s) res).
Proof.
  induction s in res,stack,k |- *.
  all:cbn.
  -reflexivity.
  -rewrite <- !Nat.add_assoc. cbn.
   rewrite IHs1, IHs2. easy.
  -rewrite IHs. easy.
Qed.

Lemma largestVarTR_correct s:
  loopSum (largestVarTR'_fuel s + 1) largestVarTR' ([s],0) = Some (largestVar s).
Proof.
  rewrite largestVarTR'_correct. cbn. easy.
Qed.

#[export]
Instance termT_largestVarTR' : computableTime' largestVarTR'
                                           (fun x _ => (let '(stack,res) := x in
                                                    match stack with
                                                      var n ::_ =>  n*15
                                                    | _ => 0
                                                    end + 31,tt)).
Proof.
 extract. solverec.
Qed.

Lemma largestVarTR'_fuel_leq_largestVar s : largestVarTR'_fuel s <= size s.
Proof.
  induction s;cbn [size largestVarTR'_fuel];try Lia.lia.
Qed.

#[export]
Instance termT_largestVar : computableTime' largestVar (fun s _ => ((40 * size s) +46,tt)).
Proof.
  eexists.
  eapply computesTime_timeLeq.

  2:{ unshelve (eapply uiter_total_instanceTime with (1 := largestVarTR_correct) (preprocessT:=(fun _ _ => (5,tt)))).
      { extract. solverec. }
  }
  split. 2:exact Logic.I.
  cbn [fst].
  erewrite uiterTime_bound_recRel with (iterT := fun _ '(stack,res) => ((sumn (map size stack)) * 40
                                                                   + 40))
                                       (P:= fun n x => True).
  { cbn [length map sumn]. Lia.lia. }
  {intros n [stack res] H. cbn.
   destruct stack as [|[[]| |]].
   2-5:split;[easy|].
   all:cbn [length map sumn largestVarTR'_fuel size];try Lia.lia.
  }
  all:easy.
Qed.


Require Import Bool.
Require Import vsequent.

Lemma negl_preserves_val : forall b0 b1 b2,
implb (andb (negb b0) b1) b2 = implb b1 (orb b0 b2).
Proof.
intros b0 b1 b2.
destruct b0; destruct b1; destruct b2; auto.
Qed.

Lemma negr_preserves_val : forall b0 b1 b2,
implb (andb b0 b1) b2 = implb b1 (orb (negb b0) b2).
Proof.
intros b0 b1 b2.
destruct b0; destruct b1; destruct b2; auto.
Qed.

Lemma eval_preserves_val_neg_l : forall c p l r b,
seq_val c (seq (seq_l_cons (p_neg p) l) r) = Some b ->
seq_val c (seq l (seq_r_cons p r)) = Some b.
Proof.
intros c p l r b Heq.
apply (satisfying_ctx_l c (seq_l_cons (p_neg p) l) r b) in Heq.
destruct Heq as [ b1 [ b2 [ Hl [ Hr Himpl ] ] ] ].
case_eq (prop_val c p).
- intros b0 Hprop.
  apply prop_val_neg_b in Hprop as Hprop_neg.
  rewrite seq_l_val_equation in Hl.
  rewrite Hprop_neg in Hl.
  unfold seq_val.
  rewrite (seq_r_val_lem c p r b2 b0).
  + case_eq (seq_l_val c l).
    * intros b3 Hl'.
      rewrite Hl' in Hl. inversion Hl. subst.
      rewrite negl_preserves_val. reflexivity.
    * intro. rewrite H in Hl. discriminate.
  + assumption.
  + assumption.
- intros Hprop. rewrite seq_l_val_equation in Hl.
  apply prop_val_neg_n in Hprop.
  rewrite Hprop in Hl. discriminate.
Qed.

Lemma eval_preserves_val_neg_r : forall c p l r b,
seq_val c (seq l (seq_r_cons (p_neg p) r)) = Some b ->
seq_val c (seq (seq_l_cons p l) r) = Some b.
Proof.
intros c p l r b Heq.
apply (satisfying_ctx_l c l (seq_r_cons (p_neg p) r) b) in Heq.
destruct Heq as [ b1 [ b2 [ Hl [ Hr Himpl ] ] ] ].
case_eq (prop_val c p).
- intros b0 Hprop.
  apply prop_val_neg_b in Hprop as Hprop_neg.
  rewrite seq_r_val_equation in Hr.
  rewrite Hprop_neg in Hr.
  unfold seq_val.
  rewrite (seq_l_val_lem c p l b1 b0).
  + case_eq (seq_r_val c r).
    * intros b3 Hr'.
      rewrite Hr' in Hr. inversion Hr. subst.
      rewrite negr_preserves_val. reflexivity.
    * intro. rewrite H in Hr. discriminate.
  + assumption.
  + assumption.
- intros Hprop. rewrite seq_r_val_equation in Hr.
  apply prop_val_neg_n in Hprop.
  rewrite Hprop in Hr. discriminate.
Qed.

Lemma eval_preserves_val_or_r : forall c p0 p1 l r b,
seq_val c (seq l (seq_r_cons (p_or p0 p1) r)) = Some b ->
seq_val c (seq l (seq_r_cons p0 (seq_r_cons p1 r))) = Some b.
Proof.
intros c p0 p1 l r b Heq.
apply (satisfying_ctx_l c l (seq_r_cons (p_or p0 p1) r)) in Heq.
destruct Heq as [ b0 [ b1 [ Hl [ Hr Himpl ] ] ] ].
apply (satisfying_ctx_r c l (seq_r_cons p0 (seq_r_cons p1 r)) b b0 b1).
repeat split.
- assumption.
- case_eq (prop_val c p1); case_eq (prop_val c p0).
  + intros b2 Hprop0 b3 Hprop1.
    apply (prop_val_or_b c p0 p1 b2 b3) in Hprop0 as Hprop2.
    rewrite seq_r_val_equation. rewrite seq_r_val_equation.
    rewrite Hprop0. rewrite Hprop1.
    rewrite seq_r_val_equation in Hr. rewrite Hprop2 in Hr.
    revert Hr. case_eq (seq_r_val c r).
    * intros b4 Hr Hor.
      inversion Hor. rewrite <- (orb_assoc b2 b3 b4). reflexivity.
    * auto.
    * assumption.
  + intros Hprop0. apply (prop_val_or_n_l c p0 p1) in Hprop0.
    rewrite seq_r_val_equation in Hr. rewrite Hprop0 in Hr. discriminate.
  + intros Hprop0 b2 Hprop1. apply (prop_val_or_n_r c p0 p1) in Hprop1.
    rewrite seq_r_val_equation in Hr. rewrite Hprop1 in Hr. discriminate.
  + intros Hprop0. apply (prop_val_or_n_l c p0 p1) in Hprop0.
    rewrite seq_r_val_equation in Hr. rewrite Hprop0 in Hr. discriminate.
- assumption.
Qed.

Lemma eval_preserves_val_or_l : forall c p0 p1 l r b0 b1 b2,
seq_val c (seq (seq_l_cons (p_or p0 p1) l) r) = Some b0 ->
seq_val c (seq (seq_l_cons p0 l) r) = Some b1 ->
seq_val c (seq (seq_l_cons p1 l) r) = Some b2 ->
b0 = andb b1 b2.
Proof.
intros c p0 p1 l r b0 b1 b2 Heq0 Heq1 Heq2.
apply (satisfying_ctx_l c (seq_l_cons (p_or p0 p1) l) r) in Heq0.
destruct Heq0 as [ b00 [ b01 [ Hl0 [ Hr0 Himpl0 ] ] ] ].
apply (satisfying_ctx_l c (seq_l_cons p0 l) r) in Heq1.
destruct Heq1 as [ b10 [ b11 [ Hl1 [ Hr1 Himpl1 ] ] ] ].
apply (satisfying_ctx_l c (seq_l_cons p1 l) r) in Heq2.
destruct Heq2 as [ b20 [ b21 [ Hl2 [ Hr2 Himpl2 ] ] ] ].
subst. rewrite Hr0 in Hr1. inversion Hr1. rewrite Hr2 in Hr0. inversion Hr0. rewrite H0.
clear H0 H1 Hr0 Hr1 Hr2.
case_eq (prop_val c p1); case_eq (prop_val c p0).
- intros b0 Hprop0 b1 Hprop1.
  apply (prop_val_or_b c p0 p1 b0 b1) in Hprop0 as Hprop2.
  rewrite seq_l_val_equation in Hl0. rewrite Hprop2 in Hl0.
  rewrite seq_l_val_equation in Hl1. rewrite Hprop0 in Hl1.
  rewrite seq_l_val_equation in Hl2. rewrite Hprop1 in Hl2.
  case_eq (seq_l_val c l).
  + intros b Hseql. rewrite Hseql in Hl0. rewrite Hseql in Hl1. rewrite Hseql in Hl2.
    inversion Hl0. inversion Hl1. inversion Hl2. clear Hl0 Hl1 Hl2.
    destruct b00; destruct b01; destruct b0; destruct b1;
    destruct b; destruct b21; destruct b10; destruct b11; auto.
  + intros Hseql. rewrite Hseql in Hl0. discriminate.
  + assumption.
- intros Hprop.
  rewrite seq_l_val_equation in Hl1. rewrite Hprop in Hl1. discriminate.
- intros b Hprop0 Hprop1.
  rewrite seq_l_val_equation in Hl2. rewrite Hprop1 in Hl2. discriminate.
- intros Hprop.
  rewrite seq_l_val_equation in Hl1. rewrite Hprop in Hl1. discriminate.
Qed.

Lemma eval_preserves_val_impl_r : forall c p0 p1 l r b,
seq_val c (seq l (seq_r_cons (p_impl p0 p1) r)) = Some b ->
seq_val c (seq (seq_l_cons p0 l) (seq_r_cons p1 r)) = Some b.
Proof.
intros c p0 p1 l r b Heq.
apply (satisfying_ctx_l c l (seq_r_cons (p_impl p0 p1) r)) in Heq.
destruct Heq as [ b0 [ b1 [ Hl [ Hr Himpl ] ] ] ].
case_eq (prop_val c p0); case_eq (prop_val c p1).
- intros b2 Hprop0 b3 Hprop1.
  rewrite seq_r_val_equation in Hr.
  apply (prop_val_impl_b c p0 p1 b3 b2) in Hprop0 as Hprop2.
  rewrite Hprop2 in Hr.
  case_eq (seq_r_val c r).
  + intros b4 Hseqr.
    rewrite Hseqr in Hr. inversion Hr. clear Hr.
    apply (satisfying_ctx_r c (seq_l_cons p0 l) (seq_r_cons p1 r) b (andb b3 b0) (orb b2 b4)).
    repeat split.
    * rewrite seq_l_val_equation. rewrite Hprop1. rewrite Hl. reflexivity.
    * rewrite seq_r_val_equation. rewrite Hprop0. rewrite Hseqr. reflexivity.
    * subst. destruct b0; destruct b2; destruct b3; destruct b4; auto.
  + intros Hseqr. rewrite Hseqr in Hr. discriminate.
  + assumption.
- intros Hprop.
  rewrite seq_r_val_equation in Hr. rewrite prop_val_impl_n_r in Hr.
  + discriminate.
  + assumption.
- intros b2 Hprop0 Hprop1.
  rewrite seq_r_val_equation in Hr. rewrite prop_val_impl_n_l in Hr.
  + discriminate.
  + assumption.
- intros Hprop.
  rewrite seq_r_val_equation in Hr. rewrite prop_val_impl_n_r in Hr.
  + discriminate.
  + assumption.
Qed.

Lemma eval_preserves_val_unary : forall c s0 s1 b,
eval_unary s0 s1 -> seq_val c s0 = Some b -> seq_val c s1 = Some b.
Proof.
intros c s0 s1 b Hev Heq. induction Hev.
- apply eval_preserves_val_neg_l. assumption.
- apply eval_preserves_val_neg_r. assumption.
- apply eval_preserves_val_or_r. assumption.
- apply eval_preserves_val_impl_r. assumption.
Qed.

Lemma eval_preserves_val_binary : forall c s0 s1 s2 b0 b1 b2,
eval_binary s0 s1 s2 -> seq_val c s0 = Some b0 ->
seq_val c s1 = Some b1 -> seq_val c s2 = Some b2 -> b0 = andb b1 b2.
Proof.
intros c s0 s1 s2 b0 b1 b2 Hev Heq1 Heq2 Heq3. induction Hev.
- apply (eval_preserves_val_or_l c p0 p1 l r b0 b1 b2); assumption.
Qed.


Require Import Coq.Program.Syntax.
Require Export ZArith.
Require Import Coq.Program.Basics.
Require Import SetoidTactics.
Require Import SetoidClass.
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import Coq.Lists.List.

Require Import HDI.Util.
Require Import HDI.Syntax.
Require Import HDI.Heap.

Local Open Scope Z.

Inductive step (h: heap) : stmt -> heap -> stmt -> Prop :=
  | s_read: forall a v,
    h a = Some v ->
    step h (act (read a)) h (ret v)
  | s_write: forall v0 a v h',
    h a = Some v0 ->
    h' = upd_heap h a v ->
    step h (act (write a v)) h' (ret 1)
  | s_bind1: forall s k h' s',
    step h s h' s' ->
    step h (bind s k) h' (bind s' k)
  | s_bind_ret: forall v k,
    step h (bind (ret v) k) h (k v).

Inductive step_star (h: heap) (s: stmt) : heap -> stmt -> Prop :=
  | step_nil:
    step_star h s h s
  | step_cons: forall h' s' h'' s'',
    step h s h' s' ->
    step_star h' s' h'' s'' ->
    step_star h s h'' s''.

Hint Constructors step : safe.

  Lemma step_heap_equiv1: forall h1 h2 s h1' s',
    heap_equiv h1 h2 ->
    step h1 s h1' s' ->
    exists h2',
      step h2 s h2' s' /\ heap_equiv h1' h2'.
  Proof.
    intros.
    induction H0; subst; eauto with safe;
      try solve [erewrite heap_lookup_equiv in *; eauto using upd_heap_equiv with safe].
    destruct IHstep as [h2'[??]]; eauto with safe.
  Qed.

  Lemma step_heap_equiv2: forall h1 h2 s h2' s',
    heap_equiv h1 h2 ->
    step h2 s h2' s' ->
    exists h1',
      step h1 s h1' s' /\ heap_equiv h1' h2'.
  Proof.
    intros.
    symmetry in H.
    edestruct step_heap_equiv1 as [h1'[??]]; eauto.
    symmetry in H2; eauto.
  Qed.

  Lemma step_deterministic: forall h s h1' h2' s1' s2',
    step h s h1' s1' ->
    step h s h2' s2' ->
    h1' = h2' /\ s1' = s2'.
  Proof.
    intros ? ? ? ? ? ? Hstep1 Hstep2.
    revert h2' s2' Hstep2.
    induction Hstep1; intros; inversion Hstep2;
      instantiate;
      repeat match goal with
      | H1: act ?a1 = act ?a2 |- _ => inversion H1; try (subst a1 || subst a2); clear H1
      | H1: read ?a1 = read ?a2 |- _ => inversion H1; try (subst a1 || subst a2); clear H1
      | H1: write ?a1 ?v1 = write ?a2 ?v2 |- _ => inversion H1; try (subst a1 || subst a2); try (subst v1 || subst v2); clear H1
      | H1: bind ?s1 ?k1 = bind ?s2 ?k2 |- _ => inversion H1; try (subst s1 || subst s2); try (subst k1 || subst k2); clear H1
      | H1: step _ (ret _) _ _ |- _ => solve[inversion H1]
      | _ => progress subst
      | _ => reflexivity
      | |- _/\_ => split; [ reflexivity | ]
      | _ => congruence
      end.
    edestruct IHHstep1; eauto; subst; auto.
  Qed.


Require Import os_code_defs.
Require Import code_notations.
Require Import os_ucos_h.

Open Scope code_scope.

Notation " hid '↝' '{' stmts '}' " := (hid%nat, stmts)  (at level 90): code_scope.

Definition OSTickISR_impl  :=
 OSTickISR ↝
 {

     EOI(0);ₛ
     OSTimeTick();ₛ
     OSIntExit();ₛ
     IRET
 }.

Definition OSToyISR_impl  :=
 OSToyISR ↝
 {

     ++OSIntToyCount′;ₛ
     STI;ₛ
     EOI(1);ₛ
     OSIntExit();ₛ
     IRET
 }.

Definition ifun := (nat * stmts).

Fixpoint  convert_ifuns (ls : list ifun)  : hid -> option stmts :=
  match ls with
    | nil => fun _ => None
    | (x :: ls')%list =>
      match x with
        | (id, imp) =>
          fun (id' : hid) =>
            if EqNat.beq_nat id id' then Some imp
            else (convert_ifuns ls') id'
      end
  end.

Close Scope code_scope.


Require Import Utf8.
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

Require Export zint.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** * ssreflect integration *)

(** Some assorted additional lemmas on lists *)

Lemma map_is_nil A B (f: A->B): forall s,
  map f s = [::] -> s = [::].
Proof. by elim. Qed.

Lemma rev_is_nil {A} (m: list A) :
  rev m = nil → m = nil.
Proof.
move: m => [|x xs] //=; rewrite rev_cons -cats1.
by move: (rev xs) => [|y ys].
Qed.

Lemma rev_is_cons {A} a (m m': list A) :
  rev m = a :: m' →
  m = rev m' ++ a :: nil.
Proof.
move: m => [| x xs] //=; rewrite !rev_cons -cats1 /= .
case E: (rev xs) => [|y ys] /=.
 by move=> [<- <-]; rewrite (rev_is_nil E).
move=> [<- <-]; rewrite rev_cat /= -[[:: y]]/(rev [:: y]) -rev_cat /=; f_equal.
by rewrite -(revK xs) E.
Qed.

Lemma map_nseq {A B} (f:A -> B) (x:A) n:
  [seq f i | i <- nseq n x] = nseq n (f x).
Proof. by elim: n => //= n IH; f_equal. Qed.

Lemma uniq_in_map: forall (A B:eqType) (f:A->B) l x1 x2,
 uniq (map f l) -> x1 \in l -> x2 \in l -> f x1 = f x2 -> x1 = x2.
Proof.
move=> A B f; elim; first by [].
move=> y ys IH x1 x2 /= /andP [Hy Hys].
rewrite ! seq.in_cons => /orP [/eqP ->|H1] /orP [/eqP ->|H2] // H; last by apply IH.
 absurd (f y \in map f ys); first by apply/negP.
 by rewrite H; apply map_f.
absurd (f x1 \in map f ys); first by rewrite H; apply/negP.
by apply map_f.
Qed.

Lemma uniq_cons_None : forall  (A:eqType) (l:list (option A)) x,
 uniq [:: None & l] -> x \in l ->
 exists y, x = Some y.
Proof.
move=> A l x /= /andP [Hh Ht].
move: x => [y|]; first by move=> Hy; exists y.
move=> Hf; elimtype False.
by move/negP: Hh; apply.
Qed.

Lemma iota_map0 m n:
 iota m n = map (addn m) (iota 0 n).
Proof.
elim: n m => //= n IH m.
rewrite IH addn0; f_equal.
rewrite [iota 1 n]IH -map_comp /=.
apply eq_map => x /=; ring.
Qed.

Lemma take_map_nth {A} d (s: seq A) n:
(n <= size s)%N -> take n s = map (nth d s) (iota 0 n).
Proof.
elim: n s => [| n IH] /= s; first by rewrite take0.
move: s => [|x xs] /= H //=.
rewrite IH; last first.
 move/ltP: H => H; apply/leP; omega.
f_equal.
by rewrite [iota 1 n]iota_map0 -map_comp; apply eq_map => y.
Qed.

Lemma drop_add {A} (s: seq A): forall n n',
  drop (n + n') s = drop n (drop n' s).
Proof.
elim: s => //= x xs IH n [|n'].
 by rewrite addn0.
by rewrite addnS IH.
Qed.

Lemma drop_is_nil {A} (s:seq A) n:
 drop n s = nil -> (size s <= n)%N.
Proof. by elim: s n => //= x xs IH [|n] // /IH H. Qed.

Lemma foldr_cat_spec {A B} (f: A → list B) acc m :
  foldr (λ a, cat (f a)) acc m = flatten (map f m) ++ acc.
Proof.
elim: m acc => //= x xs IH acc.
by rewrite IH catA.
Qed.

(* some more list functions *)

Fixpoint zipWith (f:bool->bool->bool) (s1 s2: seq bool) :=
 match s1, s2 with
 | x::xs, y::ys => f x y :: zipWith f xs ys
 | _, _ => [::]
 end.

Fixpoint insert {A:eqType} (x:A) (l:seq.seq A) : seq.seq A :=
 match l with
 | [::] => [:: x]
 | [:: y & ys] => if x==y then l else [:: y & insert x ys]
 end.

(** Association lists *)
Fixpoint aget {A:eqType} {B} (l: seq (A*B)) (k:A) : option B :=
 if l is x::xs
 then if k==x.1
      then Some x.2
      else aget xs k
 else None.

Lemma aget_cat {A:eqType} B k: forall (l1 l2: seq (A*B)),
 aget (l1++l2) k = if aget l1 k is Some x
                   then Some x
                   else aget l2 k.
Proof. by elim => //= x l IH l2; case: (ifP _). Qed.

Lemma aget_isN (A:eqType) B v: forall (l:seq (A*B)),
 aget l v = None <-> v \notin (map (@fst _ _) l).
Proof.
elim => //= x l IH. case: (ifP _) => E.
 by rewrite in_cons (eqP E) eq_refl.
by rewrite IH in_cons E.
Qed.

Fixpoint take_dflt {A} dflt n (s:seq A) {struct n} :=
  if n is n'.+1
  then if s is x :: xs
       then x :: take_dflt dflt n' xs
       else dflt :: take_dflt dflt n' [::]
  else [::].

Lemma size_take_dflt {A} (dflt:A):
 forall n s, size (take_dflt dflt n s) = n.
Proof. by elim => // n IH [|x xs]; rewrite /= (IH _). Qed.

Lemma take_dflt_nil A (d:A) n:
 take_dflt d n [::] = nseq n d.
Proof. by elim: n => //= n IH; rewrite IH. Qed.

Lemma nth_take_dflt A (d:A) bs n x:
 nth d (take_dflt d n bs) x = if (x < n)%N
                              then nth d bs x
                              else d.
Proof.
elim: x n bs => //=.
 by move=> [|n] [|b bs].
move=> x IH [|n] [|b bs] //=.
 by rewrite take_dflt_nil nth_nseq ltnS; case: (ifP _).
by rewrite IH ltnS.
Qed.

Lemma take_dflt_split {A} (d: A) s n:
  take_dflt d n s = take n s ++ nseq (n-size s) d.
Proof.
elim: n s => /= [|n IH] s; first by rewrite take0.
move: s => [|x xs] /=; rewrite IH {IH}; f_equal.
by move: n => [|n].
Qed.

Lemma take_dflt_catl: forall n (T : Type) (s1 : seq T),
    (n <= size s1)%N -> forall d s2, take_dflt d n (s1 ++ s2) = take_dflt d n s1.
Proof.
move=> n T s1; elim: s1 n => /=.
 by move=> [|n].
by move=> x xs IH [|n] H d s2 //=; rewrite IH.
Qed.

Lemma take_dflt_addl: forall n1 n2 (T : Type) (s : seq T) d,
    (size s <= n1)%N ->
    take_dflt d (n1+n2) s = take_dflt d n1 s ++ take_dflt d n2 [::].
Proof.
move=> n1 n2 T s d; elim: s n1 => /=.
 by elim => //= n IH H; rewrite IH.
by move=> x xs IH; elim => //= n IHn H; rewrite IH.
Qed.

Lemma take_dflt_eqsize: forall T d n (s : seq T),
    (size s = n)%N -> take_dflt d n s = s.
Proof.
move=> T d n s; elim: s n => /=.
 by move=> n <-.
by move=> x xs IH n <- /=; rewrite IH.
Qed.

(** * [eqType] cannonical structures *)

(** [eqType] from a decidable equality *)

Section EqDecEqType.

Variable A: Type.
Variable (eq_dec: forall (x y:A), {x=y}+{x<>y}).

Lemma EqDecEqAxiom:
 Equality.axiom [fun x y:A => if eq_dec x y then true else false].
Proof.
by move=> x y /=; apply (iffP idP); case: (eq_dec x y)=> ? H //=.
Qed.

End EqDecEqType.

(** option monad extensions and notations *)

Definition obind2 aT bT rT (f:aT->bT->option rT) (x:option (aT*bT)) : option rT :=
 obind (fun x=>f x.1 x.2) x.

Definition obind3 aT bT cT rT (f:aT->bT->cT->option rT) (x:option (aT*bT*cT)) : option rT :=
 obind (fun x=> f x.1.1 x.1.2 x.2) x.

Remark obind_isS:
  forall (A B: Type) (f: option A) (g: A -> option B) (y: B),
  obind g f = Some y <->
  exists x, f = Some x /\ g x = Some y.
Proof.
move=> A B [x|] g y /=; split.
  by move => H; exists x; split.
 by move=> [z [[->] H2]].
move=> H; inversion H.
move=> [z [H1 H2]]; inversion H1.
Qed.

Remark obind_isN:
  forall (A B: Type) (f: option A) (g: A -> option B),
  obind g f = None <-> f = None \/ exists x, f = Some x /\ g x = None.
Proof.
move=> A B [x|] g; split => //=.
  by move=> E; right; exists x.
 by move=> [H|[y [[->] Hg]]].
by move=> _; left.
Qed.

(*
Remark obind_NoneP (A B:eqType) (g: A -> option B): forall (f: option A),
  reflect (f = None \/ exists2 x, f == Some x & g x == None) (obind g f == None).
Proof.
move=> [x|]; apply/(iffP idP) => //.
  by move=> /eqP E; right; exists x; apply/eqP.
 by move=> [H|[y [/eqP[->] /eqP Hg]]]; apply/eqP.
by move=> _; left.
Qed.
*)

Remark obind2_isS:
  forall (A B C: Type) (f: option (A*B)) (g: A -> B -> option C) (z: C),
  obind2 g f = Some z <->
  exists x, exists y, f = Some (x, y) /\ g x y = Some z.
Proof.
move=> A B C f g z; split.
 move/obind_isS => [[xA xB] [Hx1 /= Hx2]].
 by exists xA; exists xB; split.
by move=> [xA [xB [-> H2]]].
Qed.

Remark obind3_isS:
  forall (A B C D: Type) (f: option (A*B*C)) (g: A->B->C->option D) (d: D),
  obind3 g f = Some d <->
  exists x, exists y, exists z, f = Some (x, y, z) /\ g x y z = Some d.
Proof.
move=> A B C D f g d; split.
 move/obind_isS => [[[xA xB] xC] [Hx1 /= Hx2]].
 by exists xA; exists xB; exists xC; repeat split.
by move=> [xA [xB [xC [-> H]]]].
Qed.

Lemma omap_isS : forall A B (f:A->B) x y,
 omap f x = Some y <-> exists z, x = Some z /\ y = f z.
Proof.
move=> A B f [x|] y; split => //=.
  by move=> [<-]; exists x.
 by move=> [w [[->] ->]].
by move=> [w //[H _]].
Qed.

Notation "'do' X <- A ; B" := (obind (fun X => B) A)
 (at level 200, X ident, A at level 100, B at level 200)
 : option_monad_scope.

Notation "'do' X , Y <- A ; B" := (obind2 (fun X Y => B) A)
 (at level 200, X ident, Y ident, A at level 100, B at level 200)
 : option_monad_scope.

Notation "'do' X , Y, Z <- A ; B" := (obind3 (fun X Y Z => B) A)
 (at level 200, X ident, Y ident, Z ident, A at level 100, B at level 200)
 : option_monad_scope.

Local Open Scope option_monad_scope.

Fixpoint oseq {aT:Type} (l:list (option aT)) : option (list aT) :=
 match l with
 | nil => Some nil
 | [:: x & xs] =>
   do y <- x; do ys <- oseq xs; Some [:: y & ys]
 end.

Lemma oseq_isS : forall A lo (l:list A),
 oseq lo = Some l <-> lo = map (@Some A) l.
Proof.
move=> A; elim => [l|x xs IH l].
 split => /= [[<-]|] //.
 by move: l => [|x xs].
split.
 move/obind_isS => [y [Hy [/obind_isS [ys /= [Hys [<-]]]]]].
 simpl; f_equal => //.
 by apply -> IH.
move: l => [|y ys] //= [->] H /=.
apply/obind_isS; exists ys; split => //.
by apply <- IH.
Qed.

Lemma oseq_isN (A:eqType) : forall (lo: seq (option A)),
 (oseq lo = None) <-> (None \in lo).
Proof.
elim => //= x xs IH.
split.
 move/obind_isN => [-> //|[y [[->]]]].
 move/obind_isN; rewrite IH{IH}; move => [H|[z [_ Hz]]]; last discriminate Hz.
 by rewrite in_cons.
rewrite in_cons => /orP [/eqP <- //|].
rewrite -IH => -> /=.
by case: x.
Qed.

Lemma oseq_isN_catl {A} (s1 s2: seq (option A)):
  oseq s1 = None -> oseq (s1++s2) = None.
Proof.
elim: s1 => //= x xs IH.
rewrite obind_isN; move => [->|[y [->]]] //=.
by case E: (oseq xs) => [v|] //= _; rewrite IH.
Qed.

Lemma oseq_isN_catr {A} (s1 s2: seq (option A)):
  oseq s2 = None -> oseq (s1++s2) = None.
Proof.
elim: s1 => //= x xs IH H.
move: x => [x|]; rewrite obind_isN; last by left.
right; exists x; split => //.
by rewrite IH.
Qed.

Lemma oseq_isS_cat {A} (s1 s2: seq (option A)) l1 l2:
  oseq s1 = Some l1 -> oseq s2 = Some l2 -> oseq (s1++s2) = Some (l1++l2).
Proof.
elim: s1 l1 => /=.
 by move=> l1 [<-] ->.
move=> x xs IH l1.
rewrite obind_isS => [[y [-> /obind_isS [y' [Hy [<-]]]]] H] /=.
by rewrite (IH y').
Qed.

Fixpoint onth {A} (s: seq A) n :=
  if s is x::xs
  then if n is S n'
       then onth xs n'
       else Some x
  else None.

Lemma onth_isN A: forall (s: seq A) n,
  onth s n = None <-> (size s <= n)%N.
Proof. by elim => //= x xs IH [|n] //=; apply IH. Qed.

Lemma onth_isS A d: forall (s: seq A) n v,
  onth s n = Some v <-> (n < size s)%N /\ nth d s n = v.
Proof.
elim => [|x xs IH] /=.
 move=> n v; split => //.
 by move=> [HH _].
move=> [|n] v; split => /=.
   by move=> [->].
  by move=> [_ ->].
 by rewrite IH.
by move=> H; rewrite IH.
Qed.

Lemma onth_isS_cat {A} (x y: list A) n z :
  onth x n = Some z →
  onth (x ++ y) n = Some z.
Proof.
elim: n x.
 by move=> [|h t] /=.
move=> n IH [|h t] //= H.
by rewrite IH.
Qed.

Lemma eqseq_onth {A} (s1 s2: seq A):
 s1 = s2 <-> forall n, onth s1 n = onth s2 n.
Proof.
elim: s1 s2 => [|x xs IHx]; elim => [|y ys IHy] //; split; try discriminate.
- move => H; move: (H 0); discriminate.
- move => H; move: (H 0); discriminate.
- by move=> [<- <-].
- move=> H; move: (H 0) => /= [<-]; f_equal.
  by rewrite IHx => n; move: (H n.+1).
Qed.

Lemma map_onth_iota {A} (m: list A) n :
  ∀ x,
    (x + n <= size m)%N →
    map (onth m) (iota x n) = map (@Some _) (take n (drop x m)).
Proof.
elim: n m => /= [|n IH] m v Hv.
 by rewrite take0 /=.
rewrite IH; last first.
 by move: Hv; rewrite addnS addSn.
move: m Hv => [|x xs] /=.
 by rewrite addnS.
case: v => [|v] //= Hv.
 by rewrite drop0.
move: Hv; rewrite addSn addnS -plusE => /leP Hv.
have: (v < size xs)%coq_nat by omega.
move=> {Hv} /leP Hv.
rewrite [drop v xs](drop_nth x) //=.
by f_equal; rewrite onth_isS; split; last by reflexivity.
Qed.

(*
Definition oguard aT (p:aT-> bool) x := if p x then Some x else None.

Lemma oguardP : forall aT p (x y:aT),
 oguard p x = Some y <-> p x /\ y = x.
Proof.
rewrite /oguard => aT p x y; split.
 case: (p x) => //.
 by move=> [->]; split.
by move=> [Hx ->]; rewrite Hx.
Qed.
*)

Fixpoint omap_all {A B} (f: A -> option B) (s: seq A) : option (seq B) :=
 if s is x::xs
 then obind (fun x => obind (fun r => Some (x::r)) (omap_all f xs)) (f x)
 else Some [::].

Lemma omap_all_oseq {A B} (f: A -> option B): forall ma,
 omap_all f ma = oseq (map f ma).
Proof. by elim => //= x xs ->. Qed.

Lemma omap_all_isS {A B} (f: A -> option B) ma mb :
  omap_all f ma = Some mb <->
  map f ma = map (@Some B) mb.
Proof. by rewrite omap_all_oseq; apply oseq_isS. Qed.

Corollary omap_all_size {A B} (f: A -> option B) ma mb :
  omap_all f ma = Some mb ->
  size ma = size mb.
Proof. by rewrite -(size_map f _) => /omap_all_isS ->; rewrite size_map. Qed.

Lemma omap_all_map {A B C} (f: A -> B) (g: B -> option C) ma :
  omap_all g (map f ma) = omap_all (fun x=> g (f x)) ma.
Proof. by rewrite !omap_all_oseq -map_comp. Qed.

(** [updpref] updates a prefix of a sequence *)
Fixpoint updpref {A} (orig new: seq A) : seq A :=
 match new, orig with
 | x::xs, y::ys => x::updpref ys xs
 | _, ys => ys
 end.

Lemma updpref_nil: forall A (new: seq A),
 updpref [::] new = [::].
Proof. by move=> A; elim. Qed.

Lemma updpref_cons_nil: forall A x (xs: seq A),
 updpref (x::xs) [::] = x::xs.
Proof. by move=> A. Qed.

Lemma updpref_cons_cons: forall A x y(xs ys: seq A),
 updpref (x::xs) (y::ys) = y::updpref xs ys.
Proof. by move=> A. Qed.

Lemma size_updpref A: forall (xs ys: seq A),
 size (updpref xs ys) = size xs.
Proof.
elim => [[|y ys] | x xs IH [|y ys]] //.
by rewrite updpref_cons_cons /= IH.
Qed.

Lemma onth_updpref A (orig new: seq A) n:
 size new <= size orig ->
 onth (updpref orig new) n = if n < min (size orig) (size new)
                             then onth new n
                             else onth orig n.
Proof.
elim: n orig new => /=.
 by move=>[|x xs] [|y ys].
move=> n IH [|x xs] [|y ys] //=.
by move=> H; rewrite IH.
Qed.

Lemma updprefE A (orig new: seq A):
  updpref orig new = take (size orig) new ++ drop (size new) orig.
Proof.
elim: orig new.
 by move=> [| y ys].
move=> x xs IH1; elim => //=.
move=> y ys IH2; f_equal.
by rewrite IH1.
Qed.

(*
Lemma updpref_drop A (orig new: seq A):
  size new <= size orig ->
  updpref orig new = new ++ drop (size new) orig.
Proof. by move=> H; rewrite updprefE take_oversize. Qed.
*)

Fixpoint updprefAt {A} n (orig new: seq A) : seq A :=
 if n is n'.+1
 then if orig is x::xs
      then x::updprefAt n' xs new
      else [::]
 else updpref orig new.

Lemma updprefAtE A (orig: seq A) n new:
  updprefAt n orig new = take n orig ++ updpref (drop n orig) new.
Proof.
elim: n orig new.
 by move=> [|x xs] [|y ys].
by move=> n IH [|x xs] [|y ys] //=; f_equal.
Qed.

Lemma size_updprefAt A (orig: seq A) n new:
  size (updprefAt n orig new) = size orig.
Proof.
rewrite updprefAtE size_cat size_take size_updpref size_drop.
case: (ifP _) => //= H.
 by rewrite subnKC //; apply ltnW.
have: leq (size orig) n.
 by move/negP/negP: H; rewrite -leqNgt.
by rewrite /leq => /eqP ->; rewrite addn0.
 Qed.

(** ssreflect integration of some StdLib defs. *)

Lemma InE: forall (A:eqType) a (l:list A),
  a \in l <-> List.In a l.
Proof.
move=> A a; elim; first by [].
move=> x xs IH; split.
 rewrite seq.in_cons => /orP [H|H].
  rewrite (eqP H) /=; left; reflexivity.
 by right; apply -> IH.
move=> /= [H|H].
 by rewrite inE H eq_refl.
rewrite inE; apply/orP; right.
by apply <- IH.
Qed.

Lemma lengthE : forall A, @length A = @size A.
Proof. by []. Qed.

Lemma appE: forall A (xs ys: seq A),
 cat xs ys = app xs ys.
Proof. by move=> A; elim. Qed.

Lemma revE A: forall (xs: seq A),
 rev xs = List.rev xs.
Proof. by elim => //= x xs IH; rewrite rev_cons -cats1 IH appE. Qed.

Lemma mapE A B (f:A -> B): forall (xs: seq A),
 map f xs = List.map f xs.
Proof. by elim => //= x xs IH; rewrite rev_cons -cats1 IH. Qed.

(*
Lemma map_eq_forall2 {A B C} (f: A → C) (g: B → C) ma mb :
  map f ma = map g mb ↔ List.Forall2 (λ a b, f a = g b) ma mb.
Proof.
elim: ma mb => [|a ma IH] mb; split => /= H.
- by symmetry in H; apply map_is_nil in H; rewrite H; left.
- inversion_clear H; reflexivity.
- move: mb H => [|b mb] /=; first by discriminate.
  by move => [E1 E2]; right => //; apply IH.
- by inversion H; simpl; f_equal => //; apply IH.
Qed.
*)


(* -*- mode: coq; mode: visual-line -*-  *)

Require Import Basics.Overture Basics.Tactics.
Require Import WildCat.Core.
Require Import WildCat.Equiv.

(** * Induced wild categories *)

(** A map A -> B of types where B is some type of category induces the same level of structure on A, via taking everything to be defined on the image.

This needs to be separate from Core because of HasEquivs usage.  We don't make these definitions Global Instances because we only want to apply them manually, but we make them Local Instances so that subsequent ones can pick up the previous ones automatically. *)

Section Induced_category.
  Context {A B : Type} (f : A -> B).

  Local Instance isgraph_induced `{IsGraph B} : IsGraph A.
  Proof.
    srapply Build_IsGraph.
    intros a1 a2.
    exact (f a1 $-> f a2).
  Defined.

  Local Instance is01cat_induced `{Is01Cat B} : Is01Cat A.
  Proof.
    srapply Build_Is01Cat.
    + intro a. cbn in *.
      exact (Id (f a)).
    + intros a b c; cbn in *; intros g1 g2.
      exact ( g1 $o g2).
  Defined.

  Local Instance is0gpd_induced `{Is0Gpd B} : Is0Gpd A.
  Proof.
    rapply Build_Is0Gpd.
    intros a b g; cbn in *; exact (g^$).
  Defined.

  (** The structure map along which we induce the category structure becomes a functor with respect to the induced structure *)
  Local Instance is0functor_induced `{IsGraph B} : Is0Functor f.
  Proof.
    srapply Build_Is0Functor.
    intros a b. cbn in *. exact idmap.
  Defined.

  Local Instance is2graph_induced `{Is2Graph B} : Is2Graph A.
  Proof.
    intros a b.
    srapply Build_IsGraph.
    intros a1 a2.
    exact (fmap f a1 $-> fmap f a2).
  Defined.

  Local Instance is1cat_induced `{Is1Cat B} : Is1Cat A.
  Proof.
    srapply Build_Is1Cat;
      unfold isgraph_induced, is2graph_induced,
        is01cat_induced, is0functor_induced in *;
      cbn in *.
    + intros a b.
      rapply is01cat_hom.
    + intros a b.
      rapply is0gpd_hom.
    + intros a b c.
      rapply is0functor_postcomp.
    + intros a b c h.
      rapply is0functor_precomp.
    + intros a b c d u v w.
      rapply cat_assoc.
    + intros a b u.
      rapply cat_idl.
    + intros a b u.
      apply cat_idr.
  Defined.

  Local Instance is1functor_induced `{Is1Cat B} : Is1Functor f.
  Proof.
    srapply Build_Is1Functor.
    + intros a b g h. cbn in *. exact idmap.
    + intros a. cbn in *. exact (Id _).
    + intros a b c g h. cbn in *. exact (Id _).
  Defined.

  Instance hasmorext_induced `{X : HasMorExt B} : HasMorExt A.
  Proof.
    constructor. intros. apply X.
  Defined.

  Definition hasequivs_induced `{HasEquivs B} : HasEquivs A.
  Proof.
    srapply Build_HasEquivs.
    + intros a b. exact (f a $<~> f b).
    + intros a b h. apply (CatIsEquiv' (f a) (f b)).
      exact (fmap f h).
    + intros a b; cbn in *.
      intros g. exact( cate_fun g).
    + intros a b h; cbn in *.
      exact (cate_isequiv' _ _ h ).
    + intros a b h; cbn in *.
      exact ( cate_buildequiv' _ _ h).
    + intros a b h fe; cbn in *.
      exact ( cate_buildequiv_fun' (f a) (f b) h fe) .
    + intros a b h; cbn in *.
      exact(cate_inv'  _ _ h ).
    + intros a b h; cbn in *.
      exact (cate_issect' _ _ h ).
    + intros a b h; cbn in *.
      exact (cate_isretr' _ _ _ ).
    + intros a b h g m n; cbn in *.
      exact ( catie_adjointify' _ _ h g m n  ).
  Defined.

End Induced_category.