(************************************************************************

 Limits and colimits in the iso-comma category

 Contents
 1. Terminal objects
 2. Products
 3. Pullbacks
 4. Initial objects
 5. Coproducts

 ************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.IsoCommaCategory.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.pullbacks.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.Preservation.

Local Open Scope cat.

Section IsoCommaLimits.
  Context {C₁ C₂ C₃ : category}
          (F : C₁ ⟶ C₃)
          (G : C₂ ⟶ C₃).

  (**
   1. Terminal objects
   *)
  Section TerminalObject.
    Context (HF : preserves_terminal F)
            (HG : preserves_terminal G).

    Definition isTerminal_iso_comma
               (x : iso_comma F G)
               (H₁ : isTerminal C₁ (pr11 x))
               (H₂ : isTerminal C₂ (pr21 x))
      : isTerminal (iso_comma F G) x.
    Proof.
      intros w.
      use iscontraprop1.
      - abstract
          (use invproofirrelevance ;
           intros φ₁ φ₂ ;
           use eq_iso_comma_mor ;
           [ apply (@TerminalArrowEq _ (make_Terminal _ H₁))
           | apply (@TerminalArrowEq _ (make_Terminal _ H₂)) ]).
      - refine ((TerminalArrow (_ ,, H₁) (pr11 w)
                   ,,
                   TerminalArrow (_ ,, H₂) (pr21 w))
                  ,,
                  _).
        apply (@TerminalArrowEq _ (make_Terminal _ (HG _ H₂))).
    Defined.

    Definition terminal_category_iso_comma
               (T₁ : Terminal C₁)
               (T₂ : Terminal C₂)
      : Terminal (iso_comma F G).
    Proof.
      simple refine (_ ,, _).
      - refine ((pr1 T₁ ,, pr1 T₂) ,, _) ; cbn.
        exact (z_iso_Terminals
                 (make_Terminal _ (HF _ (pr2 T₁)))
                 (make_Terminal _ (HG _ (pr2 T₂)))).
      - apply isTerminal_iso_comma.
        + exact (pr2 T₁).
        + exact (pr2 T₂).
    Defined.

    Definition iso_comma_pr1_preserves_terminal
               (T₁ : Terminal C₁)
               (T₂ : Terminal C₂)
      : preserves_terminal (iso_comma_pr1 F G).
    Proof.
      apply (preserves_terminal_if_preserves_chosen
               (terminal_category_iso_comma T₁ T₂)
               (iso_comma_pr1 F G)).
      exact (pr2 T₁).
    Defined.

    Definition iso_comma_pr2_preserves_terminal
               (T₁ : Terminal C₁)
               (T₂ : Terminal C₂)
      : preserves_terminal (iso_comma_pr2 F G).
    Proof.
      apply (preserves_terminal_if_preserves_chosen
               (terminal_category_iso_comma T₁ T₂)
               (iso_comma_pr2 F G)).
      exact (pr2 T₂).
    Defined.

    Definition iso_comma_ump1_preserves_terminal
               {C₀ : category}
               (H₁ : C₀ ⟶ C₁)
               (HH₁ : preserves_terminal H₁)
               (H₂ : C₀ ⟶ C₂)
               (HH₂ : preserves_terminal H₂)
               (α : nat_z_iso (H₁ ∙ F) (H₂ ∙ G))
      : preserves_terminal (iso_comma_ump1 F G H₁ H₂ α).
    Proof.
      intros x Hx.
      apply isTerminal_iso_comma.
      - apply HH₁.
        exact Hx.
      - apply HH₂.
        exact Hx.
    Defined.
  End TerminalObject.

  (**
   2. Products
   *)
  Section Product.
    Context (HF : preserves_binproduct F)
            (HG : preserves_binproduct G).

    Section IsProductInIsoComma.
      Context {x y z : iso_comma F G}
              (p₁ : z --> x)
              (p₂ : z --> y)
              (H₁ : isBinProduct _ (pr11 x) (pr11 y) (pr11 z) (pr11 p₁) (pr11 p₂))
              (H₂ : isBinProduct _ (pr21 x) (pr21 y) (pr21 z) (pr21 p₁) (pr21 p₂)).

      Let P₁ : BinProduct C₁ (pr11 x) (pr11 y) := make_BinProduct _ _ _ _ _ _ H₁.
      Let P₂ : BinProduct C₂ (pr21 x) (pr21 y) := make_BinProduct _ _ _ _ _ _ H₂.

      Section UMP.
        Context {w : iso_comma F G}
                (f : w --> x)
                (g : w --> y).

        Definition isBinProduct_in_iso_comma_unique
          : isaprop (∑ (fg : w --> z), fg · p₁ = f × fg · p₂ = g).
        Proof.
          use invproofirrelevance.
          intros φ₁ φ₂.
          use subtypePath.
          {
            intro.
            apply isapropdirprod ; apply homset_property.
          }
          use eq_iso_comma_mor.
          - use (BinProductArrowsEq _ _ _ P₁).
            + exact (maponpaths (λ z, pr11 z) (pr12 φ₁)
                     @ !(maponpaths (λ z, pr11 z) (pr12 φ₂))).
            + exact (maponpaths (λ z, pr11 z) (pr22 φ₁)
                     @ !(maponpaths (λ z, pr11 z) (pr22 φ₂))).
          - use (BinProductArrowsEq _ _ _ P₂).
            + exact (maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr12 φ₁)
                     @ !(maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr12 φ₂))).
            + exact (maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr22 φ₁)
                     @ !(maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr22 φ₂))).
        Qed.

        Definition isBinProduct_in_iso_comma_ump
          : w --> z.
        Proof.
          simple refine ((_ ,, _) ,, _) ; cbn.
          - exact (BinProductArrow _ P₁ (pr11 f) (pr11 g)).
          - exact (BinProductArrow _ P₂ (pr21 f) (pr21 g)).
          - use (BinProductArrowsEq
                   _ _ _
                   (make_BinProduct _ _ _ _ _ _ (HG _ _ _ _ _ (pr2 P₂)))) ; cbn.
            + abstract
                (rewrite !assoc' ;
                 rewrite <- functor_comp ;
                 rewrite (BinProductPr1Commutes _ _ _ P₂) ;
                 refine (_ @ pr2 f) ;
                 refine (!(maponpaths (λ z, _ · z) (pr2 p₁)) @ _) ;
                 rewrite !assoc ;
                 rewrite <- functor_comp ;
                 rewrite (BinProductPr1Commutes _ _ _ P₁) ;
                 apply idpath).
            + abstract
                (rewrite !assoc' ;
                 rewrite <- functor_comp ;
                 rewrite (BinProductPr2Commutes _ _ _ P₂) ;
                 refine (_ @ pr2 g) ;
                 refine (!(maponpaths (λ z, _ · z) (pr2 p₂)) @ _) ;
                 rewrite !assoc ;
                 rewrite <- functor_comp ;
                 rewrite (BinProductPr2Commutes _ _ _ P₁) ;
                 apply idpath).
        Defined.

        Definition isBinProduct_in_iso_comma_ump_pr1
          : isBinProduct_in_iso_comma_ump · p₁ = f.
        Proof.
          use eq_iso_comma_mor ; cbn.
          - apply (BinProductPr1Commutes _ _ _ P₁).
          - apply (BinProductPr1Commutes _ _ _ P₂).
        Qed.

        Definition isBinProduct_in_iso_comma_ump_pr2
          : isBinProduct_in_iso_comma_ump · p₂ = g.
        Proof.
          use eq_iso_comma_mor ; cbn.
          - apply (BinProductPr2Commutes _ _ _ P₁).
          - apply (BinProductPr2Commutes _ _ _ P₂).
        Qed.
      End UMP.

      Definition isBinProduct_in_iso_comma
        : isBinProduct (iso_comma F G) x y z p₁ p₂.
      Proof.
        intros w f g.
        use iscontraprop1.
        - exact (isBinProduct_in_iso_comma_unique f g).
        - simple refine (_ ,, _ ,, _).
          + exact (isBinProduct_in_iso_comma_ump f g).
          + exact (isBinProduct_in_iso_comma_ump_pr1 f g).
          + exact (isBinProduct_in_iso_comma_ump_pr2 f g).
      Defined.
    End IsProductInIsoComma.

    Definition binproducts_in_iso_comma
               (HC₁ : BinProducts C₁)
               (HC₂ : BinProducts C₂)
      : BinProducts (iso_comma F G).
    Proof.
      intros x y.
      pose (FP := make_BinProduct
                    _ _ _ _ _ _
                    (HF (pr11 x) (pr11 y)
                       _
                       (BinProductPr1 _ (HC₁ (pr11 x) (pr11 y)))
                       (BinProductPr2 _ (HC₁ (pr11 x) (pr11 y)))
                       (isBinProduct_BinProduct _ (HC₁ (pr11 x) (pr11 y))))).
      pose (GP := make_BinProduct
                    _ _ _ _ _ _
                    (HG (pr21 x) (pr21 y)
                       _
                       (BinProductPr1 _ (HC₂ (pr21 x) (pr21 y)))
                       (BinProductPr2 _ (HC₂ (pr21 x) (pr21 y)))
                       (isBinProduct_BinProduct _ (HC₂ (pr21 x) (pr21 y))))).
      use make_BinProduct.
      - simple refine ((_ ,, _) ,, _).
        + exact (BinProductObject _ (HC₁ (pr11 x) (pr11 y))).
        + exact (BinProductObject _ (HC₂ (pr21 x) (pr21 y))).
        + exact (binproduct_of_z_iso FP GP (pr2 x) (pr2 y)).
      - simple refine ((_ ,, _) ,, _).
        + exact (BinProductPr1 _ (HC₁ (pr11 x) (pr11 y))).
        + exact (BinProductPr1 _ (HC₂ (pr21 x) (pr21 y))).
        + exact (!(BinProductOfArrowsPr1 _ GP FP (pr12 x) (pr12 y))).
      - simple refine ((_ ,, _) ,, _).
        + exact (BinProductPr2 _ (HC₁ (pr11 x) (pr11 y))).
        + exact (BinProductPr2 _ (HC₂ (pr21 x) (pr21 y))).
        + exact (!(BinProductOfArrowsPr2 _ GP FP (pr12 x) (pr12 y))).
      -  use isBinProduct_in_iso_comma.
         + apply isBinProduct_BinProduct.
         + apply isBinProduct_BinProduct.
    Defined.

    Definition iso_comma_pr1_preserves_binproduct
               (HC₁ : BinProducts C₁)
               (HC₂ : BinProducts C₂)
      : preserves_binproduct (iso_comma_pr1 F G).
    Proof.
      use preserves_binproduct_if_preserves_chosen.
      - apply binproducts_in_iso_comma.
        + exact HC₁.
        + exact HC₂.
      - intros x y.
        cbn.
        apply isBinProduct_BinProduct.
    Defined.

    Definition iso_comma_pr2_preserves_binproduct
               (HC₁ : BinProducts C₁)
               (HC₂ : BinProducts C₂)
      : preserves_binproduct (iso_comma_pr2 F G).
    Proof.
      use preserves_binproduct_if_preserves_chosen.
      - apply binproducts_in_iso_comma.
        + exact HC₁.
        + exact HC₂.
      - intros x y.
        cbn.
        apply isBinProduct_BinProduct.
    Defined.

    Definition iso_comma_ump1_preserves_binproduct
               {C₀ : category}
               (H₁ : C₀ ⟶ C₁)
               (HH₁ : preserves_binproduct H₁)
               (H₂ : C₀ ⟶ C₂)
               (HH₂ : preserves_binproduct H₂)
               (α : nat_z_iso (H₁ ∙ F) (H₂ ∙ G))
      : preserves_binproduct (iso_comma_ump1 F G H₁ H₂ α).
    Proof.
      intros x y z π₁ π₂ Hx.
      apply isBinProduct_in_iso_comma.
      - apply HH₁.
        exact Hx.
      - apply HH₂.
        exact Hx.
    Defined.
  End Product.

  (**
   3. Pullbacks
   *)
  Section Pullbacks.
    Context (HF : preserves_pullback F)
            (HG : preserves_pullback G).

    Section IsPullbackIsoComma.
      Context {pb x y z : iso_comma F G}
              (f : x --> z)
              (g : y --> z)
              (π₁ : pb --> x)
              (π₂ : pb --> y)
              (sqr₁ : pr11 π₁ · pr11 f = pr11 π₂ · pr11 g)
              (H₁ : isPullback sqr₁)
              (sqr₂ : pr21 π₁ · pr21 f = pr21 π₂ · pr21 g)
              (H₂ : isPullback sqr₂)
              (sqr₃ : π₁ · f = π₂ · g).

      Let P₁ : Pullback (pr11 f) (pr11 g) := make_Pullback _ H₁.
      Let P₂ : Pullback (pr21 f) (pr21 g) := make_Pullback _ H₂.

      Section UMP.
        Context {w : iso_comma F G}
                (h₁ : w --> x)
                (h₂ : w --> y)
                (p : h₁ · f = h₂ · g).

        Definition isPullback_iso_comma_unique
          : isaprop (∑ (hk : w --> pb), hk · π₁ = h₁ × hk · π₂ = h₂).
        Proof.
          use invproofirrelevance.
          intros φ₁ φ₂.
          use subtypePath.
          {
            intro.
            apply isapropdirprod ; apply homset_property.
          }
          use eq_iso_comma_mor.
          - use (MorphismsIntoPullbackEqual H₁).
            + refine (maponpaths (λ z, pr11 z) (pr12 φ₁) @ _).
              exact (!(maponpaths (λ z, pr11 z) (pr12 φ₂))).
            + refine (maponpaths (λ z, pr11 z) (pr22 φ₁) @ _).
              exact (!(maponpaths (λ z, pr11 z) (pr22 φ₂))).
          - use (MorphismsIntoPullbackEqual H₂).
            + refine (maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr12 φ₁) @ _).
              exact (!(maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr12 φ₂))).
            + refine (maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr22 φ₁) @ _).
              exact (!(maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr22 φ₂))).
        Qed.

        Definition isPullback_iso_comma_mor
          : w --> pb.
        Proof.
          simple refine ((_ ,, _) ,, _).
          - refine (PullbackArrow P₁ _ (pr11 h₁) (pr11 h₂) _).
            abstract (exact (maponpaths (λ z, pr11 z) p)).
          - refine (PullbackArrow P₂ _ (pr21 h₁) (pr21 h₂) _).
            abstract (exact (maponpaths (λ z, dirprod_pr2 (pr1 z)) p)).
          - use (MorphismsIntoPullbackEqual (HG _ _ _ _ _ _ _ _ _ _ (pr22 P₂))).
            + abstract
                (rewrite <- !functor_comp ;
                 apply maponpaths ;
                 exact (PullbackSqrCommutes P₂)).
            + abstract
                (cbn ;
                 rewrite !assoc' ;
                 rewrite <- !functor_comp ;
                 rewrite (PullbackArrow_PullbackPr1 P₂) ;
                 refine (_ @ pr2 h₁) ;
                 rewrite <- (pr2 π₁) ;
                 rewrite !assoc ;
                 apply maponpaths_2 ;
                 rewrite <- !functor_comp ;
                 apply maponpaths ;
                 apply (PullbackArrow_PullbackPr1 P₁)).
            + abstract
                (cbn ;
                 rewrite !assoc' ;
                 rewrite <- !functor_comp ;
                 rewrite (PullbackArrow_PullbackPr2 P₂) ;
                 refine (_ @ pr2 h₂) ;
                 rewrite <- (pr2 π₂) ;
                 rewrite !assoc ;
                 apply maponpaths_2 ;
                 rewrite <- !functor_comp ;
                 apply maponpaths ;
                 apply (PullbackArrow_PullbackPr2 P₁)).
        Defined.

        Definition isPullback_iso_comma_mor_pr1
          : isPullback_iso_comma_mor · π₁ = h₁.
        Proof.
          use eq_iso_comma_mor.
          - apply (PullbackArrow_PullbackPr1 P₁).
          - apply (PullbackArrow_PullbackPr1 P₂).
        Qed.

        Definition isPullback_iso_comma_mor_pr2
          : isPullback_iso_comma_mor · π₂ = h₂.
        Proof.
          use eq_iso_comma_mor.
          - apply (PullbackArrow_PullbackPr2 P₁).
          - apply (PullbackArrow_PullbackPr2 P₂).
        Qed.
      End UMP.

      Definition isPullback_iso_comma
        : isPullback sqr₃.
      Proof.
        intros w h₁ h₂ p.
        use iscontraprop1.
        - apply isPullback_iso_comma_unique.
        - simple refine (_ ,, _ ,, _).
          + exact (isPullback_iso_comma_mor h₁ h₂ p).
          + exact (isPullback_iso_comma_mor_pr1 h₁ h₂ p).
          + exact (isPullback_iso_comma_mor_pr2 h₁ h₂ p).
      Defined.
    End IsPullbackIsoComma.

    Definition pullbacks_in_iso_comma
               (HC₁ : Pullbacks C₁)
               (HC₂ : Pullbacks C₂)
      : Pullbacks (iso_comma F G).
    Proof.
      intros z x y f g.
      simple refine ((_ ,, _ ,, _) ,, (_ ,, _)).
      - simple refine ((_ ,, _) ,, _).
        + exact (PullbackObject (HC₁ _ _ _ (pr11 f) (pr11 g))).
        + exact (PullbackObject (HC₂ _ _ _ (pr21 f) (pr21 g))).
        + use (iso_between_pullbacks
                 _ _
                 (HF _ _ _ _ _ _ _ _ _ _
                    (isPullback_Pullback (HC₁ _ _ _ (pr11 f) (pr11 g))))
                 (HG _ _ _ _ _ _ _ _ _ _
                    (isPullback_Pullback (HC₂ _ _ _ (pr21 f) (pr21 g))))).
          * abstract
              (rewrite <- !functor_comp ;
               apply maponpaths ;
               apply PullbackSqrCommutes).
          * abstract
              (rewrite <- !functor_comp ;
               apply maponpaths ;
               apply PullbackSqrCommutes).
          * exact (pr2 x).
          * exact (pr2 y).
          * exact (pr2 z).
          * exact (!(pr2 f)).
          * exact (!(pr2 g)).
      - simple refine ((_ ,, _) ,, _).
        + apply PullbackPr1.
        + apply PullbackPr1.
        + abstract
            (cbn ; unfold iso_between_pullbacks_map ;
             refine (!_) ;
             apply (PullbackArrow_PullbackPr1
                      (make_Pullback
                         _
                         (HG _ _ _ _ _ _ _ _ _ _
                            (isPullback_Pullback (HC₂ _ _ _ (pr21 f) (pr21 g))))))).
      - simple refine ((_ ,, _) ,, _).
        + apply PullbackPr2.
        + apply PullbackPr2.
        + abstract
            (cbn ; unfold iso_between_pullbacks_map ;
             refine (!_) ;
             apply (PullbackArrow_PullbackPr2
                      (make_Pullback
                         _
                         (HG _ _ _ _ _ _ _ _ _ _
                            (isPullback_Pullback (HC₂ _ _ _ (pr21 f) (pr21 g))))))).
      - abstract
          (use eq_iso_comma_mor ; cbn ;
           [ apply PullbackSqrCommutes
           | apply PullbackSqrCommutes ]).
      - use isPullback_iso_comma.
        + apply PullbackSqrCommutes.
        + apply isPullback_Pullback.
        + apply PullbackSqrCommutes.
        + apply isPullback_Pullback.
    Defined.

    Definition iso_comma_pr1_preserves_pullback
               (HC₁ : Pullbacks C₁)
               (HC₂ : Pullbacks C₂)
      : preserves_pullback (iso_comma_pr1 F G).
    Proof.
      use preserves_pullback_if_preserves_chosen.
      - apply pullbacks_in_iso_comma.
        + exact HC₁.
        + exact HC₂.
      - intros x y z f g.
        cbn.
        apply isPullback_Pullback.
    Defined.

    Definition iso_comma_pr2_preserves_pullback
               (HC₁ : Pullbacks C₁)
               (HC₂ : Pullbacks C₂)
      : preserves_pullback (iso_comma_pr2 F G).
    Proof.
      use preserves_pullback_if_preserves_chosen.
      - apply pullbacks_in_iso_comma.
        + exact HC₁.
        + exact HC₂.
      - intros x y z f g.
        cbn.
        apply isPullback_Pullback.
    Defined.

    Definition iso_comma_ump1_preserves_pullback
               {C₀ : category}
               (H₁ : C₀ ⟶ C₁)
               (HH₁ : preserves_pullback H₁)
               (H₂ : C₀ ⟶ C₂)
               (HH₂ : preserves_pullback H₂)
               (α : nat_z_iso (H₁ ∙ F) (H₂ ∙ G))
      : preserves_pullback
          (iso_comma_ump1 F G H₁ H₂ α).
    Proof.
      intros w x y z f g π₁ π₂ p₁ p₂ H.
      use isPullback_iso_comma ; cbn.
      - abstract
          (rewrite <- !functor_comp ;
           apply maponpaths ;
           exact p₁).
      - exact (HH₁ _ _ _ _ _ _ _ _ _ _ H).
      - abstract
          (rewrite <- !functor_comp ;
           apply maponpaths ;
           exact p₁).
      - exact (HH₂ _ _ _ _ _ _ _ _ _ _ H).
    Defined.
  End Pullbacks.

  (**
   4. Initial objects
   *)
  Section InitialObject.
    Context (HF : preserves_initial F)
            (HG : preserves_initial G).

    Definition isInitial_iso_comma
               (x : iso_comma F G)
               (H₁ : isInitial C₁ (pr11 x))
               (H₂ : isInitial C₂ (pr21 x))
      : isInitial (iso_comma F G) x.
    Proof.
      intros w.
      use iscontraprop1.
      - abstract
          (use invproofirrelevance ;
           intros φ₁ φ₂ ;
           use eq_iso_comma_mor ;
           [ apply (@InitialArrowEq _ (make_Initial _ H₁))
           | apply (@InitialArrowEq _ (make_Initial _ H₂)) ]).
      - refine ((InitialArrow (_ ,, H₁) (pr11 w)
                 ,,
                 InitialArrow (_ ,, H₂) (pr21 w))
                ,,
                _).
        apply (@InitialArrowEq _ (make_Initial _ (HF _ H₁))).
    Defined.

    Definition initial_category_iso_comma
               (I₁ : Initial C₁)
               (I₂ : Initial C₂)
      : Initial (iso_comma F G).
    Proof.
      simple refine (_ ,, _).
      - refine ((pr1 I₁ ,, pr1 I₂) ,, _) ; cbn.
        exact (ziso_Initials
                 (make_Initial _ (HF _ (pr2 I₁)))
                 (make_Initial _ (HG _ (pr2 I₂)))).
      - apply isInitial_iso_comma.
        + exact (pr2 I₁).
        + exact (pr2 I₂).
    Defined.

    Definition iso_comma_pr1_preserves_initial
               (I₁ : Initial C₁)
               (I₂ : Initial C₂)
      : preserves_initial (iso_comma_pr1 F G).
    Proof.
      apply (preserves_initial_if_preserves_chosen
               (initial_category_iso_comma I₁ I₂)
               (iso_comma_pr1 F G)).
      exact (pr2 I₁).
    Defined.

    Definition iso_comma_pr2_preserves_initial
               (I₁ : Initial C₁)
               (I₂ : Initial C₂)
      : preserves_initial (iso_comma_pr2 F G).
    Proof.
      apply (preserves_initial_if_preserves_chosen
               (initial_category_iso_comma I₁ I₂)
               (iso_comma_pr2 F G)).
      exact (pr2 I₂).
    Defined.

    Definition iso_comma_ump1_preserves_initial
               {C₀ : category}
               (H₁ : C₀ ⟶ C₁)
               (HH₁ : preserves_initial H₁)
               (H₂ : C₀ ⟶ C₂)
               (HH₂ : preserves_initial H₂)
               (α : nat_z_iso (H₁ ∙ F) (H₂ ∙ G))
      : preserves_initial (iso_comma_ump1 F G H₁ H₂ α).
    Proof.
      intros x Hx.
      apply isInitial_iso_comma.
      - apply HH₁.
        exact Hx.
      - apply HH₂.
        exact Hx.
    Defined.
  End InitialObject.

  (**
   5. Coproducts
   *)
  Section Coproduct.
    Context (HF : preserves_bincoproduct F)
            (HG : preserves_bincoproduct G).

    Section IsCoproductInIsoComma.
      Context {x y z : iso_comma F G}
              (i₁ : x --> z)
              (i₂ : y --> z)
              (H₁ : isBinCoproduct _ (pr11 x) (pr11 y) (pr11 z) (pr11 i₁) (pr11 i₂))
              (H₂ : isBinCoproduct _ (pr21 x) (pr21 y) (pr21 z) (pr21 i₁) (pr21 i₂)).

      Let P₁ : BinCoproduct (pr11 x) (pr11 y) := make_BinCoproduct _ _ _ _ _ _ H₁.
      Let P₂ : BinCoproduct (pr21 x) (pr21 y) := make_BinCoproduct _ _ _ _ _ _ H₂.

      Section UMP.
        Context {w : iso_comma F G}
                (f : x --> w)
                (g : y --> w).

        Definition isBinCoproduct_in_iso_comma_unique
          : isaprop (∑ (fg : z --> w), i₁ · fg = f × i₂ · fg = g).
        Proof.
          use invproofirrelevance.
          intros φ₁ φ₂.
          use subtypePath.
          {
            intro.
            apply isapropdirprod ; apply homset_property.
          }
          use eq_iso_comma_mor.
          - use (BinCoproductArrowsEq _ _ _ P₁).
            + exact (maponpaths (λ z, pr11 z) (pr12 φ₁)
                     @ !(maponpaths (λ z, pr11 z) (pr12 φ₂))).
            + exact (maponpaths (λ z, pr11 z) (pr22 φ₁)
                     @ !(maponpaths (λ z, pr11 z) (pr22 φ₂))).
          - use (BinCoproductArrowsEq _ _ _ P₂).
            + exact (maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr12 φ₁)
                     @ !(maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr12 φ₂))).
            + exact (maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr22 φ₁)
                     @ !(maponpaths (λ z, dirprod_pr2 (pr1 z)) (pr22 φ₂))).
        Qed.

        Definition isBinCoproduct_in_iso_comma_ump
          : z --> w.
        Proof.
          simple refine ((_ ,, _) ,, _) ; cbn.
          - exact (BinCoproductArrow P₁ (pr11 f) (pr11 g)).
          - exact (BinCoproductArrow P₂ (pr21 f) (pr21 g)).
          - use (BinCoproductArrowsEq
                     _ _ _
                     (make_BinCoproduct _ _ _ _ _ _ (HF _ _ _ _ _ (pr2 P₁)))) ; cbn.
            + abstract
                (rewrite !assoc ;
                 rewrite <- functor_comp ;
                 rewrite (BinCoproductIn1Commutes _ _ _ P₁) ;
                 refine (pr2 f @ _) ;
                 refine (_ @ maponpaths (λ z, z · _) (!(pr2 i₁))) ;
                 rewrite !assoc' ;
                 apply maponpaths ;
                 rewrite <- functor_comp ;
                 apply maponpaths ;
                 refine (!_) ;
                 apply (BinCoproductIn1Commutes _ _ _ P₂)).
            + abstract
                (rewrite !assoc ;
                 rewrite <- functor_comp ;
                 rewrite (BinCoproductIn2Commutes _ _ _ P₁) ;
                 refine (pr2 g @ _) ;
                 refine (_ @ maponpaths (λ z, z · _) (!(pr2 i₂))) ;
                 rewrite !assoc' ;
                 apply maponpaths ;
                 rewrite <- functor_comp ;
                 apply maponpaths ;
                 refine (!_) ;
                 apply (BinCoproductIn2Commutes _ _ _ P₂)).
        Defined.

        Definition isBinCoproduct_in_iso_comma_ump_in1
          : i₁ · isBinCoproduct_in_iso_comma_ump = f.
        Proof.
          use eq_iso_comma_mor ; cbn.
          - apply (BinCoproductIn1Commutes _ _ _ P₁).
          - apply (BinCoproductIn1Commutes _ _ _ P₂).
        Qed.

        Definition isBinCoproduct_in_iso_comma_ump_in2
          : i₂ · isBinCoproduct_in_iso_comma_ump  = g.
        Proof.
          use eq_iso_comma_mor ; cbn.
          - apply (BinCoproductIn2Commutes _ _ _ P₁).
          - apply (BinCoproductIn2Commutes _ _ _ P₂).
        Qed.
      End UMP.

      Definition isBinCoproduct_in_iso_comma
        : isBinCoproduct (iso_comma F G) x y z i₁ i₂.
      Proof.
        intros w f g.
        use iscontraprop1.
        - exact (isBinCoproduct_in_iso_comma_unique f g).
        - simple refine (_ ,, _ ,, _).
          + exact (isBinCoproduct_in_iso_comma_ump f g).
          + exact (isBinCoproduct_in_iso_comma_ump_in1 f g).
          + exact (isBinCoproduct_in_iso_comma_ump_in2 f g).
      Defined.
    End IsCoproductInIsoComma.

    Definition bincoproducts_in_iso_comma
               (HC₁ : BinCoproducts C₁)
               (HC₂ : BinCoproducts C₂)
      : BinCoproducts (iso_comma F G).
    Proof.
      intros x y.
      pose (FP := make_BinCoproduct
                    _ _ _ _ _ _
                    (HF (pr11 x) (pr11 y)
                       _
                       (BinCoproductIn1 (HC₁ (pr11 x) (pr11 y)))
                       (BinCoproductIn2 (HC₁ (pr11 x) (pr11 y)))
                       (isBinCoproduct_BinCoproduct _ (HC₁ (pr11 x) (pr11 y))))).
      pose (GP := make_BinCoproduct
                    _ _ _ _ _ _
                    (HG (pr21 x) (pr21 y)
                       _
                       (BinCoproductIn1 (HC₂ (pr21 x) (pr21 y)))
                       (BinCoproductIn2 (HC₂ (pr21 x) (pr21 y)))
                       (isBinCoproduct_BinCoproduct _ (HC₂ (pr21 x) (pr21 y))))).
      use make_BinCoproduct.
      - simple refine ((_ ,, _) ,, _).
        + exact (BinCoproductObject (HC₁ (pr11 x) (pr11 y))).
        + exact (BinCoproductObject (HC₂ (pr21 x) (pr21 y))).
        + exact (bincoproduct_of_z_iso FP GP (pr2 x) (pr2 y)).
      - simple refine ((_ ,, _) ,, _).
        + exact (BinCoproductIn1 (HC₁ (pr11 x) (pr11 y))).
        + exact (BinCoproductIn1 (HC₂ (pr21 x) (pr21 y))).
        + exact ((BinCoproductOfArrowsIn1 _ FP GP (pr12 x) (pr12 y))).
      - simple refine ((_ ,, _) ,, _).
        + exact (BinCoproductIn2 (HC₁ (pr11 x) (pr11 y))).
        + exact (BinCoproductIn2 (HC₂ (pr21 x) (pr21 y))).
        + exact ((BinCoproductOfArrowsIn2 _ FP GP (pr12 x) (pr12 y))).
      -  use isBinCoproduct_in_iso_comma.
         + apply isBinCoproduct_BinCoproduct.
         + apply isBinCoproduct_BinCoproduct.
    Defined.

    Definition iso_comma_pr1_preserves_bincoproduct
               (HC₁ : BinCoproducts C₁)
               (HC₂ : BinCoproducts C₂)
      : preserves_bincoproduct (iso_comma_pr1 F G).
    Proof.
      use preserves_bincoproduct_if_preserves_chosen.
      - apply bincoproducts_in_iso_comma.
        + exact HC₁.
        + exact HC₂.
      - intros x y.
        cbn.
        apply isBinCoproduct_BinCoproduct.
    Defined.

    Definition iso_comma_pr2_preserves_bincoproduct
               (HC₁ : BinCoproducts C₁)
               (HC₂ : BinCoproducts C₂)
      : preserves_bincoproduct (iso_comma_pr2 F G).
    Proof.
      use preserves_bincoproduct_if_preserves_chosen.
      - apply bincoproducts_in_iso_comma.
        + exact HC₁.
        + exact HC₂.
      - intros x y.
        cbn.
        apply isBinCoproduct_BinCoproduct.
    Defined.

    Definition iso_comma_ump1_preserves_bincoproduct
               {C₀ : category}
               (H₁ : C₀ ⟶ C₁)
               (HH₁ : preserves_bincoproduct H₁)
               (H₂ : C₀ ⟶ C₂)
               (HH₂ : preserves_bincoproduct H₂)
               (α : nat_z_iso (H₁ ∙ F) (H₂ ∙ G))
      : preserves_bincoproduct (iso_comma_ump1 F G H₁ H₂ α).
    Proof.
      intros x y z π₁ π₂ Hx.
      apply isBinCoproduct_in_iso_comma.
      - apply HH₁.
        exact Hx.
      - apply HH₂.
        exact Hx.
    Defined.
  End Coproduct.
