Require Export Monads.

Arguments fmap {_} {_} _ {_} {_} _.
Arguments fobj {_} {_} _ _.
Arguments Compose_Functors {_} {_} {_} _ _.
Arguments NaturalTransformation {_} {_} _ _.
Arguments trans {_} {_} {_} {_} _ _.
Arguments Compose_NaturalTransformations {_ _ _ _ _ } _ _.
Arguments Compose_NaturalTransformations_H {_ _ _ _ _ } _ _.

(**
- proof obligations:
-- natural transformations to be introduced:
 eta_A: A   -> GFA
 eps_A: FGA -> A
-- diagrams to commute:
 1. eps_FA   o F(eta_A) = id_FA
 2. G(eps_A) o eta_GA   = id_GA
*)
Class Adjunction {C D: Category}
                 (F  : @Functor C D)
                 (G  : @Functor D C): Type :=
  mk_Adj
  {
      unit  : (NaturalTransformation (@Id C) (Compose_Functors F G));
      counit: (NaturalTransformation (Compose_Functors G F) (@Id D));

      ob1   : forall a, (trans counit (fobj F a)) o (fmap F (trans unit a))
                        = @identity D (fobj F a);
      ob2   : forall a, (fmap G (trans counit a)) o (trans unit (fobj G a))
                        = @identity C (fobj G a)
}.
Check Adjunction.

(*
Definition Eta (p a: Prop) (H: id a) (H1: p): p /\ a := conj H1 H.

Definition Eps (p a: Prop) (H: p /\ (p -> a)): id a :=
  match H with
    | conj x y => y x
  end.
*)

Definition eta_GpFp: forall (p: @obj CoqCatP),
  NaturalTransformation Id (Compose_Functors (Fp p) (Gp p)).
Proof. intro p.
       unshelve econstructor.
       - cbn in *.
         unfold fobjFp, fobjGp. intro q.
         exact (fun (pq: id q) (pp: p) => conj pp pq).
       - cbn. intros a b f.
         extensionality pa. easy.
Defined.

Definition eps_FpGp: forall (p: @obj CoqCatP),
  NaturalTransformation (Compose_Functors (Gp p) (Fp p)) Id.
Proof. intro p.
       unshelve econstructor.
       - cbn in *.
         unfold fobjFp, fobjGp. intro q.
         exact (fun (H: p /\ (p -> q)) => match H with conj pp ppiq => ppiq pp end).
       - cbn. intros a b f.
         extensionality pp.
         destruct pp. easy.
Defined.

Definition FpGp_Adjoint (p: @obj CoqCatP) : Adjunction (Fp p) (Gp p).
Proof. unshelve econstructor.
       - exact (eta_GpFp p).
       - exact (eps_FpGp p).
       - intro a. extensionality H.
         now destruct H.
       - intro a. easy.
Defined.

(** no proof? *)
(*
Definition FpGp_Isomorph (p: @obj CoqCatP): @Isomorphism (FunctorCategory CoqCatP CoqCatP) (Fp p) (Gp p).
Proof. unshelve econstructor.
       - cbn in *.
         + unshelve econstructor.
           ++ intros. cbn in *.
              intros. easy.
           ++ intros. cbn in *.
              extensionality H.
              destruct H. easy.
           ++ intros. cbn in *.
              extensionality H.
              destruct H. easy.
      - cbn in *.
         + unshelve econstructor.
           ++ intros. cbn in *.
              intros. split. easy.
           ++ intros. cbn in *.
              extensionality H.
              destruct H. easy.
           ++ intros. cbn in *.
              extensionality H.
              destruct H. easy.
*)

Class Adjunct {C D: Category}
              (F  : @Functor C D)
              (G  : @Functor D C): Type :=
  mk_Adt
  {
      adj_unit    :    (NaturalTransformation (@Id C) (Compose_Functors F G));
      adj_morph_ex     {c: @obj C} {d: @obj D} (f: @arrow C (fobj G d) c): @arrow D d (fobj F c);
      adj_morph_com    {c: @obj C} {d: @obj D} (f: @arrow C (fobj G d) c): f = fmap G (adj_morph_ex f) o (trans (adj_unit) c);
      adj_morph_unique {c: @obj C} {d: @obj D} (f: @arrow C (fobj G d) c) (g h: @arrow D d (fobj F c)):
         f = fmap G g o (trans (adj_unit) c) ->
         f = fmap G h o (trans (adj_unit) c) -> g = h
  }.

Arguments Adjunction {_} {_} _ _.