End IsoCommaLimits.


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

Require Import List.

Set Implicit Arguments.

Definition app_split { X : Type } (l1 l2 r1 r2 : list X) :
   l1++r1 = l2++r2 -> (exists m, l2 = l1++m /\ r1 = m++r2)
                   \/ (exists m, l1 = l2++m /\ r2 = m++r1).
Proof.
  revert l2 r1 r2.
  induction l1 as [ | x l1 Hl1 ].
  left; exists l2; auto.
  intros [ | y l2 ] r1 r2 H.
  right; exists (x::l1); auto.
  simpl in H; injection H; clear H; intros H ?; subst.
  apply Hl1 in H.
  destruct H as [ (m & H1 & H2) | (m & H1 & H2) ].
  left; exists m; subst; auto.
  right; exists m; subst; auto.
Qed.


Require Import ssreflect ssrfun ssrbool eqtype seq.
Require Import FunctionalExtensionality.
Require Import Coq.Logic.ProofIrrelevance.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** * Basic Category Theory *)

(*************************************************)
(** ** Categories                                *)
(*************************************************)

Module Category.

Section RawMixin.

(** ** A category over objects of type 'T'. *)

Record mixin_of (T : Type) := Mixin {
  mx_hom : forall a b : T, Type;    (** hom-sets *)
  (** we have an identity arrow at all types*)
  mx_id : forall a : T, mx_hom a a;
  (** composition of arrows *)
  mx_comp : forall a b c (f : mx_hom b c) (g : mx_hom a b), mx_hom a c;
  _ : forall a b (g : mx_hom a b), mx_comp (mx_id b) g = g;
  _ : forall a b (f : mx_hom a b), mx_comp f (mx_id a) = f;
  _ : forall a b c d (f : mx_hom c d) (g : mx_hom b c) (h : mx_hom a b),
        mx_comp f (mx_comp g h) = mx_comp (mx_comp f g) h
}.

End RawMixin.

Section ClassDef.
Local Notation tp := Type.

Record class_of T := Class {mixin : mixin_of T}.

Structure type : Type := Pack {sort : tp; _ : class_of sort; _ : tp}.
Local Coercion sort : type >-> Sortclass.

Variables (T : tp) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack T c T.

(* produce a category type out of the mixin *)
(* equalize m0 and m by means of a phantom *)
Definition pack (m0 : mixin_of T) :=
  fun m & phant_id m0 m => Pack (@Class T m) T.

Definition hom := mx_hom (mixin class).
Definition ida := mx_id (mixin class).
Definition comp := @mx_comp cT (mixin class).

End ClassDef.

Module Exports.
Coercion sort : type >-> Sortclass.
Notation category := Category.type.
Notation CategoryMixin := Category.Mixin.
Notation Category T m := (@pack T _ m id).

Notation "[ 'category' 'of' T 'for' cT ]" := (@clone T cT _ id)
  (at level 0, format "[ 'category'  'of'  T  'for'  cT ]") : form_scope.
Notation "[ 'category' 'of' T ]" := (@clone T _ _ id)
  (at level 0, format "[ 'category'  'of'  T ]") : form_scope.

Notation hom := Category.hom.
Notation ida := Category.ida.
Notation comp := Category.comp.