Definition AdjCompose
            (C D E: Category)
            (F    : Functor C D)
            (G    : Functor D C)
            (F'   : Functor D E)
            (G'   : Functor E D)
            (A1   : Adjunction F G)
            (A2   : Adjunction F' G'): Adjunction (Compose_Functors F F') (Compose_Functors G' G).
Proof. unshelve econstructor.
       - unshelve econstructor.
         + intros. cbn in *.
           destruct A1, A2, unit0, unit1.
           cbn in *. unfold id in *.
           exact (fmap G (trans0 (fobj F a)) o trans a).
         + intros. cbn in *.
           destruct A1, A2, unit0, counit0, unit1, counit1. cbn in *.
           rewrite assoc.
           rewrite <- preserve_comp.
           specialize (comm_diag1 _ _ (fmap F f)).
           rewrite <- assoc.
           rewrite <- comm_diag.
           rewrite assoc.
           rewrite <- preserve_comp.
           apply rcancel.
           apply f_equal. easy.
       - unshelve econstructor.
         + intros. cbn in *.
           destruct A1, A2, counit0, counit1.
           cbn in *. unfold id in *.
           exact (trans0 a o (fmap F' (trans (fobj G' a)))).
         + intros. cbn in *.
           destruct A1, A2, unit0, counit0, unit1, counit1. cbn in *.
           rewrite <- assoc.
           rewrite <- preserve_comp.
           rewrite assoc.
           rewrite comm_diag2.
           rewrite <- assoc.
           rewrite <- preserve_comp.
           apply lcancel.
           apply f_equal.
           now rewrite <- comm_diag0.
       - intros. cbn in *.
         destruct A1, A2, unit0, counit0, unit1, counit1. cbn in *.
         unfold id in *.
         rewrite <- assoc.
         rewrite <- preserve_comp.
         assert ((trans0 (fobj G' (fobj F' (fobj F a))) o
         fmap F (fmap G (trans1 (fobj F a)) o trans a)) = trans1 (fobj F a)).
         { now rewrite preserve_comp, assoc, <- comm_diag0, <- assoc, ob3, f_identity. }
         now rewrite H, ob5.
       - intros. cbn in *.
         destruct A1, A2, unit0, counit0, unit1, counit1. cbn in *.
         unfold id in *.
         rewrite assoc.
         rewrite <- preserve_comp.
         assert ((fmap G' (trans2 a o fmap F' (trans0 (fobj G' a))) o
         trans1 (fobj F (fobj G (fobj G' a)))) = trans0 (fobj G' a)).
         { now rewrite preserve_comp, <- assoc, comm_diag1, assoc, ob6, identity_f. }
         now rewrite H, ob4.
Defined.

Lemma adjEq10_1: forall (C D: Category) (F: Functor C D) (G: Functor D C) (A: Adjunction F G),
       (forall (a: @obj C) (b: @obj D) (f: @arrow C (fobj G b) a) (g h: @arrow D b (fobj F a)),
         f = fmap G g o (trans (@unit C D F G A) a) ->
         f = fmap G h o (trans (@unit C D F G A) a) -> g = h).
Proof. intros C D F G A a b f g h Hg Hh.
       destruct A as (eta, eps, cc1, cc2).
       rewrite Hg in Hh.
       apply (f_equal (fmap F)), (f_equal (fun w => comp((trans eps) _ ) w)) in Hh.
       destruct eps. cbn in *. unfold id in *.
       rewrite !preserve_comp in Hh.
       rewrite !assoc, <- !comm_diag in Hh.
       rewrite <- !assoc in Hh.
       now rewrite !cc1, !f_identity in Hh.
Qed.

Lemma adjEq10_2: forall (C D: Category) (F: Functor D C) (G: Functor C D) (A: Adjunction F G),
       (forall (a: @obj C) (b: @obj D) (f: @arrow C a (fobj F b)) (g h: @arrow D (fobj G a) b),
         f = (trans (@counit D C F G A) a) o fmap F g ->
         f = (trans (@counit D C F G A) a) o fmap F h -> g = h).
Proof. intros. cbn in *.
         destruct A, unit0, counit0. cbn in *.
         unfold id in *.
         rewrite H in H0. remember f_equal.
         apply (f_equal (fmap G)) in H0.
         rewrite !preserve_comp in H0.
         apply (f_equal (fun w => comp w (trans _ ))) in H0.
         rewrite <- !assoc in H0. rewrite !comm_diag in H0.
         rewrite !assoc in H0.
         now rewrite !ob4, !identity_f in H0.
Qed.

Lemma adjEq10_10: forall (C D: Category) (F: Functor C D) (G: Functor D C) (A: Adjunction F G),
       (forall (a: @obj C) (b: @obj D) (f: @arrow C (fobj G b) a),
        exists !(g: @arrow D b (fobj F a)),
         f = fmap G g o (trans (@unit C D F G A) a)).
Proof. intros. cbn in *.
         destruct A, unit0, counit0. cbn in *.
         unfold id in *.
         exists (trans0 b o fmap F f).
         unfold unique. split.
         now rewrite preserve_comp, <- assoc, comm_diag, assoc,
         ob4, identity_f.
         intros.
         apply (f_equal (fmap F)) in H.
         rewrite !preserve_comp in H.
         apply (f_equal (fun w => comp(trans0 _ ) w)) in H.
         rewrite !assoc in H. rewrite <- !comm_diag0 in H.
         rewrite <- !assoc in H.
         now rewrite !ob3, !f_identity in H.
Qed.

Definition adjEq10 (C D: Category) (F: Functor C D) (U: Functor D C) (A: Adjunction F U): Adjunct F U.
Proof. unshelve econstructor.
       - destruct A. exact unit0.
       - intros. destruct A, unit0, counit0. cbn in *.
         unfold id in *. exact (trans0 d o fmap F f).
       - cbn. intros. destruct A, unit0, counit0. cbn in *.
         unfold id in *. rewrite preserve_comp.
         rewrite <- assoc. rewrite comm_diag.
         now rewrite assoc, ob4, identity_f.
       - intros. cbn in *.
         destruct A, unit0, counit0. cbn in *.
         unfold id in *.
         rewrite H in H0. remember f_equal.
         apply (f_equal (fmap F)) in H0.
         rewrite !preserve_comp in H0.
         apply (f_equal (fun w => comp(trans0 _ ) w)) in H0.
         rewrite !assoc in H0. rewrite <- !comm_diag0 in H0.
         rewrite <- !assoc in H0.
         now rewrite !ob3, !f_identity in H0.
Defined.

Definition adjEq01 (C D: Category) (F: Functor C D) (U: Functor D C) (A: Adjunct F U): Adjunction F U.
Proof. unshelve econstructor.
       - destruct A. exact adj_unit0.
       - unshelve econstructor.
         + intros. destruct A, adj_unit0. unfold Id. cbn in *. unfold id in *.
           apply adj_morph_ex0. exact (identity (fobj U a)).
         + intros. cbn in *.
           destruct A, adj_unit0. cbn in *. unfold id in *.
           apply adj_morph_unique0 with (f := fmap U f );
           rewrite !preserve_comp.
           now rewrite <- assoc, <- adj_morph_com0, f_identity.
           rewrite <- assoc. rewrite comm_diag.
           now rewrite assoc, <- adj_morph_com0, identity_f.
       - intros. cbn in *.
         destruct A, adj_unit0. cbn in *. unfold id in *.
         apply adj_morph_unique0 with (f := trans a).
         pose proof adj_morph_com0 as adj_morph_com1.
         specialize (adj_morph_com0 (fobj U (fobj F a)) (fobj F a) (identity (fobj U (fobj F a))) ).
         assert (trans a = identity (fobj U (fobj F a))  o trans a).
         { now rewrite identity_f. } rewrite H at 1.
         rewrite adj_morph_com0 at 1.
         rewrite <- adj_morph_com1.
         rewrite preserve_comp. rewrite <- assoc, comm_diag.
         rewrite assoc. apply rcancel. easy.
         now rewrite preserve_id, identity_f.
       - intros. cbn in *.
         destruct A, adj_unit0. cbn in *. unfold id in *.
         now rewrite adj_morph_com0.
Defined.

Class HomAdjunction {C D: Category} (F: Functor C D) (G: Functor D C): Type :=
  mk_Homadj
  {
     ob: @Isomorphism (FunctorCategory (C^op × D) CoqCatT) (BiHomFunctorC G) (BiHomFunctorD F)
  }.
Check HomAdjunction.

(*
Lemma adjEq12 (C D: Category) (F: Functor C D) (G: Functor D C):
Adjunction F G -> @Isomorphism (FunctorCategory (C^op × D) CoqCatT) (BiHomFunctorC G) (BiHomFunctorD F).
Proof. intro A.
       unshelve econstructor.
       - unshelve econstructor.
         + cbn in *. intros. cbn in *.
              destruct A, F, G, unit0, counit0.
              cbn in *.
              intros. destruct a as (a, b).
              unfold id in *.
              clear comm_diag0 trans_sym0 ob3 ob4.
              specialize (trans0 b).
              exact (trans0 o (fmap _ _ X)).
           + intros.  cbn in *.
              destruct A, F, G, unit0, counit0.
              cbn in *.
              intros.
              destruct a as (a0, a1).
              destruct b as (b0, b1).
              destruct f as (f, g).
              extensionality a. cbn in *.
              rewrite preserve_comp.
              specialize (@comm_diag b0 a0 f).
              repeat rewrite <- assoc.
              rewrite assoc.
              rewrite preserve_comp.
              repeat rewrite assoc.
              apply rcancel. apply rcancel.
              specialize (@comm_diag0 a1 b1 g). easy.
           + intros.  cbn in *.
              destruct A, F, G, unit0, counit0.
              cbn in *.
              intros.
              destruct a as (a0, a1).
              destruct b as (b0, b1).
              destruct f as (f, g).
              extensionality a. cbn in *.
              rewrite preserve_comp.
              specialize (@comm_diag b0 a0 f).
              repeat rewrite <- assoc.
              rewrite assoc.
              rewrite preserve_comp.
              repeat rewrite assoc.
              apply rcancel. apply rcancel.
              specialize (@comm_diag0 a1 b1 g). easy.
         - cbn in *.
           unshelve econstructor.
           + intros. cbn in *.
              destruct A, F, G, unit0, counit0.
              cbn in *.
              destruct a as (a, b).
              intros.
              clear comm_diag trans_sym ob3 ob4.
              specialize (trans a).
              exact ((fmap0 _ _ X) o trans).
           + intros.  cbn in *.
              destruct A, F, G, unit0, counit0.
              cbn in *.
              intros.
              destruct a as (a0, a1).
              destruct b as (b0, b1).
              destruct f as (f, g).
              extensionality a. cbn in *.
              rewrite preserve_comp0.
              specialize (@comm_diag b0 a0 f).
              repeat rewrite <- assoc.
              rewrite assoc.
              rewrite preserve_comp0.
              apply lcancel. easy.
           + intros.  cbn in *.
              destruct A, F, G, unit0, counit0.
              cbn in *.
              intros.
              destruct a as (a0, a1).
              destruct b as (b0, b1).
              destruct f as (f, g).
              extensionality a. cbn in *.
              rewrite preserve_comp0.
              specialize (@comm_diag b0 a0 f).
              repeat rewrite <- assoc.
              rewrite !preserve_comp0.
              rewrite <- assoc.
              apply lcancel. apply lcancel.
              now rewrite <- trans_sym.
         - cbn in *.
           apply Nt_split. cbn in *.
           destruct A, F, G, unit0, counit0.
           cbn in *.
           extensionality a.
           extensionality b.
           destruct a as (a0, a1).
           cbn in *. rewrite preserve_id, identity_f, f_identity.
           rewrite preserve_comp. unfold id in *.
           specialize (@comm_diag0 _ _ b).
           rewrite assoc. rewrite <- comm_diag0.
           specialize (ob3 a0). rewrite <- assoc. rewrite ob3.
           now rewrite f_identity.
         - cbn in *.
           apply Nt_split. cbn in *.
           destruct A, F, G, unit0, counit0.
           cbn in *.
           extensionality a.
           extensionality b.
           destruct a as (a0, a1).
           cbn in *. rewrite preserve_id0, f_identity, identity_f.
           rewrite preserve_comp0. unfold id in *.
           specialize (@comm_diag _ _ b).
           rewrite <- assoc. rewrite comm_diag.
           specialize (ob4 a1). rewrite assoc. rewrite ob4.
           now rewrite identity_f.
Qed.
*)

Lemma adjEq12 (C D: Category) (F: Functor C D) (U: Functor D C):
Adjunction F U -> HomAdjunction F U.
Proof. intro A.
       unshelve econstructor.
       - unshelve econstructor.
         + cbn in *.
           unshelve econstructor.
           ++ intros. cbn in *.
              destruct A, F, U, unit0, counit0.
              cbn in *.
              intros. destruct a as (a, b).
              unfold id in *.
              clear comm_diag0 ob3 ob4.
              specialize (trans0 b).
              exact (trans0 o (fmap _ _ X)).
           ++ intros.  cbn in *.
              destruct A, F, U, unit0, counit0.
              cbn in *.
              intros.
              destruct a as (a0, a1).
              destruct b as (b0, b1).
              destruct f as (f, g).
              extensionality a. cbn in *.
              rewrite preserve_comp.
              specialize (@comm_diag b0 a0 f).
              repeat rewrite <- assoc.
              rewrite assoc.
              rewrite preserve_comp.
              repeat rewrite assoc.
              apply rcancel. apply rcancel.
              specialize (@comm_diag0 a1 b1 g). easy.
         + cbn in *.
           unshelve econstructor.
           ++ intros. cbn in *.
              destruct A, F, U, unit0, counit0.
              cbn in *.
              destruct a as (a, b).
              intros.
              clear comm_diag ob3 ob4.
              specialize (trans a).
              exact ((fmap0 _ _ X) o trans).
           ++ intros.  cbn in *.
              destruct A, F, U, unit0, counit0.
              cbn in *.
              intros.
              destruct a as (a0, a1).
              destruct b as (b0, b1).
              destruct f as (f, g).
              extensionality a. cbn in *.
              rewrite preserve_comp0.
              specialize (@comm_diag b0 a0 f).
              repeat rewrite <- assoc.
              rewrite assoc.
              rewrite preserve_comp0.
              apply lcancel. easy.
         + cbn in *.
           apply Nt_split. cbn in *.
           destruct A, F, U, unit0, counit0.
           cbn in *.
           extensionality a.
           extensionality b.
           destruct a as (a0, a1).
           cbn in *. rewrite preserve_id, identity_f, f_identity.
           rewrite preserve_comp. unfold id in *.
           specialize (@comm_diag0 _ _ b).
           rewrite assoc. rewrite <- comm_diag0.
           specialize (ob3 a0). rewrite <- assoc. rewrite ob3.
           now rewrite f_identity.
         + cbn in *.
           apply Nt_split. cbn in *.
           destruct A, F, U, unit0, counit0.
           cbn in *.
           extensionality a.
           extensionality b.
           destruct a as (a0, a1).
           cbn in *. rewrite preserve_id0, f_identity, identity_f.
           rewrite preserve_comp0. unfold id in *.
           specialize (@comm_diag _ _ b).
           rewrite <- assoc. rewrite comm_diag.
           specialize (ob4 a1). rewrite assoc. rewrite ob4.
           now rewrite identity_f.
Defined.

Lemma adjEq21 (C D: Category) (F: Functor C D) (U: Functor D C):
HomAdjunction F U -> Adjunction F U.
Proof. intro A.
       unshelve econstructor.
       - unshelve econstructor.
         + intros. cbn in *.
           destruct A, ob0, to, from. cbn in *.
           clear comm_diag iso_to_from comm_diag0 iso_from_to.
           specialize (trans0 (a, (fobj F a))).
           cbn in *. apply trans0.
           exact (identity (fobj F a)).
         + cbn in *. intros.
           destruct A, ob0, to, from. cbn in *.
           clear iso_to_from iso_from_to.
           pose proof comm_diag0 as comm_diag00.
           specialize (comm_diag0 (a, (fobj F a))). cbn in *.
           specialize (comm_diag0 (a, (fobj F b))). cbn in *.
           specialize (comm_diag0 ((identity a), (fmap F f))).
           cbn in *.
           pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl comm_diag0) as H';
           cbv beta in H'.
           specialize (H'  (identity (fobj F a))).
           rewrite !preserve_id, !f_identity in H'.

           assert (trans0 (a, fobj F b) (fmap F f) = trans0 (b, fobj F b) (identity (fobj F b)) o f).
           {
            specialize (comm_diag00 (b, (fobj F b))). cbn in *.
            specialize (comm_diag00 (a, (fobj F b))). cbn in *.
            specialize (comm_diag00 (f, (identity (fobj F b))) ).
            cbn in *.
           pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl comm_diag00) as H'';
           cbv beta in H''.
           specialize (H''  (identity (fobj F b))).
           rewrite !preserve_id, !f_identity, !identity_f in H''. easy. }
           rewrite H in H'. easy.
       - unshelve econstructor.
         + intros. cbn in *.
           destruct A, ob0, to, from. cbn in *.
           clear comm_diag iso_to_from comm_diag0 iso_from_to.
           specialize (trans ((fobj U a), a)).
           cbn in *. apply trans.
           exact (identity (fobj U a)).
         + cbn in *. intros.
           destruct A, ob0, to, from. cbn in *.
           clear iso_to_from iso_from_to.
           pose proof comm_diag as comm_diagg.
           specialize (comm_diag ((fobj U a), a)). cbn in *.
           specialize (comm_diag ((fobj U a), b)). cbn in *.
           specialize (comm_diag ((identity (fobj U a)), f)).
           cbn in *.
           pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl comm_diag) as H';
           cbv beta in H'.
           specialize (H'  (identity (fobj U a))).
           rewrite !preserve_id, !f_identity in H'.

           assert (trans (fobj U a, b) (fmap U f) = trans (fobj U b, b) (identity (fobj U b)) o fmap F (fmap U f)).
           {
            specialize (comm_diagg ((fobj U b), b)). cbn in *.
            specialize (comm_diagg ((fobj U a), b)). cbn in *.
            specialize (comm_diagg ((fmap U f), (identity b))).
            cbn in *.
            pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl comm_diagg) as H'';
            cbv beta in H''.
            specialize (H''  (identity (fobj U b))).
            rewrite !preserve_id, !f_identity, !identity_f in H''. easy. }
           rewrite H in H'. easy.

       - cbn in *. intros.
         destruct A, ob0, to, from. cbn in *.
         pose proof comm_diag as comm_diagg.

         specialize (comm_diagg ((fobj U (fobj F a)), (fobj F a))). cbn in *.
         specialize (comm_diagg (a, (fobj F a))). cbn in *.
         specialize (comm_diagg (trans0 (a, fobj F a) (identity (fobj F a)), (identity (fobj F a)))).
         cbn in *.
         pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl comm_diagg) as H'';
         cbv beta in H''.
         specialize (H''  (identity (fobj U (fobj F a)))).
         rewrite !preserve_id, !f_identity, !identity_f in H''.
         assert (trans (a, fobj F a) (trans0 (a, fobj F a) (identity (fobj F a))) = identity (fobj F a)).
         {
           apply Nt_split in iso_to_from. cbn in *.
           pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl iso_to_from) as H';
           cbv beta in H'.
           specialize (H' (a, (fobj F a))). cbn in H'.
           pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl H') as H0;
           cbv beta in H0.
           specialize (H0 (identity (fobj F a))).
           rewrite !identity_f, preserve_id in H0. easy.
          }
         rewrite H in H''. easy.

       - cbn in *. intros.
         destruct A, ob0, to, from. cbn in *.
         pose proof comm_diag0 as comm_diagg.

         specialize (comm_diagg ((fobj U a), (fobj F (fobj U a)))). cbn in *.
         specialize (comm_diagg ((fobj U a), a)). cbn in *.
         specialize (comm_diagg ((identity (fobj U a)), (trans (fobj U a, a) (identity (fobj U a))))).
         cbn in *.
         pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl comm_diagg) as H'';
         cbv beta in H''.
         specialize (H''  (identity (fobj F (fobj U a)))).
         rewrite  !preserve_id, !f_identity in H''.
         assert (trans0 (fobj U a, a) (trans (fobj U a, a) (identity (fobj U a))) = identity (fobj U a)).
         {
           apply Nt_split in iso_from_to. cbn in *.
           pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl  iso_from_to) as H';
           cbv beta in H'.
           specialize (H' ((fobj U a), a)). cbn in H'.
           pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl H') as H0;
           cbv beta in H0.
           specialize (H0 (identity (fobj U a))).
           rewrite !f_identity, preserve_id in H0. easy.
          }
         rewrite H in H''. easy.
Qed.

Definition T2toT: forall
                 {C D: Category}
                 (F  : @Functor C D)
                 (G  : @Functor D C)
                 (T  := (Compose_Functors F G))
                 (T2 := (Compose_Functors T T)),
                  Adjunction F G -> (NaturalTransformation T2 T).
Proof. intros C D F G T T2 A.
       destruct A as (eta, eps, cc1, cc2).
       refine (@mk_nt C
                      C
                      T2
                      T
                      (fun a => fmap G (trans eps (fobj F a))) _).
       intros. unfold T, T2, id in *. simpl in *.
       destruct eta, eps. cbn in *.
       now rewrite <- !preserve_comp, <- comm_diag0.
Defined.

Definition DtoD2: forall
                 {C D: Category}
                 (F  : Functor C D)
                 (U  : Functor D C)
                 (D  := (Compose_Functors U F))
                 (D2 := (Compose_Functors D D)),
                  Adjunction F U -> (NaturalTransformation D D2).
Proof. intros C D F U cT cT2 A.
       destruct F, U, A, unit0, counit0. simpl in *.
       refine (@mk_nt D
                      D
                      cT
                      cT2
                      (fun a => fmap _  _(trans (fobj0 a))) _ ).
       intros. unfold cT, cT2, id in *. simpl in *.
       rewrite <- !preserve_comp.
       now rewrite comm_diag.
Defined.

(** every adjunction gives raise to a monad *)
Theorem adj_mon: forall
                 {C1 C2 : Category}
                 (F     : @Functor C1 C2)
                 (G     : @Functor C2 C1),
                 let T  := (Compose_Functors F G) in
                 let T2 := (Compose_Functors T T) in
                 Adjunction F G -> Monad C1 T.
Proof. intros C1 C2 F G T T2 A.
       unshelve econstructor; destruct A as (eta, eps, cc1, cc2).
       - exact eta.
       - refine (@mk_nt C1
                      C1
                      T2
                      T
                      (fun a => fmap G (trans eps (fobj F a))) _).
         intros a b f.
         destruct eta, eps. cbn in *.
         now rewrite <- !preserve_comp, <- comm_diag0.
       - intros. simpl in *.
         destruct eta, eps. simpl in *.
         destruct F, G. simpl in *.
         rewrite <- !preserve_comp0. unfold id in *.
         now rewrite <- comm_diag0.
       - intros. simpl in *.
         destruct eta, eps. simpl in *.
         destruct F, G. simpl in *.
         rewrite <- !preserve_comp0. unfold id in *.
         now rewrite cc2, cc1, preserve_id0.
       - intros. simpl in *.
         destruct eps, eta. simpl in *.
         destruct F, G. simpl in *.
         (* rewrite <- !preserve_comp0. *) unfold id in *.
         now rewrite <- preserve_comp0, cc1, preserve_id0.
       - intros. simpl in *.
         destruct eta, eps. simpl in *.
         destruct F, G. simpl in *.
         (* rewrite <- !preserve_comp0. *) unfold id in *.
         now rewrite cc2.
Defined.
Check adj_mon.

(** every hom-adjunction gives raise to a monad *)
Theorem homadj_mon: forall
                 {C D: Category}
                 (F  : @Functor C D)
                 (U  : @Functor D C),
                 HomAdjunction F U -> Monad C (Compose_Functors F U).
Proof. intros C D F U A. apply adjEq21 in A.
       now apply adj_mon.
Defined.
Check homadj_mon.

(** every adjunction gives raise to a comonad *)
Theorem adj_comon: forall
                 {C1 C2: Category}
                 (F  : @Functor C1 C2)
                 (G  : @Functor C2 C1),
                 let D  := (Compose_Functors G F) in
                 let D2 := (Compose_Functors D D) in
                 Adjunction F G -> coMonad C2 D.
Proof. intros C1 C2 F G D D2 A.
       unshelve econstructor; destruct A as (eta, eps, cc1, cc2).
       - exact eps.
       - refine (@mk_nt C2
                        C2
                        D
                        D2
                        (fun a => fmap F (trans eta (fobj G a))) _ ).
         intros a b f.
         destruct eta, eps. cbn in *. unfold id in *.
         now rewrite <- !preserve_comp, comm_diag.
       - intros. simpl in *.
         destruct eta, eps. simpl in *.
         rewrite <- !preserve_comp. unfold id in *.
         now rewrite <- comm_diag.
       - intros. destruct eta, eps. simpl in *.
         rewrite <- !preserve_comp. unfold id in *.
         now rewrite cc2, cc1, preserve_id.
       - intros. destruct eta, eps. simpl in *.
         unfold id in *. now rewrite cc1.
       - intros. destruct eta, eps. simpl in *.
         unfold id in *.
         rewrite <- preserve_comp.
         now rewrite cc2, preserve_id.
Defined.
Check adj_comon.

(** every hom-adjunction gives raise to a comonad *)
Theorem homadj_comon: forall
                 {C D: Category}
                 (F  : @Functor C D)
                 (U  : @Functor D C),
                 HomAdjunction F U -> coMonad D (Compose_Functors U F).
Proof. intros C D F U A. apply adjEq21 in A.
       now apply adj_comon.
Defined.
Check homadj_comon.

Theorem mon_kladj: forall
                   {C D: Category}
                   (F  : Functor C D)
                   (G  : Functor D C)
                   (T  := Compose_Functors F G)
                   (M  : Monad C T)
                   (FT := FT F G M)
                   (GT := GT F G M), Adjunction FT GT.
Proof. intros C D F G T M FT GT.
       unshelve econstructor.
       - unshelve econstructor.
         + intro a. destruct M as (eta, mu, cc1, cc2, cc3, cc4).
           exact (trans eta a).
         + intros. simpl in *.
           destruct M, FT, GT. destruct eta, mu. simpl in *.
           unfold id in *.
           rewrite <- assoc.
           rewrite comm_diag.
           rewrite assoc.
           rewrite comm_diagram2_b2.
           now rewrite identity_f.
       - unshelve econstructor.
         + intro a. exact (identity (fobj G (fobj F a))).
         + intros. simpl.
           destruct M, FT, GT. simpl in *. destruct mu, eta.
           simpl in *. unfold id in *.
           rewrite f_identity.
           repeat rewrite assoc.
           symmetry.
           assert (trans b o Functor.fmap G
           (Functor.fmap F f) =
           (@identity C (Functor.fobj G (Functor.fobj F b))) o trans b o
           Functor.fmap G (Functor.fmap F f) ).
           {
              now rewrite identity_f.
           }
           rewrite H. apply rcancel. apply rcancel.
           rewrite <- assoc.
           rewrite comm_diag0, f_identity.
           now rewrite comm_diagram2_b2.
       - intros. simpl in *.
         destruct M, FT, GT, eta, mu. simpl in *.
         unfold id in *.
         rewrite assoc.
         assert (trans a = (@identity C (Functor.fobj G (Functor.fobj F a))) o  trans a).
         {
            now rewrite identity_f.
         }
         rewrite H.
         rewrite assoc.
         apply rcancel.
         rewrite f_identity.
         rewrite <- assoc.
         rewrite comm_diag, f_identity.
         now rewrite comm_diagram2_b2.
       - intros. simpl in *.
         destruct M, FT, GT, eta, mu. simpl in *.
         unfold id in *.
         rewrite <- assoc.
         rewrite comm_diag, f_identity.
         now rewrite comm_diagram2_b2.
Defined.
Check mon_kladj.

Theorem mon_klhomadj: forall
                   {C D: Category}
                   (F  : Functor C D)
                   (G  : Functor D C)
                   (T  := Compose_Functors F G)
                   (M  : Monad C T)
                   (FT := FT F G M)
                   (GT := GT F G M), HomAdjunction FT GT.
Proof. intros.
       specialize (mon_kladj F G M); intros.
       apply adjEq12 in X. easy.
Defined.

Theorem comon_cokladj: forall
                   {C D: Category}
                   (F  : Functor D C)
                   (G  : Functor C D)
                   (D  := Compose_Functors G F)
                   (cM : coMonad C D)
                   (FD := cLA F G cM)
                   (GD := cRA F G cM), Adjunction FD GD.
Proof. intros.
       unshelve econstructor.
       - unshelve econstructor.
         + intros. simpl. unfold id in *.
           destruct cM, eps, delta. simpl in *.
           apply identity.
         + intros. simpl.
           destruct cM, FD, GD. simpl in *. destruct eps, delta.
           simpl in *. unfold id in *.
           rewrite identity_f.
           symmetry.
           assert ((trans (Functor.fobj F (Functor.fobj G a))) o
                    Functor.fmap F (Functor.fmap G (@identity C (Functor.fobj F
                   (Functor.fobj G a)))) o trans0 a =
                   (@identity C (Functor.fobj F (Functor.fobj G a)))).
           {
              rewrite <- comm_diag.
              now rewrite identity_f, ccomm_diagram2_b1.
           }
           setoid_rewrite <- assoc at 2.
           setoid_rewrite <- assoc at 1.
           setoid_rewrite H. now rewrite f_identity.
       - unshelve econstructor.
         + intros. simpl. unfold id in *.
           destruct cM, eps, delta. simpl in *.  unfold id in *.
           apply trans.
         + intros. simpl in *.
           destruct cM, FD, GD, F, G. destruct eps, delta. simpl in *.
           unfold id in *.
           repeat rewrite assoc.
           rewrite preserve_comp2, preserve_comp1.
           rewrite comm_diag.
           repeat rewrite <- assoc.
           now rewrite ccomm_diagram2_b2, f_identity.
       - intros. simpl in *.
         destruct cM, FD, GD, eps, delta. simpl in *.
         unfold id in *.
         rewrite assoc.
         destruct F, G. simpl in *.
         now rewrite preserve_id2, preserve_id1, f_identity, ccomm_diagram2_b1.
       - intros. simpl in *.
         destruct cM, FD, GD, eps, delta. simpl in *.
         unfold id in *.
         rewrite <- assoc.
         destruct F, G. simpl in *.
         now rewrite preserve_id2, preserve_id1, assoc, f_identity,
         comm_diag, <- assoc, ccomm_diagram2_b2, f_identity.
Defined.
Check comon_cokladj.

Theorem comon_coklhomadj: forall
                   {C D: Category}
                   (F  : Functor D C)
                   (G  : Functor C D)
                   (D  := Compose_Functors G F)
                   (cM : coMonad C D)
                   (FD := cLA F G cM)
                   (GD := cRA F G cM), HomAdjunction FD GD.
Proof. intros. apply adjEq12.
       apply comon_cokladj.
Defined.

Theorem mon_emadj: forall
                   {C D: Category}
                   (F  : Functor C D)
                   (G  : Functor D C)
                   (T  := Compose_Functors F G)
                   (M  : Monad C T)
                   (FT := LAEM F G M)
                   (GT := RAEM F G M), Adjunction FT GT.
Proof. intros.
       unshelve econstructor.
       - unshelve econstructor.
         + intros. destruct M, eta. cbn in *.
           unfold id in *. apply trans.
         + intros. cbn in *.
           destruct M, eta. cbn in *.
           now rewrite comm_diag.
       - unshelve econstructor.
         + intros. destruct a. cbn in *.
           unshelve econstructor.
           ++ destruct t. cbn in *.
              exact x0.
           ++ destruct t. cbn in *.
              destruct a.
              now rewrite H0.
         + intros. destruct a, b, f.
           cbn in *. apply eqTAM. cbn in *.
           easy.
       - intros. cbn in *.
         apply eqTAM. cbn.
         unfold T in *.
         destruct M, T. cbn in *.
         now rewrite comm_diagram2_b1.
       - intros. cbn in *.
         destruct a, t. now cbn in *.
Defined.

Theorem mon_emhomadj: forall
                   {C D: Category}
                   (F  : Functor C D)
                   (G  : Functor D C)
                   (T  := Compose_Functors F G)
                   (M  : Monad C T)
                   (FT := LAEM F G M)
                   (GT := RAEM F G M), HomAdjunction FT GT.
Proof. intros. apply adjEq12.
       apply mon_emadj.
Defined.

Definition L: forall
               {C D   : Category}
               (F     : Functor C D)
               (G     : Functor D C)
               (A     : Adjunction F G),
               let M  := (adj_mon F G A) in
               let CM := (adj_comon F G A) in
               let CK := (Kleisli_Category C (Compose_Functors F G) M) in
               let FT := (FT F G M) in
               let GT := (GT F G M) in Functor CK D.
Proof. intros C D F G A M CM CK FT GT.
       unshelve econstructor.
       - exact (fobj F).
       - intros a b f.
         destruct CM as (eps, delta, cc1, cc2, cc3, cc4).
         exact (trans eps (fobj F b) o fmap F f).
       - repeat intro. now subst.
       - intros. destruct A, unit0, counit0.
         cbn in *. now rewrite <- ob3.
       - intros. cbn in *.
         rewrite preserve_comp.
         destruct A, unit0, counit0. cbn in *.
         do 2 rewrite assoc.
         apply rcancel.
         rewrite <- preserve_comp.
         now rewrite <- comm_diag0.
Defined.
Check L.

Definition invK: forall
               {C D   : Category}
               (F     : Functor C D)
               (G     : Functor D C)
               (A1    : Adjunction F G),
               let M  := (adj_mon F G A1) in
               let CM := (adj_comon F G A1) in
               let EMC:= (EilenbergMooreCategory C (Compose_Functors F G) M) in Functor EMC D.
Proof. intros.
       unshelve econstructor.
       - intro a. cbn in *.
         destruct a. exact (fobj F x).
       - intros a b f. destruct a, b, f. cbn in *.
         exact (fmap F x1).
       - repeat intro. now subst.
       - intros. destruct a. cbn in *. now rewrite preserve_id.
       - intros. destruct a, b, c. cbn in *. destruct g, f. now rewrite preserve_comp.
Defined.
Check invK.

Definition K: forall
               {C D   : Category}
               (F     : Functor C D)
               (G     : Functor D C)
               (A1    : Adjunction F G),
               let M  := (adj_mon F G A1) in
               let EMC:= (EilenbergMooreCategory C (Compose_Functors F G) M) in Functor D EMC.
Proof. intros.
       unshelve econstructor.
       - intro a. cbn in *.
         + unshelve econstructor.
           ++ exact (fobj G a).
           ++ unshelve econstructor.
              +++ exact (fmap G (trans (@counit _ _ _ _ A1) a)).
              +++ split. now rewrite (@ob2 _ _ _ _ A1).
                  destruct A1, counit0. cbn in *.
                  rewrite <- !preserve_comp.
                  now rewrite <- comm_diag.
       - intros. cbn in *.
         + unshelve econstructor.
           ++ exact (fmap G f).
           ++ cbn in *.
              destruct A1, counit0. cbn in *.
              rewrite <- preserve_comp.
              rewrite <- comm_diag.
              now rewrite preserve_comp.
       - repeat intro.
         now subst.
       - intro a. cbn in.
         apply eqTAM. cbn in *.
         now rewrite preserve_id.
       - intros a b c g f.
         apply eqTAM.
         cbn in *.
         now rewrite preserve_comp.
Defined.
Check K.

(*
Definition K: forall
               {C D   : Category}
               (F     : Functor C D)
               (G     : Functor D C)
               (A1    : Adjunction F G),
               let M  := (adj_mon F G A1) in
               let EMC:= (EilenbergMooreCategory C (Compose_Functors F G) M) in Functor D EMC.
Proof. intros.
       unshelve econstructor.
       - intro a. cbn in *.
         + unshelve econstructor.
           ++ exact (fobj G a).
           ++ cbn in *. destruct A1, unit0, counit0. cbn in *.
              unfold id in *.
              exact ( (fmap G (trans0 a)) o (fmap G (fmap F (fmap G (trans0 a)))) o
                                 trans (fobj G (fobj F (fobj G a))) ).
           ++ cbn in *.
              destruct A1, unit0, counit0. cbn in *.
              rewrite <- assoc, <- preserve_comp.
              rewrite <- comm_diag0.
              rewrite preserve_comp.
              rewrite <- ob4. rewrite !assoc. apply rcancel.
              rewrite <- !assoc.
              assert (fmap G (trans0 a) = fmap G (trans0 a) o identity (fobj G (fobj F (fobj G a)))).
              { now rewrite f_identity. }
              symmetry. rewrite H. apply lcancel.
              now rewrite <- ob4.
           ++ cbn in *.
              destruct A1, unit0, counit0. cbn in *.
              symmetry. rewrite <- preserve_comp.
              rewrite <- comm_diag0.
              rewrite preserve_comp.
              repeat setoid_rewrite <- assoc at 1.
              assert (fmap G (trans0 a) o (fmap G (trans0 (fobj F (fobj G a))) o
              trans (fobj G (fobj F (fobj G a)))) o fmap G (trans0 (fobj F (fobj G a))) =
              fmap G (trans0 a) o fmap G (trans0 (fobj F (fobj G a)))).
              { rewrite ob4. now rewrite f_identity. }

              assert(fmap G (trans0 a)
              o (fmap G (trans0 (fobj F (fobj G a))) o
              (trans (fobj G (fobj F (fobj G a))) o
              fmap G (fmap F (fmap G (trans0 a) o
              (fmap G (trans0 (fobj F (fobj G a))) o
              trans (fobj G (fobj F (fobj G a)))))))) =
              fmap G (trans0 a) o fmap G (trans0 (fobj F (fobj G a)))
              ).
              {
                rewrite <- !preserve_comp.
                rewrite !ob4. rewrite !f_identity.
                rewrite <- trans_sym0.
                rewrite !assoc.
                rewrite assoc in H.
                repeat rewrite <- assoc.
                rewrite assoc.
                unfold id in *.
                repeat setoid_rewrite <- assoc at 1.
                setoid_rewrite assoc at 2.
                setoid_rewrite assoc at 1.
                rewrite ob4.
                rewrite !f_identity.
                rewrite preserve_comp.
                easy.
              }
              rewrite <- H in H0.
              rewrite !assoc in *.
              easy.
       - intros. cbn in *.
         + unshelve econstructor.
           ++ cbn in *. exact (fmap G f).
           ++ cbn in *.
              destruct A1, unit0, counit0. cbn in *.
              remember compose_respects.
              remember fmapP.
              rewrite !assoc.
              rewrite <- preserve_comp.
              rewrite <- comm_diag0.
              rewrite preserve_comp.
              repeat setoid_rewrite <- assoc at 1.
              setoid_rewrite assoc at 2.
              setoid_rewrite assoc at 1.
              symmetry.
              remember compose_respects.
              repeat setoid_rewrite <- assoc at 1.
              setoid_rewrite assoc at 2.
              setoid_rewrite assoc at 1.
              rewrite <- preserve_comp.
              rewrite <- comm_diag0.
              rewrite preserve_comp.
              rewrite assoc.
              repeat setoid_rewrite <- assoc at 1.
              setoid_rewrite assoc at 1.
              assert (fmap G f o fmap G (trans0 a) o
              (fmap G (trans0 (fobj F (fobj G a))) o
              trans (fobj G (fobj F (fobj G a)))) =
              fmap G f o fmap G (trans0 a)
              ).
              { rewrite ob4. now rewrite f_identity. }
              assert (
              fmap G (trans0 b) o (fmap G (trans0 (fobj F (fobj G b))) o
              (trans (fobj G (fobj F (fobj G b))) o
              fmap G (fmap F (fmap G f)))) =
              fmap G (trans0 b) o fmap G (fmap F (fmap G f))).
              { repeat setoid_rewrite <- assoc at 1.
                apply lcancel.
                rewrite assoc.
                rewrite ob4.
                now rewrite identity_f.
              }
              assert (fmap G f o fmap G (trans0 a)=
              fmap G (trans0 b) o fmap G (fmap F (fmap G f))).
              { rewrite <- !preserve_comp.
                apply f_equal.
                apply comm_diag0.
              }
              rewrite <- H1 in H0.
              rewrite <- H in H0.
              easy.
       - repeat intro.
         now subst.
       - intro a. cbn in.
         apply eqTAM. cbn in *.
         now rewrite preserve_id.
       - intros a b c g f.
         apply eqTAM.
         cbn in *.
         now rewrite preserve_comp.
Defined. (** takes time: ~ 22 secs *)
Check K.
*)

Definition duL: forall
                 {C D   : Category}
                 (F     : Functor D C)
                 (G     : Functor C D)
                 (A1    : Adjunction F G),
                 let cM := (adj_comon F G A1) in
                 let  M := (adj_mon   F G A1) in
                 let CD := (coKleisli_Category C (Compose_Functors G F) cM) in
                 let FD := (cLA F G cM) in
                 let GD := (cRA F G cM) in
                 let A2 := (comon_cokladj F G cM) in Functor CD D.
Proof. intros C D F G A1 cM M CD FD GD A2. simpl in *.
       unshelve econstructor.
       - exact (fobj G).
       - intros.
         destruct M, eta.
         exact ((fmap G f) o (trans (fobj G a))).
       - repeat intro. subst. easy.
       - intros. simpl in *. destruct A1. now rewrite ob4.
       - intros. simpl in *. rewrite preserve_comp.
         rewrite <- assoc.
         destruct A1, unit0. cbn in *.
         rewrite comm_diag.
         rewrite preserve_comp.
         do 2 rewrite assoc.
         apply rcancel.
         do 2 rewrite <- assoc.
         apply lcancel.
         unfold id in *.
         now rewrite comm_diag.
Defined.
Check duL.

Class MapOfAdjunctions {X A X' A': Category}
  (F : Functor X A)    (G : Functor A X)
  (F': Functor X' A')  (G': Functor A' X')
  (A1: Adjunction F G) (A2: Adjunction F' G'): Type :=
  mk_MOA
  {
     fK     : Functor A A';
     fL     : Functor X X';
     moa_ob1: Compose_Functors F fK = Compose_Functors fL F';
     moa_ob2: Compose_Functors G fL = Compose_Functors fK G';
     moa_ob3: forall a, JMeq (fmap fL (trans (@unit X A F G A1) a)) ((trans (@unit X' A' F' G' A2)) (fobj fL a))
  }.

Lemma moaL: forall
                 {C D: Category}
                 (F: Functor C D)
                 (G: Functor D C)
                 (A1: Adjunction F G),
                 let  M := (adj_mon   F G A1) in
                 let CT := (Kleisli_Category C (Compose_Functors F G) M) in
                 let FT := (FT F G M) in
                 let GT := (GT F G M) in
                 let A2 := (mon_kladj F G M) in MapOfAdjunctions FT GT F G A2 A1.
Proof. intros.
       unshelve econstructor.
       - exact (L F G A1).
       - exact IdFunctor.
       - unfold M, CT, GT. cbn in *.
         assert (fobj (Compose_Functors FT (L F G A1)) = fobj F).
         {
             unfold Compose_Functors. simpl in *.
             unfold id in *. easy.
         }
         simpl.
         specialize (F_split C D
           (Compose_Functors FT (L F G A1)) F); intros.
         specialize (H0 H).
         assert (HC: Compose_Functors IdFunctor F = F).
         { now apply ComposeIdl. }
         rewrite HC.
         apply H0.
         unfold Compose_Functors. simpl.
         destruct A1, unit0, counit0. simpl in *.
         unfold id in *. destruct F, G, L.
         simpl in *.
         assert (H = eq_refl).
         {
            specialize (UIP_refl _   (fun a : @obj C => fobj a)); intros.
            now specialize (H1 H).
         }
         rewrite H1.
         extensionality a. extensionality b. extensionality f.
         rewrite preserve_comp.
         rewrite assoc.
         now rewrite ob3, identity_f.
       - simpl in *.
         assert (fobj (Compose_Functors (L F G A1) G) = fobj GT).
         {
             unfold Compose_Functors. simpl in *.
             unfold id in *. easy.
         }
         simpl.
         specialize (F_split (Kleisli_Category C
           (Compose_Functors F G) M) C
           (Compose_Functors (L F G A1) G) GT); intros.
         specialize (H0 H).
         assert (HC: Compose_Functors GT IdFunctor = GT).
         { now apply ComposeIdr. }
         rewrite HC. symmetry.
         apply H0.
         unfold Compose_Functors. simpl in *.
         destruct A1, unit0, counit0. simpl in *.
         unfold id in *. destruct F, G, L.
         simpl in *.
         assert (H = eq_refl).
         {
            specialize (UIP_refl _
             (fun a : @obj C => fobj0 (fobj a))); intros.
            now specialize (H1 H).
         }
         rewrite H1.
         extensionality a. extensionality b.
         extensionality f. now rewrite preserve_comp0.
       - intros. destruct A1, A2, unit0, unit1. cbn in *.
         unfold id in *.  apply eq_dep_JMeq.
         apply EqdepFacts.eq_sigT_eq_dep. apply eq_existT_uncurried. cbn.
         exists eq_refl. cbn in *.
        admit.
Admitted.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith List Max Omega.

Require Import rel_utils list_utils good_base finite.

Set Implicit Arguments.

Section Bar_type.

  Variables (A : Type) (P : list A -> Prop).

  Inductive bar_t l : Type :=
    | in_bar_t0 : P l -> bar_t l
    | in_bar_t1 : (forall a, bar_t (a::l)) -> bar_t l.

  Fact in_bar_t_inv l : bar_t l -> P l + forall a, bar_t (a::l).
  Proof.
    induction 1 using bar_t_rect; [ left | right ]; auto.
  Qed.

  Implicit Type f : nat -> A.

  Local Lemma bar_t_recursion ws : bar_t ws -> forall f n, ws = pfx_rev f n -> { m | P (pfx_rev f m) }.
  Proof.
    induction 1 as [ ll Hll | ll Hll IH ] using bar_t_rect; intros f n ?; subst.
    exists n; auto.
    apply (IH (f n) f (S n)); auto.
  Qed.

  Theorem bar_t_inv : bar_t nil -> forall f, { m | P (pfx_rev f m) }.
  Proof.
    intros H f; apply bar_t_recursion with (1 := H) (n := 0); auto.
  Qed.

  Hypothesis P_mono : forall x ll, P ll -> P (x::ll).

  Theorem bar_t_app ll mm : bar_t ll -> bar_t (mm++ll).
  Proof.
    intros H.
    induction mm as [ | x mm IH ]; simpl; auto.
    apply in_bar_t_inv in IH; destruct IH as [ IH | IH ]; auto.
    apply in_bar_t0; apply P_mono; auto.
  Qed.

  Theorem bar_t_nil_all : bar_t nil -> forall ll, bar_t ll.
  Proof.
    intros H ll.
    rewrite app_nil_end.
    apply bar_t_app, H.
  Qed.

End Bar_type.

(* extending a list always leads to a list of length greater to a given
   value n *)

Theorem bar_t_length X n : bar_t (fun m => n <= @length X m) nil.
Proof.
  generalize (@nil X).
  induction n as [ | n IHn ]; intros l.
  apply in_bar_t0, le_0_n.
  generalize (IHn l); clear IHn.
  induction 1 using bar_t_rect.
  apply in_bar_t1; intro.
  apply in_bar_t0; simpl; apply le_n_S; auto.
  apply in_bar_t1; auto.
Qed.

Section Bar_t_inc.

  Variable (A : Type) (P Q : list A -> Prop).

  Fact bar_t_inc : P inc1 Q -> bar_t P inc1 bar_t Q.
  Proof.
    intros H ?; induction 1 as [ ws Hws | ws IH ] using bar_t_rect.
    apply in_bar_t0, H, Hws.
    apply in_bar_t1; auto.
  Qed.

End Bar_t_inc.

Section Bar_lift.

  Variables (A : Type) (P : list A -> Prop).

  Let bar_lift1 k : bar_t P k -> forall u v, k = v++u -> bar_t (fun v => P (v++u)) v.
  Proof.
    induction 1 as [ k Hk | k Hk IH ] using bar_t_rect; intros u v H.

    apply in_bar_t0; subst; auto.

    apply in_bar_t1; intros a.
    apply (IH a u (a::v)).
    simpl; f_equal; auto.
  Qed.

  Let bar_lift2 u v : bar_t (fun v => P (v++u)) v -> bar_t P (v++u).
  Proof.
    induction 1 as [ v Hv | v Hv IH ] using bar_t_rect.
    apply in_bar_t0; auto.
    apply in_bar_t1; intros a.
    apply (IH a).
  Qed.

  Theorem bar_t_lift1 u : bar_t P u -> bar_t (fun v => P (v++u)) nil.
  Proof.
    intros H; apply bar_lift1 with (1 := H); auto.
  Qed.

  Theorem bar_t_lift2 u : bar_t (fun v => P (v++u)) nil -> bar_t P u.
  Proof.
    apply bar_lift2.
  Qed.

End Bar_lift.

Section Bar_subst_eq.

  Variable (A : Type) (P : list A -> Prop) (a b : A).

  Hypothesis Hab : forall mm ll, P (mm++a::ll) -> P (mm++b::ll).

  Let bar_subst_eq_rec l : bar_t P l -> forall mm ll, l = mm++a::ll -> bar_t P (mm++b::ll).
  Proof.
    induction 1 as [ l Hl | l Hl IH ] using bar_t_rect; intros; subst.
    apply in_bar_t0; auto.
    apply in_bar_t1; intros c.
    apply (IH c (c::mm)); auto.
  Qed.

  Fact bar_t_subst_eq mm ll : bar_t P (mm++a::ll) -> bar_t P (mm++b::ll).
  Proof.
    intros H; apply bar_subst_eq_rec with (1 := H); auto.
  Qed.

End Bar_subst_eq.

Section Bar_inter.

  Variables (A : Type) (P Q : list A -> Prop).

  Hypothesis HP : forall x ll, P ll -> P (x::ll).
  Hypothesis HQ : forall x ll, Q ll -> Q (x::ll).

  Theorem bar_t_intersection u : bar_t P u -> bar_t Q u -> bar_t (fun x => P x /\ Q x) u.
  Proof.
    induction 1 as [ u Hu | u Hu IHu ] using bar_t_rect.
    induction 1 as [ v Hv | v Hv IHv ] using bar_t_rect.

    apply in_bar_t0; auto.

    apply in_bar_t1; intros a.
    apply IHv, HP; auto.

    induction 1 as [ v Hv | v Hv IHv ] using bar_t_rect.

    apply in_bar_t1; intros a.
    apply IHu.
    apply in_bar_t0.
    apply HQ; auto.

    apply in_bar_t1; intros a.
    apply IHu; auto.
  Qed.

End Bar_inter.

Section Bar_t_relmap.

  Variables (A B : Type) (R : A -> B -> Prop)
            (HR : forall a, { b | R a b })
            (P : list A -> Prop)
            (Q : list B -> Prop)
            (HPQ : forall ll mm, Forall2 R ll mm -> Q mm -> P ll).

  Lemma bar_t_relmap ll mm : Forall2 R ll mm -> bar_t Q mm -> bar_t P ll.
  Proof.
    intros H1 H2.
    revert ll H1.
    induction H2 as [ mm Hmm | mm Hmm IH ] using bar_t_rect; intros ll H1.

    apply in_bar_t0, HPQ with (1 := H1); auto.
    apply in_bar_t1; intros a.
    destruct (HR a) as (b & Hb).
    apply IH with (a := b); constructor; auto.
  Qed.

End Bar_t_relmap.

Section Bar_map_inv.

  Variables (A B : Type) (f : A -> B)
            (P : list A -> Prop)
            (Q : list B -> Prop)
            (HPQ : forall ll, Q (map f ll) -> P ll).

  Lemma bar_t_map_inv ll : bar_t Q (map f ll) -> bar_t P ll.
  Proof.
    apply bar_t_relmap with (R := fun a b => b = f a).
    intros a; exists (f a); auto.
    clear ll.
    intros ll mm H.
    rewrite Forall2_exchg, <- Forall2_map_right, Forall2_eq in H.
    subst; auto.
    rewrite Forall2_exchg, <- Forall2_map_right, Forall2_eq; auto.
  Qed.

End Bar_map_inv.

Section Bar_map.

  Variables (A B : Type) (f : A -> B) (Hf : forall b, { a | b = f a })
            (P : list A -> Prop)
            (Q : list B -> Prop)
            (HPQ : forall ll, P ll -> Q (map f ll)).

  Lemma bar_t_map ll : bar_t P ll -> bar_t Q (map f ll).
  Proof.
    apply bar_t_relmap with (R := fun b a => b = f a); auto.
    clear ll.
    intros ll mm H.
    rewrite <- Forall2_map_right, Forall2_eq in H; subst; auto.
    rewrite <- Forall2_map_right, Forall2_eq; auto.
  Qed.

End Bar_map.

Section fan_t.

  (* That proof of the FAN theorem is derived from Daniel Fridlender's paper *)

  Notation mono := ((fun X (P : list X -> Prop) => forall x l, P l -> P (x::l)) _).

  Variables (X : Type) (P : list X -> Prop) (HP : mono P).

  Let P_mono l m : P m -> P (l++m).
  Proof.
    induction l; simpl; auto.
  Qed.

  Let V u := fun lw => Forall (fun v => P (v++u)) (list_fan lw).

  Let V_mono u : mono (V u).
  Proof.
    unfold V; intros w lw H.
    apply list_fan_Forall.
    rewrite Forall_forall; intros x _.
    revert H; apply Forall_impl.
    intro; apply HP.
  Qed.

  Let bar_V u : bar_t P u -> bar_t (V u) nil.
  Proof.
    induction 1 as [ u Hu | u Hu IHu ] using bar_t_rect.

    apply in_bar_t0; unfold V.
    simpl.
    constructor; simpl; auto.

    apply in_bar_t1; intros w.
    induction w as [ | a w IHw ].

    apply in_bar_t0.
    unfold V; simpl.
    constructor.

    specialize (IHu a).
    apply bar_t_lift1 in IHw.
    unfold V in IHw.
    generalize (@V_mono (a::u)); intros HV1.
    assert (mono (fun lw => V u (lw++w::nil))) as HV2.
      intros x ll; simpl; apply V_mono.
    generalize (bar_t_intersection HV1 HV2 IHu IHw); intros HV3; clear HV1 HV2.
    apply bar_t_lift2.
    revert HV3; apply bar_t_inc.

    intros x; unfold V.
    intros [ H1 H2 ].
    rewrite (Forall_perm _ (list_fan_middle_cons x a w nil)).
    apply Forall_app; split; auto.
    rewrite list_fan_sg_right.
    rewrite Forall_map.
    revert H1; apply Forall_impl.
    intro; rewrite app_ass; auto.
  Qed.

  Theorem fan_t_on_list : bar_t P nil
                       -> bar_t (fun ll => Forall P (list_fan ll)) nil.
  Proof.
    intros H.
    generalize (bar_V H).
    apply bar_t_inc.
    intros lw; unfold V.
    apply Forall_impl.
    intro; rewrite <- app_nil_end; auto.
  Qed.

End fan_t.

Inductive bar_rel_t X (R : X -> X -> Prop) (P : X -> Prop) x :=
  | in_brel_t0 : P x -> bar_rel_t R P x
  | in_brel_t1 : (forall y, R x y -> bar_rel_t R P y) -> bar_rel_t R P x.

Section fan_rel.

  Variables (X : Type) (R : X -> X -> Prop).

  Variables (next : X -> list X) (next_R : forall x y, In y (next x) -> R x y)
            (P : X -> Prop) (HP : forall x y, R x y -> P x -> P y).

  Let N l := flat_map next l.

  Fact next_P l : Forall P l -> Forall P (N l).
  Proof.
    do 2 rewrite Forall_forall; unfold N.
    intros H y Hy.
    apply in_flat_map in Hy.
    destruct Hy as (x & H1 & H2).
    generalize (next_R _ _ H2) (H _ H1); apply HP.
  Qed.

  Fact iter_N_P n l : Forall P l -> Forall P (iter N n l).
  Proof.
    intros H; induction n as [ | n IHn ]; simpl; auto.
    apply next_P, IHn.
  Qed.

  Fact iter_N_app a b l x : In x (iter N (a+b) l) -> exists y, In x (iter N a (y::nil)) /\ In y (iter N b l).
  Proof.
    rewrite iter_app.
    revert x; induction a as [ | a IHa ]; simpl; intros x Hx.
    exists x; auto.
    unfold N at 1 in Hx.
    apply in_flat_map in Hx.
    destruct Hx as (y & H1 & H2).
    apply IHa in H1.
    destruct H1 as (z & H1 & H3).
    exists z; split; auto.
    apply in_flat_map.
    exists y; auto.
  Qed.

  Fact iter_N_S n l x : In x (iter N (S n) l) -> exists y, In x (iter N n (y::nil)) /\ In y (N l).
  Proof.
    replace (S n) with (n+1) by omega.
    intros H.
    apply iter_N_app in H; auto.
  Qed.

  Let Q n l := forall m, n <= m -> Forall P (iter N m l).

  Theorem fan_t x : bar_rel_t R P x -> { n | Q n (x::nil) }.
  Proof.
    induction 1 as [ x Hx | x Hx IHx ].
    exists 0.
    intros m Hm; apply iter_N_P; constructor; auto.
    assert (forall y, In y (N (x::nil)) -> { n | Q n (y::nil) }) as H0.
    { intros; apply IHx.
      unfold N in H.
      apply in_flat_map in H.
      destruct H as (x' & [ E | [] ] & H); subst x'.
      apply next_R in H; auto. }
    apply sig_invert_t in H0.
    destruct H0 as (ln & Hln).
    exists (S (lmax ln)).
    intros [ | m ] Hm.
    omega.
    apply Forall_forall.
    intros y Hy.
    destruct iter_N_S with (1 := Hy) as (z & H1 & H2).
    destruct (Forall2_In_inv_left Hln _ H2) as (k & H4 & H5).
    specialize (H5 m).
    rewrite Forall_forall in H5.
    apply H5; auto.
    apply le_trans with (lmax ln).
    apply lmax_In; auto.
    omega.
  Qed.

End fan_rel.

Section fan_alt.

  Variables (X : Type)
            (R : X -> X -> Prop) (R_fin : forall x, finite_t (R x))
            (P : X -> Prop) (HP : forall x y, R x y -> P x -> P y).

  Let R_mono n : forall x y, rel_iter R n x y -> P x -> P y.
  Proof.
    induction n as [ | n IHn ]; simpl; intros x y H Hx.
    destruct H; auto.
    destruct H as (z & H1 & H2).
    apply IHn with (1 := H2), HP with (1 := H1), Hx.
  Qed.

  (* If R is (computationnaly) finitary and P is R-monotonic,
     if P is bound to be reached from x, then P is bound to be
     reached uniformly from x *)

  Theorem fan_alt_t x : bar_rel_t R P x -> { n | forall m y, n <= m -> rel_iter R m x y -> P y }.
  Proof.
    induction 1 as [ x Hx | x Hx IHx ].
    * exists 0; intros ? ? _ H; apply R_mono with (1 := H); auto.
    * destruct (R_fin x) as (ll & Hll).
      assert (IH : forall y, In y ll -> { n | forall m z, n <= m -> rel_iter R m y z -> P z }).
      { intros y Hy; apply IHx, Hll, Hy. }
      apply sig_invert_t in IH.
      destruct IH as (mm & Hmm).
      exists (S (lmax mm)); intros [ | m ] y Hm.
      - omega.
      - intros (z & H1 & H2).
        apply Hll in H1.
        destruct (Forall2_In_inv_left Hmm _ H1) as (u & H3 & H4).
        apply H4 with m; auto.
        apply le_trans with (1 := lmax_In _ _ H3); omega.
  Qed.

End fan_alt.


From Ordinal Require Import CommonHeader Base.
From Coq.Arith Require Import PeanoNat.
From Coq.Vectors Require Fin.

Generalizable Variables n w P.

Section Finiteness.
  Import Ord.
  Open Scope equiv_scope.

  (* This is in Type instead of Prop because we want to eliminate it
     to extract a witness *)
  Inductive Finite: Ord → Type :=
  | finite_zero: Finite zero
  | finite_succ w: Finite w → Finite (succ w)
  | finite_eq w w': w == w' → Finite w → Finite w'.

  Existing Class Finite.
  Existing Instance finite_zero.
  Existing Instance finite_succ.
  Existing Instance finite_eq.

  (* Uninformative variant, if you really want it *)
  Variant Is_Finite: Ord → Prop := finite_witness w: Finite w → Is_Finite w.

  #[export] Instance finite_proper: Proper (eq ==> iff) Is_Finite.
  Proof.
    repeat intro; split; destruct 1; constructor.
    - exact (finite_eq H X).
    - symmetry in H; exact (finite_eq H X).
  Qed.

  Section FromNatUniqueness.
    Context `(f: Nat.t -> Ord.t).
    Hypothesis f0: f Nat.zero == Ord.zero.
    Hypothesis fS: forall n, f (Nat.succ n) == Ord.succ (f n).

    Theorem from_nat_uniqueness: f === from_nat.
    Proof.
      intro n; now_show (f n == from_nat n).
      induction n.
      - trivial.
      - rewrite -> fS; now apply succ_compat.
    Qed.
  End FromNatUniqueness.

  Instance nat_Finite (n: nat): Finite (from_nat n).
  Proof.
    induction n.
    - exact finite_zero.
    - simpl. apply finite_succ, IHn.
  Defined.

  Instance nat_eq_Finite w n (EQ: from_nat n == w): Finite w.
  Proof.
    apply (finite_eq EQ), nat_Finite.
  Defined.

  Definition to_nat `(Finite w): {n:nat | w == from_nat n}.
  Proof.
    induction H as [| w H [n IH] | w w' EQ H [n IH]].
    - exists Nat.zero. reflexivity.
    - exists (Nat.succ n). apply succ_compat, IH.
    - exists n. rewrite <- EQ; assumption.
  Defined.

  Theorem ω_not_finite: notT (Finite (ssup from_nat)).
  Proof.
    intro H; apply to_nat in H. destruct H as [n [H _]].
    induction n.
    - specialize (H 0%nat) as [devil _]. contradiction.
    - rewrite <- le_lt in H.
      specialize (H (Nat.succ n)).
      contradict H; apply irreflexivity.
  Qed.

End Finiteness.

(*
Module FinOrd.
  Import Ord.
  #[local] Notation Fin := Fin.t.

  Local Lemma Fin0_empty: ¬inhabited (Fin 0).
  Proof λ inh, let (x) := inh in Fin.case0 _ x.

  Definition from_Fin (n:nat): Fin n -> t.
    induction n as [| n IH].
    - exact (Fin.case0 _).
    - intro x. simple inversion x.
      + exact (ssup IH).
      + exact (eq_rect _ (λ n, Fin n → t) IH _ (eq_add_S _ _ (eq_sym H0))).
  Defined.

  Property Fin_0_0: ssup (@from_Fin 0) == 0.
  Proof.
    apply zero_empty, Fin0_empty.
  Qed.

  Property Fin_S_S: ∀ n,
      ssup (@from_Fin (Nat.succ n)) == succ (ssup (@from_Fin n)).
  Proof.
    intro n. apply succ_unique.
    - now_show (ssup (@from_Fin n) < ssup (@from_Fin (Nat.succ n))).
      exists Fin.F1.
      change (from_Fin Fin.F1) with (ssup (@from_Fin n)).
      apply strict_sup_greater.
    - intros y H; apply le_lt_reduce.
      now_show (∀ x: Fin.t (Nat.succ n), from_Fin x < y).
      intro x. induction x.
      + (* F1 case *) assumption.
      + (* FS case *)
        simpl.
        transitivity (ssup (@from_Fin n)).
        * apply strict_sup_greater.
        * exact H.
  Qed.

  Theorem Fin_ordinality: ∀ n:nat, ssup (@from_Fin n) == finite n.
  Proof.
    apply finite_uniqueness; [exact Fin_0_0 | exact Fin_S_S].
  Qed.

  Definition Fin_preimage {n:nat}:
      ∀ (w:Ord) (H: w < n), {x: Fin n | from_Fin x == w}.
  induction n.
  - intros; contradict H. apply zero_not_less.
  - intros. change (w < succ n) in H.
    apply le_lt_succ in H.
    apply succ_inj in H. . simpl in H. succ_inj in H.
    *)


Require BinPos POrderedType.
Require ZArith Zbool.
Require NArith.

(** Adapted from the infra.v library from CAD project *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require choice bigop ssralg.

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

Import ZArith NArith.
Lemma pospred_ofsuccnat n:
  Pos.pred_N (Pos.of_succ_nat n) = N.of_nat n.
Proof.
by apply N2Nat.inj;
rewrite N.pos_pred_spec Nat2N.id N2Nat.inj_pred /= SuccNat2Pos.pred_id.
Qed.

Lemma n_succ_pos_inj {p q} :
  N.succ_pos p = N.succ_pos q ->
  p = q.
Proof.
move=> H; move: (f_equal Npos H).
by rewrite !N.succ_pos_spec; apply N.succ_inj.
Qed.

(** Shorter names for the bijection between [N] and [nat] *)
Notation N2n := N.to_nat.
Notation n2N := N.of_nat.
Notation N2n2N := N2Nat.id.
Notation n2N2n := Nat2N.id.
Notation nsuccI := N2Nat.inj_succ.

Require Import Psatz.
Lemma N2n_lt a b:
 (a < b)%num <-> (N2n a < N2n b).
Proof.
symmetry; split => [/ltP H | H]; [|apply/ltP]; lia.
Qed.

Lemma n2N_lt a b:
 (a < b) <-> (n2N a < n2N b)%num.
Proof.
split => [/ltP H | H]; [|apply/ltP]; lia.
Qed.

Lemma N2n_le a b:
 (a <= b)%num <-> (N2n a <= N2n b).
Proof.
symmetry; split => [/leP H | H]; [|apply/leP]; lia.
Qed.

Lemma n2N_le a b:
 (a <= b) <-> (n2N a <= n2N b)%num.
Proof.
split => [/leP H | H]; [|apply/leP]; lia.
Qed.

Local Open Scope ring_scope.

(* -------------------------------------------------------------------- *)
(* Various eqtype, subtype, choice, count canonical structures          *)
(*               from the standard library                              *)
(* -------------------------------------------------------------------- *)

(* Structures on positive *)
Import BinPos.

Definition eqp (p q : positive) : bool :=
  match ( (Pos.compare_cont p q Eq))%positive with Eq => true | _ => false end.

Lemma eqpP : Equality.axiom eqp.
Proof.
move=> p q; apply: (iffP  idP)=>[|<-]; last by rewrite /eqp Pcompare_refl.
rewrite /eqp; case e: (Pos.compare_cont p q Eq)%positive=> // _; exact: Pcompare_Eq_eq.
Qed.

Canonical Structure eqp_Mixin := EqMixin eqpP.
Canonical Structure eqp_eqType := Eval hnf in @EqType positive eqp_Mixin.

Definition p_unpickle n := Some (Ppred (P_of_succ_nat n)).

Lemma p_pick_cancel : pcancel nat_of_P p_unpickle.
Proof.
move=> x; rewrite /p_unpickle; congr Some.
by rewrite Pnat.pred_o_P_of_succ_nat_o_nat_of_P_eq_id.
Qed.

Import choice.
Definition p_countMixin  := CountMixin p_pick_cancel.
Definition p_choiceMixin := CountChoiceMixin p_countMixin.

Canonical Structure p_choiceType :=
  Eval hnf in ChoiceType positive p_choiceMixin.
Canonical Structure p_countType :=
  Eval hnf in CountType positive p_countMixin.

Lemma eqNP: Equality.axiom N.eqb.
Proof.
move=> p q; apply: (iffP  idP)=>[|<-].
 by move=> /N.eqb_eq ->.
by rewrite N.eqb_refl.
Qed.

Canonical Structure eqN_Mixin := EqMixin eqNP.
Canonical Structure eqN_eqType := Eval hnf in @EqType N eqN_Mixin.

Section ComparisonAddendum.

(** First, we equip the comparison type with the eqType structure *)
Definition eq_comparison :=
 [rel x y | match x,y with Lt,Lt | Eq,Eq | Gt,Gt => true | _,_ => false end].

Lemma eq_comparisonP :  Equality.axiom eq_comparison.
Proof.
move=> x y; apply: (iffP idP) => [|<-]; last by elim x.
case: x; case: y; by [].
Qed.

Canonical Structure comparison_eqMixin := EqMixin eq_comparisonP.
Canonical Structure comparison_eqType := Eval hnf in @EqType _ comparison_eqMixin.

Implicit Arguments eq_comparisonP [x y].
Prenex Implicits eq_comparisonP.

Lemma eq_comparisonE : eq_comparison = eq_op :> rel _ . Proof. by []. Qed.

End ComparisonAddendum.

(* Structures on Z *)

Lemma eqzP : Equality.axiom Zeq_bool.
Proof. by move=> z1 z2;  apply: (iffP idP); move/Zeq_is_eq_bool. Qed.

Canonical Structure Z_Mixin := EqMixin eqzP.
Require Import ZArith.
Canonical Structure Z_eqType := Eval hnf in EqType Z Z_Mixin.

Definition z_code (z : Z) :=
  match z with
    |0%Z => (0%nat, true)
    |Zpos p => (pickle p, true)
    |Zneg p => (pickle p, false)
  end.

Definition z_pickle z := pickle (z_code z).

Definition z_decode c :=
  match c with
    |(0%nat, true) => Some 0%Z
    |(0%nat, false) => None
    |(n, true) =>
      if (@unpickle p_countType n) is Some p then Some (Zpos p) else None
    |(n, false) =>
      if (@unpickle p_countType n) is Some p then Some (Zneg p) else None
  end.

Definition z_unpickle n :=
  match (unpickle n) with
    |None => None
    |Some u => z_decode u
  end.

Lemma z_codeK : pcancel z_code z_decode.
Proof.
rewrite /z_code /z_decode.
case=> // n; case e : (@pickle p_countType n)=>[|m]; rewrite -?e ?pickleK //;
by move/ltP: (lt_O_nat_of_P n); rewrite -e -[pickle]/nat_of_P ltnn.
Qed.

Lemma z_pick_cancel : pcancel z_pickle z_unpickle.
Proof. by move=> x; rewrite /z_pickle /z_unpickle pickleK z_codeK. Qed.

Definition z_countMixin  := CountMixin z_pick_cancel.
Definition z_choiceMixin := CountChoiceMixin z_countMixin.

Canonical Structure z_choiceType :=
  Eval hnf in ChoiceType Z z_choiceMixin.
Canonical Structure z_countType :=
  Eval hnf in CountType Z z_countMixin.

Lemma ZplusA : associative Zplus.
Proof. by exact Zplus_assoc. Qed.

Lemma ZplusC : commutative Zplus.
Proof. by exact Zplus_comm. Qed.

Lemma Zplus0 : left_id (0%Z) Zplus.
Proof. by exact Zplus_0_l. Qed.

Lemma ZplusNr : left_inverse  0%Z Zopp Zplus.
Proof. exact Zplus_opp_l. Qed.

Lemma ZplusrN : right_inverse 0%Z Zopp Zplus.
Proof. exact Zplus_opp_r. Qed.

Import ssralg.
Definition Z_zmodMixin :=
  ZmodMixin ZplusA ZplusC Zplus0 ZplusNr.

Canonical Structure Z_zmodType := ZmodType Z Z_zmodMixin.

(* Z Ring *)
Lemma ZmultA : associative Zmult.
Proof. exact: Zmult_assoc. Qed.

Lemma Zmult1q : left_id 1%Z Zmult.
Proof. exact: Zmult_1_l. Qed.

Lemma Zmultq1 : right_id 1%Z Zmult.
Proof. exact: Zmult_1_r. Qed.

Lemma Zmultq0 : forall (q : Z), Zmult q 0%Z = 0%Z.
Proof. exact: Zmult_0_r. Qed.

Lemma Zmult_addl : left_distributive Zmult Zplus.
Proof. exact: Zmult_plus_distr_l. Qed.

Lemma Zmult_addr : right_distributive Zmult Zplus.
Proof. exact: Zmult_plus_distr_r. Qed.

Lemma nonzeroZ1 : 1%Z != 0%Z.
Proof. by []. Qed.

Lemma ZmultC : commutative Zmult.
Proof. exact: Zmult_comm. Qed.

Definition Z_comRingMixin :=
  ComRingMixin ZmultA ZmultC Zmult1q Zmult_addl nonzeroZ1.
(*
Definition Z_ringMixin :=
  RingMixin ZmultA Zmult1q Zmultq1 Zmult_addl Zmult_addr nonzeroZ1.
*)
Canonical Structure Z_Ring := Eval hnf in RingType Z Z_comRingMixin.
Canonical Structure Z_comRing := Eval hnf in ComRingType Z ZmultC.

(*
Canonical Structure Z_ringType :=
  Eval hnf in RingType Z_ringMixin.

Canonical Structure Z_comRingType := ComRingType ZmultC.
*)

(* Warning : an antisymmetric an a transitive predicates are
present in loaded Relations.Relation_Definition *)
Lemma ZleP: forall x y, reflect (x <= y)%Z (Zle_bool x y).
Proof.
move=> x y; apply/(iffP idP).
 by move=> H; apply Zle_bool_imp_le in H.
by move=> H; apply Zle_imp_le_bool.
Qed.

Lemma Zle_bool_antisymb : ssrbool.antisymmetric  Zle_bool.
Proof. by move=> x y; case/andP=> h1 h2; apply: Zle_bool_antisym. Qed.

Lemma Zle_bool_transb : ssrbool.transitive Zle_bool.
Proof. move=> x y z; exact: Zle_bool_trans. Qed.

Lemma Zle_bool_totalb : ssrbool.total Zle_bool.
Proof. by move=> x y; case: (Zle_bool_total x y)=> -> //; rewrite orbT. Qed.

Lemma Zle_bool_addr : forall z x y, Zle_bool x y -> Zle_bool (x + z) (y + z).
Proof. by move=> x y z h; rewrite Zle_bool_plus_mono // Zle_bool_refl. Qed.

Lemma Zle_bool_mulr : forall x y,
  Zle_bool 0 x -> Zle_bool 0 y -> Zle_bool 0 (x * y).
Proof.
move=> x y; move/Zle_is_le_bool=> px; move/Zle_is_le_bool=> py.
by apply/Zle_is_le_bool; apply: Zmult_le_0_compat.
Qed.

Lemma ZltP: forall x y, reflect (x < y)%Z (Zlt_bool x y).
Proof. move=> x y; apply/(iffP idP); by apply Zlt_is_lt_bool. Qed.

Lemma ZgeP: forall x y, reflect (x >= y)%Z (Zge_bool x y).
Proof. move=> x y; apply/(iffP idP); rewrite Z.geb_leb.
 by move => /ZleP; auto with zarith.
by move=> H; apply/ZleP; auto with zarith.
Qed.

Lemma ZgtP: forall x y, reflect (x > y)%Z (Zgt_bool x y).
Proof. move=> x y; apply/(iffP idP); by apply Zgt_is_gt_bool. Qed.

Definition Zunit := pred2 1%Z (-1)%Z.

Definition Zinv (z : Z) := z.

Lemma ZmulV : {in Zunit, left_inverse 1%R Zinv *%R}.
Proof. by move=> x; rewrite inE; case/pred2P => ->. Qed.

(* Zmult_1_inversion_r does not exist *)
Lemma unitZPl : forall x y, y * x = 1 -> Zunit x.
Proof.
move=> y x; rewrite GRing.mulrC -[y * x]/(Zmult y x); move/Zmult_1_inversion_l.
by case=> ->.
Qed.

Lemma  Zinv_out : {in predC Zunit, Zinv =1 id}.
Proof. exact. Qed.

Definition Z_comUnitRingMixin :=  ComUnitRingMixin ZmulV unitZPl Zinv_out.

Canonical Structure Z_unitRingType :=
  Eval hnf in UnitRingType Z Z_comUnitRingMixin.

Canonical Structure Z_comUnitRing := Eval hnf in [comUnitRingType of Z].

(*
Canonical Structure Z_comUnitRing := ComUnitRingType Z_comUnitRingMixin. (*Eval hnf in [comUnitRingType of Z].*)
*)
Lemma Z_idomain_axiom : forall x y : Z,
  x * y = 0 -> (x == 0) || (y == 0).
Proof.
move=> x y; rewrite -[x * y]/(Zmult x y); move/Zmult_integral; case=> -> //=.
by rewrite eqxx orbT.
Qed.
Canonical Structure Z_iDomain := Eval hnf in IdomainType Z Z_idomain_axiom.
(*
Canonical Structure Z_iDomain := Eval hnf in IdomainType Z_idomain_axiom.
*)
(*
Definition Z_OrderedRingMixin :=
  OrderedRing.Mixin
  Zle_bool_antisymb Zle_bool_transb Zle_bool_totalb Zle_bool_addr Zle_bool_mulr.

Canonical Structure Z_oIdomainType :=
  Eval hnf in OIdomainType Z Z_OrderedRingMixin.

*)