Arguments Category.hom [cT] a b.
Arguments Category.ida [cT a].
Arguments Category.comp [cT a b c] _ _.
Prenex Implicits Category.comp Category.ida Category.hom.

Section Laws.
Variable C : category.

Lemma id_left (a b : C) (g : hom a b) : comp ida g = g.
Proof. by case: C a b g=> ?; case; case. Qed.

Lemma id_right (a b : C) (f : hom a b) : comp f ida = f.
Proof. by case: C a b f=> ?; case; case. Qed.

Lemma comp_assoc (a b c d : C) (f : hom c d) (g : hom b c) (h : hom a b) :
  comp f (comp g h) = comp (comp f g) h.
Proof. by case: C a b c d f g h=> ?; case; case. Qed.

End Laws.

Hint Resolve id_left id_right comp_assoc.

End Exports.

End Category.

Export Category.Exports.

(*************************************************)
(** ** Some Categories                           *)
(*************************************************)

(** *** Category of Coq [Type]s *)

Section Coq.
Notation tp := (Type).
Program Definition coqCategoryMixin :=
  @Category.Mixin tp (fun A B => A -> B)
      (fun A (a : A) => a)
      (fun A B C (f : B -> C) (g : A -> B) => f \o g)
      _ _ _.
Definition Coq : category :=
  Eval hnf in Category tp coqCategoryMixin.
End Coq.

(*************************************************)
(** ** Functors                                  *)
(*************************************************)

Module Functor.

Section RawMixin.

Record mixin_of (C D : category) := Mixin {
  mx_fobj : forall a : C, D;
  mx_fmap : forall (a b : C) (f : hom a b), hom (mx_fobj a) (mx_fobj b);
  _ : forall a : C, mx_fmap (ida (a:=a)) = ida (a:=mx_fobj a);
  _ : forall (a b c : C) (f : hom b c) (g : hom a b),
        mx_fmap (comp f g) = comp (mx_fmap f) (mx_fmap g)
}.

End RawMixin.

Section ClassDef.

Variables C D : category.

Record class_of C D := Class {mixin : mixin_of C D}.

Structure type : Type := Pack {_ : class_of C D}.

Variables cT : type.
Definition class := let: Pack c := cT return class_of C D in c.
Definition clone c of phant_id class c := @Pack c.

Definition pack (m0 : mixin_of C D) :=
  fun m & phant_id m0 m => Pack (@Class C D m).

Definition fobj := mx_fobj (mixin class).
Definition fmap := mx_fmap (mixin class).

End ClassDef.

Module Exports.
Notation functor := Functor.type.
Notation FunctorMixin := Functor.Mixin.
Notation Functor C D m := (@pack C D _ m id).

Notation "[ 'functor' 'of' C D 'for' cT ]" := (@clone C D cT _ id)
  (at level 0, format "[ 'functor'  'of'  C  D  'for'  cT ]") : form_scope.
Notation "[ 'functor' 'of' C D ]" := (@clone C D _ _ id)
  (at level 0, format "[ 'functor'  'of'  C  D ]") : form_scope.

Notation fobj := Functor.fobj.
Notation fmap := Functor.fmap.

Arguments Functor.fobj [C D] cT _.
Arguments Functor.fmap [C D] cT [a b] _.

Section Laws.
Variables C D : category.
Variable F : functor C D.

Lemma fmap_id (a : C) : fmap F (ida (a:=a)) = ida.
Proof. by case: F; case; case. Qed.

Lemma fmap_assoc (a b c : C) (f : hom b c) (g : hom a b) :
  fmap F (comp f g) = comp (fmap F f) (fmap F g).
Proof. by case: F; case; case. Qed.

End Laws.

Hint Resolve fmap_id fmap_assoc.

End Exports.

End Functor.

Export Functor.Exports.

(*************************************************)
(** ** Some Functors                             *)
(*************************************************)

(** *** T -> Option T *)

Section OptionFunctor.
Notation tp := (option).
Program Definition optionFunctorMixin :=
  @Functor.Mixin Coq Coq tp
    (fun _ _ f o => if o is Some v then Some (f v)
                    else None) _ _.
Next Obligation. by extensionality x; case: x. Qed.
Next Obligation. by extensionality x; case: x. Qed.
Canonical optionFunctor : functor Coq Coq :=
  Eval hnf in Functor Coq Coq optionFunctorMixin.
End OptionFunctor.

(** *** T -> List T *)

Section ListFunctor.
Notation tp := (list).
Program Definition listFunctorMixin :=
  @Functor.Mixin Coq Coq tp (fun _ _ f l => map f l) _ _.
Next Obligation. by extensionality x; elim: x=> // ? l /= ->. Qed.
Next Obligation. by extensionality x; elim: x=> // ? l /= ->. Qed.
Canonical listFunctor : functor Coq Coq :=
  Eval hnf in Functor Coq Coq listFunctorMixin.
End ListFunctor.

(** *** hom(A,--) *)

Section HomFunctor.
Variable C : category.
Variable a : C.
Notation tp := (fun r => hom a r).
Program Definition homFunctorMixin :=
  @Functor.Mixin C Coq tp (fun _ _ f g => comp f g) _ _.
Next Obligation. by extensionality x; rewrite id_left. Qed.
Next Obligation. by extensionality x; rewrite -comp_assoc. Qed.
Canonical homFunctor : functor C Coq :=
  Eval hnf in Functor C Coq homFunctorMixin.

Lemma hom_fmap (b c : C) (f : hom b c) (g : fobj homFunctor b) :
  fmap homFunctor f g = comp f g.
Proof. by rewrite /homFunctor /= /homFunctorMixin /Functor.fmap. Qed.

End HomFunctor.

Arguments homFunctor [C] _.

Notation "a '==>' '?'" := (homFunctor a)
  (at level 50, format "a  '==>'  '?'") : form_scope.

(*************************************************)
(** ** Natural Transformations                   *)
(*************************************************)

Module Natural.

Section RawMixin.
Variables C D : category.
Variables F G : functor C D.

Record mixin_of := Mixin {
  mx_phi : forall a : C, hom (fobj F a) (fobj G a);
  _ : forall (a b : C) (f : hom a b),
        comp (mx_phi b) (fmap F f) = comp (fmap G f) (mx_phi a)
}.

End RawMixin.

Section ClassDef.
Variables C D : category.
Variables F G : functor C D.

Record class_of C D (F G : functor C D) := Class {mixin : mixin_of F G}.

Structure type : Type := Pack {_ : class_of F G}.

Variable cT : type.
Definition class := let: Pack c as cT' := cT return class_of F G in c.
Definition clone c of phant_id class c := @Pack c.

Definition pack (m0 : mixin_of F G) :=
  fun m & phant_id m0 m => Pack (@Class C D F G m).

Definition phi := mx_phi (mixin class).

End ClassDef.

Module Exports.
Coercion phi : type >-> Funclass.
Notation natural := Natural.type.
Notation NaturalMixin := Natural.Mixin.
Notation Natural F G m := (@pack _ _ F G _ m id).

Notation "[ 'natural' 'of' F G 'for' cT ]" := (@clone F G cT _ id)
  (at level 0, format "[ 'natural'  'of'  F  G  'for'  cT ]") : form_scope.
Notation "[ 'natural' 'of' F G ]" := (@clone F G _ _ id)
  (at level 0, format "[ 'natural'  'of'  F  G ]") : form_scope.
Notation "F ~~> G" := (natural F G)
  (at level 60, format "F  '~~>'  G") : form_scope.

Notation phi := Natural.phi.

Arguments Natural.phi [C D] F G [cT] _.

Section Laws.
Variables C D : category.
Variables F G : functor C D.
Variable phi : F ~~> G.

Lemma phi_natural (a b : C) (f : hom a b) :
  comp (phi b) (fmap F f) = comp (fmap G f) (phi a).
Proof. by case: phi=> [][][]. Qed.

End Laws.

Section Extensionality.
Variables C D : category.
Variables F G : functor C D.
Variable phi1 phi2 : natural F G.

Lemma phi_extensionality : (forall r, phi1 r = phi2 r) -> phi1 = phi2.
Proof.
move=> H; destruct phi1, phi2.
destruct c, c0; destruct mixin0, mixin1; f_equal; f_equal.
have Heq: mx_phi0 = mx_phi1.
{ by extensionality r; apply: (H r). }
by subst; f_equal; apply proof_irrelevance.
Qed.

End Extensionality.

Hint Resolve phi_natural.

End Exports.

End Natural.

Export Natural.Exports.

(*************************************************)
(** ** Cones                                     *)
(*************************************************)

Module Cone.

Section RawMixin.
Variables J C : category.
Variable F : functor J C.

Record mixin_of := Mixin {
  mx_cone : C;
  mx_mor : forall j : J, hom mx_cone (fobj F j);
  _ : forall (j k : J) (f : hom (fobj F j) (fobj F k)),
        comp f (mx_mor j) = mx_mor k
}.

End RawMixin.

Section ClassDef.

Variables J C : category.

Variable F : functor J C.

Record class_of (J C : category) (F : functor J C) :=
  Class {mixin : mixin_of F}.

Structure type : Type := Pack {_ : class_of F}.

Variables cT : type.
Definition class := let: Pack c := cT return class_of F in c.
Definition clone c of phant_id class c := @Pack c.

Definition pack (m0 : mixin_of F) :=
  fun m & phant_id m0 m => Pack (@Class J C F m).

Definition cone := mx_cone (mixin class).
Definition mor := mx_mor (mixin class).

End ClassDef.

Module Exports.
Coercion cone : type >-> Category.sort.
Notation cone := Cone.type.
Notation ConeMixin := Cone.Mixin.
Notation Cone J C F m := (@pack J C F _ m id).

Notation "[ 'cone' 'of' J C F 'for' cT ]" := (@clone J C F cT _ id)
  (at level 0, format "[ 'cone'  'of'  J  C  F  'for'  cT ]") : form_scope.
Notation "[ 'cone' 'of' J C F ]" := (@clone J C F _ _ id)
  (at level 0, format "[ 'cone'  'of'  J  C  F ]") : form_scope.

Notation cone_head := Cone.cone.
Notation cone_mor := Cone.mor.

Arguments Cone.cone [J C F] cT.
Arguments Cone.mor [J C F] cT j.

Section Laws.
Variables J C : category.
Variable F : functor J C.
Variable Con : cone F.

Lemma cone_commutes (j k : J) (f : hom (fobj F j) (fobj F k)) :
  comp f (cone_mor Con j) = cone_mor Con k.
Proof. by case: Con; case; case. Qed.

End Laws.

Hint Resolve cone_commutes.

End Exports.

End Cone.

Export Cone.Exports.

(*************************************************)
(** ** Limits                                    *)
(*************************************************)

Module Limit.

Section RawMixin.
Variables J C : category.
Variable F : functor J C.

Record mixin_of := Mixin {
  mx_lim : cone F;
  _ : forall Con : cone F,
        exists! f : hom Con mx_lim,
        forall j : J, comp (cone_mor mx_lim j) f = cone_mor Con j
}.

End RawMixin.

Section ClassDef.

Variables J C : category.

Variable F : functor J C.

Record class_of (J C : category) (F : functor J C) :=
  Class {mixin : mixin_of F}.

Structure type : Type := Pack {_ : class_of F}.

Variable cT : type.
Definition class := let: Pack c := cT return class_of F in c.
Definition clone c of phant_id class c := @Pack c.

Definition pack (m0 : mixin_of F) :=
  fun m & phant_id m0 m => Pack (@Class J C F m).

Definition lim := mx_lim (mixin class).

End ClassDef.

Module Exports.
Coercion lim : type >-> Cone.type.
Notation limit := Limit.type.
Notation LimitMixin := Limit.Mixin.
Notation Limit J C F m := (@pack J C F _ m id).

Notation "[ 'lim' 'of' J C F 'for' cT ]" := (@clone J C F cT _ id)
  (at level 0, format "[ 'lim'  'of'  J  C  F  'for'  cT ]") : form_scope.
Notation "[ 'lim' 'of' J C F ]" := (@clone J C F _ _ id)
  (at level 0, format "[ 'lim'  'of'  J  C  F ]") : form_scope.

Notation lim := Limit.lim.

Arguments Limit.lim [J C F] cT.

Section Laws.
Variables J C : category.
Variable F : functor J C.
Variable Lim : limit F.

Lemma limit_universal (Con : cone F) :
  exists! f : hom Con Lim,
  forall j : J, comp (cone_mor Lim j) f = cone_mor Con j.
Proof. by case: Lim; case; case. Qed.

End Laws.

Hint Resolve limit_universal.

End Exports.

End Limit.

Export Limit.Exports.

(*************************************************)
(** ** Isomorphisms                              *)
(*************************************************)

Module Iso.

Section RawMixin.

Record mixin_of (T U : Type) := Mixin {
  mx_f : T -> U;
  mx_g : U -> T;
  _ : forall t, (mx_g \o mx_f) t = t;
  _ : forall u, (mx_f \o mx_g) u = u
}.

End RawMixin.

Section ClassDef.

Variables T U : Type.

Record class_of T U := Class {mixin : mixin_of T U}.

Structure type : Type := Pack {_ : class_of T U}.

Variable cT : type.
Definition class := let: Pack c as cT' := cT return class_of T U in c.
Definition clone c of phant_id class c := @Pack c.

(* produce a natural type out of the mixin *)
(* equalize m0 and m by means of a phantom *)
Definition pack (m0 : mixin_of T U) :=
  fun m & phant_id m0 m => Pack (@Class T U m).

Definition iso_f := mx_f (mixin class).
Definition iso_g := mx_g (mixin class).

End ClassDef.

Module Exports.
Notation iso := Iso.type.
Notation IsoMixin := Iso.Mixin.
Notation Iso T U m := (@pack T U _ m id).

Notation "[ 'iso' 'of' T U 'for' cT ]" := (@clone T U cT _ id)
  (at level 0, format "[ 'iso'  'of'  T  U  'for'  cT ]") : form_scope.
Notation "[ 'iso' 'of' T U ]" := (@clone T U _ _ id)
  (at level 0, format "[ 'iso'  'of'  T  U ]") : form_scope.
Notation "T ~= U" := (iso T U)
  (at level 60, format "T  '~='  U") : form_scope.

Notation iso_f := Iso.iso_f.
Notation iso_g := Iso.iso_g.

Arguments Iso.iso_f [T U] cT t.
Arguments Iso.iso_g [T U] cT u.

Section Laws.
Variables T U : Type.
Variable iso : iso T U.

Lemma iso_gf (t : T) : (iso_g iso \o iso_f iso) t = t.
Proof. by case: iso=> [][][]. Qed.

Lemma iso_fg (u : U) : (iso_f iso \o iso_g iso) u = u.
Proof. by case: iso=> [][][]. Qed.

End Laws.

Hint Resolve iso_gf iso_fg.

End Exports.

End Iso.

Export Iso.Exports.

(*************************************************)
(** ** Yoneda                                    *)
(*************************************************)

Section Yoneda.
Variable C : category.
Variable F : functor C Coq.

Definition Y (a : C) := (a ==> ?) ~~> F.

Definition uncheck a (y : Y a) : fobj F a := y a ida.

Section check.
  Variables (a : C) (x : fobj F a).
  Definition check_phi (r : C) (f : fobj (a ==> ?) r) := fmap F f x.

  Lemma check_phi_natural (r b : C) (f : hom r b) :
    check_phi (r:=b) \o fmap (a ==> ?) f = fmap F f \o check_phi (r:=r).
  Proof. by extensionality y; rewrite /check_phi /= hom_fmap fmap_assoc. Qed.

  Definition checkNaturalMixin :=
    @Natural.Mixin C Coq (a ==> ?) F check_phi check_phi_natural.
  Definition check : Y a :=
    Eval hnf in Natural (a ==> ?) F checkNaturalMixin.
End check.

Lemma checkP a r (x : fobj F a) (f : fobj (a ==> ?) r) :
  check x _ f = fmap F f x.
Proof. by []. Qed.

Lemma uncheck_check a x : uncheck (a:=a) (check (a:=a) x) = id x.
Proof. by rewrite /uncheck /funcomp checkP fmap_id. Qed.

Lemma check_uncheck' A (y : Y A) R g : check (uncheck y) R g = y R g.
Proof.
rewrite checkP /uncheck.
suff: (comp (fmap F g) (y A)) ida = y R g => //.
rewrite -phi_natural.
suff: (y R \o fmap (A ==> ?) g) ida = y R g=> //=.
by rewrite hom_fmap id_right.
Qed.

Lemma check_uncheck A (y : Y A) : check (uncheck y) = y.
Proof.
by apply: phi_extensionality=> r; extensionality x; apply: check_uncheck'.
Qed.

End Yoneda.

(*
Section YonedaIso.
Variable C : category.
Variable F : functor C Coq.
Set Printing Universes.

(** Can't typecheck the following due to a universe inconsistency:
  Don't know that univ(Y F a) <= univ(T) in IsoMixin T U ...*)

Definition YonedaIsoMixin (a : C) :=
  @IsoMixin (Y F a) (fobj F a) (@uncheck _ F a) (@check _ F a)
            (@check_uncheck _ F a) (@uncheck_check _ F a).
Canonical YonedaIso a := @Iso (Y F a) (F a) (YonedaIsoMixin a).

End YonedaIso.
*)